diff --git a/.gitignore b/.gitignore new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,1 @@ +dist/ diff --git a/Cabal2Ebuild.hs b/Cabal2Ebuild.hs --- a/Cabal2Ebuild.hs +++ b/Cabal2Ebuild.hs @@ -48,12 +48,14 @@ E.version = display (Cabal.pkgVersion (Cabal.package pkg)), E.description = if null (Cabal.synopsis pkg) then Cabal.description pkg else Cabal.synopsis pkg, + E.long_desc = if null (Cabal.description pkg) then Cabal.synopsis pkg + else Cabal.description pkg, E.homepage = thisHomepage, E.license = Cabal.license pkg, E.my_pn = if any isUpper cabalPkgName then Just cabalPkgName else Nothing, E.features = E.features E.ebuildTemplate ++ (if hasExe then ["bin"] else []) - ++ maybe [] (const (["lib","profile","haddock"] + ++ maybe [] (const (["lib","profile","haddock","hoogle"] ++ if cabalPkgName == "hscolour" then [] else ["hscolour"]) ) (Cabal.library pkg) -- hscolour can't colour its own sources } where @@ -117,7 +119,7 @@ ,"random" ,"readline" --has ebuild, but only in the overlay ,"rts" - ,"syb" -- intentionally no ebuild. use ghc's version + -- ,"syb" -- was splitted off from ghc again ,"template-haskell" ,"unix" --has ebuild, but only in the overlay ] diff --git a/Diff.hs b/Diff.hs --- a/Diff.hs +++ b/Diff.hs @@ -23,7 +23,7 @@ import Distribution.Simple.Utils (equating) -- cabal-install -import qualified Distribution.Client.IndexUtils as Index (getAvailablePackages ) +import qualified Distribution.Client.IndexUtils as Index (getSourcePackages) import qualified Distribution.Client.Types as Cabal import Distribution.Client.Utils (mergeBy, MergeResult(..)) @@ -61,8 +61,8 @@ runDiff :: Verbosity -> FilePath -> DiffMode -> Cabal.Repo -> IO () runDiff verbosity overlayPath dm repo = do -- get package list from hackage - pkgDB <- Index.getAvailablePackages verbosity [ repo ] - let (Cabal.AvailablePackageDb hackageIndex _) = pkgDB + pkgDB <- Index.getSourcePackages verbosity [ repo ] + let (Cabal.SourcePackageDb hackageIndex _) = pkgDB -- get package list from the overlay overlay0 <- (Portage.loadLazy overlayPath) @@ -71,8 +71,8 @@ let (subHackage, subOverlay) = case dm of ShowPackages pkgs -> - (concatMap (Index.searchByNameSubstring hackageIndex) pkgs - ,concatMap (Index.searchByNameSubstring overlayIndex) pkgs) + (concatMap (concatMap snd . Index.searchByNameSubstring hackageIndex) pkgs + ,concatMap (concatMap snd . Index.searchByNameSubstring overlayIndex) pkgs) _ -> (Index.allPackages hackageIndex ,Index.allPackages overlayIndex) @@ -100,7 +100,7 @@ GT -> ">" LT -> "<" -diff :: [Cabal.AvailablePackage] +diff :: [Cabal.SourcePackage] -> [Portage.ExistingEbuild] -> DiffMode -> IO () diff --git a/DistroMap.hs b/DistroMap.hs --- a/DistroMap.hs +++ b/DistroMap.hs @@ -46,7 +46,7 @@ import Distribution.Verbosity import Distribution.Text ( display ) -import Distribution.Client.Types ( Repo, AvailablePackageDb(..), AvailablePackage(..) ) +import Distribution.Client.Types ( Repo, SourcePackageDb(..), SourcePackage(..) ) import Distribution.Simple.Utils ( info ) import qualified Data.Version as Cabal @@ -83,8 +83,8 @@ info verbosity ("overlay map: " ++ show (Map.size overlayMap)) info verbosity ("complete map: " ++ show (Map.size completeMap)) - AvailablePackageDb { packageIndex = packageIndex } <- - CabalInstall.getAvailablePackages verbosity [repo] + SourcePackageDb { packageIndex = packageIndex } <- + CabalInstall.getSourcePackages verbosity [repo] let pkgs0 = map (map packageInfoId) (CabalInstall.allPackagesByName packageIndex) hackagePkgs = [ (Cabal.pkgName (head p), map Cabal.pkgVersion p) | p <- pkgs0 ] diff --git a/Error.hs b/Error.hs --- a/Error.hs +++ b/Error.hs @@ -55,7 +55,7 @@ CabalParseFailed file reason -> "Error while parsing cabal file '"++file++"': "++reason BashNotFound -> "The 'bash' executable was not found. It is required to figure out your portage-overlay. If you don't want to install bash, use '-p path-to-overlay'" BashError str -> "Error while guessing your portage-overlay. Either set PORTDIR_OVERLAY in /etc/make.conf or use '-p path-to-overlay'.\nThe error was: \""++str++"\"" - MultipleOverlays overlays -> "You have the following overlays available: '"++unwords overlays++"'. Please choose one by using '-p path-to-overlay'" + MultipleOverlays overlays -> "You have the following overlays available: '"++unwords overlays++"'. Please choose one by using 'hackport -p path-to-overlay' " NoOverlay -> "You don't have PORTDIR_OVERLAY set in '/etc/make.conf'. Please set it or use '-p path-to-overlay'" UnknownVerbosityLevel str -> "The verbosity level '"++str++"' is invalid. Please use debug,normal or silent" InvalidServer srv -> "Invalid server address, could not parse: " ++ srv diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -102,10 +102,10 @@ let verbosity = fromFlag (listVerbosity flags) overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags) let repo = defaultRepo overlayPath - index <- fmap packageIndex (Index.getAvailablePackages verbosity [ repo ]) + index <- fmap packageIndex (Index.getSourcePackages verbosity [ repo ]) overlay <- Overlay.loadLazy overlayPath let pkgs | null extraArgs = Index.allPackages index - | otherwise = concatMap (Index.searchByNameSubstring index) extraArgs + | otherwise = concatMap (concatMap snd . Index.searchByNameSubstring index) extraArgs normalized = map (normalizeCabalPackageId . packageInfoId) pkgs let decorated = map (\p -> (Overlay.inOverlay overlay p, p)) normalized mapM_ (putStrLn . pretty) decorated diff --git a/Merge.hs b/Merge.hs --- a/Merge.hs +++ b/Merge.hs @@ -21,6 +21,7 @@ import System.Directory ( getCurrentDirectory , setCurrentDirectory , createDirectoryIfMissing + , doesFileExist ) import System.Cmd (system) import System.FilePath (()) @@ -38,7 +39,7 @@ import Network.URI -import Distribution.Client.IndexUtils ( getAvailablePackages ) +import Distribution.Client.IndexUtils ( getSourcePackages ) import Distribution.Client.HttpUtils ( downloadURI ) import qualified Distribution.Client.PackageIndex as Index import Distribution.Client.Types @@ -46,6 +47,7 @@ import qualified Portage.PackageId as Portage import qualified Portage.Version as Portage import qualified Portage.Host as Host +import qualified Portage.Metadata as Portage import qualified Portage.Overlay as Overlay import qualified Portage.Resolve as Portage @@ -92,7 +94,7 @@ -- | Given a list of available packages, and maybe a preferred version, -- return the available package with that version. Latest version is chosen -- if no preference. -resolveVersion :: [AvailablePackage] -> Maybe Cabal.Version -> Maybe AvailablePackage +resolveVersion :: [SourcePackage] -> Maybe Cabal.Version -> Maybe SourcePackage resolveVersion avails Nothing = Just $ maximumBy (comparing packageInfoId) avails resolveVersion avails (Just ver) = listToMaybe (filter match avails) where @@ -119,14 +121,14 @@ overlay <- Overlay.loadLazy overlayPath -- portage_path <- Host.portage_dir `fmap` Host.getInfo -- portage <- Overlay.loadLazy portage_path - index <- fmap packageIndex $ getAvailablePackages verbosity [ repo ] + index <- fmap packageIndex $ getSourcePackages verbosity [ repo ] -- find all packages that maches the user specified package name availablePkgs <- - case Index.searchByName index user_pname_str of - Index.None -> throwEx (PackageNotFound user_pname_str) - Index.Ambiguous pkgs -> throwEx (ArgumentError ("Ambiguous name: " ++ unwords (map show pkgs))) - Index.Unambiguous pkg -> return pkg + case map snd (Index.searchByName index user_pname_str) of + [] -> throwEx (PackageNotFound user_pname_str) + [pkg] -> return pkg + pkgs -> throwEx (ArgumentError ("Ambiguous name: " ++ unwords (map show pkgs))) -- select a single package taking into account the user specified version selectedPkg <- @@ -235,6 +237,17 @@ let edir = target cat E.name ebuild elocal = E.name ebuild ++"-"++ E.version ebuild <.> "ebuild" epath = edir elocal + emeta = "metadata.xml" + mpath = edir emeta + default_meta = Portage.makeDefaultMetadata (E.long_desc ebuild) createDirectoryIfMissing True edir - info verbosity $ "Writing " ++ elocal + notice verbosity $ "Writing " ++ elocal writeFile epath (display ebuild) + + yet_meta <- doesFileExist mpath + if (not yet_meta) -- TODO: add --force-meta-rewrite to opts + then do notice verbosity $ "Writing " ++ emeta + writeFile mpath default_meta + else do current_meta <- readFile mpath + when (current_meta /= default_meta) $ + notice verbosity $ "Default and current " ++ emeta ++ " differ." diff --git a/Portage.hs b/Portage.hs deleted file mode 100644 --- a/Portage.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Portage where - -import System.Directory -import Text.Regex -import Data.Maybe - -ebuildVersionRegex :: String -> Regex -ebuildVersionRegex name = mkRegex ("^"++name++"-(.*)\\.ebuild$") - -filterPackages :: String -> [String] -> IO [String] -filterPackages _ [] = return [] -filterPackages base (x:xs) = do - ak <- case x of - "." -> return Nothing - ".." -> return Nothing - dir -> do - exists <- doesDirectoryExist (base++dir) - return (if exists then Just dir else Nothing) - rest <- filterPackages base xs - return (maybe rest (:rest) ak) diff --git a/Portage/EBuild.hs b/Portage/EBuild.hs --- a/Portage/EBuild.hs +++ b/Portage/EBuild.hs @@ -19,6 +19,7 @@ version :: String, hackportVersion :: String, description :: String, + long_desc :: String, homepage :: String, license :: Cabal.License, slot :: String, @@ -42,6 +43,7 @@ version = "0.1", hackportVersion = getHackportVersion Paths_hackport.version, description = "", + long_desc = "", homepage = "http://hackage.haskell.org/package/${PN}", license = Cabal.UnknownLicense "xxx UNKNOWN xxx", slot = "0", diff --git a/Portage/GHCCore.hs b/Portage/GHCCore.hs --- a/Portage/GHCCore.hs +++ b/Portage/GHCCore.hs @@ -21,8 +21,6 @@ import Data.Maybe import Data.List ( nub ) -import Text.PrettyPrint.HughesPJ - defaultGHC :: (CompilerId, [PackageName]) defaultGHC = let (g,pix) = ghc6123 in (g, packageNamesFromPackageIndex pix) diff --git a/Portage/Host.hs b/Portage/Host.hs --- a/Portage/Host.hs +++ b/Portage/Host.hs @@ -4,7 +4,6 @@ ) where import Util (run_cmd) -import Data.Char (isSpace) import Data.Maybe (fromJust, isJust, catMaybes) import Control.Applicative ( (<$>) ) diff --git a/Portage/Metadata.hs b/Portage/Metadata.hs --- a/Portage/Metadata.hs +++ b/Portage/Metadata.hs @@ -1,6 +1,7 @@ module Portage.Metadata ( Metadata(..) , metadataFromFile + , makeDefaultMetadata ) where import qualified Data.ByteString as B @@ -9,8 +10,6 @@ import Text.XML.Light -import Control.Monad - data Metadata = Metadata { metadataHerds :: [String] -- , metadataMaintainers :: [String], @@ -29,3 +28,28 @@ { metadataHerds = herds } + +-- don't use Text.XML.Light as we like our own pretty printer +makeDefaultMetadata :: String -> String +makeDefaultMetadata long_description = + unlines [ "" + , "" + , "" + , "\thaskell" + , "\t" + , "\t\thaskell@gentoo.org" + , "\t" + , (init {- strip trailing newline-} + . unlines + . map (\l -> if l `elem` ["", ""] + then "\t" ++ l -- leading/trailing lines + else "\t\t" ++ l -- description itself + ) + . lines + . showElement + . unode "longdescription" + . ("\n" ++) -- prepend newline to separate form + . (++ "\n") -- append newline + ) long_description + , "" + ] diff --git a/README.rst b/README.rst --- a/README.rst +++ b/README.rst @@ -11,13 +11,35 @@ Ebuilds from Cabal packages. It also does handy functions to compare hackage, the overlay and the portage tree. +Quick start +----------- + +1. Build hackport binary by hand (or install it from haskell overlay). +2. Setup hackport database into overlay you plan to merge new ebuilds: + +:: + + $ mkdir ~/overlays + $ cd ~/overlays + $ git clone git clone git://github.com/gentoo-haskell/gentoo-haskell.git + $ cd gentoo-haskell + $ hackport update + $ ls -1 .hackport/ + 00-index.tar + 00-index.tar.gz + +3. Add your ~/overlays/gentoo-haskell to PORTDIR_OVERLAY in /etc/make.conf. + +Done! Now you can `hackport merge ` to get an ebuild merged to +your overlay! + Features -------- 'hackport update' Update the local copy of hackage's package list. You should run this every once in a while to get a more recent copy. - + 'hackport list [FILTER]' Print packages from hackage, with an optional substring matching. @@ -99,7 +121,7 @@ - the ebuilds differ, or - the overlay has a more recent version - 'hackport make-ebuild ' + 'hackport make-ebuild ' Generates standalone .ebuild file from .cabal spec and stores result in same directory. Option is useful for packages not-on-hackage and for debug purposes. diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -9,13 +9,13 @@ still are any missing. set good default values, and make sure we don't get any 'fromFlag' errors due to missing defaults for all commands -* catch baseconstraints and upgrade ghc requirement +* catch base constraints and upgrade ghc requirement (like in vty-4.0.0.1: base >= 4 leads to ghc >= 6.10) Harder ====== -* translate the dev-db/libpq dependency into virtual/postgresql-base +* translate the dev-db/libpq dependency into dev-db/postgresql-base the cabal field to describe c libs should be translated if we know the proper gentoo package name. @@ -33,3 +33,7 @@ * Merge the separate tool keyword-stat into hackport, and make it use the hackport API. See http://code.haskell.org/gentoo/keyword-stat/ + +* Pick keywords from latest available ebuild + +* hacport status --to-portage should warn about different 'ChangeLog' and 'metadata.xml' files diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Anonymous.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Anonymous.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Anonymous.hs +++ /dev/null @@ -1,311 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Reporting --- Copyright : (c) David Waern 2008 --- License : BSD-like --- --- Maintainer : david.waern@gmail.com --- Stability : experimental --- Portability : portable --- --- Anonymous build report data structure, printing and parsing --- ------------------------------------------------------------------------------ -module Distribution.Client.BuildReports.Anonymous ( - BuildReport(..), - InstallOutcome(..), - Outcome(..), - - -- * Constructing and writing reports - new, - - -- * parsing and pretty printing - parse, - parseList, - show, --- showList, - ) where - -import Distribution.Client.Types - ( ConfiguredPackage(..) ) -import qualified Distribution.Client.Types as BR - ( BuildResult, BuildFailure(..), BuildSuccess(..) - , DocsResult(..), TestsResult(..) ) -import Distribution.Client.Utils - ( mergeBy, MergeResult(..) ) -import qualified Paths_cabal_install (version) - -import Distribution.Package - ( PackageIdentifier(..), PackageName(..), Package(packageId) ) -import Distribution.PackageDescription - ( FlagName(..), FlagAssignment ) ---import Distribution.Version --- ( Version ) -import Distribution.System - ( OS, Arch ) -import Distribution.Compiler - ( CompilerId ) -import qualified Distribution.Text as Text - ( Text(disp, parse) ) -import Distribution.ParseUtils - ( FieldDescr(..), ParseResult(..), Field(..) - , simpleField, listField, ppFields, readFields - , syntaxError, locatedErrorMsg ) -import Distribution.Simple.Utils - ( comparing ) - -import qualified Distribution.Compat.ReadP as Parse - ( ReadP, pfail, munch1, skipSpaces ) -import qualified Text.PrettyPrint.HughesPJ as Disp - ( Doc, render, char, text ) -import Text.PrettyPrint.HughesPJ - ( (<+>), (<>) ) - -import Data.List - ( unfoldr, sortBy ) -import Data.Char as Char - ( isAlpha, isAlphaNum ) - -import Prelude hiding (show) - -data BuildReport - = BuildReport { - -- | The package this build report is about - package :: PackageIdentifier, - - -- | The OS and Arch the package was built on - os :: OS, - arch :: Arch, - - -- | The Haskell compiler (and hopefully version) used - compiler :: CompilerId, - - -- | The uploading client, ie cabal-install-x.y.z - client :: PackageIdentifier, - - -- | Which configurations flags we used - flagAssignment :: FlagAssignment, - - -- | Which dependent packages we were using exactly - dependencies :: [PackageIdentifier], - - -- | Did installing work ok? - installOutcome :: InstallOutcome, - - -- Which version of the Cabal library was used to compile the Setup.hs --- cabalVersion :: Version, - - -- Which build tools we were using (with versions) --- tools :: [PackageIdentifier], - - -- | Configure outcome, did configure work ok? - docsOutcome :: Outcome, - - -- | Configure outcome, did configure work ok? - testsOutcome :: Outcome - } - -data InstallOutcome - = DependencyFailed PackageIdentifier - | DownloadFailed - | UnpackFailed - | SetupFailed - | ConfigureFailed - | BuildFailed - | InstallFailed - | InstallOk - deriving Eq - -data Outcome = NotTried | Failed | Ok - deriving Eq - -new :: OS -> Arch -> CompilerId -- -> Version - -> ConfiguredPackage -> BR.BuildResult - -> BuildReport -new os' arch' comp (ConfiguredPackage pkg flags deps) result = - BuildReport { - package = packageId pkg, - os = os', - arch = arch', - compiler = comp, - client = cabalInstallID, - flagAssignment = flags, - dependencies = deps, - installOutcome = convertInstallOutcome, --- cabalVersion = undefined - docsOutcome = convertDocsOutcome, - testsOutcome = convertTestsOutcome - } - where - convertInstallOutcome = case result of - Left (BR.DependentFailed p) -> DependencyFailed p - Left (BR.DownloadFailed _) -> DownloadFailed - Left (BR.UnpackFailed _) -> UnpackFailed - Left (BR.ConfigureFailed _) -> ConfigureFailed - Left (BR.BuildFailed _) -> BuildFailed - Left (BR.InstallFailed _) -> InstallFailed - Right (BR.BuildOk _ _) -> InstallOk - convertDocsOutcome = case result of - Left _ -> NotTried - Right (BR.BuildOk BR.DocsNotTried _) -> NotTried - Right (BR.BuildOk BR.DocsFailed _) -> Failed - Right (BR.BuildOk BR.DocsOk _) -> Ok - convertTestsOutcome = case result of - Left _ -> NotTried - Right (BR.BuildOk _ BR.TestsNotTried) -> NotTried - Right (BR.BuildOk _ BR.TestsFailed) -> Failed - Right (BR.BuildOk _ BR.TestsOk) -> Ok - -cabalInstallID :: PackageIdentifier -cabalInstallID = - PackageIdentifier (PackageName "cabal-install") Paths_cabal_install.version - --- ------------------------------------------------------------ --- * External format --- ------------------------------------------------------------ - -initialBuildReport :: BuildReport -initialBuildReport = BuildReport { - package = requiredField "package", - os = requiredField "os", - arch = requiredField "arch", - compiler = requiredField "compiler", - client = requiredField "client", - flagAssignment = [], - dependencies = [], - installOutcome = requiredField "install-outcome", --- cabalVersion = Nothing, --- tools = [], - docsOutcome = NotTried, - testsOutcome = NotTried - } - where - requiredField fname = error ("required field: " ++ fname) - --- ----------------------------------------------------------------------------- --- Parsing - -parse :: String -> Either String BuildReport -parse s = case parseFields s of - ParseFailed perror -> Left msg where (_, msg) = locatedErrorMsg perror - ParseOk _ report -> Right report - ---FIXME: this does not allow for optional or repeated fields -parseFields :: String -> ParseResult BuildReport -parseFields input = do - fields <- mapM extractField =<< readFields input - let merged = mergeBy (\desc (_,name,_) -> compare (fieldName desc) name) - sortedFieldDescrs - (sortBy (comparing (\(_,name,_) -> name)) fields) - checkMerged initialBuildReport merged - - where - extractField :: Field -> ParseResult (Int, String, String) - extractField (F line name value) = return (line, name, value) - extractField (Section line _ _ _) = syntaxError line "Unrecognized stanza" - extractField (IfBlock line _ _ _) = syntaxError line "Unrecognized stanza" - - checkMerged report [] = return report - checkMerged report (merged:remaining) = case merged of - InBoth fieldDescr (line, _name, value) -> do - report' <- fieldSet fieldDescr line value report - checkMerged report' remaining - OnlyInRight (line, name, _) -> - syntaxError line ("Unrecognized field " ++ name) - OnlyInLeft fieldDescr -> - fail ("Missing field " ++ fieldName fieldDescr) - -parseList :: String -> [BuildReport] -parseList str = - [ report | Right report <- map parse (split str) ] - - where - split :: String -> [String] - split = filter (not . null) . unfoldr chunk . lines - chunk [] = Nothing - chunk ls = case break null ls of - (r, rs) -> Just (unlines r, dropWhile null rs) - --- ----------------------------------------------------------------------------- --- Pretty-printing - -show :: BuildReport -> String -show = Disp.render . ppFields fieldDescrs - --- ----------------------------------------------------------------------------- --- Description of the fields, for parsing/printing - -fieldDescrs :: [FieldDescr BuildReport] -fieldDescrs = - [ simpleField "package" Text.disp Text.parse - package (\v r -> r { package = v }) - , simpleField "os" Text.disp Text.parse - os (\v r -> r { os = v }) - , simpleField "arch" Text.disp Text.parse - arch (\v r -> r { arch = v }) - , simpleField "compiler" Text.disp Text.parse - compiler (\v r -> r { compiler = v }) - , simpleField "client" Text.disp Text.parse - client (\v r -> r { client = v }) - , listField "flags" dispFlag parseFlag - flagAssignment (\v r -> r { flagAssignment = v }) - , listField "dependencies" Text.disp Text.parse - dependencies (\v r -> r { dependencies = v }) - , simpleField "install-outcome" Text.disp Text.parse - installOutcome (\v r -> r { installOutcome = v }) - , simpleField "docs-outcome" Text.disp Text.parse - docsOutcome (\v r -> r { docsOutcome = v }) - , simpleField "tests-outcome" Text.disp Text.parse - testsOutcome (\v r -> r { testsOutcome = v }) - ] - -sortedFieldDescrs :: [FieldDescr BuildReport] -sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs - -dispFlag :: (FlagName, Bool) -> Disp.Doc -dispFlag (FlagName name, True) = Disp.text name -dispFlag (FlagName name, False) = Disp.char '-' <> Disp.text name - -parseFlag :: Parse.ReadP r (FlagName, Bool) -parseFlag = do - name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') - case name of - ('-':flag) -> return (FlagName flag, False) - flag -> return (FlagName flag, True) - -instance Text.Text InstallOutcome where - disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid - disp DownloadFailed = Disp.text "DownloadFailed" - disp UnpackFailed = Disp.text "UnpackFailed" - disp SetupFailed = Disp.text "SetupFailed" - disp ConfigureFailed = Disp.text "ConfigureFailed" - disp BuildFailed = Disp.text "BuildFailed" - disp InstallFailed = Disp.text "InstallFailed" - disp InstallOk = Disp.text "InstallOk" - - parse = do - name <- Parse.munch1 Char.isAlphaNum - case name of - "DependencyFailed" -> do Parse.skipSpaces - pkgid <- Text.parse - return (DependencyFailed pkgid) - "DownloadFailed" -> return DownloadFailed - "UnpackFailed" -> return UnpackFailed - "SetupFailed" -> return SetupFailed - "ConfigureFailed" -> return ConfigureFailed - "BuildFailed" -> return BuildFailed - "InstallFailed" -> return InstallFailed - "InstallOk" -> return InstallOk - _ -> Parse.pfail - -instance Text.Text Outcome where - disp NotTried = Disp.text "NotTried" - disp Failed = Disp.text "Failed" - disp Ok = Disp.text "Ok" - parse = do - name <- Parse.munch1 Char.isAlpha - case name of - "NotTried" -> return NotTried - "Failed" -> return Failed - "Ok" -> return Ok - _ -> Parse.pfail diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Storage.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Storage.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Storage.hs +++ /dev/null @@ -1,129 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Reporting --- Copyright : (c) David Waern 2008 --- License : BSD-like --- --- Maintainer : david.waern@gmail.com --- Stability : experimental --- Portability : portable --- --- Anonymous build report data structure, printing and parsing --- ------------------------------------------------------------------------------ -module Distribution.Client.BuildReports.Storage ( - - -- * Storing and retrieving build reports - storeAnonymous, - storeLocal, --- retrieve, - - -- * 'InstallPlan' support - fromInstallPlan, - ) where - -import qualified Distribution.Client.BuildReports.Anonymous as BuildReport -import Distribution.Client.BuildReports.Anonymous (BuildReport) - -import Distribution.Client.Types - ( ConfiguredPackage(..), AvailablePackage(..) - , AvailablePackageSource(..), Repo(..), RemoteRepo(..) ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan - ( InstallPlan ) - -import Distribution.Simple.InstallDirs - ( PathTemplate, fromPathTemplate - , initialPathTemplateEnv, substPathTemplate ) -import Distribution.System - ( Platform(Platform) ) -import Distribution.Compiler - ( CompilerId ) -import Distribution.Simple.Utils - ( comparing, equating ) - -import Data.List - ( groupBy, sortBy ) -import Data.Maybe - ( catMaybes ) -import System.FilePath - ( (), takeDirectory ) -import System.Directory - ( createDirectoryIfMissing ) - -storeAnonymous :: [(BuildReport, Repo)] -> IO () -storeAnonymous reports = sequence_ - [ appendFile file (concatMap format reports') - | (repo, reports') <- separate reports - , let file = repoLocalDir repo "build-reports.log" ] - --TODO: make this concurrency safe, either lock the report file or make sure - -- the writes for each report are atomic (under 4k and flush at boundaries) - - where - format r = '\n' : BuildReport.show r ++ "\n" - separate :: [(BuildReport, Repo)] - -> [(Repo, [BuildReport])] - separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ])) - . map concat - . groupBy (equating (repoName . head)) - . sortBy (comparing (repoName . head)) - . groupBy (equating repoName) - . onlyRemote - repoName (_,_,rrepo) = remoteRepoName rrepo - - onlyRemote :: [(BuildReport, Repo)] -> [(BuildReport, Repo, RemoteRepo)] - onlyRemote rs = - [ (report, repo, remoteRepo) - | (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ] - -storeLocal :: [PathTemplate] -> [(BuildReport, Repo)] -> IO () -storeLocal templates reports = sequence_ - [ do createDirectoryIfMissing True (takeDirectory file) - appendFile file output - --TODO: make this concurrency safe, either lock the report file or make - -- sure the writes for each report are atomic - | (file, reports') <- groupByFileName - [ (reportFileName template report, report) - | template <- templates - , (report, _repo) <- reports ] - , let output = concatMap format reports' - ] - where - format r = '\n' : BuildReport.show r ++ "\n" - - reportFileName template report = - fromPathTemplate (substPathTemplate env template) - where env = initialPathTemplateEnv - (BuildReport.package report) - (BuildReport.compiler report) - - groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp)) - . groupBy (equating fst) - . sortBy (comparing fst) - --- ------------------------------------------------------------ --- * InstallPlan support --- ------------------------------------------------------------ - -fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)] -fromInstallPlan plan = catMaybes - . map (fromPlanPackage platform comp) - . InstallPlan.toList - $ plan - where platform = InstallPlan.planPlatform plan - comp = InstallPlan.planCompiler plan - -fromPlanPackage :: Platform -> CompilerId - -> InstallPlan.PlanPackage - -> Maybe (BuildReport, Repo) -fromPlanPackage (Platform arch os) comp planPackage = case planPackage of - - InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage { - packageSource = RepoTarballPackage repo }) _ _) result - -> Just $ (BuildReport.new os arch comp pkg (Right result), repo) - - InstallPlan.Failed pkg@(ConfiguredPackage (AvailablePackage { - packageSource = RepoTarballPackage repo }) _ _) result - -> Just $ (BuildReport.new os arch comp pkg (Left result), repo) - - _ -> Nothing diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Types.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Types.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Types.hs +++ /dev/null @@ -1,44 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.BuildReports.Types --- Copyright : (c) Duncan Coutts 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Types related to build reporting --- ------------------------------------------------------------------------------ -module Distribution.Client.BuildReports.Types ( - ReportLevel(..), - ) where - -import qualified Distribution.Text as Text - ( Text(..) ) - -import qualified Distribution.Compat.ReadP as Parse - ( pfail, munch1 ) -import qualified Text.PrettyPrint.HughesPJ as Disp - ( text ) - -import Data.Char as Char - ( isAlpha, toLower ) - -data ReportLevel = NoReports | AnonymousReports | DetailedReports - deriving (Eq, Ord, Show) - -instance Text.Text ReportLevel where - disp NoReports = Disp.text "none" - disp AnonymousReports = Disp.text "anonymous" - disp DetailedReports = Disp.text "detailed" - parse = do - name <- Parse.munch1 Char.isAlpha - case lowercase name of - "none" -> return NoReports - "anonymous" -> return AnonymousReports - "detailed" -> return DetailedReports - _ -> Parse.pfail - -lowercase :: String -> String -lowercase = map Char.toLower diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Upload.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Upload.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Upload.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE PatternGuards #-} --- This is a quick hack for uploading build reports to Hackage. - -module Distribution.Client.BuildReports.Upload - ( BuildLog - , BuildReportId - , uploadReports - , postBuildReport - , putBuildLog - ) where - -import Network.Browser - ( BrowserAction, request, setAllowRedirects ) -import Network.HTTP - ( Header(..), HeaderName(..) - , Request(..), RequestMethod(..), Response(..) ) -import Network.TCP (HandleStream) -import Network.URI (URI, uriPath, parseRelativeReference, relativeTo) - -import Control.Monad - ( forM_ ) -import System.FilePath.Posix - ( () ) -import qualified Distribution.Client.BuildReports.Anonymous as BuildReport -import Distribution.Client.BuildReports.Anonymous (BuildReport) - -type BuildReportId = URI -type BuildLog = String - -uploadReports :: URI -> [(BuildReport, Maybe BuildLog)] - -> BrowserAction (HandleStream BuildLog) () -uploadReports uri reports - = forM_ reports $ \(report, mbBuildLog) -> - do buildId <- postBuildReport uri report - case mbBuildLog of - Just buildLog -> putBuildLog buildId buildLog - Nothing -> return () - -postBuildReport :: URI -> BuildReport - -> BrowserAction (HandleStream BuildLog) BuildReportId -postBuildReport uri buildReport = do - setAllowRedirects False - (_, response) <- request Request { - rqURI = uri { uriPath = "/buildreports" }, - rqMethod = POST, - rqHeaders = [Header HdrContentType ("text/plain"), - Header HdrContentLength (show (length body)), - Header HdrAccept ("text/plain")], - rqBody = body - } - case rspCode response of - (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location - relativeTo rel uri - | Header HdrLocation location <- rspHeaders response ] - -> return $ buildId - _ -> error "Unrecognised response from server." - where body = BuildReport.show buildReport - -putBuildLog :: BuildReportId -> BuildLog - -> BrowserAction (HandleStream BuildLog) () -putBuildLog reportId buildLog = do - --FIXME: do something if the request fails - (_, response) <- request Request { - rqURI = reportId{uriPath = uriPath reportId "buildlog"}, - rqMethod = PUT, - rqHeaders = [Header HdrContentType ("text/plain"), - Header HdrContentLength (show (length buildLog)), - Header HdrAccept ("text/plain")], - rqBody = buildLog - } - return () diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Check.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Check.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Check.hs +++ /dev/null @@ -1,85 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Check --- Copyright : (c) Lennart Kolmodin 2008 --- License : BSD-like --- --- Maintainer : kolmodin@haskell.org --- Stability : provisional --- Portability : portable --- --- Check a package for common mistakes --- ------------------------------------------------------------------------------ -module Distribution.Client.Check ( - check - ) where - -import Control.Monad ( when, unless ) - -import Distribution.PackageDescription.Parse - ( readPackageDescription ) -import Distribution.PackageDescription.Check -import Distribution.PackageDescription.Configuration - ( flattenPackageDescription ) -import Distribution.Verbosity - ( Verbosity ) -import Distribution.Simple.Utils - ( defaultPackageDesc, toUTF8, wrapText ) - -check :: Verbosity -> IO Bool -check verbosity = do - pdfile <- defaultPackageDesc verbosity - ppd <- readPackageDescription verbosity pdfile - -- flatten the generic package description into a regular package - -- description - -- TODO: this may give more warnings than it should give; - -- consider two branches of a condition, one saying - -- ghc-options: -Wall - -- and the other - -- ghc-options: -Werror - -- joined into - -- ghc-options: -Wall -Werror - -- checkPackages will yield a warning on the last line, but it - -- would not on each individual branch. - -- Hovever, this is the same way hackage does it, so we will yield - -- the exact same errors as it will. - let pkg_desc = flattenPackageDescription ppd - ioChecks <- checkPackageFiles pkg_desc "." - let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc) - buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ] - buildWarning = [ x | x@PackageBuildWarning {} <- packageChecks ] - distSuspicious = [ x | x@PackageDistSuspicious {} <- packageChecks ] - distInexusable = [ x | x@PackageDistInexcusable {} <- packageChecks ] - - unless (null buildImpossible) $ do - putStrLn "The package will not build sanely due to these errors:" - printCheckMessages buildImpossible - - unless (null buildWarning) $ do - putStrLn "The following warnings are likely affect your build negatively:" - printCheckMessages buildWarning - - unless (null distSuspicious) $ do - putStrLn "These warnings may cause trouble when distributing the package:" - printCheckMessages distSuspicious - - unless (null distInexusable) $ do - putStrLn "The following errors will cause portability problems on other environments:" - printCheckMessages distInexusable - - let isDistError (PackageDistSuspicious {}) = False - isDistError _ = True - errors = filter isDistError packageChecks - - unless (null errors) $ do - putStrLn "Hackage would reject this package." - - when (null packageChecks) $ do - putStrLn "No errors or warnings could be found in the package." - - return (null packageChecks) - - where - printCheckMessages = mapM_ (putStrLn . format . explanation) - format = toUTF8 . wrapText . ("* "++) diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Config.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Config.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Config.hs +++ /dev/null @@ -1,519 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Config --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- Utilities for handling saved state such as known packages, known servers and downloaded packages. ------------------------------------------------------------------------------ -module Distribution.Client.Config ( - SavedConfig(..), - loadConfig, - - showConfig, - showConfigWithComments, - parseConfig, - - defaultCabalDir, - defaultConfigFile, - defaultCacheDir, - defaultLogsDir, - ) where - - -import Distribution.Client.Types - ( RemoteRepo(..), Username(..), Password(..) ) -import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) -import Distribution.Client.Setup - ( GlobalFlags(..), globalCommand - , ConfigExFlags(..), configureExOptions, defaultConfigExFlags - , InstallFlags(..), installOptions, defaultInstallFlags - , UploadFlags(..), uploadCommand - , showRepo, parseRepo ) - -import Distribution.Simple.Setup - ( ConfigFlags(..), configureOptions, defaultConfigFlags - , installDirsOptions - , Flag, toFlag, flagToMaybe, fromFlagOrDefault ) -import Distribution.Simple.InstallDirs - ( InstallDirs(..), defaultInstallDirs - , PathTemplate, toPathTemplate ) -import Distribution.ParseUtils - ( FieldDescr(..), liftField - , ParseResult(..), locatedErrorMsg, showPWarning - , readFields, warning, lineNo - , simpleField, listField, parseFilePathQ, parseTokenQ ) -import qualified Distribution.ParseUtils as ParseUtils - ( Field(..) ) -import qualified Distribution.Text as Text - ( Text(..) ) -import Distribution.Simple.Command - ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..) - , viewAsFieldDescr ) -import Distribution.Simple.Program - ( defaultProgramConfiguration ) -import Distribution.Simple.Utils - ( notice, warn, lowercase ) -import Distribution.Compiler - ( CompilerFlavor(..), defaultCompilerFlavor ) -import Distribution.Verbosity - ( Verbosity, normal ) - -import Data.List - ( partition, find ) -import Data.Maybe - ( fromMaybe ) -import Data.Monoid - ( Monoid(..) ) -import Control.Monad - ( when, foldM, liftM ) -import qualified Data.Map as Map -import qualified Distribution.Compat.ReadP as Parse - ( option ) -import qualified Text.PrettyPrint.HughesPJ as Disp - ( Doc, render, text, colon, vcat, empty, isEmpty, nest ) -import Text.PrettyPrint.HughesPJ - ( (<>), (<+>), ($$), ($+$) ) -import System.Directory - ( createDirectoryIfMissing, getAppUserDataDirectory ) -import Network.URI - ( URI(..), URIAuth(..) ) -import System.FilePath - ( (), takeDirectory ) -import System.Environment - ( getEnvironment ) -import System.IO.Error - ( isDoesNotExistError ) - --- --- * Configuration saved in the config file --- - -data SavedConfig = SavedConfig { - savedGlobalFlags :: GlobalFlags, - savedInstallFlags :: InstallFlags, - savedConfigureFlags :: ConfigFlags, - savedConfigureExFlags :: ConfigExFlags, - savedUserInstallDirs :: InstallDirs (Flag PathTemplate), - savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate), - savedUploadFlags :: UploadFlags - } - -instance Monoid SavedConfig where - mempty = SavedConfig { - savedGlobalFlags = mempty, - savedInstallFlags = mempty, - savedConfigureFlags = mempty, - savedConfigureExFlags = mempty, - savedUserInstallDirs = mempty, - savedGlobalInstallDirs = mempty, - savedUploadFlags = mempty - } - mappend a b = SavedConfig { - savedGlobalFlags = combine savedGlobalFlags, - savedInstallFlags = combine savedInstallFlags, - savedConfigureFlags = combine savedConfigureFlags, - savedConfigureExFlags = combine savedConfigureExFlags, - savedUserInstallDirs = combine savedUserInstallDirs, - savedGlobalInstallDirs = combine savedGlobalInstallDirs, - savedUploadFlags = combine savedUploadFlags - } - where combine field = field a `mappend` field b - -updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig -updateInstallDirs userInstallFlag - savedConfig@SavedConfig { - savedConfigureFlags = configureFlags, - savedUserInstallDirs = userInstallDirs, - savedGlobalInstallDirs = globalInstallDirs - } = - savedConfig { - savedConfigureFlags = configureFlags { - configInstallDirs = installDirs - } - } - where - installDirs | userInstall = userInstallDirs - | otherwise = globalInstallDirs - userInstall = fromFlagOrDefault defaultUserInstall $ - configUserInstall configureFlags `mappend` userInstallFlag - --- --- * Default config --- - --- | These are the absolute basic defaults. The fields that must be --- initialised. When we load the config from the file we layer the loaded --- values over these ones, so any missing fields in the file take their values --- from here. --- -baseSavedConfig :: IO SavedConfig -baseSavedConfig = do - userPrefix <- defaultCabalDir - logsDir <- defaultLogsDir - worldFile <- defaultWorldFile - return mempty { - savedConfigureFlags = mempty { - configHcFlavor = toFlag defaultCompiler, - configUserInstall = toFlag defaultUserInstall, - configVerbosity = toFlag normal - }, - savedUserInstallDirs = mempty { - prefix = toFlag (toPathTemplate userPrefix) - }, - savedGlobalFlags = mempty { - globalLogsDir = toFlag logsDir, - globalWorldFile = toFlag worldFile - } - } - --- | This is the initial configuration that we write out to to the config file --- if the file does not exist (or the config we use if the file cannot be read --- for some other reason). When the config gets loaded it gets layered on top --- of 'baseSavedConfig' so we do not need to include it into the initial --- values we save into the config file. --- -initialSavedConfig :: IO SavedConfig -initialSavedConfig = do - cacheDir <- defaultCacheDir - logsDir <- defaultLogsDir - worldFile <- defaultWorldFile - return mempty { - savedGlobalFlags = mempty { - globalCacheDir = toFlag cacheDir, - globalRemoteRepos = [defaultRemoteRepo], - globalWorldFile = toFlag worldFile - }, - savedInstallFlags = mempty { - installSummaryFile = [toPathTemplate (logsDir "build.log")], - installBuildReports= toFlag AnonymousReports - } - } - ---TODO: misleading, there's no way to override this default --- either make it possible or rename to simply getCabalDir. -defaultCabalDir :: IO FilePath -defaultCabalDir = getAppUserDataDirectory "cabal" - -defaultConfigFile :: IO FilePath -defaultConfigFile = do - dir <- defaultCabalDir - return $ dir "config" - -defaultCacheDir :: IO FilePath -defaultCacheDir = do - dir <- defaultCabalDir - return $ dir "packages" - -defaultLogsDir :: IO FilePath -defaultLogsDir = do - dir <- defaultCabalDir - return $ dir "logs" - --- | Default position of the world file -defaultWorldFile :: IO FilePath -defaultWorldFile = do - dir <- defaultCabalDir - return $ dir "world" - -defaultCompiler :: CompilerFlavor -defaultCompiler = fromMaybe GHC defaultCompilerFlavor - -defaultUserInstall :: Bool -defaultUserInstall = True --- We do per-user installs by default on all platforms. We used to default to --- global installs on Windows but that no longer works on Windows Vista or 7. - -defaultRemoteRepo :: RemoteRepo -defaultRemoteRepo = RemoteRepo name uri - where - name = "hackage.haskell.org" - uri = URI "http:" (Just (URIAuth "" name "")) "/packages/archive" "" "" - --- --- * Config file reading --- - -loadConfig :: Verbosity -> Flag FilePath -> Flag Bool -> IO SavedConfig -loadConfig verbosity configFileFlag userInstallFlag = addBaseConf $ do - let sources = [ - ("commandline option", return . flagToMaybe $ configFileFlag), - ("env var CABAL_CONFIG", lookup "CABAL_CONFIG" `liftM` getEnvironment), - ("default config file", Just `liftM` defaultConfigFile) ] - - getSource [] = error "no config file path candidate found." - getSource ((msg,action): xs) = - action >>= maybe (getSource xs) (return . (,) msg) - - (source, configFile) <- getSource sources - minp <- readConfigFile mempty configFile - case minp of - Nothing -> do - notice verbosity $ "Config file path source is " ++ source ++ "." - notice verbosity $ "Config file " ++ configFile ++ " not found." - notice verbosity $ "Writing default configuration to " ++ configFile - commentConf <- commentSavedConfig - initialConf <- initialSavedConfig - writeConfigFile configFile commentConf initialConf - return initialConf - Just (ParseOk ws conf) -> do - when (not $ null ws) $ warn verbosity $ - unlines (map (showPWarning configFile) ws) - return conf - Just (ParseFailed err) -> do - let (line, msg) = locatedErrorMsg err - warn verbosity $ - "Error parsing config file " ++ configFile - ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg - warn verbosity $ "Using default configuration." - initialSavedConfig - - where - addBaseConf body = do - base <- baseSavedConfig - extra <- body - return (updateInstallDirs userInstallFlag (base `mappend` extra)) - -readConfigFile :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig)) -readConfigFile initial file = handleNotExists $ - fmap (Just . parseConfig initial) (readFile file) - - where - handleNotExists action = catch action $ \ioe -> - if isDoesNotExistError ioe - then return Nothing - else ioError ioe - -writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO () -writeConfigFile file comments vals = do - createDirectoryIfMissing True (takeDirectory file) - writeFile file $ explanation ++ showConfigWithComments comments vals ++ "\n" - where - explanation = unlines - ["-- This is the configuration file for the 'cabal' command line tool." - ,"" - ,"-- The available configuration options are listed below." - ,"-- Some of them have default values listed." - ,"" - ,"-- Lines (like this one) beginning with '--' are comments." - ,"-- Be careful with spaces and indentation because they are" - ,"-- used to indicate layout for nested sections." - ,"","" - ] - --- | These are the default values that get used in Cabal if a no value is --- given. We use these here to include in comments when we write out the --- initial config file so that the user can see what default value they are --- overriding. --- -commentSavedConfig :: IO SavedConfig -commentSavedConfig = do - userInstallDirs <- defaultInstallDirs defaultCompiler True True - globalInstallDirs <- defaultInstallDirs defaultCompiler False True - return SavedConfig { - savedGlobalFlags = commandDefaultFlags globalCommand, - savedInstallFlags = defaultInstallFlags, - savedConfigureExFlags = defaultConfigExFlags, - savedConfigureFlags = (defaultConfigFlags defaultProgramConfiguration) { - configUserInstall = toFlag defaultUserInstall - }, - savedUserInstallDirs = fmap toFlag userInstallDirs, - savedGlobalInstallDirs = fmap toFlag globalInstallDirs, - savedUploadFlags = commandDefaultFlags uploadCommand - } - --- | All config file fields. --- -configFieldDescriptions :: [FieldDescr SavedConfig] -configFieldDescriptions = - - toSavedConfig liftGlobalFlag - (commandOptions globalCommand ParseArgs) - ["version", "numeric-version", "config-file"] [] - - ++ toSavedConfig liftConfigFlag - (configureOptions ParseArgs) - (["builddir", "configure-option"] ++ map fieldName installDirsFields) - - --FIXME: this is only here because viewAsFieldDescr gives us a parser - -- that only recognises 'ghc' etc, the case-sensitive flag names, not - -- what the normal case-insensitive parser gives us. - [simpleField "compiler" - (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse) - configHcFlavor (\v flags -> flags { configHcFlavor = v }) - ] - - ++ toSavedConfig liftConfigExFlag - (configureExOptions ParseArgs) - [] [] - - ++ toSavedConfig liftInstallFlag - (installOptions ParseArgs) - ["dry-run", "reinstall", "only"] [] - - ++ toSavedConfig liftUploadFlag - (commandOptions uploadCommand ParseArgs) - ["verbose", "check"] [] - - where - toSavedConfig lift options exclusions replacements = - [ lift (fromMaybe field replacement) - | opt <- options - , let field = viewAsFieldDescr opt - name = fieldName field - replacement = find ((== name) . fieldName) replacements - , name `notElem` exclusions ] - optional = Parse.option mempty . fmap toFlag - --- TODO: next step, make the deprecated fields elicit a warning. --- -deprecatedFieldDescriptions :: [FieldDescr SavedConfig] -deprecatedFieldDescriptions = - [ liftGlobalFlag $ - listField "repos" - (Disp.text . showRepo) parseRepo - globalRemoteRepos (\rs cfg -> cfg { globalRemoteRepos = rs }) - , liftGlobalFlag $ - simpleField "cachedir" - (Disp.text . fromFlagOrDefault "") (optional parseFilePathQ) - globalCacheDir (\d cfg -> cfg { globalCacheDir = d }) - , liftUploadFlag $ - simpleField "hackage-username" - (Disp.text . fromFlagOrDefault "" . fmap unUsername) - (optional (fmap Username parseTokenQ)) - uploadUsername (\d cfg -> cfg { uploadUsername = d }) - , liftUploadFlag $ - simpleField "hackage-password" - (Disp.text . fromFlagOrDefault "" . fmap unPassword) - (optional (fmap Password parseTokenQ)) - uploadPassword (\d cfg -> cfg { uploadPassword = d }) - ] - ++ map (modifyFieldName ("user-"++) . liftUserInstallDirs) installDirsFields - ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) installDirsFields - where - optional = Parse.option mempty . fmap toFlag - modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a - modifyFieldName f d = d { fieldName = f (fieldName d) } - -liftUserInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) - -> FieldDescr SavedConfig -liftUserInstallDirs = liftField - savedUserInstallDirs (\flags conf -> conf { savedUserInstallDirs = flags }) - -liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) - -> FieldDescr SavedConfig -liftGlobalInstallDirs = liftField - savedGlobalInstallDirs (\flags conf -> conf { savedGlobalInstallDirs = flags }) - -liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig -liftGlobalFlag = liftField - savedGlobalFlags (\flags conf -> conf { savedGlobalFlags = flags }) - -liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig -liftConfigFlag = liftField - savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags }) - -liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig -liftConfigExFlag = liftField - savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = flags }) - -liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig -liftInstallFlag = liftField - savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags }) - -liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig -liftUploadFlag = liftField - savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags }) - -parseConfig :: SavedConfig -> String -> ParseResult SavedConfig -parseConfig initial = \str -> do - fields <- readFields str - let (knownSections, others) = partition isKnownSection fields - config <- parse others - let user0 = savedUserInstallDirs config - global0 = savedGlobalInstallDirs config - (user, global) <- foldM parseSections (user0, global0) knownSections - return config { - savedUserInstallDirs = user, - savedGlobalInstallDirs = global - } - - where - isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True - isKnownSection _ = False - - parse = parseFields (configFieldDescriptions - ++ deprecatedFieldDescriptions) initial - - parseSections accum@(u,g) (ParseUtils.Section _ "install-dirs" name fs) - | name' == "user" = do u' <- parseFields installDirsFields u fs - return (u', g) - | name' == "global" = do g' <- parseFields installDirsFields g fs - return (u, g') - | otherwise = do - warning "The install-paths section should be for 'user' or 'global'" - return accum - where name' = lowercase name - parseSections accum f = do - warning $ "Unrecognized stanza on line " ++ show (lineNo f) - return accum - -showConfig :: SavedConfig -> String -showConfig = showConfigWithComments mempty - -showConfigWithComments :: SavedConfig -> SavedConfig -> String -showConfigWithComments comment vals = Disp.render $ - ppFields configFieldDescriptions comment vals - $+$ Disp.text "" - $+$ installDirsSection "user" savedUserInstallDirs - $+$ Disp.text "" - $+$ installDirsSection "global" savedGlobalInstallDirs - where - installDirsSection name field = - ppSection "install-dirs" name installDirsFields - (field comment) (field vals) - ------------------------- --- * Parsing utils --- - ---FIXME: replace this with something better in Cabal-1.5 -parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a -parseFields fields initial = foldM setField initial - where - fieldMap = Map.fromList - [ (name, f) | f@(FieldDescr name _ _) <- fields ] - setField accum (ParseUtils.F line name value) = case Map.lookup name fieldMap of - Just (FieldDescr _ _ set) -> set line value accum - Nothing -> do - warning $ "Unrecognized field " ++ name ++ " on line " ++ show line - return accum - setField accum f = do - warning $ "Unrecognized stanza on line " ++ show (lineNo f) - return accum - --- | This is a customised version of the function from Cabal that also prints --- default values for empty fields as comments. --- -ppFields :: [FieldDescr a] -> a -> a -> Disp.Doc -ppFields fields def cur = Disp.vcat [ ppField name (getter def) (getter cur) - | FieldDescr name getter _ <- fields] - -ppField :: String -> Disp.Doc -> Disp.Doc -> Disp.Doc -ppField name def cur - | Disp.isEmpty cur = Disp.text "--" <+> Disp.text name <> Disp.colon <+> def - | otherwise = Disp.text name <> Disp.colon <+> cur - -ppSection :: String -> String -> [FieldDescr a] -> a -> a -> Disp.Doc -ppSection name arg fields def cur = - Disp.text name <+> Disp.text arg - $$ Disp.nest 2 (ppFields fields def cur) - -installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] -installDirsFields = map viewAsFieldDescr installDirsOptions - diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Configure.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Configure.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Configure.hs +++ /dev/null @@ -1,205 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Configure --- Copyright : (c) David Himmelstrup 2005, --- Duncan Coutts 2005 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- High level interface to configuring a package. ------------------------------------------------------------------------------ -module Distribution.Client.Configure ( - configure, - ) where - -import Data.Monoid - ( Monoid(mempty) ) -import qualified Data.Map as Map - -import Distribution.Client.Dependency - ( resolveDependenciesWithProgress - , PackageConstraint(..) - , PackagesPreference(..), PackagesPreferenceDefault(..) - , PackagePreference(..) - , Progress(..), foldProgress, ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan (InstallPlan) -import Distribution.Client.IndexUtils as IndexUtils - ( getAvailablePackages, getInstalledPackages ) -import Distribution.Client.Setup - ( ConfigExFlags(..), configureCommand, filterConfigureFlags ) -import Distribution.Client.Types as Available - ( AvailablePackage(..), AvailablePackageSource(..), Repo(..) - , AvailablePackageDb(..), ConfiguredPackage(..), InstalledPackage ) -import Distribution.Client.SetupWrapper - ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) - -import Distribution.Simple.Compiler - ( CompilerId(..), Compiler(compilerId) - , PackageDB(..), PackageDBStack ) -import Distribution.Simple.Program (ProgramConfiguration ) -import Distribution.Simple.Setup - ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault ) -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Client.PackageIndex (PackageIndex) -import Distribution.Simple.Utils - ( defaultPackageDesc ) -import Distribution.Package - ( PackageName, packageName, packageVersion - , Package(..), Dependency(..), thisPackageVersion ) -import Distribution.PackageDescription.Parse - ( readPackageDescription ) -import Distribution.PackageDescription.Configuration - ( finalizePackageDescription ) -import Distribution.Version - ( VersionRange, anyVersion, thisVersion ) -import Distribution.Simple.Utils as Utils - ( notice, info, die ) -import Distribution.System - ( Platform, buildPlatform ) -import Distribution.Verbosity as Verbosity - ( Verbosity ) - --- | Configure the package found in the local directory -configure :: Verbosity - -> PackageDBStack - -> [Repo] - -> Compiler - -> ProgramConfiguration - -> ConfigFlags - -> ConfigExFlags - -> [String] - -> IO () -configure verbosity packageDBs repos comp conf - configFlags configExFlags extraArgs = do - - installed <- getInstalledPackages verbosity comp packageDBs conf - available <- getAvailablePackages verbosity repos - - progress <- planLocalPackage verbosity comp configFlags configExFlags - installed available - - notice verbosity "Resolving dependencies..." - maybePlan <- foldProgress (\message rest -> info verbosity message >> rest) - (return . Left) (return . Right) progress - case maybePlan of - Left message -> do - info verbosity message - setupWrapper verbosity (setupScriptOptions installed) Nothing - configureCommand (const configFlags) extraArgs - - Right installPlan -> case InstallPlan.ready installPlan of - [pkg@(ConfiguredPackage (AvailablePackage _ _ (LocalUnpackedPackage _)) _ _)] -> - configurePackage verbosity - (InstallPlan.planPlatform installPlan) - (InstallPlan.planCompiler installPlan) - (setupScriptOptions installed) - configFlags pkg extraArgs - - _ -> die $ "internal error: configure install plan should have exactly " - ++ "one local ready package." - - where - setupScriptOptions index = SetupScriptOptions { - useCabalVersion = maybe anyVersion thisVersion - (flagToMaybe (configCabalVersion configExFlags)), - useCompiler = Just comp, - -- Hack: we typically want to allow the UserPackageDB for finding the - -- Cabal lib when compiling any Setup.hs even if we're doing a global - -- install. However we also allow looking in a specific package db. - usePackageDB = if UserPackageDB `elem` packageDBs - then packageDBs - else packageDBs ++ [UserPackageDB], - usePackageIndex = if UserPackageDB `elem` packageDBs - then Just index - else Nothing, - useProgramConfig = conf, - useDistPref = fromFlagOrDefault - (useDistPref defaultSetupScriptOptions) - (configDistPref configFlags), - useLoggingHandle = Nothing, - useWorkingDir = Nothing - } - --- | Make an 'InstallPlan' for the unpacked package in the current directory, --- and all its dependencies. --- -planLocalPackage :: Verbosity -> Compiler - -> ConfigFlags -> ConfigExFlags - -> PackageIndex InstalledPackage - -> AvailablePackageDb - -> IO (Progress String String InstallPlan) -planLocalPackage verbosity comp configFlags configExFlags installed - (AvailablePackageDb _ availablePrefs) = do - pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity - let -- The trick is, we add the local package to the available index and - -- remove it from the installed index. Then we ask to resolve a - -- dependency on exactly that package. So the resolver ends up having - -- to pick the local package. - available' = PackageIndex.insert localPkg mempty - installed' = PackageIndex.deletePackageId (packageId localPkg) installed - localPkg = AvailablePackage { - packageInfoId = packageId pkg, - Available.packageDescription = pkg, - packageSource = LocalUnpackedPackage Nothing - } - targets = [packageName pkg] - constraints = [PackageVersionConstraint (packageName pkg) - (thisVersion (packageVersion pkg)) - ,PackageFlagsConstraint (packageName pkg) - (configConfigurationsFlags configFlags)] - ++ [ PackageVersionConstraint name ver - | Dependency name ver <- configConstraints configFlags ] - preferences = mergePackagePrefs PreferLatestForSelected - availablePrefs configExFlags - - return $ resolveDependenciesWithProgress buildPlatform (compilerId comp) - installed' available' preferences constraints targets - - -mergePackagePrefs :: PackagesPreferenceDefault - -> Map.Map PackageName VersionRange - -> ConfigExFlags - -> PackagesPreference -mergePackagePrefs defaultPref availablePrefs configExFlags = - PackagesPreference defaultPref $ - -- The preferences that come from the hackage index - [ PackageVersionPreference name ver - | (name, ver) <- Map.toList availablePrefs ] - -- additional preferences from the config file or command line - ++ [ PackageVersionPreference name ver - | Dependency name ver <- configPreferences configExFlags ] - --- | Call an installer for an 'AvailablePackage' but override the configure --- flags with the ones given by the 'ConfiguredPackage'. In particular the --- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly --- versioned package dependencies. So we ignore any previous partial flag --- assignment or dependency constraints and use the new ones. --- -configurePackage :: Verbosity - -> Platform -> CompilerId - -> SetupScriptOptions - -> ConfigFlags - -> ConfiguredPackage - -> [String] - -> IO () -configurePackage verbosity platform comp scriptOptions configFlags - (ConfiguredPackage (AvailablePackage _ gpkg _) flags deps) extraArgs = - - setupWrapper verbosity - scriptOptions (Just pkg) configureCommand configureFlags extraArgs - - where - configureFlags = filterConfigureFlags configFlags { - configConfigurationsFlags = flags, - configConstraints = map thisPackageVersion deps, - configVerbosity = toFlag verbosity - } - - pkg = case finalizePackageDescription flags - (const True) - platform comp [] gpkg of - Left _ -> error "finalizePackageDescription ConfiguredPackage failed" - Right (desc, _) -> desc diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency.hs +++ /dev/null @@ -1,318 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Dependency --- Copyright : (c) David Himmelstrup 2005, --- Bjorn Bringert 2007 --- Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@gmail.com --- Stability : provisional --- Portability : portable --- --- Top level interface to dependency resolution. ------------------------------------------------------------------------------ -module Distribution.Client.Dependency ( - module Distribution.Client.Dependency.Types, - resolveDependencies, - resolveDependenciesWithProgress, - - resolveAvailablePackages, - - dependencyConstraints, - dependencyTargets, - - PackagesPreference(..), - PackagesPreferenceDefault(..), - PackagePreference(..), - - upgradableDependencies, - ) where - -import Distribution.Client.Dependency.TopDown (topDownResolver) -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Client.PackageIndex (PackageIndex) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan (InstallPlan) -import Distribution.Client.Types - ( UnresolvedDependency(..), AvailablePackage(..), InstalledPackage ) -import Distribution.Client.Dependency.Types - ( DependencyResolver, PackageConstraint(..) - , PackagePreferences(..), InstalledPreference(..) - , Progress(..), foldProgress ) -import Distribution.Package - ( PackageIdentifier(..), PackageName(..), packageVersion, packageName - , Dependency(Dependency), Package(..), PackageFixedDeps(..) ) -import Distribution.Version - ( VersionRange, anyVersion, orLaterVersion - , isAnyVersion, withinRange, simplifyVersionRange ) -import Distribution.Compiler - ( CompilerId(..) ) -import Distribution.System - ( Platform ) -import Distribution.Simple.Utils (comparing) -import Distribution.Client.Utils (mergeBy, MergeResult(..)) -import Distribution.Text - ( display ) - -import Data.List (maximumBy) -import Data.Maybe (fromMaybe, isJust) -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.Set (Set) -import Control.Exception (assert) - -defaultResolver :: DependencyResolver -defaultResolver = topDownResolver - --- | Global policy for the versions of all packages. --- -data PackagesPreference = PackagesPreference - PackagesPreferenceDefault - [PackagePreference] - -dependencyConstraints :: [UnresolvedDependency] -> [PackageConstraint] -dependencyConstraints deps = - [ PackageVersionConstraint name versionRange - | UnresolvedDependency (Dependency name versionRange) _ <- deps - , not (isAnyVersion versionRange) ] - - ++ [ PackageFlagsConstraint name flags - | UnresolvedDependency (Dependency name _) flags <- deps - , not (null flags) ] - -dependencyTargets :: [UnresolvedDependency] -> [PackageName] -dependencyTargets deps = - [ name | UnresolvedDependency (Dependency name _) _ <- deps ] - --- | Global policy for all packages to say if we prefer package versions that --- are already installed locally or if we just prefer the latest available. --- -data PackagesPreferenceDefault = - - -- | Always prefer the latest version irrespective of any existing - -- installed version. - -- - -- * This is the standard policy for upgrade. - -- - PreferAllLatest - - -- | Always prefer the installed versions over ones that would need to be - -- installed. Secondarily, prefer latest versions (eg the latest installed - -- version or if there are none then the latest available version). - | PreferAllInstalled - - -- | Prefer the latest version for packages that are explicitly requested - -- but prefers the installed version for any other packages. - -- - -- * This is the standard policy for install. - -- - | PreferLatestForSelected - -data PackagePreference - = PackageVersionPreference PackageName VersionRange - | PackageInstalledPreference PackageName InstalledPreference - -resolveDependencies :: Platform - -> CompilerId - -> PackageIndex InstalledPackage - -> PackageIndex AvailablePackage - -> PackagesPreference - -> [PackageConstraint] - -> [PackageName] - -> Either String InstallPlan -resolveDependencies platform comp installed available - preferences constraints targets = - foldProgress (flip const) Left Right $ - resolveDependenciesWithProgress - platform comp installed available - preferences constraints targets - -resolveDependenciesWithProgress :: Platform - -> CompilerId - -> PackageIndex InstalledPackage - -> PackageIndex AvailablePackage - -> PackagesPreference - -> [PackageConstraint] - -> [PackageName] - -> Progress String String InstallPlan -resolveDependenciesWithProgress platform comp installed available - pref constraints targets - -- TODO: the top down resolver chokes on the base constraints - -- below when there are no targets and thus no dep on base. - -- Need to refactor contraints separate from needing packages. - | null targets = return (toPlan []) - | otherwise = - let installed' = hideBrokenPackages installed - -- If the user is not explicitly asking to upgrade base then lets - -- prevent that from happening accidentally since it is usually not what - -- you want and it probably does not work anyway. We do it by adding a - -- constraint to only pick an installed version of base and ghc-prim. - extraConstraints = - [ PackageInstalledConstraint pkgname - | all (/=PackageName "base") targets - , pkgname <- [ PackageName "base", PackageName "ghc-prim" ] - , not (null (PackageIndex.lookupPackageName installed pkgname)) ] - preferences = interpretPackagesPreference (Set.fromList targets) pref - in fmap toPlan - $ defaultResolver platform comp installed' available - preferences (extraConstraints ++ constraints) targets - - where - toPlan pkgs = - case InstallPlan.new platform comp (PackageIndex.fromList pkgs) of - Right plan -> plan - Left problems -> error $ unlines $ - "internal error: could not construct a valid install plan." - : "The proposed (invalid) plan contained the following problems:" - : map InstallPlan.showPlanProblem problems - -hideBrokenPackages :: PackageFixedDeps p => PackageIndex p -> PackageIndex p -hideBrokenPackages index = - check (null . PackageIndex.brokenPackages) - . foldr (PackageIndex.deletePackageId . packageId) index - . PackageIndex.reverseDependencyClosure index - . map (packageId . fst) - $ PackageIndex.brokenPackages index - where - check p x = assert (p x) x - --- | Give an interpretation to the global 'PackagesPreference' as --- specific per-package 'PackageVersionPreference'. --- -interpretPackagesPreference :: Set PackageName - -> PackagesPreference - -> (PackageName -> PackagePreferences) -interpretPackagesPreference selected (PackagesPreference defaultPref prefs) = - \pkgname -> PackagePreferences (versionPref pkgname) (installPref pkgname) - - where - versionPref pkgname = - fromMaybe anyVersion (Map.lookup pkgname versionPrefs) - versionPrefs = Map.fromList - [ (pkgname, pref) - | PackageVersionPreference pkgname pref <- prefs ] - - installPref pkgname = - fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs) - installPrefs = Map.fromList - [ (pkgname, pref) - | PackageInstalledPreference pkgname pref <- prefs ] - installPrefDefault = case defaultPref of - PreferAllLatest -> \_ -> PreferLatest - PreferAllInstalled -> \_ -> PreferInstalled - PreferLatestForSelected -> \pkgname -> - -- When you say cabal install foo, what you really mean is, prefer the - -- latest version of foo, but the installed version of everything else - if pkgname `Set.member` selected then PreferLatest - else PreferInstalled - --- ------------------------------------------------------------ --- * Simple resolver that ignores dependencies --- ------------------------------------------------------------ - --- | A simplistic method of resolving a list of target package names to --- available packages. --- --- Specifically, it does not consider package dependencies at all. Unlike --- 'resolveDependencies', no attempt is made to ensure that the selected --- packages have dependencies that are satisfiable or consistent with --- each other. --- --- It is suitable for tasks such as selecting packages to download for user --- inspection. It is not suitable for selecting packages to install. --- --- Note: if no installed package index is available, it is ok to pass 'mempty'. --- It simply means preferences for installed packages will be ignored. --- -resolveAvailablePackages - :: PackageIndex InstalledPackage - -> PackageIndex AvailablePackage - -> PackagesPreference - -> [PackageConstraint] - -> [PackageName] - -> Either [ResolveNoDepsError] [AvailablePackage] -resolveAvailablePackages installed available preferences constraints targets = - collectEithers (map selectPackage targets) - where - selectPackage :: PackageName -> Either ResolveNoDepsError AvailablePackage - selectPackage pkgname - | null choices = Left $! ResolveUnsatisfiable pkgname requiredVersions - | otherwise = Right $! maximumBy bestByPrefs choices - - where - -- Constraints - requiredVersions = packageConstraints pkgname - pkgDependency = Dependency pkgname requiredVersions - choices = PackageIndex.lookupDependency available pkgDependency - - -- Preferences - PackagePreferences preferredVersions preferInstalled - = packagePreferences pkgname - - bestByPrefs = comparing $ \pkg -> - (installPref pkg, versionPref pkg, packageVersion pkg) - installPref = case preferInstalled of - PreferLatest -> const False - PreferInstalled -> isJust . PackageIndex.lookupPackageId installed - . packageId - versionPref pkg = packageVersion pkg `withinRange` preferredVersions - - packageConstraints :: PackageName -> VersionRange - packageConstraints pkgname = - Map.findWithDefault anyVersion pkgname packageVersionConstraintMap - packageVersionConstraintMap = - Map.fromList [ (name, range) - | PackageVersionConstraint name range <- constraints ] - - packagePreferences :: PackageName -> PackagePreferences - packagePreferences = interpretPackagesPreference (Set.fromList targets) preferences - - -collectEithers :: [Either a b] -> Either [a] [b] -collectEithers = collect . partitionEithers - where - collect ([], xs) = Right xs - collect (errs,_) = Left errs - partitionEithers :: [Either a b] -> ([a],[b]) - partitionEithers = foldr (either left right) ([],[]) - where - left a (l, r) = (a:l, r) - right a (l, r) = (l, a:r) - --- | Errors for 'resolveWithoutDependencies'. --- -data ResolveNoDepsError = - - -- | A package name which cannot be resolved to a specific package. - -- Also gives the constraint on the version and whether there was - -- a constraint on the package being installed. - ResolveUnsatisfiable PackageName VersionRange - -instance Show ResolveNoDepsError where - show (ResolveUnsatisfiable name ver) = - "There is no available version of " ++ display name - ++ " that satisfies " ++ display (simplifyVersionRange ver) - --- ------------------------------------------------------------ --- * Finding upgradable packages --- ------------------------------------------------------------ - --- | Given the list of installed packages and available packages, figure --- out which packages can be upgraded. --- -upgradableDependencies :: PackageIndex InstalledPackage - -> PackageIndex AvailablePackage - -> [Dependency] -upgradableDependencies installed available = - [ Dependency name (orLaterVersion latestVersion) - -- This is really quick (linear time). The trick is that we're doing a - -- merge join of two tables. We can do it as a merge because they're in - -- a comparable order because we're getting them from the package indexs. - | InBoth latestInstalled allAvailable - <- mergeBy (\a (b:_) -> packageName a `compare` packageName b) - [ maximumBy (comparing packageVersion) pkgs - | pkgs <- PackageIndex.allPackagesByName installed ] - (PackageIndex.allPackagesByName available) - , let (PackageIdentifier name latestVersion) = packageId latestInstalled - , any (\p -> packageVersion p > latestVersion) allAvailable ] diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown.hs +++ /dev/null @@ -1,776 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Dependency.Types --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Common types for dependency resolution. ------------------------------------------------------------------------------ -module Distribution.Client.Dependency.TopDown ( - topDownResolver - ) where - -import Distribution.Client.Dependency.TopDown.Types -import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints -import Distribution.Client.Dependency.TopDown.Constraints - ( Satisfiable(..) ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan - ( PlanPackage(..) ) -import Distribution.Client.Types - ( AvailablePackage(..), ConfiguredPackage(..), InstalledPackage(..) ) -import Distribution.Client.Dependency.Types - ( DependencyResolver, PackageConstraint(..) - , PackagePreferences(..), InstalledPreference(..) - , Progress(..), foldProgress ) - -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Client.PackageIndex (PackageIndex) -import Distribution.Package - ( PackageName(..), PackageIdentifier, Package(packageId), packageVersion, packageName - , Dependency(Dependency), thisPackageVersion, notThisPackageVersion - , PackageFixedDeps(depends) ) -import Distribution.PackageDescription - ( PackageDescription(buildDepends) ) -import Distribution.Client.PackageUtils - ( externalBuildDepends ) -import Distribution.PackageDescription.Configuration - ( finalizePackageDescription, flattenPackageDescription ) -import Distribution.Version - ( VersionRange, anyVersion, withinRange, simplifyVersionRange - , UpperBound(..), asVersionIntervals ) -import Distribution.Compiler - ( CompilerId ) -import Distribution.System - ( Platform ) -import Distribution.Simple.Utils - ( equating, comparing ) -import Distribution.Text - ( display ) - -import Data.List - ( foldl', maximumBy, minimumBy, nub, sort, groupBy ) -import Data.Maybe - ( fromJust, fromMaybe, catMaybes ) -import Data.Monoid - ( Monoid(mempty) ) -import Control.Monad - ( guard ) -import qualified Data.Set as Set -import Data.Set (Set) -import qualified Data.Map as Map -import qualified Data.Graph as Graph -import qualified Data.Array as Array -import Control.Exception - ( assert ) - --- ------------------------------------------------------------ --- * Search state types --- ------------------------------------------------------------ - -type Constraints = Constraints.Constraints - InstalledPackageEx UnconfiguredPackage ExclusionReason -type SelectedPackages = PackageIndex SelectedPackage - --- ------------------------------------------------------------ --- * The search tree type --- ------------------------------------------------------------ - -data SearchSpace inherited pkg - = ChoiceNode inherited [[(pkg, SearchSpace inherited pkg)]] - | Failure Failure - --- ------------------------------------------------------------ --- * Traverse a search tree --- ------------------------------------------------------------ - -explore :: (PackageName -> PackagePreferences) - -> SearchSpace (SelectedPackages, Constraints, SelectionChanges) - SelectablePackage - -> Progress Log Failure (SelectedPackages, Constraints) - -explore _ (Failure failure) = Fail failure -explore _ (ChoiceNode (s,c,_) []) = Done (s,c) -explore pref (ChoiceNode _ choices) = - case [ choice | [choice] <- choices ] of - ((_, node'):_) -> Step (logInfo node') (explore pref node') - [] -> Step (logInfo node') (explore pref node') - where - choice = minimumBy (comparing topSortNumber) choices - pkgname = packageName . fst . head $ choice - (_, node') = maximumBy (bestByPref pkgname) choice - where - topSortNumber choice = case fst (head choice) of - InstalledOnly (InstalledPackageEx _ i _) -> i - AvailableOnly (UnconfiguredPackage _ i _) -> i - InstalledAndAvailable _ (UnconfiguredPackage _ i _) -> i - - bestByPref pkgname = case packageInstalledPreference of - PreferLatest -> - comparing (\(p,_) -> ( isPreferred p, packageId p)) - PreferInstalled -> - comparing (\(p,_) -> (isInstalled p, isPreferred p, packageId p)) - where - isInstalled (AvailableOnly _) = False - isInstalled _ = True - isPreferred p = packageVersion p `withinRange` preferredVersions - (PackagePreferences preferredVersions packageInstalledPreference) - = pref pkgname - - logInfo node = Select selected discarded - where (selected, discarded) = case node of - Failure _ -> ([], []) - ChoiceNode (_,_,changes) _ -> changes - --- ------------------------------------------------------------ --- * Generate a search tree --- ------------------------------------------------------------ - -type ConfigurePackage = PackageIndex SelectablePackage - -> SelectablePackage - -> Either [Dependency] SelectedPackage - --- | (packages selected, packages discarded) -type SelectionChanges = ([SelectedPackage], [PackageIdentifier]) - -searchSpace :: ConfigurePackage - -> Constraints - -> SelectedPackages - -> SelectionChanges - -> Set PackageName - -> SearchSpace (SelectedPackages, Constraints, SelectionChanges) - SelectablePackage -searchSpace configure constraints selected changes next = - ChoiceNode (selected, constraints, changes) - [ [ (pkg, select name pkg) - | pkg <- PackageIndex.lookupPackageName available name ] - | name <- Set.elems next ] - where - available = Constraints.choices constraints - - select name pkg = case configure available pkg of - Left missing -> Failure $ ConfigureFailed pkg - [ (dep, Constraints.conflicting constraints dep) - | dep <- missing ] - Right pkg' -> case constrainDeps pkg' newDeps constraints [] of - Left failure -> Failure failure - Right (constraints', newDiscarded) -> - searchSpace configure - constraints' selected' (newSelected, newDiscarded) next' - where - selected' = foldl' (flip PackageIndex.insert) selected newSelected - newSelected = - case Constraints.isPaired constraints (packageId pkg) of - Nothing -> [pkg'] - Just pkgid' -> [pkg', pkg''] - where - Just pkg'' = fmap (\(InstalledOnly p) -> InstalledOnly p) - (PackageIndex.lookupPackageId available pkgid') - - newPkgs = [ name' - | dep <- newDeps - , let (Dependency name' _) = untagDependency dep - , null (PackageIndex.lookupPackageName selected' name') ] - newDeps = concatMap packageConstraints newSelected - next' = Set.delete name - $ foldl' (flip Set.insert) next newPkgs - -packageConstraints :: SelectedPackage -> [TaggedDependency] -packageConstraints = either installedConstraints availableConstraints - . preferAvailable - where - preferAvailable (InstalledOnly pkg) = Left pkg - preferAvailable (AvailableOnly pkg) = Right pkg - preferAvailable (InstalledAndAvailable _ pkg) = Right pkg - installedConstraints (InstalledPackageEx _ _ deps) = - [ TaggedDependency InstalledConstraint (thisPackageVersion dep) - | dep <- deps ] - availableConstraints (SemiConfiguredPackage _ _ deps) = - [ TaggedDependency NoInstalledConstraint dep | dep <- deps ] - -constrainDeps :: SelectedPackage -> [TaggedDependency] -> Constraints - -> [PackageIdentifier] - -> Either Failure (Constraints, [PackageIdentifier]) -constrainDeps pkg [] cs discard = - case addPackageSelectConstraint (packageId pkg) cs of - Satisfiable cs' discard' -> Right (cs', discard' ++ discard) - _ -> impossible -constrainDeps pkg (dep:deps) cs discard = - case addPackageDependencyConstraint (packageId pkg) dep cs of - Satisfiable cs' discard' -> constrainDeps pkg deps cs' (discard' ++ discard) - Unsatisfiable -> impossible - ConflictsWith conflicts -> - Left (DependencyConflict pkg dep conflicts) - --- ------------------------------------------------------------ --- * The main algorithm --- ------------------------------------------------------------ - -search :: ConfigurePackage - -> (PackageName -> PackagePreferences) - -> Constraints - -> Set PackageName - -> Progress Log Failure (SelectedPackages, Constraints) -search configure pref constraints = - explore pref . searchSpace configure constraints mempty ([], []) - --- ------------------------------------------------------------ --- * The top level resolver --- ------------------------------------------------------------ - --- | The main exported resolver, with string logging and failure types to fit --- the standard 'DependencyResolver' interface. --- -topDownResolver :: DependencyResolver -topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver' - where - mapMessages :: Progress Log Failure a -> Progress String String a - mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done - --- | The native resolver with detailed structured logging and failure types. --- -topDownResolver' :: Platform -> CompilerId - -> PackageIndex InstalledPackage - -> PackageIndex AvailablePackage - -> (PackageName -> PackagePreferences) - -> [PackageConstraint] - -> [PackageName] - -> Progress Log Failure [PlanPackage] -topDownResolver' platform comp installed available - preferences constraints targets = - fmap (uncurry finalise) - . (\cs -> search configure preferences cs initialPkgNames) - =<< addTopLevelConstraints constraints constraintSet - - where - configure = configurePackage platform comp - constraintSet :: Constraints - constraintSet = Constraints.empty - (annotateInstalledPackages topSortNumber installed') - (annotateAvailablePackages constraints topSortNumber available') - (installed', available') = selectNeededSubset installed available - initialPkgNames - topSortNumber = topologicalSortNumbering installed' available' - - initialPkgNames = Set.fromList targets - - finalise selected' constraints' = - PackageIndex.allPackages - . fst . improvePlan installed' constraints' - . PackageIndex.fromList - $ finaliseSelectedPackages preferences selected' constraints' - -addTopLevelConstraints :: [PackageConstraint] -> Constraints - -> Progress a Failure Constraints -addTopLevelConstraints [] cs = Done cs -addTopLevelConstraints (PackageFlagsConstraint _ _ :deps) cs = - addTopLevelConstraints deps cs - -addTopLevelConstraints (PackageVersionConstraint pkg ver:deps) cs = - case addTopLevelVersionConstraint pkg ver cs of - Satisfiable cs' _ -> - addTopLevelConstraints deps cs' - - Unsatisfiable -> - Fail (TopLevelVersionConstraintUnsatisfiable pkg ver) - - ConflictsWith conflicts -> - Fail (TopLevelVersionConstraintConflict pkg ver conflicts) - -addTopLevelConstraints (PackageInstalledConstraint pkg:deps) cs = - case addTopLevelInstalledConstraint pkg cs of - Satisfiable cs' _ -> addTopLevelConstraints deps cs' - - Unsatisfiable -> - Fail (TopLevelInstallConstraintUnsatisfiable pkg) - - ConflictsWith conflicts -> - Fail (TopLevelInstallConstraintConflict pkg conflicts) - -configurePackage :: Platform -> CompilerId -> ConfigurePackage -configurePackage platform comp available spkg = case spkg of - InstalledOnly ipkg -> Right (InstalledOnly ipkg) - AvailableOnly apkg -> fmap AvailableOnly (configure apkg) - InstalledAndAvailable ipkg apkg -> fmap (InstalledAndAvailable ipkg) - (configure apkg) - where - configure (UnconfiguredPackage apkg@(AvailablePackage _ p _) _ flags) = - case finalizePackageDescription flags dependencySatisfiable - platform comp [] p of - Left missing -> Left missing - Right (pkg, flags') -> Right $ - SemiConfiguredPackage apkg flags' (externalBuildDepends pkg) - - dependencySatisfiable = not . null . PackageIndex.lookupDependency available - --- | Annotate each installed packages with its set of transative dependencies --- and its topological sort number. --- -annotateInstalledPackages :: (PackageName -> TopologicalSortNumber) - -> PackageIndex InstalledPackage - -> PackageIndex InstalledPackageEx -annotateInstalledPackages dfsNumber installed = PackageIndex.fromList - [ InstalledPackageEx pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg) - | pkg <- PackageIndex.allPackages installed ] - where - transitiveDepends :: InstalledPackage -> [PackageIdentifier] - transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph - . fromJust . toVertex . packageId - (graph, toPkg, toVertex) = PackageIndex.dependencyGraph installed - - --- | Annotate each available packages with its topological sort number and any --- user-supplied partial flag assignment. --- -annotateAvailablePackages :: [PackageConstraint] - -> (PackageName -> TopologicalSortNumber) - -> PackageIndex AvailablePackage - -> PackageIndex UnconfiguredPackage -annotateAvailablePackages constraints dfsNumber available = PackageIndex.fromList - [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name) - | pkg <- PackageIndex.allPackages available - , let name = packageName pkg ] - where - flagsFor = fromMaybe [] . flip Map.lookup flagsMap - flagsMap = Map.fromList - [ (name, flags) - | PackageFlagsConstraint name flags <- constraints ] - --- | One of the heuristics we use when guessing which path to take in the --- search space is an ordering on the choices we make. It's generally better --- to make decisions about packages higer in the dep graph first since they --- place constraints on packages lower in the dep graph. --- --- To pick them in that order we annotate each package with its topological --- sort number. So if package A depends on package B then package A will have --- a lower topological sort number than B and we'll make a choice about which --- version of A to pick before we make a choice about B (unless there is only --- one possible choice for B in which case we pick that immediately). --- --- To construct these topological sort numbers we combine and flatten the --- installed and available package sets. We consider only dependencies between --- named packages, not including versions and for not-yet-configured packages --- we look at all the possible dependencies, not just those under any single --- flag assignment. This means we can actually get impossible combinations of --- edges and even cycles, but that doesn't really matter here, it's only a --- heuristic. --- -topologicalSortNumbering :: PackageIndex InstalledPackage - -> PackageIndex AvailablePackage - -> (PackageName -> TopologicalSortNumber) -topologicalSortNumbering installed available = - \pkgname -> let Just vertex = toVertex pkgname - in topologicalSortNumbers Array.! vertex - where - topologicalSortNumbers = Array.array (Array.bounds graph) - (zip (Graph.topSort graph) [0..]) - (graph, _, toVertex) = Graph.graphFromEdges $ - [ ((), packageName pkg, nub deps) - | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installed - , let deps = [ packageName dep - | pkg' <- pkgs - , dep <- depends pkg' ] ] - ++ [ ((), packageName pkg, nub deps) - | pkgs@(pkg:_) <- PackageIndex.allPackagesByName available - , let deps = [ depName - | AvailablePackage _ pkg' _ <- pkgs - , Dependency depName _ <- - buildDepends (flattenPackageDescription pkg') ] ] - --- | We don't need the entire index (which is rather large and costly if we --- force it by examining the whole thing). So trace out the maximul subset of --- each index that we could possibly ever need. Do this by flattening packages --- and looking at the names of all possible dependencies. --- -selectNeededSubset :: PackageIndex InstalledPackage - -> PackageIndex AvailablePackage - -> Set PackageName - -> (PackageIndex InstalledPackage - ,PackageIndex AvailablePackage) -selectNeededSubset installed available = select mempty mempty - where - select :: PackageIndex InstalledPackage - -> PackageIndex AvailablePackage - -> Set PackageName - -> (PackageIndex InstalledPackage - ,PackageIndex AvailablePackage) - select installed' available' remaining - | Set.null remaining = (installed', available') - | otherwise = select installed'' available'' remaining'' - where - (next, remaining') = Set.deleteFindMin remaining - moreInstalled = PackageIndex.lookupPackageName installed next - moreAvailable = PackageIndex.lookupPackageName available next - moreRemaining = -- we filter out packages already included in the indexes - -- this avoids an infinite loop if a package depends on itself - -- like base-3.0.3.0 with base-4.0.0.0 - filter notAlreadyIncluded - $ [ packageName dep - | pkg <- moreInstalled - , dep <- depends pkg ] - ++ [ name - | AvailablePackage _ pkg _ <- moreAvailable - , Dependency name _ <- - buildDepends (flattenPackageDescription pkg) ] - installed'' = foldl' (flip PackageIndex.insert) installed' moreInstalled - available'' = foldl' (flip PackageIndex.insert) available' moreAvailable - remaining'' = foldl' (flip Set.insert) remaining' moreRemaining - notAlreadyIncluded name = null (PackageIndex.lookupPackageName installed' name) - && null (PackageIndex.lookupPackageName available' name) - --- ------------------------------------------------------------ --- * Post processing the solution --- ------------------------------------------------------------ - -finaliseSelectedPackages :: (PackageName -> PackagePreferences) - -> SelectedPackages - -> Constraints - -> [PlanPackage] -finaliseSelectedPackages pref selected constraints = - map finaliseSelected (PackageIndex.allPackages selected) - where - remainingChoices = Constraints.choices constraints - finaliseSelected (InstalledOnly ipkg ) = finaliseInstalled ipkg - finaliseSelected (AvailableOnly apkg) = finaliseAvailable Nothing apkg - finaliseSelected (InstalledAndAvailable ipkg apkg) = - case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of - Nothing -> impossible --picked package not in constraints - Just (AvailableOnly _) -> impossible --to constrain to avail only - Just (InstalledOnly _) -> finaliseInstalled ipkg - Just (InstalledAndAvailable _ _) -> finaliseAvailable (Just ipkg) apkg - - finaliseInstalled (InstalledPackageEx pkg _ _) = InstallPlan.PreExisting pkg - finaliseAvailable mipkg (SemiConfiguredPackage pkg flags deps) = - InstallPlan.Configured (ConfiguredPackage pkg flags deps') - where - deps' = map (packageId . pickRemaining mipkg) deps - - pickRemaining mipkg dep@(Dependency _name versionRange) = - case PackageIndex.lookupDependency remainingChoices dep of - [] -> impossible - [pkg'] -> pkg' - remaining -> assert (checkIsPaired remaining) - $ maximumBy bestByPref remaining - where - -- We order candidate packages to pick for a dependency by these - -- three factors. The last factor is just highest version wins. - bestByPref = - comparing (\p -> (isCurrent p, isPreferred p, packageVersion p)) - -- Is the package already used by the installed version of this - -- package? If so we should pick that first. This stops us from doing - -- silly things like deciding to rebuild haskell98 against base 3. - isCurrent = case mipkg :: Maybe InstalledPackageEx of - Nothing -> \_ -> False - Just ipkg -> \p -> packageId p `elem` depends ipkg - -- If there is no upper bound on the version range then we apply a - -- preferred version acording to the hackage or user's suggested - -- version constraints. TODO: distinguish hacks from prefs - bounded = boundedAbove versionRange - isPreferred p - | bounded = True -- any constant will do - | otherwise = packageVersion p `withinRange` preferredVersions - where (PackagePreferences preferredVersions _) = pref (packageName p) - - boundedAbove :: VersionRange -> Bool - boundedAbove vr = case asVersionIntervals vr of - [] -> True -- this is the inconsistent version range. - intervals -> case last intervals of - (_, UpperBound _ _) -> True - (_, NoUpperBound ) -> False - - -- We really only expect to find more than one choice remaining when - -- we're finalising a dependency on a paired package. - checkIsPaired [p1, p2] = - case Constraints.isPaired constraints (packageId p1) of - Just p2' -> packageId p2' == packageId p2 - Nothing -> False - checkIsPaired _ = False - --- | Improve an existing installation plan by, where possible, swapping --- packages we plan to install with ones that are already installed. --- This may add additional constraints due to the dependencies of installed --- packages on other installed packages. --- -improvePlan :: PackageIndex InstalledPackage - -> Constraints - -> PackageIndex PlanPackage - -> (PackageIndex PlanPackage, Constraints) -improvePlan installed constraints0 selected0 = - foldl' improve (selected0, constraints0) (reverseTopologicalOrder selected0) - where - improve (selected, constraints) = fromMaybe (selected, constraints) - . improvePkg selected constraints - - -- The idea is to improve the plan by swapping a configured package for - -- an equivalent installed one. For a particular package the condition is - -- that the package be in a configured state, that a the same version be - -- already installed with the exact same dependencies and all the packages - -- in the plan that it depends on are in the installed state - improvePkg selected constraints pkgid = do - Configured pkg <- PackageIndex.lookupPackageId selected pkgid - ipkg <- PackageIndex.lookupPackageId installed pkgid - guard $ all (isInstalled selected) (depends pkg) - tryInstalled selected constraints [ipkg] - - isInstalled selected pkgid = - case PackageIndex.lookupPackageId selected pkgid of - Just (PreExisting _) -> True - _ -> False - - tryInstalled :: PackageIndex PlanPackage -> Constraints - -> [InstalledPackage] - -> Maybe (PackageIndex PlanPackage, Constraints) - tryInstalled selected constraints [] = Just (selected, constraints) - tryInstalled selected constraints (pkg:pkgs) = - case constraintsOk (packageId pkg) (depends pkg) constraints of - Nothing -> Nothing - Just constraints' -> tryInstalled selected' constraints' pkgs' - where - selected' = PackageIndex.insert (PreExisting pkg) selected - pkgs' = catMaybes (map notSelected (depends pkg)) ++ pkgs - notSelected pkgid = - case (PackageIndex.lookupPackageId installed pkgid - ,PackageIndex.lookupPackageId selected pkgid) of - (Just pkg', Nothing) -> Just pkg' - _ -> Nothing - - constraintsOk _ [] constraints = Just constraints - constraintsOk pkgid (pkgid':pkgids) constraints = - case addPackageDependencyConstraint pkgid dep constraints of - Satisfiable constraints' _ -> constraintsOk pkgid pkgids constraints' - _ -> Nothing - where - dep = TaggedDependency InstalledConstraint (thisPackageVersion pkgid') - - reverseTopologicalOrder :: PackageFixedDeps pkg - => PackageIndex pkg -> [PackageIdentifier] - reverseTopologicalOrder index = map (packageId . toPkg) - . Graph.topSort - . Graph.transposeG - $ graph - where (graph, toPkg, _) = PackageIndex.dependencyGraph index - --- ------------------------------------------------------------ --- * Adding and recording constraints --- ------------------------------------------------------------ - -addPackageSelectConstraint :: PackageIdentifier -> Constraints - -> Satisfiable Constraints - [PackageIdentifier] ExclusionReason -addPackageSelectConstraint pkgid constraints = - Constraints.constrain dep reason constraints - where - dep = TaggedDependency NoInstalledConstraint (thisPackageVersion pkgid) - reason = SelectedOther pkgid - -addPackageExcludeConstraint :: PackageIdentifier -> Constraints - -> Satisfiable Constraints - [PackageIdentifier] ExclusionReason -addPackageExcludeConstraint pkgid constraints = - Constraints.constrain dep reason constraints - where - dep = TaggedDependency NoInstalledConstraint - (notThisPackageVersion pkgid) - reason = ExcludedByConfigureFail - -addPackageDependencyConstraint :: PackageIdentifier -> TaggedDependency -> Constraints - -> Satisfiable Constraints - [PackageIdentifier] ExclusionReason -addPackageDependencyConstraint pkgid dep constraints = - Constraints.constrain dep reason constraints - where - reason = ExcludedByPackageDependency pkgid dep - -addTopLevelVersionConstraint :: PackageName -> VersionRange - -> Constraints - -> Satisfiable Constraints - [PackageIdentifier] ExclusionReason -addTopLevelVersionConstraint pkg ver constraints = - Constraints.constrain taggedDep reason constraints - where - dep = Dependency pkg ver - taggedDep = TaggedDependency NoInstalledConstraint dep - reason = ExcludedByTopLevelDependency dep - -addTopLevelInstalledConstraint :: PackageName - -> Constraints - -> Satisfiable Constraints - [PackageIdentifier] ExclusionReason -addTopLevelInstalledConstraint pkg constraints = - Constraints.constrain taggedDep reason constraints - where - dep = Dependency pkg anyVersion - taggedDep = TaggedDependency InstalledConstraint dep - reason = ExcludedByTopLevelDependency dep - --- ------------------------------------------------------------ --- * Reasons for constraints --- ------------------------------------------------------------ - --- | For every constraint we record we also record the reason that constraint --- is needed. So if we end up failing due to conflicting constraints then we --- can give an explnanation as to what was conflicting and why. --- -data ExclusionReason = - - -- | We selected this other version of the package. That means we exclude - -- all the other versions. - SelectedOther PackageIdentifier - - -- | We excluded this version of the package because it failed to - -- configure probably because of unsatisfiable deps. - | ExcludedByConfigureFail - - -- | We excluded this version of the package because another package that - -- we selected imposed a dependency which this package did not satisfy. - | ExcludedByPackageDependency PackageIdentifier TaggedDependency - - -- | We excluded this version of the package because it did not satisfy - -- a dependency given as an original top level input. - -- - | ExcludedByTopLevelDependency Dependency - --- | Given an excluded package and the reason it was excluded, produce a human --- readable explanation. --- -showExclusionReason :: PackageIdentifier -> ExclusionReason -> String -showExclusionReason pkgid (SelectedOther pkgid') = - display pkgid ++ " was excluded because " ++ - display pkgid' ++ " was selected instead" -showExclusionReason pkgid ExcludedByConfigureFail = - display pkgid ++ " was excluded because it could not be configured" -showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep) = - display pkgid ++ " was excluded because " ++ - display pkgid' ++ " requires " ++ displayDep (untagDependency dep) -showExclusionReason pkgid (ExcludedByTopLevelDependency dep) = - display pkgid ++ " was excluded because of the top level dependency " ++ - displayDep dep - - --- ------------------------------------------------------------ --- * Logging progress and failures --- ------------------------------------------------------------ - -data Log = Select [SelectedPackage] [PackageIdentifier] -data Failure - = ConfigureFailed - SelectablePackage - [(Dependency, [(PackageIdentifier, [ExclusionReason])])] - | DependencyConflict - SelectedPackage TaggedDependency - [(PackageIdentifier, [ExclusionReason])] - | TopLevelVersionConstraintConflict - PackageName VersionRange - [(PackageIdentifier, [ExclusionReason])] - | TopLevelVersionConstraintUnsatisfiable - PackageName VersionRange - | TopLevelInstallConstraintConflict - PackageName - [(PackageIdentifier, [ExclusionReason])] - | TopLevelInstallConstraintUnsatisfiable - PackageName - -showLog :: Log -> String -showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of - ("", y) -> y - (x, "") -> x - (x, y) -> x ++ " and " ++ y - - where - selectedMsg = "selecting " ++ case selected of - [] -> "" - [s] -> display (packageId s) ++ " " ++ kind s - (s:ss) -> listOf id - $ (display (packageId s) ++ " " ++ kind s) - : [ display (packageVersion s') ++ " " ++ kind s' - | s' <- ss ] - - kind (InstalledOnly _) = "(installed)" - kind (AvailableOnly _) = "(hackage)" - kind (InstalledAndAvailable _ _) = "(installed or hackage)" - - discardedMsg = case discarded of - [] -> "" - _ -> "discarding " ++ listOf id - [ element - | (pkgid:pkgids) <- groupBy (equating packageName) (sort discarded) - , element <- display pkgid : map (display . packageVersion) pkgids ] - -showFailure :: Failure -> String -showFailure (ConfigureFailed pkg missingDeps) = - "cannot configure " ++ displayPkg pkg ++ ". It requires " - ++ listOf (displayDep . fst) missingDeps - ++ '\n' : unlines (map (uncurry whyNot) missingDeps) - - where - whyNot (Dependency name ver) [] = - "There is no available version of " ++ display name - ++ " that satisfies " ++ displayVer ver - - whyNot dep conflicts = - "For the dependency on " ++ displayDep dep - ++ " there are these packages: " ++ listOf display pkgs - ++ ". However none of them are available.\n" - ++ unlines [ showExclusionReason (packageId pkg') reason - | (pkg', reasons) <- conflicts, reason <- reasons ] - - where pkgs = map fst conflicts - -showFailure (DependencyConflict pkg (TaggedDependency _ dep) conflicts) = - "dependencies conflict: " - ++ displayPkg pkg ++ " requires " ++ displayDep dep ++ " however\n" - ++ unlines [ showExclusionReason (packageId pkg') reason - | (pkg', reasons) <- conflicts, reason <- reasons ] - -showFailure (TopLevelVersionConstraintConflict name ver conflicts) = - "constraints conflict: " - ++ "top level constraint " ++ displayDep (Dependency name ver) ++ " however\n" - ++ unlines [ showExclusionReason (packageId pkg') reason - | (pkg', reasons) <- conflicts, reason <- reasons ] - -showFailure (TopLevelVersionConstraintUnsatisfiable name ver) = - "There is no available version of " ++ display name - ++ " that satisfies " ++ displayVer ver - -showFailure (TopLevelInstallConstraintConflict name conflicts) = - "constraints conflict: " - ++ "top level constraint " ++ display name ++ "-installed however\n" - ++ unlines [ showExclusionReason (packageId pkg') reason - | (pkg', reasons) <- conflicts, reason <- reasons ] - -showFailure (TopLevelInstallConstraintUnsatisfiable name) = - "There is no installed version of " ++ display name - -displayVer :: VersionRange -> String -displayVer = display . simplifyVersionRange - -displayDep :: Dependency -> String -displayDep = display . simplifyDependency - -simplifyDependency :: Dependency -> Dependency -simplifyDependency (Dependency name range) = - Dependency name (simplifyVersionRange range) - --- ------------------------------------------------------------ --- * Utils --- ------------------------------------------------------------ - -impossible :: a -impossible = internalError "impossible" - -internalError :: String -> a -internalError msg = error $ "internal error: " ++ msg - -displayPkg :: Package pkg => pkg -> String -displayPkg = display . packageId - -listOf :: (a -> String) -> [a] -> String -listOf _ [] = [] -listOf disp [x0] = disp x0 -listOf disp (x0:x1:xs) = disp x0 ++ go x1 xs - where go x [] = " and " ++ disp x - go x (x':xs') = ", " ++ disp x ++ go x' xs' diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Constraints.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Constraints.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Constraints.hs +++ /dev/null @@ -1,316 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Dependency.TopDown.Constraints --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : duncan@haskell.org --- Stability : provisional --- Portability : portable --- --- A set of satisfiable dependencies (package version constraints). ------------------------------------------------------------------------------ -module Distribution.Client.Dependency.TopDown.Constraints ( - Constraints, - empty, - choices, - isPaired, - - constrain, - Satisfiable(..), - conflicting, - ) where - -import Distribution.Client.Dependency.TopDown.Types -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Client.PackageIndex (PackageIndex) -import Distribution.Package - ( PackageName, PackageIdentifier(..) - , Package(packageId), packageName, packageVersion - , PackageFixedDeps(depends) - , Dependency(Dependency) ) -import Distribution.Version - ( Version, withinRange ) -import Distribution.Client.Utils - ( mergeBy, MergeResult(..) ) - -import Data.List - ( foldl' ) -import Data.Monoid - ( Monoid(mempty) ) -import Data.Maybe - ( catMaybes ) -import qualified Data.Map as Map -import Data.Map (Map) -import Control.Exception - ( assert ) - --- | A set of constraints on package versions. For each package name we record --- what other packages depends on it and what constraints they impose on the --- version of the package. --- -data (Package installed, Package available) - => Constraints installed available reason - = Constraints - - -- Remaining available choices - (PackageIndex (InstalledOrAvailable installed available)) - - -- Paired choices - (Map PackageName (Version, Version)) - - -- Choices that we have excluded for some reason - -- usually by applying constraints - (PackageIndex (ExcludedPackage PackageIdentifier reason)) - - -- Purely for the invariant, we keep a copy of the original index - (PackageIndex (InstalledOrAvailable installed available)) - - -data ExcludedPackage pkg reason - = ExcludedPackage pkg [reason] -- reasons for excluding just the available - [reason] -- reasons for excluding installed and avail - -instance Package pkg => Package (ExcludedPackage pkg reason) where - packageId (ExcludedPackage p _ _) = packageId p - --- | There is a conservation of packages property. Packages are never gained or --- lost, they just transfer from the remaining pot to the excluded pot. --- -invariant :: (Package installed, Package available) - => Constraints installed available a -> Bool -invariant (Constraints available _ excluded original) = all check merged - where - merged = mergeBy (\a b -> packageId a `compare` mergedPackageId b) - (PackageIndex.allPackages original) - (mergeBy (\a b -> packageId a `compare` packageId b) - (PackageIndex.allPackages available) - (PackageIndex.allPackages excluded)) - where - mergedPackageId (OnlyInLeft p ) = packageId p - mergedPackageId (OnlyInRight p) = packageId p - mergedPackageId (InBoth p _) = packageId p - - check (InBoth (InstalledOnly _) cur) = case cur of - -- If the package was originally installed only then - -- now it's either still remaining as installed only - -- or it has been excluded in which case we excluded both - -- installed and available since it was only installed - OnlyInLeft (InstalledOnly _) -> True - OnlyInRight (ExcludedPackage _ [] (_:_)) -> True - _ -> False - - check (InBoth (AvailableOnly _) cur) = case cur of - -- If the package was originally available only then - -- now it's either still remaining as available only - -- or it has been excluded in which case we excluded both - -- installed and available since it was only available - OnlyInLeft (AvailableOnly _) -> True - OnlyInRight (ExcludedPackage _ [] (_:_)) -> True - _ -> True - - -- If the package was originally installed and available - -- then there are three cases. - check (InBoth (InstalledAndAvailable _ _) cur) = case cur of - -- We can have both remaining: - OnlyInLeft (InstalledAndAvailable _ _) -> True - -- both excluded, in particular it can have had the available excluded - -- and later had both excluded so we do not mind if the available excluded - -- is empty or non-empty. - OnlyInRight (ExcludedPackage _ _ (_:_)) -> True - -- the installed remaining and the available excluded: - InBoth (InstalledOnly _) (ExcludedPackage _ (_:_) []) -> True - _ -> False - - check _ = False - --- | An update to the constraints can move packages between the two piles --- but not gain or loose packages. -transitionsTo :: (Package installed, Package available) - => Constraints installed available a - -> Constraints installed available a -> Bool -transitionsTo constraints @(Constraints available _ excluded _) - constraints'@(Constraints available' _ excluded' _) = - invariant constraints && invariant constraints' - && null availableGained && null excludedLost - && map packageId availableLost == map packageId excludedGained - - where - availableLost = foldr lost [] availableChange where - lost (OnlyInLeft pkg) rest = pkg : rest - lost (InBoth (InstalledAndAvailable _ pkg) - (InstalledOnly _)) rest = AvailableOnly pkg : rest - lost _ rest = rest - availableGained = [ pkg | OnlyInRight pkg <- availableChange ] - excludedLost = [ pkg | OnlyInLeft pkg <- excludedChange ] - excludedGained = [ pkg | OnlyInRight pkg <- excludedChange ] - ++ [ pkg | InBoth (ExcludedPackage _ (_:_) []) - pkg@(ExcludedPackage _ (_:_) (_:_)) - <- excludedChange ] - availableChange = mergeBy (\a b -> packageId a `compare` packageId b) - (PackageIndex.allPackages available) - (PackageIndex.allPackages available') - excludedChange = mergeBy (\a b -> packageId a `compare` packageId b) - (PackageIndex.allPackages excluded) - (PackageIndex.allPackages excluded') - --- | We construct 'Constraints' with an initial 'PackageIndex' of all the --- packages available. --- -empty :: (PackageFixedDeps installed, Package available) - => PackageIndex installed - -> PackageIndex available - -> Constraints installed available reason -empty installed available = Constraints pkgs pairs mempty pkgs - where - pkgs = PackageIndex.fromList - . map toInstalledOrAvailable - $ mergeBy (\a b -> packageId a `compare` packageId b) - (PackageIndex.allPackages installed) - (PackageIndex.allPackages available) - toInstalledOrAvailable (OnlyInLeft i ) = InstalledOnly i - toInstalledOrAvailable (OnlyInRight a) = AvailableOnly a - toInstalledOrAvailable (InBoth i a) = InstalledAndAvailable i a - - -- pick up cases like base-3 and 4 where one version depends on the other: - pairs = Map.fromList - [ (name, (packageVersion pkgid1, packageVersion pkgid2)) - | [pkg1, pkg2] <- PackageIndex.allPackagesByName installed - , let name = packageName pkg1 - pkgid1 = packageId pkg1 - pkgid2 = packageId pkg2 - , any ((pkgid1==) . packageId) (depends pkg2) - || any ((pkgid2==) . packageId) (depends pkg1) ] - --- | The package choices that are still available. --- -choices :: (Package installed, Package available) - => Constraints installed available reason - -> PackageIndex (InstalledOrAvailable installed available) -choices (Constraints available _ _ _) = available - -isPaired :: (Package installed, Package available) - => Constraints installed available reason - -> PackageIdentifier -> Maybe PackageIdentifier -isPaired (Constraints _ pairs _ _) (PackageIdentifier name version) = - case Map.lookup name pairs of - Just (v1, v2) - | version == v1 -> Just (PackageIdentifier name v2) - | version == v2 -> Just (PackageIdentifier name v1) - _ -> Nothing - -data Satisfiable constraints discarded reason - = Satisfiable constraints discarded - | Unsatisfiable - | ConflictsWith [(PackageIdentifier, [reason])] - -constrain :: (Package installed, Package available) - => TaggedDependency - -> reason - -> Constraints installed available reason - -> Satisfiable (Constraints installed available reason) - [PackageIdentifier] reason -constrain (TaggedDependency installedConstraint (Dependency name versionRange)) - reason constraints@(Constraints available paired excluded original) - - | not anyRemaining - = if null conflicts then Unsatisfiable - else ConflictsWith conflicts - - | otherwise - = let constraints' = Constraints available' paired excluded' original - in assert (constraints `transitionsTo` constraints') $ - Satisfiable constraints' (map packageId newExcluded) - - where - -- This tells us if any packages would remain at all for this package name if - -- we applied this constraint. This amounts to checking if any package - -- satisfies the given constraint, including version range and installation - -- status. - -- - anyRemaining = any satisfiesConstraint availableChoices - - conflicts = [ (packageId pkg, reasonsAvail ++ reasonsAll) - | ExcludedPackage pkg reasonsAvail reasonsAll <- excludedChoices - , satisfiesVersionConstraint pkg ] - - -- Applying this constraint may involve deleting some choices for this - -- package name, or restricting which install states are available. - available' = updateAvailable available - updateAvailable = flip (foldl' (flip update)) availableChoices where - update pkg | not (satisfiesVersionConstraint pkg) - = PackageIndex.deletePackageId (packageId pkg) - update _ | installedConstraint == NoInstalledConstraint - = id - update pkg = case pkg of - InstalledOnly _ -> id - AvailableOnly _ -> PackageIndex.deletePackageId (packageId pkg) - InstalledAndAvailable i _ -> PackageIndex.insert (InstalledOnly i) - - -- Applying the constraint means adding exclusions for the packages that - -- we're just freshly excluding, ie the ones we're removing from available. - excluded' = foldl' (flip PackageIndex.insert) excluded - (newExcluded ++ oldExcluded) - - newExcluded = catMaybes (map exclude availableChoices) where - exclude pkg - | not (satisfiesVersionConstraint pkg) - = Just (ExcludedPackage pkgid [] [reason]) - | installedConstraint == NoInstalledConstraint - = Nothing - | otherwise = case pkg of - InstalledOnly _ -> Nothing - AvailableOnly _ -> Just (ExcludedPackage pkgid [] [reason]) - InstalledAndAvailable _ _ -> - case PackageIndex.lookupPackageId excluded pkgid of - Just (ExcludedPackage _ avail both) - -> Just (ExcludedPackage pkgid (reason:avail) both) - Nothing -> Just (ExcludedPackage pkgid [reason] []) - where pkgid = packageId pkg - - -- Additionally we have to add extra exclusions for any already-excluded - -- packages that happen to be covered by the (inverse of the) constraint. - oldExcluded = catMaybes (map exclude excludedChoices) where - exclude (ExcludedPackage pkgid avail both) - -- if it doesn't satisfy the version constraint then we exclude the - -- package as a whole, the available or the installed instances or both. - | not (satisfiesVersionConstraint pkgid) - = Just (ExcludedPackage pkgid avail (reason:both)) - -- if on the other hand it does satisfy the constraint and we were also - -- constraining to just the installed version then we exclude just the - -- available instance. - | installedConstraint == InstalledConstraint - = Just (ExcludedPackage pkgid (reason:avail) both) - | otherwise = Nothing - - -- util definitions - availableChoices = PackageIndex.lookupPackageName available name - excludedChoices = PackageIndex.lookupPackageName excluded name - - satisfiesConstraint pkg = satisfiesVersionConstraint pkg - && satisfiesInstallStateConstraint pkg - - satisfiesVersionConstraint :: Package pkg => pkg -> Bool - satisfiesVersionConstraint = case Map.lookup name paired of - Nothing -> \pkg -> - packageVersion pkg `withinRange` versionRange - Just (v1, v2) -> \pkg -> case packageVersion pkg of - v | v == v1 - || v == v2 -> v1 `withinRange` versionRange - || v2 `withinRange` versionRange - | otherwise -> v `withinRange` versionRange - - satisfiesInstallStateConstraint = case installedConstraint of - NoInstalledConstraint -> \_ -> True - InstalledConstraint -> \pkg -> case pkg of - AvailableOnly _ -> False - _ -> True - -conflicting :: (Package installed, Package available) - => Constraints installed available reason - -> Dependency - -> [(PackageIdentifier, [reason])] -conflicting (Constraints _ _ excluded _) dep = - [ (pkgid, reasonsAvail ++ reasonsAll) --TODO - | ExcludedPackage pkgid reasonsAvail reasonsAll <- - PackageIndex.lookupDependency excluded dep ] diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Types.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Types.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Types.hs +++ /dev/null @@ -1,93 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Dependency.TopDown.Types --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Types for the top-down dependency resolver. ------------------------------------------------------------------------------ -module Distribution.Client.Dependency.TopDown.Types where - -import Distribution.Client.Types - ( AvailablePackage(..), InstalledPackage ) - -import Distribution.Package - ( PackageIdentifier, Dependency - , Package(packageId), PackageFixedDeps(depends) ) -import Distribution.PackageDescription - ( FlagAssignment ) - --- ------------------------------------------------------------ --- * The various kinds of packages --- ------------------------------------------------------------ - -type SelectablePackage - = InstalledOrAvailable InstalledPackageEx UnconfiguredPackage - -type SelectedPackage - = InstalledOrAvailable InstalledPackageEx SemiConfiguredPackage - -data InstalledOrAvailable installed available - = InstalledOnly installed - | AvailableOnly available - | InstalledAndAvailable installed available - -type TopologicalSortNumber = Int - -data InstalledPackageEx - = InstalledPackageEx - InstalledPackage - !TopologicalSortNumber - [PackageIdentifier] -- transative closure of installed deps - -data UnconfiguredPackage - = UnconfiguredPackage - AvailablePackage - !TopologicalSortNumber - FlagAssignment - -data SemiConfiguredPackage - = SemiConfiguredPackage - AvailablePackage -- package info - FlagAssignment -- total flag assignment for the package - [Dependency] -- dependencies we end up with when we apply - -- the flag assignment - -instance Package InstalledPackageEx where - packageId (InstalledPackageEx p _ _) = packageId p - -instance PackageFixedDeps InstalledPackageEx where - depends (InstalledPackageEx _ _ deps) = deps - -instance Package UnconfiguredPackage where - packageId (UnconfiguredPackage p _ _) = packageId p - -instance Package SemiConfiguredPackage where - packageId (SemiConfiguredPackage p _ _) = packageId p - -instance (Package installed, Package available) - => Package (InstalledOrAvailable installed available) where - packageId (InstalledOnly p ) = packageId p - packageId (AvailableOnly p ) = packageId p - packageId (InstalledAndAvailable p _) = packageId p - --- ------------------------------------------------------------ --- * Tagged Dependency type --- ------------------------------------------------------------ - --- | Installed packages can only depend on other installed packages while --- packages that are not yet installed but which we plan to install can depend --- on installed or other not-yet-installed packages. --- --- This makes life more complex as we have to remember these constraints. --- -data TaggedDependency = TaggedDependency InstalledConstraint Dependency -data InstalledConstraint = InstalledConstraint | NoInstalledConstraint - deriving Eq - -untagDependency :: TaggedDependency -> Dependency -untagDependency (TaggedDependency _ dep) = dep diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/Types.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/Types.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/Types.hs +++ /dev/null @@ -1,114 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Dependency.Types --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Common types for dependency resolution. ------------------------------------------------------------------------------ -module Distribution.Client.Dependency.Types ( - DependencyResolver, - - PackageConstraint(..), - PackagePreferences(..), - InstalledPreference(..), - - Progress(..), - foldProgress, - ) where - -import Distribution.Client.Types - ( AvailablePackage(..), InstalledPackage ) -import qualified Distribution.Client.InstallPlan as InstallPlan - -import Distribution.PackageDescription - ( FlagAssignment ) -import Distribution.Client.PackageIndex - ( PackageIndex ) -import Distribution.Package - ( PackageName ) -import Distribution.Version - ( VersionRange ) -import Distribution.Compiler - ( CompilerId ) -import Distribution.System - ( Platform ) - -import Prelude hiding (fail) - --- | A dependency resolver is a function that works out an installation plan --- given the set of installed and available packages and a set of deps to --- solve for. --- --- The reason for this interface is because there are dozens of approaches to --- solving the package dependency problem and we want to make it easy to swap --- in alternatives. --- -type DependencyResolver = Platform - -> CompilerId - -> PackageIndex InstalledPackage - -> PackageIndex AvailablePackage - -> (PackageName -> PackagePreferences) - -> [PackageConstraint] - -> [PackageName] - -> Progress String String [InstallPlan.PlanPackage] - --- | Per-package constraints. Package constraints must be respected by the --- solver. Multiple constraints for each package can be given, though obviously --- it is possible to construct conflicting constraints (eg impossible version --- range or inconsistent flag assignment). --- -data PackageConstraint - = PackageVersionConstraint PackageName VersionRange - | PackageInstalledConstraint PackageName - | PackageFlagsConstraint PackageName FlagAssignment - --- | A per-package preference on the version. It is a soft constraint that the --- 'DependencyResolver' should try to respect where possible. It consists of --- a 'InstalledPreference' which says if we prefer versions of packages --- that are already installed. It also hase a 'PackageVersionPreference' which --- is a suggested constraint on the version number. The resolver should try to --- use package versions that satisfy the suggested version constraint. --- --- It is not specified if preferences on some packages are more important than --- others. --- -data PackagePreferences = PackagePreferences VersionRange InstalledPreference - --- | Wether we prefer an installed version of a package or simply the latest --- version. --- -data InstalledPreference = PreferInstalled | PreferLatest - --- | A type to represent the unfolding of an expensive long running --- calculation that may fail. We may get intermediate steps before the final --- retult which may be used to indicate progress and\/or logging messages. --- -data Progress step fail done = Step step (Progress step fail done) - | Fail fail - | Done done - --- | Consume a 'Progres' calculation. Much like 'foldr' for lists but with --- two base cases, one for a final result and one for failure. --- --- Eg to convert into a simple 'Either' result use: --- --- > foldProgress (flip const) Left Right --- -foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) - -> Progress step fail done -> a -foldProgress step fail done = fold - where fold (Step s p) = step s (fold p) - fold (Fail f) = fail f - fold (Done r) = done r - -instance Functor (Progress step fail) where - fmap f = foldProgress Step Fail (Done . f) - -instance Monad (Progress step fail) where - return a = Done a - p >>= f = foldProgress Step Fail f p diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Fetch.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Fetch.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Fetch.hs +++ /dev/null @@ -1,259 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Fetch --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- ------------------------------------------------------------------------------ -module Distribution.Client.Fetch ( - - -- * Commands - fetch, - - -- * Utilities - fetchPackage, - isFetched, - downloadIndex, - ) where - -import Distribution.Client.Types - ( UnresolvedDependency (..), AvailablePackage(..) - , AvailablePackageSource(..), AvailablePackageDb(..) - , Repo(..), RemoteRepo(..), LocalRepo(..) - , InstalledPackage ) -import Distribution.Client.PackageIndex (PackageIndex) -import Distribution.Client.Dependency as Dependency - ( resolveDependenciesWithProgress - , resolveAvailablePackages - , dependencyConstraints, dependencyTargets - , PackagesPreference(..), PackagesPreferenceDefault(..) - , PackagePreference(..) ) -import Distribution.Client.Dependency.Types - ( foldProgress ) -import Distribution.Client.IndexUtils as IndexUtils - ( getAvailablePackages, disambiguateDependencies - , getInstalledPackages ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.HttpUtils - ( downloadURI, isOldHackageURI ) -import Distribution.Client.Setup - ( FetchFlags(..) ) - -import Distribution.Package - ( PackageIdentifier, packageId, packageName, packageVersion - , Dependency(..) ) -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Simple.Compiler - ( Compiler(compilerId), PackageDBStack ) -import Distribution.Simple.Program - ( ProgramConfiguration ) -import Distribution.Simple.Setup - ( fromFlag ) -import Distribution.Simple.Utils - ( die, notice, info, debug, setupMessage ) -import Distribution.System - ( buildPlatform ) -import Distribution.Text - ( display ) -import Distribution.Verbosity - ( Verbosity ) - -import qualified Data.Map as Map -import Control.Monad - ( when, filterM ) -import System.Directory - ( doesFileExist, createDirectoryIfMissing ) -import System.FilePath - ( (), (<.>) ) -import qualified System.FilePath.Posix as FilePath.Posix - ( combine, joinPath ) -import Network.URI - ( URI(uriPath) ) - - --- Downloads a package to [config-dir/packages/package-id] and returns the path to the package. -downloadPackage :: Verbosity -> Repo -> PackageIdentifier -> IO String -downloadPackage _ repo@Repo{ repoKind = Right LocalRepo } pkgid = - return (packageFile repo pkgid) - -downloadPackage verbosity repo@Repo{ repoKind = Left remoteRepo } pkgid = do - let uri = packageURI remoteRepo pkgid - dir = packageDir repo pkgid - path = packageFile repo pkgid - debug verbosity $ "GET " ++ show uri - createDirectoryIfMissing True dir - downloadURI verbosity uri path - return path - --- Downloads an index file to [config-dir/packages/serv-id]. -downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO FilePath -downloadIndex verbosity repo cacheDir = do - let uri = (remoteRepoURI repo) { - uriPath = uriPath (remoteRepoURI repo) - `FilePath.Posix.combine` "00-index.tar.gz" - } - path = cacheDir "00-index" <.> "tar.gz" - createDirectoryIfMissing True cacheDir - downloadURI verbosity uri path - return path - --- |Returns @True@ if the package has already been fetched. -isFetched :: AvailablePackage -> IO Bool -isFetched (AvailablePackage pkgid _ source) = case source of - LocalUnpackedPackage _ -> return True - LocalTarballPackage _ -> return True - RemoteTarballPackage _ -> return False --TODO: ad-hoc download caching - RepoTarballPackage repo -> doesFileExist (packageFile repo pkgid) - --- |Fetch a package if we don't have it already. -fetchPackage :: Verbosity -> Repo -> PackageIdentifier -> IO String -fetchPackage verbosity repo pkgid = do - fetched <- doesFileExist (packageFile repo pkgid) - if fetched - then do info verbosity $ display pkgid ++ " has already been downloaded." - return (packageFile repo pkgid) - else do setupMessage verbosity "Downloading" pkgid - downloadPackage verbosity repo pkgid - --- |Fetch a list of packages and their dependencies. -fetch :: Verbosity - -> PackageDBStack - -> [Repo] - -> Compiler - -> ProgramConfiguration - -> FetchFlags - -> [UnresolvedDependency] - -> IO () -fetch verbosity _ _ _ _ _ [] = - notice verbosity "No packages requested. Nothing to do." - -fetch verbosity packageDBs repos comp conf flags deps = do - - installed <- getInstalledPackages verbosity comp packageDBs conf - availableDb@(AvailablePackageDb available _) - <- getAvailablePackages verbosity repos - deps' <- IndexUtils.disambiguateDependencies available deps - - pkgs <- resolvePackages verbosity - includeDeps comp - installed availableDb deps' - - pkgs' <- filterM (fmap not . isFetched) pkgs - when (null pkgs') $ - notice verbosity $ "No packages need to be fetched. " - ++ "All the requested packages are already cached." - if dryRun - then notice verbosity $ unlines $ - "The following packages would be fetched:" - : map (display . packageId) pkgs' - else sequence_ - [ fetchPackage verbosity repo pkgid - | (AvailablePackage pkgid _ (RepoTarballPackage repo)) <- pkgs' ] - where - includeDeps = fromFlag (fetchDeps flags) - dryRun = fromFlag (fetchDryRun flags) - - -resolvePackages - :: Verbosity - -> Bool - -> Compiler - -> PackageIndex InstalledPackage - -> AvailablePackageDb - -> [UnresolvedDependency] - -> IO [AvailablePackage] -resolvePackages verbosity includeDependencies comp - installed (AvailablePackageDb available availablePrefs) deps - - | includeDependencies = do - - notice verbosity "Resolving dependencies..." - plan <- foldProgress logMsg die return $ - resolveDependenciesWithProgress - buildPlatform (compilerId comp) - installed' available - preferences constraints - targets - --TODO: suggest using --no-deps, unpack or fetch -o - -- if cannot satisfy deps - --TODO: add commandline constraint and preference args for fetch - - return (selectPackagesToFetch plan) - - | otherwise = do - - either (die . unlines . map show) return $ - resolveAvailablePackages - installed available - preferences constraints - targets - - where - targets = dependencyTargets deps - constraints = dependencyConstraints deps - preferences = PackagesPreference - PreferLatestForSelected - [ PackageVersionPreference name ver - | (name, ver) <- Map.toList availablePrefs ] - - installed' = hideGivenDeps deps installed - - -- Hide the packages given on the command line so that the dep resolver - -- will decide that they need fetching, even if they're already - -- installed. Sicne we want to get the source packages of things we might - -- have installed (but not have the sources for). - - -- TODO: to allow for preferences on selecting an available version - -- corresponding to a package we've got installed, instead of hiding the - -- installed instances, we should add a constraint on using an installed - -- instance. - hideGivenDeps pkgs index = - foldr PackageIndex.deletePackageName index - [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ] - - -- The packages we want to fetch are those packages the 'InstallPlan' that - -- are in the 'InstallPlan.Configured' state. - selectPackagesToFetch :: InstallPlan.InstallPlan -> [AvailablePackage] - selectPackagesToFetch plan = - [ pkg | (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _)) - <- InstallPlan.toList plan ] - - logMsg message rest = info verbosity message >> rest - - --- |Generate the full path to the locally cached copy of --- the tarball for a given @PackageIdentifer@. -packageFile :: Repo -> PackageIdentifier -> FilePath -packageFile repo pkgid = packageDir repo pkgid - display pkgid - <.> "tar.gz" - --- |Generate the full path to the directory where the local cached copy of --- the tarball for a given @PackageIdentifer@ is stored. -packageDir :: Repo -> PackageIdentifier -> FilePath -packageDir repo pkgid = repoLocalDir repo - display (packageName pkgid) - display (packageVersion pkgid) - --- | Generate the URI of the tarball for a given package. -packageURI :: RemoteRepo -> PackageIdentifier -> URI -packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) = - (remoteRepoURI repo) { - uriPath = FilePath.Posix.joinPath - [uriPath (remoteRepoURI repo) - ,display (packageName pkgid) - ,display (packageVersion pkgid) - ,display pkgid <.> "tar.gz"] - } -packageURI repo pkgid = - (remoteRepoURI repo) { - uriPath = FilePath.Posix.joinPath - [uriPath (remoteRepoURI repo) - ,"package" - ,display pkgid <.> "tar.gz"] - } diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/GZipUtils.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/GZipUtils.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/GZipUtils.hs +++ /dev/null @@ -1,44 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.GZipUtils --- Copyright : (c) Dmitry Astapov 2010 --- License : BSD-like --- --- Maintainer : cabal-devel@gmail.com --- Stability : provisional --- Portability : portable --- --- Provides a convenience functions for working with files that may or may not --- be zipped. ------------------------------------------------------------------------------ -module Distribution.Client.GZipUtils ( - maybeDecompress, - ) where - -import qualified Data.ByteString.Lazy.Internal as BS (ByteString(..)) -import Data.ByteString.Lazy (ByteString) -import Codec.Compression.GZip -import Codec.Compression.Zlib.Internal - --- | Attempts to decompress the `bytes' under the assumption that --- "data format" error at the very beginning of the stream means --- that it is already decompressed. Caller should make sanity checks --- to verify that it is not, in fact, garbage. --- --- This is to deal with http proxies that lie to us and transparently --- decompress without removing the content-encoding header. See: --- --- -maybeDecompress :: ByteString -> ByteString -maybeDecompress bytes = foldStream $ decompressWithErrors gzipOrZlibFormat defaultDecompressParams bytes - where - -- DataError at the beginning of the stream probably means that stream is not compressed. - -- Returning it as-is. - -- TODO: alternatively, we might consider looking for the two magic bytes - -- at the beginning of the gzip header. - foldStream (StreamError DataError _) = bytes - foldStream somethingElse = doFold somethingElse - - doFold StreamEnd = BS.Empty - doFold (StreamChunk bs stream) = BS.Chunk bs (doFold stream) - doFold (StreamError _ msg) = error $ "Codec.Compression.Zlib: " ++ msg diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Haddock.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Haddock.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Haddock.hs +++ /dev/null @@ -1,105 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Haddock --- Copyright : (c) Andrea Vezzosi 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Interfacing with Haddock --- ------------------------------------------------------------------------------ -module Distribution.Client.Haddock - ( - regenerateHaddockIndex - ) - where - -import Data.Maybe (listToMaybe) -import Data.List (maximumBy) -import Control.Monad (guard) -import System.Directory (createDirectoryIfMissing, doesFileExist, - renameFile) -import System.FilePath ((), splitFileName) -import Distribution.Package (Package(..)) -import Distribution.Simple.Program (haddockProgram, ProgramConfiguration - , rawSystemProgram, requireProgramVersion) -import Distribution.Version (Version(Version), orLaterVersion) -import Distribution.Verbosity (Verbosity) -import Distribution.Text (display) -import Distribution.Client.PackageIndex(PackageIndex, allPackages, - allPackagesByName, fromList) -import Distribution.Simple.Utils - ( comparing, intercalate, debug - , installDirectoryContents, withTempDirectory ) -import Distribution.InstalledPackageInfo as InstalledPackageInfo - ( InstalledPackageInfo - , InstalledPackageInfo_(haddockHTMLs, haddockInterfaces, exposed) ) -import Distribution.Client.Types - ( InstalledPackage(..) ) - -regenerateHaddockIndex :: Verbosity -> PackageIndex InstalledPackage -> ProgramConfiguration -> FilePath -> IO () -regenerateHaddockIndex verbosity pkgs conf index = do - (paths,warns) <- haddockPackagePaths pkgs' - case warns of - Nothing -> return () - Just m -> debug verbosity m - - (confHaddock, _, _) <- - requireProgramVersion verbosity haddockProgram - (orLaterVersion (Version [0,6] [])) conf - - createDirectoryIfMissing True destDir - - withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do - - let flags = [ "--gen-contents" - , "--gen-index" - , "--odir=" ++ tempDir - , "--title=Haskell modules on this system" ] - ++ [ "--read-interface=" ++ html ++ "," ++ interface - | (interface, html) <- paths ] - rawSystemProgram verbosity confHaddock flags - renameFile (tempDir "index.html") (tempDir destFile) - installDirectoryContents verbosity tempDir destDir - - where - (destDir,destFile) = splitFileName index - pkgs' = map (maximumBy $ comparing packageId) - . allPackagesByName - . fromList - . filter exposed - . map (\(InstalledPackage pkg _) -> pkg) - . allPackages - $ pkgs - -haddockPackagePaths :: [InstalledPackageInfo] - -> IO ([(FilePath, FilePath)], Maybe String) -haddockPackagePaths pkgs = do - interfaces <- sequence - [ case interfaceAndHtmlPath pkg of - Just (interface, html) -> do - exists <- doesFileExist interface - if exists - then return (pkgid, Just (interface, html)) - else return (pkgid, Nothing) - Nothing -> return (pkgid, Nothing) - | pkg <- pkgs, let pkgid = packageId pkg ] - - let missing = [ pkgid | (pkgid, Nothing) <- interfaces ] - - warning = "The documentation for the following packages are not " - ++ "installed. No links will be generated to these packages: " - ++ intercalate ", " (map display missing) - - flags = [ x | (_, Just x) <- interfaces ] - - return (flags, if null missing then Nothing else Just warning) - - where - interfaceAndHtmlPath pkg = do - interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg) - html <- listToMaybe (InstalledPackageInfo.haddockHTMLs pkg) - guard (not . null $ html) - return (interface, html) diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/HttpUtils.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/HttpUtils.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/HttpUtils.hs +++ /dev/null @@ -1,197 +0,0 @@ -{-# OPTIONS -cpp #-} ------------------------------------------------------------------------------ --- | Separate module for HTTP actions, using a proxy server if one exists ------------------------------------------------------------------------------ -module Distribution.Client.HttpUtils ( - downloadURI, - getHTTP, - proxy, - isOldHackageURI - ) where - -import Network.HTTP - ( Request (..), Response (..), RequestMethod (..) - , Header(..), HeaderName(..) ) -import Network.URI - ( URI (..), URIAuth (..), parseAbsoluteURI ) -import Network.Stream - ( Result, ConnError(..) ) -import Network.Browser - ( Proxy (..), Authority (..), browse - , setOutHandler, setErrHandler, setProxy, request) -import Control.Monad - ( mplus, join, liftM2 ) -import qualified Data.ByteString.Lazy.Char8 as ByteString -import Data.ByteString.Lazy (ByteString) -#ifdef WIN32 -import System.Win32.Types - ( DWORD, HKEY ) -import System.Win32.Registry - ( hKEY_CURRENT_USER, regOpenKey, regCloseKey - , regQueryValue, regQueryValueEx ) -import Control.Exception - ( bracket ) -import Distribution.Compat.Exception - ( handleIO ) -import Foreign - ( toBool, Storable(peek, sizeOf), castPtr, alloca ) -#endif -import System.Environment (getEnvironment) - -import qualified Paths_cabal_install (version) -import Distribution.Verbosity (Verbosity) -import Distribution.Simple.Utils - ( die, info, warn, debug - , copyFileVerbose, writeFileAtomic ) -import Distribution.Text - ( display ) -import qualified System.FilePath.Posix as FilePath.Posix - ( splitDirectories ) - --- FIXME: all this proxy stuff is far too complicated, especially parsing --- the proxy strings. Network.Browser should have a way to pick up the --- proxy settings hiding all this system-dependent stuff below. - --- try to read the system proxy settings on windows or unix -proxyString, envProxyString, registryProxyString :: IO (Maybe String) -#ifdef WIN32 --- read proxy settings from the windows registry -registryProxyString = handleIO (\_ -> return Nothing) $ - bracket (regOpenKey hive path) regCloseKey $ \hkey -> do - enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable" - if enable - then fmap Just $ regQueryValue hkey (Just "ProxyServer") - else return Nothing - where - -- some sources say proxy settings should be at - -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows - -- \CurrentVersion\Internet Settings\ProxyServer - -- but if the user sets them with IE connection panel they seem to - -- end up in the following place: - hive = hKEY_CURRENT_USER - path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings" - - regQueryValueDWORD :: HKEY -> String -> IO DWORD - regQueryValueDWORD hkey name = alloca $ \ptr -> do - regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD)) - peek ptr -#else -registryProxyString = return Nothing -#endif - --- read proxy settings by looking for an env var -envProxyString = do - env <- getEnvironment - return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env) - -proxyString = liftM2 mplus envProxyString registryProxyString - - --- |Get the local proxy settings -proxy :: Verbosity -> IO Proxy -proxy verbosity = do - mstr <- proxyString - case mstr of - Nothing -> return NoProxy - Just str -> case parseHttpProxy str of - Nothing -> do - warn verbosity $ "invalid http proxy uri: " ++ show str - warn verbosity $ "proxy uri must be http with a hostname" - warn verbosity $ "ignoring http proxy, trying a direct connection" - return NoProxy - Just p -> return p ---TODO: print info message when we're using a proxy - --- | We need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@ --- which lack the @\"http://\"@ URI scheme. The problem is that --- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme --- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@. --- --- So our strategy is to try parsing as normal uri first and if it lacks the --- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix. --- -parseHttpProxy :: String -> Maybe Proxy -parseHttpProxy str = join - . fmap uri2proxy - $ parseHttpURI str - `mplus` parseHttpURI ("http://" ++ str) - where - parseHttpURI str' = case parseAbsoluteURI str' of - Just uri@URI { uriAuthority = Just _ } - -> Just (fixUserInfo uri) - _ -> Nothing - -fixUserInfo :: URI -> URI -fixUserInfo uri = uri{ uriAuthority = f `fmap` uriAuthority uri } - where - f a@URIAuth{ uriUserInfo = s } = - a{ uriUserInfo = case reverse s of - '@':s' -> reverse s' - _ -> s - } -uri2proxy :: URI -> Maybe Proxy -uri2proxy uri@URI{ uriScheme = "http:" - , uriAuthority = Just (URIAuth auth' host port) - } = Just (Proxy (host ++ port) auth) - where auth = if null auth' - then Nothing - else Just (AuthBasic "" usr pwd uri) - (usr,pwd') = break (==':') auth' - pwd = case pwd' of - ':':cs -> cs - _ -> pwd' -uri2proxy _ = Nothing - -mkRequest :: URI -> Request ByteString -mkRequest uri = Request{ rqURI = uri - , rqMethod = GET - , rqHeaders = [Header HdrUserAgent userAgent] - , rqBody = ByteString.empty } - where userAgent = "cabal-install/" ++ display Paths_cabal_install.version - --- |Carry out a GET request, using the local proxy settings -getHTTP :: Verbosity -> URI -> IO (Result (Response ByteString)) -getHTTP verbosity uri = do - p <- proxy verbosity - let req = mkRequest uri - (_, resp) <- browse $ do - setErrHandler (warn verbosity . ("http error: "++)) - setOutHandler (debug verbosity) - setProxy p - request req - return (Right resp) - -downloadURI :: Verbosity - -> URI -- ^ What to download - -> FilePath -- ^ Where to put it - -> IO () -downloadURI verbosity uri path | uriScheme uri == "file:" = - copyFileVerbose verbosity (uriPath uri) path -downloadURI verbosity uri path = do - result <- getHTTP verbosity uri - let result' = case result of - Left err -> Left err - Right rsp -> case rspCode rsp of - (2,0,0) -> Right (rspBody rsp) - (a,b,c) -> Left err - where - err = ErrorMisc $ "Unsucessful HTTP code: " - ++ concatMap show [a,b,c] - - case result' of - Left err -> die $ "Failed to download " ++ show uri ++ " : " ++ show err - Right body -> do - info verbosity ("Downloaded to " ++ path) - writeFileAtomic path (ByteString.unpack body) - --FIXME: check the content-length header matches the body length. - --TODO: stream the download into the file rather than buffering the whole - -- thing in memory. - -- remember the ETag so we can not re-download if nothing changed. - --- Utility function for legacy support. -isOldHackageURI :: URI -> Bool -isOldHackageURI uri - = case uriAuthority uri of - Just (URIAuth {uriRegName = "hackage.haskell.org"}) -> - FilePath.Posix.splitDirectories (uriPath uri) == ["/","packages","archive"] - _ -> False diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/IndexUtils.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/IndexUtils.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/IndexUtils.hs +++ /dev/null @@ -1,299 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.IndexUtils --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : duncan@haskell.org --- Stability : provisional --- Portability : portable --- --- Extra utils related to the package indexes. ------------------------------------------------------------------------------ -module Distribution.Client.IndexUtils ( - getInstalledPackages, - getAvailablePackages, - - readPackageIndexFile, - parseRepoIndex, - - disambiguatePackageName, - disambiguateDependencies - ) where - -import qualified Distribution.Client.Tar as Tar -import Distribution.Client.Types - ( UnresolvedDependency(..), AvailablePackage(..) - , AvailablePackageSource(..), Repo(..), RemoteRepo(..) - , AvailablePackageDb(..), InstalledPackage(..) ) - -import Distribution.Package - ( PackageId, PackageIdentifier(..), PackageName(..), Package(..) - , Dependency(Dependency), InstalledPackageId(..) ) -import Distribution.Client.PackageIndex (PackageIndex) -import qualified Distribution.Client.PackageIndex as PackageIndex -import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo -import Distribution.PackageDescription - ( GenericPackageDescription ) -import Distribution.PackageDescription.Parse - ( parsePackageDescription ) -import Distribution.Simple.Compiler - ( Compiler, PackageDBStack ) -import Distribution.Simple.Program - ( ProgramConfiguration ) -import qualified Distribution.Simple.Configure as Configure - ( getInstalledPackages ) -import Distribution.ParseUtils - ( ParseResult(..) ) -import Distribution.Version - ( Version(Version), intersectVersionRanges ) -import Distribution.Text - ( display, simpleParse ) -import Distribution.Verbosity (Verbosity) -import Distribution.Simple.Utils (die, warn, info, intercalate, fromUTF8) - -import Data.Maybe (catMaybes, fromMaybe) -import Data.List (isPrefixOf) -import Data.Monoid (Monoid(..)) -import qualified Data.Map as Map -import Control.Monad (MonadPlus(mplus), when) -import Control.Exception (evaluate) -import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -import Data.ByteString.Lazy (ByteString) -import Distribution.Client.GZipUtils (maybeDecompress) -import System.FilePath ((), takeExtension, splitDirectories, normalise) -import System.FilePath.Posix as FilePath.Posix - ( takeFileName ) -import System.IO.Error (isDoesNotExistError) -import System.Directory - ( getModificationTime ) -import System.Time - ( getClockTime, diffClockTimes, normalizeTimeDiff, TimeDiff(tdDay) ) - -getInstalledPackages :: Verbosity -> Compiler - -> PackageDBStack -> ProgramConfiguration - -> IO (PackageIndex InstalledPackage) -getInstalledPackages verbosity comp packageDbs conf = - fmap convert (Configure.getInstalledPackages verbosity comp packageDbs conf) - where - convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage - convert index = PackageIndex.fromList $ - reverse -- because later ones mask earlier ones, but - -- InstalledPackageIndex.allPackages gives us the most preferred - -- instances first, when packages share a package id, like when - -- the same package is installed in the global & user dbs. - [ InstalledPackage ipkg (sourceDeps index ipkg) - | ipkg <- InstalledPackageIndex.allPackages index ] - - -- The InstalledPackageInfo only lists dependencies by the - -- InstalledPackageId, which means we do not directly know the corresponding - -- source dependency. The only way to find out is to lookup the - -- InstalledPackageId to get the InstalledPackageInfo and look at its - -- source PackageId. But if the package is broken because it depends on - -- other packages that do not exist then we have a problem we cannot find - -- the original source package id. Instead we make up a bogus package id. - -- This should have the same effect since it should be a dependency on a - -- non-existant package. - sourceDeps index ipkg = - [ maybe (brokenPackageId depid) packageId mdep - | let depids = InstalledPackageInfo.depends ipkg - getpkg = InstalledPackageIndex.lookupInstalledPackageId index - , (depid, mdep) <- zip depids (map getpkg depids) ] - - brokenPackageId (InstalledPackageId str) = - PackageIdentifier (PackageName (str ++ "-broken")) (Version [] []) - --- | Read a repository index from disk, from the local files specified by --- a list of 'Repo's. --- --- All the 'AvailablePackage's are marked as having come from the appropriate --- 'Repo'. --- --- This is a higher level wrapper used internally in cabal-install. --- -getAvailablePackages :: Verbosity -> [Repo] -> IO AvailablePackageDb -getAvailablePackages verbosity [] = do - warn verbosity $ "No remote package servers have been specified. Usually " - ++ "you would have one specified in the config file." - return AvailablePackageDb { - packageIndex = mempty, - packagePreferences = mempty - } -getAvailablePackages verbosity repos = do - info verbosity "Reading available packages..." - pkgss <- mapM (readRepoIndex verbosity) repos - let (pkgs, prefs) = mconcat pkgss - prefs' = Map.fromListWith intersectVersionRanges - [ (name, range) | Dependency name range <- prefs ] - _ <- evaluate pkgs - _ <- evaluate prefs' - return AvailablePackageDb { - packageIndex = pkgs, - packagePreferences = prefs' - } - --- | Read a repository index from disk, from the local file specified by --- the 'Repo'. --- --- All the 'AvailablePackage's are marked as having come from the given 'Repo'. --- --- This is a higher level wrapper used internally in cabal-install. --- -readRepoIndex :: Verbosity -> Repo - -> IO (PackageIndex AvailablePackage, [Dependency]) -readRepoIndex verbosity repo = handleNotFound $ do - let indexFile = repoLocalDir repo "00-index.tar" - (pkgs, prefs) <- either fail return - . foldlTarball extract ([], []) - =<< BS.readFile indexFile - - pkgIndex <- evaluate $ PackageIndex.fromList - [ AvailablePackage { - packageInfoId = pkgid, - packageDescription = pkg, - packageSource = RepoTarballPackage repo - } - | (pkgid, pkg) <- pkgs] - - warnIfIndexIsOld indexFile - return (pkgIndex, prefs) - - where - extract (pkgs, prefs) entry = fromMaybe (pkgs, prefs) $ - (do pkg <- extractPkg entry; return (pkg:pkgs, prefs)) - `mplus` (do prefs' <- extractPrefs entry; return (pkgs, prefs'++prefs)) - - extractPrefs :: Tar.Entry -> Maybe [Dependency] - extractPrefs entry = case Tar.entryContent entry of - Tar.NormalFile content _ - | takeFileName (Tar.entryPath entry) == "preferred-versions" - -> Just . parsePreferredVersions - . BS.Char8.unpack $ content - _ -> Nothing - - handleNotFound action = catch action $ \e -> if isDoesNotExistError e - then do - case repoKind repo of - Left remoteRepo -> warn verbosity $ - "The package list for '" ++ remoteRepoName remoteRepo - ++ "' does not exist. Run 'hackport update' to download it." - Right _localRepo -> warn verbosity $ - "The package list for the local repo '" ++ repoLocalDir repo - ++ "' is missing. The repo is invalid." - return mempty - else ioError e - - isOldThreshold = 15 --days - warnIfIndexIsOld indexFile = do - indexTime <- getModificationTime indexFile - currentTime <- getClockTime - let diff = normalizeTimeDiff (diffClockTimes currentTime indexTime) - when (tdDay diff >= isOldThreshold) $ case repoKind repo of - Left remoteRepo -> warn verbosity $ - "The package list for '" ++ remoteRepoName remoteRepo - ++ "' is " ++ show (tdDay diff) ++ " days old.\nRun " - ++ "'hackport update' to get the latest list of available packages." - Right _localRepo -> return () - -parsePreferredVersions :: String -> [Dependency] -parsePreferredVersions = catMaybes - . map simpleParse - . filter (not . isPrefixOf "--") - . lines - --- | Read a compressed \"00-index.tar.gz\" file into a 'PackageIndex'. --- --- This is supposed to be an \"all in one\" way to easily get at the info in --- the hackage package index. --- --- It takes a function to map a 'GenericPackageDescription' into any more --- specific instance of 'Package' that you might want to use. In the simple --- case you can just use @\_ p -> p@ here. --- -readPackageIndexFile :: Package pkg - => (PackageId -> GenericPackageDescription -> pkg) - -> FilePath -> IO (PackageIndex pkg) -readPackageIndexFile mkPkg indexFile = do - pkgs <- either fail return - . parseRepoIndex - . maybeDecompress - =<< BS.readFile indexFile - - evaluate $ PackageIndex.fromList - [ mkPkg pkgid pkg | (pkgid, pkg) <- pkgs] - --- | Parse an uncompressed \"00-index.tar\" repository index file represented --- as a 'ByteString'. --- -parseRepoIndex :: ByteString - -> Either String [(PackageId, GenericPackageDescription)] -parseRepoIndex = foldlTarball (\pkgs -> maybe pkgs (:pkgs) . extractPkg) [] - -extractPkg :: Tar.Entry -> Maybe (PackageId, GenericPackageDescription) -extractPkg entry = case Tar.entryContent entry of - Tar.NormalFile content _ - | takeExtension fileName == ".cabal" - -> case splitDirectories (normalise fileName) of - [pkgname,vers,_] -> case simpleParse vers of - Just ver -> Just (pkgid, descr) - where - pkgid = PackageIdentifier (PackageName pkgname) ver - parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack - $ content - descr = case parsed of - ParseOk _ d -> d - _ -> error $ "Couldn't read cabal file " - ++ show fileName - _ -> Nothing - _ -> Nothing - _ -> Nothing - where - fileName = Tar.entryPath entry - -foldlTarball :: (a -> Tar.Entry -> a) -> a - -> ByteString -> Either String a -foldlTarball f z = either Left (Right . foldl f z) . check [] . Tar.read - where - check _ (Tar.Fail err) = Left err - check ok Tar.Done = Right ok - check ok (Tar.Next e es) = check (e:ok) es - --- | Disambiguate a set of packages using 'disambiguatePackage' and report any --- ambiguities to the user. --- -disambiguateDependencies :: PackageIndex AvailablePackage - -> [UnresolvedDependency] - -> IO [UnresolvedDependency] -disambiguateDependencies index deps = do - let names = [ (name, disambiguatePackageName index name) - | UnresolvedDependency (Dependency name _) _ <- deps ] - in case [ (name, matches) | (name, Right matches) <- names ] of - [] -> return - [ UnresolvedDependency (Dependency name vrange) flags - | (UnresolvedDependency (Dependency _ vrange) flags, - (_, Left name)) <- zip deps names ] - ambigious -> die $ unlines - [ if null matches - then "There is no package named " ++ display name ++ ". " - ++ "Perhaps you need to run 'hackport update' first?" - else "The package name " ++ display name ++ "is ambigious. " - ++ "It could be: " ++ intercalate ", " (map display matches) - | (name, matches) <- ambigious ] - --- | Given an index of known packages and a package name, figure out which one it --- might be referring to. If there is an exact case-sensitive match then that's --- ok. If it matches just one package case-insensitively then that's also ok. --- The only problem is if it matches multiple packages case-insensitively, in --- that case it is ambigious. --- -disambiguatePackageName :: PackageIndex AvailablePackage - -> PackageName - -> Either PackageName [PackageName] -disambiguatePackageName index (PackageName name) = - case PackageIndex.searchByName index name of - PackageIndex.None -> Right [] - PackageIndex.Unambiguous pkgs -> Left (pkgName (packageId (head pkgs))) - PackageIndex.Ambiguous pkgss -> Right [ pkgName (packageId pkg) - | (pkg:_) <- pkgss ] diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Init.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Init.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Init.hs +++ /dev/null @@ -1,556 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init --- Copyright : (c) Brent Yorgey 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Implementation of the 'cabal init' command, which creates an initial .cabal --- file for a project. --- ------------------------------------------------------------------------------ - -module Distribution.Client.Init ( - - -- * Commands - initCabal - - ) where - -import System.IO - ( hSetBuffering, stdout, BufferMode(..) ) -import System.Directory - ( getCurrentDirectory ) -import Data.Time - ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) - -import Data.List - ( intersperse ) -import Data.Maybe - ( fromMaybe, isJust ) -import Data.Traversable - ( traverse ) -import Control.Monad - ( when ) -#if MIN_VERSION_base(3,0,0) -import Control.Monad - ( (>=>) ) -#endif - -import Text.PrettyPrint.HughesPJ hiding (mode, cat) - -import Data.Version - ( Version(..) ) -import Distribution.Version - ( orLaterVersion ) - -import Distribution.Client.Init.Types - ( InitFlags(..), PackageType(..), Category(..) ) -import Distribution.Client.Init.Licenses - ( bsd3, gplv2, gplv3, lgpl2, lgpl3 ) -import Distribution.Client.Init.Heuristics - ( guessPackageName, guessAuthorNameMail, SourceFileEntry(..), scanForModules, neededBuildPrograms ) - -import Distribution.License - ( License(..), knownLicenses ) -import Distribution.ModuleName - ( ) -- for the Text instance - -import Distribution.ReadE - ( runReadE, readP_to_E ) -import Distribution.Simple.Setup - ( Flag(..), flagToMaybe ) -import Distribution.Text - ( display, Text(..) ) - -initCabal :: InitFlags -> IO () -initCabal initFlags = do - hSetBuffering stdout NoBuffering - - initFlags' <- extendFlags initFlags - - writeLicense initFlags' - writeSetupFile initFlags' - success <- writeCabalFile initFlags' - - when success $ generateWarnings initFlags' - ---------------------------------------------------------------------------- --- Flag acquisition ----------------------------------------------------- ---------------------------------------------------------------------------- - --- | Fill in more details by guessing, discovering, or prompting the --- user. -extendFlags :: InitFlags -> IO InitFlags -extendFlags = getPackageName - >=> getVersion - >=> getLicense - >=> getAuthorInfo - >=> getHomepage - >=> getSynopsis - >=> getCategory - >=> getLibOrExec - >=> getSrcDir - >=> getModulesAndBuildTools - --- | Combine two actions which may return a value, preferring the first. That --- is, run the second action only if the first doesn't return a value. -infixr 1 ?>> -(?>>) :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a) -f ?>> g = do - ma <- f - if isJust ma - then return ma - else g - --- | Witness the isomorphism between Maybe and Flag. -maybeToFlag :: Maybe a -> Flag a -maybeToFlag = maybe NoFlag Flag - --- | Get the package name: use the package directory (supplied, or the current --- directory by default) as a guess. -getPackageName :: InitFlags -> IO InitFlags -getPackageName flags = do - guess <- traverse guessPackageName (flagToMaybe $ packageDir flags) - ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName) - - pkgName' <- return (flagToMaybe $ packageName flags) - ?>> maybePrompt flags (promptStr "Package name" guess) - ?>> return guess - - return $ flags { packageName = maybeToFlag pkgName' } - --- | Package version: use 0.1 as a last resort, but try prompting the user if --- possible. -getVersion :: InitFlags -> IO InitFlags -getVersion flags = do - let v = Just $ Version { versionBranch = [0,1], versionTags = [] } - v' <- return (flagToMaybe $ version flags) - ?>> maybePrompt flags (prompt "Package version" v) - ?>> return v - return $ flags { version = maybeToFlag v' } - --- | Choose a license. -getLicense :: InitFlags -> IO InitFlags -getLicense flags = do - lic <- return (flagToMaybe $ license flags) - ?>> fmap (fmap (either UnknownLicense id)) - (maybePrompt flags - (promptList "Please choose a license" - knownLicenses (Just BSD3) True)) - return $ flags { license = maybeToFlag lic } - --- | The author's name and email. Prompt, or try to guess from an existing --- darcs repo. -getAuthorInfo :: InitFlags -> IO InitFlags -getAuthorInfo flags = do - (authorName, authorEmail) <- (\(a,e) -> (flagToMaybe a, flagToMaybe e)) `fmap` guessAuthorNameMail - authorName' <- return (flagToMaybe $ author flags) - ?>> maybePrompt flags (promptStr "Author name" authorName) - ?>> return authorName - - authorEmail' <- return (flagToMaybe $ email flags) - ?>> maybePrompt flags (promptStr "Maintainer email" authorEmail) - ?>> return authorEmail - - return $ flags { author = maybeToFlag authorName' - , email = maybeToFlag authorEmail' - } - --- | Prompt for a homepage URL. -getHomepage :: InitFlags -> IO InitFlags -getHomepage flags = do - hp <- queryHomepage - hp' <- return (flagToMaybe $ homepage flags) - ?>> maybePrompt flags (promptStr "Project homepage/repo URL" hp) - ?>> return hp - - return $ flags { homepage = maybeToFlag hp' } - --- | Right now this does nothing, but it could be changed to do some --- intelligent guessing. -queryHomepage :: IO (Maybe String) -queryHomepage = return Nothing -- get default remote darcs repo? - --- | Prompt for a project synopsis. -getSynopsis :: InitFlags -> IO InitFlags -getSynopsis flags = do - syn <- return (flagToMaybe $ synopsis flags) - ?>> maybePrompt flags (promptStr "Project synopsis" Nothing) - - return $ flags { synopsis = maybeToFlag syn } - --- | Prompt for a package category. --- Note that it should be possible to do some smarter guessing here too, i.e. --- look at the name of the top level source directory. -getCategory :: InitFlags -> IO InitFlags -getCategory flags = do - cat <- return (flagToMaybe $ category flags) - ?>> maybePrompt flags (promptList "Project category" [Codec ..] - Nothing True) - return $ flags { category = maybeToFlag cat } - --- | Ask whether the project builds a library or executable. -getLibOrExec :: InitFlags -> IO InitFlags -getLibOrExec flags = do - isLib <- return (flagToMaybe $ packageType flags) - ?>> maybePrompt flags (either (const Library) id `fmap` - (promptList "What does the package build" - [Library, Executable] - Nothing False)) - ?>> return (Just Library) - - return $ flags { packageType = maybeToFlag isLib } - --- | Try to guess the source root directory (don't prompt the user). -getSrcDir :: InitFlags -> IO InitFlags -getSrcDir flags = do - srcDirs <- return (sourceDirs flags) - ?>> guessSourceDirs - - return $ flags { sourceDirs = srcDirs } - --- XXX --- | Try to guess source directories. -guessSourceDirs :: IO (Maybe [String]) -guessSourceDirs = return Nothing - --- | Get the list of exposed modules and extra tools needed to build them. -getModulesAndBuildTools :: InitFlags -> IO InitFlags -getModulesAndBuildTools flags = do - dir <- fromMaybe getCurrentDirectory - (fmap return . flagToMaybe $ packageDir flags) - - -- XXX really should use guessed source roots. - sourceFiles <- scanForModules dir - - mods <- return (exposedModules flags) - ?>> (return . Just . map moduleName $ sourceFiles) - - tools <- return (buildTools flags) - ?>> (return . Just . neededBuildPrograms $ sourceFiles) - - return $ flags { exposedModules = mods - , buildTools = tools } - ---------------------------------------------------------------------------- --- Prompting/user interaction ------------------------------------------- ---------------------------------------------------------------------------- - --- | Run a prompt or not based on the nonInteractive flag of the --- InitFlags structure. -maybePrompt :: InitFlags -> IO t -> IO (Maybe t) -maybePrompt flags p = - case nonInteractive flags of - Flag True -> return Nothing - _ -> Just `fmap` p - --- | Create a prompt with optional default value that returns a --- String. -promptStr :: String -> Maybe String -> IO String -promptStr = promptDefault' Just id - --- | Create a prompt with optional default value that returns a value --- of some Text instance. -prompt :: Text t => String -> Maybe t -> IO t -prompt = promptDefault' - (either (const Nothing) Just . runReadE (readP_to_E id parse)) - display - --- | Create a prompt with an optional default value. -promptDefault' :: (String -> Maybe t) -- ^ parser - -> (t -> String) -- ^ pretty-printer - -> String -- ^ prompt message - -> Maybe t -- ^ optional default value - -> IO t -promptDefault' parser pretty pr def = do - putStr $ mkDefPrompt pr (pretty `fmap` def) - inp <- getLine - case (inp, def) of - ("", Just d) -> return d - _ -> case parser inp of - Just t -> return t - Nothing -> do putStrLn $ "Couldn't parse " ++ inp ++ ", please try again!" - promptDefault' parser pretty pr def - --- | Create a prompt from a prompt string and a String representation --- of an optional default value. -mkDefPrompt :: String -> Maybe String -> String -mkDefPrompt pr def = pr ++ defStr def ++ "? " - where defStr Nothing = "" - defStr (Just s) = " [default \"" ++ s ++ "\"]" - --- | Create a prompt from a list of items. -promptList :: (Text t, Eq t) - => String -- ^ prompt - -> [t] -- ^ choices - -> Maybe t -- ^ optional default value - -> Bool -- ^ whether to allow an 'other' option - -> IO (Either String t) -promptList pr choices def other = do - putStrLn $ pr ++ ":" - let options1 = map (\c -> (Just c == def, display c)) choices - options2 = zip ([1..]::[Int]) - (options1 ++ if other then [(False, "Other (specify)")] - else []) - mapM_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2 - promptList' (length options2) choices def other - where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest - | otherwise = " " ++ star i ++ rest - where rest = show n ++ ") " - star True = "*" - star False = " " - -promptList' :: Text t => Int -> [t] -> Maybe t -> Bool -> IO (Either String t) -promptList' numChoices choices def other = do - putStr $ mkDefPrompt "Your choice" (display `fmap` def) - inp <- getLine - case (inp, def) of - ("", Just d) -> return $ Right d - _ -> case readMaybe inp of - Nothing -> invalidChoice inp - Just n -> getChoice n - where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice." - promptList' numChoices choices def other - getChoice n | n < 1 || n > numChoices = invalidChoice (show n) - | n < numChoices || - (n == numChoices && not other) - = return . Right $ choices !! (n-1) - | otherwise = Left `fmap` promptStr "Please specify" Nothing - -readMaybe :: (Read a) => String -> Maybe a -readMaybe s = case reads s of - [(a,"")] -> Just a - _ -> Nothing - ---------------------------------------------------------------------------- --- File generation ------------------------------------------------------ ---------------------------------------------------------------------------- - -writeLicense :: InitFlags -> IO () -writeLicense flags = do - message flags "Generating LICENSE..." - year <- getYear - let licenseFile = - case license flags of - Flag BSD3 -> Just $ bsd3 (fromMaybe "???" - . flagToMaybe - . author - $ flags) - (show year) - - Flag (GPL (Just (Version {versionBranch = [2]}))) - -> Just gplv2 - - Flag (GPL (Just (Version {versionBranch = [3]}))) - -> Just gplv3 - - Flag (LGPL (Just (Version {versionBranch = [2]}))) - -> Just lgpl2 - - Flag (LGPL (Just (Version {versionBranch = [3]}))) - -> Just lgpl3 - - _ -> Nothing - - case licenseFile of - Just licenseText -> writeFile "LICENSE" licenseText - Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself." - -getYear :: IO Integer -getYear = do - u <- getCurrentTime - z <- getCurrentTimeZone - let l = utcToLocalTime z u - (y, _, _) = toGregorian $ localDay l - return y - -writeSetupFile :: InitFlags -> IO () -writeSetupFile flags = do - message flags "Generating Setup.hs..." - writeFile "Setup.hs" setupFile - where - setupFile = unlines - [ "import Distribution.Simple" - , "main = defaultMain" - ] - -writeCabalFile :: InitFlags -> IO Bool -writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do - message flags "Error: no package name provided." - return False -writeCabalFile flags@(InitFlags{packageName = Flag p}) = do - let cabalFileName = p ++ ".cabal" - message flags $ "Generating " ++ cabalFileName ++ "..." - writeFile cabalFileName (generateCabalFile cabalFileName flags) - return True - --- | Generate a .cabal file from an InitFlags structure. NOTE: this --- is rather ad-hoc! What we would REALLY like is to have a --- standard low-level AST type representing .cabal files, which --- preserves things like comments, and to write an *inverse* --- parser/pretty-printer pair between .cabal files and this AST. --- Then instead of this ad-hoc code we could just map an InitFlags --- structure onto a low-level AST structure and use the existing --- pretty-printing code to generate the file. -generateCabalFile :: String -> InitFlags -> String -generateCabalFile fileName c = render $ - (if (minimal c /= Flag True) - then showComment (Just $ fileName ++ " auto-generated by cabal init. For additional options, see http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.") - else empty) - $$ - vcat [ fieldS "Name" (packageName c) - (Just "The name of the package.") - True - - , field "Version" (version c) - (Just "The package version. See the Haskell package versioning policy (http://www.haskell.org/haskellwiki/Package_versioning_policy) for standards guiding when and how versions should be incremented.") - True - - , fieldS "Synopsis" (synopsis c) - (Just "A short (one-line) description of the package.") - True - - , fieldS "Description" NoFlag - (Just "A longer description of the package.") - True - - , fieldS "Homepage" (homepage c) - (Just "URL for the project homepage or repository.") - False - - , fieldS "Bug-reports" NoFlag - (Just "A URL where users can report bugs.") - False - - , field "License" (license c) - (Just "The license under which the package is released.") - True - - , fieldS "License-file" (Flag "LICENSE") - (Just "The file containing the license text.") - True - - , fieldS "Author" (author c) - (Just "The package author(s).") - True - - , fieldS "Maintainer" (email c) - (Just "An email address to which users can send suggestions, bug reports, and patches.") - True - - , fieldS "Copyright" NoFlag - (Just "A copyright notice.") - True - - , fieldS "Category" (either id display `fmap` category c) - Nothing - True - - , fieldS "Build-type" (Flag "Simple") - Nothing - True - - , fieldS "Extra-source-files" NoFlag - (Just "Extra files to be distributed with the package, such as examples or a README.") - True - - , field "Cabal-version" (Flag $ orLaterVersion (Version [1,2] [])) - (Just "Constraint on the version of Cabal needed to build this package.") - False - - , case packageType c of - Flag Executable -> - text "\nExecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ (nest 2 $ vcat - [ fieldS "Main-is" NoFlag (Just ".hs or .lhs file containing the Main module.") True - - , generateBuildInfo c - ]) - Flag Library -> text "\nLibrary" $$ (nest 2 $ vcat - [ fieldS "Exposed-modules" (listField (exposedModules c)) - (Just "Modules exported by the library.") - True - - , generateBuildInfo c - ]) - _ -> empty - ] - where - generateBuildInfo :: InitFlags -> Doc - generateBuildInfo c' = vcat - [ fieldS "Build-depends" (listField (dependencies c')) - (Just "Packages needed in order to build this package.") - True - - , fieldS "Other-modules" (listField (otherModules c')) - (Just "Modules not exported by this package.") - True - - , fieldS "hs-source-dirs" (listFieldS (sourceDirs c')) - (Just "Directories other than the root containing source files.") - False - - , fieldS "Build-tools" (listFieldS (buildTools c')) - (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.") - True - ] - - listField :: Text s => Maybe [s] -> Flag String - listField = listFieldS . fmap (map display) - - listFieldS :: Maybe [String] -> Flag String - listFieldS = Flag . maybe "" (concat . intersperse ", ") - - field :: Text t => String -> Flag t -> Maybe String -> Bool -> Doc - field s f = fieldS s (fmap display f) - - fieldS :: String -- ^ Name of the field - -> Flag String -- ^ Field contents - -> Maybe String -- ^ Comment to explain the field - -> Bool -- ^ Should the field be included (commented out) even if blank? - -> Doc - fieldS _ NoFlag _ inc | not inc || (minimal c == Flag True) = empty - fieldS _ (Flag "") _ inc | not inc || (minimal c == Flag True) = empty - fieldS s f com _ = case (isJust com, noComments c, minimal c) of - (_, _, Flag True) -> id - (_, Flag True, _) -> id - (True, _, _) -> (showComment com $$) . ($$ text "") - (False, _, _) -> ($$ text "") - $ - comment f <> text s <> colon - <> text (take (20 - length s) (repeat ' ')) - <> text (fromMaybe "" . flagToMaybe $ f) - comment NoFlag = text "-- " - comment (Flag "") = text "-- " - comment _ = text "" - - showComment :: Maybe String -> Doc - showComment (Just t) = vcat . map text - . map ("-- "++) . lines - . render . fsep . map text . words $ t - showComment Nothing = text "" - --- | Generate warnings for missing fields etc. -generateWarnings :: InitFlags -> IO () -generateWarnings flags = do - message flags "" - when (synopsis flags `elem` [NoFlag, Flag ""]) - (message flags "Warning: no synopsis given. You should edit the .cabal file and add one.") - - message flags "You may want to edit the .cabal file and add a Description field." - --- | Possibly generate a message to stdout, taking into account the --- --quiet flag. -message :: InitFlags -> String -> IO () -message (InitFlags{quiet = Flag True}) _ = return () -message _ s = putStrLn s - -#if MIN_VERSION_base(3,0,0) -#else -(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) -f >=> g = \x -> f x >>= g -#endif diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Heuristics.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Heuristics.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Heuristics.hs +++ /dev/null @@ -1,191 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init.Heuristics --- Copyright : (c) Benedikt Huber 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Heuristics for creating initial cabal files. --- ------------------------------------------------------------------------------ -module Distribution.Client.Init.Heuristics ( - guessPackageName, - scanForModules, SourceFileEntry(..), - neededBuildPrograms, - guessAuthorNameMail, - knownCategories, -) where -import Distribution.Simple.Setup(Flag(..)) -import Distribution.ModuleName ( ModuleName, fromString ) -import Distribution.Client.PackageIndex - ( allPackagesByName ) -import qualified Distribution.PackageDescription as PD - ( category, packageDescription ) -import Distribution.Simple.Utils - ( intercalate ) - -import Distribution.Client.Types ( packageDescription, AvailablePackageDb(..) ) -import Control.Monad (liftM ) -import Data.Char ( isUpper, isLower, isSpace ) -#if MIN_VERSION_base(3,0,3) -import Data.Either ( partitionEithers ) -#endif -import Data.Maybe ( catMaybes ) -import Data.Monoid ( mempty, mappend ) -import qualified Data.Set as Set ( fromList, toList ) -import System.Directory ( getDirectoryContents, doesDirectoryExist, doesFileExist, - getHomeDirectory, canonicalizePath ) -import System.Environment ( getEnvironment ) -import System.FilePath ( takeExtension, takeBaseName, dropExtension, - (), splitDirectories, makeRelative ) - --- |Guess the package name based on the given root directory -guessPackageName :: FilePath -> IO String -guessPackageName = liftM (last . splitDirectories) . canonicalizePath - --- |Data type of source files found in the working directory -data SourceFileEntry = SourceFileEntry - { relativeSourcePath :: FilePath - , moduleName :: ModuleName - , fileExtension :: String - } deriving Show - --- |Search for source files in the given directory --- and return pairs of guessed haskell source path and --- module names. -scanForModules :: FilePath -> IO [SourceFileEntry] -scanForModules rootDir = scanForModulesIn rootDir rootDir - -scanForModulesIn :: FilePath -> FilePath -> IO [SourceFileEntry] -scanForModulesIn projectRoot srcRoot = scan srcRoot [] - where - scan dir hierarchy = do - entries <- getDirectoryContents (projectRoot dir) - (files, dirs) <- liftM partitionEithers (mapM (tagIsDir dir) entries) - let modules = catMaybes [ guessModuleName hierarchy file - | file <- files - , isUpper (head file) ] - recMods <- mapM (scanRecursive dir hierarchy) dirs - return $ concat (modules : recMods) - tagIsDir parent entry = do - isDir <- doesDirectoryExist (parent entry) - return $ (if isDir then Right else Left) entry - guessModuleName hierarchy entry - | takeBaseName entry == "Setup" = Nothing - | ext `elem` sourceExtensions = Just $ SourceFileEntry relRoot modName ext - | otherwise = Nothing - where - relRoot = makeRelative projectRoot srcRoot - unqualModName = dropExtension entry - modName = fromString $ intercalate "." . reverse $ (unqualModName : hierarchy) - ext = case takeExtension entry of '.':e -> e; e -> e - scanRecursive parent hierarchy entry - | isUpper (head entry) = scan (parent entry) (entry : hierarchy) - | isLower (head entry) && not (ignoreDir entry) = - scanForModulesIn projectRoot $ foldl () srcRoot (entry : hierarchy) - | otherwise = return [] - ignoreDir ('.':_) = True - ignoreDir dir = dir `elem` ["dist", "_darcs"] - --- Unfortunately we cannot use the version exported by Distribution.Simple.Program -knownSuffixHandlers :: [(String,String)] -knownSuffixHandlers = - [ ("gc", "greencard") - , ("chs", "chs") - , ("hsc", "hsc2hs") - , ("x", "alex") - , ("y", "happy") - , ("ly", "happy") - , ("cpphs", "cpp") - ] - -sourceExtensions :: [String] -sourceExtensions = "hs" : "lhs" : map fst knownSuffixHandlers - -neededBuildPrograms :: [SourceFileEntry] -> [String] -neededBuildPrograms entries = - [ handler - | ext <- nubSet (map fileExtension entries) - , handler <- maybe [] (:[]) (lookup ext knownSuffixHandlers) - ] - --- |Guess author and email -guessAuthorNameMail :: IO (Flag String, Flag String) -guessAuthorNameMail = - update (readFromFile authorRepoFile) mempty >>= - update (getAuthorHome >>= readFromFile) >>= - update readFromEnvironment - where - update _ info@(Flag _, Flag _) = return info - update extract info = liftM (`mappend` info) extract -- prefer info - readFromFile file = do - exists <- doesFileExist file - if exists then liftM nameAndMail (readFile file) else return mempty - readFromEnvironment = fmap extractFromEnvironment getEnvironment - extractFromEnvironment env = - let darcsEmailEnv = maybe mempty nameAndMail (lookup "DARCS_EMAIL" env) - emailEnv = maybe mempty (\e -> (mempty, Flag e)) (lookup "EMAIL" env) - in darcsEmailEnv `mappend` emailEnv - getAuthorHome = liftM ( (".darcs" "author")) getHomeDirectory - authorRepoFile = "_darcs" "prefs" "author" - --- |Get list of categories used in hackage. NOTE: Very slow, needs to be cached -knownCategories :: AvailablePackageDb -> [String] -knownCategories (AvailablePackageDb available _) = nubSet $ - [ cat | pkg <- map head (allPackagesByName available) - , let catList = (PD.category . PD.packageDescription . packageDescription) pkg - , cat <- splitString ',' catList - ] - --- Parse name and email, from darcs pref files or environment variable -nameAndMail :: String -> (Flag String, Flag String) -nameAndMail str - | all isSpace nameOrEmail = mempty - | null erest = (mempty, Flag $ trim nameOrEmail) - | otherwise = (Flag $ trim nameOrEmail, Flag email) - where - (nameOrEmail,erest) = break (== '<') str - (email,_) = break (== '>') (tail erest) - trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse - removeLeadingSpace = dropWhile isSpace - --- split string at given character, and remove whitespaces -splitString :: Char -> String -> [String] -splitString sep str = go str where - go s = if null s' then [] else tok : go rest where - s' = dropWhile (\c -> c == sep || isSpace c) s - (tok,rest) = break (==sep) s' - -nubSet :: (Ord a) => [a] -> [a] -nubSet = Set.toList . Set.fromList - -{- -test db testProjectRoot = do - putStrLn "Guessed package name" - (guessPackageName >=> print) testProjectRoot - putStrLn "Guessed name and email" - guessAuthorNameMail >>= print - - mods <- scanForModules testProjectRoot - - putStrLn "Guessed modules" - mapM_ print mods - putStrLn "Needed build programs" - print (neededBuildPrograms mods) - - putStrLn "List of known categories" - print $ knownCategories db --} - -#if MIN_VERSION_base(3,0,3) -#else -partitionEithers :: [Either a b] -> ([a],[b]) -partitionEithers = foldr (either left right) ([],[]) - where - left a (l, r) = (a:l, r) - right a (l, r) = (l, a:r) -#endif diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Licenses.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Licenses.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Licenses.hs +++ /dev/null @@ -1,1722 +0,0 @@ -module Distribution.Client.Init.Licenses - ( License - , bsd3 - , gplv2 - , gplv3 - , lgpl2 - , lgpl3 - - ) where - -type License = String - -bsd3 :: String -> String -> License -bsd3 authors year = unlines - [ "Copyright (c)" ++ year ++ ", " ++ authors - , "" - , "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 " ++ authors ++ " 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." - ] - -gplv2 :: License -gplv2 = unlines - [ " GNU GENERAL PUBLIC LICENSE" - , " Version 2, June 1991" - , "" - , " Copyright (C) 1989, 1991 Free Software Foundation, Inc.," - , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" - , " Everyone is permitted to copy and distribute verbatim copies" - , " of this license document, but changing it is not allowed." - , "" - , " Preamble" - , "" - , " The licenses for most software are designed to take away your" - , "freedom to share and change it. By contrast, the GNU General Public" - , "License is intended to guarantee your freedom to share and change free" - , "software--to make sure the software is free for all its users. This" - , "General Public License applies to most of the Free Software" - , "Foundation's software and to any other program whose authors commit to" - , "using it. (Some other Free Software Foundation software is covered by" - , "the GNU Lesser General Public License instead.) You can apply it to" - , "your programs, too." - , "" - , " When we speak of free software, we are referring to freedom, not" - , "price. Our General Public Licenses are designed to make sure that you" - , "have the freedom to distribute copies of free software (and charge for" - , "this service if you wish), that you receive source code or can get it" - , "if you want it, that you can change the software or use pieces of it" - , "in new free programs; and that you know you can do these things." - , "" - , " To protect your rights, we need to make restrictions that forbid" - , "anyone to deny you these rights or to ask you to surrender the rights." - , "These restrictions translate to certain responsibilities for you if you" - , "distribute copies of the software, or if you modify it." - , "" - , " For example, if you distribute copies of such a program, whether" - , "gratis or for a fee, you must give the recipients all the rights that" - , "you have. You must make sure that they, too, receive or can get the" - , "source code. And you must show them these terms so they know their" - , "rights." - , "" - , " We protect your rights with two steps: (1) copyright the software, and" - , "(2) offer you this license which gives you legal permission to copy," - , "distribute and/or modify the software." - , "" - , " Also, for each author's protection and ours, we want to make certain" - , "that everyone understands that there is no warranty for this free" - , "software. If the software is modified by someone else and passed on, we" - , "want its recipients to know that what they have is not the original, so" - , "that any problems introduced by others will not reflect on the original" - , "authors' reputations." - , "" - , " Finally, any free program is threatened constantly by software" - , "patents. We wish to avoid the danger that redistributors of a free" - , "program will individually obtain patent licenses, in effect making the" - , "program proprietary. To prevent this, we have made it clear that any" - , "patent must be licensed for everyone's free use or not licensed at all." - , "" - , " The precise terms and conditions for copying, distribution and" - , "modification follow." - , "" - , " GNU GENERAL PUBLIC LICENSE" - , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" - , "" - , " 0. This License applies to any program or other work which contains" - , "a notice placed by the copyright holder saying it may be distributed" - , "under the terms of this General Public License. The \"Program\", below," - , "refers to any such program or work, and a \"work based on the Program\"" - , "means either the Program or any derivative work under copyright law:" - , "that is to say, a work containing the Program or a portion of it," - , "either verbatim or with modifications and/or translated into another" - , "language. (Hereinafter, translation is included without limitation in" - , "the term \"modification\".) Each licensee is addressed as \"you\"." - , "" - , "Activities other than copying, distribution and modification are not" - , "covered by this License; they are outside its scope. The act of" - , "running the Program is not restricted, and the output from the Program" - , "is covered only if its contents constitute a work based on the" - , "Program (independent of having been made by running the Program)." - , "Whether that is true depends on what the Program does." - , "" - , " 1. You may copy and distribute verbatim copies of the Program's" - , "source code as you receive it, in any medium, provided that you" - , "conspicuously and appropriately publish on each copy an appropriate" - , "copyright notice and disclaimer of warranty; keep intact all the" - , "notices that refer to this License and to the absence of any warranty;" - , "and give any other recipients of the Program a copy of this License" - , "along with the Program." - , "" - , "You may charge a fee for the physical act of transferring a copy, and" - , "you may at your option offer warranty protection in exchange for a fee." - , "" - , " 2. You may modify your copy or copies of the Program or any portion" - , "of it, thus forming a work based on the Program, and copy and" - , "distribute such modifications or work under the terms of Section 1" - , "above, provided that you also meet all of these conditions:" - , "" - , " a) You must cause the modified files to carry prominent notices" - , " stating that you changed the files and the date of any change." - , "" - , " b) You must cause any work that you distribute or publish, that in" - , " whole or in part contains or is derived from the Program or any" - , " part thereof, to be licensed as a whole at no charge to all third" - , " parties under the terms of this License." - , "" - , " c) If the modified program normally reads commands interactively" - , " when run, you must cause it, when started running for such" - , " interactive use in the most ordinary way, to print or display an" - , " announcement including an appropriate copyright notice and a" - , " notice that there is no warranty (or else, saying that you provide" - , " a warranty) and that users may redistribute the program under" - , " these conditions, and telling the user how to view a copy of this" - , " License. (Exception: if the Program itself is interactive but" - , " does not normally print such an announcement, your work based on" - , " the Program is not required to print an announcement.)" - , "" - , "These requirements apply to the modified work as a whole. If" - , "identifiable sections of that work are not derived from the Program," - , "and can be reasonably considered independent and separate works in" - , "themselves, then this License, and its terms, do not apply to those" - , "sections when you distribute them as separate works. But when you" - , "distribute the same sections as part of a whole which is a work based" - , "on the Program, the distribution of the whole must be on the terms of" - , "this License, whose permissions for other licensees extend to the" - , "entire whole, and thus to each and every part regardless of who wrote it." - , "" - , "Thus, it is not the intent of this section to claim rights or contest" - , "your rights to work written entirely by you; rather, the intent is to" - , "exercise the right to control the distribution of derivative or" - , "collective works based on the Program." - , "" - , "In addition, mere aggregation of another work not based on the Program" - , "with the Program (or with a work based on the Program) on a volume of" - , "a storage or distribution medium does not bring the other work under" - , "the scope of this License." - , "" - , " 3. You may copy and distribute the Program (or a work based on it," - , "under Section 2) in object code or executable form under the terms of" - , "Sections 1 and 2 above provided that you also do one of the following:" - , "" - , " a) Accompany it with the complete corresponding machine-readable" - , " source code, which must be distributed under the terms of Sections" - , " 1 and 2 above on a medium customarily used for software interchange; or," - , "" - , " b) Accompany it with a written offer, valid for at least three" - , " years, to give any third party, for a charge no more than your" - , " cost of physically performing source distribution, a complete" - , " machine-readable copy of the corresponding source code, to be" - , " distributed under the terms of Sections 1 and 2 above on a medium" - , " customarily used for software interchange; or," - , "" - , " c) Accompany it with the information you received as to the offer" - , " to distribute corresponding source code. (This alternative is" - , " allowed only for noncommercial distribution and only if you" - , " received the program in object code or executable form with such" - , " an offer, in accord with Subsection b above.)" - , "" - , "The source code for a work means the preferred form of the work for" - , "making modifications to it. For an executable work, complete source" - , "code means all the source code for all modules it contains, plus any" - , "associated interface definition files, plus the scripts used to" - , "control compilation and installation of the executable. However, as a" - , "special exception, the source code distributed need not include" - , "anything that is normally distributed (in either source or binary" - , "form) with the major components (compiler, kernel, and so on) of the" - , "operating system on which the executable runs, unless that component" - , "itself accompanies the executable." - , "" - , "If distribution of executable or object code is made by offering" - , "access to copy from a designated place, then offering equivalent" - , "access to copy the source code from the same place counts as" - , "distribution of the source code, even though third parties are not" - , "compelled to copy the source along with the object code." - , "" - , " 4. You may not copy, modify, sublicense, or distribute the Program" - , "except as expressly provided under this License. Any attempt" - , "otherwise to copy, modify, sublicense or distribute the Program is" - , "void, and will automatically terminate your rights under this License." - , "However, parties who have received copies, or rights, from you under" - , "this License will not have their licenses terminated so long as such" - , "parties remain in full compliance." - , "" - , " 5. You are not required to accept this License, since you have not" - , "signed it. However, nothing else grants you permission to modify or" - , "distribute the Program or its derivative works. These actions are" - , "prohibited by law if you do not accept this License. Therefore, by" - , "modifying or distributing the Program (or any work based on the" - , "Program), you indicate your acceptance of this License to do so, and" - , "all its terms and conditions for copying, distributing or modifying" - , "the Program or works based on it." - , "" - , " 6. Each time you redistribute the Program (or any work based on the" - , "Program), the recipient automatically receives a license from the" - , "original licensor to copy, distribute or modify the Program subject to" - , "these terms and conditions. You may not impose any further" - , "restrictions on the recipients' exercise of the rights granted herein." - , "You are not responsible for enforcing compliance by third parties to" - , "this License." - , "" - , " 7. If, as a consequence of a court judgment or allegation of patent" - , "infringement or for any other reason (not limited to patent issues)," - , "conditions are imposed on you (whether by court order, agreement or" - , "otherwise) that contradict the conditions of this License, they do not" - , "excuse you from the conditions of this License. If you cannot" - , "distribute so as to satisfy simultaneously your obligations under this" - , "License and any other pertinent obligations, then as a consequence you" - , "may not distribute the Program at all. For example, if a patent" - , "license would not permit royalty-free redistribution of the Program by" - , "all those who receive copies directly or indirectly through you, then" - , "the only way you could satisfy both it and this License would be to" - , "refrain entirely from distribution of the Program." - , "" - , "If any portion of this section is held invalid or unenforceable under" - , "any particular circumstance, the balance of the section is intended to" - , "apply and the section as a whole is intended to apply in other" - , "circumstances." - , "" - , "It is not the purpose of this section to induce you to infringe any" - , "patents or other property right claims or to contest validity of any" - , "such claims; this section has the sole purpose of protecting the" - , "integrity of the free software distribution system, which is" - , "implemented by public license practices. Many people have made" - , "generous contributions to the wide range of software distributed" - , "through that system in reliance on consistent application of that" - , "system; it is up to the author/donor to decide if he or she is willing" - , "to distribute software through any other system and a licensee cannot" - , "impose that choice." - , "" - , "This section is intended to make thoroughly clear what is believed to" - , "be a consequence of the rest of this License." - , "" - , " 8. If the distribution and/or use of the Program is restricted in" - , "certain countries either by patents or by copyrighted interfaces, the" - , "original copyright holder who places the Program under this License" - , "may add an explicit geographical distribution limitation excluding" - , "those countries, so that distribution is permitted only in or among" - , "countries not thus excluded. In such case, this License incorporates" - , "the limitation as if written in the body of this License." - , "" - , " 9. The Free Software Foundation may publish revised and/or new versions" - , "of the General Public License from time to time. Such new versions will" - , "be similar in spirit to the present version, but may differ in detail to" - , "address new problems or concerns." - , "" - , "Each version is given a distinguishing version number. If the Program" - , "specifies a version number of this License which applies to it and \"any" - , "later version\", you have the option of following the terms and conditions" - , "either of that version or of any later version published by the Free" - , "Software Foundation. If the Program does not specify a version number of" - , "this License, you may choose any version ever published by the Free Software" - , "Foundation." - , "" - , " 10. If you wish to incorporate parts of the Program into other free" - , "programs whose distribution conditions are different, write to the author" - , "to ask for permission. For software which is copyrighted by the Free" - , "Software Foundation, write to the Free Software Foundation; we sometimes" - , "make exceptions for this. Our decision will be guided by the two goals" - , "of preserving the free status of all derivatives of our free software and" - , "of promoting the sharing and reuse of software generally." - , "" - , " NO WARRANTY" - , "" - , " 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY" - , "FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN" - , "OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES" - , "PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED" - , "OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF" - , "MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS" - , "TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE" - , "PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING," - , "REPAIR OR CORRECTION." - , "" - , " 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" - , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR" - , "REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES," - , "INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING" - , "OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED" - , "TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY" - , "YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER" - , "PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE" - , "POSSIBILITY OF SUCH DAMAGES." - , "" - , " END OF TERMS AND CONDITIONS" - , "" - , " How to Apply These Terms to Your New Programs" - , "" - , " If you develop a new program, and you want it to be of the greatest" - , "possible use to the public, the best way to achieve this is to make it" - , "free software which everyone can redistribute and change under these terms." - , "" - , " To do so, attach the following notices to the program. It is safest" - , "to attach them to the start of each source file to most effectively" - , "convey the exclusion of warranty; and each file should have at least" - , "the \"copyright\" line and a pointer to where the full notice is found." - , "" - , " " - , " Copyright (C) " - , "" - , " This program is free software; you can redistribute it and/or modify" - , " it under the terms of the GNU General Public License as published by" - , " the Free Software Foundation; either version 2 of the License, or" - , " (at your option) any later version." - , "" - , " This program is distributed in the hope that it will be useful," - , " but WITHOUT ANY WARRANTY; without even the implied warranty of" - , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" - , " GNU General Public License for more details." - , "" - , " You should have received a copy of the GNU General Public License along" - , " with this program; if not, write to the Free Software Foundation, Inc.," - , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA." - , "" - , "Also add information on how to contact you by electronic and paper mail." - , "" - , "If the program is interactive, make it output a short notice like this" - , "when it starts in an interactive mode:" - , "" - , " Gnomovision version 69, Copyright (C) year name of author" - , " Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'." - , " This is free software, and you are welcome to redistribute it" - , " under certain conditions; type `show c' for details." - , "" - , "The hypothetical commands `show w' and `show c' should show the appropriate" - , "parts of the General Public License. Of course, the commands you use may" - , "be called something other than `show w' and `show c'; they could even be" - , "mouse-clicks or menu items--whatever suits your program." - , "" - , "You should also get your employer (if you work as a programmer) or your" - , "school, if any, to sign a \"copyright disclaimer\" for the program, if" - , "necessary. Here is a sample; alter the names:" - , "" - , " Yoyodyne, Inc., hereby disclaims all copyright interest in the program" - , " `Gnomovision' (which makes passes at compilers) written by James Hacker." - , "" - , " , 1 April 1989" - , " Ty Coon, President of Vice" - , "" - , "This General Public License does not permit incorporating your program into" - , "proprietary programs. If your program is a subroutine library, you may" - , "consider it more useful to permit linking proprietary applications with the" - , "library. If this is what you want to do, use the GNU Lesser General" - , "Public License instead of this License." - ] - -gplv3 :: License -gplv3 = unlines - [ " GNU GENERAL PUBLIC LICENSE" - , " Version 3, 29 June 2007" - , "" - , " Copyright (C) 2007 Free Software Foundation, Inc. " - , " Everyone is permitted to copy and distribute verbatim copies" - , " of this license document, but changing it is not allowed." - , "" - , " Preamble" - , "" - , " The GNU General Public License is a free, copyleft license for" - , "software and other kinds of works." - , "" - , " The licenses for most software and other practical works are designed" - , "to take away your freedom to share and change the works. By contrast," - , "the GNU General Public License is intended to guarantee your freedom to" - , "share and change all versions of a program--to make sure it remains free" - , "software for all its users. We, the Free Software Foundation, use the" - , "GNU General Public License for most of our software; it applies also to" - , "any other work released this way by its authors. You can apply it to" - , "your programs, too." - , "" - , " When we speak of free software, we are referring to freedom, not" - , "price. Our General Public Licenses are designed to make sure that you" - , "have the freedom to distribute copies of free software (and charge for" - , "them if you wish), that you receive source code or can get it if you" - , "want it, that you can change the software or use pieces of it in new" - , "free programs, and that you know you can do these things." - , "" - , " To protect your rights, we need to prevent others from denying you" - , "these rights or asking you to surrender the rights. Therefore, you have" - , "certain responsibilities if you distribute copies of the software, or if" - , "you modify it: responsibilities to respect the freedom of others." - , "" - , " For example, if you distribute copies of such a program, whether" - , "gratis or for a fee, you must pass on to the recipients the same" - , "freedoms that you received. You must make sure that they, too, receive" - , "or can get the source code. And you must show them these terms so they" - , "know their rights." - , "" - , " Developers that use the GNU GPL protect your rights with two steps:" - , "(1) assert copyright on the software, and (2) offer you this License" - , "giving you legal permission to copy, distribute and/or modify it." - , "" - , " For the developers' and authors' protection, the GPL clearly explains" - , "that there is no warranty for this free software. For both users' and" - , "authors' sake, the GPL requires that modified versions be marked as" - , "changed, so that their problems will not be attributed erroneously to" - , "authors of previous versions." - , "" - , " Some devices are designed to deny users access to install or run" - , "modified versions of the software inside them, although the manufacturer" - , "can do so. This is fundamentally incompatible with the aim of" - , "protecting users' freedom to change the software. The systematic" - , "pattern of such abuse occurs in the area of products for individuals to" - , "use, which is precisely where it is most unacceptable. Therefore, we" - , "have designed this version of the GPL to prohibit the practice for those" - , "products. If such problems arise substantially in other domains, we" - , "stand ready to extend this provision to those domains in future versions" - , "of the GPL, as needed to protect the freedom of users." - , "" - , " Finally, every program is threatened constantly by software patents." - , "States should not allow patents to restrict development and use of" - , "software on general-purpose computers, but in those that do, we wish to" - , "avoid the special danger that patents applied to a free program could" - , "make it effectively proprietary. To prevent this, the GPL assures that" - , "patents cannot be used to render the program non-free." - , "" - , " The precise terms and conditions for copying, distribution and" - , "modification follow." - , "" - , " TERMS AND CONDITIONS" - , "" - , " 0. Definitions." - , "" - , " \"This License\" refers to version 3 of the GNU General Public License." - , "" - , " \"Copyright\" also means copyright-like laws that apply to other kinds of" - , "works, such as semiconductor masks." - , " " - , " \"The Program\" refers to any copyrightable work licensed under this" - , "License. Each licensee is addressed as \"you\". \"Licensees\" and" - , "\"recipients\" may be individuals or organizations." - , "" - , " To \"modify\" a work means to copy from or adapt all or part of the work" - , "in a fashion requiring copyright permission, other than the making of an" - , "exact copy. The resulting work is called a \"modified version\" of the" - , "earlier work or a work \"based on\" the earlier work." - , "" - , " A \"covered work\" means either the unmodified Program or a work based" - , "on the Program." - , "" - , " To \"propagate\" a work means to do anything with it that, without" - , "permission, would make you directly or secondarily liable for" - , "infringement under applicable copyright law, except executing it on a" - , "computer or modifying a private copy. Propagation includes copying," - , "distribution (with or without modification), making available to the" - , "public, and in some countries other activities as well." - , "" - , " To \"convey\" a work means any kind of propagation that enables other" - , "parties to make or receive copies. Mere interaction with a user through" - , "a computer network, with no transfer of a copy, is not conveying." - , "" - , " An interactive user interface displays \"Appropriate Legal Notices\"" - , "to the extent that it includes a convenient and prominently visible" - , "feature that (1) displays an appropriate copyright notice, and (2)" - , "tells the user that there is no warranty for the work (except to the" - , "extent that warranties are provided), that licensees may convey the" - , "work under this License, and how to view a copy of this License. If" - , "the interface presents a list of user commands or options, such as a" - , "menu, a prominent item in the list meets this criterion." - , "" - , " 1. Source Code." - , "" - , " The \"source code\" for a work means the preferred form of the work" - , "for making modifications to it. \"Object code\" means any non-source" - , "form of a work." - , "" - , " A \"Standard Interface\" means an interface that either is an official" - , "standard defined by a recognized standards body, or, in the case of" - , "interfaces specified for a particular programming language, one that" - , "is widely used among developers working in that language." - , "" - , " The \"System Libraries\" of an executable work include anything, other" - , "than the work as a whole, that (a) is included in the normal form of" - , "packaging a Major Component, but which is not part of that Major" - , "Component, and (b) serves only to enable use of the work with that" - , "Major Component, or to implement a Standard Interface for which an" - , "implementation is available to the public in source code form. A" - , "\"Major Component\", in this context, means a major essential component" - , "(kernel, window system, and so on) of the specific operating system" - , "(if any) on which the executable work runs, or a compiler used to" - , "produce the work, or an object code interpreter used to run it." - , "" - , " The \"Corresponding Source\" for a work in object code form means all" - , "the source code needed to generate, install, and (for an executable" - , "work) run the object code and to modify the work, including scripts to" - , "control those activities. However, it does not include the work's" - , "System Libraries, or general-purpose tools or generally available free" - , "programs which are used unmodified in performing those activities but" - , "which are not part of the work. For example, Corresponding Source" - , "includes interface definition files associated with source files for" - , "the work, and the source code for shared libraries and dynamically" - , "linked subprograms that the work is specifically designed to require," - , "such as by intimate data communication or control flow between those" - , "subprograms and other parts of the work." - , "" - , " The Corresponding Source need not include anything that users" - , "can regenerate automatically from other parts of the Corresponding" - , "Source." - , "" - , " The Corresponding Source for a work in source code form is that" - , "same work." - , "" - , " 2. Basic Permissions." - , "" - , " All rights granted under this License are granted for the term of" - , "copyright on the Program, and are irrevocable provided the stated" - , "conditions are met. This License explicitly affirms your unlimited" - , "permission to run the unmodified Program. The output from running a" - , "covered work is covered by this License only if the output, given its" - , "content, constitutes a covered work. This License acknowledges your" - , "rights of fair use or other equivalent, as provided by copyright law." - , "" - , " You may make, run and propagate covered works that you do not" - , "convey, without conditions so long as your license otherwise remains" - , "in force. You may convey covered works to others for the sole purpose" - , "of having them make modifications exclusively for you, or provide you" - , "with facilities for running those works, provided that you comply with" - , "the terms of this License in conveying all material for which you do" - , "not control copyright. Those thus making or running the covered works" - , "for you must do so exclusively on your behalf, under your direction" - , "and control, on terms that prohibit them from making any copies of" - , "your copyrighted material outside their relationship with you." - , "" - , " Conveying under any other circumstances is permitted solely under" - , "the conditions stated below. Sublicensing is not allowed; section 10" - , "makes it unnecessary." - , "" - , " 3. Protecting Users' Legal Rights From Anti-Circumvention Law." - , "" - , " No covered work shall be deemed part of an effective technological" - , "measure under any applicable law fulfilling obligations under article" - , "11 of the WIPO copyright treaty adopted on 20 December 1996, or" - , "similar laws prohibiting or restricting circumvention of such" - , "measures." - , "" - , " When you convey a covered work, you waive any legal power to forbid" - , "circumvention of technological measures to the extent such circumvention" - , "is effected by exercising rights under this License with respect to" - , "the covered work, and you disclaim any intention to limit operation or" - , "modification of the work as a means of enforcing, against the work's" - , "users, your or third parties' legal rights to forbid circumvention of" - , "technological measures." - , "" - , " 4. Conveying Verbatim Copies." - , "" - , " You may convey verbatim copies of the Program's source code as you" - , "receive it, in any medium, provided that you conspicuously and" - , "appropriately publish on each copy an appropriate copyright notice;" - , "keep intact all notices stating that this License and any" - , "non-permissive terms added in accord with section 7 apply to the code;" - , "keep intact all notices of the absence of any warranty; and give all" - , "recipients a copy of this License along with the Program." - , "" - , " You may charge any price or no price for each copy that you convey," - , "and you may offer support or warranty protection for a fee." - , "" - , " 5. Conveying Modified Source Versions." - , "" - , " You may convey a work based on the Program, or the modifications to" - , "produce it from the Program, in the form of source code under the" - , "terms of section 4, provided that you also meet all of these conditions:" - , "" - , " a) The work must carry prominent notices stating that you modified" - , " it, and giving a relevant date." - , "" - , " b) The work must carry prominent notices stating that it is" - , " released under this License and any conditions added under section" - , " 7. This requirement modifies the requirement in section 4 to" - , " \"keep intact all notices\"." - , "" - , " c) You must license the entire work, as a whole, under this" - , " License to anyone who comes into possession of a copy. This" - , " License will therefore apply, along with any applicable section 7" - , " additional terms, to the whole of the work, and all its parts," - , " regardless of how they are packaged. This License gives no" - , " permission to license the work in any other way, but it does not" - , " invalidate such permission if you have separately received it." - , "" - , " d) If the work has interactive user interfaces, each must display" - , " Appropriate Legal Notices; however, if the Program has interactive" - , " interfaces that do not display Appropriate Legal Notices, your" - , " work need not make them do so." - , "" - , " A compilation of a covered work with other separate and independent" - , "works, which are not by their nature extensions of the covered work," - , "and which are not combined with it such as to form a larger program," - , "in or on a volume of a storage or distribution medium, is called an" - , "\"aggregate\" if the compilation and its resulting copyright are not" - , "used to limit the access or legal rights of the compilation's users" - , "beyond what the individual works permit. Inclusion of a covered work" - , "in an aggregate does not cause this License to apply to the other" - , "parts of the aggregate." - , "" - , " 6. Conveying Non-Source Forms." - , "" - , " You may convey a covered work in object code form under the terms" - , "of sections 4 and 5, provided that you also convey the" - , "machine-readable Corresponding Source under the terms of this License," - , "in one of these ways:" - , "" - , " a) Convey the object code in, or embodied in, a physical product" - , " (including a physical distribution medium), accompanied by the" - , " Corresponding Source fixed on a durable physical medium" - , " customarily used for software interchange." - , "" - , " b) Convey the object code in, or embodied in, a physical product" - , " (including a physical distribution medium), accompanied by a" - , " written offer, valid for at least three years and valid for as" - , " long as you offer spare parts or customer support for that product" - , " model, to give anyone who possesses the object code either (1) a" - , " copy of the Corresponding Source for all the software in the" - , " product that is covered by this License, on a durable physical" - , " medium customarily used for software interchange, for a price no" - , " more than your reasonable cost of physically performing this" - , " conveying of source, or (2) access to copy the" - , " Corresponding Source from a network server at no charge." - , "" - , " c) Convey individual copies of the object code with a copy of the" - , " written offer to provide the Corresponding Source. This" - , " alternative is allowed only occasionally and noncommercially, and" - , " only if you received the object code with such an offer, in accord" - , " with subsection 6b." - , "" - , " d) Convey the object code by offering access from a designated" - , " place (gratis or for a charge), and offer equivalent access to the" - , " Corresponding Source in the same way through the same place at no" - , " further charge. You need not require recipients to copy the" - , " Corresponding Source along with the object code. If the place to" - , " copy the object code is a network server, the Corresponding Source" - , " may be on a different server (operated by you or a third party)" - , " that supports equivalent copying facilities, provided you maintain" - , " clear directions next to the object code saying where to find the" - , " Corresponding Source. Regardless of what server hosts the" - , " Corresponding Source, you remain obligated to ensure that it is" - , " available for as long as needed to satisfy these requirements." - , "" - , " e) Convey the object code using peer-to-peer transmission, provided" - , " you inform other peers where the object code and Corresponding" - , " Source of the work are being offered to the general public at no" - , " charge under subsection 6d." - , "" - , " A separable portion of the object code, whose source code is excluded" - , "from the Corresponding Source as a System Library, need not be" - , "included in conveying the object code work." - , "" - , " A \"User Product\" is either (1) a \"consumer product\", which means any" - , "tangible personal property which is normally used for personal, family," - , "or household purposes, or (2) anything designed or sold for incorporation" - , "into a dwelling. In determining whether a product is a consumer product," - , "doubtful cases shall be resolved in favor of coverage. For a particular" - , "product received by a particular user, \"normally used\" refers to a" - , "typical or common use of that class of product, regardless of the status" - , "of the particular user or of the way in which the particular user" - , "actually uses, or expects or is expected to use, the product. A product" - , "is a consumer product regardless of whether the product has substantial" - , "commercial, industrial or non-consumer uses, unless such uses represent" - , "the only significant mode of use of the product." - , "" - , " \"Installation Information\" for a User Product means any methods," - , "procedures, authorization keys, or other information required to install" - , "and execute modified versions of a covered work in that User Product from" - , "a modified version of its Corresponding Source. The information must" - , "suffice to ensure that the continued functioning of the modified object" - , "code is in no case prevented or interfered with solely because" - , "modification has been made." - , "" - , " If you convey an object code work under this section in, or with, or" - , "specifically for use in, a User Product, and the conveying occurs as" - , "part of a transaction in which the right of possession and use of the" - , "User Product is transferred to the recipient in perpetuity or for a" - , "fixed term (regardless of how the transaction is characterized), the" - , "Corresponding Source conveyed under this section must be accompanied" - , "by the Installation Information. But this requirement does not apply" - , "if neither you nor any third party retains the ability to install" - , "modified object code on the User Product (for example, the work has" - , "been installed in ROM)." - , "" - , " The requirement to provide Installation Information does not include a" - , "requirement to continue to provide support service, warranty, or updates" - , "for a work that has been modified or installed by the recipient, or for" - , "the User Product in which it has been modified or installed. Access to a" - , "network may be denied when the modification itself materially and" - , "adversely affects the operation of the network or violates the rules and" - , "protocols for communication across the network." - , "" - , " Corresponding Source conveyed, and Installation Information provided," - , "in accord with this section must be in a format that is publicly" - , "documented (and with an implementation available to the public in" - , "source code form), and must require no special password or key for" - , "unpacking, reading or copying." - , "" - , " 7. Additional Terms." - , "" - , " \"Additional permissions\" are terms that supplement the terms of this" - , "License by making exceptions from one or more of its conditions." - , "Additional permissions that are applicable to the entire Program shall" - , "be treated as though they were included in this License, to the extent" - , "that they are valid under applicable law. If additional permissions" - , "apply only to part of the Program, that part may be used separately" - , "under those permissions, but the entire Program remains governed by" - , "this License without regard to the additional permissions." - , "" - , " When you convey a copy of a covered work, you may at your option" - , "remove any additional permissions from that copy, or from any part of" - , "it. (Additional permissions may be written to require their own" - , "removal in certain cases when you modify the work.) You may place" - , "additional permissions on material, added by you to a covered work," - , "for which you have or can give appropriate copyright permission." - , "" - , " Notwithstanding any other provision of this License, for material you" - , "add to a covered work, you may (if authorized by the copyright holders of" - , "that material) supplement the terms of this License with terms:" - , "" - , " a) Disclaiming warranty or limiting liability differently from the" - , " terms of sections 15 and 16 of this License; or" - , "" - , " b) Requiring preservation of specified reasonable legal notices or" - , " author attributions in that material or in the Appropriate Legal" - , " Notices displayed by works containing it; or" - , "" - , " c) Prohibiting misrepresentation of the origin of that material, or" - , " requiring that modified versions of such material be marked in" - , " reasonable ways as different from the original version; or" - , "" - , " d) Limiting the use for publicity purposes of names of licensors or" - , " authors of the material; or" - , "" - , " e) Declining to grant rights under trademark law for use of some" - , " trade names, trademarks, or service marks; or" - , "" - , " f) Requiring indemnification of licensors and authors of that" - , " material by anyone who conveys the material (or modified versions of" - , " it) with contractual assumptions of liability to the recipient, for" - , " any liability that these contractual assumptions directly impose on" - , " those licensors and authors." - , "" - , " All other non-permissive additional terms are considered \"further" - , "restrictions\" within the meaning of section 10. If the Program as you" - , "received it, or any part of it, contains a notice stating that it is" - , "governed by this License along with a term that is a further" - , "restriction, you may remove that term. If a license document contains" - , "a further restriction but permits relicensing or conveying under this" - , "License, you may add to a covered work material governed by the terms" - , "of that license document, provided that the further restriction does" - , "not survive such relicensing or conveying." - , "" - , " If you add terms to a covered work in accord with this section, you" - , "must place, in the relevant source files, a statement of the" - , "additional terms that apply to those files, or a notice indicating" - , "where to find the applicable terms." - , "" - , " Additional terms, permissive or non-permissive, may be stated in the" - , "form of a separately written license, or stated as exceptions;" - , "the above requirements apply either way." - , "" - , " 8. Termination." - , "" - , " You may not propagate or modify a covered work except as expressly" - , "provided under this License. Any attempt otherwise to propagate or" - , "modify it is void, and will automatically terminate your rights under" - , "this License (including any patent licenses granted under the third" - , "paragraph of section 11)." - , "" - , " However, if you cease all violation of this License, then your" - , "license from a particular copyright holder is reinstated (a)" - , "provisionally, unless and until the copyright holder explicitly and" - , "finally terminates your license, and (b) permanently, if the copyright" - , "holder fails to notify you of the violation by some reasonable means" - , "prior to 60 days after the cessation." - , "" - , " Moreover, your license from a particular copyright holder is" - , "reinstated permanently if the copyright holder notifies you of the" - , "violation by some reasonable means, this is the first time you have" - , "received notice of violation of this License (for any work) from that" - , "copyright holder, and you cure the violation prior to 30 days after" - , "your receipt of the notice." - , "" - , " Termination of your rights under this section does not terminate the" - , "licenses of parties who have received copies or rights from you under" - , "this License. If your rights have been terminated and not permanently" - , "reinstated, you do not qualify to receive new licenses for the same" - , "material under section 10." - , "" - , " 9. Acceptance Not Required for Having Copies." - , "" - , " You are not required to accept this License in order to receive or" - , "run a copy of the Program. Ancillary propagation of a covered work" - , "occurring solely as a consequence of using peer-to-peer transmission" - , "to receive a copy likewise does not require acceptance. However," - , "nothing other than this License grants you permission to propagate or" - , "modify any covered work. These actions infringe copyright if you do" - , "not accept this License. Therefore, by modifying or propagating a" - , "covered work, you indicate your acceptance of this License to do so." - , "" - , " 10. Automatic Licensing of Downstream Recipients." - , "" - , " Each time you convey a covered work, the recipient automatically" - , "receives a license from the original licensors, to run, modify and" - , "propagate that work, subject to this License. You are not responsible" - , "for enforcing compliance by third parties with this License." - , "" - , " An \"entity transaction\" is a transaction transferring control of an" - , "organization, or substantially all assets of one, or subdividing an" - , "organization, or merging organizations. If propagation of a covered" - , "work results from an entity transaction, each party to that" - , "transaction who receives a copy of the work also receives whatever" - , "licenses to the work the party's predecessor in interest had or could" - , "give under the previous paragraph, plus a right to possession of the" - , "Corresponding Source of the work from the predecessor in interest, if" - , "the predecessor has it or can get it with reasonable efforts." - , "" - , " You may not impose any further restrictions on the exercise of the" - , "rights granted or affirmed under this License. For example, you may" - , "not impose a license fee, royalty, or other charge for exercise of" - , "rights granted under this License, and you may not initiate litigation" - , "(including a cross-claim or counterclaim in a lawsuit) alleging that" - , "any patent claim is infringed by making, using, selling, offering for" - , "sale, or importing the Program or any portion of it." - , "" - , " 11. Patents." - , "" - , " A \"contributor\" is a copyright holder who authorizes use under this" - , "License of the Program or a work on which the Program is based. The" - , "work thus licensed is called the contributor's \"contributor version\"." - , "" - , " A contributor's \"essential patent claims\" are all patent claims" - , "owned or controlled by the contributor, whether already acquired or" - , "hereafter acquired, that would be infringed by some manner, permitted" - , "by this License, of making, using, or selling its contributor version," - , "but do not include claims that would be infringed only as a" - , "consequence of further modification of the contributor version. For" - , "purposes of this definition, \"control\" includes the right to grant" - , "patent sublicenses in a manner consistent with the requirements of" - , "this License." - , "" - , " Each contributor grants you a non-exclusive, worldwide, royalty-free" - , "patent license under the contributor's essential patent claims, to" - , "make, use, sell, offer for sale, import and otherwise run, modify and" - , "propagate the contents of its contributor version." - , "" - , " In the following three paragraphs, a \"patent license\" is any express" - , "agreement or commitment, however denominated, not to enforce a patent" - , "(such as an express permission to practice a patent or covenant not to" - , "sue for patent infringement). To \"grant\" such a patent license to a" - , "party means to make such an agreement or commitment not to enforce a" - , "patent against the party." - , "" - , " If you convey a covered work, knowingly relying on a patent license," - , "and the Corresponding Source of the work is not available for anyone" - , "to copy, free of charge and under the terms of this License, through a" - , "publicly available network server or other readily accessible means," - , "then you must either (1) cause the Corresponding Source to be so" - , "available, or (2) arrange to deprive yourself of the benefit of the" - , "patent license for this particular work, or (3) arrange, in a manner" - , "consistent with the requirements of this License, to extend the patent" - , "license to downstream recipients. \"Knowingly relying\" means you have" - , "actual knowledge that, but for the patent license, your conveying the" - , "covered work in a country, or your recipient's use of the covered work" - , "in a country, would infringe one or more identifiable patents in that" - , "country that you have reason to believe are valid." - , " " - , " If, pursuant to or in connection with a single transaction or" - , "arrangement, you convey, or propagate by procuring conveyance of, a" - , "covered work, and grant a patent license to some of the parties" - , "receiving the covered work authorizing them to use, propagate, modify" - , "or convey a specific copy of the covered work, then the patent license" - , "you grant is automatically extended to all recipients of the covered" - , "work and works based on it." - , "" - , " A patent license is \"discriminatory\" if it does not include within" - , "the scope of its coverage, prohibits the exercise of, or is" - , "conditioned on the non-exercise of one or more of the rights that are" - , "specifically granted under this License. You may not convey a covered" - , "work if you are a party to an arrangement with a third party that is" - , "in the business of distributing software, under which you make payment" - , "to the third party based on the extent of your activity of conveying" - , "the work, and under which the third party grants, to any of the" - , "parties who would receive the covered work from you, a discriminatory" - , "patent license (a) in connection with copies of the covered work" - , "conveyed by you (or copies made from those copies), or (b) primarily" - , "for and in connection with specific products or compilations that" - , "contain the covered work, unless you entered into that arrangement," - , "or that patent license was granted, prior to 28 March 2007." - , "" - , " Nothing in this License shall be construed as excluding or limiting" - , "any implied license or other defenses to infringement that may" - , "otherwise be available to you under applicable patent law." - , "" - , " 12. No Surrender of Others' Freedom." - , "" - , " If conditions are imposed on you (whether by court order, agreement or" - , "otherwise) that contradict the conditions of this License, they do not" - , "excuse you from the conditions of this License. If you cannot convey a" - , "covered work so as to satisfy simultaneously your obligations under this" - , "License and any other pertinent obligations, then as a consequence you may" - , "not convey it at all. For example, if you agree to terms that obligate you" - , "to collect a royalty for further conveying from those to whom you convey" - , "the Program, the only way you could satisfy both those terms and this" - , "License would be to refrain entirely from conveying the Program." - , "" - , " 13. Use with the GNU Affero General Public License." - , "" - , " Notwithstanding any other provision of this License, you have" - , "permission to link or combine any covered work with a work licensed" - , "under version 3 of the GNU Affero General Public License into a single" - , "combined work, and to convey the resulting work. The terms of this" - , "License will continue to apply to the part which is the covered work," - , "but the special requirements of the GNU Affero General Public License," - , "section 13, concerning interaction through a network will apply to the" - , "combination as such." - , "" - , " 14. Revised Versions of this License." - , "" - , " The Free Software Foundation may publish revised and/or new versions of" - , "the GNU General Public License from time to time. Such new versions will" - , "be similar in spirit to the present version, but may differ in detail to" - , "address new problems or concerns." - , "" - , " Each version is given a distinguishing version number. If the" - , "Program specifies that a certain numbered version of the GNU General" - , "Public License \"or any later version\" applies to it, you have the" - , "option of following the terms and conditions either of that numbered" - , "version or of any later version published by the Free Software" - , "Foundation. If the Program does not specify a version number of the" - , "GNU General Public License, you may choose any version ever published" - , "by the Free Software Foundation." - , "" - , " If the Program specifies that a proxy can decide which future" - , "versions of the GNU General Public License can be used, that proxy's" - , "public statement of acceptance of a version permanently authorizes you" - , "to choose that version for the Program." - , "" - , " Later license versions may give you additional or different" - , "permissions. However, no additional obligations are imposed on any" - , "author or copyright holder as a result of your choosing to follow a" - , "later version." - , "" - , " 15. Disclaimer of Warranty." - , "" - , " THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY" - , "APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT" - , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY" - , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO," - , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" - , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM" - , "IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF" - , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION." - , "" - , " 16. Limitation of Liability." - , "" - , " IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" - , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS" - , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY" - , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE" - , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF" - , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD" - , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS)," - , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF" - , "SUCH DAMAGES." - , "" - , " 17. Interpretation of Sections 15 and 16." - , "" - , " If the disclaimer of warranty and limitation of liability provided" - , "above cannot be given local legal effect according to their terms," - , "reviewing courts shall apply local law that most closely approximates" - , "an absolute waiver of all civil liability in connection with the" - , "Program, unless a warranty or assumption of liability accompanies a" - , "copy of the Program in return for a fee." - , "" - , " END OF TERMS AND CONDITIONS" - , "" - , " How to Apply These Terms to Your New Programs" - , "" - , " If you develop a new program, and you want it to be of the greatest" - , "possible use to the public, the best way to achieve this is to make it" - , "free software which everyone can redistribute and change under these terms." - , "" - , " To do so, attach the following notices to the program. It is safest" - , "to attach them to the start of each source file to most effectively" - , "state the exclusion of warranty; and each file should have at least" - , "the \"copyright\" line and a pointer to where the full notice is found." - , "" - , " " - , " Copyright (C) " - , "" - , " This program is free software: you can redistribute it and/or modify" - , " it under the terms of the GNU General Public License as published by" - , " the Free Software Foundation, either version 3 of the License, or" - , " (at your option) any later version." - , "" - , " This program is distributed in the hope that it will be useful," - , " but WITHOUT ANY WARRANTY; without even the implied warranty of" - , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" - , " GNU General Public License for more details." - , "" - , " You should have received a copy of the GNU General Public License" - , " along with this program. If not, see ." - , "" - , "Also add information on how to contact you by electronic and paper mail." - , "" - , " If the program does terminal interaction, make it output a short" - , "notice like this when it starts in an interactive mode:" - , "" - , " Copyright (C) " - , " This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'." - , " This is free software, and you are welcome to redistribute it" - , " under certain conditions; type `show c' for details." - , "" - , "The hypothetical commands `show w' and `show c' should show the appropriate" - , "parts of the General Public License. Of course, your program's commands" - , "might be different; for a GUI interface, you would use an \"about box\"." - , "" - , " You should also get your employer (if you work as a programmer) or school," - , "if any, to sign a \"copyright disclaimer\" for the program, if necessary." - , "For more information on this, and how to apply and follow the GNU GPL, see" - , "." - , "" - , " The GNU General Public License does not permit incorporating your program" - , "into proprietary programs. If your program is a subroutine library, you" - , "may consider it more useful to permit linking proprietary applications with" - , "the library. If this is what you want to do, use the GNU Lesser General" - , "Public License instead of this License. But first, please read" - , "." - , "" - ] - -lgpl2 :: License -lgpl2 = unlines - [ " GNU LIBRARY GENERAL PUBLIC LICENSE" - , " Version 2, June 1991" - , "" - , " Copyright (C) 1991 Free Software Foundation, Inc." - , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" - , " Everyone is permitted to copy and distribute verbatim copies" - , " of this license document, but changing it is not allowed." - , "" - , "[This is the first released version of the library GPL. It is" - , " numbered 2 because it goes with version 2 of the ordinary GPL.]" - , "" - , " Preamble" - , "" - , " The licenses for most software are designed to take away your" - , "freedom to share and change it. By contrast, the GNU General Public" - , "Licenses are intended to guarantee your freedom to share and change" - , "free software--to make sure the software is free for all its users." - , "" - , " This license, the Library General Public License, applies to some" - , "specially designated Free Software Foundation software, and to any" - , "other libraries whose authors decide to use it. You can use it for" - , "your libraries, too." - , "" - , " When we speak of free software, we are referring to freedom, not" - , "price. Our General Public Licenses are designed to make sure that you" - , "have the freedom to distribute copies of free software (and charge for" - , "this service if you wish), that you receive source code or can get it" - , "if you want it, that you can change the software or use pieces of it" - , "in new free programs; and that you know you can do these things." - , "" - , " To protect your rights, we need to make restrictions that forbid" - , "anyone to deny you these rights or to ask you to surrender the rights." - , "These restrictions translate to certain responsibilities for you if" - , "you distribute copies of the library, or if you modify it." - , "" - , " For example, if you distribute copies of the library, whether gratis" - , "or for a fee, you must give the recipients all the rights that we gave" - , "you. You must make sure that they, too, receive or can get the source" - , "code. If you link a program with the library, you must provide" - , "complete object files to the recipients so that they can relink them" - , "with the library, after making changes to the library and recompiling" - , "it. And you must show them these terms so they know their rights." - , "" - , " Our method of protecting your rights has two steps: (1) copyright" - , "the library, and (2) offer you this license which gives you legal" - , "permission to copy, distribute and/or modify the library." - , "" - , " Also, for each distributor's protection, we want to make certain" - , "that everyone understands that there is no warranty for this free" - , "library. If the library is modified by someone else and passed on, we" - , "want its recipients to know that what they have is not the original" - , "version, so that any problems introduced by others will not reflect on" - , "the original authors' reputations." - , "" - , " Finally, any free program is threatened constantly by software" - , "patents. We wish to avoid the danger that companies distributing free" - , "software will individually obtain patent licenses, thus in effect" - , "transforming the program into proprietary software. To prevent this," - , "we have made it clear that any patent must be licensed for everyone's" - , "free use or not licensed at all." - , "" - , " Most GNU software, including some libraries, is covered by the ordinary" - , "GNU General Public License, which was designed for utility programs. This" - , "license, the GNU Library General Public License, applies to certain" - , "designated libraries. This license is quite different from the ordinary" - , "one; be sure to read it in full, and don't assume that anything in it is" - , "the same as in the ordinary license." - , "" - , " The reason we have a separate public license for some libraries is that" - , "they blur the distinction we usually make between modifying or adding to a" - , "program and simply using it. Linking a program with a library, without" - , "changing the library, is in some sense simply using the library, and is" - , "analogous to running a utility program or application program. However, in" - , "a textual and legal sense, the linked executable is a combined work, a" - , "derivative of the original library, and the ordinary General Public License" - , "treats it as such." - , "" - , " Because of this blurred distinction, using the ordinary General" - , "Public License for libraries did not effectively promote software" - , "sharing, because most developers did not use the libraries. We" - , "concluded that weaker conditions might promote sharing better." - , "" - , " However, unrestricted linking of non-free programs would deprive the" - , "users of those programs of all benefit from the free status of the" - , "libraries themselves. This Library General Public License is intended to" - , "permit developers of non-free programs to use free libraries, while" - , "preserving your freedom as a user of such programs to change the free" - , "libraries that are incorporated in them. (We have not seen how to achieve" - , "this as regards changes in header files, but we have achieved it as regards" - , "changes in the actual functions of the Library.) The hope is that this" - , "will lead to faster development of free libraries." - , "" - , " The precise terms and conditions for copying, distribution and" - , "modification follow. Pay close attention to the difference between a" - , "\"work based on the library\" and a \"work that uses the library\". The" - , "former contains code derived from the library, while the latter only" - , "works together with the library." - , "" - , " Note that it is possible for a library to be covered by the ordinary" - , "General Public License rather than by this special one." - , "" - , " GNU LIBRARY GENERAL PUBLIC LICENSE" - , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" - , "" - , " 0. This License Agreement applies to any software library which" - , "contains a notice placed by the copyright holder or other authorized" - , "party saying it may be distributed under the terms of this Library" - , "General Public License (also called \"this License\"). Each licensee is" - , "addressed as \"you\"." - , "" - , " A \"library\" means a collection of software functions and/or data" - , "prepared so as to be conveniently linked with application programs" - , "(which use some of those functions and data) to form executables." - , "" - , " The \"Library\", below, refers to any such software library or work" - , "which has been distributed under these terms. A \"work based on the" - , "Library\" means either the Library or any derivative work under" - , "copyright law: that is to say, a work containing the Library or a" - , "portion of it, either verbatim or with modifications and/or translated" - , "straightforwardly into another language. (Hereinafter, translation is" - , "included without limitation in the term \"modification\".)" - , "" - , " \"Source code\" for a work means the preferred form of the work for" - , "making modifications to it. For a library, complete source code means" - , "all the source code for all modules it contains, plus any associated" - , "interface definition files, plus the scripts used to control compilation" - , "and installation of the library." - , "" - , " Activities other than copying, distribution and modification are not" - , "covered by this License; they are outside its scope. The act of" - , "running a program using the Library is not restricted, and output from" - , "such a program is covered only if its contents constitute a work based" - , "on the Library (independent of the use of the Library in a tool for" - , "writing it). Whether that is true depends on what the Library does" - , "and what the program that uses the Library does." - , " " - , " 1. You may copy and distribute verbatim copies of the Library's" - , "complete source code as you receive it, in any medium, provided that" - , "you conspicuously and appropriately publish on each copy an" - , "appropriate copyright notice and disclaimer of warranty; keep intact" - , "all the notices that refer to this License and to the absence of any" - , "warranty; and distribute a copy of this License along with the" - , "Library." - , "" - , " You may charge a fee for the physical act of transferring a copy," - , "and you may at your option offer warranty protection in exchange for a" - , "fee." - , "" - , " 2. You may modify your copy or copies of the Library or any portion" - , "of it, thus forming a work based on the Library, and copy and" - , "distribute such modifications or work under the terms of Section 1" - , "above, provided that you also meet all of these conditions:" - , "" - , " a) The modified work must itself be a software library." - , "" - , " b) You must cause the files modified to carry prominent notices" - , " stating that you changed the files and the date of any change." - , "" - , " c) You must cause the whole of the work to be licensed at no" - , " charge to all third parties under the terms of this License." - , "" - , " d) If a facility in the modified Library refers to a function or a" - , " table of data to be supplied by an application program that uses" - , " the facility, other than as an argument passed when the facility" - , " is invoked, then you must make a good faith effort to ensure that," - , " in the event an application does not supply such function or" - , " table, the facility still operates, and performs whatever part of" - , " its purpose remains meaningful." - , "" - , " (For example, a function in a library to compute square roots has" - , " a purpose that is entirely well-defined independent of the" - , " application. Therefore, Subsection 2d requires that any" - , " application-supplied function or table used by this function must" - , " be optional: if the application does not supply it, the square" - , " root function must still compute square roots.)" - , "" - , "These requirements apply to the modified work as a whole. If" - , "identifiable sections of that work are not derived from the Library," - , "and can be reasonably considered independent and separate works in" - , "themselves, then this License, and its terms, do not apply to those" - , "sections when you distribute them as separate works. But when you" - , "distribute the same sections as part of a whole which is a work based" - , "on the Library, the distribution of the whole must be on the terms of" - , "this License, whose permissions for other licensees extend to the" - , "entire whole, and thus to each and every part regardless of who wrote" - , "it." - , "" - , "Thus, it is not the intent of this section to claim rights or contest" - , "your rights to work written entirely by you; rather, the intent is to" - , "exercise the right to control the distribution of derivative or" - , "collective works based on the Library." - , "" - , "In addition, mere aggregation of another work not based on the Library" - , "with the Library (or with a work based on the Library) on a volume of" - , "a storage or distribution medium does not bring the other work under" - , "the scope of this License." - , "" - , " 3. You may opt to apply the terms of the ordinary GNU General Public" - , "License instead of this License to a given copy of the Library. To do" - , "this, you must alter all the notices that refer to this License, so" - , "that they refer to the ordinary GNU General Public License, version 2," - , "instead of to this License. (If a newer version than version 2 of the" - , "ordinary GNU General Public License has appeared, then you can specify" - , "that version instead if you wish.) Do not make any other change in" - , "these notices." - , "" - , " Once this change is made in a given copy, it is irreversible for" - , "that copy, so the ordinary GNU General Public License applies to all" - , "subsequent copies and derivative works made from that copy." - , "" - , " This option is useful when you wish to copy part of the code of" - , "the Library into a program that is not a library." - , "" - , " 4. You may copy and distribute the Library (or a portion or" - , "derivative of it, under Section 2) in object code or executable form" - , "under the terms of Sections 1 and 2 above provided that you accompany" - , "it with the complete corresponding machine-readable source code, which" - , "must be distributed under the terms of Sections 1 and 2 above on a" - , "medium customarily used for software interchange." - , "" - , " If distribution of object code is made by offering access to copy" - , "from a designated place, then offering equivalent access to copy the" - , "source code from the same place satisfies the requirement to" - , "distribute the source code, even though third parties are not" - , "compelled to copy the source along with the object code." - , "" - , " 5. A program that contains no derivative of any portion of the" - , "Library, but is designed to work with the Library by being compiled or" - , "linked with it, is called a \"work that uses the Library\". Such a" - , "work, in isolation, is not a derivative work of the Library, and" - , "therefore falls outside the scope of this License." - , "" - , " However, linking a \"work that uses the Library\" with the Library" - , "creates an executable that is a derivative of the Library (because it" - , "contains portions of the Library), rather than a \"work that uses the" - , "library\". The executable is therefore covered by this License." - , "Section 6 states terms for distribution of such executables." - , "" - , " When a \"work that uses the Library\" uses material from a header file" - , "that is part of the Library, the object code for the work may be a" - , "derivative work of the Library even though the source code is not." - , "Whether this is true is especially significant if the work can be" - , "linked without the Library, or if the work is itself a library. The" - , "threshold for this to be true is not precisely defined by law." - , "" - , " If such an object file uses only numerical parameters, data" - , "structure layouts and accessors, and small macros and small inline" - , "functions (ten lines or less in length), then the use of the object" - , "file is unrestricted, regardless of whether it is legally a derivative" - , "work. (Executables containing this object code plus portions of the" - , "Library will still fall under Section 6.)" - , "" - , " Otherwise, if the work is a derivative of the Library, you may" - , "distribute the object code for the work under the terms of Section 6." - , "Any executables containing that work also fall under Section 6," - , "whether or not they are linked directly with the Library itself." - , "" - , " 6. As an exception to the Sections above, you may also compile or" - , "link a \"work that uses the Library\" with the Library to produce a" - , "work containing portions of the Library, and distribute that work" - , "under terms of your choice, provided that the terms permit" - , "modification of the work for the customer's own use and reverse" - , "engineering for debugging such modifications." - , "" - , " You must give prominent notice with each copy of the work that the" - , "Library is used in it and that the Library and its use are covered by" - , "this License. You must supply a copy of this License. If the work" - , "during execution displays copyright notices, you must include the" - , "copyright notice for the Library among them, as well as a reference" - , "directing the user to the copy of this License. Also, you must do one" - , "of these things:" - , "" - , " a) Accompany the work with the complete corresponding" - , " machine-readable source code for the Library including whatever" - , " changes were used in the work (which must be distributed under" - , " Sections 1 and 2 above); and, if the work is an executable linked" - , " with the Library, with the complete machine-readable \"work that" - , " uses the Library\", as object code and/or source code, so that the" - , " user can modify the Library and then relink to produce a modified" - , " executable containing the modified Library. (It is understood" - , " that the user who changes the contents of definitions files in the" - , " Library will not necessarily be able to recompile the application" - , " to use the modified definitions.)" - , "" - , " b) Accompany the work with a written offer, valid for at" - , " least three years, to give the same user the materials" - , " specified in Subsection 6a, above, for a charge no more" - , " than the cost of performing this distribution." - , "" - , " c) If distribution of the work is made by offering access to copy" - , " from a designated place, offer equivalent access to copy the above" - , " specified materials from the same place." - , "" - , " d) Verify that the user has already received a copy of these" - , " materials or that you have already sent this user a copy." - , "" - , " For an executable, the required form of the \"work that uses the" - , "Library\" must include any data and utility programs needed for" - , "reproducing the executable from it. However, as a special exception," - , "the source code distributed need not include anything that is normally" - , "distributed (in either source or binary form) with the major" - , "components (compiler, kernel, and so on) of the operating system on" - , "which the executable runs, unless that component itself accompanies" - , "the executable." - , "" - , " It may happen that this requirement contradicts the license" - , "restrictions of other proprietary libraries that do not normally" - , "accompany the operating system. Such a contradiction means you cannot" - , "use both them and the Library together in an executable that you" - , "distribute." - , "" - , " 7. You may place library facilities that are a work based on the" - , "Library side-by-side in a single library together with other library" - , "facilities not covered by this License, and distribute such a combined" - , "library, provided that the separate distribution of the work based on" - , "the Library and of the other library facilities is otherwise" - , "permitted, and provided that you do these two things:" - , "" - , " a) Accompany the combined library with a copy of the same work" - , " based on the Library, uncombined with any other library" - , " facilities. This must be distributed under the terms of the" - , " Sections above." - , "" - , " b) Give prominent notice with the combined library of the fact" - , " that part of it is a work based on the Library, and explaining" - , " where to find the accompanying uncombined form of the same work." - , "" - , " 8. You may not copy, modify, sublicense, link with, or distribute" - , "the Library except as expressly provided under this License. Any" - , "attempt otherwise to copy, modify, sublicense, link with, or" - , "distribute the Library is void, and will automatically terminate your" - , "rights under this License. However, parties who have received copies," - , "or rights, from you under this License will not have their licenses" - , "terminated so long as such parties remain in full compliance." - , "" - , " 9. You are not required to accept this License, since you have not" - , "signed it. However, nothing else grants you permission to modify or" - , "distribute the Library or its derivative works. These actions are" - , "prohibited by law if you do not accept this License. Therefore, by" - , "modifying or distributing the Library (or any work based on the" - , "Library), you indicate your acceptance of this License to do so, and" - , "all its terms and conditions for copying, distributing or modifying" - , "the Library or works based on it." - , "" - , " 10. Each time you redistribute the Library (or any work based on the" - , "Library), the recipient automatically receives a license from the" - , "original licensor to copy, distribute, link with or modify the Library" - , "subject to these terms and conditions. You may not impose any further" - , "restrictions on the recipients' exercise of the rights granted herein." - , "You are not responsible for enforcing compliance by third parties to" - , "this License." - , "" - , " 11. If, as a consequence of a court judgment or allegation of patent" - , "infringement or for any other reason (not limited to patent issues)," - , "conditions are imposed on you (whether by court order, agreement or" - , "otherwise) that contradict the conditions of this License, they do not" - , "excuse you from the conditions of this License. If you cannot" - , "distribute so as to satisfy simultaneously your obligations under this" - , "License and any other pertinent obligations, then as a consequence you" - , "may not distribute the Library at all. For example, if a patent" - , "license would not permit royalty-free redistribution of the Library by" - , "all those who receive copies directly or indirectly through you, then" - , "the only way you could satisfy both it and this License would be to" - , "refrain entirely from distribution of the Library." - , "" - , "If any portion of this section is held invalid or unenforceable under any" - , "particular circumstance, the balance of the section is intended to apply," - , "and the section as a whole is intended to apply in other circumstances." - , "" - , "It is not the purpose of this section to induce you to infringe any" - , "patents or other property right claims or to contest validity of any" - , "such claims; this section has the sole purpose of protecting the" - , "integrity of the free software distribution system which is" - , "implemented by public license practices. Many people have made" - , "generous contributions to the wide range of software distributed" - , "through that system in reliance on consistent application of that" - , "system; it is up to the author/donor to decide if he or she is willing" - , "to distribute software through any other system and a licensee cannot" - , "impose that choice." - , "" - , "This section is intended to make thoroughly clear what is believed to" - , "be a consequence of the rest of this License." - , "" - , " 12. If the distribution and/or use of the Library is restricted in" - , "certain countries either by patents or by copyrighted interfaces, the" - , "original copyright holder who places the Library under this License may add" - , "an explicit geographical distribution limitation excluding those countries," - , "so that distribution is permitted only in or among countries not thus" - , "excluded. In such case, this License incorporates the limitation as if" - , "written in the body of this License." - , "" - , " 13. The Free Software Foundation may publish revised and/or new" - , "versions of the Library General Public License from time to time." - , "Such new versions will be similar in spirit to the present version," - , "but may differ in detail to address new problems or concerns." - , "" - , "Each version is given a distinguishing version number. If the Library" - , "specifies a version number of this License which applies to it and" - , "\"any later version\", you have the option of following the terms and" - , "conditions either of that version or of any later version published by" - , "the Free Software Foundation. If the Library does not specify a" - , "license version number, you may choose any version ever published by" - , "the Free Software Foundation." - , "" - , " 14. If you wish to incorporate parts of the Library into other free" - , "programs whose distribution conditions are incompatible with these," - , "write to the author to ask for permission. For software which is" - , "copyrighted by the Free Software Foundation, write to the Free" - , "Software Foundation; we sometimes make exceptions for this. Our" - , "decision will be guided by the two goals of preserving the free status" - , "of all derivatives of our free software and of promoting the sharing" - , "and reuse of software generally." - , "" - , " NO WARRANTY" - , "" - , " 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO" - , "WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW." - , "EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR" - , "OTHER PARTIES PROVIDE THE LIBRARY \"AS IS\" WITHOUT WARRANTY OF ANY" - , "KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE" - , "IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" - , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE" - , "LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME" - , "THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION." - , "" - , " 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN" - , "WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY" - , "AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU" - , "FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR" - , "CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE" - , "LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING" - , "RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A" - , "FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF" - , "SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH" - , "DAMAGES." - , "" - , " END OF TERMS AND CONDITIONS" - , "" - , " How to Apply These Terms to Your New Libraries" - , "" - , " If you develop a new library, and you want it to be of the greatest" - , "possible use to the public, we recommend making it free software that" - , "everyone can redistribute and change. You can do so by permitting" - , "redistribution under these terms (or, alternatively, under the terms of the" - , "ordinary General Public License)." - , "" - , " To apply these terms, attach the following notices to the library. It is" - , "safest to attach them to the start of each source file to most effectively" - , "convey the exclusion of warranty; and each file should have at least the" - , "\"copyright\" line and a pointer to where the full notice is found." - , "" - , " " - , " Copyright (C) " - , "" - , " This library is free software; you can redistribute it and/or" - , " modify it under the terms of the GNU Library General Public" - , " License as published by the Free Software Foundation; either" - , " version 2 of the License, or (at your option) any later version." - , "" - , " This library is distributed in the hope that it will be useful," - , " but WITHOUT ANY WARRANTY; without even the implied warranty of" - , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU" - , " Library General Public License for more details." - , "" - , " You should have received a copy of the GNU Library General Public" - , " License along with this library; if not, write to the Free" - , " Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" - , "" - , "Also add information on how to contact you by electronic and paper mail." - , "" - , "You should also get your employer (if you work as a programmer) or your" - , "school, if any, to sign a \"copyright disclaimer\" for the library, if" - , "necessary. Here is a sample; alter the names:" - , "" - , " Yoyodyne, Inc., hereby disclaims all copyright interest in the" - , " library `Frob' (a library for tweaking knobs) written by James Random Hacker." - , "" - , " , 1 April 1990" - , " Ty Coon, President of Vice" - , "" - , "That's all there is to it!" - ] - -lgpl3 :: License -lgpl3 = unlines - [ " GNU LESSER GENERAL PUBLIC LICENSE" - , " Version 3, 29 June 2007" - , "" - , " Copyright (C) 2007 Free Software Foundation, Inc. " - , " Everyone is permitted to copy and distribute verbatim copies" - , " of this license document, but changing it is not allowed." - , "" - , "" - , " This version of the GNU Lesser General Public License incorporates" - , "the terms and conditions of version 3 of the GNU General Public" - , "License, supplemented by the additional permissions listed below." - , "" - , " 0. Additional Definitions. " - , "" - , " As used herein, \"this License\" refers to version 3 of the GNU Lesser" - , "General Public License, and the \"GNU GPL\" refers to version 3 of the GNU" - , "General Public License." - , "" - , " \"The Library\" refers to a covered work governed by this License," - , "other than an Application or a Combined Work as defined below." - , "" - , " An \"Application\" is any work that makes use of an interface provided" - , "by the Library, but which is not otherwise based on the Library." - , "Defining a subclass of a class defined by the Library is deemed a mode" - , "of using an interface provided by the Library." - , "" - , " A \"Combined Work\" is a work produced by combining or linking an" - , "Application with the Library. The particular version of the Library" - , "with which the Combined Work was made is also called the \"Linked" - , "Version\"." - , "" - , " The \"Minimal Corresponding Source\" for a Combined Work means the" - , "Corresponding Source for the Combined Work, excluding any source code" - , "for portions of the Combined Work that, considered in isolation, are" - , "based on the Application, and not on the Linked Version." - , "" - , " The \"Corresponding Application Code\" for a Combined Work means the" - , "object code and/or source code for the Application, including any data" - , "and utility programs needed for reproducing the Combined Work from the" - , "Application, but excluding the System Libraries of the Combined Work." - , "" - , " 1. Exception to Section 3 of the GNU GPL." - , "" - , " You may convey a covered work under sections 3 and 4 of this License" - , "without being bound by section 3 of the GNU GPL." - , "" - , " 2. Conveying Modified Versions." - , "" - , " If you modify a copy of the Library, and, in your modifications, a" - , "facility refers to a function or data to be supplied by an Application" - , "that uses the facility (other than as an argument passed when the" - , "facility is invoked), then you may convey a copy of the modified" - , "version:" - , "" - , " a) under this License, provided that you make a good faith effort to" - , " ensure that, in the event an Application does not supply the" - , " function or data, the facility still operates, and performs" - , " whatever part of its purpose remains meaningful, or" - , "" - , " b) under the GNU GPL, with none of the additional permissions of" - , " this License applicable to that copy." - , "" - , " 3. Object Code Incorporating Material from Library Header Files." - , "" - , " The object code form of an Application may incorporate material from" - , "a header file that is part of the Library. You may convey such object" - , "code under terms of your choice, provided that, if the incorporated" - , "material is not limited to numerical parameters, data structure" - , "layouts and accessors, or small macros, inline functions and templates" - , "(ten or fewer lines in length), you do both of the following:" - , "" - , " a) Give prominent notice with each copy of the object code that the" - , " Library is used in it and that the Library and its use are" - , " covered by this License." - , "" - , " b) Accompany the object code with a copy of the GNU GPL and this license" - , " document." - , "" - , " 4. Combined Works." - , "" - , " You may convey a Combined Work under terms of your choice that," - , "taken together, effectively do not restrict modification of the" - , "portions of the Library contained in the Combined Work and reverse" - , "engineering for debugging such modifications, if you also do each of" - , "the following:" - , "" - , " a) Give prominent notice with each copy of the Combined Work that" - , " the Library is used in it and that the Library and its use are" - , " covered by this License." - , "" - , " b) Accompany the Combined Work with a copy of the GNU GPL and this license" - , " document." - , "" - , " c) For a Combined Work that displays copyright notices during" - , " execution, include the copyright notice for the Library among" - , " these notices, as well as a reference directing the user to the" - , " copies of the GNU GPL and this license document." - , "" - , " d) Do one of the following:" - , "" - , " 0) Convey the Minimal Corresponding Source under the terms of this" - , " License, and the Corresponding Application Code in a form" - , " suitable for, and under terms that permit, the user to" - , " recombine or relink the Application with a modified version of" - , " the Linked Version to produce a modified Combined Work, in the" - , " manner specified by section 6 of the GNU GPL for conveying" - , " Corresponding Source." - , "" - , " 1) Use a suitable shared library mechanism for linking with the" - , " Library. A suitable mechanism is one that (a) uses at run time" - , " a copy of the Library already present on the user's computer" - , " system, and (b) will operate properly with a modified version" - , " of the Library that is interface-compatible with the Linked" - , " Version. " - , "" - , " e) Provide Installation Information, but only if you would otherwise" - , " be required to provide such information under section 6 of the" - , " GNU GPL, and only to the extent that such information is" - , " necessary to install and execute a modified version of the" - , " Combined Work produced by recombining or relinking the" - , " Application with a modified version of the Linked Version. (If" - , " you use option 4d0, the Installation Information must accompany" - , " the Minimal Corresponding Source and Corresponding Application" - , " Code. If you use option 4d1, you must provide the Installation" - , " Information in the manner specified by section 6 of the GNU GPL" - , " for conveying Corresponding Source.)" - , "" - , " 5. Combined Libraries." - , "" - , " You may place library facilities that are a work based on the" - , "Library side by side in a single library together with other library" - , "facilities that are not Applications and are not covered by this" - , "License, and convey such a combined library under terms of your" - , "choice, if you do both of the following:" - , "" - , " a) Accompany the combined library with a copy of the same work based" - , " on the Library, uncombined with any other library facilities," - , " conveyed under the terms of this License." - , "" - , " b) Give prominent notice with the combined library that part of it" - , " is a work based on the Library, and explaining where to find the" - , " accompanying uncombined form of the same work." - , "" - , " 6. Revised Versions of the GNU Lesser General Public License." - , "" - , " The Free Software Foundation may publish revised and/or new versions" - , "of the GNU Lesser General Public License from time to time. Such new" - , "versions will be similar in spirit to the present version, but may" - , "differ in detail to address new problems or concerns." - , "" - , " Each version is given a distinguishing version number. If the" - , "Library as you received it specifies that a certain numbered version" - , "of the GNU Lesser General Public License \"or any later version\"" - , "applies to it, you have the option of following the terms and" - , "conditions either of that published version or of any later version" - , "published by the Free Software Foundation. If the Library as you" - , "received it does not specify a version number of the GNU Lesser" - , "General Public License, you may choose any version of the GNU Lesser" - , "General Public License ever published by the Free Software Foundation." - , "" - , " If the Library as you received it specifies that a proxy can decide" - , "whether future versions of the GNU Lesser General Public License shall" - , "apply, that proxy's public statement of acceptance of any version is" - , "permanent authorization for you to choose that version for the" - , "Library." - ] - diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Types.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Types.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Types.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Init.Types --- Copyright : (c) Brent Yorgey, Benedikt Huber 2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Some types used by the 'cabal init' command. --- ------------------------------------------------------------------------------ -module Distribution.Client.Init.Types where - -import Distribution.Simple.Setup - ( Flag(..) ) - -import Distribution.Version -import qualified Distribution.Package as P -import Distribution.License -import Distribution.ModuleName - -import qualified Text.PrettyPrint as Disp -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Text - -import Data.Monoid - --- | InitFlags is really just a simple type to represent certain --- portions of a .cabal file. Rather than have a flag for EVERY --- possible field, we just have one for each field that the user is --- likely to want and/or that we are likely to be able to --- intelligently guess. -data InitFlags = - InitFlags { nonInteractive :: Flag Bool - , quiet :: Flag Bool - , packageDir :: Flag FilePath - , noComments :: Flag Bool - , minimal :: Flag Bool - - , packageName :: Flag String - , version :: Flag Version - , cabalVersion :: Flag VersionRange - , license :: Flag License - , author :: Flag String - , email :: Flag String - , homepage :: Flag String - - , synopsis :: Flag String - , category :: Flag (Either String Category) - - , packageType :: Flag PackageType - - , exposedModules :: Maybe [ModuleName] - , otherModules :: Maybe [ModuleName] - - , dependencies :: Maybe [P.Dependency] - , sourceDirs :: Maybe [String] - , buildTools :: Maybe [String] - } - deriving (Show) - -data PackageType = Library | Executable - deriving (Show, Read, Eq) - -instance Text PackageType where - disp = Disp.text . show - parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable] - -instance Monoid InitFlags where - mempty = InitFlags - { nonInteractive = mempty - , quiet = mempty - , packageDir = mempty - , noComments = mempty - , minimal = mempty - , packageName = mempty - , version = mempty - , cabalVersion = mempty - , license = mempty - , author = mempty - , email = mempty - , homepage = mempty - , synopsis = mempty - , category = mempty - , packageType = mempty - , exposedModules = mempty - , otherModules = mempty - , dependencies = mempty - , sourceDirs = mempty - , buildTools = mempty - } - mappend a b = InitFlags - { nonInteractive = combine nonInteractive - , quiet = combine quiet - , packageDir = combine packageDir - , noComments = combine noComments - , minimal = combine minimal - , packageName = combine packageName - , version = combine version - , cabalVersion = combine cabalVersion - , license = combine license - , author = combine author - , email = combine email - , homepage = combine homepage - , synopsis = combine synopsis - , category = combine category - , packageType = combine packageType - , exposedModules = combine exposedModules - , otherModules = combine otherModules - , dependencies = combine dependencies - , sourceDirs = combine sourceDirs - , buildTools = combine buildTools - } - where combine field = field a `mappend` field b - --- | Some common package categories. -data Category - = Codec - | Concurrency - | Control - | Data - | Database - | Development - | Distribution - | Game - | Graphics - | Language - | Math - | Network - | Sound - | System - | Testing - | Text - | Web - deriving (Read, Show, Eq, Ord, Bounded, Enum) - -instance Text Category where - disp = Disp.text . show - parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ] - -#if MIN_VERSION_base(3,0,0) -#else --- Compat instance for ghc-6.6 era -instance Monoid a => Monoid (Maybe a) where - mempty = Nothing - Nothing `mappend` m = m - m `mappend` Nothing = m - Just m1 `mappend` Just m2 = Just (m1 `mappend` m2) -#endif diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Install.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Install.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Install.hs +++ /dev/null @@ -1,940 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Install --- Copyright : (c) 2005 David Himmelstrup --- 2007 Bjorn Bringert --- 2007-2010 Duncan Coutts --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- High level interface to package installation. ------------------------------------------------------------------------------ -module Distribution.Client.Install ( - install, - upgrade, - ) where - -import Data.List - ( unfoldr, find, nub, sort, partition ) -import Data.Maybe - ( isJust, fromMaybe ) -import qualified Data.Map as Map -import Control.Exception as Exception - ( handleJust ) -#if MIN_VERSION_base(4,0,0) -import Control.Exception as Exception - ( Exception(toException), catches, Handler(Handler), IOException ) -import System.Exit - ( ExitCode ) -#else -import Control.Exception as Exception - ( Exception(IOException, ExitException) ) -#endif -import Distribution.Compat.Exception - ( SomeException, catchIO, catchExit ) -import Control.Monad - ( when, unless ) -import System.Directory - ( getTemporaryDirectory, doesFileExist, createDirectoryIfMissing ) -import System.FilePath - ( (), (<.>), takeDirectory ) -import System.IO - ( openFile, IOMode(AppendMode) ) -import System.IO.Error - ( isDoesNotExistError, ioeGetFileName ) - -import Distribution.Client.Dependency - ( resolveDependenciesWithProgress - , PackageConstraint(..), dependencyConstraints, dependencyTargets - , PackagesPreference(..), PackagesPreferenceDefault(..) - , PackagePreference(..) - , Progress(..), foldProgress, ) -import Distribution.Client.Fetch - ( fetchPackage ) -import Distribution.Client.HttpUtils - ( downloadURI ) -import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) --- import qualified Distribution.Client.Info as Info -import Distribution.Client.IndexUtils as IndexUtils - ( getAvailablePackages, disambiguateDependencies - , getInstalledPackages ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan (InstallPlan) -import Distribution.Client.Setup - ( GlobalFlags(..) - , ConfigFlags(..), configureCommand, filterConfigureFlags - , ConfigExFlags(..), InstallFlags(..) ) -import Distribution.Client.Config - ( defaultCabalDir ) -import Distribution.Client.Tar (extractTarGzFile) -import Distribution.Client.Types as Available - ( UnresolvedDependency(..), AvailablePackage(..) - , AvailablePackageSource(..), AvailablePackageDb(..) - , Repo(..), ConfiguredPackage(..) - , BuildResult, BuildFailure(..), BuildSuccess(..) - , DocsResult(..), TestsResult(..), RemoteRepo(..) - , InstalledPackage ) -import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) -import Distribution.Client.SetupWrapper - ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) -import qualified Distribution.Client.BuildReports.Anonymous as BuildReports -import qualified Distribution.Client.BuildReports.Storage as BuildReports - ( storeAnonymous, storeLocal, fromInstallPlan ) -import qualified Distribution.Client.InstallSymlink as InstallSymlink - ( symlinkBinaries ) -import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade -import qualified Distribution.Client.World as World -import Paths_cabal_install (getBinDir) - -import Distribution.Simple.Compiler - ( CompilerId(..), Compiler(compilerId), compilerFlavor - , PackageDB(..), PackageDBStack ) -import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Client.PackageIndex (PackageIndex) -import Distribution.Simple.Setup - ( haddockCommand, HaddockFlags(..), emptyHaddockFlags - , buildCommand, BuildFlags(..), emptyBuildFlags - , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe ) -import qualified Distribution.Simple.Setup as Cabal - ( installCommand, InstallFlags(..), emptyInstallFlags ) -import Distribution.Simple.Utils - ( defaultPackageDesc, rawSystemExit, comparing ) -import Distribution.Simple.InstallDirs as InstallDirs - ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate - , initialPathTemplateEnv, installDirsTemplateEnv ) -import Distribution.Package - ( PackageName(..), PackageIdentifier, packageName, packageVersion - , Package(..), PackageFixedDeps(..) - , Dependency(..), thisPackageVersion ) -import qualified Distribution.PackageDescription as PackageDescription -import Distribution.PackageDescription - ( PackageDescription ) -import Distribution.PackageDescription.Parse - ( readPackageDescription ) -import Distribution.PackageDescription.Configuration - ( finalizePackageDescription ) -import Distribution.Version - ( Version, VersionRange, anyVersion, thisVersion ) -import Distribution.Simple.Utils as Utils - ( notice, info, warn, die, intercalate, withTempDirectory ) -import Distribution.Client.Utils - ( inDir, mergeBy, MergeResult(..) ) -import Distribution.System - ( Platform, buildPlatform, OS(Windows), buildOS ) -import Distribution.Text - ( display ) -import Distribution.Verbosity as Verbosity - ( Verbosity, showForCabal, verbose ) -import Distribution.Simple.BuildPaths ( exeExtension ) - ---TODO: --- * add --upgrade-deps flag --- * add --only-deps flag --- * eliminate upgrade, replaced by --upgrade-deps and world target --- * assign flags to packages individually --- * complain about flags that do not apply to any package given as target --- so flags do not apply to dependencies, only listed, can use flag --- constraints for dependencies --- * only record applicable flags in world file --- * allow flag constraints --- * allow installed constraints --- * allow flag and installed preferences --- * change world file to use cabal section syntax --- * allow persistent configure flags for each package individually - --- ------------------------------------------------------------ --- * Top level user actions --- ------------------------------------------------------------ - --- | An installation target given by the user. At the moment this --- is just a named package, possibly with a version constraint. --- It should be generalised to handle other targets like http or dirs. --- -type InstallTarget = UnresolvedDependency - --- | Installs the packages needed to satisfy a list of dependencies. --- -install, upgrade - :: Verbosity - -> PackageDBStack - -> [Repo] - -> Compiler - -> ProgramConfiguration - -> GlobalFlags - -> ConfigFlags - -> ConfigExFlags - -> InstallFlags - -> [InstallTarget] - -> IO () -install verbosity packageDB repos comp conf - globalFlags configFlags configExFlags installFlags targets = - - installWithPlanner verbosity context planner targets - - where - context :: InstallContext - context = (packageDB, repos, comp, conf, - globalFlags, configFlags, configExFlags, installFlags) - - planner :: Planner - planner - | null targets = planLocalPackage verbosity - comp configFlags configExFlags - - | otherwise = planRepoPackages defaultPref - comp globalFlags configFlags configExFlags - installFlags targets - - defaultPref - | fromFlag (installUpgradeDeps installFlags) = PreferAllLatest - | otherwise = PreferLatestForSelected - - -upgrade _ _ _ _ _ _ _ _ _ _ = die $ - "Use the 'cabal install' command instead of 'cabal upgrade'.\n" - ++ "You can install the latest version of a package using 'cabal install'. " - ++ "The 'cabal upgrade' command has been removed because people found it " - ++ "confusing and it often led to broken packages.\n" - ++ "If you want the old upgrade behaviour then use the install command " - ++ "with the --upgrade-dependencies flag (but check first with --dry-run " - ++ "to see what would happen). This will try to pick the latest versions " - ++ "of all dependencies, rather than the usual behaviour of trying to pick " - ++ "installed versions of all dependencies. If you do use " - ++ "--upgrade-dependencies, it is recommended that you do not upgrade core " - ++ "packages (e.g. by using appropriate --constraint= flags)." - - -type Planner = PackageIndex InstalledPackage - -> AvailablePackageDb - -> IO (Progress String String InstallPlan) - -type InstallContext = ( PackageDBStack - , [Repo] - , Compiler - , ProgramConfiguration - , GlobalFlags - , ConfigFlags - , ConfigExFlags - , InstallFlags ) - --- | Top-level orchestration. Installs the packages generated by a planner. --- -installWithPlanner :: Verbosity - -> InstallContext - -> Planner - -> [UnresolvedDependency] - -> IO () -installWithPlanner verbosity - context@(packageDBs, repos, comp, conf, _, _, _, installFlags) - planner targets = do - - installed <- getInstalledPackages verbosity comp packageDBs conf - available <- getAvailablePackages verbosity repos - - notice verbosity "Resolving dependencies..." - installPlan <- foldProgress logMsg die return =<< planner installed available - - printPlanMessages verbosity installed installPlan dryRun - - unless dryRun $ - performInstallations verbosity context installed installPlan - >>= postInstallActions verbosity context targets - - where - dryRun = fromFlag (installDryRun installFlags) - logMsg message rest = info verbosity message >> rest - --- ------------------------------------------------------------ --- * Installation planning --- ------------------------------------------------------------ - --- | Make an 'InstallPlan' for the unpacked package in the current directory, --- and all its dependencies. --- -planLocalPackage :: Verbosity - -> Compiler - -> ConfigFlags - -> ConfigExFlags - -> Planner -planLocalPackage verbosity comp configFlags configExFlags installed - (AvailablePackageDb available availablePrefs) = do - pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity - let -- The trick is, we add the local package to the available index and - -- remove it from the installed index. Then we ask to resolve a - -- dependency on exactly that package. So the resolver ends up having - -- to pick the local package. - available' = PackageIndex.insert localPkg available - installed' = PackageIndex.deletePackageId (packageId localPkg) installed - localPkg = AvailablePackage { - packageInfoId = packageId pkg, - Available.packageDescription = pkg, - packageSource = LocalUnpackedPackage Nothing - } - targets = [packageName pkg] - constraints = [PackageVersionConstraint (packageName pkg) - (thisVersion (packageVersion pkg)) - ,PackageFlagsConstraint (packageName pkg) - (configConfigurationsFlags configFlags)] - ++ [ PackageVersionConstraint name ver - | Dependency name ver <- configConstraints configFlags ] - preferences = mergePackagePrefs PreferLatestForSelected - availablePrefs configExFlags - - return $ resolveDependenciesWithProgress buildPlatform (compilerId comp) - installed' available' preferences constraints targets - - --- | Make an 'InstallPlan' for the given dependencies. --- -planRepoPackages :: PackagesPreferenceDefault - -> Compiler - -> GlobalFlags - -> ConfigFlags - -> ConfigExFlags - -> InstallFlags - -> [UnresolvedDependency] - -> Planner -planRepoPackages defaultPref comp - globalFlags configFlags configExFlags installFlags - deps installed (AvailablePackageDb available availablePrefs) = do - - deps' <- addWorldPackages deps - >>= IndexUtils.disambiguateDependencies available - - let installed' - | fromFlag (installReinstall installFlags) - = hideGivenDeps deps' installed - | otherwise = installed - targets = dependencyTargets deps' - constraints = dependencyConstraints deps' - ++ [ PackageVersionConstraint name ver - | Dependency name ver <- configConstraints configFlags ] - preferences = mergePackagePrefs defaultPref availablePrefs configExFlags - return $ resolveDependenciesWithProgress buildPlatform (compilerId comp) - installed' available preferences constraints targets - where - hideGivenDeps pkgs index = - foldr PackageIndex.deletePackageName index - [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ] - - addWorldPackages :: [UnresolvedDependency] -> IO [UnresolvedDependency] - addWorldPackages targets = case partition World.isWorldTarget targets of - ([], _) -> return targets - (world, otherTargets) -> do - unless (all World.isGoodWorldTarget world) $ - die $ "The virtual package 'world' does not take any version " - ++ "or configuration flags." - worldTargets <- World.getContents worldFile - --TODO: should we warn if there are no world targets? - return (otherTargets ++ worldTargets) - where - worldFile = fromFlag $ globalWorldFile globalFlags - - -mergePackagePrefs :: PackagesPreferenceDefault - -> Map.Map PackageName VersionRange - -> ConfigExFlags - -> PackagesPreference -mergePackagePrefs defaultPref availablePrefs configExFlags = - PackagesPreference defaultPref $ - -- The preferences that come from the hackage index - [ PackageVersionPreference name ver - | (name, ver) <- Map.toList availablePrefs ] - -- additional preferences from the config file or command line - ++ [ PackageVersionPreference name ver - | Dependency name ver <- configPreferences configExFlags ] - - --- ------------------------------------------------------------ --- * Informational messages --- ------------------------------------------------------------ - -printPlanMessages :: Verbosity - -> PackageIndex InstalledPackage - -> InstallPlan - -> Bool - -> IO () -printPlanMessages verbosity installed installPlan dryRun = do - - when nothingToInstall $ - notice verbosity $ - "No packages to be installed. All the requested packages are " - ++ "already installed.\n If you want to reinstall anyway then use " - ++ "the --reinstall flag." - - when (dryRun || verbosity >= verbose) $ - printDryRun verbosity installed installPlan - - where - nothingToInstall = null (InstallPlan.ready installPlan) - - -printDryRun :: Verbosity - -> PackageIndex InstalledPackage - -> InstallPlan - -> IO () -printDryRun verbosity installed plan = case unfoldr next plan of - [] -> return () - pkgs - | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $ - "In order, the following would be installed:" - : map showPkgAndReason pkgs - | otherwise -> notice verbosity $ unlines $ - "In order, the following would be installed (use -v for more details):" - : map (display . packageId) pkgs - where - next plan' = case InstallPlan.ready plan' of - [] -> Nothing - (pkg:_) -> Just (pkg, InstallPlan.completed pkgid result plan') - where pkgid = packageId pkg - result = BuildOk DocsNotTried TestsNotTried - --FIXME: This is a bit of a hack, - -- pretending that each package is installed - - showPkgAndReason pkg' = display (packageId pkg') ++ " " ++ - case PackageIndex.lookupPackageName installed (packageName pkg') of - [] -> "(new package)" - ps -> case find ((==packageId pkg') . packageId) ps of - Nothing -> "(new version)" - Just pkg -> "(reinstall)" ++ case changes pkg pkg' of - [] -> "" - diff -> " changes: " ++ intercalate ", " diff - changes pkg pkg' = map change . filter changed - $ mergeBy (comparing packageName) - (nub . sort . depends $ pkg) - (nub . sort . depends $ pkg') - change (OnlyInLeft pkgid) = display pkgid ++ " removed" - change (InBoth pkgid pkgid') = display pkgid ++ " -> " - ++ display (packageVersion pkgid') - change (OnlyInRight pkgid') = display pkgid' ++ " added" - changed (InBoth pkgid pkgid') = pkgid /= pkgid' - changed _ = True - --- ------------------------------------------------------------ --- * Post installation stuff --- ------------------------------------------------------------ - --- | Various stuff we do after successful or unsuccessfully installing a bunch --- of packages. This includes: --- --- * build reporting, local and remote --- * symlinking binaries --- * updating indexes --- * updating world file --- * error reporting --- -postInstallActions :: Verbosity - -> InstallContext - -> [InstallTarget] - -> InstallPlan - -> IO () -postInstallActions verbosity - (packageDBs, _, comp, conf, globalFlags, configFlags, _, installFlags) - targets installPlan = do - - unless oneShot $ - World.insert verbosity worldFile targets' - - let buildReports = BuildReports.fromInstallPlan installPlan - BuildReports.storeLocal (installSummaryFile installFlags) buildReports - when (reportingLevel >= AnonymousReports) $ - BuildReports.storeAnonymous buildReports - when (reportingLevel == DetailedReports) $ - storeDetailedBuildReports verbosity logsDir buildReports - - regenerateHaddockIndex verbosity packageDBs comp conf - configFlags installFlags installPlan - - symlinkBinaries verbosity configFlags installFlags installPlan - - printBuildFailures installPlan - - where - reportingLevel = fromFlag (installBuildReports installFlags) - logsDir = fromFlag (globalLogsDir globalFlags) - oneShot = fromFlag (installOneShot installFlags) - worldFile = fromFlag $ globalWorldFile globalFlags - targets' = filter (not . World.isWorldTarget) targets - -storeDetailedBuildReports :: Verbosity -> FilePath - -> [(BuildReports.BuildReport, Repo)] -> IO () -storeDetailedBuildReports verbosity logsDir reports = sequence_ - [ do dotCabal <- defaultCabalDir - let logFileName = display (BuildReports.package report) <.> "log" - logFile = logsDir logFileName - reportsDir = dotCabal "reports" remoteRepoName remoteRepo - reportFile = reportsDir logFileName - - handleMissingLogFile $ do - buildLog <- readFile logFile - createDirectoryIfMissing True reportsDir -- FIXME - writeFile reportFile (show (BuildReports.show report, buildLog)) - - | (report, Repo { repoKind = Left remoteRepo }) <- reports - , isLikelyToHaveLogFile (BuildReports.installOutcome report) ] - - where - isLikelyToHaveLogFile BuildReports.ConfigureFailed {} = True - isLikelyToHaveLogFile BuildReports.BuildFailed {} = True - isLikelyToHaveLogFile BuildReports.InstallFailed {} = True - isLikelyToHaveLogFile BuildReports.InstallOk {} = True - isLikelyToHaveLogFile _ = False - - handleMissingLogFile = Exception.handleJust missingFile $ \ioe -> - warn verbosity $ "Missing log file for build report: " - ++ fromMaybe "" (ioeGetFileName ioe) - -#if MIN_VERSION_base(4,0,0) - missingFile ioe -#else - missingFile (IOException ioe) -#endif - | isDoesNotExistError ioe = Just ioe - missingFile _ = Nothing - - -regenerateHaddockIndex :: Verbosity - -> [PackageDB] - -> Compiler - -> ProgramConfiguration - -> ConfigFlags - -> InstallFlags - -> InstallPlan - -> IO () -regenerateHaddockIndex verbosity packageDBs comp conf - configFlags installFlags installPlan - | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do - - defaultDirs <- InstallDirs.defaultInstallDirs - (compilerFlavor comp) - (fromFlag (configUserInstall configFlags)) - True - let indexFileTemplate = fromFlag (installHaddockIndex installFlags) - indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate - - notice verbosity $ - "Updating documentation index " ++ indexFile - - --TODO: might be nice if the install plan gave us the new InstalledPackageInfo - installed <- getInstalledPackages verbosity comp packageDBs conf - Haddock.regenerateHaddockIndex verbosity installed conf indexFile - - | otherwise = return () - where - haddockIndexFileIsRequested = - fromFlag (installDocumentation installFlags) - && isJust (flagToMaybe (installHaddockIndex installFlags)) - - -- We want to regenerate the index if some new documentation was actually - -- installed. Since the index is per-user, we don't do it for global - -- installs or special cases where we're installing into a specific db. - shouldRegenerateHaddockIndex = normalUserInstall - && someDocsWereInstalled installPlan - where - someDocsWereInstalled = any installedDocs . InstallPlan.toList - normalUserInstall = (UserPackageDB `elem` packageDBs) - && all (not . isSpecificPackageDB) packageDBs - - installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _)) = True - installedDocs _ = False - isSpecificPackageDB (SpecificPackageDB _) = True - isSpecificPackageDB _ = False - - substHaddockIndexFileName defaultDirs = fromPathTemplate - . substPathTemplate env - where - env = env0 ++ installDirsTemplateEnv absoluteDirs - env0 = InstallDirs.compilerTemplateEnv (compilerId comp) - ++ InstallDirs.platformTemplateEnv (buildPlatform) - absoluteDirs = InstallDirs.substituteInstallDirTemplates - env0 templateDirs - templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault - defaultDirs (configInstallDirs configFlags) - - -symlinkBinaries :: Verbosity - -> ConfigFlags - -> InstallFlags - -> InstallPlan -> IO () -symlinkBinaries verbosity configFlags installFlags plan = do - failed <- InstallSymlink.symlinkBinaries configFlags installFlags plan - case failed of - [] -> return () - [(_, exe, path)] -> - warn verbosity $ - "could not create a symlink in " ++ bindir ++ " for " - ++ exe ++ " because the file exists there already but is not " - ++ "managed by cabal. You can create a symlink for this executable " - ++ "manually if you wish. The executable file has been installed at " - ++ path - exes -> - warn verbosity $ - "could not create symlinks in " ++ bindir ++ " for " - ++ intercalate ", " [ exe | (_, exe, _) <- exes ] - ++ " because the files exist there already and are not " - ++ "managed by cabal. You can create symlinks for these executables " - ++ "manually if you wish. The executable files have been installed at " - ++ intercalate ", " [ path | (_, _, path) <- exes ] - where - bindir = fromFlag (installSymlinkBinDir installFlags) - - -printBuildFailures :: InstallPlan -> IO () -printBuildFailures plan = - case [ (pkg, reason) - | InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of - [] -> return () - failed -> die . unlines - $ "Error: some packages failed to install:" - : [ display (packageId pkg) ++ printFailureReason reason - | (pkg, reason) <- failed ] - where - printFailureReason reason = case reason of - DependentFailed pkgid -> " depends on " ++ display pkgid - ++ " which failed to install." - DownloadFailed e -> " failed while downloading the package." - ++ " The exception was:\n " ++ show e - UnpackFailed e -> " failed while unpacking the package." - ++ " The exception was:\n " ++ show e - ConfigureFailed e -> " failed during the configure step." - ++ " The exception was:\n " ++ show e - BuildFailed e -> " failed during the building phase." - ++ " The exception was:\n " ++ show e - InstallFailed e -> " failed during the final install step." - ++ " The exception was:\n " ++ show e - - --- ------------------------------------------------------------ --- * Actually do the installations --- ------------------------------------------------------------ - -data InstallMisc = InstallMisc { - rootCmd :: Maybe FilePath, - libVersion :: Maybe Version - } - -performInstallations :: Verbosity - -> InstallContext - -> PackageIndex InstalledPackage - -> InstallPlan - -> IO InstallPlan -performInstallations verbosity - (packageDBs, _, comp, conf, - globalFlags, configFlags, configExFlags, installFlags) - installed installPlan = do - - executeInstallPlan installPlan $ \cpkg -> - installConfiguredPackage platform compid configFlags - cpkg $ \configFlags' src pkg -> - installAvailablePackage verbosity (packageId pkg) src $ \mpath -> - installUnpackedPackage verbosity (setupScriptOptions installed) - miscOptions configFlags' installFlags - compid pkg mpath useLogFile - - where - platform = InstallPlan.planPlatform installPlan - compid = InstallPlan.planCompiler installPlan - - setupScriptOptions index = SetupScriptOptions { - useCabalVersion = maybe anyVersion thisVersion (libVersion miscOptions), - useCompiler = Just comp, - -- Hack: we typically want to allow the UserPackageDB for finding the - -- Cabal lib when compiling any Setup.hs even if we're doing a global - -- install. However we also allow looking in a specific package db. - usePackageDB = if UserPackageDB `elem` packageDBs - then packageDBs - else let (db@GlobalPackageDB:dbs) = packageDBs - in db : UserPackageDB : dbs, - --TODO: use Ord instance: - -- insert UserPackageDB packageDBs - usePackageIndex = if UserPackageDB `elem` packageDBs - then Just index - else Nothing, - useProgramConfig = conf, - useDistPref = fromFlagOrDefault - (useDistPref defaultSetupScriptOptions) - (configDistPref configFlags), - useLoggingHandle = Nothing, - useWorkingDir = Nothing - } - reportingLevel = fromFlag (installBuildReports installFlags) - logsDir = fromFlag (globalLogsDir globalFlags) - useLogFile :: Maybe (PackageIdentifier -> FilePath) - useLogFile = fmap substLogFileName logFileTemplate - where - logFileTemplate :: Maybe PathTemplate - logFileTemplate --TODO: separate policy from mechanism - | reportingLevel == DetailedReports - = Just $ toPathTemplate $ logsDir "$pkgid" <.> "log" - | otherwise - = flagToMaybe (installLogFile installFlags) - substLogFileName template pkg = fromPathTemplate - . substPathTemplate env - $ template - where env = initialPathTemplateEnv (packageId pkg) (compilerId comp) - miscOptions = InstallMisc { - rootCmd = if fromFlag (configUserInstall configFlags) - then Nothing -- ignore --root-cmd if --user. - else flagToMaybe (installRootCmd installFlags), - libVersion = flagToMaybe (configCabalVersion configExFlags) - } - - -executeInstallPlan :: Monad m - => InstallPlan - -> (ConfiguredPackage -> m BuildResult) - -> m InstallPlan -executeInstallPlan plan installPkg = case InstallPlan.ready plan of - [] -> return plan - (pkg: _) -> do buildResult <- installPkg pkg - let plan' = updatePlan (packageId pkg) buildResult plan - executeInstallPlan plan' installPkg - where - updatePlan pkgid (Right buildSuccess) = - InstallPlan.completed pkgid buildSuccess - - updatePlan pkgid (Left buildFailure) = - InstallPlan.failed pkgid buildFailure depsFailure - where - depsFailure = DependentFailed pkgid - -- So this first pkgid failed for whatever reason (buildFailure). - -- All the other packages that depended on this pkgid, which we - -- now cannot build, we mark as failing due to 'DependentFailed' - -- which kind of means it was not their fault. - - --- | Call an installer for an 'AvailablePackage' but override the configure --- flags with the ones given by the 'ConfiguredPackage'. In particular the --- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly --- versioned package dependencies. So we ignore any previous partial flag --- assignment or dependency constraints and use the new ones. --- -installConfiguredPackage :: Platform -> CompilerId - -> ConfigFlags -> ConfiguredPackage - -> (ConfigFlags -> AvailablePackageSource - -> PackageDescription -> a) - -> a -installConfiguredPackage platform comp configFlags - (ConfiguredPackage (AvailablePackage _ gpkg source) flags deps) - installPkg = installPkg configFlags { - configConfigurationsFlags = flags, - configConstraints = map thisPackageVersion deps - } source pkg - where - pkg = case finalizePackageDescription flags - (const True) - platform comp [] gpkg of - Left _ -> error "finalizePackageDescription ConfiguredPackage failed" - Right (desc, _) -> desc - - -installAvailablePackage - :: Verbosity -> PackageIdentifier -> AvailablePackageSource - -> (Maybe FilePath -> IO BuildResult) - -> IO BuildResult -installAvailablePackage _ _ (LocalUnpackedPackage dir) installPkg = - installPkg dir - -installAvailablePackage verbosity pkgid - (LocalTarballPackage tarballPath) installPkg = do - tmp <- getTemporaryDirectory - withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath -> - installLocalTarballPackage verbosity pkgid - tarballPath tmpDirPath installPkg - -installAvailablePackage verbosity pkgid - (RemoteTarballPackage tarballURL) installPkg = do - tmp <- getTemporaryDirectory - withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath -> - onFailure DownloadFailed $ do - let tarballPath = tmpDirPath display pkgid <.> "tar.gz" - --TODO: perhaps we've already had to download this to a local cache - -- so we even know what package version it is. So might be able - -- to get it from the local cache rather than from remote. - downloadURI verbosity tarballURL tarballPath - installLocalTarballPackage verbosity pkgid - tarballPath tmpDirPath installPkg - -installAvailablePackage verbosity pkgid (RepoTarballPackage repo) installPkg = - onFailure DownloadFailed $ do - tarballPath <- fetchPackage verbosity repo pkgid - tmp <- getTemporaryDirectory - withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath -> - installLocalTarballPackage verbosity pkgid - tarballPath tmpDirPath installPkg - -installLocalTarballPackage - :: Verbosity -> PackageIdentifier -> FilePath -> FilePath - -> (Maybe FilePath -> IO BuildResult) - -> IO BuildResult -installLocalTarballPackage verbosity pkgid tarballPath tmpDirPath installPkg = - onFailure UnpackFailed $ do - info verbosity $ "Extracting " ++ tarballPath - ++ " to " ++ tmpDirPath ++ "..." - let relUnpackedPath = display pkgid - absUnpackedPath = tmpDirPath relUnpackedPath - descFilePath = absUnpackedPath - display (packageName pkgid) <.> "cabal" - extractTarGzFile tmpDirPath relUnpackedPath tarballPath - exists <- doesFileExist descFilePath - when (not exists) $ - die $ "Package .cabal file not found: " ++ show descFilePath - installPkg (Just absUnpackedPath) - - -installUnpackedPackage :: Verbosity - -> SetupScriptOptions - -> InstallMisc - -> ConfigFlags - -> InstallFlags - -> CompilerId - -> PackageDescription - -> Maybe FilePath -- ^ Directory to change to before starting the installation. - -> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any) - -> IO BuildResult -installUnpackedPackage verbosity scriptOptions miscOptions - configFlags installConfigFlags - compid pkg workingDir useLogFile = - - -- Configure phase - onFailure ConfigureFailed $ do - setup configureCommand configureFlags - - -- Build phase - onFailure BuildFailed $ do - setup buildCommand' buildFlags - - -- Doc generation phase - docsResult <- if shouldHaddock - then (do setup haddockCommand haddockFlags - return DocsOk) - `catchIO` (\_ -> return DocsFailed) - `catchExit` (\_ -> return DocsFailed) - else return DocsNotTried - - -- Tests phase - testsResult <- return TestsNotTried --TODO: add optional tests - - -- Install phase - onFailure InstallFailed $ - withWin32SelfUpgrade verbosity configFlags compid pkg $ do - case rootCmd miscOptions of - (Just cmd) -> reexec cmd - Nothing -> setup Cabal.installCommand installFlags - return (Right (BuildOk docsResult testsResult)) - - where - configureFlags = filterConfigureFlags configFlags { - configVerbosity = toFlag verbosity' - } - buildCommand' = buildCommand defaultProgramConfiguration - buildFlags _ = emptyBuildFlags { - buildDistPref = configDistPref configFlags, - buildVerbosity = toFlag verbosity' - } - shouldHaddock = fromFlag (installDocumentation installConfigFlags) - haddockFlags _ = emptyHaddockFlags { - haddockDistPref = configDistPref configFlags, - haddockVerbosity = toFlag verbosity' - } - installFlags _ = Cabal.emptyInstallFlags { - Cabal.installDistPref = configDistPref configFlags, - Cabal.installVerbosity = toFlag verbosity' - } - verbosity' | isJust useLogFile = max Verbosity.verbose verbosity - | otherwise = verbosity - setup cmd flags = do - logFileHandle <- case useLogFile of - Nothing -> return Nothing - Just mkLogFileName -> do - let logFileName = mkLogFileName (packageId pkg) - logDir = takeDirectory logFileName - unless (null logDir) $ createDirectoryIfMissing True logDir - logFile <- openFile logFileName AppendMode - return (Just logFile) - - setupWrapper verbosity - scriptOptions { useLoggingHandle = logFileHandle - , useWorkingDir = workingDir } - (Just pkg) - cmd flags [] - reexec cmd = do - -- look for our on executable file and re-exec ourselves using - -- a helper program like sudo to elevate priviledges: - bindir <- getBinDir - let self = bindir "cabal" <.> exeExtension - weExist <- doesFileExist self - if weExist - then inDir workingDir $ - rawSystemExit verbosity cmd - [self, "install", "--only" - ,"--verbose=" ++ showForCabal verbosity] - else die $ "Unable to find cabal executable at: " ++ self - - --- helper -onFailure :: (SomeException -> BuildFailure) -> IO BuildResult -> IO BuildResult -onFailure result action = -#if MIN_VERSION_base(4,0,0) - action `catches` - [ Handler $ \ioe -> handler (ioe :: IOException) - , Handler $ \exit -> handler (exit :: ExitCode) - ] - where - handler :: Exception e => e -> IO BuildResult - handler = return . Left . result . toException -#else - action - `catchIO` (return . Left . result . IOException) - `catchExit` (return . Left . result . ExitException) -#endif - - --- ------------------------------------------------------------ --- * Wierd windows hacks --- ------------------------------------------------------------ - -withWin32SelfUpgrade :: Verbosity - -> ConfigFlags - -> CompilerId - -> PackageDescription - -> IO a -> IO a -withWin32SelfUpgrade _ _ _ _ action | buildOS /= Windows = action -withWin32SelfUpgrade verbosity configFlags compid pkg action = do - - defaultDirs <- InstallDirs.defaultInstallDirs - compFlavor - (fromFlag (configUserInstall configFlags)) - (PackageDescription.hasLibs pkg) - - Win32SelfUpgrade.possibleSelfUpgrade verbosity - (exeInstallPaths defaultDirs) action - - where - pkgid = packageId pkg - (CompilerId compFlavor _) = compid - - exeInstallPaths defaultDirs = - [ InstallDirs.bindir absoluteDirs exeName <.> exeExtension - | exe <- PackageDescription.executables pkg - , PackageDescription.buildable (PackageDescription.buildInfo exe) - , let exeName = prefix ++ PackageDescription.exeName exe ++ suffix - prefix = substTemplate prefixTemplate - suffix = substTemplate suffixTemplate ] - where - fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") - prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) - suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) - templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault - defaultDirs (configInstallDirs configFlags) - absoluteDirs = InstallDirs.absoluteInstallDirs - pkgid compid InstallDirs.NoCopyDest templateDirs - substTemplate = InstallDirs.fromPathTemplate - . InstallDirs.substPathTemplate env - where env = InstallDirs.initialPathTemplateEnv pkgid compid diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/InstallPlan.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/InstallPlan.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/InstallPlan.hs +++ /dev/null @@ -1,495 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.InstallPlan --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : duncan@haskell.org --- Stability : provisional --- Portability : portable --- --- Package installation plan --- ------------------------------------------------------------------------------ -module Distribution.Client.InstallPlan ( - InstallPlan, - ConfiguredPackage(..), - PlanPackage(..), - - -- * Operations on 'InstallPlan's - new, - toList, - ready, - completed, - failed, - - -- ** Query functions - planPlatform, - planCompiler, - - -- * Checking valididy of plans - valid, - closed, - consistent, - acyclic, - configuredPackageValid, - - -- ** Details on invalid plans - PlanProblem(..), - showPlanProblem, - PackageProblem(..), - showPackageProblem, - problems, - configuredPackageProblems - ) where - -import Distribution.Client.Types - ( AvailablePackage(packageDescription), ConfiguredPackage(..) - , InstalledPackage - , BuildFailure, BuildSuccess ) -import Distribution.Package - ( PackageIdentifier(..), PackageName(..), Package(..), packageName - , PackageFixedDeps(..), Dependency(..) ) -import Distribution.Version - ( Version, withinRange ) -import Distribution.PackageDescription - ( GenericPackageDescription(genPackageFlags) - , Flag(flagName), FlagName(..) ) -import Distribution.Client.PackageUtils - ( externalBuildDepends ) -import Distribution.PackageDescription.Configuration - ( finalizePackageDescription ) -import Distribution.Client.PackageIndex - ( PackageIndex ) -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Text - ( display ) -import Distribution.System - ( Platform ) -import Distribution.Compiler - ( CompilerId(..) ) -import Distribution.Client.Utils - ( duplicates, duplicatesBy, mergeBy, MergeResult(..) ) -import Distribution.Simple.Utils - ( comparing, intercalate ) - -import Data.List - ( sort, sortBy ) -import Data.Maybe - ( fromMaybe ) -import qualified Data.Graph as Graph -import Data.Graph (Graph) -import Control.Exception - ( assert ) - --- When cabal tries to install a number of packages, including all their --- dependencies it has a non-trivial problem to solve. --- --- The Problem: --- --- In general we start with a set of installed packages and a set of available --- packages. --- --- Installed packages have fixed dependencies. They have already been built and --- we know exactly what packages they were built against, including their exact --- versions. --- --- Available package have somewhat flexible dependencies. They are specified as --- version ranges, though really they're predicates. To make matters worse they --- have conditional flexible dependencies. Configuration flags can affect which --- packages are required and can place additional constraints on their --- versions. --- --- These two sets of package can and usually do overlap. There can be installed --- packages that are also available which means they could be re-installed if --- required, though there will also be packages which are not available and --- cannot be re-installed. Very often there will be extra versions available --- than are installed. Sometimes we may like to prefer installed packages over --- available ones or perhaps always prefer the latest available version whether --- installed or not. --- --- The goal is to calculate an installation plan that is closed, acyclic and --- consistent and where every configured package is valid. --- --- An installation plan is a set of packages that are going to be used --- together. It will consist of a mixture of installed packages and available --- packages along with their exact version dependencies. An installation plan --- is closed if for every package in the set, all of its dependencies are --- also in the set. It is consistent if for every package in the set, all --- dependencies which target that package have the same version. - --- Note that plans do not necessarily compose. You might have a valid plan for --- package A and a valid plan for package B. That does not mean the composition --- is simultaniously valid for A and B. In particular you're most likely to --- have problems with inconsistent dependencies. --- On the other hand it is true that every closed sub plan is valid. - -data PlanPackage = PreExisting InstalledPackage - | Configured ConfiguredPackage - | Installed ConfiguredPackage BuildSuccess - | Failed ConfiguredPackage BuildFailure - -instance Package PlanPackage where - packageId (PreExisting pkg) = packageId pkg - packageId (Configured pkg) = packageId pkg - packageId (Installed pkg _) = packageId pkg - packageId (Failed pkg _) = packageId pkg - -instance PackageFixedDeps PlanPackage where - depends (PreExisting pkg) = depends pkg - depends (Configured pkg) = depends pkg - depends (Installed pkg _) = depends pkg - depends (Failed pkg _) = depends pkg - -data InstallPlan = InstallPlan { - planIndex :: PackageIndex PlanPackage, - planGraph :: Graph, - planGraphRev :: Graph, - planPkgOf :: Graph.Vertex -> PlanPackage, - planVertexOf :: PackageIdentifier -> Graph.Vertex, - planPlatform :: Platform, - planCompiler :: CompilerId - } - -invariant :: InstallPlan -> Bool -invariant plan = - valid (planPlatform plan) (planCompiler plan) (planIndex plan) - -internalError :: String -> a -internalError msg = error $ "InstallPlan: internal error: " ++ msg - --- | Build an installation plan from a valid set of resolved packages. --- -new :: Platform -> CompilerId -> PackageIndex PlanPackage - -> Either [PlanProblem] InstallPlan -new platform compiler index = - case problems platform compiler index of - [] -> Right InstallPlan { - planIndex = index, - planGraph = graph, - planGraphRev = Graph.transposeG graph, - planPkgOf = vertexToPkgId, - planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex, - planPlatform = platform, - planCompiler = compiler - } - where (graph, vertexToPkgId, pkgIdToVertex) = - PackageIndex.dependencyGraph index - noSuchPkgId = internalError "package is not in the graph" - probs -> Left probs - -toList :: InstallPlan -> [PlanPackage] -toList = PackageIndex.allPackages . planIndex - --- | The packages that are ready to be installed. That is they are in the --- configured state and have all their dependencies installed already. --- The plan is complete if the result is @[]@. --- -ready :: InstallPlan -> [ConfiguredPackage] -ready plan = assert check readyPackages - where - check = if null readyPackages then null configuredPackages else True - configuredPackages = - [ pkg | Configured pkg <- PackageIndex.allPackages (planIndex plan) ] - readyPackages = filter (all isInstalled . depends) configuredPackages - isInstalled pkg = - case PackageIndex.lookupPackageId (planIndex plan) pkg of - Just (Configured _) -> False - Just (Failed _ _) -> internalError depOnFailed - Just (PreExisting _) -> True - Just (Installed _ _) -> True - Nothing -> internalError incomplete - incomplete = "install plan is not closed" - depOnFailed = "configured package depends on failed package" - --- | Marks a package in the graph as completed. Also saves the build result for --- the completed package in the plan. --- --- * The package must exist in the graph. --- * The package must have had no uninstalled dependent packages. --- -completed :: PackageIdentifier - -> BuildSuccess - -> InstallPlan -> InstallPlan -completed pkgid buildResult plan = assert (invariant plan') plan' - where - plan' = plan { - planIndex = PackageIndex.insert installed (planIndex plan) - } - installed = Installed (lookupConfiguredPackage plan pkgid) buildResult - --- | Marks a package in the graph as having failed. It also marks all the --- packages that depended on it as having failed. --- --- * The package must exist in the graph and be in the configured state. --- -failed :: PackageIdentifier -- ^ The id of the package that failed to install - -> BuildFailure -- ^ The build result to use for the failed package - -> BuildFailure -- ^ The build result to use for its dependencies - -> InstallPlan - -> InstallPlan -failed pkgid buildResult buildResult' plan = assert (invariant plan') plan' - where - plan' = plan { - planIndex = PackageIndex.merge (planIndex plan) failures - } - pkg = lookupConfiguredPackage plan pkgid - failures = PackageIndex.fromList - $ Failed pkg buildResult - : [ Failed pkg' buildResult' - | Just pkg' <- map checkConfiguredPackage - $ packagesThatDependOn plan pkgid ] - --- | lookup the reachable packages in the reverse dependency graph --- -packagesThatDependOn :: InstallPlan - -> PackageIdentifier -> [PlanPackage] -packagesThatDependOn plan = map (planPkgOf plan) - . tail - . Graph.reachable (planGraphRev plan) - . planVertexOf plan - --- | lookup a package that we expect to be in the configured state --- -lookupConfiguredPackage :: InstallPlan - -> PackageIdentifier -> ConfiguredPackage -lookupConfiguredPackage plan pkgid = - case PackageIndex.lookupPackageId (planIndex plan) pkgid of - Just (Configured pkg) -> pkg - _ -> internalError $ "not configured or no such pkg " ++ display pkgid - --- | check a package that we expect to be in the configured or failed state --- -checkConfiguredPackage :: PlanPackage -> Maybe ConfiguredPackage -checkConfiguredPackage (Configured pkg) = Just pkg -checkConfiguredPackage (Failed _ _) = Nothing -checkConfiguredPackage pkg = - internalError $ "not configured or no such pkg " ++ display (packageId pkg) - --- ------------------------------------------------------------ --- * Checking valididy of plans --- ------------------------------------------------------------ - --- | A valid installation plan is a set of packages that is 'acyclic', --- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the --- plan has to have a valid configuration (see 'configuredPackageValid'). --- --- * if the result is @False@ use 'problems' to get a detailed list. --- -valid :: Platform -> CompilerId -> PackageIndex PlanPackage -> Bool -valid platform comp index = null (problems platform comp index) - -data PlanProblem = - PackageInvalid ConfiguredPackage [PackageProblem] - | PackageMissingDeps PlanPackage [PackageIdentifier] - | PackageCycle [PlanPackage] - | PackageInconsistency PackageName [(PackageIdentifier, Version)] - | PackageStateInvalid PlanPackage PlanPackage - -showPlanProblem :: PlanProblem -> String -showPlanProblem (PackageInvalid pkg packageProblems) = - "Package " ++ display (packageId pkg) - ++ " has an invalid configuration, in particular:\n" - ++ unlines [ " " ++ showPackageProblem problem - | problem <- packageProblems ] - -showPlanProblem (PackageMissingDeps pkg missingDeps) = - "Package " ++ display (packageId pkg) - ++ " depends on the following packages which are missing from the plan " - ++ intercalate ", " (map display missingDeps) - -showPlanProblem (PackageCycle cycleGroup) = - "The following packages are involved in a dependency cycle " - ++ intercalate ", " (map (display.packageId) cycleGroup) - -showPlanProblem (PackageInconsistency name inconsistencies) = - "Package " ++ display name - ++ " is required by several packages," - ++ " but they require inconsistent versions:\n" - ++ unlines [ " package " ++ display pkg ++ " requires " - ++ display (PackageIdentifier name ver) - | (pkg, ver) <- inconsistencies ] - -showPlanProblem (PackageStateInvalid pkg pkg') = - "Package " ++ display (packageId pkg) - ++ " is in the " ++ showPlanState pkg - ++ " state but it depends on package " ++ display (packageId pkg') - ++ " which is in the " ++ showPlanState pkg' - ++ " state" - where - showPlanState (PreExisting _) = "pre-existing" - showPlanState (Configured _) = "configured" - showPlanState (Installed _ _) = "installed" - showPlanState (Failed _ _) = "failed" - --- | For an invalid plan, produce a detailed list of problems as human readable --- error messages. This is mainly intended for debugging purposes. --- Use 'showPlanProblem' for a human readable explanation. --- -problems :: Platform -> CompilerId - -> PackageIndex PlanPackage -> [PlanProblem] -problems platform comp index = - [ PackageInvalid pkg packageProblems - | Configured pkg <- PackageIndex.allPackages index - , let packageProblems = configuredPackageProblems platform comp pkg - , not (null packageProblems) ] - - ++ [ PackageMissingDeps pkg missingDeps - | (pkg, missingDeps) <- PackageIndex.brokenPackages index ] - - ++ [ PackageCycle cycleGroup - | cycleGroup <- PackageIndex.dependencyCycles index ] - - ++ [ PackageInconsistency name inconsistencies - | (name, inconsistencies) <- PackageIndex.dependencyInconsistencies index ] - - ++ [ PackageStateInvalid pkg pkg' - | pkg <- PackageIndex.allPackages index - , Just pkg' <- map (PackageIndex.lookupPackageId index) (depends pkg) - , not (stateDependencyRelation pkg pkg') ] - --- | The graph of packages (nodes) and dependencies (edges) must be acyclic. --- --- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out --- which packages are involved in dependency cycles. --- -acyclic :: PackageIndex PlanPackage -> Bool -acyclic = null . PackageIndex.dependencyCycles - --- | An installation plan is closed if for every package in the set, all of --- its dependencies are also in the set. That is, the set is closed under the --- dependency relation. --- --- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out --- which packages depend on packages not in the index. --- -closed :: PackageIndex PlanPackage -> Bool -closed = null . PackageIndex.brokenPackages - --- | An installation plan is consistent if all dependencies that target a --- single package name, target the same version. --- --- This is slightly subtle. It is not the same as requiring that there be at --- most one version of any package in the set. It only requires that of --- packages which have more than one other package depending on them. We could --- actually make the condition even more precise and say that different --- versions are ok so long as they are not both in the transative closure of --- any other package (or equivalently that their inverse closures do not --- intersect). The point is we do not want to have any packages depending --- directly or indirectly on two different versions of the same package. The --- current definition is just a safe aproximation of that. --- --- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to --- find out which packages are. --- -consistent :: PackageIndex PlanPackage -> Bool -consistent = null . PackageIndex.dependencyInconsistencies - --- | The states of packages have that depend on each other must respect --- this relation. That is for very case where package @a@ depends on --- package @b@ we require that @dependencyStatesOk a b = True@. --- -stateDependencyRelation :: PlanPackage -> PlanPackage -> Bool -stateDependencyRelation (PreExisting _) (PreExisting _) = True - -stateDependencyRelation (Configured _) (PreExisting _) = True -stateDependencyRelation (Configured _) (Configured _) = True -stateDependencyRelation (Configured _) (Installed _ _) = True - -stateDependencyRelation (Installed _ _) (PreExisting _) = True -stateDependencyRelation (Installed _ _) (Installed _ _) = True - -stateDependencyRelation (Failed _ _) (PreExisting _) = True --- failed can depends on configured because a package can depend on --- several other packages and if one of the deps fail then we fail --- but we still depend on the other ones that did not fail: -stateDependencyRelation (Failed _ _) (Configured _) = True -stateDependencyRelation (Failed _ _) (Installed _ _) = True -stateDependencyRelation (Failed _ _) (Failed _ _) = True - -stateDependencyRelation _ _ = False - --- | A 'ConfiguredPackage' is valid if the flag assignment is total and if --- in the configuration given by the flag assignment, all the package --- dependencies are satisfied by the specified packages. --- -configuredPackageValid :: Platform -> CompilerId -> ConfiguredPackage -> Bool -configuredPackageValid platform comp pkg = - null (configuredPackageProblems platform comp pkg) - -data PackageProblem = DuplicateFlag FlagName - | MissingFlag FlagName - | ExtraFlag FlagName - | DuplicateDeps [PackageIdentifier] - | MissingDep Dependency - | ExtraDep PackageIdentifier - | InvalidDep Dependency PackageIdentifier - -showPackageProblem :: PackageProblem -> String -showPackageProblem (DuplicateFlag (FlagName flag)) = - "duplicate flag in the flag assignment: " ++ flag - -showPackageProblem (MissingFlag (FlagName flag)) = - "missing an assignment for the flag: " ++ flag - -showPackageProblem (ExtraFlag (FlagName flag)) = - "extra flag given that is not used by the package: " ++ flag - -showPackageProblem (DuplicateDeps pkgids) = - "duplicate packages specified as selected dependencies: " - ++ intercalate ", " (map display pkgids) - -showPackageProblem (MissingDep dep) = - "the package has a dependency " ++ display dep - ++ " but no package has been selected to satisfy it." - -showPackageProblem (ExtraDep pkgid) = - "the package configuration specifies " ++ display pkgid - ++ " but (with the given flag assignment) the package does not actually" - ++ " depend on any version of that package." - -showPackageProblem (InvalidDep dep pkgid) = - "the package depends on " ++ display dep - ++ " but the configuration specifies " ++ display pkgid - ++ " which does not satisfy the dependency." - -configuredPackageProblems :: Platform -> CompilerId - -> ConfiguredPackage -> [PackageProblem] -configuredPackageProblems platform comp - (ConfiguredPackage pkg specifiedFlags specifiedDeps) = - [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ] - ++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ] - ++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ] - ++ [ DuplicateDeps pkgs - | pkgs <- duplicatesBy (comparing packageName) specifiedDeps ] - ++ [ MissingDep dep | OnlyInLeft dep <- mergedDeps ] - ++ [ ExtraDep pkgid | OnlyInRight pkgid <- mergedDeps ] - ++ [ InvalidDep dep pkgid | InBoth dep pkgid <- mergedDeps - , not (packageSatisfiesDependency pkgid dep) ] - where - mergedFlags = mergeBy compare - (sort $ map flagName (genPackageFlags (packageDescription pkg))) - (sort $ map fst specifiedFlags) - - mergedDeps = mergeBy - (\dep pkgid -> dependencyName dep `compare` packageName pkgid) - (sortBy (comparing dependencyName) requiredDeps) - (sortBy (comparing packageName) specifiedDeps) - - packageSatisfiesDependency - (PackageIdentifier name version) - (Dependency name' versionRange) = assert (name == name') $ - version `withinRange` versionRange - - dependencyName (Dependency name _) = name - - requiredDeps :: [Dependency] - requiredDeps = - --TODO: use something lower level than finalizePackageDescription - case finalizePackageDescription specifiedFlags - (const True) - platform comp - [] - (packageDescription pkg) of - Right (resolvedPkg, _) -> externalBuildDepends resolvedPkg - Left _ -> error "configuredPackageInvalidDeps internal error" diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/InstallSymlink.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/InstallSymlink.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/InstallSymlink.hs +++ /dev/null @@ -1,238 +0,0 @@ -{-# OPTIONS -cpp #-} --- OPTIONS required for ghc-6.4.x compat, and must appear first -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -cpp #-} -{-# OPTIONS_NHC98 -cpp #-} -{-# OPTIONS_JHC -fcpp #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.InstallSymlink --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Managing installing binaries with symlinks. ------------------------------------------------------------------------------ -module Distribution.Client.InstallSymlink ( - symlinkBinaries, - symlinkBinary, - ) where - -#if mingw32_HOST_OS || mingw32_TARGET_OS - -import Distribution.Package (PackageIdentifier) -import Distribution.Client.InstallPlan (InstallPlan) -import Distribution.Client.Setup (InstallFlags) -import Distribution.Simple.Setup (ConfigFlags) - -symlinkBinaries :: ConfigFlags - -> InstallFlags - -> InstallPlan - -> IO [(PackageIdentifier, String, FilePath)] -symlinkBinaries _ _ _ = return [] - -symlinkBinary :: FilePath -> FilePath -> String -> String -> IO Bool -symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows" - -#else - -import Distribution.Client.Types - ( AvailablePackage(..), ConfiguredPackage(..) ) -import Distribution.Client.Setup - ( InstallFlags(installSymlinkBinDir) ) -import qualified Distribution.Client.InstallPlan as InstallPlan -import Distribution.Client.InstallPlan (InstallPlan) - -import Distribution.Package - ( PackageIdentifier, Package(packageId) ) -import Distribution.Compiler - ( CompilerId(..) ) -import qualified Distribution.PackageDescription as PackageDescription -import Distribution.PackageDescription - ( PackageDescription ) -import Distribution.PackageDescription.Configuration - ( finalizePackageDescription ) -import Distribution.Simple.Setup - ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe ) -import qualified Distribution.Simple.InstallDirs as InstallDirs - -import System.Posix.Files - ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink - , removeLink ) -import System.Directory - ( canonicalizePath ) -import System.FilePath - ( (), splitPath, joinPath, isAbsolute ) - -import Prelude hiding (catch, ioError) -import System.IO.Error - ( catch, isDoesNotExistError, ioError ) -import Control.Exception - ( assert ) -import Data.Maybe - ( catMaybes ) - --- | We would like by default to install binaries into some location that is on --- the user's PATH. For per-user installations on Unix systems that basically --- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@ --- directory will be on the user's PATH. However some people are a bit nervous --- about letting a package manager install programs into @~/bin/@. --- --- A comprimise solution is that instead of installing binaries directly into --- @~/bin/@, we could install them in a private location under @~/.cabal/bin@ --- and then create symlinks in @~/bin/@. We can be careful when setting up the --- symlinks that we do not overwrite any binary that the user installed. We can --- check if it was a symlink we made because it would point to the private dir --- where we install our binaries. This means we can install normally without --- worrying and in a later phase set up symlinks, and if that fails then we --- report it to the user, but even in this case the package is still in an ok --- installed state. --- --- This is an optional feature that users can choose to use or not. It is --- controlled from the config file. Of course it only works on posix systems --- with symlinks so is not available to Windows users. --- -symlinkBinaries :: ConfigFlags - -> InstallFlags - -> InstallPlan - -> IO [(PackageIdentifier, String, FilePath)] -symlinkBinaries configFlags installFlags plan = - case flagToMaybe (installSymlinkBinDir installFlags) of - Nothing -> return [] - Just symlinkBinDir - | null exes -> return [] - | otherwise -> do - publicBinDir <- canonicalizePath symlinkBinDir --- TODO: do we want to do this here? : --- createDirectoryIfMissing True publicBinDir - fmap catMaybes $ sequence - [ do privateBinDir <- pkgBinDir pkg - ok <- symlinkBinary - publicBinDir privateBinDir - publicExeName privateExeName - if ok - then return Nothing - else return (Just (pkgid, publicExeName, - privateBinDir privateExeName)) - | (pkg, exe) <- exes - , let publicExeName = PackageDescription.exeName exe - privateExeName = prefix ++ publicExeName ++ suffix - pkgid = packageId pkg - prefix = substTemplate pkgid prefixTemplate - suffix = substTemplate pkgid suffixTemplate ] - where - exes = - [ (pkg, exe) - | InstallPlan.Installed cpkg _ <- InstallPlan.toList plan - , let pkg = pkgDescription cpkg - , exe <- PackageDescription.executables pkg - , PackageDescription.buildable (PackageDescription.buildInfo exe) ] - - pkgDescription :: ConfiguredPackage -> PackageDescription - pkgDescription (ConfiguredPackage (AvailablePackage _ pkg _) flags _) = - case finalizePackageDescription flags - (const True) - platform compilerId [] pkg of - Left _ -> error "finalizePackageDescription ConfiguredPackage failed" - Right (desc, _) -> desc - - -- This is sadly rather complicated. We're kind of re-doing part of the - -- configuration for the package. :-( - pkgBinDir :: PackageDescription -> IO FilePath - pkgBinDir pkg = do - defaultDirs <- InstallDirs.defaultInstallDirs - compilerFlavor - (fromFlag (configUserInstall configFlags)) - (PackageDescription.hasLibs pkg) - let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault - defaultDirs (configInstallDirs configFlags) - absoluteDirs = InstallDirs.absoluteInstallDirs - (packageId pkg) compilerId InstallDirs.NoCopyDest - templateDirs - canonicalizePath (InstallDirs.bindir absoluteDirs) - - substTemplate pkgid = InstallDirs.fromPathTemplate - . InstallDirs.substPathTemplate env - where env = InstallDirs.initialPathTemplateEnv pkgid compilerId - - fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") - prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) - suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) - platform = InstallPlan.planPlatform plan - compilerId@(CompilerId compilerFlavor _) = InstallPlan.planCompiler plan - -symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir - -- eg @/home/user/bin@ - -> FilePath -- ^ The canonical path of the private bin dir - -- eg @/home/user/.cabal/bin@ - -> String -- ^ The name of the executable to go in the public - -- bin dir, eg @foo@ - -> String -- ^ The name of the executable to in the private bin - -- dir, eg @foo-1.0@ - -> IO Bool -- ^ If creating the symlink was sucessful. @False@ - -- if there was another file there already that we - -- did not own. Other errors like permission errors - -- just propagate as exceptions. -symlinkBinary publicBindir privateBindir publicName privateName = do - ok <- targetOkToOverwrite (publicBindir publicName) - (privateBindir privateName) - case ok of - NotOurFile -> return False - NotExists -> mkLink >> return True - OkToOverwrite -> rmLink >> mkLink >> return True - where - relativeBindir = makeRelative publicBindir privateBindir - mkLink = createSymbolicLink (relativeBindir privateName) - (publicBindir publicName) - rmLink = removeLink (publicBindir publicName) - --- | Check a filepath of a symlink that we would like to create to see if it --- is ok. For it to be ok to overwrite it must either not already exist yet or --- be a symlink to our target (in which case we can assume ownership). --- -targetOkToOverwrite :: FilePath -- ^ The filepath of the symlink to the private - -- binary that we would like to create - -> FilePath -- ^ The canonical path of the private binary. - -- Use 'canonicalizePath' to make this. - -> IO SymlinkStatus -targetOkToOverwrite symlink target = handleNotExist $ do - status <- getSymbolicLinkStatus symlink - if not (isSymbolicLink status) - then return NotOurFile - else do target' <- canonicalizePath symlink - -- This relies on canonicalizePath handling symlinks - if target == target' - then return OkToOverwrite - else return NotOurFile - - where - handleNotExist action = catch action $ \ioexception -> - -- If the target doesn't exist then there's no problem overwriting it! - if isDoesNotExistError ioexception - then return NotExists - else ioError ioexception - -data SymlinkStatus - = NotExists -- ^ The file doesn't exist so we can make a symlink. - | OkToOverwrite -- ^ A symlink already exists, though it is ours. We'll - -- have to delete it first bemore we make a new symlink. - | NotOurFile -- ^ A file already exists and it is not one of our existing - -- symlinks (either because it is not a symlink or because - -- it points somewhere other than our managed space). - deriving Show - --- | Take two canonical paths and produce a relative path to get from the first --- to the second, even if it means adding @..@ path components. --- -makeRelative :: FilePath -> FilePath -> FilePath -makeRelative a b = assert (isAbsolute a && isAbsolute b) $ - let as = splitPath a - bs = splitPath b - commonLen = length $ takeWhile id $ zipWith (==) as bs - in joinPath $ [ ".." | _ <- drop commonLen as ] - ++ [ b' | b' <- drop commonLen bs ] - -#endif diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/List.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/List.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/List.hs +++ /dev/null @@ -1,368 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.List --- Copyright : (c) David Himmelstrup 2005 --- Duncan Coutts 2008-2009 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- --- Search for and print information about packages ------------------------------------------------------------------------------ -module Distribution.Client.List ( - list, info - ) where - -import Distribution.Package - ( PackageName(..), packageName, packageVersion - , Dependency(..), thisPackageVersion, depends ) -import Distribution.ModuleName (ModuleName) -import Distribution.License (License) -import qualified Distribution.InstalledPackageInfo as Installed -import qualified Distribution.PackageDescription as Available -import Distribution.PackageDescription - ( Flag(..), FlagName(..) ) -import Distribution.PackageDescription.Configuration - ( flattenPackageDescription ) - -import Distribution.Simple.Compiler - ( Compiler, PackageDBStack ) -import Distribution.Simple.Program (ProgramConfiguration) -import Distribution.Simple.Utils (equating, comparing, notice) -import Distribution.Simple.Setup (fromFlag) -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Version (Version) -import Distribution.Verbosity (Verbosity) -import Distribution.Text - ( Text(disp), display ) - -import Distribution.Client.Types - ( AvailablePackage(..), Repo, AvailablePackageDb(..) - , UnresolvedDependency(..), InstalledPackage(..) ) -import Distribution.Client.Setup - ( ListFlags(..), InfoFlags(..) ) -import Distribution.Client.Utils - ( mergeBy, MergeResult(..) ) -import Distribution.Client.IndexUtils as IndexUtils - ( getAvailablePackages, disambiguateDependencies - , getInstalledPackages ) -import Distribution.Client.Fetch - ( isFetched ) - -import Data.List - ( sortBy, groupBy, sort, nub, intersperse, maximumBy ) -import Data.Maybe - ( listToMaybe, fromJust, fromMaybe, isJust, isNothing ) -import Control.Monad - ( MonadPlus(mplus), join ) -import Control.Exception - ( assert ) -import Text.PrettyPrint.HughesPJ as Disp -import System.Directory - ( doesDirectoryExist ) - - --- |Show information about packages -list :: Verbosity - -> PackageDBStack - -> [Repo] - -> Compiler - -> ProgramConfiguration - -> ListFlags - -> [String] - -> IO () -list verbosity packageDBs repos comp conf listFlags pats = do - installed <- getInstalledPackages verbosity comp packageDBs conf - AvailablePackageDb available _ <- getAvailablePackages verbosity repos - let pkgs | null pats = (PackageIndex.allPackages installed - ,PackageIndex.allPackages available) - | otherwise = - (concatMap (PackageIndex.searchByNameSubstring installed) pats - ,concatMap (PackageIndex.searchByNameSubstring available) pats) - matches = installedFilter - . map (uncurry mergePackageInfo) - $ uncurry mergePackages pkgs - - if simpleOutput - then putStr $ unlines - [ display (pkgname pkg) ++ " " ++ display version - | pkg <- matches - , version <- if onlyInstalled - then installedVersions pkg - else nub . sort $ installedVersions pkg - ++ availableVersions pkg ] - else - if null matches - then notice verbosity "No matches found." - else putStr $ unlines (map showPackageSummaryInfo matches) - where - installedFilter - | onlyInstalled = filter (not . null . installedVersions) - | otherwise = id - onlyInstalled = fromFlag (listInstalled listFlags) - simpleOutput = fromFlag (listSimpleOutput listFlags) - -info :: Verbosity - -> PackageDBStack - -> [Repo] - -> Compiler - -> ProgramConfiguration - -> InfoFlags - -> [UnresolvedDependency] --FIXME: just package names? or actually use the constraint - -> IO () -info verbosity packageDBs repos comp conf _listFlags deps = do - AvailablePackageDb available _ <- getAvailablePackages verbosity repos - deps' <- IndexUtils.disambiguateDependencies available deps - installed <- getInstalledPackages verbosity comp packageDBs conf - let deps'' = [ name | UnresolvedDependency (Dependency name _) _ <- deps' ] - let pkgs = (concatMap (PackageIndex.lookupPackageName installed) deps'' - ,concatMap (PackageIndex.lookupPackageName available) deps'') - pkgsinfo = map (uncurry mergePackageInfo) - $ uncurry mergePackages pkgs - - pkgsinfo' <- mapM updateFileSystemPackageDetails pkgsinfo - putStr $ unlines (map showPackageDetailedInfo pkgsinfo') - --- | The info that we can display for each package. It is information per --- package name and covers all installed and avilable versions. --- -data PackageDisplayInfo = PackageDisplayInfo { - pkgname :: PackageName, - allInstalled :: [InstalledPackage], - allAvailable :: [AvailablePackage], - latestInstalled :: Maybe InstalledPackage, - latestAvailable :: Maybe AvailablePackage, - homepage :: String, - bugReports :: String, - sourceRepo :: String, - synopsis :: String, - description :: String, - category :: String, - license :: License, --- copyright :: String, --TODO: is this useful? - author :: String, - maintainer :: String, - dependencies :: [Dependency], - flags :: [Flag], - hasLib :: Bool, - hasExe :: Bool, - executables :: [String], - modules :: [ModuleName], - haddockHtml :: FilePath, - haveTarball :: Bool - } - -installedVersions :: PackageDisplayInfo -> [Version] -installedVersions = map packageVersion . allInstalled - -availableVersions :: PackageDisplayInfo -> [Version] -availableVersions = map packageVersion . allAvailable - -showPackageSummaryInfo :: PackageDisplayInfo -> String -showPackageSummaryInfo pkginfo = - renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ - char '*' <+> disp (pkgname pkginfo) - $+$ - (nest 4 $ vcat [ - maybeShow (synopsis pkginfo) "Synopsis:" reflowParagraphs - , text "Latest version available:" <+> - case latestAvailable pkginfo of - Nothing -> text "[ Not available from server ]" - Just pkg -> disp (packageVersion pkg) - , text "Latest version installed:" <+> - case latestInstalled pkginfo of - Nothing | hasLib pkginfo -> text "[ Not installed ]" - | otherwise -> text "[ Unknown ]" - Just pkg -> disp (packageVersion pkg) - , maybeShow (homepage pkginfo) "Homepage:" text - , text "License: " <+> text (display (license pkginfo)) - ]) - $+$ text "" - where - maybeShow [] _ _ = empty - maybeShow l s f = text s <+> (f l) - -showPackageDetailedInfo :: PackageDisplayInfo -> String -showPackageDetailedInfo pkginfo = - renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ - char '*' <+> disp (pkgname pkginfo) - <+> text (replicate (16 - length (display (pkgname pkginfo))) ' ') - <> parens pkgkind - $+$ - (nest 4 $ vcat [ - entry "Synopsis" synopsis alwaysShow reflowParagraphs - , entry "Latest version available" latestAvailable - (altText isNothing "[ Not available from server ]") - (disp . packageVersion . fromJust) - , entry "Latest version installed" latestInstalled - (altText isNothing (if hasLib pkginfo then "[ Not installed ]" - else "[ Unknown ]")) - (disp . packageVersion . fromJust) - , entry "Homepage" homepage orNotSpecified text - , entry "Bug reports" bugReports orNotSpecified text - , entry "Description" description alwaysShow reflowParagraphs - , entry "Category" category hideIfNull text - , entry "License" license alwaysShow disp - , entry "Author" author hideIfNull reflowLines - , entry "Maintainer" maintainer hideIfNull reflowLines - , entry "Source repo" sourceRepo orNotSpecified text - , entry "Executables" executables hideIfNull (commaSep text) - , entry "Flags" flags hideIfNull (commaSep dispFlag) - , entry "Dependencies" dependencies hideIfNull (commaSep disp) - , entry "Documentation" haddockHtml showIfInstalled text - , entry "Cached" haveTarball alwaysShow dispYesNo - , if not (hasLib pkginfo) then empty else - text "Modules:" $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo)) - ]) - $+$ text "" - where - entry fname field cond format = case cond (field pkginfo) of - Nothing -> label <+> format (field pkginfo) - Just Nothing -> empty - Just (Just other) -> label <+> text other - where - label = text fname <> char ':' <> padding - padding = text (replicate (13 - length fname ) ' ') - - normal = Nothing - hide = Just Nothing - replace msg = Just (Just msg) - - alwaysShow = const normal - hideIfNull v = if null v then hide else normal - showIfInstalled v - | not isInstalled = hide - | null v = replace "[ Not installed ]" - | otherwise = normal - altText nul msg v = if nul v then replace msg else normal - orNotSpecified = altText null "[ Not specified ]" - - commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f - dispFlag f = case flagName f of FlagName n -> text n - dispYesNo True = text "Yes" - dispYesNo False = text "No" - - isInstalled = not (null (installedVersions pkginfo)) - hasExes = length (executables pkginfo) >= 2 - --TODO: exclude non-buildable exes - pkgkind | hasLib pkginfo && hasExes = text "programs and library" - | hasLib pkginfo && hasExe pkginfo = text "program and library" - | hasLib pkginfo = text "library" - | hasExes = text "programs" - | hasExe pkginfo = text "program" - | otherwise = empty - -reflowParagraphs :: String -> Doc -reflowParagraphs = - vcat - . intersperse (text "") -- re-insert blank lines - . map (fsep . map text . concatMap words) -- reflow paragraphs - . filter (/= [""]) - . groupBy (\x y -> "" `notElem` [x,y]) -- break on blank lines - . lines - -reflowLines :: String -> Doc -reflowLines = vcat . map text . lines - --- | We get the 'PackageDisplayInfo' by combining the info for the installed --- and available versions of a package. --- --- * We're building info about a various versions of a single named package so --- the input package info records are all supposed to refer to the same --- package name. --- -mergePackageInfo :: [InstalledPackage] - -> [AvailablePackage] - -> PackageDisplayInfo -mergePackageInfo installedPkgs availablePkgs = - assert (length installedPkgs + length availablePkgs > 0) $ - PackageDisplayInfo { - pkgname = combine packageName available - packageName installed, - allInstalled = installedPkgs, - allAvailable = availablePkgs, - latestInstalled = latest installedPkgs, - latestAvailable = latest availablePkgs, - license = combine Available.license available - Installed.license installed, - maintainer = combine Available.maintainer available - Installed.maintainer installed, - author = combine Available.author available - Installed.author installed, - homepage = combine Available.homepage available - Installed.homepage installed, - bugReports = maybe "" Available.bugReports available, - sourceRepo = fromMaybe "" . join - . fmap (uncons Nothing Available.repoLocation - . sortBy (comparing Available.repoKind) - . Available.sourceRepos) - $ available, - synopsis = combine Available.synopsis available - Installed.description installed, - description = combine Available.description available - Installed.description installed, - category = combine Available.category available - Installed.category installed, - flags = maybe [] Available.genPackageFlags availableGeneric, - hasLib = isJust installed - || fromMaybe False - (fmap (isJust . Available.condLibrary) availableGeneric), - hasExe = fromMaybe False - (fmap (not . null . Available.condExecutables) availableGeneric), - executables = map fst (maybe [] Available.condExecutables availableGeneric), - modules = combine Installed.exposedModules installed - (maybe [] Available.exposedModules - . Available.library) available, - dependencies = combine Available.buildDepends available - (map thisPackageVersion . depends) installed', - haddockHtml = fromMaybe "" . join - . fmap (listToMaybe . Installed.haddockHTMLs) - $ installed, - haveTarball = False - } - where - combine f x g y = fromJust (fmap f x `mplus` fmap g y) - installed' = latest installedPkgs - installed = fmap (\(InstalledPackage p _) -> p) installed' - availableGeneric = fmap packageDescription (latest availablePkgs) - available = fmap flattenPackageDescription availableGeneric - latest [] = Nothing - latest pkgs = Just (maximumBy (comparing packageVersion) pkgs) - - uncons :: b -> (a -> b) -> [a] -> b - uncons z _ [] = z - uncons _ f (x:_) = f x - --- | Not all the info is pure. We have to check if the docs really are --- installed, because the registered package info lies. Similarly we have to --- check if the tarball has indeed been fetched. --- -updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo -updateFileSystemPackageDetails pkginfo = do - fetched <- maybe (return False) isFetched (latestAvailable pkginfo) - docsExist <- doesDirectoryExist (haddockHtml pkginfo) - return pkginfo { - haveTarball = fetched, - haddockHtml = if docsExist then haddockHtml pkginfo else "" - } - --- | Rearrange installed and available packages into groups referring to the --- same package by name. In the result pairs, the lists are guaranteed to not --- both be empty. --- -mergePackages :: [InstalledPackage] -> [AvailablePackage] - -> [([InstalledPackage], [AvailablePackage])] -mergePackages installed available = - map collect - $ mergeBy (\i a -> fst i `compare` fst a) - (groupOn packageName installed) - (groupOn packageName available) - where - collect (OnlyInLeft (_,is) ) = (is, []) - collect ( InBoth (_,is) (_,as)) = (is, as) - collect (OnlyInRight (_,as)) = ([], as) - -groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])] -groupOn key = map (\xs -> (key (head xs), xs)) - . groupBy (equating key) - . sortBy (comparing key) diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/PackageIndex.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/PackageIndex.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/PackageIndex.hs +++ /dev/null @@ -1,479 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.PackageIndex --- Copyright : (c) David Himmelstrup 2005, --- Bjorn Bringert 2007, --- Duncan Coutts 2008 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- An index of packages. --- -module Distribution.Client.PackageIndex ( - -- * Package index data type - PackageIndex, - - -- * Creating an index - fromList, - - -- * Updates - merge, - insert, - deletePackageName, - deletePackageId, - deleteDependency, - - -- * Queries - - -- ** Precise lookups - lookupPackageName, - lookupPackageId, - lookupDependency, - - -- ** Case-insensitive searches - searchByName, - SearchResult(..), - searchByNameSubstring, - - -- ** Bulk queries - allPackages, - allPackagesByName, - - -- ** Special queries - brokenPackages, - dependencyClosure, - reverseDependencyClosure, - topologicalOrder, - reverseTopologicalOrder, - dependencyInconsistencies, - dependencyCycles, - dependencyGraph, - ) where - -import Prelude hiding (lookup) -import Control.Exception (assert) -import qualified Data.Map as Map -import Data.Map (Map) -import qualified Data.Tree as Tree -import qualified Data.Graph as Graph -import qualified Data.Array as Array -import Data.Array ((!)) -import Data.List (groupBy, sortBy, nub, find, isInfixOf) -import Data.Monoid (Monoid(..)) -import Data.Maybe (isNothing, fromMaybe) - -import Distribution.Package - ( PackageName(..), PackageIdentifier(..) - , Package(..), packageName, packageVersion - , Dependency(Dependency), PackageFixedDeps(..) ) -import Distribution.Version - ( Version, withinRange ) -import Distribution.Simple.Utils (lowercase, equating, comparing) - - --- | The collection of information about packages from one or more 'PackageDB's. --- --- It can be searched effeciently by package name and version. --- -newtype Package pkg => PackageIndex pkg = PackageIndex - -- This index package names to all the package records matching that package - -- name case-sensitively. It includes all versions. - -- - -- This allows us to find all versions satisfying a dependency. - -- Most queries are a map lookup followed by a linear scan of the bucket. - -- - (Map PackageName [pkg]) - - deriving (Show, Read) - -instance Package pkg => Monoid (PackageIndex pkg) where - mempty = PackageIndex (Map.empty) - mappend = merge - --save one mappend with empty in the common case: - mconcat [] = mempty - mconcat xs = foldr1 mappend xs - -invariant :: Package pkg => PackageIndex pkg -> Bool -invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m) - where - goodBucket _ [] = False - goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0 - where - check pkgid [] = packageName pkgid == name - check pkgid (pkg':pkgs) = packageName pkgid == name - && pkgid < pkgid' - && check pkgid' pkgs - where pkgid' = packageId pkg' - --- --- * Internal helpers --- - -mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg -mkPackageIndex index = assert (invariant (PackageIndex index)) - (PackageIndex index) - -internalError :: String -> a -internalError name = error ("PackageIndex." ++ name ++ ": internal error") - --- | Lookup a name in the index to get all packages that match that name --- case-sensitively. --- -lookup :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] -lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m - --- --- * Construction --- - --- | Build an index out of a bunch of packages. --- --- If there are duplicates, later ones mask earlier ones. --- -fromList :: Package pkg => [pkg] -> PackageIndex pkg -fromList pkgs = mkPackageIndex - . Map.map fixBucket - . Map.fromListWith (++) - $ [ (packageName pkg, [pkg]) - | pkg <- pkgs ] - where - fixBucket = -- out of groups of duplicates, later ones mask earlier ones - -- but Map.fromListWith (++) constructs groups in reverse order - map head - -- Eq instance for PackageIdentifier is wrong, so use Ord: - . groupBy (\a b -> EQ == comparing packageId a b) - -- relies on sortBy being a stable sort so we - -- can pick consistently among duplicates - . sortBy (comparing packageId) - --- --- * Updates --- - --- | Merge two indexes. --- --- Packages from the second mask packages of the same exact name --- (case-sensitively) from the first. --- -merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg -merge i1@(PackageIndex m1) i2@(PackageIndex m2) = - assert (invariant i1 && invariant i2) $ - mkPackageIndex (Map.unionWith mergeBuckets m1 m2) - --- | Elements in the second list mask those in the first. -mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg] -mergeBuckets [] ys = ys -mergeBuckets xs [] = xs -mergeBuckets xs@(x:xs') ys@(y:ys') = - case packageId x `compare` packageId y of - GT -> y : mergeBuckets xs ys' - EQ -> y : mergeBuckets xs' ys' - LT -> x : mergeBuckets xs' ys - --- | Inserts a single package into the index. --- --- This is equivalent to (but slightly quicker than) using 'mappend' or --- 'merge' with a singleton index. --- -insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg -insert pkg (PackageIndex index) = mkPackageIndex $ - Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index - where - pkgid = packageId pkg - insertNoDup [] = [pkg] - insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of - LT -> pkg : pkgs - EQ -> pkg : pkgs' - GT -> pkg' : insertNoDup pkgs' - --- | Internal delete helper. --- -delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg -delete name p (PackageIndex index) = mkPackageIndex $ - Map.update filterBucket name index - where - filterBucket = deleteEmptyBucket - . filter (not . p) - deleteEmptyBucket [] = Nothing - deleteEmptyBucket remaining = Just remaining - --- | Removes a single package from the index. --- -deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg -> PackageIndex pkg -deletePackageId pkgid = - delete (packageName pkgid) (\pkg -> packageId pkg == pkgid) - --- | Removes all packages with this (case-sensitive) name from the index. --- -deletePackageName :: Package pkg => PackageName -> PackageIndex pkg -> PackageIndex pkg -deletePackageName name = - delete name (\pkg -> packageName pkg == name) - --- | Removes all packages satisfying this dependency from the index. --- -deleteDependency :: Package pkg => Dependency -> PackageIndex pkg -> PackageIndex pkg -deleteDependency (Dependency name verstionRange) = - delete name (\pkg -> packageVersion pkg `withinRange` verstionRange) - --- --- * Bulk queries --- - --- | Get all the packages from the index. --- -allPackages :: Package pkg => PackageIndex pkg -> [pkg] -allPackages (PackageIndex m) = concat (Map.elems m) - --- | Get all the packages from the index. --- --- They are grouped by package name, case-sensitively. --- -allPackagesByName :: Package pkg => PackageIndex pkg -> [[pkg]] -allPackagesByName (PackageIndex m) = Map.elems m - --- --- * Lookups --- - --- | Does a lookup by package id (name & version). --- --- Since multiple package DBs mask each other case-sensitively by package name, --- then we get back at most one package. --- -lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg -lookupPackageId index pkgid = - case [ pkg | pkg <- lookup index (packageName pkgid) - , packageId pkg == pkgid ] of - [] -> Nothing - [pkg] -> Just pkg - _ -> internalError "lookupPackageIdentifier" - --- | Does a case-sensitive search by package name. --- -lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] -lookupPackageName index name = - [ pkg | pkg <- lookup index name - , packageName pkg == name ] - --- | Does a case-sensitive search by package name and a range of versions. --- --- We get back any number of versions of the specified package name, all --- satisfying the version range constraint. --- -lookupDependency :: Package pkg => PackageIndex pkg -> Dependency -> [pkg] -lookupDependency index (Dependency name versionRange) = - [ pkg | pkg <- lookup index name - , packageName pkg == name - , packageVersion pkg `withinRange` versionRange ] - --- --- * Case insensitive name lookups --- - --- | Does a case-insensitive search by package name. --- --- If there is only one package that compares case-insentiviely to this name --- then the search is unambiguous and we get back all versions of that package. --- If several match case-insentiviely but one matches exactly then it is also --- unambiguous. --- --- If however several match case-insentiviely and none match exactly then we --- have an ambiguous result, and we get back all the versions of all the --- packages. The list of ambiguous results is split by exact package name. So --- it is a non-empty list of non-empty lists. --- -searchByName :: Package pkg => PackageIndex pkg -> String -> SearchResult [pkg] -searchByName (PackageIndex m) name = - case [ pkgs | pkgs@(PackageName name',_) <- Map.toList m - , lowercase name' == lname ] of - [] -> None - [(_,pkgs)] -> Unambiguous pkgs - pkgss -> case find ((PackageName name==) . fst) pkgss of - Just (_,pkgs) -> Unambiguous pkgs - Nothing -> Ambiguous (map snd pkgss) - where lname = lowercase name - -data SearchResult a = None | Unambiguous a | Ambiguous [a] - --- | Does a case-insensitive substring search by package name. --- --- That is, all packages that contain the given string in their name. --- -searchByNameSubstring :: Package pkg => PackageIndex pkg -> String -> [pkg] -searchByNameSubstring (PackageIndex m) searchterm = - [ pkg - | (PackageName name, pkgs) <- Map.toList m - , lsearchterm `isInfixOf` lowercase name - , pkg <- pkgs ] - where lsearchterm = lowercase searchterm - --- --- * Special queries --- - --- | All packages that have dependencies that are not in the index. --- --- Returns such packages along with the dependencies that they're missing. --- -brokenPackages :: PackageFixedDeps pkg - => PackageIndex pkg - -> [(pkg, [PackageIdentifier])] -brokenPackages index = - [ (pkg, missing) - | pkg <- allPackages index - , let missing = [ pkg' | pkg' <- depends pkg - , isNothing (lookupPackageId index pkg') ] - , not (null missing) ] - --- | Tries to take the transative closure of the package dependencies. --- --- If the transative closure is complete then it returns that subset of the --- index. Otherwise it returns the broken packages as in 'brokenPackages'. --- --- * Note that if the result is @Right []@ it is because at least one of --- the original given 'PackageIdentifier's do not occur in the index. --- -dependencyClosure :: PackageFixedDeps pkg - => PackageIndex pkg - -> [PackageIdentifier] - -> Either (PackageIndex pkg) - [(pkg, [PackageIdentifier])] -dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of - (completed, []) -> Left completed - (completed, _) -> Right (brokenPackages completed) - where - closure completed failed [] = (completed, failed) - closure completed failed (pkgid:pkgids) = case lookupPackageId index pkgid of - Nothing -> closure completed (pkgid:failed) pkgids - Just pkg -> case lookupPackageId completed (packageId pkg) of - Just _ -> closure completed failed pkgids - Nothing -> closure completed' failed pkgids' - where completed' = insert pkg completed - pkgids' = depends pkg ++ pkgids - --- | Takes the transative closure of the packages reverse dependencies. --- --- * The given 'PackageIdentifier's must be in the index. --- -reverseDependencyClosure :: PackageFixedDeps pkg - => PackageIndex pkg - -> [PackageIdentifier] - -> [pkg] -reverseDependencyClosure index = - map vertexToPkg - . concatMap Tree.flatten - . Graph.dfs reverseDepGraph - . map (fromMaybe noSuchPkgId . pkgIdToVertex) - - where - (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index - reverseDepGraph = Graph.transposeG depGraph - noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" - -topologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg] -topologicalOrder index = map toPkgId - . Graph.topSort - $ graph - where (graph, toPkgId, _) = dependencyGraph index - -reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg] -reverseTopologicalOrder index = map toPkgId - . Graph.topSort - . Graph.transposeG - $ graph - where (graph, toPkgId, _) = dependencyGraph index - --- | Given a package index where we assume we want to use all the packages --- (use 'dependencyClosure' if you need to get such a index subset) find out --- if the dependencies within it use consistent versions of each package. --- Return all cases where multiple packages depend on different versions of --- some other package. --- --- Each element in the result is a package name along with the packages that --- depend on it and the versions they require. These are guaranteed to be --- distinct. --- -dependencyInconsistencies :: PackageFixedDeps pkg - => PackageIndex pkg - -> [(PackageName, [(PackageIdentifier, Version)])] -dependencyInconsistencies index = - [ (name, inconsistencies) - | (name, uses) <- Map.toList inverseIndex - , let inconsistencies = duplicatesBy uses - versions = map snd inconsistencies - , reallyIsInconsistent name (nub versions) ] - - where inverseIndex = Map.fromListWith (++) - [ (packageName dep, [(packageId pkg, packageVersion dep)]) - | pkg <- allPackages index - , dep <- depends pkg ] - - duplicatesBy = (\groups -> if length groups == 1 - then [] - else concat groups) - . groupBy (equating snd) - . sortBy (comparing snd) - - reallyIsInconsistent :: PackageName -> [Version] -> Bool - reallyIsInconsistent _ [] = False - reallyIsInconsistent name [v1, v2] = - case (mpkg1, mpkg2) of - (Just pkg1, Just pkg2) -> pkgid1 `notElem` depends pkg2 - && pkgid2 `notElem` depends pkg1 - _ -> True - where - pkgid1 = PackageIdentifier name v1 - pkgid2 = PackageIdentifier name v2 - mpkg1 = lookupPackageId index pkgid1 - mpkg2 = lookupPackageId index pkgid2 - - reallyIsInconsistent _ _ = True - --- | Find if there are any cycles in the dependency graph. If there are no --- cycles the result is @[]@. --- --- This actually computes the strongly connected components. So it gives us a --- list of groups of packages where within each group they all depend on each --- other, directly or indirectly. --- -dependencyCycles :: PackageFixedDeps pkg - => PackageIndex pkg - -> [[pkg]] -dependencyCycles index = - [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] - where - adjacencyList = [ (pkg, packageId pkg, depends pkg) - | pkg <- allPackages index ] - --- | Builds a graph of the package dependencies. --- --- Dependencies on other packages that are not in the index are discarded. --- You can check if there are any such dependencies with 'brokenPackages'. --- -dependencyGraph :: PackageFixedDeps pkg - => PackageIndex pkg - -> (Graph.Graph, - Graph.Vertex -> pkg, - PackageIdentifier -> Maybe Graph.Vertex) -dependencyGraph index = (graph, vertexToPkg, pkgIdToVertex) - where - graph = Array.listArray bounds - [ [ v | Just v <- map pkgIdToVertex (depends pkg) ] - | pkg <- pkgs ] - vertexToPkg vertex = pkgTable ! vertex - pkgIdToVertex = binarySearch 0 topBound - - pkgTable = Array.listArray bounds pkgs - pkgIdTable = Array.listArray bounds (map packageId pkgs) - pkgs = sortBy (comparing packageId) (allPackages index) - topBound = length pkgs - 1 - bounds = (0, topBound) - - binarySearch a b key - | a > b = Nothing - | otherwise = case compare key (pkgIdTable ! mid) of - LT -> binarySearch a (mid-1) key - EQ -> Just mid - GT -> binarySearch (mid+1) b key - where mid = (a + b) `div` 2 diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/PackageUtils.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/PackageUtils.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/PackageUtils.hs +++ /dev/null @@ -1,34 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.PackageUtils --- Copyright : (c) Duncan Coutts 2010 --- License : BSD-like --- --- Maintainer : cabal-devel@gmail.com --- Stability : provisional --- Portability : portable --- --- Various package description utils that should be in the Cabal lib ------------------------------------------------------------------------------ -module Distribution.Client.PackageUtils ( - externalBuildDepends, - ) where - -import Distribution.Package - ( packageVersion, packageName, Dependency(..) ) -import Distribution.PackageDescription - ( PackageDescription(..) ) -import Distribution.Version - ( withinRange ) - --- | The list of dependencies that refer to external packages --- rather than internal package components. --- -externalBuildDepends :: PackageDescription -> [Dependency] -externalBuildDepends pkg = filter (not . internal) (buildDepends pkg) - where - -- True if this dependency is an internal one (depends on a library - -- defined in the same package). - internal (Dependency depName versionRange) = - depName == packageName pkg && - packageVersion pkg `withinRange` versionRange diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Setup.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Setup.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Setup.hs +++ /dev/null @@ -1,952 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Setup --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- ------------------------------------------------------------------------------ -module Distribution.Client.Setup - ( globalCommand, GlobalFlags(..), globalRepos - , configureCommand, ConfigFlags(..), filterConfigureFlags - , configureExCommand, ConfigExFlags(..), defaultConfigExFlags - , configureExOptions - , installCommand, InstallFlags(..), installOptions, defaultInstallFlags - , listCommand, ListFlags(..) - , updateCommand - , upgradeCommand - , infoCommand, InfoFlags(..) - , fetchCommand, FetchFlags(..) - , checkCommand - , uploadCommand, UploadFlags(..) - , reportCommand - , unpackCommand, UnpackFlags(..) - , initCommand, IT.InitFlags(..) - - , parsePackageArgs - --TODO: stop exporting these: - , showRepo - , parseRepo - ) where - -import Distribution.Client.Types - ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) ) -import Distribution.Client.BuildReports.Types - ( ReportLevel(..) ) -import qualified Distribution.Client.Init.Types as IT - ( InitFlags(..), PackageType(..) ) - -import Distribution.Simple.Program - ( defaultProgramConfiguration ) -import Distribution.Simple.Command hiding (boolOpt) -import qualified Distribution.Simple.Command as Command -import qualified Distribution.Simple.Setup as Cabal - ( configureCommand ) -import Distribution.Simple.Setup - ( ConfigFlags(..) ) -import Distribution.Simple.Setup - ( Flag(..), toFlag, fromFlag, flagToList, flagToMaybe - , optionVerbosity, trueArg, falseArg ) -import Distribution.Simple.InstallDirs - ( PathTemplate, toPathTemplate, fromPathTemplate ) -import Distribution.Version - ( Version(Version), anyVersion, thisVersion ) -import Distribution.Package - ( PackageIdentifier, packageName, packageVersion, Dependency(..) ) -import Distribution.Text - ( Text(parse), display ) -import Distribution.ReadE - ( readP_to_E, succeedReadE ) -import qualified Distribution.Compat.ReadP as Parse - ( ReadP, readP_to_S, char, munch1, pfail, (+++) ) -import Distribution.Verbosity - ( Verbosity, normal ) -import Distribution.Simple.Utils - ( wrapText ) - -import Data.Char - ( isSpace, isAlphaNum ) -import Data.Maybe - ( listToMaybe, maybeToList, fromMaybe ) -import Data.Monoid - ( Monoid(..) ) -import Control.Monad - ( liftM ) -import System.FilePath - ( () ) -import Network.URI - ( parseAbsoluteURI, uriToString ) - --- ------------------------------------------------------------ --- * Global flags --- ------------------------------------------------------------ - --- | Flags that apply at the top level, not to any sub-command. -data GlobalFlags = GlobalFlags { - globalVersion :: Flag Bool, - globalNumericVersion :: Flag Bool, - globalConfigFile :: Flag FilePath, - globalRemoteRepos :: [RemoteRepo], -- ^Available Hackage servers. - globalCacheDir :: Flag FilePath, - globalLocalRepos :: [FilePath], - globalLogsDir :: Flag FilePath, - globalWorldFile :: Flag FilePath - } - -defaultGlobalFlags :: GlobalFlags -defaultGlobalFlags = GlobalFlags { - globalVersion = Flag False, - globalNumericVersion = Flag False, - globalConfigFile = mempty, - globalRemoteRepos = [], - globalCacheDir = mempty, - globalLocalRepos = mempty, - globalLogsDir = mempty, - globalWorldFile = mempty - } - -globalCommand :: CommandUI GlobalFlags -globalCommand = CommandUI { - commandName = "", - commandSynopsis = "", - commandUsage = \_ -> - "This program is the command line interface " - ++ "to the Haskell Cabal infrastructure.\n" - ++ "See http://www.haskell.org/cabal/ for more information.\n", - commandDescription = Just $ \pname -> - "For more information about a command use:\n" - ++ " " ++ pname ++ " COMMAND --help\n\n" - ++ "To install Cabal packages from hackage use:\n" - ++ " " ++ pname ++ " install foo [--dry-run]\n\n" - ++ "Occasionally you need to update the list of available packages:\n" - ++ " " ++ pname ++ " update\n", - commandDefaultFlags = defaultGlobalFlags, - commandOptions = \showOrParseArgs -> - (case showOrParseArgs of ShowArgs -> take 2; ParseArgs -> id) - [option ['V'] ["version"] - "Print version information" - globalVersion (\v flags -> flags { globalVersion = v }) - trueArg - - ,option [] ["numeric-version"] - "Print just the version number" - globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) - trueArg - - ,option [] ["config-file"] - "Set an alternate location for the config file" - globalConfigFile (\v flags -> flags { globalConfigFile = v }) - (reqArgFlag "FILE") - - ,option [] ["remote-repo"] - "The name and url for a remote repository" - globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v }) - (reqArg' "NAME:URL" (maybeToList . readRepo) (map showRepo)) - - ,option [] ["remote-repo-cache"] - "The location where downloads from all remote repos are cached" - globalCacheDir (\v flags -> flags { globalCacheDir = v }) - (reqArgFlag "DIR") - - ,option [] ["local-repo"] - "The location of a local repository" - globalLocalRepos (\v flags -> flags { globalLocalRepos = v }) - (reqArg' "DIR" (\x -> [x]) id) - - ,option [] ["logs-dir"] - "The location to put log files" - globalLogsDir (\v flags -> flags { globalLogsDir = v }) - (reqArgFlag "DIR") - - ,option [] ["world-file"] - "The location of the world file" - globalWorldFile (\v flags -> flags { globalWorldFile = v }) - (reqArgFlag "FILE") - ] - } - -instance Monoid GlobalFlags where - mempty = GlobalFlags { - globalVersion = mempty, - globalNumericVersion = mempty, - globalConfigFile = mempty, - globalRemoteRepos = mempty, - globalCacheDir = mempty, - globalLocalRepos = mempty, - globalLogsDir = mempty, - globalWorldFile = mempty - } - mappend a b = GlobalFlags { - globalVersion = combine globalVersion, - globalNumericVersion = combine globalNumericVersion, - globalConfigFile = combine globalConfigFile, - globalRemoteRepos = combine globalRemoteRepos, - globalCacheDir = combine globalCacheDir, - globalLocalRepos = combine globalLocalRepos, - globalLogsDir = combine globalLogsDir, - globalWorldFile = combine globalWorldFile - } - where combine field = field a `mappend` field b - -globalRepos :: GlobalFlags -> [Repo] -globalRepos globalFlags = remoteRepos ++ localRepos - where - remoteRepos = - [ Repo (Left remote) cacheDir - | remote <- globalRemoteRepos globalFlags - , let cacheDir = fromFlag (globalCacheDir globalFlags) - remoteRepoName remote ] - localRepos = - [ Repo (Right LocalRepo) local - | local <- globalLocalRepos globalFlags ] - --- ------------------------------------------------------------ --- * Config flags --- ------------------------------------------------------------ - -configureCommand :: CommandUI ConfigFlags -configureCommand = (Cabal.configureCommand defaultProgramConfiguration) { - commandDefaultFlags = mempty - } - -configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] -configureOptions = commandOptions configureCommand - -filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags -filterConfigureFlags flags cabalLibVersion - | cabalLibVersion >= Version [1,3,10] [] = flags - -- older Cabal does not grok the constraints flag: - | otherwise = flags { configConstraints = [] } - - --- ------------------------------------------------------------ --- * Config extra flags --- ------------------------------------------------------------ - --- | cabal configure takes some extra flags beyond runghc Setup configure --- -data ConfigExFlags = ConfigExFlags { - configCabalVersion :: Flag Version, - configPreferences :: [Dependency] - } - -defaultConfigExFlags :: ConfigExFlags -defaultConfigExFlags = mempty - -configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) -configureExCommand = configureCommand { - commandDefaultFlags = (mempty, defaultConfigExFlags), - commandOptions = \showOrParseArgs -> - liftOptions fst setFst (configureOptions showOrParseArgs) - ++ liftOptions snd setSnd (configureExOptions showOrParseArgs) - } - where - setFst a (_,b) = (a,b) - setSnd b (a,_) = (a,b) - -configureExOptions :: ShowOrParseArgs -> [OptionField ConfigExFlags] -configureExOptions _showOrParseArgs = - [ option [] ["cabal-lib-version"] - ("Select which version of the Cabal lib to use to build packages " - ++ "(useful for testing).") - configCabalVersion (\v flags -> flags { configCabalVersion = v }) - (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++) - (fmap toFlag parse)) - (map display . flagToList)) - - , option [] ["preference"] - "Specify preferences (soft constraints) on the version of a package" - configPreferences (\v flags -> flags { configPreferences = v }) - (reqArg "DEPENDENCY" - (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse)) - (map (\x -> display x))) - ] - -instance Monoid ConfigExFlags where - mempty = ConfigExFlags { - configCabalVersion = mempty, - configPreferences = mempty - } - mappend a b = ConfigExFlags { - configCabalVersion = combine configCabalVersion, - configPreferences = combine configPreferences - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Fetch command --- ------------------------------------------------------------ - -data FetchFlags = FetchFlags { --- fetchOutput :: Flag FilePath, - fetchDeps :: Flag Bool, - fetchDryRun :: Flag Bool, - fetchVerbosity :: Flag Verbosity - } - -defaultFetchFlags :: FetchFlags -defaultFetchFlags = FetchFlags { --- fetchOutput = mempty, - fetchDeps = toFlag True, - fetchDryRun = toFlag False, - fetchVerbosity = toFlag normal - } - -fetchCommand :: CommandUI FetchFlags -fetchCommand = CommandUI { - commandName = "fetch", - commandSynopsis = "Downloads packages for later installation.", - commandDescription = Nothing, - commandUsage = usagePackages "fetch", - commandDefaultFlags = defaultFetchFlags, - commandOptions = \_ -> [ - optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v }) - --- , option "o" ["output"] --- "Put the package(s) somewhere specific rather than the usual cache." --- fetchOutput (\v flags -> flags { fetchOutput = v }) --- (reqArgFlag "PATH") - - , option [] ["dependencies", "deps"] - "Resolve and fetch dependencies (default)" - fetchDeps (\v flags -> flags { fetchDeps = v }) - trueArg - - , option [] ["no-dependencies", "no-deps"] - "Ignore dependencies" - fetchDeps (\v flags -> flags { fetchDeps = v }) - falseArg - - , option [] ["dry-run"] - "Do not install anything, only print what would be installed." - fetchDryRun (\v flags -> flags { fetchDryRun = v }) - trueArg - ] - } - --- ------------------------------------------------------------ --- * Other commands --- ------------------------------------------------------------ - -updateCommand :: CommandUI (Flag Verbosity) -updateCommand = CommandUI { - commandName = "update", - commandSynopsis = "Updates list of known packages", - commandDescription = Nothing, - commandUsage = usagePackages "update", - commandDefaultFlags = toFlag normal, - commandOptions = \_ -> [optionVerbosity id const] - } - -upgradeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags) -upgradeCommand = configureCommand { - commandName = "upgrade", - commandSynopsis = "(command disabled, use install instead)", - commandDescription = Nothing, - commandUsage = usagePackages "upgrade", - commandDefaultFlags = (mempty, mempty, mempty), - commandOptions = commandOptions installCommand - } - -{- -cleanCommand :: CommandUI () -cleanCommand = makeCommand name shortDesc longDesc emptyFlags options - where - name = "clean" - shortDesc = "Removes downloaded files" - longDesc = Nothing - emptyFlags = () - options _ = [] --} - -checkCommand :: CommandUI (Flag Verbosity) -checkCommand = CommandUI { - commandName = "check", - commandSynopsis = "Check the package for common mistakes", - commandDescription = Nothing, - commandUsage = \pname -> "Usage: " ++ pname ++ " check\n", - commandDefaultFlags = toFlag normal, - commandOptions = \_ -> [] - } - -reportCommand :: CommandUI (Flag Verbosity) -reportCommand = CommandUI { - commandName = "report", - commandSynopsis = "Upload build reports to a remote server.", - commandDescription = Nothing, - commandUsage = \pname -> "Usage: " ++ pname ++ " report\n", - commandDefaultFlags = toFlag normal, - commandOptions = \_ -> [optionVerbosity id const] - } - --- ------------------------------------------------------------ --- * Unpack flags --- ------------------------------------------------------------ - -data UnpackFlags = UnpackFlags { - unpackDestDir :: Flag FilePath, - unpackVerbosity :: Flag Verbosity - } - -defaultUnpackFlags :: UnpackFlags -defaultUnpackFlags = UnpackFlags { - unpackDestDir = mempty, - unpackVerbosity = toFlag normal - } - -unpackCommand :: CommandUI UnpackFlags -unpackCommand = CommandUI { - commandName = "unpack", - commandSynopsis = "Unpacks packages for user inspection.", - commandDescription = Nothing, - commandUsage = usagePackages "unpack", - commandDefaultFlags = mempty, - commandOptions = \_ -> [ - optionVerbosity unpackVerbosity (\v flags -> flags { unpackVerbosity = v }) - - ,option "d" ["destdir"] - "where to unpack the packages, defaults to the current directory." - unpackDestDir (\v flags -> flags { unpackDestDir = v }) - (reqArgFlag "PATH") - ] - } - -instance Monoid UnpackFlags where - mempty = defaultUnpackFlags - mappend a b = UnpackFlags { - unpackDestDir = combine unpackDestDir - ,unpackVerbosity = combine unpackVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * List flags --- ------------------------------------------------------------ - -data ListFlags = ListFlags { - listInstalled :: Flag Bool, - listSimpleOutput :: Flag Bool, - listVerbosity :: Flag Verbosity - } - -defaultListFlags :: ListFlags -defaultListFlags = ListFlags { - listInstalled = Flag False, - listSimpleOutput = Flag False, - listVerbosity = toFlag normal - } - -listCommand :: CommandUI ListFlags -listCommand = CommandUI { - commandName = "list", - commandSynopsis = "List packages matching a search string.", - commandDescription = Nothing, - commandUsage = usagePackages "list", - commandDefaultFlags = defaultListFlags, - commandOptions = \_ -> [ - optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v }) - - , option [] ["installed"] - "Only print installed packages" - listInstalled (\v flags -> flags { listInstalled = v }) - trueArg - - , option [] ["simple-output"] - "Print in a easy-to-parse format" - listSimpleOutput (\v flags -> flags { listSimpleOutput = v }) - trueArg - - ] - } - -instance Monoid ListFlags where - mempty = defaultListFlags - mappend a b = ListFlags { - listInstalled = combine listInstalled, - listSimpleOutput = combine listSimpleOutput, - listVerbosity = combine listVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Info flags --- ------------------------------------------------------------ - -data InfoFlags = InfoFlags { - infoVerbosity :: Flag Verbosity - } - -defaultInfoFlags :: InfoFlags -defaultInfoFlags = InfoFlags { - infoVerbosity = toFlag normal - } - -infoCommand :: CommandUI InfoFlags -infoCommand = CommandUI { - commandName = "info", - commandSynopsis = "Display detailed information about a particular package.", - commandDescription = Nothing, - commandUsage = usagePackages "info", - commandDefaultFlags = defaultInfoFlags, - commandOptions = \_ -> [ - optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v }) - ] - } - -instance Monoid InfoFlags where - mempty = defaultInfoFlags - mappend a b = InfoFlags { - infoVerbosity = combine infoVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Install flags --- ------------------------------------------------------------ - --- | Install takes the same flags as configure along with a few extras. --- -data InstallFlags = InstallFlags { - installDocumentation:: Flag Bool, - installHaddockIndex :: Flag PathTemplate, - installDryRun :: Flag Bool, - installReinstall :: Flag Bool, - installUpgradeDeps :: Flag Bool, - installOnly :: Flag Bool, - installRootCmd :: Flag String, - installSummaryFile :: [PathTemplate], - installLogFile :: Flag PathTemplate, - installBuildReports :: Flag ReportLevel, - installSymlinkBinDir:: Flag FilePath, - installOneShot :: Flag Bool - } - -defaultInstallFlags :: InstallFlags -defaultInstallFlags = InstallFlags { - installDocumentation= Flag False, - installHaddockIndex = Flag docIndexFile, - installDryRun = Flag False, - installReinstall = Flag False, - installUpgradeDeps = Flag False, - installOnly = Flag False, - installRootCmd = mempty, - installSummaryFile = mempty, - installLogFile = mempty, - installBuildReports = Flag NoReports, - installSymlinkBinDir= mempty, - installOneShot = Flag False - } - where - docIndexFile = toPathTemplate ("$datadir" "doc" "index.html") - -installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags) -installCommand = CommandUI { - commandName = "install", - commandSynopsis = "Installs a list of packages.", - commandUsage = usagePackages "install", - commandDescription = Just $ \pname -> - let original = case commandDescription configureCommand of - Just desc -> desc pname ++ "\n" - Nothing -> "" - in original - ++ "Examples:\n" - ++ " " ++ pname ++ " install " - ++ " Package in the current directory\n" - ++ " " ++ pname ++ " install foo " - ++ " Package from the hackage server\n" - ++ " " ++ pname ++ " install foo-1.0 " - ++ " Specific version of a package\n" - ++ " " ++ pname ++ " install 'foo < 2' " - ++ " Constrained package version\n", - commandDefaultFlags = (mempty, mempty, mempty), - commandOptions = \showOrParseArgs -> - liftOptions get1 set1 (configureOptions showOrParseArgs) - ++ liftOptions get2 set2 (configureExOptions showOrParseArgs) - ++ liftOptions get3 set3 (installOptions showOrParseArgs) - } - where - get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c) - get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c) - get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c) - -installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] -installOptions showOrParseArgs = - [ option "" ["documentation"] - "building of documentation" - installDocumentation (\v flags -> flags { installDocumentation = v }) - (boolOpt [] []) - - , option [] ["doc-index-file"] - "A central index of haddock API documentation (template cannot use $pkgid)" - installHaddockIndex (\v flags -> flags { installHaddockIndex = v }) - (reqArg' "TEMPLATE" (toFlag.toPathTemplate) - (flagToList . fmap fromPathTemplate)) - - , option [] ["dry-run"] - "Do not install anything, only print what would be installed." - installDryRun (\v flags -> flags { installDryRun = v }) - trueArg - - , option [] ["reinstall"] - "Install even if it means installing the same version again." - installReinstall (\v flags -> flags { installReinstall = v }) - trueArg - - , option [] ["upgrade-dependencies"] - "Pick the latest version for all dependencies, rather than trying to pick an installed version." - installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v }) - trueArg - - , option [] ["root-cmd"] - "Command used to gain root privileges, when installing with --global." - installRootCmd (\v flags -> flags { installRootCmd = v }) - (reqArg' "COMMAND" toFlag flagToList) - - , option [] ["symlink-bindir"] - "Add symlinks to installed executables into this directory." - installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v }) - (reqArgFlag "DIR") - - , option [] ["build-summary"] - "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)" - installSummaryFile (\v flags -> flags { installSummaryFile = v }) - (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) (map fromPathTemplate)) - - , option [] ["build-log"] - "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)" - installLogFile (\v flags -> flags { installLogFile = v }) - (reqArg' "TEMPLATE" (toFlag.toPathTemplate) - (flagToList . fmap fromPathTemplate)) - - , option [] ["remote-build-reporting"] - "Generate build reports to send to a remote server (none, anonymous or detailed)." - installBuildReports (\v flags -> flags { installBuildReports = v }) - (reqArg "LEVEL" (readP_to_E (const $ "report level must be 'none', " - ++ "'anonymous' or 'detailed'") - (toFlag `fmap` parse)) - (flagToList . fmap display)) - - , option [] ["one-shot"] - "Do not record the packages in the world file." - installOneShot (\v flags -> flags { installOneShot = v }) - trueArg - ] ++ case showOrParseArgs of -- TODO: remove when "cabal install" avoids - ParseArgs -> - option [] ["only"] - "Only installs the package in the current directory." - installOnly (\v flags -> flags { installOnly = v }) - trueArg - : [] - _ -> [] - -instance Monoid InstallFlags where - mempty = InstallFlags { - installDocumentation= mempty, - installHaddockIndex = mempty, - installDryRun = mempty, - installReinstall = mempty, - installUpgradeDeps = mempty, - installOnly = mempty, - installRootCmd = mempty, - installSummaryFile = mempty, - installLogFile = mempty, - installBuildReports = mempty, - installSymlinkBinDir= mempty, - installOneShot = mempty - } - mappend a b = InstallFlags { - installDocumentation= combine installDocumentation, - installHaddockIndex = combine installHaddockIndex, - installDryRun = combine installDryRun, - installReinstall = combine installReinstall, - installUpgradeDeps = combine installUpgradeDeps, - installOnly = combine installOnly, - installRootCmd = combine installRootCmd, - installSummaryFile = combine installSummaryFile, - installLogFile = combine installLogFile, - installBuildReports = combine installBuildReports, - installSymlinkBinDir= combine installSymlinkBinDir, - installOneShot = combine installOneShot - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Upload flags --- ------------------------------------------------------------ - -data UploadFlags = UploadFlags { - uploadCheck :: Flag Bool, - uploadUsername :: Flag Username, - uploadPassword :: Flag Password, - uploadVerbosity :: Flag Verbosity - } - -defaultUploadFlags :: UploadFlags -defaultUploadFlags = UploadFlags { - uploadCheck = toFlag False, - uploadUsername = mempty, - uploadPassword = mempty, - uploadVerbosity = toFlag normal - } - -uploadCommand :: CommandUI UploadFlags -uploadCommand = CommandUI { - commandName = "upload", - commandSynopsis = "Uploads source packages to Hackage", - commandDescription = Just $ \_ -> - "You can store your Hackage login in the ~/.cabal/config file\n", - commandUsage = \pname -> - "Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n" - ++ "Flags for upload:", - commandDefaultFlags = defaultUploadFlags, - commandOptions = \_ -> - [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v }) - - ,option ['c'] ["check"] - "Do not upload, just do QA checks." - uploadCheck (\v flags -> flags { uploadCheck = v }) - trueArg - - ,option ['u'] ["username"] - "Hackage username." - uploadUsername (\v flags -> flags { uploadUsername = v }) - (reqArg' "USERNAME" (toFlag . Username) - (flagToList . fmap unUsername)) - - ,option ['p'] ["password"] - "Hackage password." - uploadPassword (\v flags -> flags { uploadPassword = v }) - (reqArg' "PASSWORD" (toFlag . Password) - (flagToList . fmap unPassword)) - ] - } - -instance Monoid UploadFlags where - mempty = UploadFlags { - uploadCheck = mempty, - uploadUsername = mempty, - uploadPassword = mempty, - uploadVerbosity = mempty - } - mappend a b = UploadFlags { - uploadCheck = combine uploadCheck, - uploadUsername = combine uploadUsername, - uploadPassword = combine uploadPassword, - uploadVerbosity = combine uploadVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Init flags --- ------------------------------------------------------------ - -emptyInitFlags :: IT.InitFlags -emptyInitFlags = mempty - -defaultInitFlags :: IT.InitFlags -defaultInitFlags = emptyInitFlags - -initCommand :: CommandUI IT.InitFlags -initCommand = CommandUI { - commandName = "init", - commandSynopsis = "Interactively create a .cabal file.", - commandDescription = Just $ \_ -> wrapText $ - "Cabalise a project by creating a .cabal, Setup.hs, and " - ++ "optionally a LICENSE file.\n\n" - ++ "Calling init with no arguments (recommended) uses an " - ++ "interactive mode, which will try to guess as much as " - ++ "possible and prompt you for the rest. Command-line " - ++ "arguments are provided for scripting purposes. " - ++ "If you don't want interactive mode, be sure to pass " - ++ "the -n flag.\n", - commandUsage = \pname -> - "Usage: " ++ pname ++ " init [FLAGS]\n\n" - ++ "Flags for init:", - commandDefaultFlags = defaultInitFlags, - commandOptions = \_ -> - [ option ['n'] ["non-interactive"] - "Non-interactive mode." - IT.nonInteractive (\v flags -> flags { IT.nonInteractive = v }) - trueArg - - , option ['q'] ["quiet"] - "Do not generate log messages to stdout." - IT.quiet (\v flags -> flags { IT.quiet = v }) - trueArg - - , option [] ["no-comments"] - "Do not generate explanatory comments in the .cabal file." - IT.noComments (\v flags -> flags { IT.noComments = v }) - trueArg - - , option ['m'] ["minimal"] - "Generate a minimal .cabal file, that is, do not include extra empty fields. Also implies --no-comments." - IT.minimal (\v flags -> flags { IT.minimal = v }) - trueArg - - , option [] ["package-dir"] - "Root directory of the package (default = current directory)." - IT.packageDir (\v flags -> flags { IT.packageDir = v }) - (reqArgFlag "DIRECTORY") - - , option ['p'] ["package-name"] - "Name of the Cabal package to create." - IT.packageName (\v flags -> flags { IT.packageName = v }) - (reqArgFlag "PACKAGE") - - , option [] ["version"] - "Initial version of the package." - IT.version (\v flags -> flags { IT.version = v }) - (reqArg "VERSION" (readP_to_E ("Cannot parse package version: "++) - (toFlag `fmap` parse)) - (flagToList . fmap display)) - - , option [] ["cabal-version"] - "Required version of the Cabal library." - IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v }) - (reqArg "VERSION_RANGE" (readP_to_E ("Cannot parse Cabal version range: "++) - (toFlag `fmap` parse)) - (flagToList . fmap display)) - - , option ['l'] ["license"] - "Project license." - IT.license (\v flags -> flags { IT.license = v }) - (reqArg "LICENSE" (readP_to_E ("Cannot parse license: "++) - (toFlag `fmap` parse)) - (flagToList . fmap display)) - - , option ['a'] ["author"] - "Name of the project's author." - IT.author (\v flags -> flags { IT.author = v }) - (reqArgFlag "NAME") - - , option ['e'] ["email"] - "Email address of the maintainer." - IT.email (\v flags -> flags { IT.email = v }) - (reqArgFlag "EMAIL") - - , option ['u'] ["homepage"] - "Project homepage and/or repository." - IT.homepage (\v flags -> flags { IT.homepage = v }) - (reqArgFlag "URL") - - , option ['s'] ["synopsis"] - "Short project synopsis." - IT.synopsis (\v flags -> flags { IT.synopsis = v }) - (reqArgFlag "TEXT") - - , option ['c'] ["category"] - "Project category." - IT.category (\v flags -> flags { IT.category = v }) - (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s)) - (flagToList . fmap (either id show))) - - , option [] ["is-library"] - "Build a library." - IT.packageType (\v flags -> flags { IT.packageType = v }) - (noArg (Flag IT.Library)) - - , option [] ["is-executable"] - "Build an executable." - IT.packageType - (\v flags -> flags { IT.packageType = v }) - (noArg (Flag IT.Executable)) - - , option ['o'] ["expose-module"] - "Export a module from the package." - IT.exposedModules - (\v flags -> flags { IT.exposedModules = v }) - (reqArg "MODULE" (readP_to_E ("Cannot parse module name: "++) - ((Just . (:[])) `fmap` parse)) - (fromMaybe [] . fmap (fmap display))) - - , option ['d'] ["dependency"] - "Package dependency." - IT.dependencies (\v flags -> flags { IT.dependencies = v }) - (reqArg "PACKAGE" (readP_to_E ("Cannot parse dependency: "++) - ((Just . (:[])) `fmap` parse)) - (fromMaybe [] . fmap (fmap display))) - - , option [] ["source-dir"] - "Directory containing package source." - IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v }) - (reqArg' "DIR" (Just . (:[])) - (fromMaybe [])) - - , option [] ["build-tool"] - "Required external build tool." - IT.buildTools (\v flags -> flags { IT.buildTools = v }) - (reqArg' "TOOL" (Just . (:[])) - (fromMaybe [])) - ] - } - where readMaybe s = case reads s of - [(x,"")] -> Just x - _ -> Nothing - --- ------------------------------------------------------------ --- * GetOpt Utils --- ------------------------------------------------------------ - -boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a -boolOpt = Command.boolOpt flagToMaybe Flag - -reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description -> - (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b -reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList - -liftOptions :: (b -> a) -> (a -> b -> b) - -> [OptionField a] -> [OptionField b] -liftOptions get set = map (liftOption get set) - -usagePackages :: String -> String -> String -usagePackages name pname = - "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n" - ++ " or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n" - ++ "Flags for " ++ name ++ ":" - ---TODO: do we want to allow per-package flags? -parsePackageArgs :: [String] -> Either String [Dependency] -parsePackageArgs = parsePkgArgs [] - where - parsePkgArgs ds [] = Right (reverse ds) - parsePkgArgs ds (arg:args) = - case readPToMaybe parseDependencyOrPackageId arg of - Just dep -> parsePkgArgs (dep:ds) args - Nothing -> Left $ - show arg ++ " is not valid syntax for a package name or" - ++ " package dependency." - -readPToMaybe :: Parse.ReadP a a -> String -> Maybe a -readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str - , all isSpace s ] - -parseDependencyOrPackageId :: Parse.ReadP r Dependency -parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse - where - pkgidToDependency :: PackageIdentifier -> Dependency - pkgidToDependency p = case packageVersion p of - Version [] _ -> Dependency (packageName p) anyVersion - version -> Dependency (packageName p) (thisVersion version) - -showRepo :: RemoteRepo -> String -showRepo repo = remoteRepoName repo ++ ":" - ++ uriToString id (remoteRepoURI repo) [] - -readRepo :: String -> Maybe RemoteRepo -readRepo = readPToMaybe parseRepo - -parseRepo :: Parse.ReadP r RemoteRepo -parseRepo = do - name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.") - _ <- Parse.char ':' - uriStr <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~") - uri <- maybe Parse.pfail return (parseAbsoluteURI uriStr) - return $ RemoteRepo { - remoteRepoName = name, - remoteRepoURI = uri - } diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/SetupWrapper.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/SetupWrapper.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/SetupWrapper.hs +++ /dev/null @@ -1,320 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.SetupWrapper --- Copyright : (c) The University of Glasgow 2006, --- Duncan Coutts 2008 --- --- Maintainer : cabal-devel@haskell.org --- Stability : alpha --- Portability : portable --- --- An interface to building and installing Cabal packages. --- If the @Built-Type@ field is specified as something other than --- 'Custom', and the current version of Cabal is acceptable, this performs --- setup actions directly. Otherwise it builds the setup script and --- runs it with the given arguments. - -module Distribution.Client.SetupWrapper ( - setupWrapper, - SetupScriptOptions(..), - defaultSetupScriptOptions, - ) where - -import Distribution.Client.Types - ( InstalledPackage ) - -import qualified Distribution.Make as Make -import qualified Distribution.Simple as Simple -import Distribution.Version - ( Version(..), VersionRange, anyVersion - , intersectVersionRanges, orLaterVersion - , withinRange ) -import Distribution.Package - ( PackageIdentifier(..), PackageName(..), Package(..), packageName - , packageVersion, Dependency(..) ) -import Distribution.PackageDescription - ( GenericPackageDescription(packageDescription) - , PackageDescription(..), specVersion, BuildType(..) ) -import Distribution.PackageDescription.Parse - ( readPackageDescription ) -import Distribution.Simple.Configure - ( configCompiler ) -import Distribution.Simple.Compiler - ( CompilerFlavor(GHC), Compiler, PackageDB(..), PackageDBStack ) -import Distribution.Simple.Program - ( ProgramConfiguration, emptyProgramConfiguration - , rawSystemProgramConf, ghcProgram ) -import Distribution.Simple.BuildPaths - ( defaultDistPref, exeExtension ) -import Distribution.Simple.Command - ( CommandUI(..), commandShowOptions ) -import Distribution.Simple.GHC - ( ghcVerbosityOptions ) -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Client.PackageIndex (PackageIndex) -import Distribution.Client.IndexUtils - ( getInstalledPackages ) -import Distribution.Simple.Utils - ( die, debug, info, cabalVersion, findPackageDesc, comparing - , createDirectoryIfMissingVerbose, rewriteFile ) -import Distribution.Client.Utils - ( moreRecentFile, inDir ) -import Distribution.Text - ( display ) -import Distribution.Verbosity - ( Verbosity ) - -import System.Directory ( doesFileExist, getCurrentDirectory ) -import System.FilePath ( (), (<.>) ) -import System.IO ( Handle ) -import System.Exit ( ExitCode(..), exitWith ) -import System.Process ( runProcess, waitForProcess ) -import Control.Monad ( when, unless ) -import Data.List ( maximumBy ) -import Data.Maybe ( fromMaybe, isJust ) -import Data.Char ( isSpace ) - -data SetupScriptOptions = SetupScriptOptions { - useCabalVersion :: VersionRange, - useCompiler :: Maybe Compiler, - usePackageDB :: PackageDBStack, - usePackageIndex :: Maybe (PackageIndex InstalledPackage), - useProgramConfig :: ProgramConfiguration, - useDistPref :: FilePath, - useLoggingHandle :: Maybe Handle, - useWorkingDir :: Maybe FilePath - } - -defaultSetupScriptOptions :: SetupScriptOptions -defaultSetupScriptOptions = SetupScriptOptions { - useCabalVersion = anyVersion, - useCompiler = Nothing, - usePackageDB = [GlobalPackageDB, UserPackageDB], - usePackageIndex = Nothing, - useProgramConfig = emptyProgramConfiguration, - useDistPref = defaultDistPref, - useLoggingHandle = Nothing, - useWorkingDir = Nothing - } - -setupWrapper :: Verbosity - -> SetupScriptOptions - -> Maybe PackageDescription - -> CommandUI flags - -> (Version -> flags) - -> [String] - -> IO () -setupWrapper verbosity options mpkg cmd flags extraArgs = do - pkg <- maybe getPkg return mpkg - let setupMethod = determineSetupMethod options' buildType' - options' = options { - useCabalVersion = intersectVersionRanges - (useCabalVersion options) - (orLaterVersion (specVersion pkg)) - } - buildType' = fromMaybe Custom (buildType pkg) - mkArgs cabalLibVersion = commandName cmd - : commandShowOptions cmd (flags cabalLibVersion) - ++ extraArgs - setupMethod verbosity options' (packageId pkg) buildType' mkArgs - where - getPkg = findPackageDesc (fromMaybe "." (useWorkingDir options)) - >>= readPackageDescription verbosity - >>= return . packageDescription - --- | Decide if we're going to be able to do a direct internal call to the --- entry point in the Cabal library or if we're going to have to compile --- and execute an external Setup.hs script. --- -determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod -determineSetupMethod options buildType' - | isJust (useLoggingHandle options) - || buildType' == Custom = externalSetupMethod - | cabalVersion `withinRange` - useCabalVersion options = internalSetupMethod - | otherwise = externalSetupMethod - -type SetupMethod = Verbosity - -> SetupScriptOptions - -> PackageIdentifier - -> BuildType - -> (Version -> [String]) -> IO () - --- ------------------------------------------------------------ --- * Internal SetupMethod --- ------------------------------------------------------------ - -internalSetupMethod :: SetupMethod -internalSetupMethod verbosity options _ bt mkargs = do - let args = mkargs cabalVersion - debug verbosity $ "Using internal setup method with build-type " ++ show bt - ++ " and args:\n " ++ show args - inDir (useWorkingDir options) $ - buildTypeAction bt args - -buildTypeAction :: BuildType -> ([String] -> IO ()) -buildTypeAction Simple = Simple.defaultMainArgs -buildTypeAction Configure = Simple.defaultMainWithHooksArgs - Simple.autoconfUserHooks -buildTypeAction Make = Make.defaultMainArgs -buildTypeAction Custom = error "buildTypeAction Custom" -buildTypeAction (UnknownBuildType _) = error "buildTypeAction UnknownBuildType" - --- ------------------------------------------------------------ --- * External SetupMethod --- ------------------------------------------------------------ - -externalSetupMethod :: SetupMethod -externalSetupMethod verbosity options pkg bt mkargs = do - debug verbosity $ "Using external setup method with build-type " ++ show bt - createDirectoryIfMissingVerbose verbosity True setupDir - (cabalLibVersion, options') <- cabalLibVersionToUse - debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion - setupHs <- updateSetupScript cabalLibVersion bt - debug verbosity $ "Using " ++ setupHs ++ " as setup script." - compileSetupExecutable options' cabalLibVersion setupHs - invokeSetupScript (mkargs cabalLibVersion) - - where - workingDir = case fromMaybe "" (useWorkingDir options) of - [] -> "." - dir -> dir - setupDir = workingDir useDistPref options "setup" - setupVersionFile = setupDir "setup" <.> "version" - setupProgFile = setupDir "setup" <.> exeExtension - - cabalLibVersionToUse :: IO (Version, SetupScriptOptions) - cabalLibVersionToUse = do - savedVersion <- savedCabalVersion - case savedVersion of - Just version | version `withinRange` useCabalVersion options - -> return (version, options) - _ -> do (comp, conf, options') <- configureCompiler options - version <- installedCabalVersion options comp conf - writeFile setupVersionFile (show version ++ "\n") - return (version, options') - - savedCabalVersion = do - versionString <- readFile setupVersionFile `catch` \_ -> return "" - case reads versionString of - [(version,s)] | all isSpace s -> return (Just version) - _ -> return Nothing - - installedCabalVersion :: SetupScriptOptions -> Compiler - -> ProgramConfiguration -> IO Version - installedCabalVersion _ _ _ | packageName pkg == PackageName "Cabal" = - return (packageVersion pkg) - installedCabalVersion options' comp conf = do - index <- case usePackageIndex options' of - Just index -> return index - Nothing -> getInstalledPackages verbosity - comp (usePackageDB options') conf - - let cabalDep = Dependency (PackageName "Cabal") (useCabalVersion options) - case PackageIndex.lookupDependency index cabalDep of - [] -> die $ "The package requires Cabal library version " - ++ display (useCabalVersion options) - ++ " but no suitable version is installed." - pkgs -> return $ bestVersion (map packageVersion pkgs) - where - bestVersion = maximumBy (comparing preference) - preference version = (sameVersion, sameMajorVersion - ,stableVersion, latestVersion) - where - sameVersion = version == cabalVersion - sameMajorVersion = majorVersion version == majorVersion cabalVersion - majorVersion = take 2 . versionBranch - stableVersion = case versionBranch version of - (_:x:_) -> even x - _ -> False - latestVersion = version - - configureCompiler :: SetupScriptOptions - -> IO (Compiler, ProgramConfiguration, SetupScriptOptions) - configureCompiler options' = do - (comp, conf) <- case useCompiler options' of - Just comp -> return (comp, useProgramConfig options') - Nothing -> configCompiler (Just GHC) Nothing Nothing - (useProgramConfig options') verbosity - return (comp, conf, options' { useCompiler = Just comp, - useProgramConfig = conf }) - - -- | Decide which Setup.hs script to use, creating it if necessary. - -- - updateSetupScript :: Version -> BuildType -> IO FilePath - updateSetupScript _ Custom = do - useHs <- doesFileExist setupHs - useLhs <- doesFileExist setupLhs - unless (useHs || useLhs) $ die - "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script." - return (if useHs then setupHs else setupLhs) - where - setupHs = workingDir "Setup.hs" - setupLhs = workingDir "Setup.lhs" - - updateSetupScript cabalLibVersion _ = do - rewriteFile setupHs (buildTypeScript cabalLibVersion) - return setupHs - where - setupHs = setupDir "setup.hs" - - buildTypeScript :: Version -> String - buildTypeScript cabalLibVersion = case bt of - Simple -> "import Distribution.Simple; main = defaultMain\n" - Configure -> "import Distribution.Simple; main = defaultMainWithHooks " - ++ if cabalLibVersion >= Version [1,3,10] [] - then "autoconfUserHooks\n" - else "defaultUserHooks\n" - Make -> "import Distribution.Make; main = defaultMain\n" - Custom -> error "buildTypeScript Custom" - UnknownBuildType _ -> error "buildTypeScript UnknownBuildType" - - -- | If the Setup.hs is out of date wrt the executable then recompile it. - -- Currently this is GHC only. It should really be generalised. - -- - compileSetupExecutable :: SetupScriptOptions -> Version -> FilePath -> IO () - compileSetupExecutable options' cabalLibVersion setupHsFile = do - setupHsNewer <- setupHsFile `moreRecentFile` setupProgFile - cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile - let outOfDate = setupHsNewer || cabalVersionNewer - when outOfDate $ do - debug verbosity "Setup script is out of date, compiling..." - (_, conf, _) <- configureCompiler options' - --TODO: get Cabal's GHC module to export a GhcOptions type and render func - rawSystemProgramConf verbosity ghcProgram conf $ - ghcVerbosityOptions verbosity - ++ ["--make", setupHsFile, "-o", setupProgFile - ,"-odir", setupDir, "-hidir", setupDir - ,"-i", "-i" ++ workingDir ] - ++ ghcPackageDbOptions (usePackageDB options') - ++ if packageName pkg == PackageName "Cabal" - then [] - else ["-package", display cabalPkgid] - where - cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion - - ghcPackageDbOptions :: PackageDBStack -> [String] - ghcPackageDbOptions dbstack = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs - (GlobalPackageDB:dbs) -> "-no-user-package-conf" - : concatMap specific dbs - _ -> ierror - where - specific (SpecificPackageDB db) = [ "-package-conf", db ] - specific _ = ierror - ierror = error "internal error: unexpected package db stack" - - - invokeSetupScript :: [String] -> IO () - invokeSetupScript args = do - info verbosity $ unwords (setupProgFile : args) - case useLoggingHandle options of - Nothing -> return () - Just logHandle -> info verbosity $ "Redirecting build log to " - ++ show logHandle - currentDir <- getCurrentDirectory - process <- runProcess (currentDir setupProgFile) args - (useWorkingDir options) Nothing - Nothing (useLoggingHandle options) (useLoggingHandle options) - exitCode <- waitForProcess process - unless (exitCode == ExitSuccess) $ exitWith exitCode diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/SrcDist.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/SrcDist.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/SrcDist.hs +++ /dev/null @@ -1,80 +0,0 @@ --- Implements the \"@.\/cabal sdist@\" command, which creates a source --- distribution for this package. That is, packs up the source code --- into a tarball, making use of the corresponding Cabal module. -module Distribution.Client.SrcDist ( - sdist - ) where -import Distribution.Simple.SrcDist - ( printPackageProblems, prepareTree - , prepareSnapshotTree, snapshotPackage ) -import Distribution.Client.Tar (createTarGzFile) - -import Distribution.Package - ( Package(..) ) -import Distribution.PackageDescription - ( PackageDescription ) -import Distribution.PackageDescription.Parse - ( readPackageDescription ) -import Distribution.Simple.Utils - ( defaultPackageDesc, warn, notice, setupMessage - , createDirectoryIfMissingVerbose, withTempDirectory ) -import Distribution.Simple.Setup (SDistFlags(..), fromFlag) -import Distribution.Verbosity (Verbosity) -import Distribution.Simple.PreProcess (knownSuffixHandlers) -import Distribution.Simple.BuildPaths ( srcPref) -import Distribution.Simple.Configure(maybeGetPersistBuildConfig) -import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) -import Distribution.Text - ( display ) - -import System.Time (getClockTime, toCalendarTime) -import System.FilePath ((), (<.>)) -import Control.Monad (when) -import Data.Maybe (isNothing) - --- |Create a source distribution. -sdist :: SDistFlags -> IO () -sdist flags = do - pkg <- return . flattenPackageDescription - =<< readPackageDescription verbosity - =<< defaultPackageDesc verbosity - mb_lbi <- maybeGetPersistBuildConfig distPref - let tmpTargetDir = srcPref distPref - - -- do some QA - printPackageProblems verbosity pkg - - when (isNothing mb_lbi) $ - warn verbosity "Cannot run preprocessors. Run 'configure' command first." - - createDirectoryIfMissingVerbose verbosity True tmpTargetDir - withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do - - date <- toCalendarTime =<< getClockTime - let pkg' | snapshot = snapshotPackage date pkg - | otherwise = pkg - setupMessage verbosity "Building source dist for" (packageId pkg') - - _ <- if snapshot - then prepareSnapshotTree verbosity pkg' mb_lbi distPref tmpDir pps - else prepareTree verbosity pkg' mb_lbi distPref tmpDir pps - targzFile <- createArchive verbosity pkg' tmpDir distPref - notice verbosity $ "Source tarball created: " ++ targzFile - - where - verbosity = fromFlag (sDistVerbosity flags) - snapshot = fromFlag (sDistSnapshot flags) - distPref = fromFlag (sDistDistPref flags) - pps = knownSuffixHandlers - --- |Create an archive from a tree of source files, and clean up the tree. -createArchive :: Verbosity - -> PackageDescription - -> FilePath - -> FilePath - -> IO FilePath -createArchive _verbosity pkg tmpDir targetPref = do - let tarBallName = display (packageId pkg) - tarBallFilePath = targetPref tarBallName <.> "tar.gz" - createTarGzFile tarBallFilePath tmpDir tarBallName - return tarBallFilePath diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Tar.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Tar.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Tar.hs +++ /dev/null @@ -1,871 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Tar --- Copyright : (c) 2007 Bjorn Bringert, --- 2008 Andrea Vezzosi, --- 2008-2009 Duncan Coutts --- License : BSD3 --- --- Maintainer : duncan@haskell.org --- Portability : portable --- --- Reading, writing and manipulating \"@.tar@\" archive files. --- ------------------------------------------------------------------------------ -module Distribution.Client.Tar ( - -- * High level \"all in one\" operations - createTarGzFile, - extractTarGzFile, - - -- * Converting between internal and external representation - read, - write, - - -- * Packing and unpacking files to\/from internal representation - pack, - unpack, - - -- * Tar entry and associated types - Entry(..), - entryPath, - EntryContent(..), - Ownership(..), - FileSize, - Permissions, - EpochTime, - DevMajor, - DevMinor, - TypeCode, - Format(..), - - -- * Constructing simple entry values - simpleEntry, - fileEntry, - directoryEntry, - - -- * TarPath type - TarPath, - toTarPath, - fromTarPath, - - -- ** Sequences of tar entries - Entries(..), - foldEntries, - unfoldEntries, - mapEntries, - - ) where - -import Data.Char (ord) -import Data.Int (Int64) -import Data.Bits (Bits, shiftL) -import Data.List (foldl') -import Numeric (readOct, showOct) -import Control.Monad (MonadPlus(mplus)) - -import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -import Data.ByteString.Lazy (ByteString) -import qualified Codec.Compression.GZip as GZip -import qualified Distribution.Client.GZipUtils as GZipUtils - -import System.FilePath - ( () ) -import qualified System.FilePath as FilePath.Native -import qualified System.FilePath.Windows as FilePath.Windows -import qualified System.FilePath.Posix as FilePath.Posix -import System.Directory - ( getDirectoryContents, doesDirectoryExist, getModificationTime - , getPermissions, createDirectoryIfMissing, copyFile ) -import qualified System.Directory as Permissions - ( Permissions(executable) ) -import System.Posix.Types - ( FileMode ) -import System.Time - ( ClockTime(..) ) -import System.IO - ( IOMode(ReadMode), openBinaryFile, hFileSize ) -import System.IO.Unsafe (unsafeInterleaveIO) - -import Prelude hiding (read) - - --- --- * High level operations --- - -createTarGzFile :: FilePath -- ^ Full Tarball path - -> FilePath -- ^ Base directory - -> FilePath -- ^ Directory to archive, relative to base dir - -> IO () -createTarGzFile tar base dir = - BS.writeFile tar . GZip.compress . write =<< pack base [dir] - -extractTarGzFile :: FilePath -- ^ Destination directory - -> FilePath -- ^ Expected subdir (to check for tarbombs) - -> FilePath -- ^ Tarball - -> IO () -extractTarGzFile dir expected tar = do - unpack dir . checkTarbomb expected . read . GZipUtils.maybeDecompress =<< BS.readFile tar - --- --- * Entry type --- - -type FileSize = Int64 --- | The number of seconds since the UNIX epoch -type EpochTime = Int64 -type DevMajor = Int -type DevMinor = Int -type TypeCode = Char -type Permissions = FileMode - --- | Tar archive entry. --- -data Entry = Entry { - - -- | The path of the file or directory within the archive. This is in a - -- tar-specific form. Use 'entryPath' to get a native 'FilePath'. - entryTarPath :: !TarPath, - - -- | The real content of the entry. For 'NormalFile' this includes the - -- file data. An entry usually contains a 'NormalFile' or a 'Directory'. - entryContent :: !EntryContent, - - -- | File permissions (Unix style file mode). - entryPermissions :: !Permissions, - - -- | The user and group to which this file belongs. - entryOwnership :: !Ownership, - - -- | The time the file was last modified. - entryTime :: !EpochTime, - - -- | The tar format the archive is using. - entryFormat :: !Format - } - --- | Native 'FilePath' of the file or directory within the archive. --- -entryPath :: Entry -> FilePath -entryPath = fromTarPath . entryTarPath - --- | The content of a tar archive entry, which depends on the type of entry. --- --- Portable archives should contain only 'NormalFile' and 'Directory'. --- -data EntryContent = NormalFile ByteString !FileSize - | Directory - | SymbolicLink !LinkTarget - | HardLink !LinkTarget - | CharacterDevice !DevMajor !DevMinor - | BlockDevice !DevMajor !DevMinor - | NamedPipe - | OtherEntryType !TypeCode ByteString !FileSize - -data Ownership = Ownership { - -- | The owner user name. Should be set to @\"\"@ if unknown. - ownerName :: String, - - -- | The owner group name. Should be set to @\"\"@ if unknown. - groupName :: String, - - -- | Numeric owner user id. Should be set to @0@ if unknown. - ownerId :: !Int, - - -- | Numeric owner group id. Should be set to @0@ if unknown. - groupId :: !Int - } - --- | There have been a number of extensions to the tar file format over the --- years. They all share the basic entry fields and put more meta-data in --- different extended headers. --- -data Format = - - -- | This is the classic Unix V7 tar format. It does not support owner and - -- group names, just numeric Ids. It also does not support device numbers. - V7Format - - -- | The \"USTAR\" format is an extension of the classic V7 format. It was - -- later standardised by POSIX. It has some restructions but is the most - -- portable format. - -- - | UstarFormat - - -- | The GNU tar implementation also extends the classic V7 format, though - -- in a slightly different way from the USTAR format. In general for new - -- archives the standard USTAR/POSIX should be used. - -- - | GnuFormat - deriving Eq - --- | @rw-r--r--@ for normal files -ordinaryFilePermissions :: Permissions -ordinaryFilePermissions = 0o0644 - --- | @rwxr-xr-x@ for executable files -executableFilePermissions :: Permissions -executableFilePermissions = 0o0755 - --- | @rwxr-xr-x@ for directories -directoryPermissions :: Permissions -directoryPermissions = 0o0755 - --- | An 'Entry' with all default values except for the file name and type. It --- uses the portable USTAR/POSIX format (see 'UstarHeader'). --- --- You can use this as a basis and override specific fields, eg: --- --- > (emptyEntry name HardLink) { linkTarget = target } --- -simpleEntry :: TarPath -> EntryContent -> Entry -simpleEntry tarpath content = Entry { - entryTarPath = tarpath, - entryContent = content, - entryPermissions = case content of - Directory -> directoryPermissions - _ -> ordinaryFilePermissions, - entryOwnership = Ownership "" "" 0 0, - entryTime = 0, - entryFormat = UstarFormat - } - --- | A tar 'Entry' for a file. --- --- Entry fields such as file permissions and ownership have default values. --- --- You can use this as a basis and override specific fields. For example if you --- need an executable file you could use: --- --- > (fileEntry name content) { fileMode = executableFileMode } --- -fileEntry :: TarPath -> ByteString -> Entry -fileEntry name fileContent = - simpleEntry name (NormalFile fileContent (BS.length fileContent)) - --- | A tar 'Entry' for a directory. --- --- Entry fields such as file permissions and ownership have default values. --- -directoryEntry :: TarPath -> Entry -directoryEntry name = simpleEntry name Directory - --- --- * Tar paths --- - --- | The classic tar format allowed just 100 charcters for the file name. The --- USTAR format extended this with an extra 155 characters, however it uses a --- complex method of splitting the name between the two sections. --- --- Instead of just putting any overflow into the extended area, it uses the --- extended area as a prefix. The agrevating insane bit however is that the --- prefix (if any) must only contain a directory prefix. That is the split --- between the two areas must be on a directory separator boundary. So there is --- no simple calculation to work out if a file name is too long. Instead we --- have to try to find a valid split that makes the name fit in the two areas. --- --- The rationale presumably was to make it a bit more compatible with old tar --- programs that only understand the classic format. A classic tar would be --- able to extract the file name and possibly some dir prefix, but not the --- full dir prefix. So the files would end up in the wrong place, but that's --- probably better than ending up with the wrong names too. --- --- So it's understandable but rather annoying. --- --- * Tar paths use posix format (ie @\'/\'@ directory separators), irrespective --- of the local path conventions. --- --- * The directory separator between the prefix and name is /not/ stored. --- -data TarPath = TarPath FilePath -- path name, 100 characters max. - FilePath -- path prefix, 155 characters max. - deriving (Eq, Ord) - --- | Convert a 'TarPath' to a native 'FilePath'. --- --- The native 'FilePath' will use the native directory separator but it is not --- otherwise checked for validity or sanity. In particular: --- --- * The tar path may be invalid as a native path, eg the filename @\"nul\"@ is --- not valid on Windows. --- --- * The tar path may be an absolute path or may contain @\"..\"@ components. --- For security reasons this should not usually be allowed, but it is your --- responsibility to check for these conditions (eg using 'checkSecurity'). --- -fromTarPath :: TarPath -> FilePath -fromTarPath (TarPath name prefix) = adjustDirectory $ - FilePath.Native.joinPath $ FilePath.Posix.splitDirectories prefix - ++ FilePath.Posix.splitDirectories name - where - adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name - = FilePath.Native.addTrailingPathSeparator - | otherwise = id - --- | Convert a native 'FilePath' to a 'TarPath'. --- --- The conversion may fail if the 'FilePath' is too long. See 'TarPath' for a --- description of the problem with splitting long 'FilePath's. --- -toTarPath :: Bool -- ^ Is the path for a directory? This is needed because for - -- directories a 'TarPath' must always use a trailing @\/@. - -> FilePath -> Either String TarPath -toTarPath isDir = splitLongPath - . addTrailingSep - . FilePath.Posix.joinPath - . FilePath.Native.splitDirectories - where - addTrailingSep | isDir = FilePath.Posix.addTrailingPathSeparator - | otherwise = id - --- | Take a sanitized path, split on directory separators and try to pack it --- into the 155 + 100 tar file name format. --- --- The stragey is this: take the name-directory components in reverse order --- and try to fit as many components into the 100 long name area as possible. --- If all the remaining components fit in the 155 name area then we win. --- -splitLongPath :: FilePath -> Either String TarPath -splitLongPath path = - case packName nameMax (reverse (FilePath.Posix.splitPath path)) of - Left err -> Left err - Right (name, []) -> Right (TarPath name "") - Right (name, first:rest) -> case packName prefixMax remainder of - Left err -> Left err - Right (_ , (_:_)) -> Left "File name too long (cannot split)" - Right (prefix, []) -> Right (TarPath name prefix) - where - -- drop the '/' between the name and prefix: - remainder = init first : rest - - where - nameMax, prefixMax :: Int - nameMax = 100 - prefixMax = 155 - - packName _ [] = Left "File name empty" - packName maxLen (c:cs) - | n > maxLen = Left "File name too long" - | otherwise = Right (packName' maxLen n [c] cs) - where n = length c - - packName' maxLen n ok (c:cs) - | n' <= maxLen = packName' maxLen n' (c:ok) cs - where n' = n + length c - packName' _ _ ok cs = (FilePath.Posix.joinPath ok, cs) - --- | The tar format allows just 100 ASCII charcters for the 'SymbolicLink' and --- 'HardLink' entry types. --- -newtype LinkTarget = LinkTarget FilePath - deriving (Eq, Ord) - --- | Convert a tar 'LinkTarget' to a native 'FilePath'. --- -fromLinkTarget :: LinkTarget -> FilePath -fromLinkTarget (LinkTarget path) = adjustDirectory $ - FilePath.Native.joinPath $ FilePath.Posix.splitDirectories path - where - adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path - = FilePath.Native.addTrailingPathSeparator - | otherwise = id - --- --- * Entries type --- - --- | A tar archive is a sequence of entries. -data Entries = Next Entry Entries - | Done - | Fail String - -unfoldEntries :: (a -> Either String (Maybe (Entry, a))) -> a -> Entries -unfoldEntries f = unfold - where - unfold x = case f x of - Left err -> Fail err - Right Nothing -> Done - Right (Just (e, x')) -> Next e (unfold x') - -foldEntries :: (Entry -> a -> a) -> a -> (String -> a) -> Entries -> a -foldEntries next done fail' = fold - where - fold (Next e es) = next e (fold es) - fold Done = done - fold (Fail err) = fail' err - -mapEntries :: (Entry -> Either String Entry) -> Entries -> Entries -mapEntries f = - foldEntries (\entry rest -> either Fail (flip Next rest) (f entry)) Done Fail - --- --- * Checking --- - --- | This function checks a sequence of tar entries for file name security --- problems. It checks that: --- --- * file paths are not absolute --- --- * file paths do not contain any path components that are \"@..@\" --- --- * file names are valid --- --- These checks are from the perspective of the current OS. That means we check --- for \"@C:\blah@\" files on Windows and \"\/blah\" files on unix. For archive --- entry types 'HardLink' and 'SymbolicLink' the same checks are done for the --- link target. A failure in any entry terminates the sequence of entries with --- an error. --- -checkSecurity :: Entries -> Entries -checkSecurity = checkEntries checkEntrySecurity - -checkTarbomb :: FilePath -> Entries -> Entries -checkTarbomb expectedTopDir = checkEntries (checkEntryTarbomb expectedTopDir) - -checkEntrySecurity :: Entry -> Maybe String -checkEntrySecurity entry = case entryContent entry of - HardLink link -> check (entryPath entry) - `mplus` check (fromLinkTarget link) - SymbolicLink link -> check (entryPath entry) - `mplus` check (fromLinkTarget link) - _ -> check (entryPath entry) - - where - check name - | not (FilePath.Native.isRelative name) - = Just $ "Absolute file name in tar archive: " ++ show name - - | not (FilePath.Native.isValid name) - = Just $ "Invalid file name in tar archive: " ++ show name - - | any (=="..") (FilePath.Native.splitDirectories name) - = Just $ "Invalid file name in tar archive: " ++ show name - - | otherwise = Nothing - -checkEntryTarbomb :: FilePath -> Entry -> Maybe String -checkEntryTarbomb _ entry | nonFilesystemEntry = Nothing - where - -- Ignore some special entries we will not unpack anyway - nonFilesystemEntry = - case entryContent entry of - OtherEntryType 'g' _ _ -> True --PAX global header - OtherEntryType 'x' _ _ -> True --PAX individual header - _ -> False - -checkEntryTarbomb expectedTopDir entry = - case FilePath.Native.splitDirectories (entryPath entry) of - (topDir:_) | topDir == expectedTopDir -> Nothing - _ -> Just $ "File in tar archive is not in the expected directory " - ++ show expectedTopDir - -checkEntries :: (Entry -> Maybe String) -> Entries -> Entries -checkEntries checkEntry = - mapEntries (\entry -> maybe (Right entry) Left (checkEntry entry)) - --- --- * Reading --- - -read :: ByteString -> Entries -read = unfoldEntries getEntry - -getEntry :: ByteString -> Either String (Maybe (Entry, ByteString)) -getEntry bs - | BS.length header < 512 = Left "truncated tar archive" - - -- Tar files end with at least two blocks of all '0'. Checking this serves - -- two purposes. It checks the format but also forces the tail of the data - -- which is necessary to close the file if it came from a lazily read file. - | BS.head bs == 0 = case BS.splitAt 1024 bs of - (end, trailing) - | BS.length end /= 1024 -> Left "short tar trailer" - | not (BS.all (== 0) end) -> Left "bad tar trailer" - | not (BS.all (== 0) trailing) -> Left "tar file has trailing junk" - | otherwise -> Right Nothing - - | otherwise = partial $ do - - case (chksum_, format_) of - (Ok chksum, _ ) | correctChecksum header chksum -> return () - (Ok _, Ok _) -> fail "tar checksum error" - _ -> fail "data is not in tar format" - - -- These fields are partial, have to check them - format <- format_; mode <- mode_; - uid <- uid_; gid <- gid_; - size <- size_; mtime <- mtime_; - devmajor <- devmajor_; devminor <- devminor_; - - let content = BS.take size (BS.drop 512 bs) - padding = (512 - size) `mod` 512 - bs' = BS.drop (512 + size + padding) bs - - entry = Entry { - entryTarPath = TarPath name prefix, - entryContent = case typecode of - '\0' -> NormalFile content size - '0' -> NormalFile content size - '1' -> HardLink (LinkTarget linkname) - '2' -> SymbolicLink (LinkTarget linkname) - '3' -> CharacterDevice devmajor devminor - '4' -> BlockDevice devmajor devminor - '5' -> Directory - '6' -> NamedPipe - '7' -> NormalFile content size - _ -> OtherEntryType typecode content size, - entryPermissions = mode, - entryOwnership = Ownership uname gname uid gid, - entryTime = mtime, - entryFormat = format - } - - return (Just (entry, bs')) - - where - header = BS.take 512 bs - - name = getString 0 100 header - mode_ = getOct 100 8 header - uid_ = getOct 108 8 header - gid_ = getOct 116 8 header - size_ = getOct 124 12 header - mtime_ = getOct 136 12 header - chksum_ = getOct 148 8 header - typecode = getByte 156 header - linkname = getString 157 100 header - magic = getChars 257 8 header - uname = getString 265 32 header - gname = getString 297 32 header - devmajor_ = getOct 329 8 header - devminor_ = getOct 337 8 header - prefix = getString 345 155 header --- trailing = getBytes 500 12 header - - format_ = case magic of - "\0\0\0\0\0\0\0\0" -> return V7Format - "ustar\NUL00" -> return UstarFormat - "ustar \NUL" -> return GnuFormat - _ -> fail "tar entry not in a recognised format" - -correctChecksum :: ByteString -> Int -> Bool -correctChecksum header checksum = checksum == checksum' - where - -- sum of all 512 bytes in the header block, - -- treating each byte as an 8-bit unsigned value - checksum' = BS.Char8.foldl' (\x y -> x + ord y) 0 header' - -- treating the 8 bytes of chksum as blank characters. - header' = BS.concat [BS.take 148 header, - BS.Char8.replicate 8 ' ', - BS.drop 156 header] - --- * TAR format primitive input - -getOct :: (Integral a, Bits a) => Int64 -> Int64 -> ByteString -> Partial a -getOct off len header - | BS.head bytes == 128 = parseBinInt (BS.unpack (BS.tail bytes)) - | null octstr = return 0 - | otherwise = case readOct octstr of - [(x,[])] -> return x - _ -> fail "tar header is malformed (bad numeric encoding)" - where - bytes = getBytes off len header - octstr = BS.Char8.unpack - . BS.Char8.takeWhile (\c -> c /= '\NUL' && c /= ' ') - . BS.Char8.dropWhile (== ' ') - $ bytes - - -- Some tar programs switch into a binary format when they try to represent - -- field values that will not fit in the required width when using the text - -- octal format. In particular, the UID/GID fields can only hold up to 2^21 - -- while in the binary format can hold up to 2^32. The binary format uses - -- '\128' as the header which leaves 7 bytes. Only the last 4 are used. - parseBinInt [0, 0, 0, byte3, byte2, byte1, byte0] = - return $! shiftL (fromIntegral byte3) 24 - + shiftL (fromIntegral byte2) 16 - + shiftL (fromIntegral byte1) 8 - + shiftL (fromIntegral byte0) 0 - parseBinInt _ = fail "tar header uses non-standard number encoding" - -getBytes :: Int64 -> Int64 -> ByteString -> ByteString -getBytes off len = BS.take len . BS.drop off - -getByte :: Int64 -> ByteString -> Char -getByte off bs = BS.Char8.index bs off - -getChars :: Int64 -> Int64 -> ByteString -> String -getChars off len = BS.Char8.unpack . getBytes off len - -getString :: Int64 -> Int64 -> ByteString -> String -getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0') . getBytes off len - -data Partial a = Error String | Ok a - -partial :: Partial a -> Either String a -partial (Error msg) = Left msg -partial (Ok x) = Right x - -instance Monad Partial where - return = Ok - Error m >>= _ = Error m - Ok x >>= k = k x - fail = Error - --- --- * Writing --- - --- | Create the external representation of a tar archive by serialising a list --- of tar entries. --- --- * The conversion is done lazily. --- -write :: [Entry] -> ByteString -write es = BS.concat $ map putEntry es ++ [BS.replicate (512*2) 0] - -putEntry :: Entry -> ByteString -putEntry entry = case entryContent entry of - NormalFile content size -> BS.concat [ header, content, padding size ] - OtherEntryType _ content size -> BS.concat [ header, content, padding size ] - _ -> header - where - header = putHeader entry - padding size = BS.replicate paddingSize 0 - where paddingSize = fromIntegral (negate size `mod` 512) - -putHeader :: Entry -> ByteString -putHeader entry = - BS.Char8.pack $ take 148 block - ++ putOct 7 checksum - ++ ' ' : drop 156 block - where - block = putHeaderNoChkSum entry - checksum = foldl' (\x y -> x + ord y) 0 block - -putHeaderNoChkSum :: Entry -> String -putHeaderNoChkSum Entry { - entryTarPath = TarPath name prefix, - entryContent = content, - entryPermissions = permissions, - entryOwnership = ownership, - entryTime = modTime, - entryFormat = format - } = - - concat - [ putString 100 $ name - , putOct 8 $ permissions - , putOct 8 $ ownerId ownership - , putOct 8 $ groupId ownership - , putOct 12 $ contentSize - , putOct 12 $ modTime - , fill 8 $ ' ' -- dummy checksum - , putChar8 $ typeCode - , putString 100 $ linkTarget - ] ++ - case format of - V7Format -> - fill 255 '\NUL' - UstarFormat -> concat - [ putString 8 $ "ustar\NUL00" - , putString 32 $ ownerName ownership - , putString 32 $ groupName ownership - , putOct 8 $ deviceMajor - , putOct 8 $ deviceMinor - , putString 155 $ prefix - , fill 12 $ '\NUL' - ] - GnuFormat -> concat - [ putString 8 $ "ustar \NUL" - , putString 32 $ ownerName ownership - , putString 32 $ groupName ownership - , putGnuDev 8 $ deviceMajor - , putGnuDev 8 $ deviceMinor - , putString 155 $ prefix - , fill 12 $ '\NUL' - ] - where - (typeCode, contentSize, linkTarget, - deviceMajor, deviceMinor) = case content of - NormalFile _ size -> ('0' , size, [], 0, 0) - Directory -> ('5' , 0, [], 0, 0) - SymbolicLink (LinkTarget link) -> ('2' , 0, link, 0, 0) - HardLink (LinkTarget link) -> ('1' , 0, link, 0, 0) - CharacterDevice major minor -> ('3' , 0, [], major, minor) - BlockDevice major minor -> ('4' , 0, [], major, minor) - NamedPipe -> ('6' , 0, [], 0, 0) - OtherEntryType code _ size -> (code, size, [], 0, 0) - - putGnuDev w n = case content of - CharacterDevice _ _ -> putOct w n - BlockDevice _ _ -> putOct w n - _ -> replicate w '\NUL' - --- * TAR format primitive output - -type FieldWidth = Int - -putString :: FieldWidth -> String -> String -putString n s = take n s ++ fill (n - length s) '\NUL' - ---TODO: check integer widths, eg for large file sizes -putOct :: Integral a => FieldWidth -> a -> String -putOct n x = - let octStr = take (n-1) $ showOct x "" - in fill (n - length octStr - 1) '0' - ++ octStr - ++ putChar8 '\NUL' - -putChar8 :: Char -> String -putChar8 c = [c] - -fill :: FieldWidth -> Char -> String -fill n c = replicate n c - --- --- * Unpacking --- - -unpack :: FilePath -> Entries -> IO () -unpack baseDir entries = unpackEntries [] (checkSecurity entries) - >>= emulateLinks - - where - -- We're relying here on 'checkSecurity' to make sure we're not scribbling - -- files all over the place. - - unpackEntries _ (Fail err) = fail err - unpackEntries links Done = return links - unpackEntries links (Next entry es) = case entryContent entry of - NormalFile file _ -> extractFile path file - >> unpackEntries links es - Directory -> extractDir path - >> unpackEntries links es - HardLink link -> (unpackEntries $! saveLink path link links) es - SymbolicLink link -> (unpackEntries $! saveLink path link links) es - _ -> unpackEntries links es --ignore other file types - where - path = entryPath entry - - extractFile path content = do - -- Note that tar archives do not make sure each directory is created - -- before files they contain, indeed we may have to create several - -- levels of directory. - createDirectoryIfMissing True absDir - BS.writeFile absPath content - where - absDir = baseDir FilePath.Native.takeDirectory path - absPath = baseDir path - - extractDir path = createDirectoryIfMissing True (baseDir path) - - saveLink path link links = seq (length path) - $ seq (length link') - $ (path, link'):links - where link' = fromLinkTarget link - - emulateLinks = mapM_ $ \(relPath, relLinkTarget) -> - let absPath = baseDir relPath - absTarget = FilePath.Native.takeDirectory absPath relLinkTarget - in copyFile absTarget absPath - --- --- * Packing --- - -pack :: FilePath -- ^ Base directory - -> [FilePath] -- ^ Files and directories to pack, relative to the base dir - -> IO [Entry] -pack baseDir paths0 = preparePaths baseDir paths0 >>= packPaths baseDir - -preparePaths :: FilePath -> [FilePath] -> IO [FilePath] -preparePaths baseDir paths = - fmap concat $ interleave - [ do isDir <- doesDirectoryExist (baseDir path) - if isDir - then do entries <- getDirectoryContentsRecursive (baseDir path) - return (FilePath.Native.addTrailingPathSeparator path - : map (path ) entries) - else return [path] - | path <- paths ] - -packPaths :: FilePath -> [FilePath] -> IO [Entry] -packPaths baseDir paths = - interleave - [ do tarpath <- either fail return (toTarPath isDir relpath) - if isDir then packDirectoryEntry filepath tarpath - else packFileEntry filepath tarpath - | relpath <- paths - , let isDir = FilePath.Native.hasTrailingPathSeparator filepath - filepath = baseDir relpath ] - -interleave :: [IO a] -> IO [a] -interleave = unsafeInterleaveIO . go - where - go [] = return [] - go (x:xs) = do - x' <- x - xs' <- interleave xs - return (x':xs') - -packFileEntry :: FilePath -- ^ Full path to find the file on the local disk - -> TarPath -- ^ Path to use for the tar Entry in the archive - -> IO Entry -packFileEntry filepath tarpath = do - mtime <- getModTime filepath - perms <- getPermissions filepath - file <- openBinaryFile filepath ReadMode - size <- hFileSize file - content <- BS.hGetContents file - return (simpleEntry tarpath (NormalFile content (fromIntegral size))) { - entryPermissions = if Permissions.executable perms - then executableFilePermissions - else ordinaryFilePermissions, - entryTime = mtime - } - -packDirectoryEntry :: FilePath -- ^ Full path to find the file on the local disk - -> TarPath -- ^ Path to use for the tar Entry in the archive - -> IO Entry -packDirectoryEntry filepath tarpath = do - mtime <- getModTime filepath - return (directoryEntry tarpath) { - entryTime = mtime - } - -getDirectoryContentsRecursive :: FilePath -> IO [FilePath] -getDirectoryContentsRecursive dir0 = - fmap tail (recurseDirectories dir0 [""]) - -recurseDirectories :: FilePath -> [FilePath] -> IO [FilePath] -recurseDirectories _ [] = return [] -recurseDirectories base (dir:dirs) = unsafeInterleaveIO $ do - (files, dirs') <- collect [] [] =<< getDirectoryContents (base dir) - - files' <- recurseDirectories base (dirs' ++ dirs) - return (dir : files ++ files') - - where - collect files dirs' [] = return (reverse files, reverse dirs') - collect files dirs' (entry:entries) | ignore entry - = collect files dirs' entries - collect files dirs' (entry:entries) = do - let dirEntry = dir entry - dirEntry' = FilePath.Native.addTrailingPathSeparator dirEntry - isDirectory <- doesDirectoryExist (base dirEntry) - if isDirectory - then collect files (dirEntry':dirs') entries - else collect (dirEntry:files) dirs' entries - - ignore ['.'] = True - ignore ['.', '.'] = True - ignore _ = False - -getModTime :: FilePath -> IO EpochTime -getModTime path = do - (TOD s _) <- getModificationTime path - return $! fromIntegral s diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Types.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Types.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Types.hs +++ /dev/null @@ -1,211 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Types --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- All data types for the entire cabal-install system gathered here to avoid some .hs-boot files. ------------------------------------------------------------------------------ -module Distribution.Client.Types where - -import Distribution.Package - ( PackageName, PackageId, Package(..) - , PackageFixedDeps(..), Dependency ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo ) -import Distribution.PackageDescription - ( GenericPackageDescription, FlagAssignment, FlagName(FlagName) ) -import Distribution.Client.PackageIndex - ( PackageIndex ) -import Distribution.Version - ( VersionRange ) -import Distribution.Text - ( Text(disp,parse) ) -import qualified Distribution.Compat.ReadP as Parse -import qualified Text.PrettyPrint as Disp - - -import Data.Char as Char -import Data.Map (Map) -import Network.URI (URI) -import Distribution.Compat.Exception - ( SomeException ) - -newtype Username = Username { unUsername :: String } -newtype Password = Password { unPassword :: String } - --- | This is the information we get from a @00-index.tar.gz@ hackage index. --- -data AvailablePackageDb = AvailablePackageDb { - packageIndex :: PackageIndex AvailablePackage, - packagePreferences :: Map PackageName VersionRange -} - --- | TODO: This is a hack to help us transition from Cabal-1.6 to 1.8. --- What is new in 1.8 is that installed packages and dependencies between --- installed packages are now identified by an opaque InstalledPackageId --- rather than a source PackageId. --- --- We should use simply an 'InstalledPackageInfo' here but to ease the --- transition we are temporarily using this variant where we pretend that --- installed packages still specify their deps in terms of PackageIds. --- --- Crucially this means that 'InstalledPackage' can be an instance of --- 'PackageFixedDeps' where as 'InstalledPackageInfo' is no longer an instance --- of that class. This means we can make 'PackageIndex'es of InstalledPackage --- where as the InstalledPackageInfo now has its own monomorphic index type. --- -data InstalledPackage = InstalledPackage - InstalledPackageInfo - [PackageId] - -instance Package InstalledPackage where - packageId (InstalledPackage pkg _) = packageId pkg -instance PackageFixedDeps InstalledPackage where - depends (InstalledPackage _ deps) = deps - --- | A 'ConfiguredPackage' is a not-yet-installed package along with the --- total configuration information. The configuration information is total in --- the sense that it provides all the configuration information and so the --- final configure process will be independent of the environment. --- -data ConfiguredPackage = ConfiguredPackage - AvailablePackage -- package info, including repo - FlagAssignment -- complete flag assignment for the package - [PackageId] -- set of exact dependencies. These must be - -- consistent with the 'buildDepends' in the - -- 'PackageDescrption' that you'd get by applying - -- the flag assignment. - deriving Show - -instance Package ConfiguredPackage where - packageId (ConfiguredPackage pkg _ _) = packageId pkg - -instance PackageFixedDeps ConfiguredPackage where - depends (ConfiguredPackage _ _ deps) = deps - - --- | We re-use @GenericPackageDescription@ and use the @package-url@ --- field to store the tarball URI. -data AvailablePackage = AvailablePackage { - packageInfoId :: PackageId, - packageDescription :: GenericPackageDescription, - packageSource :: AvailablePackageSource - } - deriving Show - -instance Package AvailablePackage where packageId = packageInfoId - -data AvailablePackageSource = - - -- | An unpacked package in the given dir, or current dir - LocalUnpackedPackage (Maybe FilePath) - - -- | A package as a tarball that's available as a local tarball - | LocalTarballPackage FilePath - - -- | A package as a tarball from a remote URI - | RemoteTarballPackage URI - - -- | A package available as a tarball from a repository. - -- - -- It may be from a local repository or from a remote repository, with a - -- locally cached copy. ie a package available from hackage - | RepoTarballPackage Repo - --- | ScmPackage - deriving Show - ---TODO: --- * add support for darcs and other SCM style remote repos with a local cache - -data LocalRepo = LocalRepo - deriving (Show,Eq) - -data RemoteRepo = RemoteRepo { - remoteRepoName :: String, - remoteRepoURI :: URI - } - deriving (Show,Eq) - -data Repo = Repo { - repoKind :: Either RemoteRepo LocalRepo, - repoLocalDir :: FilePath - } - deriving (Show,Eq) - -data UnresolvedDependency - = UnresolvedDependency - { dependency :: Dependency - , depFlags :: FlagAssignment - } - deriving (Show,Eq) - - -instance Text UnresolvedDependency where - disp udep = disp (dependency udep) Disp.<+> dispFlags (depFlags udep) - where - dispFlags [] = Disp.empty - dispFlags fs = Disp.text "--flags=" - Disp.<> - (Disp.doubleQuotes $ flagAssToDoc fs) - flagAssToDoc = foldr (\(FlagName fname,val) flagAssDoc -> - (if not val then Disp.char '-' - else Disp.empty) - Disp.<> Disp.text fname - Disp.<+> flagAssDoc) - Disp.empty - parse = do - dep <- parse - Parse.skipSpaces - flagAss <- Parse.option [] parseFlagAssignment - return $ UnresolvedDependency dep flagAss - where - parseFlagAssignment :: Parse.ReadP r FlagAssignment - parseFlagAssignment = do - Parse.string "--flags" - Parse.skipSpaces - Parse.char '=' - Parse.skipSpaces - inDoubleQuotes $ Parse.many1 flag - where - inDoubleQuotes :: Parse.ReadP r a -> Parse.ReadP r a - inDoubleQuotes = Parse.between (Parse.char '"') (Parse.char '"') - - flag = do - Parse.skipSpaces - val <- negative Parse.+++ positive - name <- ident - Parse.skipSpaces - return (FlagName name,val) - negative = do - Parse.char '-' - return False - positive = return True - - ident :: Parse.ReadP r String - ident = do - -- First character must be a letter/digit to avoid flags - -- like "+-debug": - c <- Parse.satisfy Char.isAlphaNum - cs <- Parse.munch (\ch -> Char.isAlphaNum ch || ch == '_' - || ch == '-') - return (c:cs) - - - -type BuildResult = Either BuildFailure BuildSuccess -data BuildFailure = DependentFailed PackageId - | DownloadFailed SomeException - | UnpackFailed SomeException - | ConfigureFailed SomeException - | BuildFailed SomeException - | InstallFailed SomeException -data BuildSuccess = BuildOk DocsResult TestsResult - -data DocsResult = DocsNotTried | DocsFailed | DocsOk -data TestsResult = TestsNotTried | TestsFailed | TestsOk diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Unpack.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Unpack.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Unpack.hs +++ /dev/null @@ -1,138 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Unpack --- Copyright : (c) Andrea Vezzosi 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- ------------------------------------------------------------------------------ -module Distribution.Client.Unpack ( - - -- * Commands - unpack, - - ) where - -import Distribution.Package - ( PackageId, Dependency(..) ) -import Distribution.Simple.Setup(fromFlag, fromFlagOrDefault) -import Distribution.Simple.Utils - ( notice, die ) -import Distribution.Verbosity - ( Verbosity ) -import Distribution.Text(display) - -import Distribution.Client.Setup(UnpackFlags(unpackVerbosity, - unpackDestDir)) -import Distribution.Client.Types(UnresolvedDependency(..), - Repo, AvailablePackageSource(..), - AvailablePackage(AvailablePackage), - AvailablePackageDb(AvailablePackageDb)) -import Distribution.Client.Dependency as Dependency - ( resolveAvailablePackages - , dependencyConstraints, dependencyTargets - , PackagesPreference(..), PackagesPreferenceDefault(..) - , PackagePreference(..) ) -import Distribution.Client.Fetch - ( fetchPackage ) -import Distribution.Client.HttpUtils - ( downloadURI ) -import qualified Distribution.Client.Tar as Tar (extractTarGzFile) -import Distribution.Client.IndexUtils as IndexUtils - (getAvailablePackages, disambiguateDependencies) - -import System.Directory - ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist - , getTemporaryDirectory ) -import System.IO - ( openTempFile, hClose ) -import Control.Monad - ( unless, when ) -import Data.Monoid - ( mempty ) -import System.FilePath - ( (), addTrailingPathSeparator ) -import qualified Data.Map as Map - -unpack :: UnpackFlags -> [Repo] -> [Dependency] -> IO () -unpack flags _ [] = - notice verbosity "No packages requested. Nothing to do." - where - verbosity = fromFlag (unpackVerbosity flags) - -unpack flags repos deps = do - db@(AvailablePackageDb available _) - <- getAvailablePackages verbosity repos - deps' <- IndexUtils.disambiguateDependencies available - . map toUnresolved $ deps - - pkgs <- resolvePackages db deps' - - unless (null prefix) $ - createDirectoryIfMissing True prefix - - flip mapM_ pkgs $ \pkg -> case pkg of - - AvailablePackage pkgid _ (LocalTarballPackage tarballPath) -> - unpackPackage verbosity prefix pkgid tarballPath - - AvailablePackage pkgid _ (RemoteTarballPackage tarballURL) -> do - tmp <- getTemporaryDirectory - (tarballPath, hnd) <- openTempFile tmp (display pkgid) - hClose hnd - --TODO: perhaps we've already had to download this to a local cache - -- so we even know what package version it is. So might be able - -- to get it from the local cache rather than from remote. - downloadURI verbosity tarballURL tarballPath - unpackPackage verbosity prefix pkgid tarballPath - - AvailablePackage pkgid _ (RepoTarballPackage repo) -> do - tarballPath <- fetchPackage verbosity repo pkgid - unpackPackage verbosity prefix pkgid tarballPath - - AvailablePackage _ _ (LocalUnpackedPackage _) -> - error "Distribution.Client.Unpack.unpack: the impossible happened." - - where - verbosity = fromFlag (unpackVerbosity flags) - prefix = fromFlagOrDefault "" (unpackDestDir flags) - toUnresolved d = UnresolvedDependency d [] - -unpackPackage :: Verbosity -> FilePath -> PackageId -> FilePath -> IO () -unpackPackage verbosity prefix pkgid pkgPath = do - let pkgdirname = display pkgid - pkgdir = prefix pkgdirname - pkgdir' = addTrailingPathSeparator pkgdir - existsDir <- doesDirectoryExist pkgdir - when existsDir $ die $ - "The directory \"" ++ pkgdir' ++ "\" already exists, not unpacking." - existsFile <- doesFileExist pkgdir - when existsFile $ die $ - "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." - notice verbosity $ "Unpacking to " ++ pkgdir' - Tar.extractTarGzFile prefix pkgdirname pkgPath - -resolvePackages :: AvailablePackageDb - -> [UnresolvedDependency] - -> IO [AvailablePackage] -resolvePackages - (AvailablePackageDb available availablePrefs) deps = - - either (die . unlines . map show) return $ - resolveAvailablePackages - installed available - preferences constraints - targets - - where - installed = mempty - targets = dependencyTargets deps - constraints = dependencyConstraints deps - preferences = PackagesPreference - PreferLatestForSelected - [ PackageVersionPreference name ver - | (name, ver) <- Map.toList availablePrefs ] diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Update.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Update.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Update.hs +++ /dev/null @@ -1,82 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Update --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- ------------------------------------------------------------------------------ -module Distribution.Client.Update - ( update - ) where - -import Distribution.Client.Types - ( Repo(..), RemoteRepo(..), LocalRepo(..), AvailablePackageDb(..) ) -import Distribution.Client.Fetch - ( downloadIndex ) -import qualified Distribution.Client.PackageIndex as PackageIndex -import Distribution.Client.IndexUtils - ( getAvailablePackages ) -import qualified Paths_cabal_install - ( version ) - -import Distribution.Package - ( PackageName(..), packageVersion ) -import Distribution.Version - ( anyVersion, withinRange ) -import Distribution.Simple.Utils - ( warn, notice, writeFileAtomic ) -import Distribution.Verbosity - ( Verbosity ) - -import qualified Data.ByteString.Lazy as BS -import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -import Distribution.Client.GZipUtils (maybeDecompress) -import qualified Data.Map as Map -import System.FilePath (dropExtension) -import Data.Maybe (fromMaybe) -import Control.Monad (when) - --- | 'update' downloads the package list from all known servers -update :: Verbosity -> [Repo] -> IO () -update verbosity [] = do - warn verbosity $ "No remote package servers have been specified. Usually " - ++ "you would have one specified in the config file." -update verbosity repos = do - mapM_ (updateRepo verbosity) repos - checkForSelfUpgrade verbosity repos - -updateRepo :: Verbosity -> Repo -> IO () -updateRepo verbosity repo = case repoKind repo of - Right LocalRepo -> return () - Left remoteRepo -> do - notice verbosity $ "Downloading the latest package list from " - ++ remoteRepoName remoteRepo - indexPath <- downloadIndex verbosity remoteRepo (repoLocalDir repo) - writeFileAtomic (dropExtension indexPath) . BS.Char8.unpack - . maybeDecompress - =<< BS.readFile indexPath - -checkForSelfUpgrade :: Verbosity -> [Repo] -> IO () -checkForSelfUpgrade verbosity repos = do - AvailablePackageDb available prefs <- getAvailablePackages verbosity repos - - let self = PackageName "cabal-install" - preferredVersionRange = fromMaybe anyVersion (Map.lookup self prefs) - currentVersion = Paths_cabal_install.version - laterPreferredVersions = - [ packageVersion pkg - | pkg <- PackageIndex.lookupPackageName available self - , let version = packageVersion pkg - , version > currentVersion - , version `withinRange` preferredVersionRange ] - - when (not (null laterPreferredVersions)) $ - notice verbosity $ - "Note: there is a new version of cabal-install available.\n" - ++ "To upgrade, run: cabal install cabal-install" - diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Upload.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Upload.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Upload.hs +++ /dev/null @@ -1,177 +0,0 @@ --- This is a quick hack for uploading packages to Hackage. --- See http://hackage.haskell.org/trac/hackage/wiki/CabalUpload - -module Distribution.Client.Upload (check, upload, report) where - -import Distribution.Client.Types (Username(..), Password(..),Repo(..),RemoteRepo(..)) -import Distribution.Client.HttpUtils (proxy, isOldHackageURI) - -import Distribution.Simple.Utils (debug, notice, warn, info) -import Distribution.Verbosity (Verbosity) -import Distribution.Text (display) -import Distribution.Client.Config - -import qualified Distribution.Client.BuildReports.Anonymous as BuildReport -import qualified Distribution.Client.BuildReports.Upload as BuildReport - -import Network.Browser - ( BrowserAction, browse, request - , Authority(..), addAuthority, setAuthorityGen - , setOutHandler, setErrHandler, setProxy ) -import Network.HTTP - ( Header(..), HeaderName(..), findHeader - , Request(..), RequestMethod(..), Response(..) ) -import Network.TCP (HandleStream) -import Network.URI (URI(uriPath), parseURI) - -import Data.Char (intToDigit) -import Numeric (showHex) -import System.IO (hFlush, stdin, stdout, hGetEcho, hSetEcho - ,openBinaryFile, IOMode(ReadMode), hGetContents) -import Control.Exception (bracket) -import System.Random (randomRIO) -import System.FilePath ((), takeExtension, takeFileName) -import qualified System.FilePath.Posix as FilePath.Posix (combine) -import System.Directory -import Control.Monad (forM_) - - ---FIXME: how do we find this path for an arbitrary hackage server? --- is it always at some fixed location relative to the server root? -legacyUploadURI :: URI -Just legacyUploadURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/protected/upload-pkg" - -checkURI :: URI -Just checkURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/check-pkg" - - -upload :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> [FilePath] -> IO () -upload verbosity repos mUsername mPassword paths = do - let uploadURI = if isOldHackageURI targetRepoURI - then legacyUploadURI - else targetRepoURI{uriPath = uriPath targetRepoURI `FilePath.Posix.combine` "upload"} - Username username <- maybe promptUsername return mUsername - Password password <- maybe promptPassword return mPassword - let auth = addAuthority AuthBasic { - auRealm = "Hackage", - auUsername = username, - auPassword = password, - auSite = uploadURI - } - flip mapM_ paths $ \path -> do - notice verbosity $ "Uploading " ++ path ++ "... " - handlePackage verbosity uploadURI auth path - where - targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given - promptUsername :: IO Username - promptUsername = do - putStr "Hackage username: " - hFlush stdout - fmap Username getLine - - promptPassword :: IO Password - promptPassword = do - putStr "Hackage password: " - hFlush stdout - -- save/restore the terminal echoing status - passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do - hSetEcho stdin False -- no echoing for entering the password - fmap Password getLine - putStrLn "" - return passwd - -report :: Verbosity -> [Repo] -> IO () -report verbosity repos - = forM_ repos $ \repo -> - case repoKind repo of - Left remoteRepo - -> do dotCabal <- defaultCabalDir - let srcDir = dotCabal "reports" remoteRepoName remoteRepo - contents <- getDirectoryContents srcDir - forM_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile -> - do inp <- readFile (srcDir logFile) - let (reportStr, buildLog) = read inp :: (String,String) - case BuildReport.parse reportStr of - Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME - Right report' -> - do info verbosity $ "Uploading report for " ++ display (BuildReport.package report') - browse $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)] - return () - Right{} -> return () - -check :: Verbosity -> [FilePath] -> IO () -check verbosity paths = do - flip mapM_ paths $ \path -> do - notice verbosity $ "Checking " ++ path ++ "... " - handlePackage verbosity checkURI (return ()) path - -handlePackage :: Verbosity -> URI -> BrowserAction (HandleStream String) () - -> FilePath -> IO () -handlePackage verbosity uri auth path = - do req <- mkRequest uri path - p <- proxy verbosity - debug verbosity $ "\n" ++ show req - (_,resp) <- browse $ do - setProxy p - setErrHandler (warn verbosity . ("http error: "++)) - setOutHandler (debug verbosity) - auth - setAuthorityGen (\_ _ -> return Nothing) - request req - debug verbosity $ show resp - case rspCode resp of - (2,0,0) -> do notice verbosity "Ok" - (x,y,z) -> do notice verbosity $ "Error: " ++ path ++ ": " - ++ map intToDigit [x,y,z] ++ " " - ++ rspReason resp - case findHeader HdrContentType resp of - Just contenttype - | takeWhile (/= ';') contenttype == "text/plain" - -> notice verbosity $ rspBody resp - _ -> debug verbosity $ rspBody resp - -mkRequest :: URI -> FilePath -> IO (Request String) -mkRequest uri path = - do pkg <- readBinaryFile path - boundary <- genBoundary - let body = printMultiPart boundary (mkFormData path pkg) - return $ Request { - rqURI = uri, - rqMethod = POST, - rqHeaders = [Header HdrContentType ("multipart/form-data; boundary="++boundary), - Header HdrContentLength (show (length body)), - Header HdrAccept ("text/plain")], - rqBody = body - } - -readBinaryFile :: FilePath -> IO String -readBinaryFile path = openBinaryFile path ReadMode >>= hGetContents - -genBoundary :: IO String -genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer - return $ showHex i "" - -mkFormData :: FilePath -> String -> [BodyPart] -mkFormData path pkg = - -- yes, web browsers are that stupid (re quoting) - [BodyPart [Header hdrContentDisposition $ - "form-data; name=package; filename=\""++takeFileName path++"\"", - Header HdrContentType "application/x-gzip"] - pkg] - -hdrContentDisposition :: HeaderName -hdrContentDisposition = HdrCustom "Content-disposition" - --- * Multipart, partly stolen from the cgi package. - -data BodyPart = BodyPart [Header] String - -printMultiPart :: String -> [BodyPart] -> String -printMultiPart boundary xs = - concatMap (printBodyPart boundary) xs ++ crlf ++ "--" ++ boundary ++ "--" ++ crlf - -printBodyPart :: String -> BodyPart -> String -printBodyPart boundary (BodyPart hs c) = crlf ++ "--" ++ boundary ++ crlf ++ concatMap show hs ++ crlf ++ c - -crlf :: String -crlf = "\r\n" diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Utils.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Utils.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Utils.hs +++ /dev/null @@ -1,60 +0,0 @@ -module Distribution.Client.Utils where - -import Data.List - ( sortBy, groupBy ) -import System.Directory - ( doesFileExist, getModificationTime - , getCurrentDirectory, setCurrentDirectory ) -import qualified Control.Exception as Exception - ( finally ) - --- | Generic merging utility. For sorted input lists this is a full outer join. --- --- * The result list never contains @(Nothing, Nothing)@. --- -mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b] -mergeBy cmp = merge - where - merge [] ys = [ OnlyInRight y | y <- ys] - merge xs [] = [ OnlyInLeft x | x <- xs] - merge (x:xs) (y:ys) = - case x `cmp` y of - GT -> OnlyInRight y : merge (x:xs) ys - EQ -> InBoth x y : merge xs ys - LT -> OnlyInLeft x : merge xs (y:ys) - -data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b - -duplicates :: Ord a => [a] -> [[a]] -duplicates = duplicatesBy compare - -duplicatesBy :: (a -> a -> Ordering) -> [a] -> [[a]] -duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp - where - eq a b = case cmp a b of - EQ -> True - _ -> False - moreThanOne (_:_:_) = True - moreThanOne _ = False - --- | Compare the modification times of two files to see if the first is newer --- than the second. The first file must exist but the second need not. --- The expected use case is when the second file is generated using the first. --- In this use case, if the result is True then the second file is out of date. --- -moreRecentFile :: FilePath -> FilePath -> IO Bool -moreRecentFile a b = do - exists <- doesFileExist b - if not exists - then return True - else do tb <- getModificationTime b - ta <- getModificationTime a - return (ta > tb) - --- | Executes the action in the specified directory. -inDir :: Maybe FilePath -> IO () -> IO () -inDir Nothing m = m -inDir (Just d) m = do - old <- getCurrentDirectory - setCurrentDirectory d - m `Exception.finally` setCurrentDirectory old diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/Win32SelfUpgrade.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/Win32SelfUpgrade.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/Win32SelfUpgrade.hs +++ /dev/null @@ -1,222 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} -{-# OPTIONS_NHC98 -cpp #-} -{-# OPTIONS_JHC -fcpp -fffi #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.Win32SelfUpgrade --- Copyright : (c) Duncan Coutts 2008 --- License : BSD-like --- --- Maintainer : cabal-devel@haskell.org --- Stability : provisional --- Portability : portable --- --- Support for self-upgrading executables on Windows platforms. ------------------------------------------------------------------------------ -module Distribution.Client.Win32SelfUpgrade ( --- * Explanation --- --- | Windows inherited a design choice from DOS that while initially innocuous --- has rather unfortunate consequences. It maintains the invariant that every --- open file has a corresponding name on disk. One positive consequence of this --- is that an executable can always find it's own executable file. The downside --- is that a program cannot be deleted or upgraded while it is running without --- hideous workarounds. This module implements one such hideous workaround. --- --- The basic idea is: --- --- * Move our own exe file to a new name --- * Copy a new exe file to the previous name --- * Run the new exe file, passing our own pid and new path --- * Wait for the new process to start --- * Close the new exe file --- * Exit old process --- --- Then in the new process: --- --- * Inform the old process that we've started --- * Wait for the old process to die --- * Delete the old exe file --- * Exit new process --- - - possibleSelfUpgrade, - deleteOldExeFile, - ) where - -#if mingw32_HOST_OS || mingw32_TARGET_OS - -import qualified System.Win32 as Win32 -import qualified System.Win32.DLL as Win32 -import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR) -import Foreign.Ptr (Ptr, nullPtr) -import System.Process (runProcess) -import System.Directory (canonicalizePath) -import System.FilePath (takeBaseName, replaceBaseName, equalFilePath) - -import Distribution.Verbosity as Verbosity (Verbosity, showForCabal) -import Distribution.Simple.Utils (debug, info) - -import Prelude hiding (log) - --- | If one of the given files is our own exe file then we arrange things such --- that the nested action can replace our own exe file. --- --- We require that the new process accepts a command line invocation that --- calls 'deleteOldExeFile', passing in the pid and exe file. --- -possibleSelfUpgrade :: Verbosity - -> [FilePath] - -> IO a -> IO a -possibleSelfUpgrade verbosity newPaths action = do - dstPath <- canonicalizePath =<< Win32.getModuleFileName Win32.nullHANDLE - - newPaths' <- mapM canonicalizePath newPaths - let doingSelfUpgrade = any (equalFilePath dstPath) newPaths' - - if not doingSelfUpgrade - then action - else do - info verbosity $ "cabal-install does the replace-own-exe-file dance..." - tmpPath <- moveOurExeOutOfTheWay verbosity - result <- action - scheduleOurDemise verbosity dstPath tmpPath - (\pid path -> ["win32selfupgrade", pid, path - ,"--verbose=" ++ Verbosity.showForCabal verbosity]) - return result - --- | The name of a Win32 Event object that we use to synchronise between the --- old and new processes. We need to synchronise to make sure that the old --- process has not yet terminated by the time the new one starts up and looks --- for the old process. Otherwise the old one might have already terminated --- and we could not wait on it terminating reliably (eg the pid might get --- re-used). --- -syncEventName :: String -syncEventName = "Local\\cabal-install-upgrade" - --- | The first part of allowing our exe file to be replaced is to move the --- existing exe file out of the way. Although we cannot delete our exe file --- while we're still running, fortunately we can rename it, at least within --- the same directory. --- -moveOurExeOutOfTheWay :: Verbosity -> IO FilePath -moveOurExeOutOfTheWay verbosity = do - ourPID <- getCurrentProcessId - dstPath <- Win32.getModuleFileName Win32.nullHANDLE - - let tmpPath = replaceBaseName dstPath (takeBaseName dstPath ++ show ourPID) - - debug verbosity $ "moving " ++ dstPath ++ " to " ++ tmpPath - Win32.moveFile dstPath tmpPath - return tmpPath - --- | Assuming we've now installed the new exe file in the right place, we --- launch it and ask it to delete our exe file when we eventually terminate. --- -scheduleOurDemise :: Verbosity -> FilePath -> FilePath - -> (String -> FilePath -> [String]) -> IO () -scheduleOurDemise verbosity dstPath tmpPath mkArgs = do - ourPID <- getCurrentProcessId - event <- createEvent syncEventName - - let args = mkArgs (show ourPID) tmpPath - log $ "launching child " ++ unwords (dstPath : map show args) - runProcess dstPath args Nothing Nothing Nothing Nothing Nothing - - log $ "waiting for the child to start up" - waitForSingleObject event (10*1000) -- wait at most 10 sec - log $ "child started ok" - - where - log msg = debug verbosity ("Win32Reinstall.parent: " ++ msg) - --- | Assuming we're now in the new child process, we've been asked by the old --- process to wait for it to terminate and then we can remove the old exe file --- that it renamted itself to. --- -deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () -deleteOldExeFile verbosity oldPID tmpPath = do - log $ "process started. Will delete exe file of process " - ++ show oldPID ++ " at path " ++ tmpPath - - log $ "getting handle of parent process " ++ show oldPID - oldPHANDLE <- Win32.openProcess Win32.sYNCHORNIZE False (fromIntegral oldPID) - - log $ "synchronising with parent" - event <- openEvent syncEventName - setEvent event - - log $ "waiting for parent process to terminate" - waitForSingleObject oldPHANDLE Win32.iNFINITE - log $ "parent process terminated" - - log $ "deleting parent's old .exe file" - Win32.deleteFile tmpPath - - where - log msg = debug verbosity ("Win32Reinstall.child: " ++ msg) - ------------------------- --- Win32 foreign imports --- - --- A bunch of functions sadly not provided by the Win32 package. - -foreign import stdcall unsafe "windows.h GetCurrentProcessId" - getCurrentProcessId :: IO DWORD - -foreign import stdcall unsafe "windows.h WaitForSingleObject" - waitForSingleObject_ :: HANDLE -> DWORD -> IO DWORD - -waitForSingleObject :: HANDLE -> DWORD -> IO () -waitForSingleObject handle timeout = - Win32.failIf_ bad "WaitForSingleObject" $ - waitForSingleObject_ handle timeout - where - bad result = not (result == 0 || result == wAIT_TIMEOUT) - wAIT_TIMEOUT = 0x00000102 - -foreign import stdcall unsafe "windows.h CreateEventW" - createEvent_ :: Ptr () -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE - -createEvent :: String -> IO HANDLE -createEvent name = do - Win32.failIfNull "CreateEvent" $ - Win32.withTString name $ - createEvent_ nullPtr False False - -foreign import stdcall unsafe "windows.h OpenEventW" - openEvent_ :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE - -openEvent :: String -> IO HANDLE -openEvent name = do - Win32.failIfNull "OpenEvent" $ - Win32.withTString name $ - openEvent_ eVENT_MODIFY_STATE False - where - eVENT_MODIFY_STATE :: DWORD - eVENT_MODIFY_STATE = 0x0002 - -foreign import stdcall unsafe "windows.h SetEvent" - setEvent_ :: HANDLE -> IO BOOL - -setEvent :: HANDLE -> IO () -setEvent handle = - Win32.failIfFalse_ "SetEvent" $ - setEvent_ handle - -#else - -import Distribution.Verbosity (Verbosity) -import Distribution.Simple.Utils (die) - -possibleSelfUpgrade :: Verbosity - -> [FilePath] - -> IO a -> IO a -possibleSelfUpgrade _ _ action = action - -deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () -deleteOldExeFile _ _ _ = die "win32selfupgrade not needed except on win32" - -#endif diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Client/World.hs b/cabal-install-0.9.5_rc20101226/Distribution/Client/World.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Client/World.hs +++ /dev/null @@ -1,132 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Client.World --- Copyright : (c) Peter Robinson 2009 --- License : BSD-like --- --- Maintainer : thaldyron@gmail.com --- Stability : provisional --- Portability : portable --- --- Interface to the world-file that contains a list of explicitly --- requested packages. Meant to be imported qualified. --- --- A world file entry stores the package-name, package-version, and --- user flags. --- For example, the entry generated by --- # cabal install stm-io-hooks --flags="-debug" --- looks like this: --- # stm-io-hooks -any --flags="-debug" --- To rebuild/upgrade the packages in world (e.g. when updating the compiler) --- use --- # cabal install world --- ------------------------------------------------------------------------------ -module Distribution.Client.World ( - insert, - delete, - getContents, - - worldPkg, - isWorldTarget, - isGoodWorldTarget, - ) where - -import Distribution.Simple.Utils( writeFileAtomic ) -import Distribution.Client.Types - ( UnresolvedDependency(..) ) -import Distribution.Package - ( PackageName(..), Dependency( Dependency ) ) -import Distribution.Version( anyVersion ) -import Distribution.Text( display, simpleParse ) -import Distribution.Verbosity ( Verbosity ) -import Distribution.Simple.Utils ( die, info, chattyTry ) -import Data.List( unionBy, deleteFirstsBy, nubBy ) -import Data.Maybe( isJust, fromJust ) -import System.IO.Error( isDoesNotExistError, ) -import qualified Data.ByteString.Lazy.Char8 as B -import Prelude hiding ( getContents ) - --- | Adds packages to the world file; creates the file if it doesn't --- exist yet. Version constraints and flag assignments for a package are --- updated if already present. IO errors are non-fatal. -insert :: Verbosity -> FilePath -> [UnresolvedDependency] -> IO () -insert = modifyWorld $ unionBy equalUDep - --- | Removes packages from the world file. --- Note: Currently unused as there is no mechanism in Cabal (yet) to --- handle uninstalls. IO errors are non-fatal. -delete :: Verbosity -> FilePath -> [UnresolvedDependency] -> IO () -delete = modifyWorld $ flip (deleteFirstsBy equalUDep) - --- | UnresolvedDependency values are considered equal if they refer to --- the same package, i.e., we don't care about differing versions or flags. -equalUDep :: UnresolvedDependency -> UnresolvedDependency -> Bool -equalUDep (UnresolvedDependency (Dependency pkg1 _) _) - (UnresolvedDependency (Dependency pkg2 _) _) = pkg1 == pkg2 - --- | Modifies the world file by applying an update-function ('unionBy' --- for 'insert', 'deleteFirstsBy' for 'delete') to the given list of --- packages. IO errors are considered non-fatal. -modifyWorld :: ([UnresolvedDependency] -> [UnresolvedDependency] - -> [UnresolvedDependency]) - -- ^ Function that defines how - -- the list of user packages are merged with - -- existing world packages. - -> Verbosity - -> FilePath -- ^ Location of the world file - -> [UnresolvedDependency] -- ^ list of user supplied packages - -> IO () -modifyWorld _ _ _ [] = return () -modifyWorld f verbosity world pkgs = - chattyTry "Error while updating world-file. " $ do - pkgsOldWorld <- getContents world - -- Filter out packages that are not in the world file: - let pkgsNewWorld = nubBy equalUDep $ f pkgs pkgsOldWorld - -- 'Dependency' is not an Ord instance, so we need to check for - -- equivalence the awkward way: - if not (all (`elem` pkgsOldWorld) pkgsNewWorld && - all (`elem` pkgsNewWorld) pkgsOldWorld) - then do - info verbosity "Updating world file..." - writeFileAtomic world $ unlines - [ (display pkg) | pkg <- pkgsNewWorld] - else - info verbosity "World file is already up to date." - - --- | Returns the content of the world file as a list -getContents :: FilePath -> IO [UnresolvedDependency] -getContents world = do - content <- safelyReadFile world - let result = map simpleParse (lines $ B.unpack content) - if all isJust result - then return $ map fromJust result - else die "Could not parse world file." - where - safelyReadFile :: FilePath -> IO B.ByteString - safelyReadFile file = B.readFile file `catch` handler - where - handler e | isDoesNotExistError e = return B.empty - | otherwise = ioError e - - --- | A dummy package that represents the world file. -worldPkg :: PackageName -worldPkg = PackageName "world" - --- | Currently we have a silly way of representing the world target as --- an 'UnresolvedDependency' so we need a way to recognise it. --- --- We should be using a structured type with various target kinds, like --- local file, repo package etc. --- -isWorldTarget :: UnresolvedDependency -> Bool -isWorldTarget (UnresolvedDependency (Dependency pkg _) _) = - pkg == worldPkg - -isGoodWorldTarget :: UnresolvedDependency -> Bool -isGoodWorldTarget (UnresolvedDependency (Dependency pkg ver) flags) = - pkg == worldPkg - && ver == anyVersion - && null flags diff --git a/cabal-install-0.9.5_rc20101226/Distribution/Compat/Exception.hs b/cabal-install-0.9.5_rc20101226/Distribution/Compat/Exception.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Distribution/Compat/Exception.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -cpp #-} -{-# OPTIONS_NHC98 -cpp #-} -{-# OPTIONS_JHC -fcpp #-} --- #hide -module Distribution.Compat.Exception ( - SomeException, - onException, - catchIO, - handleIO, - catchExit, - throwIOIO - ) where - -import System.Exit -import qualified Control.Exception as Exception -#if MIN_VERSION_base(4,0,0) -import Control.Exception (SomeException) -#else -import Control.Exception (Exception) -type SomeException = Exception -#endif - -onException :: IO a -> IO b -> IO a -#if MIN_VERSION_base(4,0,0) -onException = Exception.onException -#else -onException io what = io `Exception.catch` \e -> do what - Exception.throw e -#endif - -throwIOIO :: Exception.IOException -> IO a -#if MIN_VERSION_base(4,0,0) -throwIOIO = Exception.throwIO -#else -throwIOIO = Exception.throwIO . Exception.IOException -#endif - -catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a -#if MIN_VERSION_base(4,0,0) -catchIO = Exception.catch -#else -catchIO = Exception.catchJust Exception.ioErrors -#endif - -handleIO :: (Exception.IOException -> IO a) -> IO a -> IO a -handleIO = flip catchIO - -catchExit :: IO a -> (ExitCode -> IO a) -> IO a -#if MIN_VERSION_base(4,0,0) -catchExit = Exception.catch -#else -catchExit = Exception.catchJust exitExceptions - where exitExceptions (Exception.ExitException ee) = Just ee - exitExceptions _ = Nothing -#endif diff --git a/cabal-install-0.9.5_rc20101226/LICENSE b/cabal-install-0.9.5_rc20101226/LICENSE deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/LICENSE +++ /dev/null @@ -1,34 +0,0 @@ -Copyright (c) 2003-2008, Isaac Jones, Simon Marlow, Martin Sjögren, - Bjorn Bringert, Krasimir Angelov, - Malcolm Wallace, Ross Patterson, - Lemmih, Paolo Martini, Don Stewart, - Duncan Coutts -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/cabal-install-0.9.5_rc20101226/Main.hs b/cabal-install-0.9.5_rc20101226/Main.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Main.hs +++ /dev/null @@ -1,388 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Main --- Copyright : (c) David Himmelstrup 2005 --- License : BSD-like --- --- Maintainer : lemmih@gmail.com --- Stability : provisional --- Portability : portable --- --- Entry point to the default cabal-install front-end. ------------------------------------------------------------------------------ - -module Main (main) where - -import Distribution.Client.Setup - ( GlobalFlags(..), globalCommand, globalRepos - , ConfigFlags(..) - , ConfigExFlags(..), configureExCommand - , InstallFlags(..), defaultInstallFlags - , installCommand, upgradeCommand - , FetchFlags(..), fetchCommand - , checkCommand - , updateCommand - , ListFlags(..), listCommand - , InfoFlags(..), infoCommand - , UploadFlags(..), uploadCommand - , InitFlags, initCommand - , reportCommand - , unpackCommand, UnpackFlags(..) - , parsePackageArgs ) -import Distribution.Simple.Setup - ( BuildFlags(..), buildCommand - , HaddockFlags(..), haddockCommand - , HscolourFlags(..), hscolourCommand - , CopyFlags(..), copyCommand - , RegisterFlags(..), registerCommand - , CleanFlags(..), cleanCommand - , SDistFlags(..), sdistCommand - , TestFlags(..), testCommand - , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) - -import Distribution.Client.Types - ( UnresolvedDependency(UnresolvedDependency) ) -import Distribution.Client.SetupWrapper - ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) -import Distribution.Client.Config - ( SavedConfig(..), loadConfig, defaultConfigFile ) -import Distribution.Client.List (list, info) -import Distribution.Client.Install (install, upgrade) -import Distribution.Client.Configure (configure) -import Distribution.Client.Update (update) -import Distribution.Client.Fetch (fetch) -import Distribution.Client.Check as Check (check) ---import Distribution.Client.Clean (clean) -import Distribution.Client.Upload as Upload (upload, check, report) -import Distribution.Client.SrcDist (sdist) -import Distribution.Client.Unpack (unpack) -import Distribution.Client.Init (initCabal) -import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade - -import Distribution.Simple.Compiler - ( PackageDB(..), PackageDBStack ) -import Distribution.Simple.Program (defaultProgramConfiguration) -import Distribution.Simple.Command -import Distribution.Simple.Configure (configCompilerAux) -import Distribution.Simple.Utils - ( cabalVersion, die, topHandler, intercalate ) -import Distribution.Text - ( display ) -import Distribution.Verbosity as Verbosity - ( Verbosity, normal, intToVerbosity ) -import qualified Paths_cabal_install (version) - -import System.Environment (getArgs, getProgName) -import System.Exit (exitFailure) -import System.FilePath (splitExtension, takeExtension) -import System.Directory (doesFileExist) -import Data.List (intersperse) -import Data.Maybe (fromMaybe) -import Data.Monoid (Monoid(..)) -import Control.Monad (unless) - --- | Entry point --- -main :: IO () -main = getArgs >>= mainWorker - -mainWorker :: [String] -> IO () -mainWorker ("win32selfupgrade":args) = win32SelfUpgradeAction args -mainWorker args = topHandler $ - case commandsRun globalCommand commands args of - CommandHelp help -> printGlobalHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (globalflags, commandParse) -> - case commandParse of - _ | fromFlag (globalVersion globalflags) -> printVersion - | fromFlag (globalNumericVersion globalflags) -> printNumericVersion - CommandHelp help -> printCommandHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo action -> action globalflags - - where - printCommandHelp help = do - pname <- getProgName - putStr (help pname) - printGlobalHelp help = do - pname <- getProgName - configFile <- defaultConfigFile - putStr (help pname) - putStr $ "\nYou can edit the cabal configuration file to set defaults:\n" - ++ " " ++ configFile ++ "\n" - printOptionsList = putStr . unlines - printErrors errs = die $ concat (intersperse "\n" errs) - printNumericVersion = putStrLn $ display Paths_cabal_install.version - printVersion = putStrLn $ "cabal-install version " - ++ display Paths_cabal_install.version - ++ "\nusing version " - ++ display cabalVersion - ++ " of the Cabal library " - - commands = - [installCommand `commandAddAction` installAction - ,updateCommand `commandAddAction` updateAction - ,listCommand `commandAddAction` listAction - ,infoCommand `commandAddAction` infoAction - ,fetchCommand `commandAddAction` fetchAction - ,unpackCommand `commandAddAction` unpackAction - ,checkCommand `commandAddAction` checkAction - ,sdistCommand `commandAddAction` sdistAction - ,uploadCommand `commandAddAction` uploadAction - ,reportCommand `commandAddAction` reportAction - ,initCommand `commandAddAction` initAction - ,configureExCommand `commandAddAction` configureAction - ,wrapperAction (buildCommand defaultProgramConfiguration) - buildVerbosity buildDistPref - ,wrapperAction copyCommand - copyVerbosity copyDistPref - ,wrapperAction haddockCommand - haddockVerbosity haddockDistPref - ,wrapperAction cleanCommand - cleanVerbosity cleanDistPref - ,wrapperAction hscolourCommand - hscolourVerbosity hscolourDistPref - ,wrapperAction registerCommand - regVerbosity regDistPref - ,wrapperAction testCommand - testVerbosity testDistPref - ,upgradeCommand `commandAddAction` upgradeAction - ] - -wrapperAction :: Monoid flags - => CommandUI flags - -> (flags -> Flag Verbosity) - -> (flags -> Flag String) - -> Command (GlobalFlags -> IO ()) -wrapperAction command verbosityFlag distPrefFlag = - commandAddAction command - { commandDefaultFlags = mempty } $ \flags extraArgs _globalFlags -> do - let verbosity = fromFlagOrDefault normal (verbosityFlag flags) - setupScriptOptions = defaultSetupScriptOptions { - useDistPref = fromFlagOrDefault - (useDistPref defaultSetupScriptOptions) - (distPrefFlag flags) - } - setupWrapper verbosity setupScriptOptions Nothing - command (const flags) extraArgs - -configureAction :: (ConfigFlags, ConfigExFlags) - -> [String] -> GlobalFlags -> IO () -configureAction (configFlags, configExFlags) extraArgs globalFlags = do - let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - config <- loadConfig verbosity (globalConfigFile globalFlags) - (configUserInstall configFlags) - let configFlags' = savedConfigureFlags config `mappend` configFlags - configExFlags' = savedConfigureExFlags config `mappend` configExFlags - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, conf) <- configCompilerAux configFlags' - configure verbosity - (configPackageDB' configFlags') (globalRepos globalFlags') - comp conf configFlags' configExFlags' extraArgs - -installAction :: (ConfigFlags, ConfigExFlags, InstallFlags) - -> [String] -> GlobalFlags -> IO () -installAction (configFlags, _, installFlags) _ _globalFlags - | fromFlagOrDefault False (installOnly installFlags) - = let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - in setupWrapper verbosity defaultSetupScriptOptions Nothing - installCommand (const mempty) [] - -installAction (configFlags, configExFlags, installFlags) - extraArgs globalFlags = do - pkgs <- either die return (parsePackageArgs extraArgs) - let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - config <- loadConfig verbosity (globalConfigFile globalFlags) - (configUserInstall configFlags) - let configFlags' = savedConfigureFlags config `mappend` configFlags - configExFlags' = savedConfigureExFlags config `mappend` configExFlags - installFlags' = defaultInstallFlags `mappend` - savedInstallFlags config `mappend` installFlags - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, conf) <- configCompilerAux configFlags' - install verbosity - (configPackageDB' configFlags') (globalRepos globalFlags') - comp conf globalFlags' configFlags' configExFlags' installFlags' - [ UnresolvedDependency pkg (configConfigurationsFlags configFlags') - | pkg <- pkgs ] - -listAction :: ListFlags -> [String] -> GlobalFlags -> IO () -listAction listFlags extraArgs globalFlags = do - let verbosity = fromFlag (listVerbosity listFlags) - config <- loadConfig verbosity (globalConfigFile globalFlags) mempty - let configFlags = savedConfigureFlags config - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, conf) <- configCompilerAux configFlags - list verbosity - (configPackageDB' configFlags) - (globalRepos globalFlags') - comp - conf - listFlags - extraArgs - -infoAction :: InfoFlags -> [String] -> GlobalFlags -> IO () -infoAction infoFlags extraArgs globalFlags = do - pkgs <- either die return (parsePackageArgs extraArgs) - let verbosity = fromFlag (infoVerbosity infoFlags) - config <- loadConfig verbosity (globalConfigFile globalFlags) mempty - let configFlags = savedConfigureFlags config - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, conf) <- configCompilerAux configFlags - info verbosity - (configPackageDB' configFlags) - (globalRepos globalFlags') - comp - conf - infoFlags - [ UnresolvedDependency pkg [] | pkg <- pkgs ] - -updateAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO () -updateAction verbosityFlag extraArgs globalFlags = do - unless (null extraArgs) $ do - die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs - let verbosity = fromFlag verbosityFlag - config <- loadConfig verbosity (globalConfigFile globalFlags) mempty - let globalFlags' = savedGlobalFlags config `mappend` globalFlags - update verbosity (globalRepos globalFlags') - -upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags) - -> [String] -> GlobalFlags -> IO () -upgradeAction (configFlags, configExFlags, installFlags) - extraArgs globalFlags = do - pkgs <- either die return (parsePackageArgs extraArgs) - let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - config <- loadConfig verbosity (globalConfigFile globalFlags) - (configUserInstall configFlags) - let configFlags' = savedConfigureFlags config `mappend` configFlags - configExFlags' = savedConfigureExFlags config `mappend` configExFlags - installFlags' = defaultInstallFlags `mappend` - savedInstallFlags config `mappend` installFlags - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, conf) <- configCompilerAux configFlags' - upgrade verbosity - (configPackageDB' configFlags') (globalRepos globalFlags') - comp conf globalFlags' configFlags' configExFlags' installFlags' - [ UnresolvedDependency pkg (configConfigurationsFlags configFlags') - | pkg <- pkgs ] - -fetchAction :: FetchFlags -> [String] -> GlobalFlags -> IO () -fetchAction fetchFlags extraArgs globalFlags = do - pkgs <- either die return (parsePackageArgs extraArgs) - let verbosity = fromFlag (fetchVerbosity fetchFlags) - config <- loadConfig verbosity (globalConfigFile globalFlags) mempty - let configFlags = savedConfigureFlags config - globalFlags' = savedGlobalFlags config `mappend` globalFlags - (comp, conf) <- configCompilerAux configFlags - fetch verbosity - (configPackageDB' configFlags) (globalRepos globalFlags') - comp conf fetchFlags - [ UnresolvedDependency pkg [] --TODO: flags? - | pkg <- pkgs ] - -uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO () -uploadAction uploadFlags extraArgs globalFlags = do - let verbosity = fromFlag (uploadVerbosity uploadFlags) - config <- loadConfig verbosity (globalConfigFile globalFlags) mempty - let uploadFlags' = savedUploadFlags config `mappend` uploadFlags - globalFlags' = savedGlobalFlags config `mappend` globalFlags - tarfiles = extraArgs - checkTarFiles extraArgs - if fromFlag (uploadCheck uploadFlags') - then Upload.check verbosity tarfiles - else upload verbosity - (globalRepos globalFlags') - (flagToMaybe $ uploadUsername uploadFlags') - (flagToMaybe $ uploadPassword uploadFlags') - tarfiles - where - checkTarFiles tarfiles - | null tarfiles - = die "the 'upload' command expects one or more .tar.gz packages." - | not (null otherFiles) - = die $ "the 'upload' command expects only .tar.gz packages: " - ++ intercalate ", " otherFiles - | otherwise = sequence_ - [ do exists <- doesFileExist tarfile - unless exists $ die $ "file not found: " ++ tarfile - | tarfile <- tarfiles ] - - where otherFiles = filter (not . isTarGzFile) tarfiles - isTarGzFile file = case splitExtension file of - (file', ".gz") -> takeExtension file' == ".tar" - _ -> False - -checkAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO () -checkAction verbosityFlag extraArgs _globalFlags = do - unless (null extraArgs) $ do - die $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs - allOk <- Check.check (fromFlag verbosityFlag) - unless allOk exitFailure - - -sdistAction :: SDistFlags -> [String] -> GlobalFlags -> IO () -sdistAction sflags extraArgs _globalFlags = do - unless (null extraArgs) $ do - die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs - sdist sflags - -reportAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO () -reportAction verbosityFlag extraArgs globalFlags = do - unless (null extraArgs) $ do - die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs - - let verbosity = fromFlag verbosityFlag - config <- loadConfig verbosity (globalConfigFile globalFlags) mempty - let globalFlags' = savedGlobalFlags config `mappend` globalFlags - - Upload.report verbosity (globalRepos globalFlags') - -unpackAction :: UnpackFlags -> [String] -> GlobalFlags -> IO () -unpackAction flags extraArgs globalFlags = do - pkgs <- either die return (parsePackageArgs extraArgs) - let verbosity = fromFlag (unpackVerbosity flags) - config <- loadConfig verbosity (globalConfigFile globalFlags) mempty - unpack flags (globalRepos (savedGlobalFlags config)) pkgs - -initAction :: InitFlags -> [String] -> GlobalFlags -> IO () -initAction flags _extraArgs _globalFlags = do - initCabal flags - --- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. --- -win32SelfUpgradeAction :: [String] -> IO () -win32SelfUpgradeAction (pid:path:rest) = - Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path - where - verbosity = case rest of - (['-','-','v','e','r','b','o','s','e','=',n]:_) | n `elem` ['0'..'9'] - -> fromMaybe Verbosity.normal (Verbosity.intToVerbosity (read [n])) - _ -> Verbosity.normal -win32SelfUpgradeAction _ = return () - --- --- Utils (transitionary) --- - --- | Currently the user interface specifies the package dbs to use with just a --- single valued option, a 'PackageDB'. However internally we represent the --- stack of 'PackageDB's explictly as a list. This function converts encodes --- the package db stack implicit in a single packagedb. --- --- TODO: sort this out, make it consistent with the command line UI -implicitPackageDbStack :: Bool -> Maybe PackageDB -> PackageDBStack -implicitPackageDbStack userInstall packageDbFlag - | userInstall = GlobalPackageDB : UserPackageDB : extra - | otherwise = GlobalPackageDB : extra - where - extra = case packageDbFlag of - Just (SpecificPackageDB db) -> [SpecificPackageDB db] - _ -> [] - -configPackageDB' :: ConfigFlags -> PackageDBStack -configPackageDB' cfg = - implicitPackageDbStack userInstall (flagToMaybe (configPackageDB cfg)) - where - userInstall = fromFlagOrDefault True (configUserInstall cfg) diff --git a/cabal-install-0.9.5_rc20101226/Paths_cabal_install.hs b/cabal-install-0.9.5_rc20101226/Paths_cabal_install.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Paths_cabal_install.hs +++ /dev/null @@ -1,8 +0,0 @@ -module Paths_cabal_install ( - version, - ) where - -import Data.Version (Version(..)) - -version :: Version -version = Version {versionBranch = [0,9,5], versionTags = []} diff --git a/cabal-install-0.9.5_rc20101226/README b/cabal-install-0.9.5_rc20101226/README deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/README +++ /dev/null @@ -1,153 +0,0 @@ -The cabal-install package -========================= - -[Cabal home page](http://www.haskell.org/cabal/) - -The `cabal-install` package provides a command line tool called `cabal`. The -tool uses the `Cabal` library and provides a convenient user interface to the -Cabal/Hackage package build and distribution system. It can build and install -both local and remote packages, including dependencies. - - -Installation instructions for the cabal-install command line tool -================================================================= - -The `cabal-install` package requires a number of other packages, most of which -come with a standard ghc installation. It requires the `network` package, which -is sometimes packaged separately by Linux distributions, for example on -debian or ubuntu it is in "libghc6-network-dev". - -It requires a few other Haskell packages that are not always installed: - - * Cabal (version 1.8 or later) - * HTTP (version 4000 or later) - * zlib (version 0.4 or later) - -All of these are available from [Hackage](http://hackage.haskell.org). - -Note that on some Unix systems you may need to install an additional zlib -development package using your system package manager, for example on -debian or ubuntu it is in "zlib1g-dev". It is needed is because the -Haskell zlib package uses the system zlib C library and header files. - -The `cabal-install` package is now part of the Haskell Platform so you do not -usually need to install it separately. However if you are starting from a -minimal ghc installation then you need to install `cabal-install` manually. -Since it is just an ordinary Cabal package it can be built in the standard -way, but to make it a bit easier we have partly automated the process: - - -Quickstart on Unix systems --------------------------- - -As a convenience for users on Unix systems there is a `bootstrap.sh` script -which will download and install each of the dependencies in turn. - - $ ./bootstrap.sh - -It will download and install the above three dependencies. The script will -install the library packages into `$HOME/.cabal/` and the `cabal` program will -be installed into `$HOME/.cabal/bin/`. - -You then have two choices: - - * put `$HOME/.cabal/bin` on your `$PATH` - * move the `cabal` program somewhere that is on your `$PATH` - -The next thing to do is to get the latest list of packages with: - - $ cabal update - -This will also create a default config file (if it does not already echo exist) -at `$HOME/.cabal/config` - -By default cabal will install programs to `$HOME/.cabal/bin`. If you do not -want to add this directory to your `$PATH` then you can change the setting in -the config file, for example you could use: - - symlink-bindir: $HOME/bin - - -Quickstart on Windows systems ------------------------------ - -For Windows users we provide a pre-compiled [cabal.exe] program. Just download -it and put it somewhere on your `%PATH%`, for example -`C:\Program Files\Haskell\bin`. - -[cabal.exe]: http://haskell.org/cabal/release/cabal-install-latest/cabal.exe - -The next thing to do is to get the latest list of packages with - - cabal update - -This will also create a default config file (if it does not already echo exist) -at `C:\Documents and Settings\username\Application Data\cabal\config` - - -Using cabal-install -=================== - -There are two sets of commands: commands for working with a local project build -tree and ones for working with distributed released packages from hackage. - -For a list of the full set of commands and the flags for each command see - - $ cabal --help - - -Commands for developers for local build trees ---------------------------------------------- - -The commands for local project build trees are almost exactly the same as the -`runghc Setup` command line interface that many people are already familiar -with. In particular there are the commands - - cabal configure - cabal build - cabal haddock - cabal clean - cabal sdist - -The `install` command is somewhat different. It is an all-in-one operation. If -you run - - $ cabal install - -in your build tree it will configure, build and install. It takes all the flags -that `configure` takes such as `--global` and `--prefix`. - -In addition, if any dependencies are not installed it will download and install -them. If can also rebuild packages to ensure a consistent set of dependencies. - - -Commands for released hackage packages --------------------------------------- - - $ cabal update - -This command gets the latest list of packages from the hackage server. -Currently this command has to be run manually occasionally, in particular if -you want to install a newly released package. - - - $ cabal install xmonad - -This is the eponymous command. It installs one or more named packages (and all -their dependencies) from hackage. - -By default it installs the latest available version however you can optionally -specify exact versions or version ranges. For example `cabal install alex-2.2` -or `cabal install parsec < 3`. - - $ cabal upgrade xmonad - -This is a variation on the `install` command. Both mean to install the latest -version, the only difference is in the treatment of dependencies. The `install` -command tries to use existing installed versions of dependent packages while -the `upgrade` command tries to upgrade all the dependencies too. - - $ cabal list xml - -This does a search of the installed and available packages. It does a -case-insensitive substring match on the package name. diff --git a/cabal-install-0.9.5_rc20101226/Setup.hs b/cabal-install-0.9.5_rc20101226/Setup.hs deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/cabal-install-0.9.5_rc20101226/bash-completion/cabal b/cabal-install-0.9.5_rc20101226/bash-completion/cabal deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/bash-completion/cabal +++ /dev/null @@ -1,24 +0,0 @@ -# cabal command line completion -# Copyright 2007-2008 "Lennart Kolmodin" -# "Duncan Coutts" -# - -_cabal() -{ - # get the word currently being completed - local cur - cur=${COMP_WORDS[$COMP_CWORD]} - - # create a command line to run - local cmd - # copy all words the user has entered - cmd=( ${COMP_WORDS[@]} ) - - # replace the current word with --list-options - cmd[${COMP_CWORD}]="--list-options" - - # the resulting completions should be put into this array - COMPREPLY=( $( compgen -W "$( ${cmd[@]} )" -- $cur ) ) -} - -complete -F _cabal -o default cabal diff --git a/cabal-install-0.9.5_rc20101226/bootstrap.sh b/cabal-install-0.9.5_rc20101226/bootstrap.sh deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/bootstrap.sh +++ /dev/null @@ -1,241 +0,0 @@ -#!/bin/sh - -# A script to bootstrap cabal-install. - -# It works by downloading and installing the Cabal, zlib and -# HTTP packages. It then installs cabal-install itself. -# It expects to be run inside the cabal-install directory. - -# install settings, you can override these by setting environment vars -PREFIX=${PREFIX:-${HOME}/.cabal} -#VERBOSE -#EXTRA_CONFIGURE_OPTS - -# programs, you can override these by setting environment vars -GHC=${GHC:-ghc} -GHC_PKG=${GHC_PKG:-ghc-pkg} -WGET=${WGET:-wget} -CURL=${CURL:-curl} -TAR=${TAR:-tar} -GUNZIP=${GUNZIP:-gunzip} -SCOPE_OF_INSTALLATION="--user" - - -for arg in $* -do - case "${arg}" in - "--user") - SCOPE_OF_INSTALLATION=${arg} - shift;; - "--global") - SCOPE_OF_INSTALLATION=${arg} - PREFIX="/usr/local" - shift;; - *) - echo "Unknown argument or option, quitting: ${arg}" - echo "usage: bootstrap.sh [OPTION]" - echo - echo "options:" - echo " --user Install for the local user (default)" - echo " --global Install systemwide" - exit;; - esac -done - - -# Versions of the packages to install. -# The version regex says what existing installed versions are ok. -PARSEC_VER="2.1.0.1"; PARSEC_VER_REGEXP="2\." # == 2.* -NETWORK_VER="2.2.1.10"; NETWORK_VER_REGEXP="2\." # == 2.* -CABAL_VER="1.10.0.0"; CABAL_VER_REGEXP="1\.10\." # == 1.10.* -MTL_VER="1.1.1.0"; MTL_VER_REGEXP="1\.1\." # == 1.1.* -HTTP_VER="4000.0.10"; HTTP_VER_REGEXP="4000\.0" # == 4000.0.* -ZLIB_VER="0.5.2.0"; ZLIB_VER_REGEXP="0\.[45]\." # == 0.4.* || ==0.5.* -TIME_VER="1.2.0.3" TIME_VER_REGEXP="1\.[12]\." # == 0.1.* || ==0.2.* - -HACKAGE_URL="http://hackage.haskell.org/packages/archive" - -die () { - echo - echo "Error during cabal-install bootstrap:" - echo $1 >&2 - exit 2 -} - -# Check we're in the right directory: -grep "cabal-install" ./cabal-install.cabal > /dev/null 2>&1 \ - || die "The bootstrap.sh script must be run in the cabal-install directory" - -${GHC} --numeric-version > /dev/null \ - || die "${GHC} not found (or could not be run). If ghc is installed make sure it is on your PATH or set the GHC and GHC_PKG vars." -${GHC_PKG} --version > /dev/null \ - || die "${GHC_PKG} not found." -GHC_VER=`${GHC} --numeric-version` -GHC_PKG_VER=`${GHC_PKG} --version | cut -d' ' -f 5` -[ ${GHC_VER} = ${GHC_PKG_VER} ] \ - || die "Version mismatch between ${GHC} and ${GHC_PKG} If you set the GHC variable then set GHC_PKG too" - -# Cache the list of packages: -echo "Checking installed packages for ghc-${GHC_VER}..." -${GHC_PKG} list > ghc-pkg.list \ - || die "running '${GHC_PKG} list' failed" - -# Will we need to install this package, or is a suitable version installed? -need_pkg () { - PKG=$1 - VER_MATCH=$2 - if grep " ${PKG}-${VER_MATCH}" ghc-pkg.list > /dev/null 2>&1 - then - return 1; - else - return 0; - fi - #Note: we cannot use "! grep" here as Solaris 9 /bin/sh doesn't like it. -} - -info_pkg () { - PKG=$1 - VER=$2 - VER_MATCH=$3 - - if need_pkg ${PKG} ${VER_MATCH} - then - echo "${PKG}-${VER} will be downloaded and installed." - else - echo "${PKG} is already installed and the version is ok." - fi -} - -dep_pkg () { - PKG=$1 - VER_MATCH=$2 - if need_pkg ${PKG} ${VER_MATCH} - then - echo - echo "The Haskell package '${PKG}' is required but it is not installed." - echo "If you are using a ghc package provided by your operating system" - echo "then install the corresponding packages for 'parsec' and 'network'." - echo "If you built ghc from source with only the core libraries then you" - echo "should install these extra packages. You can get them from hackage." - die "The Haskell package '${PKG}' is required but it is not installed." - else - echo "${PKG} is already installed and the version is ok." - fi -} - -fetch_pkg () { - PKG=$1 - VER=$2 - - URL=${HACKAGE_URL}/${PKG}/${VER}/${PKG}-${VER}.tar.gz - if which ${CURL} > /dev/null - then - ${CURL} -C - -O ${URL} || die "Failed to download ${PKG}." - elif which ${WGET} > /dev/null - then - ${WGET} -c ${URL} || die "Failed to download ${PKG}." - else - die "Failed to find a downloader. 'wget' or 'curl' is required." - fi - [ -f "${PKG}-${VER}.tar.gz" ] \ - || die "Downloading ${URL} did not create ${PKG}-${VER}.tar.gz" -} - -unpack_pkg () { - PKG=$1 - VER=$2 - - rm -rf "${PKG}-${VER}.tar" "${PKG}-${VER}"/ - ${GUNZIP} -f "${PKG}-${VER}.tar.gz" \ - || die "Failed to gunzip ${PKG}-${VER}.tar.gz" - ${TAR} -xf "${PKG}-${VER}.tar" \ - || die "Failed to untar ${PKG}-${VER}.tar.gz" - [ -d "${PKG}-${VER}" ] \ - || die "Unpacking ${PKG}-${VER}.tar.gz did not create ${PKG}-${VER}/" -} - -install_pkg () { - PKG=$1 - - [ -x Setup ] && ./Setup clean - [ -f Setup ] && rm Setup - - ${GHC} --make Setup -o Setup \ - || die "Compiling the Setup script failed" - [ -x Setup ] || die "The Setup script does not exist or cannot be run" - - ./Setup configure ${SCOPE_OF_INSTALLATION} "--prefix=${PREFIX}" \ - --with-compiler=${GHC} --with-hc-pkg=${GHC_PKG} \ - ${EXTRA_CONFIGURE_OPTS} ${VERBOSE} \ - || die "Configuring the ${PKG} package failed" - - ./Setup build ${VERBOSE} \ - || die "Building the ${PKG} package failed" - - ./Setup install ${VERBOSE} \ - || die "Installing the ${PKG} package failed" -} - -do_pkg () { - PKG=$1 - VER=$2 - VER_MATCH=$3 - - if need_pkg ${PKG} ${VER_MATCH} - then - echo - echo "Downloading ${PKG}-${VER}..." - fetch_pkg ${PKG} ${VER} - unpack_pkg ${PKG} ${VER} - cd "${PKG}-${VER}" - install_pkg ${PKG} ${VER} - cd .. - fi -} - -# Actually do something! - -info_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP} -info_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP} -info_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP} -info_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP} -info_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP} -info_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP} -info_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP} - -do_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP} -do_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP} -do_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP} -do_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP} -do_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP} -do_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP} -do_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP} - -install_pkg "cabal-install" - -echo -echo "===========================================" -CABAL_BIN="$PREFIX/bin" -if [ -x "$CABAL_BIN/cabal" ] -then - echo "The 'cabal' program has been installed in $CABAL_BIN/" - echo "You should either add $CABAL_BIN to your PATH" - echo "or copy the cabal program to a directory that is on your PATH." - echo - echo "The first thing to do is to get the latest list of packages with:" - echo " cabal update" - echo "This will also create a default config file (if it does not already" - echo "exist) at $HOME/.cabal/config" - echo - echo "By default cabal will install programs to $HOME/.cabal/bin" - echo "If you do not want to add this directory to your PATH then you can" - echo "change the setting in the config file, for example you could use:" - echo "symlink-bindir: $HOME/bin" -else - echo "Sorry, something went wrong." - echo "The 'cabal' executable was not successfully installed into" - echo "$CABAL_BIN/" -fi -echo - -rm ghc-pkg.list diff --git a/cabal-install-0.9.5_rc20101226/cabal-install.cabal b/cabal-install-0.9.5_rc20101226/cabal-install.cabal deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/cabal-install.cabal +++ /dev/null @@ -1,117 +0,0 @@ -Name: cabal-install -Version: 0.9.5 -Synopsis: The command-line interface for Cabal and Hackage. -Description: - The \'cabal\' command-line program simplifies the process of managing - Haskell software by automating the fetching, configuration, compilation - and installation of Haskell libraries and programs. -homepage: http://www.haskell.org/cabal/ -bug-reports: http://hackage.haskell.org/trac/hackage/ -License: BSD3 -License-File: LICENSE -Author: Lemmih - Paolo Martini - Bjorn Bringert - Isaac Potoczny-Jones - Duncan Coutts -Maintainer: cabal-devel@haskell.org -Copyright: 2005 Lemmih - 2006 Paolo Martini - 2007 Bjorn Bringert - 2007 Isaac Potoczny-Jones - 2007-2010 Duncan Coutts -Category: Distribution -Build-type: Simple -Extra-Source-Files: README bash-completion/cabal bootstrap.sh -Cabal-Version: >= 1.6 - -source-repository head - type: darcs - location: http://darcs.haskell.org/cabal-install/ - -flag old-base - description: Old, monolithic base - default: False - -flag bytestring-in-base - -Executable cabal - Main-Is: Main.hs - -- We want assertion checking on even if people build with -O - -- although it is expensive, we want to catch problems early: - ghc-options: -Wall -fno-ignore-asserts - if impl(ghc >= 6.8) - ghc-options: -fwarn-tabs - Other-Modules: - Distribution.Client.BuildReports.Anonymous - Distribution.Client.BuildReports.Storage - Distribution.Client.BuildReports.Types - Distribution.Client.BuildReports.Upload - Distribution.Client.Check - Distribution.Client.Config - Distribution.Client.Configure - Distribution.Client.Dependency - Distribution.Client.Dependency.TopDown - Distribution.Client.Dependency.TopDown.Constraints - Distribution.Client.Dependency.TopDown.Types - Distribution.Client.Dependency.Types - Distribution.Client.Fetch - Distribution.Client.GZipUtils - Distribution.Client.Haddock - Distribution.Client.HttpUtils - Distribution.Client.IndexUtils - Distribution.Client.Init - Distribution.Client.Init.Heuristics - Distribution.Client.Init.Licenses - Distribution.Client.Init.Types - Distribution.Client.Install - Distribution.Client.InstallPlan - Distribution.Client.InstallSymlink - Distribution.Client.List - Distribution.Client.PackageIndex - Distribution.Client.PackageUtils - Distribution.Client.Setup - Distribution.Client.SetupWrapper - Distribution.Client.SrcDist - Distribution.Client.Tar - Distribution.Client.Types - Distribution.Client.Unpack - Distribution.Client.Update - Distribution.Client.Upload - Distribution.Client.Utils - Distribution.Client.World - Distribution.Client.Win32SelfUpgrade - Distribution.Compat.Exception - Paths_cabal_install - - build-depends: base >= 2 && < 5, - Cabal >= 1.10 && < 1.11, - filepath >= 1.0 && < 1.3, - network >= 1 && < 3, - HTTP >= 4000.0.2 && < 4001, - zlib >= 0.4 && < 0.6, - time >= 1.1 && < 1.3 - - if flag(old-base) - build-depends: base < 3 - else - build-depends: base >= 3, - process >= 1 && < 1.1, - directory >= 1 && < 1.2, - pretty >= 1 && < 1.1, - random >= 1 && < 1.1, - containers >= 0.1 && < 0.5, - array >= 0.1 && < 0.4, - old-time >= 1 && < 1.1 - - if flag(bytestring-in-base) - build-depends: base >= 2.0 && < 2.2 - else - build-depends: base < 2.0 || >= 3.0, bytestring >= 0.9 - - if os(windows) - build-depends: Win32 >= 2 && < 3 - cpp-options: -DWIN32 - else - build-depends: unix >= 1.0 && < 2.5 - extensions: CPP diff --git a/cabal-install-0.9.5_rc20101226/changelog b/cabal-install-0.9.5_rc20101226/changelog deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/changelog +++ /dev/null @@ -1,100 +0,0 @@ --*-change-log-*- - -0.8.0 Duncan Coutts Dec 2009 - * Works with ghc-6.12 - * New "cabal init" command for making initial project .cabal file - * New feature to maintain an index of haddock documentation - -0.6.4 Duncan Coutts Nov 2009 - * Improve the algorithm for selecting the base package version - * Hackage errors now reported by "cabal upload [--check]" - * Improved format of messages from "cabal check" - * Config file can now be selected by an env var - * Updated tar reading/writing code - * Improve instructions in the README and bootstrap output - * Fix bootstrap.sh on Solaris 9 - * Fix bootstrap for systems where network uses parsec 3 - * Fix building with ghc-6.6 - -0.6.2 Duncan Coutts Feb 2009 - * The upgrade command has been disabled in this release - * The configure and install commands now have consistent behaviour - * Reduce the tendancy to re-install already existing packages - * The --constraint= flag now works for the install command - * New --preference= flag for soft constraints / version preferences - * Improved bootstrap.sh script, smarter and better error checking - * New cabal info command to display detailed info on packages - * New cabal unpack command to download and untar a package - * HTTP-4000 package required, should fix bugs with http proxies - * Now works with authenticated proxies. - * On Windows can now override the proxy setting using an env var - * Fix compatability with config files generated by older versions - * Warn if the hackage package list is very old - * More helpful --help output, mention config file and examples - * Better documentation in ~/.cabal/config file - * Improved command line interface for logging and build reporting - * Minor improvements to some messages - -0.6.0 Duncan Coutts Oct 2008 - * Constraint solver can now cope with base 3 and base 4 - * Allow use of package version preferences from hackage index - * More detailed output from cabal install --dry-run -v - * Improved bootstrap.sh - -0.5.2 Duncan Coutts Aug 2008 - * Suport building haddock documentaion - * Self-reinstall now works on Windows - * Allow adding symlinks to excutables into a separate bindir - * New self-documenting config file - * New install --reinstall flag - * More helpful status messages in a couple places - * Upload failures now report full text error message from the server - * Support for local package repositories - * New build logging and reporting - * New command to upload build reports to (a compatible) server - * Allow tilde in hackage server URIs - * Internal code improvements - * Many other minor improvements and bug fixes - -0.5.1 Duncan Coutts June 2008 - * Restore minimal hugs support in dependency resolver - * Fix for disabled http proxies on Windows - * Revert to global installs on Windows by default - -0.5.0 Duncan Coutts June 2008 - * New package dependency resolver, solving diamond dep problem - * Integrate cabal-setup functionality - * Integrate cabal-upload functionality - * New cabal update and check commands - * Improved behavior for install and upgrade commands - * Full Windows support - * New command line handling - * Bash command line completion - * Allow case insensitive package names on command line - * New --dry-run flag for install, upgrade and fetch commands - * New --root-cmd flag to allow installing as root - * New --cabal-lib-version flag to select different Cabal lib versions - * Support for HTTP proxies - * Improved cabal list output - * Build other non-dependent packages even when some fail - * Report a summary of all build failures at the end - * Partial support for hugs - * Partial implementation of build reporting and logging - * More consistent logging and verbosity - * Significant internal code restructuring - -0.4 Duncan Coutts Oct 2007 - * Renamed executable from 'cabal-install' to 'cabal' - * Partial Windows compatability - * Do per-user installs by default - * cabal install now installs the package in the current directory - * Allow multiple remote servers - * Use zlib lib and internal tar code and rather than external tar - * Reorganised configuration files - * Significant code restructuring - * Cope with packages with conditional dependencies - -0.3 and older versions by Lemmih, Paolo Martini and others 2006-2007 - * Switch from smart-server, dumb-client model to the reverse - * New .tar.gz based index format - * New remote and local package archive format diff --git a/cabal-install-0.9.5_rc20101226/tests/test-cabal-install b/cabal-install-0.9.5_rc20101226/tests/test-cabal-install deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/tests/test-cabal-install +++ /dev/null @@ -1,9 +0,0 @@ -#!/bin/sh - -darcs get --partial http://darcs.haskell.org/packages/Cabal/ && \ -cd Cabal/cabal-install && \ -make && \ -sudo make install && \ -sudo cabal-install update && \ -cabal-install install --prefix=/tmp --user hnop && \ -ls -l /tmp/bin/hnop diff --git a/cabal-install-0.9.5_rc20101226/tests/test-cabal-install-user b/cabal-install-0.9.5_rc20101226/tests/test-cabal-install-user deleted file mode 100644 --- a/cabal-install-0.9.5_rc20101226/tests/test-cabal-install-user +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh - -darcs get --partial http://darcs.haskell.org/packages/Cabal/ && \ -cd Cabal/cabal-install && \ -make install-user && \ -cabal-install update && \ -cabal-install install --prefix=/tmp --user hnop && \ -ls -l /tmp/bin/hnop diff --git a/cabal/.darcs-boring b/cabal/.darcs-boring new file mode 100644 --- /dev/null +++ b/cabal/.darcs-boring @@ -0,0 +1,6 @@ +^dist(/|$) +^setup(/|$) +^GNUmakefile$ +^Makefile.local$ +^.depend(.bak)?$ +^doc/.depend(.bak)?$ diff --git a/cabal/HACKING b/cabal/HACKING new file mode 100644 --- /dev/null +++ b/cabal/HACKING @@ -0,0 +1,10 @@ +If you want to hack on Cabal, don't be intimidated! + +Read the guide to the source code: + http://hackage.haskell.org/trac/hackage/wiki/SourceGuide + +There are other resources listed on the dev wiki: + http://hackage.haskell.org/trac/hackage/ + +In particular, the open tickets and the cabal-devel mailing list +which is a good place to ask questions. diff --git a/cabal/IMPORTED-FROM b/cabal/IMPORTED-FROM new file mode 100644 --- /dev/null +++ b/cabal/IMPORTED-FROM @@ -0,0 +1,7 @@ +http://darcs.haskell.org/cabal-branches/cabal-1.12 + +Fri Jul 15 15:04:46 EEST 2011 Ian Lynagh + * Bump version number + hunk ./cabal/Cabal.cabal 2 + -Version: 1.11.2 + +Version: 1.12.0 diff --git a/cabal/LICENSE b/cabal/LICENSE new file mode 100644 --- /dev/null +++ b/cabal/LICENSE @@ -0,0 +1,33 @@ +Copyright (c) 2011, Duncan Coutts and Ian Lynagh. + +See */LICENSE for the copyright holders of the subcomponents. + +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/cabal/README b/cabal/README new file mode 100644 --- /dev/null +++ b/cabal/README @@ -0,0 +1,8 @@ +This Cabal darcs repository contains multiple packages: + + * cabal/ -- the Cabal library package + * cabal-install/ -- the cabal-install package containing the 'cabal' tool. + +See the README in each subdir for more details. + +The canonical upstream repo lives at http://darcs.haskell.org/cabal/ diff --git a/cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs @@ -0,0 +1,311 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Reporting +-- Copyright : (c) David Waern 2008 +-- License : BSD-like +-- +-- Maintainer : david.waern@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Anonymous build report data structure, printing and parsing +-- +----------------------------------------------------------------------------- +module Distribution.Client.BuildReports.Anonymous ( + BuildReport(..), + InstallOutcome(..), + Outcome(..), + + -- * Constructing and writing reports + new, + + -- * parsing and pretty printing + parse, + parseList, + show, +-- showList, + ) where + +import Distribution.Client.Types + ( ConfiguredPackage(..) ) +import qualified Distribution.Client.Types as BR + ( BuildResult, BuildFailure(..), BuildSuccess(..) + , DocsResult(..), TestsResult(..) ) +import Distribution.Client.Utils + ( mergeBy, MergeResult(..) ) +import qualified Paths_cabal_install (version) + +import Distribution.Package + ( PackageIdentifier(..), PackageName(..), Package(packageId) ) +import Distribution.PackageDescription + ( FlagName(..), FlagAssignment ) +--import Distribution.Version +-- ( Version ) +import Distribution.System + ( OS, Arch ) +import Distribution.Compiler + ( CompilerId ) +import qualified Distribution.Text as Text + ( Text(disp, parse) ) +import Distribution.ParseUtils + ( FieldDescr(..), ParseResult(..), Field(..) + , simpleField, listField, ppFields, readFields + , syntaxError, locatedErrorMsg ) +import Distribution.Simple.Utils + ( comparing ) + +import qualified Distribution.Compat.ReadP as Parse + ( ReadP, pfail, munch1, skipSpaces ) +import qualified Text.PrettyPrint.HughesPJ as Disp + ( Doc, render, char, text ) +import Text.PrettyPrint.HughesPJ + ( (<+>), (<>) ) + +import Data.List + ( unfoldr, sortBy ) +import Data.Char as Char + ( isAlpha, isAlphaNum ) + +import Prelude hiding (show) + +data BuildReport + = BuildReport { + -- | The package this build report is about + package :: PackageIdentifier, + + -- | The OS and Arch the package was built on + os :: OS, + arch :: Arch, + + -- | The Haskell compiler (and hopefully version) used + compiler :: CompilerId, + + -- | The uploading client, ie cabal-install-x.y.z + client :: PackageIdentifier, + + -- | Which configurations flags we used + flagAssignment :: FlagAssignment, + + -- | Which dependent packages we were using exactly + dependencies :: [PackageIdentifier], + + -- | Did installing work ok? + installOutcome :: InstallOutcome, + + -- Which version of the Cabal library was used to compile the Setup.hs +-- cabalVersion :: Version, + + -- Which build tools we were using (with versions) +-- tools :: [PackageIdentifier], + + -- | Configure outcome, did configure work ok? + docsOutcome :: Outcome, + + -- | Configure outcome, did configure work ok? + testsOutcome :: Outcome + } + +data InstallOutcome + = DependencyFailed PackageIdentifier + | DownloadFailed + | UnpackFailed + | SetupFailed + | ConfigureFailed + | BuildFailed + | InstallFailed + | InstallOk + deriving Eq + +data Outcome = NotTried | Failed | Ok + deriving Eq + +new :: OS -> Arch -> CompilerId -- -> Version + -> ConfiguredPackage -> BR.BuildResult + -> BuildReport +new os' arch' comp (ConfiguredPackage pkg flags deps) result = + BuildReport { + package = packageId pkg, + os = os', + arch = arch', + compiler = comp, + client = cabalInstallID, + flagAssignment = flags, + dependencies = deps, + installOutcome = convertInstallOutcome, +-- cabalVersion = undefined + docsOutcome = convertDocsOutcome, + testsOutcome = convertTestsOutcome + } + where + convertInstallOutcome = case result of + Left (BR.DependentFailed p) -> DependencyFailed p + Left (BR.DownloadFailed _) -> DownloadFailed + Left (BR.UnpackFailed _) -> UnpackFailed + Left (BR.ConfigureFailed _) -> ConfigureFailed + Left (BR.BuildFailed _) -> BuildFailed + Left (BR.InstallFailed _) -> InstallFailed + Right (BR.BuildOk _ _) -> InstallOk + convertDocsOutcome = case result of + Left _ -> NotTried + Right (BR.BuildOk BR.DocsNotTried _) -> NotTried + Right (BR.BuildOk BR.DocsFailed _) -> Failed + Right (BR.BuildOk BR.DocsOk _) -> Ok + convertTestsOutcome = case result of + Left _ -> NotTried + Right (BR.BuildOk _ BR.TestsNotTried) -> NotTried + Right (BR.BuildOk _ BR.TestsFailed) -> Failed + Right (BR.BuildOk _ BR.TestsOk) -> Ok + +cabalInstallID :: PackageIdentifier +cabalInstallID = + PackageIdentifier (PackageName "cabal-install") Paths_cabal_install.version + +-- ------------------------------------------------------------ +-- * External format +-- ------------------------------------------------------------ + +initialBuildReport :: BuildReport +initialBuildReport = BuildReport { + package = requiredField "package", + os = requiredField "os", + arch = requiredField "arch", + compiler = requiredField "compiler", + client = requiredField "client", + flagAssignment = [], + dependencies = [], + installOutcome = requiredField "install-outcome", +-- cabalVersion = Nothing, +-- tools = [], + docsOutcome = NotTried, + testsOutcome = NotTried + } + where + requiredField fname = error ("required field: " ++ fname) + +-- ----------------------------------------------------------------------------- +-- Parsing + +parse :: String -> Either String BuildReport +parse s = case parseFields s of + ParseFailed perror -> Left msg where (_, msg) = locatedErrorMsg perror + ParseOk _ report -> Right report + +--FIXME: this does not allow for optional or repeated fields +parseFields :: String -> ParseResult BuildReport +parseFields input = do + fields <- mapM extractField =<< readFields input + let merged = mergeBy (\desc (_,name,_) -> compare (fieldName desc) name) + sortedFieldDescrs + (sortBy (comparing (\(_,name,_) -> name)) fields) + checkMerged initialBuildReport merged + + where + extractField :: Field -> ParseResult (Int, String, String) + extractField (F line name value) = return (line, name, value) + extractField (Section line _ _ _) = syntaxError line "Unrecognized stanza" + extractField (IfBlock line _ _ _) = syntaxError line "Unrecognized stanza" + + checkMerged report [] = return report + checkMerged report (merged:remaining) = case merged of + InBoth fieldDescr (line, _name, value) -> do + report' <- fieldSet fieldDescr line value report + checkMerged report' remaining + OnlyInRight (line, name, _) -> + syntaxError line ("Unrecognized field " ++ name) + OnlyInLeft fieldDescr -> + fail ("Missing field " ++ fieldName fieldDescr) + +parseList :: String -> [BuildReport] +parseList str = + [ report | Right report <- map parse (split str) ] + + where + split :: String -> [String] + split = filter (not . null) . unfoldr chunk . lines + chunk [] = Nothing + chunk ls = case break null ls of + (r, rs) -> Just (unlines r, dropWhile null rs) + +-- ----------------------------------------------------------------------------- +-- Pretty-printing + +show :: BuildReport -> String +show = Disp.render . ppFields fieldDescrs + +-- ----------------------------------------------------------------------------- +-- Description of the fields, for parsing/printing + +fieldDescrs :: [FieldDescr BuildReport] +fieldDescrs = + [ simpleField "package" Text.disp Text.parse + package (\v r -> r { package = v }) + , simpleField "os" Text.disp Text.parse + os (\v r -> r { os = v }) + , simpleField "arch" Text.disp Text.parse + arch (\v r -> r { arch = v }) + , simpleField "compiler" Text.disp Text.parse + compiler (\v r -> r { compiler = v }) + , simpleField "client" Text.disp Text.parse + client (\v r -> r { client = v }) + , listField "flags" dispFlag parseFlag + flagAssignment (\v r -> r { flagAssignment = v }) + , listField "dependencies" Text.disp Text.parse + dependencies (\v r -> r { dependencies = v }) + , simpleField "install-outcome" Text.disp Text.parse + installOutcome (\v r -> r { installOutcome = v }) + , simpleField "docs-outcome" Text.disp Text.parse + docsOutcome (\v r -> r { docsOutcome = v }) + , simpleField "tests-outcome" Text.disp Text.parse + testsOutcome (\v r -> r { testsOutcome = v }) + ] + +sortedFieldDescrs :: [FieldDescr BuildReport] +sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs + +dispFlag :: (FlagName, Bool) -> Disp.Doc +dispFlag (FlagName name, True) = Disp.text name +dispFlag (FlagName name, False) = Disp.char '-' <> Disp.text name + +parseFlag :: Parse.ReadP r (FlagName, Bool) +parseFlag = do + name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') + case name of + ('-':flag) -> return (FlagName flag, False) + flag -> return (FlagName flag, True) + +instance Text.Text InstallOutcome where + disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid + disp DownloadFailed = Disp.text "DownloadFailed" + disp UnpackFailed = Disp.text "UnpackFailed" + disp SetupFailed = Disp.text "SetupFailed" + disp ConfigureFailed = Disp.text "ConfigureFailed" + disp BuildFailed = Disp.text "BuildFailed" + disp InstallFailed = Disp.text "InstallFailed" + disp InstallOk = Disp.text "InstallOk" + + parse = do + name <- Parse.munch1 Char.isAlphaNum + case name of + "DependencyFailed" -> do Parse.skipSpaces + pkgid <- Text.parse + return (DependencyFailed pkgid) + "DownloadFailed" -> return DownloadFailed + "UnpackFailed" -> return UnpackFailed + "SetupFailed" -> return SetupFailed + "ConfigureFailed" -> return ConfigureFailed + "BuildFailed" -> return BuildFailed + "InstallFailed" -> return InstallFailed + "InstallOk" -> return InstallOk + _ -> Parse.pfail + +instance Text.Text Outcome where + disp NotTried = Disp.text "NotTried" + disp Failed = Disp.text "Failed" + disp Ok = Disp.text "Ok" + parse = do + name <- Parse.munch1 Char.isAlpha + case name of + "NotTried" -> return NotTried + "Failed" -> return Failed + "Ok" -> return Ok + _ -> Parse.pfail diff --git a/cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs @@ -0,0 +1,127 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Reporting +-- Copyright : (c) David Waern 2008 +-- License : BSD-like +-- +-- Maintainer : david.waern@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Anonymous build report data structure, printing and parsing +-- +----------------------------------------------------------------------------- +module Distribution.Client.BuildReports.Storage ( + + -- * Storing and retrieving build reports + storeAnonymous, + storeLocal, +-- retrieve, + + -- * 'InstallPlan' support + fromInstallPlan, + ) where + +import qualified Distribution.Client.BuildReports.Anonymous as BuildReport +import Distribution.Client.BuildReports.Anonymous (BuildReport) + +import Distribution.Client.Types +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan + ( InstallPlan ) + +import Distribution.Simple.InstallDirs + ( PathTemplate, fromPathTemplate + , initialPathTemplateEnv, substPathTemplate ) +import Distribution.System + ( Platform(Platform) ) +import Distribution.Compiler + ( CompilerId ) +import Distribution.Simple.Utils + ( comparing, equating ) + +import Data.List + ( groupBy, sortBy ) +import Data.Maybe + ( catMaybes ) +import System.FilePath + ( (), takeDirectory ) +import System.Directory + ( createDirectoryIfMissing ) + +storeAnonymous :: [(BuildReport, Repo)] -> IO () +storeAnonymous reports = sequence_ + [ appendFile file (concatMap format reports') + | (repo, reports') <- separate reports + , let file = repoLocalDir repo "build-reports.log" ] + --TODO: make this concurrency safe, either lock the report file or make sure + -- the writes for each report are atomic (under 4k and flush at boundaries) + + where + format r = '\n' : BuildReport.show r ++ "\n" + separate :: [(BuildReport, Repo)] + -> [(Repo, [BuildReport])] + separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ])) + . map concat + . groupBy (equating (repoName . head)) + . sortBy (comparing (repoName . head)) + . groupBy (equating repoName) + . onlyRemote + repoName (_,_,rrepo) = remoteRepoName rrepo + + onlyRemote :: [(BuildReport, Repo)] -> [(BuildReport, Repo, RemoteRepo)] + onlyRemote rs = + [ (report, repo, remoteRepo) + | (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ] + +storeLocal :: [PathTemplate] -> [(BuildReport, Repo)] -> IO () +storeLocal templates reports = sequence_ + [ do createDirectoryIfMissing True (takeDirectory file) + appendFile file output + --TODO: make this concurrency safe, either lock the report file or make + -- sure the writes for each report are atomic + | (file, reports') <- groupByFileName + [ (reportFileName template report, report) + | template <- templates + , (report, _repo) <- reports ] + , let output = concatMap format reports' + ] + where + format r = '\n' : BuildReport.show r ++ "\n" + + reportFileName template report = + fromPathTemplate (substPathTemplate env template) + where env = initialPathTemplateEnv + (BuildReport.package report) + (BuildReport.compiler report) + + groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp)) + . groupBy (equating fst) + . sortBy (comparing fst) + +-- ------------------------------------------------------------ +-- * InstallPlan support +-- ------------------------------------------------------------ + +fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)] +fromInstallPlan plan = catMaybes + . map (fromPlanPackage platform comp) + . InstallPlan.toList + $ plan + where platform = InstallPlan.planPlatform plan + comp = InstallPlan.planCompiler plan + +fromPlanPackage :: Platform -> CompilerId + -> InstallPlan.PlanPackage + -> Maybe (BuildReport, Repo) +fromPlanPackage (Platform arch os) comp planPackage = case planPackage of + + InstallPlan.Installed pkg@(ConfiguredPackage (SourcePackage { + packageSource = RepoTarballPackage repo _ _ }) _ _) result + -> Just $ (BuildReport.new os arch comp pkg (Right result), repo) + + InstallPlan.Failed pkg@(ConfiguredPackage (SourcePackage { + packageSource = RepoTarballPackage repo _ _ }) _ _) result + -> Just $ (BuildReport.new os arch comp pkg (Left result), repo) + + _ -> Nothing diff --git a/cabal/cabal-install/Distribution/Client/BuildReports/Types.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Types.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/BuildReports/Types.hs @@ -0,0 +1,44 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.BuildReports.Types +-- Copyright : (c) Duncan Coutts 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Types related to build reporting +-- +----------------------------------------------------------------------------- +module Distribution.Client.BuildReports.Types ( + ReportLevel(..), + ) where + +import qualified Distribution.Text as Text + ( Text(..) ) + +import qualified Distribution.Compat.ReadP as Parse + ( pfail, munch1 ) +import qualified Text.PrettyPrint.HughesPJ as Disp + ( text ) + +import Data.Char as Char + ( isAlpha, toLower ) + +data ReportLevel = NoReports | AnonymousReports | DetailedReports + deriving (Eq, Ord, Show) + +instance Text.Text ReportLevel where + disp NoReports = Disp.text "none" + disp AnonymousReports = Disp.text "anonymous" + disp DetailedReports = Disp.text "detailed" + parse = do + name <- Parse.munch1 Char.isAlpha + case lowercase name of + "none" -> return NoReports + "anonymous" -> return AnonymousReports + "detailed" -> return DetailedReports + _ -> Parse.pfail + +lowercase :: String -> String +lowercase = map Char.toLower diff --git a/cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs b/cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE PatternGuards #-} +-- This is a quick hack for uploading build reports to Hackage. + +module Distribution.Client.BuildReports.Upload + ( BuildLog + , BuildReportId + , uploadReports + , postBuildReport + , putBuildLog + ) where + +import Network.Browser + ( BrowserAction, request, setAllowRedirects ) +import Network.HTTP + ( Header(..), HeaderName(..) + , Request(..), RequestMethod(..), Response(..) ) +import Network.TCP (HandleStream) +import Network.URI (URI, uriPath, parseRelativeReference, relativeTo) + +import Control.Monad + ( forM_ ) +import System.FilePath.Posix + ( () ) +import qualified Distribution.Client.BuildReports.Anonymous as BuildReport +import Distribution.Client.BuildReports.Anonymous (BuildReport) +import Distribution.Text (display) + +type BuildReportId = URI +type BuildLog = String + +uploadReports :: URI -> [(BuildReport, Maybe BuildLog)] + -> BrowserAction (HandleStream String) () + -> BrowserAction (HandleStream BuildLog) () +uploadReports uri reports auth = do + auth + forM_ reports $ \(report, mbBuildLog) -> do + buildId <- postBuildReport uri report + case mbBuildLog of + Just buildLog -> putBuildLog buildId buildLog + Nothing -> return () + +postBuildReport :: URI -> BuildReport + -> BrowserAction (HandleStream BuildLog) BuildReportId +postBuildReport uri buildReport = do + setAllowRedirects False + (_, response) <- request Request { + rqURI = uri { uriPath = "/package" display (BuildReport.package buildReport) "reports" }, + rqMethod = POST, + rqHeaders = [Header HdrContentType ("text/plain"), + Header HdrContentLength (show (length body)), + Header HdrAccept ("text/plain")], + rqBody = body + } + case rspCode response of + (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location + relativeTo rel uri + | Header HdrLocation location <- rspHeaders response ] + -> return $ buildId + _ -> error "Unrecognised response from server." + where body = BuildReport.show buildReport + +putBuildLog :: BuildReportId -> BuildLog + -> BrowserAction (HandleStream BuildLog) () +putBuildLog reportId buildLog = do + --FIXME: do something if the request fails + (_, response) <- request Request { + rqURI = reportId{uriPath = uriPath reportId "log"}, + rqMethod = PUT, + rqHeaders = [Header HdrContentType ("text/plain"), + Header HdrContentLength (show (length buildLog)), + Header HdrAccept ("text/plain")], + rqBody = buildLog + } + return () diff --git a/cabal/cabal-install/Distribution/Client/Check.hs b/cabal/cabal-install/Distribution/Client/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Check.hs @@ -0,0 +1,85 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Check +-- Copyright : (c) Lennart Kolmodin 2008 +-- License : BSD-like +-- +-- Maintainer : kolmodin@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Check a package for common mistakes +-- +----------------------------------------------------------------------------- +module Distribution.Client.Check ( + check + ) where + +import Control.Monad ( when, unless ) + +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.PackageDescription.Check +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Simple.Utils + ( defaultPackageDesc, toUTF8, wrapText ) + +check :: Verbosity -> IO Bool +check verbosity = do + pdfile <- defaultPackageDesc verbosity + ppd <- readPackageDescription verbosity pdfile + -- flatten the generic package description into a regular package + -- description + -- TODO: this may give more warnings than it should give; + -- consider two branches of a condition, one saying + -- ghc-options: -Wall + -- and the other + -- ghc-options: -Werror + -- joined into + -- ghc-options: -Wall -Werror + -- checkPackages will yield a warning on the last line, but it + -- would not on each individual branch. + -- Hovever, this is the same way hackage does it, so we will yield + -- the exact same errors as it will. + let pkg_desc = flattenPackageDescription ppd + ioChecks <- checkPackageFiles pkg_desc "." + let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc) + buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ] + buildWarning = [ x | x@PackageBuildWarning {} <- packageChecks ] + distSuspicious = [ x | x@PackageDistSuspicious {} <- packageChecks ] + distInexusable = [ x | x@PackageDistInexcusable {} <- packageChecks ] + + unless (null buildImpossible) $ do + putStrLn "The package will not build sanely due to these errors:" + printCheckMessages buildImpossible + + unless (null buildWarning) $ do + putStrLn "The following warnings are likely affect your build negatively:" + printCheckMessages buildWarning + + unless (null distSuspicious) $ do + putStrLn "These warnings may cause trouble when distributing the package:" + printCheckMessages distSuspicious + + unless (null distInexusable) $ do + putStrLn "The following errors will cause portability problems on other environments:" + printCheckMessages distInexusable + + let isDistError (PackageDistSuspicious {}) = False + isDistError _ = True + errors = filter isDistError packageChecks + + unless (null errors) $ do + putStrLn "Hackage would reject this package." + + when (null packageChecks) $ do + putStrLn "No errors or warnings could be found in the package." + + return (null packageChecks) + + where + printCheckMessages = mapM_ (putStrLn . format . explanation) + format = toUTF8 . wrapText . ("* "++) diff --git a/cabal/cabal-install/Distribution/Client/Config.hs b/cabal/cabal-install/Distribution/Client/Config.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Config.hs @@ -0,0 +1,536 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Config +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Utilities for handling saved state such as known packages, known servers and downloaded packages. +----------------------------------------------------------------------------- +module Distribution.Client.Config ( + SavedConfig(..), + loadConfig, + + showConfig, + showConfigWithComments, + parseConfig, + + defaultCabalDir, + defaultConfigFile, + defaultCacheDir, + defaultLogsDir, + ) where + + +import Distribution.Client.Types + ( RemoteRepo(..), Username(..), Password(..) ) +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +import Distribution.Client.Setup + ( GlobalFlags(..), globalCommand + , ConfigExFlags(..), configureExOptions, defaultConfigExFlags + , InstallFlags(..), installOptions, defaultInstallFlags + , UploadFlags(..), uploadCommand + , ReportFlags(..), reportCommand + , showRepo, parseRepo ) + +import Distribution.Simple.Setup + ( ConfigFlags(..), configureOptions, defaultConfigFlags + , installDirsOptions + , Flag, toFlag, flagToMaybe, fromFlagOrDefault ) +import Distribution.Simple.InstallDirs + ( InstallDirs(..), defaultInstallDirs + , PathTemplate, toPathTemplate ) +import Distribution.ParseUtils + ( FieldDescr(..), liftField + , ParseResult(..), locatedErrorMsg, showPWarning + , readFields, warning, lineNo + , simpleField, listField, parseFilePathQ, parseTokenQ ) +import qualified Distribution.ParseUtils as ParseUtils + ( Field(..) ) +import qualified Distribution.Text as Text + ( Text(..) ) +import Distribution.Simple.Command + ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..) + , viewAsFieldDescr ) +import Distribution.Simple.Program + ( defaultProgramConfiguration ) +import Distribution.Simple.Utils + ( notice, warn, lowercase ) +import Distribution.Compiler + ( CompilerFlavor(..), defaultCompilerFlavor ) +import Distribution.Verbosity + ( Verbosity, normal ) + +import Data.List + ( partition, find ) +import Data.Maybe + ( fromMaybe ) +import Data.Monoid + ( Monoid(..) ) +import Control.Monad + ( when, foldM, liftM ) +import qualified Data.Map as Map +import qualified Distribution.Compat.ReadP as Parse + ( option ) +import qualified Text.PrettyPrint.HughesPJ as Disp + ( Doc, render, text, colon, vcat, empty, isEmpty, nest ) +import Text.PrettyPrint.HughesPJ + ( (<>), (<+>), ($$), ($+$) ) +import System.Directory + ( createDirectoryIfMissing, getAppUserDataDirectory ) +import Network.URI + ( URI(..), URIAuth(..) ) +import System.FilePath + ( (), takeDirectory ) +import System.Environment + ( getEnvironment ) +import System.IO.Error + ( isDoesNotExistError ) + +-- +-- * Configuration saved in the config file +-- + +data SavedConfig = SavedConfig { + savedGlobalFlags :: GlobalFlags, + savedInstallFlags :: InstallFlags, + savedConfigureFlags :: ConfigFlags, + savedConfigureExFlags :: ConfigExFlags, + savedUserInstallDirs :: InstallDirs (Flag PathTemplate), + savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate), + savedUploadFlags :: UploadFlags, + savedReportFlags :: ReportFlags + } + +instance Monoid SavedConfig where + mempty = SavedConfig { + savedGlobalFlags = mempty, + savedInstallFlags = mempty, + savedConfigureFlags = mempty, + savedConfigureExFlags = mempty, + savedUserInstallDirs = mempty, + savedGlobalInstallDirs = mempty, + savedUploadFlags = mempty, + savedReportFlags = mempty + } + mappend a b = SavedConfig { + savedGlobalFlags = combine savedGlobalFlags, + savedInstallFlags = combine savedInstallFlags, + savedConfigureFlags = combine savedConfigureFlags, + savedConfigureExFlags = combine savedConfigureExFlags, + savedUserInstallDirs = combine savedUserInstallDirs, + savedGlobalInstallDirs = combine savedGlobalInstallDirs, + savedUploadFlags = combine savedUploadFlags, + savedReportFlags = combine savedReportFlags + } + where combine field = field a `mappend` field b + +updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig +updateInstallDirs userInstallFlag + savedConfig@SavedConfig { + savedConfigureFlags = configureFlags, + savedUserInstallDirs = userInstallDirs, + savedGlobalInstallDirs = globalInstallDirs + } = + savedConfig { + savedConfigureFlags = configureFlags { + configInstallDirs = installDirs + } + } + where + installDirs | userInstall = userInstallDirs + | otherwise = globalInstallDirs + userInstall = fromFlagOrDefault defaultUserInstall $ + configUserInstall configureFlags `mappend` userInstallFlag + +-- +-- * Default config +-- + +-- | These are the absolute basic defaults. The fields that must be +-- initialised. When we load the config from the file we layer the loaded +-- values over these ones, so any missing fields in the file take their values +-- from here. +-- +baseSavedConfig :: IO SavedConfig +baseSavedConfig = do + userPrefix <- defaultCabalDir + logsDir <- defaultLogsDir + worldFile <- defaultWorldFile + return mempty { + savedConfigureFlags = mempty { + configHcFlavor = toFlag defaultCompiler, + configUserInstall = toFlag defaultUserInstall, + configVerbosity = toFlag normal + }, + savedUserInstallDirs = mempty { + prefix = toFlag (toPathTemplate userPrefix) + }, + savedGlobalFlags = mempty { + globalLogsDir = toFlag logsDir, + globalWorldFile = toFlag worldFile + } + } + +-- | This is the initial configuration that we write out to to the config file +-- if the file does not exist (or the config we use if the file cannot be read +-- for some other reason). When the config gets loaded it gets layered on top +-- of 'baseSavedConfig' so we do not need to include it into the initial +-- values we save into the config file. +-- +initialSavedConfig :: IO SavedConfig +initialSavedConfig = do + cacheDir <- defaultCacheDir + logsDir <- defaultLogsDir + worldFile <- defaultWorldFile + return mempty { + savedGlobalFlags = mempty { + globalCacheDir = toFlag cacheDir, + globalRemoteRepos = [defaultRemoteRepo], + globalWorldFile = toFlag worldFile + }, + savedInstallFlags = mempty { + installSummaryFile = [toPathTemplate (logsDir "build.log")], + installBuildReports= toFlag AnonymousReports + } + } + +--TODO: misleading, there's no way to override this default +-- either make it possible or rename to simply getCabalDir. +defaultCabalDir :: IO FilePath +defaultCabalDir = getAppUserDataDirectory "cabal" + +defaultConfigFile :: IO FilePath +defaultConfigFile = do + dir <- defaultCabalDir + return $ dir "config" + +defaultCacheDir :: IO FilePath +defaultCacheDir = do + dir <- defaultCabalDir + return $ dir "packages" + +defaultLogsDir :: IO FilePath +defaultLogsDir = do + dir <- defaultCabalDir + return $ dir "logs" + +-- | Default position of the world file +defaultWorldFile :: IO FilePath +defaultWorldFile = do + dir <- defaultCabalDir + return $ dir "world" + +defaultCompiler :: CompilerFlavor +defaultCompiler = fromMaybe GHC defaultCompilerFlavor + +defaultUserInstall :: Bool +defaultUserInstall = True +-- We do per-user installs by default on all platforms. We used to default to +-- global installs on Windows but that no longer works on Windows Vista or 7. + +defaultRemoteRepo :: RemoteRepo +defaultRemoteRepo = RemoteRepo name uri + where + name = "hackage.haskell.org" + uri = URI "http:" (Just (URIAuth "" name "")) "/packages/archive" "" "" + +-- +-- * Config file reading +-- + +loadConfig :: Verbosity -> Flag FilePath -> Flag Bool -> IO SavedConfig +loadConfig verbosity configFileFlag userInstallFlag = addBaseConf $ do + let sources = [ + ("commandline option", return . flagToMaybe $ configFileFlag), + ("env var CABAL_CONFIG", lookup "CABAL_CONFIG" `liftM` getEnvironment), + ("default config file", Just `liftM` defaultConfigFile) ] + + getSource [] = error "no config file path candidate found." + getSource ((msg,action): xs) = + action >>= maybe (getSource xs) (return . (,) msg) + + (source, configFile) <- getSource sources + minp <- readConfigFile mempty configFile + case minp of + Nothing -> do + notice verbosity $ "Config file path source is " ++ source ++ "." + notice verbosity $ "Config file " ++ configFile ++ " not found." + notice verbosity $ "Writing default configuration to " ++ configFile + commentConf <- commentSavedConfig + initialConf <- initialSavedConfig + writeConfigFile configFile commentConf initialConf + return initialConf + Just (ParseOk ws conf) -> do + when (not $ null ws) $ warn verbosity $ + unlines (map (showPWarning configFile) ws) + return conf + Just (ParseFailed err) -> do + let (line, msg) = locatedErrorMsg err + warn verbosity $ + "Error parsing config file " ++ configFile + ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg + warn verbosity $ "Using default configuration." + initialSavedConfig + + where + addBaseConf body = do + base <- baseSavedConfig + extra <- body + return (updateInstallDirs userInstallFlag (base `mappend` extra)) + +readConfigFile :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig)) +readConfigFile initial file = handleNotExists $ + fmap (Just . parseConfig initial) (readFile file) + + where + handleNotExists action = catch action $ \ioe -> + if isDoesNotExistError ioe + then return Nothing + else ioError ioe + +writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO () +writeConfigFile file comments vals = do + createDirectoryIfMissing True (takeDirectory file) + writeFile file $ explanation ++ showConfigWithComments comments vals ++ "\n" + where + explanation = unlines + ["-- This is the configuration file for the 'cabal' command line tool." + ,"" + ,"-- The available configuration options are listed below." + ,"-- Some of them have default values listed." + ,"" + ,"-- Lines (like this one) beginning with '--' are comments." + ,"-- Be careful with spaces and indentation because they are" + ,"-- used to indicate layout for nested sections." + ,"","" + ] + +-- | These are the default values that get used in Cabal if a no value is +-- given. We use these here to include in comments when we write out the +-- initial config file so that the user can see what default value they are +-- overriding. +-- +commentSavedConfig :: IO SavedConfig +commentSavedConfig = do + userInstallDirs <- defaultInstallDirs defaultCompiler True True + globalInstallDirs <- defaultInstallDirs defaultCompiler False True + return SavedConfig { + savedGlobalFlags = commandDefaultFlags globalCommand, + savedInstallFlags = defaultInstallFlags, + savedConfigureExFlags = defaultConfigExFlags, + savedConfigureFlags = (defaultConfigFlags defaultProgramConfiguration) { + configUserInstall = toFlag defaultUserInstall + }, + savedUserInstallDirs = fmap toFlag userInstallDirs, + savedGlobalInstallDirs = fmap toFlag globalInstallDirs, + savedUploadFlags = commandDefaultFlags uploadCommand, + savedReportFlags = commandDefaultFlags reportCommand + } + +-- | All config file fields. +-- +configFieldDescriptions :: [FieldDescr SavedConfig] +configFieldDescriptions = + + toSavedConfig liftGlobalFlag + (commandOptions globalCommand ParseArgs) + ["version", "numeric-version", "config-file"] [] + + ++ toSavedConfig liftConfigFlag + (configureOptions ParseArgs) + (["builddir", "configure-option"] ++ map fieldName installDirsFields) + + --FIXME: this is only here because viewAsFieldDescr gives us a parser + -- that only recognises 'ghc' etc, the case-sensitive flag names, not + -- what the normal case-insensitive parser gives us. + [simpleField "compiler" + (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse) + configHcFlavor (\v flags -> flags { configHcFlavor = v }) + ] + + ++ toSavedConfig liftConfigExFlag + (configureExOptions ParseArgs) + [] [] + + ++ toSavedConfig liftInstallFlag + (installOptions ParseArgs) + ["dry-run", "reinstall", "only"] [] + + ++ toSavedConfig liftUploadFlag + (commandOptions uploadCommand ParseArgs) + ["verbose", "check"] [] + + ++ toSavedConfig liftReportFlag + (commandOptions reportCommand ParseArgs) + ["verbose", "username", "password"] [] + --FIXME: this is a hack, hiding the username and password. + -- But otherwise it masks the upload ones. Either need to + -- share the options or make then distinct. In any case + -- they should probably be per-server. + + where + toSavedConfig lift options exclusions replacements = + [ lift (fromMaybe field replacement) + | opt <- options + , let field = viewAsFieldDescr opt + name = fieldName field + replacement = find ((== name) . fieldName) replacements + , name `notElem` exclusions ] + optional = Parse.option mempty . fmap toFlag + +-- TODO: next step, make the deprecated fields elicit a warning. +-- +deprecatedFieldDescriptions :: [FieldDescr SavedConfig] +deprecatedFieldDescriptions = + [ liftGlobalFlag $ + listField "repos" + (Disp.text . showRepo) parseRepo + globalRemoteRepos (\rs cfg -> cfg { globalRemoteRepos = rs }) + , liftGlobalFlag $ + simpleField "cachedir" + (Disp.text . fromFlagOrDefault "") (optional parseFilePathQ) + globalCacheDir (\d cfg -> cfg { globalCacheDir = d }) + , liftUploadFlag $ + simpleField "hackage-username" + (Disp.text . fromFlagOrDefault "" . fmap unUsername) + (optional (fmap Username parseTokenQ)) + uploadUsername (\d cfg -> cfg { uploadUsername = d }) + , liftUploadFlag $ + simpleField "hackage-password" + (Disp.text . fromFlagOrDefault "" . fmap unPassword) + (optional (fmap Password parseTokenQ)) + uploadPassword (\d cfg -> cfg { uploadPassword = d }) + ] + ++ map (modifyFieldName ("user-"++) . liftUserInstallDirs) installDirsFields + ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) installDirsFields + where + optional = Parse.option mempty . fmap toFlag + modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a + modifyFieldName f d = d { fieldName = f (fieldName d) } + +liftUserInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) + -> FieldDescr SavedConfig +liftUserInstallDirs = liftField + savedUserInstallDirs (\flags conf -> conf { savedUserInstallDirs = flags }) + +liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate)) + -> FieldDescr SavedConfig +liftGlobalInstallDirs = liftField + savedGlobalInstallDirs (\flags conf -> conf { savedGlobalInstallDirs = flags }) + +liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig +liftGlobalFlag = liftField + savedGlobalFlags (\flags conf -> conf { savedGlobalFlags = flags }) + +liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig +liftConfigFlag = liftField + savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags }) + +liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig +liftConfigExFlag = liftField + savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = flags }) + +liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig +liftInstallFlag = liftField + savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags }) + +liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig +liftUploadFlag = liftField + savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags }) + +liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig +liftReportFlag = liftField + savedReportFlags (\flags conf -> conf { savedReportFlags = flags }) + +parseConfig :: SavedConfig -> String -> ParseResult SavedConfig +parseConfig initial = \str -> do + fields <- readFields str + let (knownSections, others) = partition isKnownSection fields + config <- parse others + let user0 = savedUserInstallDirs config + global0 = savedGlobalInstallDirs config + (user, global) <- foldM parseSections (user0, global0) knownSections + return config { + savedUserInstallDirs = user, + savedGlobalInstallDirs = global + } + + where + isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True + isKnownSection _ = False + + parse = parseFields (configFieldDescriptions + ++ deprecatedFieldDescriptions) initial + + parseSections accum@(u,g) (ParseUtils.Section _ "install-dirs" name fs) + | name' == "user" = do u' <- parseFields installDirsFields u fs + return (u', g) + | name' == "global" = do g' <- parseFields installDirsFields g fs + return (u, g') + | otherwise = do + warning "The install-paths section should be for 'user' or 'global'" + return accum + where name' = lowercase name + parseSections accum f = do + warning $ "Unrecognized stanza on line " ++ show (lineNo f) + return accum + +showConfig :: SavedConfig -> String +showConfig = showConfigWithComments mempty + +showConfigWithComments :: SavedConfig -> SavedConfig -> String +showConfigWithComments comment vals = Disp.render $ + ppFields configFieldDescriptions comment vals + $+$ Disp.text "" + $+$ installDirsSection "user" savedUserInstallDirs + $+$ Disp.text "" + $+$ installDirsSection "global" savedGlobalInstallDirs + where + installDirsSection name field = + ppSection "install-dirs" name installDirsFields + (field comment) (field vals) + +------------------------ +-- * Parsing utils +-- + +--FIXME: replace this with something better in Cabal-1.5 +parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a +parseFields fields initial = foldM setField initial + where + fieldMap = Map.fromList + [ (name, f) | f@(FieldDescr name _ _) <- fields ] + setField accum (ParseUtils.F line name value) = case Map.lookup name fieldMap of + Just (FieldDescr _ _ set) -> set line value accum + Nothing -> do + warning $ "Unrecognized field " ++ name ++ " on line " ++ show line + return accum + setField accum f = do + warning $ "Unrecognized stanza on line " ++ show (lineNo f) + return accum + +-- | This is a customised version of the function from Cabal that also prints +-- default values for empty fields as comments. +-- +ppFields :: [FieldDescr a] -> a -> a -> Disp.Doc +ppFields fields def cur = Disp.vcat [ ppField name (getter def) (getter cur) + | FieldDescr name getter _ <- fields] + +ppField :: String -> Disp.Doc -> Disp.Doc -> Disp.Doc +ppField name def cur + | Disp.isEmpty cur = Disp.text "--" <+> Disp.text name <> Disp.colon <+> def + | otherwise = Disp.text name <> Disp.colon <+> cur + +ppSection :: String -> String -> [FieldDescr a] -> a -> a -> Disp.Doc +ppSection name arg fields def cur = + Disp.text name <+> Disp.text arg + $$ Disp.nest 2 (ppFields fields def cur) + +installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] +installDirsFields = map viewAsFieldDescr installDirsOptions + diff --git a/cabal/cabal-install/Distribution/Client/Configure.hs b/cabal/cabal-install/Distribution/Client/Configure.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Configure.hs @@ -0,0 +1,194 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Configure +-- Copyright : (c) David Himmelstrup 2005, +-- Duncan Coutts 2005 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- High level interface to configuring a package. +----------------------------------------------------------------------------- +module Distribution.Client.Configure ( + configure, + ) where + +import Distribution.Client.Dependency +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.IndexUtils as IndexUtils + ( getSourcePackages, getInstalledPackages ) +import Distribution.Client.Setup + ( ConfigExFlags(..), configureCommand, filterConfigureFlags ) +import Distribution.Client.Types as Source +import Distribution.Client.SetupWrapper + ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) +import Distribution.Client.Targets + ( userToPackageConstraint ) + +import Distribution.Simple.Compiler + ( CompilerId(..), Compiler(compilerId) + , PackageDB(..), PackageDBStack ) +import Distribution.Simple.Program (ProgramConfiguration ) +import Distribution.Simple.Setup + ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault ) +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Simple.Utils + ( defaultPackageDesc ) +import Distribution.Package + ( Package(..), packageName, Dependency(..), thisPackageVersion ) +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Version + ( anyVersion, thisVersion ) +import Distribution.Simple.Utils as Utils + ( notice, info, debug, die ) +import Distribution.System + ( Platform, buildPlatform ) +import Distribution.Verbosity as Verbosity + ( Verbosity ) + +import Data.Monoid (Monoid(..)) + +-- | Configure the package found in the local directory +configure :: Verbosity + -> PackageDBStack + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> ConfigFlags + -> ConfigExFlags + -> [String] + -> IO () +configure verbosity packageDBs repos comp conf + configFlags configExFlags extraArgs = do + + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf + sourcePkgDb <- getSourcePackages verbosity repos + + progress <- planLocalPackage verbosity comp configFlags configExFlags + installedPkgIndex sourcePkgDb + + notice verbosity "Resolving dependencies..." + maybePlan <- foldProgress logMsg (return . Left) (return . Right) + progress + case maybePlan of + Left message -> do + info verbosity message + setupWrapper verbosity (setupScriptOptions installedPkgIndex) Nothing + configureCommand (const configFlags) extraArgs + + Right installPlan -> case InstallPlan.ready installPlan of + [pkg@(ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _)) _ _)] -> + configurePackage verbosity + (InstallPlan.planPlatform installPlan) + (InstallPlan.planCompiler installPlan) + (setupScriptOptions installedPkgIndex) + configFlags pkg extraArgs + + _ -> die $ "internal error: configure install plan should have exactly " + ++ "one local ready package." + + where + setupScriptOptions index = SetupScriptOptions { + useCabalVersion = maybe anyVersion thisVersion + (flagToMaybe (configCabalVersion configExFlags)), + useCompiler = Just comp, + -- Hack: we typically want to allow the UserPackageDB for finding the + -- Cabal lib when compiling any Setup.hs even if we're doing a global + -- install. However we also allow looking in a specific package db. + usePackageDB = if UserPackageDB `elem` packageDBs + then packageDBs + else packageDBs ++ [UserPackageDB], + usePackageIndex = if UserPackageDB `elem` packageDBs + then Just index + else Nothing, + useProgramConfig = conf, + useDistPref = fromFlagOrDefault + (useDistPref defaultSetupScriptOptions) + (configDistPref configFlags), + useLoggingHandle = Nothing, + useWorkingDir = Nothing + } + + logMsg message rest = debug verbosity message >> rest + +-- | Make an 'InstallPlan' for the unpacked package in the current directory, +-- and all its dependencies. +-- +planLocalPackage :: Verbosity -> Compiler + -> ConfigFlags -> ConfigExFlags + -> PackageIndex InstalledPackage + -> SourcePackageDb + -> IO (Progress String String InstallPlan) +planLocalPackage verbosity comp configFlags configExFlags installedPkgIndex + (SourcePackageDb _ packagePrefs) = do + pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity + + let -- We create a local package and ask to resolve a dependency on it + localPkg = SourcePackage { + packageInfoId = packageId pkg, + Source.packageDescription = pkg, + packageSource = LocalUnpackedPackage "." + } + + resolverParams = + + addPreferences + -- preferences from the config file or command line + [ PackageVersionPreference name ver + | Dependency name ver <- configPreferences configExFlags ] + + . addConstraints + -- version constraints from the config file or command line + -- TODO: should warn or error on constraints that are not on direct deps + -- or flag constraints not on the package in question. + (map userToPackageConstraint (configExConstraints configExFlags)) + + . addConstraints + -- package flags from the config file or command line + [ PackageConstraintFlags (packageName pkg) + (configConfigurationsFlags configFlags) ] + + $ standardInstallPolicy + installedPkgIndex + (SourcePackageDb mempty packagePrefs) + [SpecificSourcePackage localPkg] + + return (resolveDependencies buildPlatform (compilerId comp) resolverParams) + + +-- | Call an installer for an 'SourcePackage' but override the configure +-- flags with the ones given by the 'ConfiguredPackage'. In particular the +-- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly +-- versioned package dependencies. So we ignore any previous partial flag +-- assignment or dependency constraints and use the new ones. +-- +configurePackage :: Verbosity + -> Platform -> CompilerId + -> SetupScriptOptions + -> ConfigFlags + -> ConfiguredPackage + -> [String] + -> IO () +configurePackage verbosity platform comp scriptOptions configFlags + (ConfiguredPackage (SourcePackage _ gpkg _) flags deps) extraArgs = + + setupWrapper verbosity + scriptOptions (Just pkg) configureCommand configureFlags extraArgs + + where + configureFlags = filterConfigureFlags configFlags { + configConfigurationsFlags = flags, + configConstraints = map thisPackageVersion deps, + configVerbosity = toFlag verbosity + } + + pkg = case finalizePackageDescription flags + (const True) + platform comp [] gpkg of + Left _ -> error "finalizePackageDescription ConfiguredPackage failed" + Right (desc, _) -> desc diff --git a/cabal/cabal-install/Distribution/Client/Dependency.hs b/cabal/cabal-install/Distribution/Client/Dependency.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency.hs @@ -0,0 +1,449 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency +-- Copyright : (c) David Himmelstrup 2005, +-- Bjorn Bringert 2007 +-- Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Top level interface to dependency resolution. +----------------------------------------------------------------------------- +module Distribution.Client.Dependency ( + -- * The main package dependency resolver + resolveDependencies, + Progress(..), + foldProgress, + + -- * Alternate, simple resolver that does not do dependencies recursively + resolveWithoutDependencies, + + -- * Constructing resolver policies + DepResolverParams(..), + PackageConstraint(..), + PackagesPreferenceDefault(..), + PackagePreference(..), + InstalledPreference(..), + + -- ** Standard policy + standardInstallPolicy, + PackageSpecifier(..), + + -- ** Extra policy options + dontUpgradeBasePackage, + hideBrokenInstalledPackages, + upgradeDependencies, + reinstallTargets, + + -- ** Policy utils + addConstraints, + addPreferences, + setPreferenceDefault, + addSourcePackages, + hideInstalledPackagesSpecific, + hideInstalledPackagesAllVersions, + ) where + +import Distribution.Client.Dependency.TopDown (topDownResolver) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.Types + ( SourcePackageDb(SourcePackageDb) + , SourcePackage(..), InstalledPackage ) +import Distribution.Client.Dependency.Types + ( DependencyResolver, PackageConstraint(..) + , PackagePreferences(..), InstalledPreference(..) + , Progress(..), foldProgress ) +import Distribution.Client.Targets +import Distribution.Package + ( PackageName(..), PackageId, Package(..), packageVersion + , Dependency(Dependency)) +import Distribution.Version + ( VersionRange, anyVersion, withinRange, simplifyVersionRange ) +import Distribution.Compiler + ( CompilerId(..) ) +import Distribution.System + ( Platform ) +import Distribution.Simple.Utils (comparing) +import Distribution.Text + ( display ) + +import Data.List (maximumBy, foldl') +import Data.Maybe (fromMaybe, isJust) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Set (Set) + + +-- ------------------------------------------------------------ +-- * High level planner policy +-- ------------------------------------------------------------ + +-- | The set of parameters to the dependency resolver. These parameters are +-- relatively low level but many kinds of high level policies can be +-- implemented in terms of adjustments to the parameters. +-- +data DepResolverParams = DepResolverParams { + depResolverTargets :: [PackageName], + depResolverConstraints :: [PackageConstraint], + depResolverPreferences :: [PackagePreference], + depResolverPreferenceDefault :: PackagesPreferenceDefault, + depResolverInstalledPkgIndex :: PackageIndex InstalledPackage, + depResolverSourcePkgIndex :: PackageIndex SourcePackage + } + + +-- | Global policy for all packages to say if we prefer package versions that +-- are already installed locally or if we just prefer the latest available. +-- +data PackagesPreferenceDefault = + + -- | Always prefer the latest version irrespective of any existing + -- installed version. + -- + -- * This is the standard policy for upgrade. + -- + PreferAllLatest + + -- | Always prefer the installed versions over ones that would need to be + -- installed. Secondarily, prefer latest versions (eg the latest installed + -- version or if there are none then the latest source version). + | PreferAllInstalled + + -- | Prefer the latest version for packages that are explicitly requested + -- but prefers the installed version for any other packages. + -- + -- * This is the standard policy for install. + -- + | PreferLatestForSelected + + +-- | A package selection preference for a particular package. +-- +-- Preferences are soft constraints that the dependency resolver should try to +-- respect where possible. It is not specified if preferences on some packages +-- are more important than others. +-- +data PackagePreference = + + -- | A suggested constraint on the version number. + PackageVersionPreference PackageName VersionRange + + -- | If we prefer versions of packages that are already installed. + | PackageInstalledPreference PackageName InstalledPreference + +basicDepResolverParams :: PackageIndex InstalledPackage + -> PackageIndex SourcePackage + -> DepResolverParams +basicDepResolverParams installedPkgIndex sourcePkgIndex = + DepResolverParams { + depResolverTargets = [], + depResolverConstraints = [], + depResolverPreferences = [], + depResolverPreferenceDefault = PreferLatestForSelected, + depResolverInstalledPkgIndex = installedPkgIndex, + depResolverSourcePkgIndex = sourcePkgIndex + } + +addTargets :: [PackageName] + -> DepResolverParams -> DepResolverParams +addTargets extraTargets params = + params { + depResolverTargets = extraTargets ++ depResolverTargets params + } + +addConstraints :: [PackageConstraint] + -> DepResolverParams -> DepResolverParams +addConstraints extraConstraints params = + params { + depResolverConstraints = extraConstraints + ++ depResolverConstraints params + } + +addPreferences :: [PackagePreference] + -> DepResolverParams -> DepResolverParams +addPreferences extraPreferences params = + params { + depResolverPreferences = extraPreferences + ++ depResolverPreferences params + } + +setPreferenceDefault :: PackagesPreferenceDefault + -> DepResolverParams -> DepResolverParams +setPreferenceDefault preferenceDefault params = + params { + depResolverPreferenceDefault = preferenceDefault + } + +dontUpgradeBasePackage :: DepResolverParams -> DepResolverParams +dontUpgradeBasePackage params = + addConstraints extraConstraints params + where + extraConstraints = + [ PackageConstraintInstalled pkgname + | all (/=PackageName "base") (depResolverTargets params) + , pkgname <- [ PackageName "base", PackageName "ghc-prim" ] + , isInstalled pkgname ] + -- TODO: the top down resolver chokes on the base constraints + -- below when there are no targets and thus no dep on base. + -- Need to refactor contraints separate from needing packages. + isInstalled = not . null + . PackageIndex.lookupPackageName + (depResolverInstalledPkgIndex params) + +addSourcePackages :: [SourcePackage] + -> DepResolverParams -> DepResolverParams +addSourcePackages pkgs params = + params { + depResolverSourcePkgIndex = + foldl (flip PackageIndex.insert) + (depResolverSourcePkgIndex params) pkgs + } + +hideInstalledPackagesSpecific :: [PackageId] + -> DepResolverParams -> DepResolverParams +hideInstalledPackagesSpecific pkgids params = + --TODO: this should work using exclude constraints instead + params { + depResolverInstalledPkgIndex = + foldl' (flip PackageIndex.deletePackageId) + (depResolverInstalledPkgIndex params) pkgids + } + +hideInstalledPackagesAllVersions :: [PackageName] + -> DepResolverParams -> DepResolverParams +hideInstalledPackagesAllVersions pkgnames params = + --TODO: this should work using exclude constraints instead + params { + depResolverInstalledPkgIndex = + foldl' (flip PackageIndex.deletePackageName) + (depResolverInstalledPkgIndex params) pkgnames + } + + +hideBrokenInstalledPackages :: DepResolverParams -> DepResolverParams +hideBrokenInstalledPackages params = + hideInstalledPackagesSpecific pkgids params + where + pkgids = map packageId + . PackageIndex.reverseDependencyClosure + (depResolverInstalledPkgIndex params) + . map (packageId . fst) + . PackageIndex.brokenPackages + $ depResolverInstalledPkgIndex params + + +upgradeDependencies :: DepResolverParams -> DepResolverParams +upgradeDependencies = setPreferenceDefault PreferAllLatest + + +reinstallTargets :: DepResolverParams -> DepResolverParams +reinstallTargets params = + hideInstalledPackagesAllVersions (depResolverTargets params) params + + +standardInstallPolicy :: PackageIndex InstalledPackage + -> SourcePackageDb + -> [PackageSpecifier SourcePackage] + -> DepResolverParams +standardInstallPolicy + installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs) + pkgSpecifiers + + = addPreferences + [ PackageVersionPreference name ver + | (name, ver) <- Map.toList sourcePkgPrefs ] + + . addConstraints + (concatMap pkgSpecifierConstraints pkgSpecifiers) + + . addTargets + (map pkgSpecifierTarget pkgSpecifiers) + + . hideInstalledPackagesSpecific + [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] + + . addSourcePackages + [ pkg | SpecificSourcePackage pkg <- pkgSpecifiers ] + + $ basicDepResolverParams + installedPkgIndex sourcePkgIndex + + +-- ------------------------------------------------------------ +-- * Interface to the standard resolver +-- ------------------------------------------------------------ + +defaultResolver :: DependencyResolver +defaultResolver = topDownResolver + +-- | Run the dependency solver. +-- +-- Since this is potentially an expensive operation, the result is wrapped in a +-- a 'Progress' structure that can be unfolded to provide progress information, +-- logging messages and the final result or an error. +-- +resolveDependencies :: Platform + -> CompilerId + -> DepResolverParams + -> Progress String String InstallPlan + + --TODO: is this needed here? see dontUpgradeBasePackage +resolveDependencies platform comp params + | null (depResolverTargets params) + = return (mkInstallPlan platform comp []) + +resolveDependencies platform comp params = + + fmap (mkInstallPlan platform comp) + $ defaultResolver platform comp installedPkgIndex sourcePkgIndex + preferences constraints targets + where + DepResolverParams + targets constraints + prefs defpref + installedPkgIndex + sourcePkgIndex = dontUpgradeBasePackage + . hideBrokenInstalledPackages + $ params + + preferences = interpretPackagesPreference + (Set.fromList targets) defpref prefs + + +-- | Make an install plan from the output of the dep resolver. +-- It checks that the plan is valid, or it's an error in the dep resolver. +-- +mkInstallPlan :: Platform + -> CompilerId + -> [InstallPlan.PlanPackage] -> InstallPlan +mkInstallPlan platform comp pkgIndex = + case InstallPlan.new platform comp (PackageIndex.fromList pkgIndex) of + Right plan -> plan + Left problems -> error $ unlines $ + "internal error: could not construct a valid install plan." + : "The proposed (invalid) plan contained the following problems:" + : map InstallPlan.showPlanProblem problems + + +-- | Give an interpretation to the global 'PackagesPreference' as +-- specific per-package 'PackageVersionPreference'. +-- +interpretPackagesPreference :: Set PackageName + -> PackagesPreferenceDefault + -> [PackagePreference] + -> (PackageName -> PackagePreferences) +interpretPackagesPreference selected defaultPref prefs = + \pkgname -> PackagePreferences (versionPref pkgname) (installPref pkgname) + + where + versionPref pkgname = + fromMaybe anyVersion (Map.lookup pkgname versionPrefs) + versionPrefs = Map.fromList + [ (pkgname, pref) + | PackageVersionPreference pkgname pref <- prefs ] + + installPref pkgname = + fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs) + installPrefs = Map.fromList + [ (pkgname, pref) + | PackageInstalledPreference pkgname pref <- prefs ] + installPrefDefault = case defaultPref of + PreferAllLatest -> \_ -> PreferLatest + PreferAllInstalled -> \_ -> PreferInstalled + PreferLatestForSelected -> \pkgname -> + -- When you say cabal install foo, what you really mean is, prefer the + -- latest version of foo, but the installed version of everything else + if pkgname `Set.member` selected then PreferLatest + else PreferInstalled + +-- ------------------------------------------------------------ +-- * Simple resolver that ignores dependencies +-- ------------------------------------------------------------ + +-- | A simplistic method of resolving a list of target package names to +-- available packages. +-- +-- Specifically, it does not consider package dependencies at all. Unlike +-- 'resolveDependencies', no attempt is made to ensure that the selected +-- packages have dependencies that are satisfiable or consistent with +-- each other. +-- +-- It is suitable for tasks such as selecting packages to download for user +-- inspection. It is not suitable for selecting packages to install. +-- +-- Note: if no installed package index is available, it is ok to pass 'mempty'. +-- It simply means preferences for installed packages will be ignored. +-- +resolveWithoutDependencies :: DepResolverParams + -> Either [ResolveNoDepsError] [SourcePackage] +resolveWithoutDependencies (DepResolverParams targets constraints + prefs defpref installedPkgIndex sourcePkgIndex) = + collectEithers (map selectPackage targets) + where + selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage + selectPackage pkgname + | null choices = Left $! ResolveUnsatisfiable pkgname requiredVersions + | otherwise = Right $! maximumBy bestByPrefs choices + + where + -- Constraints + requiredVersions = packageConstraints pkgname + pkgDependency = Dependency pkgname requiredVersions + choices = PackageIndex.lookupDependency sourcePkgIndex + pkgDependency + + -- Preferences + PackagePreferences preferredVersions preferInstalled + = packagePreferences pkgname + + bestByPrefs = comparing $ \pkg -> + (installPref pkg, versionPref pkg, packageVersion pkg) + installPref = case preferInstalled of + PreferLatest -> const False + PreferInstalled -> isJust . PackageIndex.lookupPackageId + installedPkgIndex + . packageId + versionPref pkg = packageVersion pkg `withinRange` preferredVersions + + packageConstraints :: PackageName -> VersionRange + packageConstraints pkgname = + Map.findWithDefault anyVersion pkgname packageVersionConstraintMap + packageVersionConstraintMap = + Map.fromList [ (name, range) + | PackageConstraintVersion name range <- constraints ] + + packagePreferences :: PackageName -> PackagePreferences + packagePreferences = interpretPackagesPreference + (Set.fromList targets) defpref prefs + + +collectEithers :: [Either a b] -> Either [a] [b] +collectEithers = collect . partitionEithers + where + collect ([], xs) = Right xs + collect (errs,_) = Left errs + partitionEithers :: [Either a b] -> ([a],[b]) + partitionEithers = foldr (either left right) ([],[]) + where + left a (l, r) = (a:l, r) + right a (l, r) = (l, a:r) + +-- | Errors for 'resolveWithoutDependencies'. +-- +data ResolveNoDepsError = + + -- | A package name which cannot be resolved to a specific package. + -- Also gives the constraint on the version and whether there was + -- a constraint on the package being installed. + ResolveUnsatisfiable PackageName VersionRange + +instance Show ResolveNoDepsError where + show (ResolveUnsatisfiable name ver) = + "There is no available version of " ++ display name + ++ " that satisfies " ++ display (simplifyVersionRange ver) diff --git a/cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs b/cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs @@ -0,0 +1,928 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency.Types +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Common types for dependency resolution. +----------------------------------------------------------------------------- +module Distribution.Client.Dependency.TopDown ( + topDownResolver + ) where + +import Distribution.Client.Dependency.TopDown.Types +import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints +import Distribution.Client.Dependency.TopDown.Constraints + ( Satisfiable(..) ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan + ( PlanPackage(..) ) +import Distribution.Client.Types + ( SourcePackage(..), ConfiguredPackage(..), InstalledPackage(..) ) +import Distribution.Client.Dependency.Types + ( DependencyResolver, PackageConstraint(..) + , PackagePreferences(..), InstalledPreference(..) + , Progress(..), foldProgress ) + +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Package + ( PackageName(..), PackageId, Package(..), packageVersion, packageName + , Dependency(Dependency), thisPackageVersion + , simplifyDependency, PackageFixedDeps(depends) ) +import Distribution.PackageDescription + ( PackageDescription(buildDepends) ) +import Distribution.Client.PackageUtils + ( externalBuildDepends ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription, flattenPackageDescription ) +import Distribution.Version + ( VersionRange, withinRange, simplifyVersionRange + , UpperBound(..), asVersionIntervals ) +import Distribution.Compiler + ( CompilerId ) +import Distribution.System + ( Platform ) +import Distribution.Simple.Utils + ( equating, comparing ) +import Distribution.Text + ( display ) + +import Data.List + ( foldl', maximumBy, minimumBy, nub, sort, sortBy, groupBy ) +import Data.Maybe + ( fromJust, fromMaybe, catMaybes ) +import Data.Monoid + ( Monoid(mempty) ) +import Control.Monad + ( guard ) +import qualified Data.Set as Set +import Data.Set (Set) +import qualified Data.Map as Map +import qualified Data.Graph as Graph +import qualified Data.Array as Array +import Control.Exception + ( assert ) + +-- ------------------------------------------------------------ +-- * Search state types +-- ------------------------------------------------------------ + +type Constraints = Constraints.Constraints + InstalledPackageEx UnconfiguredPackage ExclusionReason +type SelectedPackages = PackageIndex SelectedPackage + +-- ------------------------------------------------------------ +-- * The search tree type +-- ------------------------------------------------------------ + +data SearchSpace inherited pkg + = ChoiceNode inherited [[(pkg, SearchSpace inherited pkg)]] + | Failure Failure + +-- ------------------------------------------------------------ +-- * Traverse a search tree +-- ------------------------------------------------------------ + +explore :: (PackageName -> PackagePreferences) + -> SearchSpace (SelectedPackages, Constraints, SelectionChanges) + SelectablePackage + -> Progress Log Failure (SelectedPackages, Constraints) + +explore _ (Failure failure) = Fail failure +explore _ (ChoiceNode (s,c,_) []) = Done (s,c) +explore pref (ChoiceNode _ choices) = + case [ choice | [choice] <- choices ] of + ((_, node'):_) -> Step (logInfo node') (explore pref node') + [] -> Step (logInfo node') (explore pref node') + where + choice = minimumBy (comparing topSortNumber) choices + pkgname = packageName . fst . head $ choice + (_, node') = maximumBy (bestByPref pkgname) choice + where + topSortNumber choice = case fst (head choice) of + InstalledOnly (InstalledPackageEx _ i _) -> i + SourceOnly (UnconfiguredPackage _ i _) -> i + InstalledAndSource _ (UnconfiguredPackage _ i _) -> i + + bestByPref pkgname = case packageInstalledPreference of + PreferLatest -> + comparing (\(p,_) -> ( isPreferred p, packageId p)) + PreferInstalled -> + comparing (\(p,_) -> (isInstalled p, isPreferred p, packageId p)) + where + isInstalled (SourceOnly _) = False + isInstalled _ = True + isPreferred p = packageVersion p `withinRange` preferredVersions + (PackagePreferences preferredVersions packageInstalledPreference) + = pref pkgname + + logInfo node = Select selected discarded + where (selected, discarded) = case node of + Failure _ -> ([], []) + ChoiceNode (_,_,changes) _ -> changes + +-- ------------------------------------------------------------ +-- * Generate a search tree +-- ------------------------------------------------------------ + +type ConfigurePackage = PackageIndex SelectablePackage + -> SelectablePackage + -> Either [Dependency] SelectedPackage + +-- | (packages selected, packages discarded) +type SelectionChanges = ([SelectedPackage], [PackageId]) + +searchSpace :: ConfigurePackage + -> Constraints + -> SelectedPackages + -> SelectionChanges + -> Set PackageName + -> SearchSpace (SelectedPackages, Constraints, SelectionChanges) + SelectablePackage +searchSpace configure constraints selected changes next = + assert (Set.null (selectedSet `Set.intersection` next)) $ + assert (selectedSet `Set.isSubsetOf` Constraints.packages constraints) $ + assert (next `Set.isSubsetOf` Constraints.packages constraints) $ + + ChoiceNode (selected, constraints, changes) + [ [ (pkg, select name pkg) + | pkg <- PackageIndex.lookupPackageName available name ] + | name <- Set.elems next ] + where + available = Constraints.choices constraints + + selectedSet = Set.fromList (map packageName (PackageIndex.allPackages selected)) + + select name pkg = case configure available pkg of + Left missing -> Failure $ ConfigureFailed pkg + [ (dep, Constraints.conflicting constraints dep) + | dep <- missing ] + Right pkg' -> + case constrainDeps pkg' newDeps (addDeps constraints newPkgs) [] of + Left failure -> Failure failure + Right (constraints', newDiscarded) -> + searchSpace configure + constraints' selected' (newSelected, newDiscarded) next' + where + selected' = foldl' (flip PackageIndex.insert) selected newSelected + newSelected = + case Constraints.isPaired constraints (packageId pkg) of + Nothing -> [pkg'] + Just pkgid' -> [pkg', pkg''] + where + Just pkg'' = fmap (\(InstalledOnly p) -> InstalledOnly p) + (PackageIndex.lookupPackageId available pkgid') + + newPkgs = [ name' + | (Dependency name' _, _) <- newDeps + , null (PackageIndex.lookupPackageName selected' name') ] + newDeps = concatMap packageConstraints newSelected + next' = Set.delete name + $ foldl' (flip Set.insert) next newPkgs + +packageConstraints :: SelectedPackage -> [(Dependency, Bool)] +packageConstraints = either installedConstraints availableConstraints + . preferSource + where + preferSource (InstalledOnly pkg) = Left pkg + preferSource (SourceOnly pkg) = Right pkg + preferSource (InstalledAndSource _ pkg) = Right pkg + installedConstraints (InstalledPackageEx _ _ deps) = + [ (thisPackageVersion dep, True) + | dep <- deps ] + availableConstraints (SemiConfiguredPackage _ _ deps) = + [ (dep, False) | dep <- deps ] + +addDeps :: Constraints -> [PackageName] -> Constraints +addDeps = + foldr $ \pkgname cs -> + case Constraints.addTarget pkgname cs of + Satisfiable cs' () -> cs' + _ -> impossible "addDeps unsatisfiable" + +constrainDeps :: SelectedPackage -> [(Dependency, Bool)] -> Constraints + -> [PackageId] + -> Either Failure (Constraints, [PackageId]) +constrainDeps pkg [] cs discard = + case addPackageSelectConstraint (packageId pkg) cs of + Satisfiable cs' discard' -> Right (cs', discard' ++ discard) + _ -> impossible "constrainDeps unsatisfiable(1)" +constrainDeps pkg ((dep, installedConstraint):deps) cs discard = + case addPackageDependencyConstraint (packageId pkg) dep installedConstraint cs of + Satisfiable cs' discard' -> constrainDeps pkg deps cs' (discard' ++ discard) + Unsatisfiable -> impossible "constrainDeps unsatisfiable(2)" + ConflictsWith conflicts -> + Left (DependencyConflict pkg dep installedConstraint conflicts) + +-- ------------------------------------------------------------ +-- * The main algorithm +-- ------------------------------------------------------------ + +search :: ConfigurePackage + -> (PackageName -> PackagePreferences) + -> Constraints + -> Set PackageName + -> Progress Log Failure (SelectedPackages, Constraints) +search configure pref constraints = + explore pref . searchSpace configure constraints mempty ([], []) + +-- ------------------------------------------------------------ +-- * The top level resolver +-- ------------------------------------------------------------ + +-- | The main exported resolver, with string logging and failure types to fit +-- the standard 'DependencyResolver' interface. +-- +topDownResolver :: DependencyResolver +topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver' + where + mapMessages :: Progress Log Failure a -> Progress String String a + mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done + +-- | The native resolver with detailed structured logging and failure types. +-- +topDownResolver' :: Platform -> CompilerId + -> PackageIndex InstalledPackage + -> PackageIndex SourcePackage + -> (PackageName -> PackagePreferences) + -> [PackageConstraint] + -> [PackageName] + -> Progress Log Failure [PlanPackage] +topDownResolver' platform comp installedPkgIndex sourcePkgIndex + preferences constraints targets = + fmap (uncurry finalise) + . (\cs -> search configure preferences cs initialPkgNames) + =<< pruneBottomUp platform comp + =<< addTopLevelConstraints constraints + =<< addTopLevelTargets targets emptyConstraintSet + + where + configure = configurePackage platform comp + emptyConstraintSet :: Constraints + emptyConstraintSet = Constraints.empty + (annotateInstalledPackages topSortNumber installedPkgIndex') + (annotateSourcePackages constraints topSortNumber sourcePkgIndex') + (installedPkgIndex', sourcePkgIndex') = + selectNeededSubset installedPkgIndex sourcePkgIndex initialPkgNames + topSortNumber = topologicalSortNumbering installedPkgIndex' sourcePkgIndex' + + initialPkgNames = Set.fromList targets + + finalise selected' constraints' = + PackageIndex.allPackages + . fst . improvePlan installedPkgIndex' constraints' + . PackageIndex.fromList + $ finaliseSelectedPackages preferences selected' constraints' + + +addTopLevelTargets :: [PackageName] + -> Constraints + -> Progress a Failure Constraints +addTopLevelTargets [] cs = Done cs +addTopLevelTargets (pkg:pkgs) cs = + case Constraints.addTarget pkg cs of + Satisfiable cs' () -> addTopLevelTargets pkgs cs' + Unsatisfiable -> Fail (NoSuchPackage pkg) + ConflictsWith _conflicts -> impossible "addTopLevelTargets conflicts" + + +addTopLevelConstraints :: [PackageConstraint] -> Constraints + -> Progress Log Failure Constraints +addTopLevelConstraints [] cs = Done cs +addTopLevelConstraints (PackageConstraintFlags _ _ :deps) cs = + addTopLevelConstraints deps cs + +addTopLevelConstraints (PackageConstraintVersion pkg ver:deps) cs = + case addTopLevelVersionConstraint pkg ver cs of + Satisfiable cs' pkgids -> + Step (AppliedVersionConstraint pkg ver pkgids) + (addTopLevelConstraints deps cs') + + Unsatisfiable -> + Fail (TopLevelVersionConstraintUnsatisfiable pkg ver) + + ConflictsWith conflicts -> + Fail (TopLevelVersionConstraintConflict pkg ver conflicts) + +addTopLevelConstraints (PackageConstraintInstalled pkg:deps) cs = + case addTopLevelInstalledConstraint pkg cs of + Satisfiable cs' pkgids -> + Step (AppliedInstalledConstraint pkg InstalledConstraint pkgids) + (addTopLevelConstraints deps cs') + + Unsatisfiable -> + Fail (TopLevelInstallConstraintUnsatisfiable pkg InstalledConstraint) + + ConflictsWith conflicts -> + Fail (TopLevelInstallConstraintConflict pkg InstalledConstraint conflicts) + +addTopLevelConstraints (PackageConstraintSource pkg:deps) cs = + case addTopLevelSourceConstraint pkg cs of + Satisfiable cs' pkgids -> + Step (AppliedInstalledConstraint pkg SourceConstraint pkgids) + (addTopLevelConstraints deps cs') + + Unsatisfiable -> + Fail (TopLevelInstallConstraintUnsatisfiable pkg SourceConstraint) + + ConflictsWith conflicts -> + Fail (TopLevelInstallConstraintConflict pkg SourceConstraint conflicts) + +-- | Add exclusion on available packages that cannot be configured. +-- +pruneBottomUp :: Platform -> CompilerId + -> Constraints -> Progress Log Failure Constraints +pruneBottomUp platform comp constraints = + foldr prune Done (initialPackages constraints) constraints + + where + prune pkgs rest cs = foldr addExcludeConstraint rest unconfigurable cs + where + unconfigurable = + [ (pkg, missing) -- if necessary we could look up missing reasons + | (Just pkg', pkg) <- zip (map getSourcePkg pkgs) pkgs + , Left missing <- [configure cs pkg'] ] + + addExcludeConstraint (pkg, missing) rest cs = + let reason = ExcludedByConfigureFail missing in + case addPackageExcludeConstraint (packageId pkg) reason cs of + Satisfiable cs' [pkgid]| packageId pkg == pkgid + -> Step (ExcludeUnconfigurable pkgid) (rest cs') + Satisfiable _ _ -> impossible "pruneBottomUp satisfiable" + _ -> Fail $ ConfigureFailed pkg + [ (dep, Constraints.conflicting cs dep) + | dep <- missing ] + + configure cs (UnconfiguredPackage (SourcePackage _ pkg _) _ flags) = + finalizePackageDescription flags (dependencySatisfiable cs) + platform comp [] pkg + dependencySatisfiable cs = + not . null . PackageIndex.lookupDependency (Constraints.choices cs) + + -- collect each group of packages (by name) in reverse topsort order + initialPackages = + reverse + . sortBy (comparing (topSortNumber . head)) + . PackageIndex.allPackagesByName + . Constraints.choices + + topSortNumber (InstalledOnly (InstalledPackageEx _ i _)) = i + topSortNumber (SourceOnly (UnconfiguredPackage _ i _)) = i + topSortNumber (InstalledAndSource _ (UnconfiguredPackage _ i _)) = i + + getSourcePkg (InstalledOnly _ ) = Nothing + getSourcePkg (SourceOnly spkg) = Just spkg + getSourcePkg (InstalledAndSource _ spkg) = Just spkg + + +configurePackage :: Platform -> CompilerId -> ConfigurePackage +configurePackage platform comp available spkg = case spkg of + InstalledOnly ipkg -> Right (InstalledOnly ipkg) + SourceOnly apkg -> fmap SourceOnly (configure apkg) + InstalledAndSource ipkg apkg -> fmap (InstalledAndSource ipkg) + (configure apkg) + where + configure (UnconfiguredPackage apkg@(SourcePackage _ p _) _ flags) = + case finalizePackageDescription flags dependencySatisfiable + platform comp [] p of + Left missing -> Left missing + Right (pkg, flags') -> Right $ + SemiConfiguredPackage apkg flags' (externalBuildDepends pkg) + + dependencySatisfiable = not . null . PackageIndex.lookupDependency available + +-- | Annotate each installed packages with its set of transative dependencies +-- and its topological sort number. +-- +annotateInstalledPackages :: (PackageName -> TopologicalSortNumber) + -> PackageIndex InstalledPackage + -> PackageIndex InstalledPackageEx +annotateInstalledPackages dfsNumber installed = PackageIndex.fromList + [ InstalledPackageEx pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg) + | pkg <- PackageIndex.allPackages installed ] + where + transitiveDepends :: InstalledPackage -> [PackageId] + transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph + . fromJust . toVertex . packageId + (graph, toPkg, toVertex) = PackageIndex.dependencyGraph installed + + +-- | Annotate each available packages with its topological sort number and any +-- user-supplied partial flag assignment. +-- +annotateSourcePackages :: [PackageConstraint] + -> (PackageName -> TopologicalSortNumber) + -> PackageIndex SourcePackage + -> PackageIndex UnconfiguredPackage +annotateSourcePackages constraints dfsNumber sourcePkgIndex = + PackageIndex.fromList + [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name) + | pkg <- PackageIndex.allPackages sourcePkgIndex + , let name = packageName pkg ] + where + flagsFor = fromMaybe [] . flip Map.lookup flagsMap + flagsMap = Map.fromList + [ (name, flags) + | PackageConstraintFlags name flags <- constraints ] + +-- | One of the heuristics we use when guessing which path to take in the +-- search space is an ordering on the choices we make. It's generally better +-- to make decisions about packages higer in the dep graph first since they +-- place constraints on packages lower in the dep graph. +-- +-- To pick them in that order we annotate each package with its topological +-- sort number. So if package A depends on package B then package A will have +-- a lower topological sort number than B and we'll make a choice about which +-- version of A to pick before we make a choice about B (unless there is only +-- one possible choice for B in which case we pick that immediately). +-- +-- To construct these topological sort numbers we combine and flatten the +-- installed and source package sets. We consider only dependencies between +-- named packages, not including versions and for not-yet-configured packages +-- we look at all the possible dependencies, not just those under any single +-- flag assignment. This means we can actually get impossible combinations of +-- edges and even cycles, but that doesn't really matter here, it's only a +-- heuristic. +-- +topologicalSortNumbering :: PackageIndex InstalledPackage + -> PackageIndex SourcePackage + -> (PackageName -> TopologicalSortNumber) +topologicalSortNumbering installedPkgIndex sourcePkgIndex = + \pkgname -> let Just vertex = toVertex pkgname + in topologicalSortNumbers Array.! vertex + where + topologicalSortNumbers = Array.array (Array.bounds graph) + (zip (Graph.topSort graph) [0..]) + (graph, _, toVertex) = Graph.graphFromEdges $ + [ ((), packageName pkg, nub deps) + | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installedPkgIndex + , let deps = [ packageName dep + | pkg' <- pkgs + , dep <- depends pkg' ] ] + ++ [ ((), packageName pkg, nub deps) + | pkgs@(pkg:_) <- PackageIndex.allPackagesByName sourcePkgIndex + , let deps = [ depName + | SourcePackage _ pkg' _ <- pkgs + , Dependency depName _ <- + buildDepends (flattenPackageDescription pkg') ] ] + +-- | We don't need the entire index (which is rather large and costly if we +-- force it by examining the whole thing). So trace out the maximul subset of +-- each index that we could possibly ever need. Do this by flattening packages +-- and looking at the names of all possible dependencies. +-- +selectNeededSubset :: PackageIndex InstalledPackage + -> PackageIndex SourcePackage + -> Set PackageName + -> (PackageIndex InstalledPackage + ,PackageIndex SourcePackage) +selectNeededSubset installedPkgIndex sourcePkgIndex = select mempty mempty + where + select :: PackageIndex InstalledPackage + -> PackageIndex SourcePackage + -> Set PackageName + -> (PackageIndex InstalledPackage + ,PackageIndex SourcePackage) + select installedPkgIndex' sourcePkgIndex' remaining + | Set.null remaining = (installedPkgIndex', sourcePkgIndex') + | otherwise = select installedPkgIndex'' sourcePkgIndex'' remaining'' + where + (next, remaining') = Set.deleteFindMin remaining + moreInstalled = PackageIndex.lookupPackageName installedPkgIndex next + moreSource = PackageIndex.lookupPackageName sourcePkgIndex next + moreRemaining = -- we filter out packages already included in the indexes + -- this avoids an infinite loop if a package depends on itself + -- like base-3.0.3.0 with base-4.0.0.0 + filter notAlreadyIncluded + $ [ packageName dep + | pkg <- moreInstalled + , dep <- depends pkg ] + ++ [ name + | SourcePackage _ pkg _ <- moreSource + , Dependency name _ <- + buildDepends (flattenPackageDescription pkg) ] + installedPkgIndex'' = foldl' (flip PackageIndex.insert) + installedPkgIndex' moreInstalled + sourcePkgIndex'' = foldl' (flip PackageIndex.insert) + sourcePkgIndex' moreSource + remaining'' = foldl' (flip Set.insert) + remaining' moreRemaining + notAlreadyIncluded name = + null (PackageIndex.lookupPackageName installedPkgIndex' name) + && null (PackageIndex.lookupPackageName sourcePkgIndex' name) + +-- ------------------------------------------------------------ +-- * Post processing the solution +-- ------------------------------------------------------------ + +finaliseSelectedPackages :: (PackageName -> PackagePreferences) + -> SelectedPackages + -> Constraints + -> [PlanPackage] +finaliseSelectedPackages pref selected constraints = + map finaliseSelected (PackageIndex.allPackages selected) + where + remainingChoices = Constraints.choices constraints + finaliseSelected (InstalledOnly ipkg ) = finaliseInstalled ipkg + finaliseSelected (SourceOnly apkg) = finaliseSource Nothing apkg + finaliseSelected (InstalledAndSource ipkg apkg) = + case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of + --picked package not in constraints + Nothing -> impossible "finaliseSelected no pkg" + -- to constrain to avail only: + Just (SourceOnly _) -> impossible "finaliseSelected src only" + Just (InstalledOnly _) -> finaliseInstalled ipkg + Just (InstalledAndSource _ _) -> finaliseSource (Just ipkg) apkg + + finaliseInstalled (InstalledPackageEx pkg _ _) = InstallPlan.PreExisting pkg + finaliseSource mipkg (SemiConfiguredPackage pkg flags deps) = + InstallPlan.Configured (ConfiguredPackage pkg flags deps') + where + deps' = map (packageId . pickRemaining mipkg) deps + + pickRemaining mipkg dep@(Dependency _name versionRange) = + case PackageIndex.lookupDependency remainingChoices dep of + [] -> impossible "pickRemaining no pkg" + [pkg'] -> pkg' + remaining -> assert (checkIsPaired remaining) + $ maximumBy bestByPref remaining + where + -- We order candidate packages to pick for a dependency by these + -- three factors. The last factor is just highest version wins. + bestByPref = + comparing (\p -> (isCurrent p, isPreferred p, packageVersion p)) + -- Is the package already used by the installed version of this + -- package? If so we should pick that first. This stops us from doing + -- silly things like deciding to rebuild haskell98 against base 3. + isCurrent = case mipkg :: Maybe InstalledPackageEx of + Nothing -> \_ -> False + Just ipkg -> \p -> packageId p `elem` depends ipkg + -- If there is no upper bound on the version range then we apply a + -- preferred version according to the hackage or user's suggested + -- version constraints. TODO: distinguish hacks from prefs + bounded = boundedAbove versionRange + isPreferred p + | bounded = True -- any constant will do + | otherwise = packageVersion p `withinRange` preferredVersions + where (PackagePreferences preferredVersions _) = pref (packageName p) + + boundedAbove :: VersionRange -> Bool + boundedAbove vr = case asVersionIntervals vr of + [] -> True -- this is the inconsistent version range. + intervals -> case last intervals of + (_, UpperBound _ _) -> True + (_, NoUpperBound ) -> False + + -- We really only expect to find more than one choice remaining when + -- we're finalising a dependency on a paired package. + checkIsPaired [p1, p2] = + case Constraints.isPaired constraints (packageId p1) of + Just p2' -> packageId p2' == packageId p2 + Nothing -> False + checkIsPaired _ = False + +-- | Improve an existing installation plan by, where possible, swapping +-- packages we plan to install with ones that are already installed. +-- This may add additional constraints due to the dependencies of installed +-- packages on other installed packages. +-- +improvePlan :: PackageIndex InstalledPackage + -> Constraints + -> PackageIndex PlanPackage + -> (PackageIndex PlanPackage, Constraints) +improvePlan installed constraints0 selected0 = + foldl' improve (selected0, constraints0) (reverseTopologicalOrder selected0) + where + improve (selected, constraints) = fromMaybe (selected, constraints) + . improvePkg selected constraints + + -- The idea is to improve the plan by swapping a configured package for + -- an equivalent installed one. For a particular package the condition is + -- that the package be in a configured state, that a the same version be + -- already installed with the exact same dependencies and all the packages + -- in the plan that it depends on are in the installed state + improvePkg selected constraints pkgid = do + Configured pkg <- PackageIndex.lookupPackageId selected pkgid + ipkg <- PackageIndex.lookupPackageId installed pkgid + guard $ all (isInstalled selected) (depends pkg) + tryInstalled selected constraints [ipkg] + + isInstalled selected pkgid = + case PackageIndex.lookupPackageId selected pkgid of + Just (PreExisting _) -> True + _ -> False + + tryInstalled :: PackageIndex PlanPackage -> Constraints + -> [InstalledPackage] + -> Maybe (PackageIndex PlanPackage, Constraints) + tryInstalled selected constraints [] = Just (selected, constraints) + tryInstalled selected constraints (pkg:pkgs) = + case constraintsOk (packageId pkg) (depends pkg) constraints of + Nothing -> Nothing + Just constraints' -> tryInstalled selected' constraints' pkgs' + where + selected' = PackageIndex.insert (PreExisting pkg) selected + pkgs' = catMaybes (map notSelected (depends pkg)) ++ pkgs + notSelected pkgid = + case (PackageIndex.lookupPackageId installed pkgid + ,PackageIndex.lookupPackageId selected pkgid) of + (Just pkg', Nothing) -> Just pkg' + _ -> Nothing + + constraintsOk _ [] constraints = Just constraints + constraintsOk pkgid (pkgid':pkgids) constraints = + case addPackageDependencyConstraint pkgid dep True constraints of + Satisfiable constraints' _ -> constraintsOk pkgid pkgids constraints' + _ -> Nothing + where + dep = thisPackageVersion pkgid' + + reverseTopologicalOrder :: PackageFixedDeps pkg + => PackageIndex pkg -> [PackageId] + reverseTopologicalOrder index = map (packageId . toPkg) + . Graph.topSort + . Graph.transposeG + $ graph + where (graph, toPkg, _) = PackageIndex.dependencyGraph index + +-- ------------------------------------------------------------ +-- * Adding and recording constraints +-- ------------------------------------------------------------ + +addPackageSelectConstraint :: PackageId -> Constraints + -> Satisfiable Constraints + [PackageId] ExclusionReason +addPackageSelectConstraint pkgid = + Constraints.constrain pkgname constraint reason + where + pkgname = packageName pkgid + constraint ver _ = ver == packageVersion pkgid + reason = SelectedOther pkgid + +addPackageExcludeConstraint :: PackageId -> ExclusionReason + -> Constraints + -> Satisfiable Constraints + [PackageId] ExclusionReason +addPackageExcludeConstraint pkgid reason = + Constraints.constrain pkgname constraint reason + where + pkgname = packageName pkgid + constraint ver installed + | ver == packageVersion pkgid = installed + | otherwise = True + +addPackageDependencyConstraint :: PackageId -> Dependency -> Bool + -> Constraints + -> Satisfiable Constraints + [PackageId] ExclusionReason +addPackageDependencyConstraint pkgid dep@(Dependency pkgname verrange) + installedConstraint = + Constraints.constrain pkgname constraint reason + where + constraint ver installed = ver `withinRange` verrange + && if installedConstraint then installed else True + reason = ExcludedByPackageDependency pkgid dep installedConstraint + +addTopLevelVersionConstraint :: PackageName -> VersionRange + -> Constraints + -> Satisfiable Constraints + [PackageId] ExclusionReason +addTopLevelVersionConstraint pkgname verrange = + Constraints.constrain pkgname constraint reason + where + constraint ver _installed = ver `withinRange` verrange + reason = ExcludedByTopLevelConstraintVersion pkgname verrange + +addTopLevelInstalledConstraint, + addTopLevelSourceConstraint :: PackageName + -> Constraints + -> Satisfiable Constraints + [PackageId] ExclusionReason +addTopLevelInstalledConstraint pkgname = + Constraints.constrain pkgname constraint reason + where + constraint _ver installed = installed + reason = ExcludedByTopLevelConstraintInstalled pkgname + +addTopLevelSourceConstraint pkgname = + Constraints.constrain pkgname constraint reason + where + constraint _ver installed = not installed + reason = ExcludedByTopLevelConstraintSource pkgname + + +-- ------------------------------------------------------------ +-- * Reasons for constraints +-- ------------------------------------------------------------ + +-- | For every constraint we record we also record the reason that constraint +-- is needed. So if we end up failing due to conflicting constraints then we +-- can give an explnanation as to what was conflicting and why. +-- +data ExclusionReason = + + -- | We selected this other version of the package. That means we exclude + -- all the other versions. + SelectedOther PackageId + + -- | We excluded this version of the package because it failed to + -- configure probably because of unsatisfiable deps. + | ExcludedByConfigureFail [Dependency] + + -- | We excluded this version of the package because another package that + -- we selected imposed a dependency which this package did not satisfy. + | ExcludedByPackageDependency PackageId Dependency Bool + + -- | We excluded this version of the package because it did not satisfy + -- a dependency given as an original top level input. + -- + | ExcludedByTopLevelConstraintVersion PackageName VersionRange + | ExcludedByTopLevelConstraintInstalled PackageName + | ExcludedByTopLevelConstraintSource PackageName + + deriving Eq + +-- | Given an excluded package and the reason it was excluded, produce a human +-- readable explanation. +-- +showExclusionReason :: PackageId -> ExclusionReason -> String +showExclusionReason pkgid (SelectedOther pkgid') = + display pkgid ++ " was excluded because " ++ + display pkgid' ++ " was selected instead" +showExclusionReason pkgid (ExcludedByConfigureFail missingDeps) = + display pkgid ++ " was excluded because it could not be configured. " + ++ "It requires " ++ listOf displayDep missingDeps +showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep installedConstraint) + = display pkgid ++ " was excluded because " ++ display pkgid' ++ " requires " + ++ (if installedConstraint then "an installed instance of " else "") + ++ displayDep dep +showExclusionReason pkgid (ExcludedByTopLevelConstraintVersion pkgname verRange) = + display pkgid ++ " was excluded because of the top level constraint " ++ + displayDep (Dependency pkgname verRange) +showExclusionReason pkgid (ExcludedByTopLevelConstraintInstalled pkgname) + = display pkgid ++ " was excluded because of the top level constraint '" + ++ display pkgname ++ " installed' which means that only installed instances " + ++ "of the package may be selected." +showExclusionReason pkgid (ExcludedByTopLevelConstraintSource pkgname) + = display pkgid ++ " was excluded because of the top level constraint '" + ++ display pkgname ++ " source' which means that only source versions " + ++ "of the package may be selected." + + +-- ------------------------------------------------------------ +-- * Logging progress and failures +-- ------------------------------------------------------------ + +data Log = Select [SelectedPackage] [PackageId] + | AppliedVersionConstraint PackageName VersionRange [PackageId] + | AppliedInstalledConstraint PackageName InstalledConstraint [PackageId] + | ExcludeUnconfigurable PackageId + +data Failure + = NoSuchPackage + PackageName + | ConfigureFailed + SelectablePackage + [(Dependency, [(PackageId, [ExclusionReason])])] + | DependencyConflict + SelectedPackage Dependency Bool + [(PackageId, [ExclusionReason])] + | TopLevelVersionConstraintConflict + PackageName VersionRange + [(PackageId, [ExclusionReason])] + | TopLevelVersionConstraintUnsatisfiable + PackageName VersionRange + | TopLevelInstallConstraintConflict + PackageName InstalledConstraint + [(PackageId, [ExclusionReason])] + | TopLevelInstallConstraintUnsatisfiable + PackageName InstalledConstraint + +showLog :: Log -> String +showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of + ("", y) -> y + (x, "") -> x + (x, y) -> x ++ " and " ++ y + + where + selectedMsg = "selecting " ++ case selected of + [] -> "" + [s] -> display (packageId s) ++ " " ++ kind s + (s:ss) -> listOf id + $ (display (packageId s) ++ " " ++ kind s) + : [ display (packageVersion s') ++ " " ++ kind s' + | s' <- ss ] + + kind (InstalledOnly _) = "(installed)" + kind (SourceOnly _) = "(source)" + kind (InstalledAndSource _ _) = "(installed or source)" + + discardedMsg = case discarded of + [] -> "" + _ -> "discarding " ++ listOf id + [ element + | (pkgid:pkgids) <- groupBy (equating packageName) (sort discarded) + , element <- display pkgid : map (display . packageVersion) pkgids ] +showLog (AppliedVersionConstraint pkgname ver pkgids) = + "applying constraint " ++ display (Dependency pkgname ver) + ++ if null pkgids + then "" + else "which excludes " ++ listOf display pkgids +showLog (AppliedInstalledConstraint pkgname inst pkgids) = + "applying constraint " ++ display pkgname ++ " '" + ++ (case inst of InstalledConstraint -> "installed"; _ -> "source") ++ "' " + ++ if null pkgids + then "" + else "which excludes " ++ listOf display pkgids +showLog (ExcludeUnconfigurable pkgid) = + "excluding " ++ display pkgid ++ " (it cannot be configured)" + +showFailure :: Failure -> String +showFailure (NoSuchPackage pkgname) = + "The package " ++ display pkgname ++ " is unknown." +showFailure (ConfigureFailed pkg missingDeps) = + "cannot configure " ++ displayPkg pkg ++ ". It requires " + ++ listOf (displayDep . fst) missingDeps + ++ '\n' : unlines (map (uncurry whyNot) missingDeps) + + where + whyNot (Dependency name ver) [] = + "There is no available version of " ++ display name + ++ " that satisfies " ++ displayVer ver + + whyNot dep conflicts = + "For the dependency on " ++ displayDep dep + ++ " there are these packages: " ++ listOf display pkgs + ++ ". However none of them are available.\n" + ++ unlines [ showExclusionReason (packageId pkg') reason + | (pkg', reasons) <- conflicts, reason <- reasons ] + + where pkgs = map fst conflicts + +showFailure (DependencyConflict pkg dep installedConstraint conflicts) = + "dependencies conflict: " + ++ displayPkg pkg ++ " requires " + ++ (if installedConstraint then "an installed instance of " else "") + ++ displayDep dep ++ " however:\n" + ++ unlines [ showExclusionReason (packageId pkg') reason + | (pkg', reasons) <- conflicts, reason <- reasons ] + +showFailure (TopLevelVersionConstraintConflict name ver conflicts) = + "constraints conflict: we have the top level constraint " + ++ displayDep (Dependency name ver) ++ ", but\n" + ++ unlines [ showExclusionReason (packageId pkg') reason + | (pkg', reasons) <- conflicts, reason <- reasons ] + +showFailure (TopLevelVersionConstraintUnsatisfiable name ver) = + "There is no available version of " ++ display name + ++ " that satisfies " ++ displayVer ver + +showFailure (TopLevelInstallConstraintConflict name InstalledConstraint conflicts) = + "constraints conflict: " + ++ "top level constraint '" ++ display name ++ " installed' however\n" + ++ unlines [ showExclusionReason (packageId pkg') reason + | (pkg', reasons) <- conflicts, reason <- reasons ] + +showFailure (TopLevelInstallConstraintUnsatisfiable name InstalledConstraint) = + "There is no installed version of " ++ display name + +showFailure (TopLevelInstallConstraintConflict name SourceConstraint conflicts) = + "constraints conflict: " + ++ "top level constraint '" ++ display name ++ " source' however\n" + ++ unlines [ showExclusionReason (packageId pkg') reason + | (pkg', reasons) <- conflicts, reason <- reasons ] + +showFailure (TopLevelInstallConstraintUnsatisfiable name SourceConstraint) = + "There is no available source version of " ++ display name + +displayVer :: VersionRange -> String +displayVer = display . simplifyVersionRange + +displayDep :: Dependency -> String +displayDep = display . simplifyDependency + + +-- ------------------------------------------------------------ +-- * Utils +-- ------------------------------------------------------------ + +impossible :: String -> a +impossible msg = internalError $ "assertion failure: " ++ msg + +internalError :: String -> a +internalError msg = error $ "internal error: " ++ msg + +displayPkg :: Package pkg => pkg -> String +displayPkg = display . packageId + +listOf :: (a -> String) -> [a] -> String +listOf _ [] = [] +listOf disp [x0] = disp x0 +listOf disp (x0:x1:xs) = disp x0 ++ go x1 xs + where go x [] = " and " ++ disp x + go x (x':xs') = ", " ++ disp x ++ go x' xs' diff --git a/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs b/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs @@ -0,0 +1,601 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency.TopDown.Constraints +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- A set of satisfiable constraints on a set of packages. +----------------------------------------------------------------------------- +module Distribution.Client.Dependency.TopDown.Constraints ( + Constraints, + empty, + packages, + choices, + isPaired, + + addTarget, + constrain, + Satisfiable(..), + conflicting, + ) where + +import Distribution.Client.Dependency.TopDown.Types +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Package + ( PackageName, PackageId, PackageIdentifier(..) + , Package(packageId), packageName, packageVersion + , Dependency, PackageFixedDeps(depends) ) +import Distribution.Version + ( Version ) +import Distribution.Client.Utils + ( mergeBy, MergeResult(..) ) + +import Data.Monoid + ( Monoid(mempty) ) +import Data.Either + ( partitionEithers ) +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Set as Set +import Data.Set (Set) +import Control.Exception + ( assert ) + + +-- | A set of satisfiable constraints on a set of packages. +-- +-- The 'Constraints' type keeps track of a set of targets (identified by +-- package name) that we know that we need. It also keeps track of a set of +-- constraints over all packages in the environment. +-- +-- It maintains the guarantee that, for the target set, the constraints are +-- satisfiable, meaning that there is at least one instance available for each +-- package name that satisfies the constraints on that package name. +-- +-- Note that it is possible to over-constrain a package in the environment that +-- is not in the target set -- the satisfiability guarantee is only maintained +-- for the target set. This is useful because it allows us to exclude packages +-- without needing to know if it would ever be needed or not (e.g. allows +-- excluding broken installed packages). +-- +-- Adding a constraint for a target package can fail if it would mean that +-- there are no remaining choices. +-- +-- Adding a constraint for package that is not a target never fails. +-- +-- Adding a new target package can fail if that package already has conflicting +-- constraints. +-- +data (Package installed, Package source) + => Constraints installed source reason + = Constraints + + -- | Targets that we know we need. This is the set for which we + -- guarantee the constraints are satisfiable. + !(Set PackageName) + + -- | The available/remaining set. These are packages that have available + -- choices remaining. This is guaranteed to cover the target packages, + -- but can also cover other packages in the environment. New targets can + -- only be added if there are available choices remaining for them. + !(PackageIndex (InstalledOrSource installed source)) + + -- | The excluded set. Choices that we have excluded by applying + -- constraints. Excluded choices are tagged with the reason. + !(PackageIndex (ExcludedPkg (InstalledOrSource installed source) reason)) + + -- | Paired choices, this is an ugly hack. + !(Map PackageName (Version, Version)) + + -- | Purely for the invariant, we keep a copy of the original index + !(PackageIndex (InstalledOrSource installed source)) + + +-- | Reasons for excluding all, or some choices for a package version. +-- +-- Each package version can have a source instance, an installed instance or +-- both. We distinguish reasons for constraints that excluded both instances, +-- from reasons for constraints that excluded just one instance. +-- +data ExcludedPkg pkg reason + = ExcludedPkg pkg + [reason] -- ^ reasons for excluding both source and installed instances + [reason] -- ^ reasons for excluding the installed instance + [reason] -- ^ reasons for excluding the source instance + +instance Package pkg => Package (ExcludedPkg pkg reason) where + packageId (ExcludedPkg p _ _ _) = packageId p + + +-- | There is a conservation of packages property. Packages are never gained or +-- lost, they just transfer from the remaining set to the excluded set. +-- +invariant :: (Package installed, Package source) + => Constraints installed source a -> Bool +invariant (Constraints targets available excluded _ original) = + + -- Relationship between available, excluded and original + all check merged + + -- targets is a subset of available + && all (PackageIndex.elemByPackageName available) (Set.elems targets) + + where + merged = mergeBy (\a b -> packageId a `compare` mergedPackageId b) + (PackageIndex.allPackages original) + (mergeBy (\a b -> packageId a `compare` packageId b) + (PackageIndex.allPackages available) + (PackageIndex.allPackages excluded)) + where + mergedPackageId (OnlyInLeft p ) = packageId p + mergedPackageId (OnlyInRight p) = packageId p + mergedPackageId (InBoth p _) = packageId p + + -- If the package was originally installed only, then + check (InBoth (InstalledOnly _) cur) = case cur of + -- now it's either still remaining as installed only + OnlyInLeft (InstalledOnly _) -> True + -- or it has been excluded + OnlyInRight (ExcludedPkg (InstalledOnly _) [] (_:_) []) -> True + _ -> False + + -- If the package was originally available only, then + check (InBoth (SourceOnly _) cur) = case cur of + -- now it's either still remaining as source only + OnlyInLeft (SourceOnly _) -> True + -- or it has been excluded + OnlyInRight (ExcludedPkg (SourceOnly _) [] [] (_:_)) -> True + _ -> False + + -- If the package was originally installed and source, then + check (InBoth (InstalledAndSource _ _) cur) = case cur of + -- We can have both remaining: + OnlyInLeft (InstalledAndSource _ _) -> True + + -- both excluded, in particular it can have had the just source or + -- installed excluded and later had both excluded so we do not mind if + -- the source or installed excluded is empty or non-empty. + OnlyInRight (ExcludedPkg (InstalledAndSource _ _) _ _ _) -> True + + -- the installed remaining and the source excluded: + InBoth (InstalledOnly _) + (ExcludedPkg (SourceOnly _) [] [] (_:_)) -> True + + -- the source remaining and the installed excluded: + InBoth (SourceOnly _) + (ExcludedPkg (InstalledOnly _) [] (_:_) []) -> True + _ -> False + + check _ = False + + +-- | An update to the constraints can move packages between the two piles +-- but not gain or loose packages. +transitionsTo :: (Package installed, Package source) + => Constraints installed source a + -> Constraints installed source a -> Bool +transitionsTo constraints @(Constraints _ available excluded _ _) + constraints'@(Constraints _ available' excluded' _ _) = + + invariant constraints && invariant constraints' + && null availableGained && null excludedLost + && map (mapInstalledOrSource packageId packageId) availableLost + == map (mapInstalledOrSource packageId packageId) excludedGained + + where + (availableLost, availableGained) + = partitionEithers (foldr lostAndGained [] availableChange) + + (excludedLost, excludedGained) + = partitionEithers (foldr lostAndGained [] excludedChange) + + availableChange = + mergeBy (\a b -> packageId a `compare` packageId b) + (PackageIndex.allPackages available) + (PackageIndex.allPackages available') + + excludedChange = + mergeBy (\a b -> packageId a `compare` packageId b) + [ pkg | ExcludedPkg pkg _ _ _ <- PackageIndex.allPackages excluded ] + [ pkg | ExcludedPkg pkg _ _ _ <- PackageIndex.allPackages excluded' ] + + lostAndGained mr rest = case mr of + OnlyInLeft pkg -> Left pkg : rest + InBoth (InstalledAndSource pkg _) + (SourceOnly _) -> Left (InstalledOnly pkg) : rest + InBoth (InstalledAndSource _ pkg) + (InstalledOnly _) -> Left (SourceOnly pkg) : rest + InBoth (SourceOnly _) + (InstalledAndSource pkg _) -> Right (InstalledOnly pkg) : rest + InBoth (InstalledOnly _) + (InstalledAndSource _ pkg) -> Right (SourceOnly pkg) : rest + OnlyInRight pkg -> Right pkg : rest + _ -> rest + + mapInstalledOrSource f g pkg = case pkg of + InstalledOnly a -> InstalledOnly (f a) + SourceOnly b -> SourceOnly (g b) + InstalledAndSource a b -> InstalledAndSource (f a) (g b) + + +-- | We construct 'Constraints' with an initial 'PackageIndex' of all the +-- packages available. +-- +empty :: (PackageFixedDeps installed, Package source) + => PackageIndex installed + -> PackageIndex source + -> Constraints installed source reason +empty installed source = + Constraints targets pkgs excluded pairs pkgs + where + targets = mempty + excluded = mempty + pkgs = PackageIndex.fromList + . map toInstalledOrSource + $ mergeBy (\a b -> packageId a `compare` packageId b) + (PackageIndex.allPackages installed) + (PackageIndex.allPackages source) + toInstalledOrSource (OnlyInLeft i ) = InstalledOnly i + toInstalledOrSource (OnlyInRight a) = SourceOnly a + toInstalledOrSource (InBoth i a) = InstalledAndSource i a + + -- pick up cases like base-3 and 4 where one version depends on the other: + pairs = Map.fromList + [ (name, (packageVersion pkgid1, packageVersion pkgid2)) + | [pkg1, pkg2] <- PackageIndex.allPackagesByName installed + , let name = packageName pkg1 + pkgid1 = packageId pkg1 + pkgid2 = packageId pkg2 + , any ((pkgid1==) . packageId) (depends pkg2) + || any ((pkgid2==) . packageId) (depends pkg1) ] + + +-- | The package targets. +-- +packages :: (Package installed, Package source) + => Constraints installed source reason + -> Set PackageName +packages (Constraints ts _ _ _ _) = ts + + +-- | The package choices that are still available. +-- +choices :: (Package installed, Package source) + => Constraints installed source reason + -> PackageIndex (InstalledOrSource installed source) +choices (Constraints _ available _ _ _) = available + +isPaired :: (Package installed, Package source) + => Constraints installed source reason + -> PackageId -> Maybe PackageId +isPaired (Constraints _ _ _ pairs _) (PackageIdentifier name version) = + case Map.lookup name pairs of + Just (v1, v2) + | version == v1 -> Just (PackageIdentifier name v2) + | version == v2 -> Just (PackageIdentifier name v1) + _ -> Nothing + + +data Satisfiable constraints discarded reason + = Satisfiable constraints discarded + | Unsatisfiable + | ConflictsWith [(PackageId, [reason])] + + +addTarget :: (Package installed, Package source) + => PackageName + -> Constraints installed source reason + -> Satisfiable (Constraints installed source reason) + () reason +addTarget pkgname + constraints@(Constraints targets available excluded paired original) + + -- If it's already a target then there's no change + | pkgname `Set.member` targets + = Satisfiable constraints () + + -- If there is some possible choice available for this target then we're ok + | PackageIndex.elemByPackageName available pkgname + = let targets' = Set.insert pkgname targets + constraints' = Constraints targets' available excluded paired original + in assert (constraints `transitionsTo` constraints') $ + Satisfiable constraints' () + + -- If it's not available and it is excluded then we return the conflicts + | PackageIndex.elemByPackageName excluded pkgname + = ConflictsWith conflicts + + -- Otherwise, it's not available and it has not been excluded so the + -- package is simply completely unknown. + | otherwise + = Unsatisfiable + + where + conflicts = + [ (packageId pkg, reasons) + | let excludedChoices = PackageIndex.lookupPackageName excluded pkgname + , ExcludedPkg pkg isReasons iReasons sReasons <- excludedChoices + , let reasons = isReasons ++ iReasons ++ sReasons ] + + +constrain :: (Package installed, Package source) + => PackageName -- ^ which package to constrain + -> (Version -> Bool -> Bool) -- ^ the constraint test + -> reason -- ^ the reason for the constraint + -> Constraints installed source reason + -> Satisfiable (Constraints installed source reason) + [PackageId] reason +constrain pkgname constraint reason + constraints@(Constraints targets available excluded paired original) + + | pkgname `Set.member` targets && not anyRemaining + = if null conflicts then Unsatisfiable + else ConflictsWith conflicts + + | otherwise + = let constraints' = Constraints targets available' excluded' paired original + in assert (constraints `transitionsTo` constraints') $ + Satisfiable constraints' (map packageId newExcluded) + + where + -- This tells us if any packages would remain at all for this package name if + -- we applied this constraint. This amounts to checking if any package + -- satisfies the given constraint, including version range and installation + -- status. + -- + (available', excluded', newExcluded, anyRemaining, conflicts) = + updatePkgsStatus + available excluded + [] False [] + (mergeBy (\pkg pkg' -> packageVersion pkg `compare` packageVersion pkg') + (PackageIndex.lookupPackageName available pkgname) + (PackageIndex.lookupPackageName excluded pkgname)) + + testConstraint pkg = + let ver = packageVersion pkg in + case Map.lookup (packageName pkg) paired of + + Just (v1, v2) + | ver == v1 || ver == v2 + -> case pkg of + InstalledOnly ipkg -> InstalledOnly (ipkg, iOk) + SourceOnly spkg -> SourceOnly (spkg, sOk) + InstalledAndSource ipkg spkg -> + InstalledAndSource (ipkg, iOk) (spkg, sOk) + where + iOk = constraint v1 True || constraint v2 True + sOk = constraint v1 False || constraint v2 False + + _ -> case pkg of + InstalledOnly ipkg -> InstalledOnly (ipkg, iOk) + SourceOnly spkg -> SourceOnly (spkg, sOk) + InstalledAndSource ipkg spkg -> + InstalledAndSource (ipkg, iOk) (spkg, sOk) + where + iOk = constraint ver True + sOk = constraint ver False + + -- For the info about available and excluded versions of the package in + -- question, update the info given the current constraint + -- + -- We update the available package map and the excluded package map + -- we also collect: + -- * the change in available packages (for logging) + -- * whether there are any remaining choices + -- * any constraints that conflict with the current constraint + + updatePkgsStatus _ _ nePkgs ok cs _ + | seq nePkgs $ seq ok $ seq cs False = undefined + + updatePkgsStatus aPkgs ePkgs nePkgs ok cs [] + = (aPkgs, ePkgs, reverse nePkgs, ok, reverse cs) + + updatePkgsStatus aPkgs ePkgs nePkgs ok cs (pkg:pkgs) = + let (aPkgs', ePkgs', mnePkg, ok', mc) = updatePkgStatus aPkgs ePkgs pkg + nePkgs' = maybeCons mnePkg nePkgs + cs' = maybeCons mc cs + in updatePkgsStatus aPkgs' ePkgs' nePkgs' (ok' || ok) cs' pkgs + + maybeCons Nothing xs = xs + maybeCons (Just x) xs = x:xs + + + -- For the info about an available or excluded version of the package in + -- question, update the info given the current constraint. + -- + updatePkgStatus aPkgs ePkgs pkg = + case viewPackageStatus pkg of + AllAvailable (InstalledOnly (aiPkg, False)) -> + removeAvailable False + (InstalledOnly aiPkg) + (PackageIndex.deletePackageId pkgid) + (ExcludedPkg (InstalledOnly aiPkg) [] [reason] []) + Nothing + + AllAvailable (SourceOnly (asPkg, False)) -> + removeAvailable False + (SourceOnly asPkg) + (PackageIndex.deletePackageId pkgid) + (ExcludedPkg (SourceOnly asPkg) [] [] [reason]) + Nothing + + AllAvailable (InstalledAndSource (aiPkg, False) (asPkg, False)) -> + removeAvailable False + (InstalledAndSource aiPkg asPkg) + (PackageIndex.deletePackageId pkgid) + (ExcludedPkg (InstalledAndSource aiPkg asPkg) [reason] [] []) + Nothing + + AllAvailable (InstalledAndSource (aiPkg, True) (asPkg, False)) -> + removeAvailable True + (SourceOnly asPkg) + (PackageIndex.insert (InstalledOnly aiPkg)) + (ExcludedPkg (SourceOnly asPkg) [] [] [reason]) + Nothing + + AllAvailable (InstalledAndSource (aiPkg, False) (asPkg, True)) -> + removeAvailable True + (InstalledOnly aiPkg) + (PackageIndex.insert (SourceOnly asPkg)) + (ExcludedPkg (InstalledOnly aiPkg) [] [reason] []) + Nothing + + AllAvailable _ -> noChange True Nothing + + AvailableExcluded (aiPkg, False) (ExcludedPkg (esPkg, False) _ _ srs) -> + removeAvailable False + (InstalledOnly aiPkg) + (PackageIndex.deletePackageId pkgid) + (ExcludedPkg (InstalledAndSource aiPkg esPkg) [reason] [] srs) + Nothing + + AvailableExcluded (_aiPkg, True) (ExcludedPkg (esPkg, False) _ _ srs) -> + addExtraExclusion True + (ExcludedPkg (SourceOnly esPkg) [] [] (reason:srs)) + Nothing + + AvailableExcluded (aiPkg, False) (ExcludedPkg (esPkg, True) _ _ srs) -> + removeAvailable True + (InstalledOnly aiPkg) + (PackageIndex.deletePackageId pkgid) + (ExcludedPkg (InstalledAndSource aiPkg esPkg) [] [reason] srs) + (Just (pkgid, srs)) + + AvailableExcluded (_aiPkg, True) (ExcludedPkg (_esPkg, True) _ _ srs) -> + noChange True + (Just (pkgid, srs)) + + ExcludedAvailable (ExcludedPkg (eiPkg, False) _ irs _) (asPkg, False) -> + removeAvailable False + (SourceOnly asPkg) + (PackageIndex.deletePackageId pkgid) + (ExcludedPkg (InstalledAndSource eiPkg asPkg) [reason] irs []) + Nothing + + ExcludedAvailable (ExcludedPkg (eiPkg, True) _ irs _) (asPkg, False) -> + removeAvailable False + (SourceOnly asPkg) + (PackageIndex.deletePackageId pkgid) + (ExcludedPkg (InstalledAndSource eiPkg asPkg) [] irs [reason]) + (Just (pkgid, irs)) + + ExcludedAvailable (ExcludedPkg (eiPkg, False) _ irs _) (_asPkg, True) -> + addExtraExclusion True + (ExcludedPkg (InstalledOnly eiPkg) [] (reason:irs) []) + Nothing + + ExcludedAvailable (ExcludedPkg (_eiPkg, True) _ irs _) (_asPkg, True) -> + noChange True + (Just (pkgid, irs)) + + AllExcluded (ExcludedPkg (InstalledOnly (eiPkg, False)) _ irs _) -> + addExtraExclusion False + (ExcludedPkg (InstalledOnly eiPkg) [] (reason:irs) []) + Nothing + + AllExcluded (ExcludedPkg (InstalledOnly (_eiPkg, True)) _ irs _) -> + noChange False + (Just (pkgid, irs)) + + AllExcluded (ExcludedPkg (SourceOnly (esPkg, False)) _ _ srs) -> + addExtraExclusion False + (ExcludedPkg (SourceOnly esPkg) [] [] (reason:srs)) + Nothing + + AllExcluded (ExcludedPkg (SourceOnly (_esPkg, True)) _ _ srs) -> + noChange False + (Just (pkgid, srs)) + + AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, False) (esPkg, False)) isrs irs srs) -> + addExtraExclusion False + (ExcludedPkg (InstalledAndSource eiPkg esPkg) (reason:isrs) irs srs) + Nothing + + AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, True) (esPkg, False)) isrs irs srs) -> + addExtraExclusion False + (ExcludedPkg (InstalledAndSource eiPkg esPkg) isrs irs (reason:srs)) + (Just (pkgid, irs)) + + AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, False) (esPkg, True)) isrs irs srs) -> + addExtraExclusion False + (ExcludedPkg (InstalledAndSource eiPkg esPkg) isrs (reason:irs) srs) + (Just (pkgid, srs)) + + AllExcluded (ExcludedPkg (InstalledAndSource (_eiPkg, True) (_esPkg, True)) isrs irs srs) -> + noChange False + (Just (pkgid, isrs ++ irs ++ srs)) + + where + removeAvailable ok nePkg adjustAvailable ePkg c = + let aPkgs' = adjustAvailable aPkgs + ePkgs' = PackageIndex.insert ePkg ePkgs + in aPkgs' `seq` ePkgs' `seq` + (aPkgs', ePkgs', Just nePkg, ok, c) + + addExtraExclusion ok ePkg c = + let ePkgs' = PackageIndex.insert ePkg ePkgs + in ePkgs' `seq` + (aPkgs, ePkgs', Nothing, ok, c) + + noChange ok c = + (aPkgs, ePkgs, Nothing, ok, c) + + pkgid = case pkg of OnlyInLeft p -> packageId p + OnlyInRight p -> packageId p + InBoth p _ -> packageId p + + + viewPackageStatus + :: (Package installed, Package source) + => MergeResult (InstalledOrSource installed source) + (ExcludedPkg (InstalledOrSource installed source) reason) + -> PackageStatus (installed, Bool) (source, Bool) reason + viewPackageStatus merged = + case merged of + OnlyInLeft aPkg -> + AllAvailable (testConstraint aPkg) + + OnlyInRight (ExcludedPkg ePkg isrs irs srs) -> + AllExcluded (ExcludedPkg (testConstraint ePkg) isrs irs srs) + + InBoth (InstalledOnly aiPkg) + (ExcludedPkg (SourceOnly esPkg) [] [] srs) -> + case testConstraint (InstalledAndSource aiPkg esPkg) of + InstalledAndSource (aiPkg', iOk) (esPkg', sOk) -> + AvailableExcluded (aiPkg', iOk) (ExcludedPkg (esPkg', sOk) [] [] srs) + _ -> impossible + + InBoth (SourceOnly asPkg) + (ExcludedPkg (InstalledOnly eiPkg) [] irs []) -> + case testConstraint (InstalledAndSource eiPkg asPkg) of + InstalledAndSource (eiPkg', iOk) (asPkg', sOk) -> + ExcludedAvailable (ExcludedPkg (eiPkg', iOk) [] irs []) (asPkg', sOk) + _ -> impossible + _ -> impossible + where + impossible = error "impossible: viewPackageStatus invariant violation" + +-- A intermediate structure that enumerates all the possible cases given the +-- invariant. This helps us to get simpler and complete pattern matching in +-- updatePkg above +-- +data PackageStatus installed source reason + = AllAvailable (InstalledOrSource installed source) + | AllExcluded (ExcludedPkg (InstalledOrSource installed source) reason) + | AvailableExcluded installed (ExcludedPkg source reason) + | ExcludedAvailable (ExcludedPkg installed reason) source + + +conflicting :: (Package installed, Package source) + => Constraints installed source reason + -> Dependency + -> [(PackageId, [reason])] +conflicting (Constraints _ _ excluded _ _) dep = + [ (packageId pkg, reasonsAll ++ reasonsAvail ++ reasonsInstalled) --TODO + | ExcludedPkg pkg reasonsAll reasonsAvail reasonsInstalled <- + PackageIndex.lookupDependency excluded dep ] diff --git a/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs b/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs @@ -0,0 +1,89 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency.TopDown.Types +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Types for the top-down dependency resolver. +----------------------------------------------------------------------------- +module Distribution.Client.Dependency.TopDown.Types where + +import Distribution.Client.Types + ( SourcePackage(..), InstalledPackage ) + +import Distribution.Package + ( PackageIdentifier, Dependency + , Package(packageId), PackageFixedDeps(depends) ) +import Distribution.PackageDescription + ( FlagAssignment ) + +-- ------------------------------------------------------------ +-- * The various kinds of packages +-- ------------------------------------------------------------ + +type SelectablePackage + = InstalledOrSource InstalledPackageEx UnconfiguredPackage + +type SelectedPackage + = InstalledOrSource InstalledPackageEx SemiConfiguredPackage + +data InstalledOrSource installed source + = InstalledOnly installed + | SourceOnly source + | InstalledAndSource installed source + deriving Eq + +type TopologicalSortNumber = Int + +data InstalledPackageEx + = InstalledPackageEx + InstalledPackage + !TopologicalSortNumber + [PackageIdentifier] -- transative closure of installed deps + +data UnconfiguredPackage + = UnconfiguredPackage + SourcePackage + !TopologicalSortNumber + FlagAssignment + +data SemiConfiguredPackage + = SemiConfiguredPackage + SourcePackage -- package info + FlagAssignment -- total flag assignment for the package + [Dependency] -- dependencies we end up with when we apply + -- the flag assignment + +instance Package InstalledPackageEx where + packageId (InstalledPackageEx p _ _) = packageId p + +instance PackageFixedDeps InstalledPackageEx where + depends (InstalledPackageEx _ _ deps) = deps + +instance Package UnconfiguredPackage where + packageId (UnconfiguredPackage p _ _) = packageId p + +instance Package SemiConfiguredPackage where + packageId (SemiConfiguredPackage p _ _) = packageId p + +instance (Package installed, Package source) + => Package (InstalledOrSource installed source) where + packageId (InstalledOnly p ) = packageId p + packageId (SourceOnly p ) = packageId p + packageId (InstalledAndSource p _) = packageId p + + +-- | We can have constraints on selecting just installed or just source +-- packages. +-- +-- In particular, installed packages can only depend on other installed +-- packages while packages that are not yet installed but which we plan to +-- install can depend on installed or other not-yet-installed packages. +-- +data InstalledConstraint = InstalledConstraint + | SourceConstraint + deriving (Eq, Show) diff --git a/cabal/cabal-install/Distribution/Client/Dependency/Types.hs b/cabal/cabal-install/Distribution/Client/Dependency/Types.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Dependency/Types.hs @@ -0,0 +1,116 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Dependency.Types +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Common types for dependency resolution. +----------------------------------------------------------------------------- +module Distribution.Client.Dependency.Types ( + DependencyResolver, + + PackageConstraint(..), + PackagePreferences(..), + InstalledPreference(..), + + Progress(..), + foldProgress, + ) where + +import Distribution.Client.Types + ( SourcePackage(..), InstalledPackage ) +import qualified Distribution.Client.InstallPlan as InstallPlan + +import Distribution.PackageDescription + ( FlagAssignment ) +import Distribution.Client.PackageIndex + ( PackageIndex ) +import Distribution.Package + ( PackageName ) +import Distribution.Version + ( VersionRange ) +import Distribution.Compiler + ( CompilerId ) +import Distribution.System + ( Platform ) + +import Prelude hiding (fail) + +-- | A dependency resolver is a function that works out an installation plan +-- given the set of installed and available packages and a set of deps to +-- solve for. +-- +-- The reason for this interface is because there are dozens of approaches to +-- solving the package dependency problem and we want to make it easy to swap +-- in alternatives. +-- +type DependencyResolver = Platform + -> CompilerId + -> PackageIndex InstalledPackage + -> PackageIndex SourcePackage + -> (PackageName -> PackagePreferences) + -> [PackageConstraint] + -> [PackageName] + -> Progress String String [InstallPlan.PlanPackage] + +-- | Per-package constraints. Package constraints must be respected by the +-- solver. Multiple constraints for each package can be given, though obviously +-- it is possible to construct conflicting constraints (eg impossible version +-- range or inconsistent flag assignment). +-- +data PackageConstraint + = PackageConstraintVersion PackageName VersionRange + | PackageConstraintInstalled PackageName + | PackageConstraintSource PackageName + | PackageConstraintFlags PackageName FlagAssignment + deriving (Show,Eq) + +-- | A per-package preference on the version. It is a soft constraint that the +-- 'DependencyResolver' should try to respect where possible. It consists of +-- a 'InstalledPreference' which says if we prefer versions of packages +-- that are already installed. It also hase a 'PackageVersionPreference' which +-- is a suggested constraint on the version number. The resolver should try to +-- use package versions that satisfy the suggested version constraint. +-- +-- It is not specified if preferences on some packages are more important than +-- others. +-- +data PackagePreferences = PackagePreferences VersionRange InstalledPreference + +-- | Wether we prefer an installed version of a package or simply the latest +-- version. +-- +data InstalledPreference = PreferInstalled | PreferLatest + +-- | A type to represent the unfolding of an expensive long running +-- calculation that may fail. We may get intermediate steps before the final +-- retult which may be used to indicate progress and\/or logging messages. +-- +data Progress step fail done = Step step (Progress step fail done) + | Fail fail + | Done done + +-- | Consume a 'Progres' calculation. Much like 'foldr' for lists but with +-- two base cases, one for a final result and one for failure. +-- +-- Eg to convert into a simple 'Either' result use: +-- +-- > foldProgress (flip const) Left Right +-- +foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) + -> Progress step fail done -> a +foldProgress step fail done = fold + where fold (Step s p) = step s (fold p) + fold (Fail f) = fail f + fold (Done r) = done r + +instance Functor (Progress step fail) where + fmap f = foldProgress Step Fail (Done . f) + +instance Monad (Progress step fail) where + return a = Done a + p >>= f = foldProgress Step Fail f p diff --git a/cabal/cabal-install/Distribution/Client/Fetch.hs b/cabal/cabal-install/Distribution/Client/Fetch.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Fetch.hs @@ -0,0 +1,173 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Fetch +-- Copyright : (c) David Himmelstrup 2005 +-- Duncan Coutts 2011 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- The cabal fetch command +----------------------------------------------------------------------------- +module Distribution.Client.Fetch ( + fetch, + ) where + +import Distribution.Client.Types +import Distribution.Client.Targets +import Distribution.Client.FetchUtils hiding (fetchPackage) +import Distribution.Client.Dependency +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Client.IndexUtils as IndexUtils + ( getSourcePackages, getInstalledPackages ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.Setup + ( GlobalFlags(..), FetchFlags(..) ) + +import Distribution.Package + ( packageId ) +import Distribution.Simple.Compiler + ( Compiler(compilerId), PackageDBStack ) +import Distribution.Simple.Program + ( ProgramConfiguration ) +import Distribution.Simple.Setup + ( fromFlag ) +import Distribution.Simple.Utils + ( die, notice, debug ) +import Distribution.System + ( buildPlatform ) +import Distribution.Text + ( display ) +import Distribution.Verbosity + ( Verbosity ) + +import Control.Monad + ( filterM ) + +-- ------------------------------------------------------------ +-- * The fetch command +-- ------------------------------------------------------------ + +--TODO: +-- * add fetch -o support +-- * support tarball URLs via ad-hoc download cache (or in -o mode?) +-- * suggest using --no-deps, unpack or fetch -o if deps cannot be satisfied +-- * Port various flags from install: +-- * --updage-dependencies +-- * --constraint and --preference +-- * --only-dependencies, but note it conflicts with --no-deps + + +-- | Fetch a list of packages and their dependencies. +-- +fetch :: Verbosity + -> PackageDBStack + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> GlobalFlags + -> FetchFlags + -> [UserTarget] + -> IO () +fetch verbosity _ _ _ _ _ _ [] = + notice verbosity "No packages requested. Nothing to do." + +fetch verbosity packageDBs repos comp conf + globalFlags fetchFlags userTargets = do + + mapM_ checkTarget userTargets + + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf + sourcePkgDb <- getSourcePackages verbosity repos + + pkgSpecifiers <- resolveUserTargets verbosity + (fromFlag $ globalWorldFile globalFlags) + (packageIndex sourcePkgDb) + userTargets + + pkgs <- planPackages + verbosity comp fetchFlags + installedPkgIndex sourcePkgDb pkgSpecifiers + + pkgs' <- filterM (fmap not . isFetched . packageSource) pkgs + if null pkgs' + --TODO: when we add support for remote tarballs then this message + -- will need to be changed because for remote tarballs we fetch them + -- at the earlier phase. + then notice verbosity $ "No packages need to be fetched. " + ++ "All the requested packages are already local " + ++ "or cached locally." + else if dryRun + then notice verbosity $ unlines $ + "The following packages would be fetched:" + : map (display . packageId) pkgs' + + else mapM_ (fetchPackage verbosity . packageSource) pkgs' + + where + dryRun = fromFlag (fetchDryRun fetchFlags) + +planPackages :: Verbosity + -> Compiler + -> FetchFlags + -> PackageIndex InstalledPackage + -> SourcePackageDb + -> [PackageSpecifier SourcePackage] + -> IO [SourcePackage] +planPackages verbosity comp fetchFlags + installedPkgIndex sourcePkgDb pkgSpecifiers + + | includeDependencies = do + notice verbosity "Resolving dependencies..." + installPlan <- foldProgress logMsg die return $ + resolveDependencies + buildPlatform (compilerId comp) + resolverParams + + -- The packages we want to fetch are those packages the 'InstallPlan' + -- that are in the 'InstallPlan.Configured' state. + return + [ pkg + | (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _)) + <- InstallPlan.toList installPlan ] + + | otherwise = + either (die . unlines . map show) return $ + resolveWithoutDependencies resolverParams + + where + resolverParams = + + -- Reinstall the targets given on the command line so that the dep + -- resolver will decide that they need fetching, even if they're + -- already installed. Sicne we want to get the source packages of + -- things we might have installed (but not have the sources for). + reinstallTargets + + $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers + + includeDependencies = fromFlag (fetchDeps fetchFlags) + logMsg message rest = debug verbosity message >> rest + + +checkTarget :: UserTarget -> IO () +checkTarget target = case target of + UserTargetRemoteTarball _uri + -> die $ "The 'fetch' command does not yet support remote tarballs. " + ++ "In the meantime you can use the 'unpack' commands." + _ -> return () + +fetchPackage :: Verbosity -> PackageLocation a -> IO () +fetchPackage verbosity pkgsrc = case pkgsrc of + LocalUnpackedPackage _dir -> return () + LocalTarballPackage _file -> return () + + RemoteTarballPackage _uri _ -> + die $ "The 'fetch' command does not yet support remote tarballs. " + ++ "In the meantime you can use the 'unpack' commands." + + RepoTarballPackage repo pkgid _ -> do + _ <- fetchRepoTarball verbosity repo pkgid + return () diff --git a/cabal/cabal-install/Distribution/Client/FetchUtils.hs b/cabal/cabal-install/Distribution/Client/FetchUtils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/FetchUtils.hs @@ -0,0 +1,193 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.FetchUtils +-- Copyright : (c) David Himmelstrup 2005 +-- Duncan Coutts 2011 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Functions for fetching packages +----------------------------------------------------------------------------- +module Distribution.Client.FetchUtils ( + + -- * fetching packages + fetchPackage, + isFetched, + checkFetched, + + -- ** specifically for repo packages + fetchRepoTarball, + + -- * fetching other things + downloadIndex, + ) where + +import Distribution.Client.Types +import Distribution.Client.HttpUtils + ( downloadURI, isOldHackageURI ) + +import Distribution.Package + ( PackageId, packageName, packageVersion ) +import Distribution.Simple.Utils + ( notice, info, setupMessage ) +import Distribution.Text + ( display ) +import Distribution.Verbosity + ( Verbosity ) + +import Data.Maybe +import System.Directory + ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory ) +import System.IO + ( openTempFile, hClose ) +import System.FilePath + ( (), (<.>) ) +import qualified System.FilePath.Posix as FilePath.Posix + ( combine, joinPath ) +import Network.URI + ( URI(uriPath) ) + +-- ------------------------------------------------------------ +-- * Actually fetch things +-- ------------------------------------------------------------ + +-- | Returns @True@ if the package has already been fetched +-- or does not need fetching. +-- +isFetched :: PackageLocation (Maybe FilePath) -> IO Bool +isFetched loc = case loc of + LocalUnpackedPackage _dir -> return True + LocalTarballPackage _file -> return True + RemoteTarballPackage _uri local -> return (isJust local) + RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid) + + +checkFetched :: PackageLocation (Maybe FilePath) + -> IO (Maybe (PackageLocation FilePath)) +checkFetched loc = case loc of + LocalUnpackedPackage dir -> + return (Just $ LocalUnpackedPackage dir) + LocalTarballPackage file -> + return (Just $ LocalTarballPackage file) + RemoteTarballPackage uri (Just file) -> + return (Just $ RemoteTarballPackage uri file) + RepoTarballPackage repo pkgid (Just file) -> + return (Just $ RepoTarballPackage repo pkgid file) + + RemoteTarballPackage _uri Nothing -> return Nothing + RepoTarballPackage repo pkgid Nothing -> do + let file = packageFile repo pkgid + exists <- doesFileExist file + if exists + then return (Just $ RepoTarballPackage repo pkgid file) + else return Nothing + + +-- | Fetch a package if we don't have it already. +-- +fetchPackage :: Verbosity + -> PackageLocation (Maybe FilePath) + -> IO (PackageLocation FilePath) +fetchPackage verbosity loc = case loc of + LocalUnpackedPackage dir -> + return (LocalUnpackedPackage dir) + LocalTarballPackage file -> + return (LocalTarballPackage file) + RemoteTarballPackage uri (Just file) -> + return (RemoteTarballPackage uri file) + RepoTarballPackage repo pkgid (Just file) -> + return (RepoTarballPackage repo pkgid file) + + RemoteTarballPackage uri Nothing -> do + path <- downloadTarballPackage uri + return (RemoteTarballPackage uri path) + RepoTarballPackage repo pkgid Nothing -> do + local <- fetchRepoTarball verbosity repo pkgid + return (RepoTarballPackage repo pkgid local) + where + downloadTarballPackage uri = do + notice verbosity ("Downloading " ++ show uri) + tmpdir <- getTemporaryDirectory + (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz" + hClose hnd + downloadURI verbosity uri path + return path + + +-- | Fetch a repo package if we don't have it already. +-- +fetchRepoTarball :: Verbosity -> Repo -> PackageId -> IO FilePath +fetchRepoTarball verbosity repo pkgid = do + fetched <- doesFileExist (packageFile repo pkgid) + if fetched + then do info verbosity $ display pkgid ++ " has already been downloaded." + return (packageFile repo pkgid) + else do setupMessage verbosity "Downloading" pkgid + downloadRepoPackage + where + downloadRepoPackage = case repoKind repo of + Right LocalRepo -> return (packageFile repo pkgid) + + Left remoteRepo -> do + let uri = packageURI remoteRepo pkgid + dir = packageDir repo pkgid + path = packageFile repo pkgid + createDirectoryIfMissing True dir + downloadURI verbosity uri path + return path + +-- | Downloads an index file to [config-dir/packages/serv-id]. +-- +downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO FilePath +downloadIndex verbosity repo cacheDir = do + let uri = (remoteRepoURI repo) { + uriPath = uriPath (remoteRepoURI repo) + `FilePath.Posix.combine` "00-index.tar.gz" + } + path = cacheDir "00-index" <.> "tar.gz" + createDirectoryIfMissing True cacheDir + downloadURI verbosity uri path + return path + + +-- ------------------------------------------------------------ +-- * Path utilities +-- ------------------------------------------------------------ + +-- | Generate the full path to the locally cached copy of +-- the tarball for a given @PackageIdentifer@. +-- +packageFile :: Repo -> PackageId -> FilePath +packageFile repo pkgid = packageDir repo pkgid + display pkgid + <.> "tar.gz" + +-- | Generate the full path to the directory where the local cached copy of +-- the tarball for a given @PackageIdentifer@ is stored. +-- +packageDir :: Repo -> PackageId -> FilePath +packageDir repo pkgid = repoLocalDir repo + display (packageName pkgid) + display (packageVersion pkgid) + +-- | Generate the URI of the tarball for a given package. +-- +packageURI :: RemoteRepo -> PackageId -> URI +packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) = + (remoteRepoURI repo) { + uriPath = FilePath.Posix.joinPath + [uriPath (remoteRepoURI repo) + ,display (packageName pkgid) + ,display (packageVersion pkgid) + ,display pkgid <.> "tar.gz"] + } +packageURI repo pkgid = + (remoteRepoURI repo) { + uriPath = FilePath.Posix.joinPath + [uriPath (remoteRepoURI repo) + ,"package" + ,display pkgid <.> "tar.gz"] + } diff --git a/cabal/cabal-install/Distribution/Client/GZipUtils.hs b/cabal/cabal-install/Distribution/Client/GZipUtils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/GZipUtils.hs @@ -0,0 +1,44 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.GZipUtils +-- Copyright : (c) Dmitry Astapov 2010 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Provides a convenience functions for working with files that may or may not +-- be zipped. +----------------------------------------------------------------------------- +module Distribution.Client.GZipUtils ( + maybeDecompress, + ) where + +import qualified Data.ByteString.Lazy.Internal as BS (ByteString(..)) +import Data.ByteString.Lazy (ByteString) +import Codec.Compression.GZip +import Codec.Compression.Zlib.Internal + +-- | Attempts to decompress the `bytes' under the assumption that +-- "data format" error at the very beginning of the stream means +-- that it is already decompressed. Caller should make sanity checks +-- to verify that it is not, in fact, garbage. +-- +-- This is to deal with http proxies that lie to us and transparently +-- decompress without removing the content-encoding header. See: +-- +-- +maybeDecompress :: ByteString -> ByteString +maybeDecompress bytes = foldStream $ decompressWithErrors gzipOrZlibFormat defaultDecompressParams bytes + where + -- DataError at the beginning of the stream probably means that stream is not compressed. + -- Returning it as-is. + -- TODO: alternatively, we might consider looking for the two magic bytes + -- at the beginning of the gzip header. + foldStream (StreamError DataError _) = bytes + foldStream somethingElse = doFold somethingElse + + doFold StreamEnd = BS.Empty + doFold (StreamChunk bs stream) = BS.Chunk bs (doFold stream) + doFold (StreamError _ msg) = error $ "Codec.Compression.Zlib: " ++ msg diff --git a/cabal/cabal-install/Distribution/Client/Haddock.hs b/cabal/cabal-install/Distribution/Client/Haddock.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Haddock.hs @@ -0,0 +1,105 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Haddock +-- Copyright : (c) Andrea Vezzosi 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Interfacing with Haddock +-- +----------------------------------------------------------------------------- +module Distribution.Client.Haddock + ( + regenerateHaddockIndex + ) + where + +import Data.Maybe (listToMaybe) +import Data.List (maximumBy) +import Control.Monad (guard) +import System.Directory (createDirectoryIfMissing, doesFileExist, + renameFile) +import System.FilePath ((), splitFileName) +import Distribution.Package (Package(..)) +import Distribution.Simple.Program (haddockProgram, ProgramConfiguration + , rawSystemProgram, requireProgramVersion) +import Distribution.Version (Version(Version), orLaterVersion) +import Distribution.Verbosity (Verbosity) +import Distribution.Text (display) +import Distribution.Client.PackageIndex(PackageIndex, allPackages, + allPackagesByName, fromList) +import Distribution.Simple.Utils + ( comparing, intercalate, debug + , installDirectoryContents, withTempDirectory ) +import Distribution.InstalledPackageInfo as InstalledPackageInfo + ( InstalledPackageInfo + , InstalledPackageInfo_(haddockHTMLs, haddockInterfaces, exposed) ) +import Distribution.Client.Types + ( InstalledPackage(..) ) + +regenerateHaddockIndex :: Verbosity -> PackageIndex InstalledPackage -> ProgramConfiguration -> FilePath -> IO () +regenerateHaddockIndex verbosity pkgs conf index = do + (paths,warns) <- haddockPackagePaths pkgs' + case warns of + Nothing -> return () + Just m -> debug verbosity m + + (confHaddock, _, _) <- + requireProgramVersion verbosity haddockProgram + (orLaterVersion (Version [0,6] [])) conf + + createDirectoryIfMissing True destDir + + withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do + + let flags = [ "--gen-contents" + , "--gen-index" + , "--odir=" ++ tempDir + , "--title=Haskell modules on this system" ] + ++ [ "--read-interface=" ++ html ++ "," ++ interface + | (interface, html) <- paths ] + rawSystemProgram verbosity confHaddock flags + renameFile (tempDir "index.html") (tempDir destFile) + installDirectoryContents verbosity tempDir destDir + + where + (destDir,destFile) = splitFileName index + pkgs' = map (maximumBy $ comparing packageId) + . allPackagesByName + . fromList + . filter exposed + . map (\(InstalledPackage pkg _) -> pkg) + . allPackages + $ pkgs + +haddockPackagePaths :: [InstalledPackageInfo] + -> IO ([(FilePath, FilePath)], Maybe String) +haddockPackagePaths pkgs = do + interfaces <- sequence + [ case interfaceAndHtmlPath pkg of + Just (interface, html) -> do + exists <- doesFileExist interface + if exists + then return (pkgid, Just (interface, html)) + else return (pkgid, Nothing) + Nothing -> return (pkgid, Nothing) + | pkg <- pkgs, let pkgid = packageId pkg ] + + let missing = [ pkgid | (pkgid, Nothing) <- interfaces ] + + warning = "The documentation for the following packages are not " + ++ "installed. No links will be generated to these packages: " + ++ intercalate ", " (map display missing) + + flags = [ x | (_, Just x) <- interfaces ] + + return (flags, if null missing then Nothing else Just warning) + + where + interfaceAndHtmlPath pkg = do + interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg) + html <- listToMaybe (InstalledPackageInfo.haddockHTMLs pkg) + guard (not . null $ html) + return (interface, html) diff --git a/cabal/cabal-install/Distribution/Client/HttpUtils.hs b/cabal/cabal-install/Distribution/Client/HttpUtils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/HttpUtils.hs @@ -0,0 +1,197 @@ +{-# OPTIONS -cpp #-} +----------------------------------------------------------------------------- +-- | Separate module for HTTP actions, using a proxy server if one exists +----------------------------------------------------------------------------- +module Distribution.Client.HttpUtils ( + downloadURI, + getHTTP, + proxy, + isOldHackageURI + ) where + +import Network.HTTP + ( Request (..), Response (..), RequestMethod (..) + , Header(..), HeaderName(..) ) +import Network.URI + ( URI (..), URIAuth (..), parseAbsoluteURI ) +import Network.Stream + ( Result, ConnError(..) ) +import Network.Browser + ( Proxy (..), Authority (..), browse + , setOutHandler, setErrHandler, setProxy, request) +import Control.Monad + ( mplus, join, liftM2 ) +import qualified Data.ByteString.Lazy.Char8 as ByteString +import Data.ByteString.Lazy (ByteString) +#ifdef WIN32 +import System.Win32.Types + ( DWORD, HKEY ) +import System.Win32.Registry + ( hKEY_CURRENT_USER, regOpenKey, regCloseKey + , regQueryValue, regQueryValueEx ) +import Control.Exception + ( bracket ) +import Distribution.Compat.ExceptionCI + ( handleIO ) +import Foreign + ( toBool, Storable(peek, sizeOf), castPtr, alloca ) +#endif +import System.Environment (getEnvironment) + +import qualified Paths_cabal_install (version) +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.Utils + ( die, info, warn, debug + , copyFileVerbose, writeFileAtomic ) +import Distribution.Text + ( display ) +import qualified System.FilePath.Posix as FilePath.Posix + ( splitDirectories ) + +-- FIXME: all this proxy stuff is far too complicated, especially parsing +-- the proxy strings. Network.Browser should have a way to pick up the +-- proxy settings hiding all this system-dependent stuff below. + +-- try to read the system proxy settings on windows or unix +proxyString, envProxyString, registryProxyString :: IO (Maybe String) +#ifdef WIN32 +-- read proxy settings from the windows registry +registryProxyString = handleIO (\_ -> return Nothing) $ + bracket (regOpenKey hive path) regCloseKey $ \hkey -> do + enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable" + if enable + then fmap Just $ regQueryValue hkey (Just "ProxyServer") + else return Nothing + where + -- some sources say proxy settings should be at + -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows + -- \CurrentVersion\Internet Settings\ProxyServer + -- but if the user sets them with IE connection panel they seem to + -- end up in the following place: + hive = hKEY_CURRENT_USER + path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings" + + regQueryValueDWORD :: HKEY -> String -> IO DWORD + regQueryValueDWORD hkey name = alloca $ \ptr -> do + regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD)) + peek ptr +#else +registryProxyString = return Nothing +#endif + +-- read proxy settings by looking for an env var +envProxyString = do + env <- getEnvironment + return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env) + +proxyString = liftM2 mplus envProxyString registryProxyString + + +-- |Get the local proxy settings +proxy :: Verbosity -> IO Proxy +proxy verbosity = do + mstr <- proxyString + case mstr of + Nothing -> return NoProxy + Just str -> case parseHttpProxy str of + Nothing -> do + warn verbosity $ "invalid http proxy uri: " ++ show str + warn verbosity $ "proxy uri must be http with a hostname" + warn verbosity $ "ignoring http proxy, trying a direct connection" + return NoProxy + Just p -> return p +--TODO: print info message when we're using a proxy + +-- | We need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@ +-- which lack the @\"http://\"@ URI scheme. The problem is that +-- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme +-- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@. +-- +-- So our strategy is to try parsing as normal uri first and if it lacks the +-- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix. +-- +parseHttpProxy :: String -> Maybe Proxy +parseHttpProxy str = join + . fmap uri2proxy + $ parseHttpURI str + `mplus` parseHttpURI ("http://" ++ str) + where + parseHttpURI str' = case parseAbsoluteURI str' of + Just uri@URI { uriAuthority = Just _ } + -> Just (fixUserInfo uri) + _ -> Nothing + +fixUserInfo :: URI -> URI +fixUserInfo uri = uri{ uriAuthority = f `fmap` uriAuthority uri } + where + f a@URIAuth{ uriUserInfo = s } = + a{ uriUserInfo = case reverse s of + '@':s' -> reverse s' + _ -> s + } +uri2proxy :: URI -> Maybe Proxy +uri2proxy uri@URI{ uriScheme = "http:" + , uriAuthority = Just (URIAuth auth' host port) + } = Just (Proxy (host ++ port) auth) + where auth = if null auth' + then Nothing + else Just (AuthBasic "" usr pwd uri) + (usr,pwd') = break (==':') auth' + pwd = case pwd' of + ':':cs -> cs + _ -> pwd' +uri2proxy _ = Nothing + +mkRequest :: URI -> Request ByteString +mkRequest uri = Request{ rqURI = uri + , rqMethod = GET + , rqHeaders = [Header HdrUserAgent userAgent] + , rqBody = ByteString.empty } + where userAgent = "cabal-install/" ++ display Paths_cabal_install.version + +-- |Carry out a GET request, using the local proxy settings +getHTTP :: Verbosity -> URI -> IO (Result (Response ByteString)) +getHTTP verbosity uri = do + p <- proxy verbosity + let req = mkRequest uri + (_, resp) <- browse $ do + setErrHandler (warn verbosity . ("http error: "++)) + setOutHandler (debug verbosity) + setProxy p + request req + return (Right resp) + +downloadURI :: Verbosity + -> URI -- ^ What to download + -> FilePath -- ^ Where to put it + -> IO () +downloadURI verbosity uri path | uriScheme uri == "file:" = + copyFileVerbose verbosity (uriPath uri) path +downloadURI verbosity uri path = do + result <- getHTTP verbosity uri + let result' = case result of + Left err -> Left err + Right rsp -> case rspCode rsp of + (2,0,0) -> Right (rspBody rsp) + (a,b,c) -> Left err + where + err = ErrorMisc $ "Unsucessful HTTP code: " + ++ concatMap show [a,b,c] + + case result' of + Left err -> die $ "Failed to download " ++ show uri ++ " : " ++ show err + Right body -> do + info verbosity ("Downloaded to " ++ path) + writeFileAtomic path (ByteString.unpack body) + --FIXME: check the content-length header matches the body length. + --TODO: stream the download into the file rather than buffering the whole + -- thing in memory. + -- remember the ETag so we can not re-download if nothing changed. + +-- Utility function for legacy support. +isOldHackageURI :: URI -> Bool +isOldHackageURI uri + = case uriAuthority uri of + Just (URIAuth {uriRegName = "hackage.haskell.org"}) -> + FilePath.Posix.splitDirectories (uriPath uri) == ["/","packages","archive"] + _ -> False diff --git a/cabal/cabal-install/Distribution/Client/IndexUtils.hs b/cabal/cabal-install/Distribution/Client/IndexUtils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/IndexUtils.hs @@ -0,0 +1,270 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.IndexUtils +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Extra utils related to the package indexes. +----------------------------------------------------------------------------- +module Distribution.Client.IndexUtils ( + getInstalledPackages, + getSourcePackages, + + readPackageIndexFile, + parseRepoIndex, + ) where + +import qualified Distribution.Client.Tar as Tar +import Distribution.Client.Types + +import Distribution.Package + ( PackageId, PackageIdentifier(..), PackageName(..) + , Package(..), packageVersion + , Dependency(Dependency), InstalledPackageId(..) ) +import Distribution.Client.PackageIndex (PackageIndex) +import qualified Distribution.Client.PackageIndex as PackageIndex +import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import Distribution.PackageDescription + ( GenericPackageDescription ) +import Distribution.PackageDescription.Parse + ( parsePackageDescription ) +import Distribution.Simple.Compiler + ( Compiler, PackageDBStack ) +import Distribution.Simple.Program + ( ProgramConfiguration ) +import qualified Distribution.Simple.Configure as Configure + ( getInstalledPackages ) +import Distribution.ParseUtils + ( ParseResult(..) ) +import Distribution.Version + ( Version(Version), intersectVersionRanges ) +import Distribution.Text + ( simpleParse ) +import Distribution.Verbosity + ( Verbosity, lessVerbose ) +import Distribution.Simple.Utils + ( warn, info, fromUTF8, equating ) + +import Data.Maybe (catMaybes, fromMaybe) +import Data.List (isPrefixOf, groupBy) +import Data.Monoid (Monoid(..)) +import qualified Data.Map as Map +import Control.Monad (MonadPlus(mplus), when) +import Control.Exception (evaluate) +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 +import Data.ByteString.Lazy (ByteString) +import Distribution.Client.GZipUtils (maybeDecompress) +import System.FilePath ((), takeExtension, splitDirectories, normalise) +import System.FilePath.Posix as FilePath.Posix + ( takeFileName ) +import System.IO.Error (isDoesNotExistError) +import System.Directory + ( getModificationTime ) +import System.Time + ( getClockTime, diffClockTimes, normalizeTimeDiff, TimeDiff(tdDay) ) + +getInstalledPackages :: Verbosity -> Compiler + -> PackageDBStack -> ProgramConfiguration + -> IO (PackageIndex InstalledPackage) +getInstalledPackages verbosity comp packageDbs conf = + fmap convert (Configure.getInstalledPackages verbosity' + comp packageDbs conf) + where + --FIXME: make getInstalledPackages use sensible verbosity in the first place + verbosity' = lessVerbose verbosity + + convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage + convert index = PackageIndex.fromList + -- There can be multiple installed instances of each package version, + -- like when the same package is installed in the global & user dbs. + -- InstalledPackageIndex.allPackagesByName gives us the installed + -- packages with the most preferred instances first, so by picking the + -- first we should get the user one. This is almost but not quite the + -- same as what ghc does. + [ InstalledPackage ipkg (sourceDeps index ipkg) + | ipkgs <- InstalledPackageIndex.allPackagesByName index + , (ipkg:_) <- groupBy (equating packageVersion) ipkgs ] + + -- The InstalledPackageInfo only lists dependencies by the + -- InstalledPackageId, which means we do not directly know the corresponding + -- source dependency. The only way to find out is to lookup the + -- InstalledPackageId to get the InstalledPackageInfo and look at its + -- source PackageId. But if the package is broken because it depends on + -- other packages that do not exist then we have a problem we cannot find + -- the original source package id. Instead we make up a bogus package id. + -- This should have the same effect since it should be a dependency on a + -- non-existant package. + sourceDeps index ipkg = + [ maybe (brokenPackageId depid) packageId mdep + | let depids = InstalledPackageInfo.depends ipkg + getpkg = InstalledPackageIndex.lookupInstalledPackageId index + , (depid, mdep) <- zip depids (map getpkg depids) ] + + brokenPackageId (InstalledPackageId str) = + PackageIdentifier (PackageName (str ++ "-broken")) (Version [] []) + +-- | Read a repository index from disk, from the local files specified by +-- a list of 'Repo's. +-- +-- All the 'SourcePackage's are marked as having come from the appropriate +-- 'Repo'. +-- +-- This is a higher level wrapper used internally in cabal-install. +-- +getSourcePackages :: Verbosity -> [Repo] -> IO SourcePackageDb +getSourcePackages verbosity [] = do + warn verbosity $ "No remote package servers have been specified. Usually " + ++ "you would have one specified in the config file." + return SourcePackageDb { + packageIndex = mempty, + packagePreferences = mempty + } +getSourcePackages verbosity repos = do + info verbosity "Reading available packages..." + pkgss <- mapM (readRepoIndex verbosity) repos + let (pkgs, prefs) = mconcat pkgss + prefs' = Map.fromListWith intersectVersionRanges + [ (name, range) | Dependency name range <- prefs ] + _ <- evaluate pkgs + _ <- evaluate prefs' + return SourcePackageDb { + packageIndex = pkgs, + packagePreferences = prefs' + } + +-- | Read a repository index from disk, from the local file specified by +-- the 'Repo'. +-- +-- All the 'SourcePackage's are marked as having come from the given 'Repo'. +-- +-- This is a higher level wrapper used internally in cabal-install. +-- +readRepoIndex :: Verbosity -> Repo + -> IO (PackageIndex SourcePackage, [Dependency]) +readRepoIndex verbosity repo = handleNotFound $ do + let indexFile = repoLocalDir repo "00-index.tar" + (pkgs, prefs) <- either fail return + . foldlTarball extract ([], []) + =<< BS.readFile indexFile + + pkgIndex <- evaluate $ PackageIndex.fromList + [ SourcePackage { + packageInfoId = pkgid, + packageDescription = pkg, + packageSource = RepoTarballPackage repo pkgid Nothing + } + | (pkgid, pkg) <- pkgs] + + warnIfIndexIsOld indexFile + return (pkgIndex, prefs) + + where + extract (pkgs, prefs) entry = fromMaybe (pkgs, prefs) $ + (do pkg <- extractPkg entry; return (pkg:pkgs, prefs)) + `mplus` (do prefs' <- extractPrefs entry; return (pkgs, prefs'++prefs)) + + extractPrefs :: Tar.Entry -> Maybe [Dependency] + extractPrefs entry = case Tar.entryContent entry of + {- + -- get rid of hackage's preferred-versions + -- I'd like to have bleeding-edge packages in system and I don't fear of + -- broken packages with improper depends + Tar.NormalFile content _ + | takeFileName (Tar.entryPath entry) == "preferred-versions" + -> Just . parsePreferredVersions + . BS.Char8.unpack $ content + -} + _ -> Nothing + + handleNotFound action = catch action $ \e -> if isDoesNotExistError e + then do + case repoKind repo of + Left remoteRepo -> warn verbosity $ + "The package list for '" ++ remoteRepoName remoteRepo + ++ "' does not exist. Run 'hackport update' to download it." + Right _localRepo -> warn verbosity $ + "The package list for the local repo '" ++ repoLocalDir repo + ++ "' is missing. The repo is invalid." + return mempty + else ioError e + + isOldThreshold = 15 --days + warnIfIndexIsOld indexFile = do + indexTime <- getModificationTime indexFile + currentTime <- getClockTime + let diff = normalizeTimeDiff (diffClockTimes currentTime indexTime) + when (tdDay diff >= isOldThreshold) $ case repoKind repo of + Left remoteRepo -> warn verbosity $ + "The package list for '" ++ remoteRepoName remoteRepo + ++ "' is " ++ show (tdDay diff) ++ " days old.\nRun " + ++ "'hackport update' to get the latest list of available packages." + Right _localRepo -> return () + +parsePreferredVersions :: String -> [Dependency] +parsePreferredVersions = catMaybes + . map simpleParse + . filter (not . isPrefixOf "--") + . lines + +-- | Read a compressed \"00-index.tar.gz\" file into a 'PackageIndex'. +-- +-- This is supposed to be an \"all in one\" way to easily get at the info in +-- the hackage package index. +-- +-- It takes a function to map a 'GenericPackageDescription' into any more +-- specific instance of 'Package' that you might want to use. In the simple +-- case you can just use @\_ p -> p@ here. +-- +readPackageIndexFile :: Package pkg + => (PackageId -> GenericPackageDescription -> pkg) + -> FilePath -> IO (PackageIndex pkg) +readPackageIndexFile mkPkg indexFile = do + pkgs <- either fail return + . parseRepoIndex + . maybeDecompress + =<< BS.readFile indexFile + + evaluate $ PackageIndex.fromList + [ mkPkg pkgid pkg | (pkgid, pkg) <- pkgs] + +-- | Parse an uncompressed \"00-index.tar\" repository index file represented +-- as a 'ByteString'. +-- +parseRepoIndex :: ByteString + -> Either String [(PackageId, GenericPackageDescription)] +parseRepoIndex = foldlTarball (\pkgs -> maybe pkgs (:pkgs) . extractPkg) [] + +extractPkg :: Tar.Entry -> Maybe (PackageId, GenericPackageDescription) +extractPkg entry = case Tar.entryContent entry of + Tar.NormalFile content _ + | takeExtension fileName == ".cabal" + -> case splitDirectories (normalise fileName) of + [pkgname,vers,_] -> case simpleParse vers of + Just ver -> Just (pkgid, descr) + where + pkgid = PackageIdentifier (PackageName pkgname) ver + parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack + $ content + descr = case parsed of + ParseOk _ d -> d + _ -> error $ "Couldn't read cabal file " + ++ show fileName + _ -> Nothing + _ -> Nothing + _ -> Nothing + where + fileName = Tar.entryPath entry + +foldlTarball :: (a -> Tar.Entry -> a) -> a + -> ByteString -> Either String a +foldlTarball f z = either Left (Right . foldl f z) . check [] . Tar.read + where + check _ (Tar.Fail err) = Left err + check ok Tar.Done = Right ok + check ok (Tar.Next e es) = check (e:ok) es diff --git a/cabal/cabal-install/Distribution/Client/Init.hs b/cabal/cabal-install/Distribution/Client/Init.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Init.hs @@ -0,0 +1,603 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init +-- Copyright : (c) Brent Yorgey 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Implementation of the 'cabal init' command, which creates an initial .cabal +-- file for a project. +-- +----------------------------------------------------------------------------- + +module Distribution.Client.Init ( + + -- * Commands + initCabal + + ) where + +import System.IO + ( hSetBuffering, stdout, BufferMode(..) ) +import System.Directory + ( getCurrentDirectory ) +import Data.Time + ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) + +import Data.List + ( intersperse, (\\) ) +import Data.Maybe + ( fromMaybe, isJust ) +import Data.Traversable + ( traverse ) +import Control.Monad + ( when ) +#if MIN_VERSION_base(3,0,0) +import Control.Monad + ( (>=>), join ) +#endif + +import Text.PrettyPrint.HughesPJ hiding (mode, cat) + +import Data.Version + ( Version(..) ) +import Distribution.Version + ( orLaterVersion ) + +import Distribution.Client.Init.Types + ( InitFlags(..), PackageType(..), Category(..) ) +import Distribution.Client.Init.Licenses + ( bsd3, gplv2, gplv3, lgpl2, lgpl3 ) +import Distribution.Client.Init.Heuristics + ( guessPackageName, guessAuthorNameMail, SourceFileEntry(..), scanForModules, neededBuildPrograms ) + +import Distribution.License + ( License(..), knownLicenses ) +import Distribution.ModuleName + ( ) -- for the Text instance + +import Distribution.ReadE + ( runReadE, readP_to_E ) +import Distribution.Simple.Setup + ( Flag(..), flagToMaybe ) +import Distribution.Text + ( display, Text(..) ) + +initCabal :: InitFlags -> IO () +initCabal initFlags = do + hSetBuffering stdout NoBuffering + + initFlags' <- extendFlags initFlags + + writeLicense initFlags' + writeSetupFile initFlags' + success <- writeCabalFile initFlags' + + when success $ generateWarnings initFlags' + +--------------------------------------------------------------------------- +-- Flag acquisition ----------------------------------------------------- +--------------------------------------------------------------------------- + +-- | Fill in more details by guessing, discovering, or prompting the +-- user. +extendFlags :: InitFlags -> IO InitFlags +extendFlags = getPackageName + >=> getVersion + >=> getLicense + >=> getAuthorInfo + >=> getHomepage + >=> getSynopsis + >=> getCategory + >=> getLibOrExec + >=> getGenComments + >=> getSrcDir + >=> getModulesAndBuildTools + +-- | Combine two actions which may return a value, preferring the first. That +-- is, run the second action only if the first doesn't return a value. +infixr 1 ?>> +(?>>) :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a) +f ?>> g = do + ma <- f + if isJust ma + then return ma + else g + +-- | Witness the isomorphism between Maybe and Flag. +maybeToFlag :: Maybe a -> Flag a +maybeToFlag = maybe NoFlag Flag + +-- | Get the package name: use the package directory (supplied, or the current +-- directory by default) as a guess. +getPackageName :: InitFlags -> IO InitFlags +getPackageName flags = do + guess <- traverse guessPackageName (flagToMaybe $ packageDir flags) + ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName) + + pkgName' <- return (flagToMaybe $ packageName flags) + ?>> maybePrompt flags (promptStr "Package name" guess) + ?>> return guess + + return $ flags { packageName = maybeToFlag pkgName' } + +-- | Package version: use 0.1 as a last resort, but try prompting the user if +-- possible. +getVersion :: InitFlags -> IO InitFlags +getVersion flags = do + let v = Just $ Version { versionBranch = [0,1], versionTags = [] } + v' <- return (flagToMaybe $ version flags) + ?>> maybePrompt flags (prompt "Package version" v) + ?>> return v + return $ flags { version = maybeToFlag v' } + +-- | Choose a license. +getLicense :: InitFlags -> IO InitFlags +getLicense flags = do + lic <- return (flagToMaybe $ license flags) + ?>> fmap (fmap (either UnknownLicense id) . join) + (maybePrompt flags + (promptListOptional "Please choose a license" listedLicenses)) + return $ flags { license = maybeToFlag lic } + where + listedLicenses = + knownLicenses \\ [GPL Nothing, LGPL Nothing, OtherLicense] + +-- | The author's name and email. Prompt, or try to guess from an existing +-- darcs repo. +getAuthorInfo :: InitFlags -> IO InitFlags +getAuthorInfo flags = do + (authorName, authorEmail) <- (\(a,e) -> (flagToMaybe a, flagToMaybe e)) `fmap` guessAuthorNameMail + authorName' <- return (flagToMaybe $ author flags) + ?>> maybePrompt flags (promptStr "Author name" authorName) + ?>> return authorName + + authorEmail' <- return (flagToMaybe $ email flags) + ?>> maybePrompt flags (promptStr "Maintainer email" authorEmail) + ?>> return authorEmail + + return $ flags { author = maybeToFlag authorName' + , email = maybeToFlag authorEmail' + } + +-- | Prompt for a homepage URL. +getHomepage :: InitFlags -> IO InitFlags +getHomepage flags = do + hp <- queryHomepage + hp' <- return (flagToMaybe $ homepage flags) + ?>> maybePrompt flags (promptStr "Project homepage/repo URL" hp) + ?>> return hp + + return $ flags { homepage = maybeToFlag hp' } + +-- | Right now this does nothing, but it could be changed to do some +-- intelligent guessing. +queryHomepage :: IO (Maybe String) +queryHomepage = return Nothing -- get default remote darcs repo? + +-- | Prompt for a project synopsis. +getSynopsis :: InitFlags -> IO InitFlags +getSynopsis flags = do + syn <- return (flagToMaybe $ synopsis flags) + ?>> maybePrompt flags (promptStr "Project synopsis" Nothing) + + return $ flags { synopsis = maybeToFlag syn } + +-- | Prompt for a package category. +-- Note that it should be possible to do some smarter guessing here too, i.e. +-- look at the name of the top level source directory. +getCategory :: InitFlags -> IO InitFlags +getCategory flags = do + cat <- return (flagToMaybe $ category flags) + ?>> fmap join (maybePrompt flags + (promptListOptional "Project category" [Codec ..])) + return $ flags { category = maybeToFlag cat } + +-- | Ask whether the project builds a library or executable. +getLibOrExec :: InitFlags -> IO InitFlags +getLibOrExec flags = do + isLib <- return (flagToMaybe $ packageType flags) + ?>> maybePrompt flags (either (const Library) id `fmap` + (promptList "What does the package build" + [Library, Executable] + Nothing display False)) + ?>> return (Just Library) + + return $ flags { packageType = maybeToFlag isLib } + +-- | Ask whether to generate explanitory comments. +getGenComments :: InitFlags -> IO InitFlags +getGenComments flags = do + genComments <- return (flagToMaybe $ noComments flags) + ?>> maybePrompt flags (promptYesNo promptMsg (Just False)) + ?>> return (Just False) + return $ flags { noComments = maybeToFlag (fmap not genComments) } + where + promptMsg = "Include documentation on what each field means y/n" + +-- | Try to guess the source root directory (don't prompt the user). +getSrcDir :: InitFlags -> IO InitFlags +getSrcDir flags = do + srcDirs <- return (sourceDirs flags) + ?>> guessSourceDirs + + return $ flags { sourceDirs = srcDirs } + +-- XXX +-- | Try to guess source directories. +guessSourceDirs :: IO (Maybe [String]) +guessSourceDirs = return Nothing + +-- | Get the list of exposed modules and extra tools needed to build them. +getModulesAndBuildTools :: InitFlags -> IO InitFlags +getModulesAndBuildTools flags = do + dir <- fromMaybe getCurrentDirectory + (fmap return . flagToMaybe $ packageDir flags) + + -- XXX really should use guessed source roots. + sourceFiles <- scanForModules dir + + mods <- return (exposedModules flags) + ?>> (return . Just . map moduleName $ sourceFiles) + + tools <- return (buildTools flags) + ?>> (return . Just . neededBuildPrograms $ sourceFiles) + + return $ flags { exposedModules = mods + , buildTools = tools } + +--------------------------------------------------------------------------- +-- Prompting/user interaction ------------------------------------------- +--------------------------------------------------------------------------- + +-- | Run a prompt or not based on the nonInteractive flag of the +-- InitFlags structure. +maybePrompt :: InitFlags -> IO t -> IO (Maybe t) +maybePrompt flags p = + case nonInteractive flags of + Flag True -> return Nothing + _ -> Just `fmap` p + +-- | Create a prompt with optional default value that returns a +-- String. +promptStr :: String -> Maybe String -> IO String +promptStr = promptDefault' Just id + +-- | Create a yes/no prompt with optional default value. +-- +promptYesNo :: String -> Maybe Bool -> IO Bool +promptYesNo = + promptDefault' recogniseYesNo showYesNo + where + recogniseYesNo s | s == "y" || s == "Y" = Just True + | s == "n" || s == "N" = Just False + | otherwise = Nothing + showYesNo True = "y" + showYesNo False = "n" + +-- | Create a prompt with optional default value that returns a value +-- of some Text instance. +prompt :: Text t => String -> Maybe t -> IO t +prompt = promptDefault' + (either (const Nothing) Just . runReadE (readP_to_E id parse)) + display + +-- | Create a prompt with an optional default value. +promptDefault' :: (String -> Maybe t) -- ^ parser + -> (t -> String) -- ^ pretty-printer + -> String -- ^ prompt message + -> Maybe t -- ^ optional default value + -> IO t +promptDefault' parser pretty pr def = do + putStr $ mkDefPrompt pr (pretty `fmap` def) + inp <- getLine + case (inp, def) of + ("", Just d) -> return d + _ -> case parser inp of + Just t -> return t + Nothing -> do putStrLn $ "Couldn't parse " ++ inp ++ ", please try again!" + promptDefault' parser pretty pr def + +-- | Create a prompt from a prompt string and a String representation +-- of an optional default value. +mkDefPrompt :: String -> Maybe String -> String +mkDefPrompt pr def = pr ++ "?" ++ defStr def + where defStr Nothing = " " + defStr (Just s) = " [default: " ++ s ++ "] " + +promptListOptional :: (Text t, Eq t) + => String -- ^ prompt + -> [t] -- ^ choices + -> IO (Maybe (Either String t)) +promptListOptional pr choices = + fmap rearrange + $ promptList pr (Nothing : map Just choices) (Just Nothing) + (maybe "(none)" display) True + where + rearrange = either (Just . Left) (maybe Nothing (Just . Right)) + +-- | Create a prompt from a list of items. +promptList :: Eq t + => String -- ^ prompt + -> [t] -- ^ choices + -> Maybe t -- ^ optional default value + -> (t -> String) -- ^ show an item + -> Bool -- ^ whether to allow an 'other' option + -> IO (Either String t) +promptList pr choices def displayItem other = do + putStrLn $ pr ++ ":" + let options1 = map (\c -> (Just c == def, displayItem c)) choices + options2 = zip ([1..]::[Int]) + (options1 ++ if other then [(False, "Other (specify)")] + else []) + mapM_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2 + promptList' displayItem (length options2) choices def other + where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest + | otherwise = " " ++ star i ++ rest + where rest = show n ++ ") " + star True = "*" + star False = " " + +promptList' :: (t -> String) -> Int -> [t] -> Maybe t -> Bool -> IO (Either String t) +promptList' displayItem numChoices choices def other = do + putStr $ mkDefPrompt "Your choice" (displayItem `fmap` def) + inp <- getLine + case (inp, def) of + ("", Just d) -> return $ Right d + _ -> case readMaybe inp of + Nothing -> invalidChoice inp + Just n -> getChoice n + where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice." + promptList' displayItem numChoices choices def other + getChoice n | n < 1 || n > numChoices = invalidChoice (show n) + | n < numChoices || + (n == numChoices && not other) + = return . Right $ choices !! (n-1) + | otherwise = Left `fmap` promptStr "Please specify" Nothing + +readMaybe :: (Read a) => String -> Maybe a +readMaybe s = case reads s of + [(a,"")] -> Just a + _ -> Nothing + +--------------------------------------------------------------------------- +-- File generation ------------------------------------------------------ +--------------------------------------------------------------------------- + +writeLicense :: InitFlags -> IO () +writeLicense flags = do + message flags "Generating LICENSE..." + year <- getYear + let licenseFile = + case license flags of + Flag BSD3 -> Just $ bsd3 (fromMaybe "???" + . flagToMaybe + . author + $ flags) + (show year) + + Flag (GPL (Just (Version {versionBranch = [2]}))) + -> Just gplv2 + + Flag (GPL (Just (Version {versionBranch = [3]}))) + -> Just gplv3 + + Flag (LGPL (Just (Version {versionBranch = [2]}))) + -> Just lgpl2 + + Flag (LGPL (Just (Version {versionBranch = [3]}))) + -> Just lgpl3 + + _ -> Nothing + + case licenseFile of + Just licenseText -> writeFile "LICENSE" licenseText + Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself." + +getYear :: IO Integer +getYear = do + u <- getCurrentTime + z <- getCurrentTimeZone + let l = utcToLocalTime z u + (y, _, _) = toGregorian $ localDay l + return y + +writeSetupFile :: InitFlags -> IO () +writeSetupFile flags = do + message flags "Generating Setup.hs..." + writeFile "Setup.hs" setupFile + where + setupFile = unlines + [ "import Distribution.Simple" + , "main = defaultMain" + ] + +writeCabalFile :: InitFlags -> IO Bool +writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do + message flags "Error: no package name provided." + return False +writeCabalFile flags@(InitFlags{packageName = Flag p}) = do + let cabalFileName = p ++ ".cabal" + message flags $ "Generating " ++ cabalFileName ++ "..." + writeFile cabalFileName (generateCabalFile cabalFileName flags) + return True + +-- | Generate a .cabal file from an InitFlags structure. NOTE: this +-- is rather ad-hoc! What we would REALLY like is to have a +-- standard low-level AST type representing .cabal files, which +-- preserves things like comments, and to write an *inverse* +-- parser/pretty-printer pair between .cabal files and this AST. +-- Then instead of this ad-hoc code we could just map an InitFlags +-- structure onto a low-level AST structure and use the existing +-- pretty-printing code to generate the file. +generateCabalFile :: String -> InitFlags -> String +generateCabalFile fileName c = + renderStyle style { lineLength = 79, ribbonsPerLine = 1.1 } $ + (if (minimal c /= Flag True) + then showComment (Just $ "Initial " ++ fileName ++ " generated by cabal " + ++ "init. For further documentation, see " + ++ "http://haskell.org/cabal/users-guide/") + $$ text "" + else empty) + $$ + vcat [ fieldS "name" (packageName c) + (Just "The name of the package.") + True + + , field "version" (version c) + (Just "The package version. See the Haskell package versioning policy (http://www.haskell.org/haskellwiki/Package_versioning_policy) for standards guiding when and how versions should be incremented.") + True + + , fieldS "synopsis" (synopsis c) + (Just "A short (one-line) description of the package.") + True + + , fieldS "description" NoFlag + (Just "A longer description of the package.") + True + + , fieldS "homepage" (homepage c) + (Just "URL for the project homepage or repository.") + False + + , fieldS "bug-reports" NoFlag + (Just "A URL where users can report bugs.") + False + + , field "license" (license c) + (Just "The license under which the package is released.") + True + + , fieldS "license-file" (Flag "LICENSE") + (Just "The file containing the license text.") + True + + , fieldS "author" (author c) + (Just "The package author(s).") + True + + , fieldS "maintainer" (email c) + (Just "An email address to which users can send suggestions, bug reports, and patches.") + True + + , fieldS "copyright" NoFlag + (Just "A copyright notice.") + True + + , fieldS "category" (either id display `fmap` category c) + Nothing + True + + , fieldS "build-type" (Flag "Simple") + Nothing + True + + , fieldS "extra-source-files" NoFlag + (Just "Extra files to be distributed with the package, such as examples or a README.") + False + + , field "cabal-version" (Flag $ orLaterVersion (Version [1,8] [])) + (Just "Constraint on the version of Cabal needed to build this package.") + False + + , case packageType c of + Flag Executable -> + text "\nexecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ (nest 2 $ vcat + [ fieldS "main-is" NoFlag (Just ".hs or .lhs file containing the Main module.") True + + , generateBuildInfo Executable c + ]) + Flag Library -> text "\nlibrary" $$ (nest 2 $ vcat + [ fieldS "exposed-modules" (listField (exposedModules c)) + (Just "Modules exported by the library.") + True + + , generateBuildInfo Library c + ]) + _ -> empty + ] + where + generateBuildInfo :: PackageType -> InitFlags -> Doc + generateBuildInfo pkgtype c' = vcat + [ fieldS "other-modules" (listField (otherModules c')) + (Just $ case pkgtype of + Library -> "Modules included in this library but not exported." + Executable -> "Modules included in this executable, other than Main.") + True + + , fieldS "build-depends" (listField (dependencies c')) + (Just "Other library packages from which modules are imported.") + True + + , fieldS "hs-source-dirs" (listFieldS (sourceDirs c')) + (Just "Directories containing source files.") + False + + , fieldS "build-tools" (listFieldS (buildTools c')) + (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.") + False + ] + + listField :: Text s => Maybe [s] -> Flag String + listField = listFieldS . fmap (map display) + + listFieldS :: Maybe [String] -> Flag String + listFieldS = Flag . maybe "" (concat . intersperse ", ") + + field :: Text t => String -> Flag t -> Maybe String -> Bool -> Doc + field s f = fieldS s (fmap display f) + + fieldS :: String -- ^ Name of the field + -> Flag String -- ^ Field contents + -> Maybe String -- ^ Comment to explain the field + -> Bool -- ^ Should the field be included (commented out) even if blank? + -> Doc + fieldS _ NoFlag _ inc | not inc || (minimal c == Flag True) = empty + fieldS _ (Flag "") _ inc | not inc || (minimal c == Flag True) = empty + fieldS s f com _ = case (isJust com, noComments c, minimal c) of + (_, _, Flag True) -> id + (_, Flag True, _) -> id + (True, _, _) -> (showComment com $$) . ($$ text "") + (False, _, _) -> ($$ text "") + $ + comment f <> text s <> colon + <> text (take (20 - length s) (repeat ' ')) + <> text (fromMaybe "" . flagToMaybe $ f) + comment NoFlag = text "-- " + comment (Flag "") = text "-- " + comment _ = text "" + + showComment :: Maybe String -> Doc + showComment (Just t) = vcat . map text + . map ("-- "++) . lines + . renderStyle style { + lineLength = 76, + ribbonsPerLine = 1.05 + } + . fsep . map text . words $ t + showComment Nothing = text "" + +-- | Generate warnings for missing fields etc. +generateWarnings :: InitFlags -> IO () +generateWarnings flags = do + message flags "" + when (synopsis flags `elem` [NoFlag, Flag ""]) + (message flags "Warning: no synopsis given. You should edit the .cabal file and add one.") + + message flags "You may want to edit the .cabal file and add a Description field." + +-- | Possibly generate a message to stdout, taking into account the +-- --quiet flag. +message :: InitFlags -> String -> IO () +message (InitFlags{quiet = Flag True}) _ = return () +message _ s = putStrLn s + +#if MIN_VERSION_base(3,0,0) +#else +(>=>) :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c) +f >=> g = \x -> f x >>= g +#endif diff --git a/cabal/cabal-install/Distribution/Client/Init/Heuristics.hs b/cabal/cabal-install/Distribution/Client/Init/Heuristics.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Init/Heuristics.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.Heuristics +-- Copyright : (c) Benedikt Huber 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Heuristics for creating initial cabal files. +-- +----------------------------------------------------------------------------- +module Distribution.Client.Init.Heuristics ( + guessPackageName, + scanForModules, SourceFileEntry(..), + neededBuildPrograms, + guessAuthorNameMail, + knownCategories, +) where +import Distribution.Simple.Setup(Flag(..)) +import Distribution.ModuleName ( ModuleName, fromString ) +import Distribution.Client.PackageIndex + ( allPackagesByName ) +import qualified Distribution.PackageDescription as PD + ( category, packageDescription ) +import Distribution.Simple.Utils + ( intercalate ) + +import Distribution.Client.Types ( packageDescription, SourcePackageDb(..) ) +import Control.Monad (liftM ) +import Data.Char ( isUpper, isLower, isSpace ) +#if MIN_VERSION_base(3,0,3) +import Data.Either ( partitionEithers ) +#endif +import Data.Maybe ( catMaybes ) +import Data.Monoid ( mempty, mappend ) +import qualified Data.Set as Set ( fromList, toList ) +import System.Directory ( getDirectoryContents, doesDirectoryExist, doesFileExist, + getHomeDirectory, canonicalizePath ) +import System.Environment ( getEnvironment ) +import System.FilePath ( takeExtension, takeBaseName, dropExtension, + (), splitDirectories, makeRelative ) + +-- |Guess the package name based on the given root directory +guessPackageName :: FilePath -> IO String +guessPackageName = liftM (last . splitDirectories) . canonicalizePath + +-- |Data type of source files found in the working directory +data SourceFileEntry = SourceFileEntry + { relativeSourcePath :: FilePath + , moduleName :: ModuleName + , fileExtension :: String + } deriving Show + +-- |Search for source files in the given directory +-- and return pairs of guessed haskell source path and +-- module names. +scanForModules :: FilePath -> IO [SourceFileEntry] +scanForModules rootDir = scanForModulesIn rootDir rootDir + +scanForModulesIn :: FilePath -> FilePath -> IO [SourceFileEntry] +scanForModulesIn projectRoot srcRoot = scan srcRoot [] + where + scan dir hierarchy = do + entries <- getDirectoryContents (projectRoot dir) + (files, dirs) <- liftM partitionEithers (mapM (tagIsDir dir) entries) + let modules = catMaybes [ guessModuleName hierarchy file + | file <- files + , isUpper (head file) ] + recMods <- mapM (scanRecursive dir hierarchy) dirs + return $ concat (modules : recMods) + tagIsDir parent entry = do + isDir <- doesDirectoryExist (parent entry) + return $ (if isDir then Right else Left) entry + guessModuleName hierarchy entry + | takeBaseName entry == "Setup" = Nothing + | ext `elem` sourceExtensions = Just $ SourceFileEntry relRoot modName ext + | otherwise = Nothing + where + relRoot = makeRelative projectRoot srcRoot + unqualModName = dropExtension entry + modName = fromString $ intercalate "." . reverse $ (unqualModName : hierarchy) + ext = case takeExtension entry of '.':e -> e; e -> e + scanRecursive parent hierarchy entry + | isUpper (head entry) = scan (parent entry) (entry : hierarchy) + | isLower (head entry) && not (ignoreDir entry) = + scanForModulesIn projectRoot $ foldl () srcRoot (entry : hierarchy) + | otherwise = return [] + ignoreDir ('.':_) = True + ignoreDir dir = dir `elem` ["dist", "_darcs"] + +-- Unfortunately we cannot use the version exported by Distribution.Simple.Program +knownSuffixHandlers :: [(String,String)] +knownSuffixHandlers = + [ ("gc", "greencard") + , ("chs", "chs") + , ("hsc", "hsc2hs") + , ("x", "alex") + , ("y", "happy") + , ("ly", "happy") + , ("cpphs", "cpp") + ] + +sourceExtensions :: [String] +sourceExtensions = "hs" : "lhs" : map fst knownSuffixHandlers + +neededBuildPrograms :: [SourceFileEntry] -> [String] +neededBuildPrograms entries = + [ handler + | ext <- nubSet (map fileExtension entries) + , handler <- maybe [] (:[]) (lookup ext knownSuffixHandlers) + ] + +-- |Guess author and email +guessAuthorNameMail :: IO (Flag String, Flag String) +guessAuthorNameMail = + update (readFromFile authorRepoFile) mempty >>= + update (getAuthorHome >>= readFromFile) >>= + update readFromEnvironment + where + update _ info@(Flag _, Flag _) = return info + update extract info = liftM (`mappend` info) extract -- prefer info + readFromFile file = do + exists <- doesFileExist file + if exists then liftM nameAndMail (readFile file) else return mempty + readFromEnvironment = fmap extractFromEnvironment getEnvironment + extractFromEnvironment env = + let darcsEmailEnv = maybe mempty nameAndMail (lookup "DARCS_EMAIL" env) + emailEnv = maybe mempty (\e -> (mempty, Flag e)) (lookup "EMAIL" env) + in darcsEmailEnv `mappend` emailEnv + getAuthorHome = liftM ( (".darcs" "author")) getHomeDirectory + authorRepoFile = "_darcs" "prefs" "author" + +-- |Get list of categories used in hackage. NOTE: Very slow, needs to be cached +knownCategories :: SourcePackageDb -> [String] +knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet $ + [ cat | pkg <- map head (allPackagesByName sourcePkgIndex) + , let catList = (PD.category . PD.packageDescription . packageDescription) pkg + , cat <- splitString ',' catList + ] + +-- Parse name and email, from darcs pref files or environment variable +nameAndMail :: String -> (Flag String, Flag String) +nameAndMail str + | all isSpace nameOrEmail = mempty + | null erest = (mempty, Flag $ trim nameOrEmail) + | otherwise = (Flag $ trim nameOrEmail, Flag email) + where + (nameOrEmail,erest) = break (== '<') str + (email,_) = break (== '>') (tail erest) + trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse + removeLeadingSpace = dropWhile isSpace + +-- split string at given character, and remove whitespaces +splitString :: Char -> String -> [String] +splitString sep str = go str where + go s = if null s' then [] else tok : go rest where + s' = dropWhile (\c -> c == sep || isSpace c) s + (tok,rest) = break (==sep) s' + +nubSet :: (Ord a) => [a] -> [a] +nubSet = Set.toList . Set.fromList + +{- +test db testProjectRoot = do + putStrLn "Guessed package name" + (guessPackageName >=> print) testProjectRoot + putStrLn "Guessed name and email" + guessAuthorNameMail >>= print + + mods <- scanForModules testProjectRoot + + putStrLn "Guessed modules" + mapM_ print mods + putStrLn "Needed build programs" + print (neededBuildPrograms mods) + + putStrLn "List of known categories" + print $ knownCategories db +-} + +#if MIN_VERSION_base(3,0,3) +#else +partitionEithers :: [Either a b] -> ([a],[b]) +partitionEithers = foldr (either left right) ([],[]) + where + left a (l, r) = (a:l, r) + right a (l, r) = (l, a:r) +#endif diff --git a/cabal/cabal-install/Distribution/Client/Init/Licenses.hs b/cabal/cabal-install/Distribution/Client/Init/Licenses.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Init/Licenses.hs @@ -0,0 +1,1722 @@ +module Distribution.Client.Init.Licenses + ( License + , bsd3 + , gplv2 + , gplv3 + , lgpl2 + , lgpl3 + + ) where + +type License = String + +bsd3 :: String -> String -> License +bsd3 authors year = unlines + [ "Copyright (c) " ++ year ++ ", " ++ authors + , "" + , "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 " ++ authors ++ " 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." + ] + +gplv2 :: License +gplv2 = unlines + [ " GNU GENERAL PUBLIC LICENSE" + , " Version 2, June 1991" + , "" + , " Copyright (C) 1989, 1991 Free Software Foundation, Inc.," + , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , " Preamble" + , "" + , " The licenses for most software are designed to take away your" + , "freedom to share and change it. By contrast, the GNU General Public" + , "License is intended to guarantee your freedom to share and change free" + , "software--to make sure the software is free for all its users. This" + , "General Public License applies to most of the Free Software" + , "Foundation's software and to any other program whose authors commit to" + , "using it. (Some other Free Software Foundation software is covered by" + , "the GNU Lesser General Public License instead.) You can apply it to" + , "your programs, too." + , "" + , " When we speak of free software, we are referring to freedom, not" + , "price. Our General Public Licenses are designed to make sure that you" + , "have the freedom to distribute copies of free software (and charge for" + , "this service if you wish), that you receive source code or can get it" + , "if you want it, that you can change the software or use pieces of it" + , "in new free programs; and that you know you can do these things." + , "" + , " To protect your rights, we need to make restrictions that forbid" + , "anyone to deny you these rights or to ask you to surrender the rights." + , "These restrictions translate to certain responsibilities for you if you" + , "distribute copies of the software, or if you modify it." + , "" + , " For example, if you distribute copies of such a program, whether" + , "gratis or for a fee, you must give the recipients all the rights that" + , "you have. You must make sure that they, too, receive or can get the" + , "source code. And you must show them these terms so they know their" + , "rights." + , "" + , " We protect your rights with two steps: (1) copyright the software, and" + , "(2) offer you this license which gives you legal permission to copy," + , "distribute and/or modify the software." + , "" + , " Also, for each author's protection and ours, we want to make certain" + , "that everyone understands that there is no warranty for this free" + , "software. If the software is modified by someone else and passed on, we" + , "want its recipients to know that what they have is not the original, so" + , "that any problems introduced by others will not reflect on the original" + , "authors' reputations." + , "" + , " Finally, any free program is threatened constantly by software" + , "patents. We wish to avoid the danger that redistributors of a free" + , "program will individually obtain patent licenses, in effect making the" + , "program proprietary. To prevent this, we have made it clear that any" + , "patent must be licensed for everyone's free use or not licensed at all." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow." + , "" + , " GNU GENERAL PUBLIC LICENSE" + , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" + , "" + , " 0. This License applies to any program or other work which contains" + , "a notice placed by the copyright holder saying it may be distributed" + , "under the terms of this General Public License. The \"Program\", below," + , "refers to any such program or work, and a \"work based on the Program\"" + , "means either the Program or any derivative work under copyright law:" + , "that is to say, a work containing the Program or a portion of it," + , "either verbatim or with modifications and/or translated into another" + , "language. (Hereinafter, translation is included without limitation in" + , "the term \"modification\".) Each licensee is addressed as \"you\"." + , "" + , "Activities other than copying, distribution and modification are not" + , "covered by this License; they are outside its scope. The act of" + , "running the Program is not restricted, and the output from the Program" + , "is covered only if its contents constitute a work based on the" + , "Program (independent of having been made by running the Program)." + , "Whether that is true depends on what the Program does." + , "" + , " 1. You may copy and distribute verbatim copies of the Program's" + , "source code as you receive it, in any medium, provided that you" + , "conspicuously and appropriately publish on each copy an appropriate" + , "copyright notice and disclaimer of warranty; keep intact all the" + , "notices that refer to this License and to the absence of any warranty;" + , "and give any other recipients of the Program a copy of this License" + , "along with the Program." + , "" + , "You may charge a fee for the physical act of transferring a copy, and" + , "you may at your option offer warranty protection in exchange for a fee." + , "" + , " 2. You may modify your copy or copies of the Program or any portion" + , "of it, thus forming a work based on the Program, and copy and" + , "distribute such modifications or work under the terms of Section 1" + , "above, provided that you also meet all of these conditions:" + , "" + , " a) You must cause the modified files to carry prominent notices" + , " stating that you changed the files and the date of any change." + , "" + , " b) You must cause any work that you distribute or publish, that in" + , " whole or in part contains or is derived from the Program or any" + , " part thereof, to be licensed as a whole at no charge to all third" + , " parties under the terms of this License." + , "" + , " c) If the modified program normally reads commands interactively" + , " when run, you must cause it, when started running for such" + , " interactive use in the most ordinary way, to print or display an" + , " announcement including an appropriate copyright notice and a" + , " notice that there is no warranty (or else, saying that you provide" + , " a warranty) and that users may redistribute the program under" + , " these conditions, and telling the user how to view a copy of this" + , " License. (Exception: if the Program itself is interactive but" + , " does not normally print such an announcement, your work based on" + , " the Program is not required to print an announcement.)" + , "" + , "These requirements apply to the modified work as a whole. If" + , "identifiable sections of that work are not derived from the Program," + , "and can be reasonably considered independent and separate works in" + , "themselves, then this License, and its terms, do not apply to those" + , "sections when you distribute them as separate works. But when you" + , "distribute the same sections as part of a whole which is a work based" + , "on the Program, the distribution of the whole must be on the terms of" + , "this License, whose permissions for other licensees extend to the" + , "entire whole, and thus to each and every part regardless of who wrote it." + , "" + , "Thus, it is not the intent of this section to claim rights or contest" + , "your rights to work written entirely by you; rather, the intent is to" + , "exercise the right to control the distribution of derivative or" + , "collective works based on the Program." + , "" + , "In addition, mere aggregation of another work not based on the Program" + , "with the Program (or with a work based on the Program) on a volume of" + , "a storage or distribution medium does not bring the other work under" + , "the scope of this License." + , "" + , " 3. You may copy and distribute the Program (or a work based on it," + , "under Section 2) in object code or executable form under the terms of" + , "Sections 1 and 2 above provided that you also do one of the following:" + , "" + , " a) Accompany it with the complete corresponding machine-readable" + , " source code, which must be distributed under the terms of Sections" + , " 1 and 2 above on a medium customarily used for software interchange; or," + , "" + , " b) Accompany it with a written offer, valid for at least three" + , " years, to give any third party, for a charge no more than your" + , " cost of physically performing source distribution, a complete" + , " machine-readable copy of the corresponding source code, to be" + , " distributed under the terms of Sections 1 and 2 above on a medium" + , " customarily used for software interchange; or," + , "" + , " c) Accompany it with the information you received as to the offer" + , " to distribute corresponding source code. (This alternative is" + , " allowed only for noncommercial distribution and only if you" + , " received the program in object code or executable form with such" + , " an offer, in accord with Subsection b above.)" + , "" + , "The source code for a work means the preferred form of the work for" + , "making modifications to it. For an executable work, complete source" + , "code means all the source code for all modules it contains, plus any" + , "associated interface definition files, plus the scripts used to" + , "control compilation and installation of the executable. However, as a" + , "special exception, the source code distributed need not include" + , "anything that is normally distributed (in either source or binary" + , "form) with the major components (compiler, kernel, and so on) of the" + , "operating system on which the executable runs, unless that component" + , "itself accompanies the executable." + , "" + , "If distribution of executable or object code is made by offering" + , "access to copy from a designated place, then offering equivalent" + , "access to copy the source code from the same place counts as" + , "distribution of the source code, even though third parties are not" + , "compelled to copy the source along with the object code." + , "" + , " 4. You may not copy, modify, sublicense, or distribute the Program" + , "except as expressly provided under this License. Any attempt" + , "otherwise to copy, modify, sublicense or distribute the Program is" + , "void, and will automatically terminate your rights under this License." + , "However, parties who have received copies, or rights, from you under" + , "this License will not have their licenses terminated so long as such" + , "parties remain in full compliance." + , "" + , " 5. You are not required to accept this License, since you have not" + , "signed it. However, nothing else grants you permission to modify or" + , "distribute the Program or its derivative works. These actions are" + , "prohibited by law if you do not accept this License. Therefore, by" + , "modifying or distributing the Program (or any work based on the" + , "Program), you indicate your acceptance of this License to do so, and" + , "all its terms and conditions for copying, distributing or modifying" + , "the Program or works based on it." + , "" + , " 6. Each time you redistribute the Program (or any work based on the" + , "Program), the recipient automatically receives a license from the" + , "original licensor to copy, distribute or modify the Program subject to" + , "these terms and conditions. You may not impose any further" + , "restrictions on the recipients' exercise of the rights granted herein." + , "You are not responsible for enforcing compliance by third parties to" + , "this License." + , "" + , " 7. If, as a consequence of a court judgment or allegation of patent" + , "infringement or for any other reason (not limited to patent issues)," + , "conditions are imposed on you (whether by court order, agreement or" + , "otherwise) that contradict the conditions of this License, they do not" + , "excuse you from the conditions of this License. If you cannot" + , "distribute so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you" + , "may not distribute the Program at all. For example, if a patent" + , "license would not permit royalty-free redistribution of the Program by" + , "all those who receive copies directly or indirectly through you, then" + , "the only way you could satisfy both it and this License would be to" + , "refrain entirely from distribution of the Program." + , "" + , "If any portion of this section is held invalid or unenforceable under" + , "any particular circumstance, the balance of the section is intended to" + , "apply and the section as a whole is intended to apply in other" + , "circumstances." + , "" + , "It is not the purpose of this section to induce you to infringe any" + , "patents or other property right claims or to contest validity of any" + , "such claims; this section has the sole purpose of protecting the" + , "integrity of the free software distribution system, which is" + , "implemented by public license practices. Many people have made" + , "generous contributions to the wide range of software distributed" + , "through that system in reliance on consistent application of that" + , "system; it is up to the author/donor to decide if he or she is willing" + , "to distribute software through any other system and a licensee cannot" + , "impose that choice." + , "" + , "This section is intended to make thoroughly clear what is believed to" + , "be a consequence of the rest of this License." + , "" + , " 8. If the distribution and/or use of the Program is restricted in" + , "certain countries either by patents or by copyrighted interfaces, the" + , "original copyright holder who places the Program under this License" + , "may add an explicit geographical distribution limitation excluding" + , "those countries, so that distribution is permitted only in or among" + , "countries not thus excluded. In such case, this License incorporates" + , "the limitation as if written in the body of this License." + , "" + , " 9. The Free Software Foundation may publish revised and/or new versions" + , "of the General Public License from time to time. Such new versions will" + , "be similar in spirit to the present version, but may differ in detail to" + , "address new problems or concerns." + , "" + , "Each version is given a distinguishing version number. If the Program" + , "specifies a version number of this License which applies to it and \"any" + , "later version\", you have the option of following the terms and conditions" + , "either of that version or of any later version published by the Free" + , "Software Foundation. If the Program does not specify a version number of" + , "this License, you may choose any version ever published by the Free Software" + , "Foundation." + , "" + , " 10. If you wish to incorporate parts of the Program into other free" + , "programs whose distribution conditions are different, write to the author" + , "to ask for permission. For software which is copyrighted by the Free" + , "Software Foundation, write to the Free Software Foundation; we sometimes" + , "make exceptions for this. Our decision will be guided by the two goals" + , "of preserving the free status of all derivatives of our free software and" + , "of promoting the sharing and reuse of software generally." + , "" + , " NO WARRANTY" + , "" + , " 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY" + , "FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN" + , "OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES" + , "PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED" + , "OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF" + , "MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS" + , "TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE" + , "PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING," + , "REPAIR OR CORRECTION." + , "" + , " 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" + , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR" + , "REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES," + , "INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING" + , "OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED" + , "TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY" + , "YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER" + , "PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE" + , "POSSIBILITY OF SUCH DAMAGES." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Programs" + , "" + , " If you develop a new program, and you want it to be of the greatest" + , "possible use to the public, the best way to achieve this is to make it" + , "free software which everyone can redistribute and change under these terms." + , "" + , " To do so, attach the following notices to the program. It is safest" + , "to attach them to the start of each source file to most effectively" + , "convey the exclusion of warranty; and each file should have at least" + , "the \"copyright\" line and a pointer to where the full notice is found." + , "" + , " " + , " Copyright (C) " + , "" + , " This program is free software; you can redistribute it and/or modify" + , " it under the terms of the GNU General Public License as published by" + , " the Free Software Foundation; either version 2 of the License, or" + , " (at your option) any later version." + , "" + , " This program is distributed in the hope that it will be useful," + , " but WITHOUT ANY WARRANTY; without even the implied warranty of" + , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , " GNU General Public License for more details." + , "" + , " You should have received a copy of the GNU General Public License along" + , " with this program; if not, write to the Free Software Foundation, Inc.," + , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA." + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , "If the program is interactive, make it output a short notice like this" + , "when it starts in an interactive mode:" + , "" + , " Gnomovision version 69, Copyright (C) year name of author" + , " Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'." + , " This is free software, and you are welcome to redistribute it" + , " under certain conditions; type `show c' for details." + , "" + , "The hypothetical commands `show w' and `show c' should show the appropriate" + , "parts of the General Public License. Of course, the commands you use may" + , "be called something other than `show w' and `show c'; they could even be" + , "mouse-clicks or menu items--whatever suits your program." + , "" + , "You should also get your employer (if you work as a programmer) or your" + , "school, if any, to sign a \"copyright disclaimer\" for the program, if" + , "necessary. Here is a sample; alter the names:" + , "" + , " Yoyodyne, Inc., hereby disclaims all copyright interest in the program" + , " `Gnomovision' (which makes passes at compilers) written by James Hacker." + , "" + , " , 1 April 1989" + , " Ty Coon, President of Vice" + , "" + , "This General Public License does not permit incorporating your program into" + , "proprietary programs. If your program is a subroutine library, you may" + , "consider it more useful to permit linking proprietary applications with the" + , "library. If this is what you want to do, use the GNU Lesser General" + , "Public License instead of this License." + ] + +gplv3 :: License +gplv3 = unlines + [ " GNU GENERAL PUBLIC LICENSE" + , " Version 3, 29 June 2007" + , "" + , " Copyright (C) 2007 Free Software Foundation, Inc. " + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , " Preamble" + , "" + , " The GNU General Public License is a free, copyleft license for" + , "software and other kinds of works." + , "" + , " The licenses for most software and other practical works are designed" + , "to take away your freedom to share and change the works. By contrast," + , "the GNU General Public License is intended to guarantee your freedom to" + , "share and change all versions of a program--to make sure it remains free" + , "software for all its users. We, the Free Software Foundation, use the" + , "GNU General Public License for most of our software; it applies also to" + , "any other work released this way by its authors. You can apply it to" + , "your programs, too." + , "" + , " When we speak of free software, we are referring to freedom, not" + , "price. Our General Public Licenses are designed to make sure that you" + , "have the freedom to distribute copies of free software (and charge for" + , "them if you wish), that you receive source code or can get it if you" + , "want it, that you can change the software or use pieces of it in new" + , "free programs, and that you know you can do these things." + , "" + , " To protect your rights, we need to prevent others from denying you" + , "these rights or asking you to surrender the rights. Therefore, you have" + , "certain responsibilities if you distribute copies of the software, or if" + , "you modify it: responsibilities to respect the freedom of others." + , "" + , " For example, if you distribute copies of such a program, whether" + , "gratis or for a fee, you must pass on to the recipients the same" + , "freedoms that you received. You must make sure that they, too, receive" + , "or can get the source code. And you must show them these terms so they" + , "know their rights." + , "" + , " Developers that use the GNU GPL protect your rights with two steps:" + , "(1) assert copyright on the software, and (2) offer you this License" + , "giving you legal permission to copy, distribute and/or modify it." + , "" + , " For the developers' and authors' protection, the GPL clearly explains" + , "that there is no warranty for this free software. For both users' and" + , "authors' sake, the GPL requires that modified versions be marked as" + , "changed, so that their problems will not be attributed erroneously to" + , "authors of previous versions." + , "" + , " Some devices are designed to deny users access to install or run" + , "modified versions of the software inside them, although the manufacturer" + , "can do so. This is fundamentally incompatible with the aim of" + , "protecting users' freedom to change the software. The systematic" + , "pattern of such abuse occurs in the area of products for individuals to" + , "use, which is precisely where it is most unacceptable. Therefore, we" + , "have designed this version of the GPL to prohibit the practice for those" + , "products. If such problems arise substantially in other domains, we" + , "stand ready to extend this provision to those domains in future versions" + , "of the GPL, as needed to protect the freedom of users." + , "" + , " Finally, every program is threatened constantly by software patents." + , "States should not allow patents to restrict development and use of" + , "software on general-purpose computers, but in those that do, we wish to" + , "avoid the special danger that patents applied to a free program could" + , "make it effectively proprietary. To prevent this, the GPL assures that" + , "patents cannot be used to render the program non-free." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow." + , "" + , " TERMS AND CONDITIONS" + , "" + , " 0. Definitions." + , "" + , " \"This License\" refers to version 3 of the GNU General Public License." + , "" + , " \"Copyright\" also means copyright-like laws that apply to other kinds of" + , "works, such as semiconductor masks." + , " " + , " \"The Program\" refers to any copyrightable work licensed under this" + , "License. Each licensee is addressed as \"you\". \"Licensees\" and" + , "\"recipients\" may be individuals or organizations." + , "" + , " To \"modify\" a work means to copy from or adapt all or part of the work" + , "in a fashion requiring copyright permission, other than the making of an" + , "exact copy. The resulting work is called a \"modified version\" of the" + , "earlier work or a work \"based on\" the earlier work." + , "" + , " A \"covered work\" means either the unmodified Program or a work based" + , "on the Program." + , "" + , " To \"propagate\" a work means to do anything with it that, without" + , "permission, would make you directly or secondarily liable for" + , "infringement under applicable copyright law, except executing it on a" + , "computer or modifying a private copy. Propagation includes copying," + , "distribution (with or without modification), making available to the" + , "public, and in some countries other activities as well." + , "" + , " To \"convey\" a work means any kind of propagation that enables other" + , "parties to make or receive copies. Mere interaction with a user through" + , "a computer network, with no transfer of a copy, is not conveying." + , "" + , " An interactive user interface displays \"Appropriate Legal Notices\"" + , "to the extent that it includes a convenient and prominently visible" + , "feature that (1) displays an appropriate copyright notice, and (2)" + , "tells the user that there is no warranty for the work (except to the" + , "extent that warranties are provided), that licensees may convey the" + , "work under this License, and how to view a copy of this License. If" + , "the interface presents a list of user commands or options, such as a" + , "menu, a prominent item in the list meets this criterion." + , "" + , " 1. Source Code." + , "" + , " The \"source code\" for a work means the preferred form of the work" + , "for making modifications to it. \"Object code\" means any non-source" + , "form of a work." + , "" + , " A \"Standard Interface\" means an interface that either is an official" + , "standard defined by a recognized standards body, or, in the case of" + , "interfaces specified for a particular programming language, one that" + , "is widely used among developers working in that language." + , "" + , " The \"System Libraries\" of an executable work include anything, other" + , "than the work as a whole, that (a) is included in the normal form of" + , "packaging a Major Component, but which is not part of that Major" + , "Component, and (b) serves only to enable use of the work with that" + , "Major Component, or to implement a Standard Interface for which an" + , "implementation is available to the public in source code form. A" + , "\"Major Component\", in this context, means a major essential component" + , "(kernel, window system, and so on) of the specific operating system" + , "(if any) on which the executable work runs, or a compiler used to" + , "produce the work, or an object code interpreter used to run it." + , "" + , " The \"Corresponding Source\" for a work in object code form means all" + , "the source code needed to generate, install, and (for an executable" + , "work) run the object code and to modify the work, including scripts to" + , "control those activities. However, it does not include the work's" + , "System Libraries, or general-purpose tools or generally available free" + , "programs which are used unmodified in performing those activities but" + , "which are not part of the work. For example, Corresponding Source" + , "includes interface definition files associated with source files for" + , "the work, and the source code for shared libraries and dynamically" + , "linked subprograms that the work is specifically designed to require," + , "such as by intimate data communication or control flow between those" + , "subprograms and other parts of the work." + , "" + , " The Corresponding Source need not include anything that users" + , "can regenerate automatically from other parts of the Corresponding" + , "Source." + , "" + , " The Corresponding Source for a work in source code form is that" + , "same work." + , "" + , " 2. Basic Permissions." + , "" + , " All rights granted under this License are granted for the term of" + , "copyright on the Program, and are irrevocable provided the stated" + , "conditions are met. This License explicitly affirms your unlimited" + , "permission to run the unmodified Program. The output from running a" + , "covered work is covered by this License only if the output, given its" + , "content, constitutes a covered work. This License acknowledges your" + , "rights of fair use or other equivalent, as provided by copyright law." + , "" + , " You may make, run and propagate covered works that you do not" + , "convey, without conditions so long as your license otherwise remains" + , "in force. You may convey covered works to others for the sole purpose" + , "of having them make modifications exclusively for you, or provide you" + , "with facilities for running those works, provided that you comply with" + , "the terms of this License in conveying all material for which you do" + , "not control copyright. Those thus making or running the covered works" + , "for you must do so exclusively on your behalf, under your direction" + , "and control, on terms that prohibit them from making any copies of" + , "your copyrighted material outside their relationship with you." + , "" + , " Conveying under any other circumstances is permitted solely under" + , "the conditions stated below. Sublicensing is not allowed; section 10" + , "makes it unnecessary." + , "" + , " 3. Protecting Users' Legal Rights From Anti-Circumvention Law." + , "" + , " No covered work shall be deemed part of an effective technological" + , "measure under any applicable law fulfilling obligations under article" + , "11 of the WIPO copyright treaty adopted on 20 December 1996, or" + , "similar laws prohibiting or restricting circumvention of such" + , "measures." + , "" + , " When you convey a covered work, you waive any legal power to forbid" + , "circumvention of technological measures to the extent such circumvention" + , "is effected by exercising rights under this License with respect to" + , "the covered work, and you disclaim any intention to limit operation or" + , "modification of the work as a means of enforcing, against the work's" + , "users, your or third parties' legal rights to forbid circumvention of" + , "technological measures." + , "" + , " 4. Conveying Verbatim Copies." + , "" + , " You may convey verbatim copies of the Program's source code as you" + , "receive it, in any medium, provided that you conspicuously and" + , "appropriately publish on each copy an appropriate copyright notice;" + , "keep intact all notices stating that this License and any" + , "non-permissive terms added in accord with section 7 apply to the code;" + , "keep intact all notices of the absence of any warranty; and give all" + , "recipients a copy of this License along with the Program." + , "" + , " You may charge any price or no price for each copy that you convey," + , "and you may offer support or warranty protection for a fee." + , "" + , " 5. Conveying Modified Source Versions." + , "" + , " You may convey a work based on the Program, or the modifications to" + , "produce it from the Program, in the form of source code under the" + , "terms of section 4, provided that you also meet all of these conditions:" + , "" + , " a) The work must carry prominent notices stating that you modified" + , " it, and giving a relevant date." + , "" + , " b) The work must carry prominent notices stating that it is" + , " released under this License and any conditions added under section" + , " 7. This requirement modifies the requirement in section 4 to" + , " \"keep intact all notices\"." + , "" + , " c) You must license the entire work, as a whole, under this" + , " License to anyone who comes into possession of a copy. This" + , " License will therefore apply, along with any applicable section 7" + , " additional terms, to the whole of the work, and all its parts," + , " regardless of how they are packaged. This License gives no" + , " permission to license the work in any other way, but it does not" + , " invalidate such permission if you have separately received it." + , "" + , " d) If the work has interactive user interfaces, each must display" + , " Appropriate Legal Notices; however, if the Program has interactive" + , " interfaces that do not display Appropriate Legal Notices, your" + , " work need not make them do so." + , "" + , " A compilation of a covered work with other separate and independent" + , "works, which are not by their nature extensions of the covered work," + , "and which are not combined with it such as to form a larger program," + , "in or on a volume of a storage or distribution medium, is called an" + , "\"aggregate\" if the compilation and its resulting copyright are not" + , "used to limit the access or legal rights of the compilation's users" + , "beyond what the individual works permit. Inclusion of a covered work" + , "in an aggregate does not cause this License to apply to the other" + , "parts of the aggregate." + , "" + , " 6. Conveying Non-Source Forms." + , "" + , " You may convey a covered work in object code form under the terms" + , "of sections 4 and 5, provided that you also convey the" + , "machine-readable Corresponding Source under the terms of this License," + , "in one of these ways:" + , "" + , " a) Convey the object code in, or embodied in, a physical product" + , " (including a physical distribution medium), accompanied by the" + , " Corresponding Source fixed on a durable physical medium" + , " customarily used for software interchange." + , "" + , " b) Convey the object code in, or embodied in, a physical product" + , " (including a physical distribution medium), accompanied by a" + , " written offer, valid for at least three years and valid for as" + , " long as you offer spare parts or customer support for that product" + , " model, to give anyone who possesses the object code either (1) a" + , " copy of the Corresponding Source for all the software in the" + , " product that is covered by this License, on a durable physical" + , " medium customarily used for software interchange, for a price no" + , " more than your reasonable cost of physically performing this" + , " conveying of source, or (2) access to copy the" + , " Corresponding Source from a network server at no charge." + , "" + , " c) Convey individual copies of the object code with a copy of the" + , " written offer to provide the Corresponding Source. This" + , " alternative is allowed only occasionally and noncommercially, and" + , " only if you received the object code with such an offer, in accord" + , " with subsection 6b." + , "" + , " d) Convey the object code by offering access from a designated" + , " place (gratis or for a charge), and offer equivalent access to the" + , " Corresponding Source in the same way through the same place at no" + , " further charge. You need not require recipients to copy the" + , " Corresponding Source along with the object code. If the place to" + , " copy the object code is a network server, the Corresponding Source" + , " may be on a different server (operated by you or a third party)" + , " that supports equivalent copying facilities, provided you maintain" + , " clear directions next to the object code saying where to find the" + , " Corresponding Source. Regardless of what server hosts the" + , " Corresponding Source, you remain obligated to ensure that it is" + , " available for as long as needed to satisfy these requirements." + , "" + , " e) Convey the object code using peer-to-peer transmission, provided" + , " you inform other peers where the object code and Corresponding" + , " Source of the work are being offered to the general public at no" + , " charge under subsection 6d." + , "" + , " A separable portion of the object code, whose source code is excluded" + , "from the Corresponding Source as a System Library, need not be" + , "included in conveying the object code work." + , "" + , " A \"User Product\" is either (1) a \"consumer product\", which means any" + , "tangible personal property which is normally used for personal, family," + , "or household purposes, or (2) anything designed or sold for incorporation" + , "into a dwelling. In determining whether a product is a consumer product," + , "doubtful cases shall be resolved in favor of coverage. For a particular" + , "product received by a particular user, \"normally used\" refers to a" + , "typical or common use of that class of product, regardless of the status" + , "of the particular user or of the way in which the particular user" + , "actually uses, or expects or is expected to use, the product. A product" + , "is a consumer product regardless of whether the product has substantial" + , "commercial, industrial or non-consumer uses, unless such uses represent" + , "the only significant mode of use of the product." + , "" + , " \"Installation Information\" for a User Product means any methods," + , "procedures, authorization keys, or other information required to install" + , "and execute modified versions of a covered work in that User Product from" + , "a modified version of its Corresponding Source. The information must" + , "suffice to ensure that the continued functioning of the modified object" + , "code is in no case prevented or interfered with solely because" + , "modification has been made." + , "" + , " If you convey an object code work under this section in, or with, or" + , "specifically for use in, a User Product, and the conveying occurs as" + , "part of a transaction in which the right of possession and use of the" + , "User Product is transferred to the recipient in perpetuity or for a" + , "fixed term (regardless of how the transaction is characterized), the" + , "Corresponding Source conveyed under this section must be accompanied" + , "by the Installation Information. But this requirement does not apply" + , "if neither you nor any third party retains the ability to install" + , "modified object code on the User Product (for example, the work has" + , "been installed in ROM)." + , "" + , " The requirement to provide Installation Information does not include a" + , "requirement to continue to provide support service, warranty, or updates" + , "for a work that has been modified or installed by the recipient, or for" + , "the User Product in which it has been modified or installed. Access to a" + , "network may be denied when the modification itself materially and" + , "adversely affects the operation of the network or violates the rules and" + , "protocols for communication across the network." + , "" + , " Corresponding Source conveyed, and Installation Information provided," + , "in accord with this section must be in a format that is publicly" + , "documented (and with an implementation available to the public in" + , "source code form), and must require no special password or key for" + , "unpacking, reading or copying." + , "" + , " 7. Additional Terms." + , "" + , " \"Additional permissions\" are terms that supplement the terms of this" + , "License by making exceptions from one or more of its conditions." + , "Additional permissions that are applicable to the entire Program shall" + , "be treated as though they were included in this License, to the extent" + , "that they are valid under applicable law. If additional permissions" + , "apply only to part of the Program, that part may be used separately" + , "under those permissions, but the entire Program remains governed by" + , "this License without regard to the additional permissions." + , "" + , " When you convey a copy of a covered work, you may at your option" + , "remove any additional permissions from that copy, or from any part of" + , "it. (Additional permissions may be written to require their own" + , "removal in certain cases when you modify the work.) You may place" + , "additional permissions on material, added by you to a covered work," + , "for which you have or can give appropriate copyright permission." + , "" + , " Notwithstanding any other provision of this License, for material you" + , "add to a covered work, you may (if authorized by the copyright holders of" + , "that material) supplement the terms of this License with terms:" + , "" + , " a) Disclaiming warranty or limiting liability differently from the" + , " terms of sections 15 and 16 of this License; or" + , "" + , " b) Requiring preservation of specified reasonable legal notices or" + , " author attributions in that material or in the Appropriate Legal" + , " Notices displayed by works containing it; or" + , "" + , " c) Prohibiting misrepresentation of the origin of that material, or" + , " requiring that modified versions of such material be marked in" + , " reasonable ways as different from the original version; or" + , "" + , " d) Limiting the use for publicity purposes of names of licensors or" + , " authors of the material; or" + , "" + , " e) Declining to grant rights under trademark law for use of some" + , " trade names, trademarks, or service marks; or" + , "" + , " f) Requiring indemnification of licensors and authors of that" + , " material by anyone who conveys the material (or modified versions of" + , " it) with contractual assumptions of liability to the recipient, for" + , " any liability that these contractual assumptions directly impose on" + , " those licensors and authors." + , "" + , " All other non-permissive additional terms are considered \"further" + , "restrictions\" within the meaning of section 10. If the Program as you" + , "received it, or any part of it, contains a notice stating that it is" + , "governed by this License along with a term that is a further" + , "restriction, you may remove that term. If a license document contains" + , "a further restriction but permits relicensing or conveying under this" + , "License, you may add to a covered work material governed by the terms" + , "of that license document, provided that the further restriction does" + , "not survive such relicensing or conveying." + , "" + , " If you add terms to a covered work in accord with this section, you" + , "must place, in the relevant source files, a statement of the" + , "additional terms that apply to those files, or a notice indicating" + , "where to find the applicable terms." + , "" + , " Additional terms, permissive or non-permissive, may be stated in the" + , "form of a separately written license, or stated as exceptions;" + , "the above requirements apply either way." + , "" + , " 8. Termination." + , "" + , " You may not propagate or modify a covered work except as expressly" + , "provided under this License. Any attempt otherwise to propagate or" + , "modify it is void, and will automatically terminate your rights under" + , "this License (including any patent licenses granted under the third" + , "paragraph of section 11)." + , "" + , " However, if you cease all violation of this License, then your" + , "license from a particular copyright holder is reinstated (a)" + , "provisionally, unless and until the copyright holder explicitly and" + , "finally terminates your license, and (b) permanently, if the copyright" + , "holder fails to notify you of the violation by some reasonable means" + , "prior to 60 days after the cessation." + , "" + , " Moreover, your license from a particular copyright holder is" + , "reinstated permanently if the copyright holder notifies you of the" + , "violation by some reasonable means, this is the first time you have" + , "received notice of violation of this License (for any work) from that" + , "copyright holder, and you cure the violation prior to 30 days after" + , "your receipt of the notice." + , "" + , " Termination of your rights under this section does not terminate the" + , "licenses of parties who have received copies or rights from you under" + , "this License. If your rights have been terminated and not permanently" + , "reinstated, you do not qualify to receive new licenses for the same" + , "material under section 10." + , "" + , " 9. Acceptance Not Required for Having Copies." + , "" + , " You are not required to accept this License in order to receive or" + , "run a copy of the Program. Ancillary propagation of a covered work" + , "occurring solely as a consequence of using peer-to-peer transmission" + , "to receive a copy likewise does not require acceptance. However," + , "nothing other than this License grants you permission to propagate or" + , "modify any covered work. These actions infringe copyright if you do" + , "not accept this License. Therefore, by modifying or propagating a" + , "covered work, you indicate your acceptance of this License to do so." + , "" + , " 10. Automatic Licensing of Downstream Recipients." + , "" + , " Each time you convey a covered work, the recipient automatically" + , "receives a license from the original licensors, to run, modify and" + , "propagate that work, subject to this License. You are not responsible" + , "for enforcing compliance by third parties with this License." + , "" + , " An \"entity transaction\" is a transaction transferring control of an" + , "organization, or substantially all assets of one, or subdividing an" + , "organization, or merging organizations. If propagation of a covered" + , "work results from an entity transaction, each party to that" + , "transaction who receives a copy of the work also receives whatever" + , "licenses to the work the party's predecessor in interest had or could" + , "give under the previous paragraph, plus a right to possession of the" + , "Corresponding Source of the work from the predecessor in interest, if" + , "the predecessor has it or can get it with reasonable efforts." + , "" + , " You may not impose any further restrictions on the exercise of the" + , "rights granted or affirmed under this License. For example, you may" + , "not impose a license fee, royalty, or other charge for exercise of" + , "rights granted under this License, and you may not initiate litigation" + , "(including a cross-claim or counterclaim in a lawsuit) alleging that" + , "any patent claim is infringed by making, using, selling, offering for" + , "sale, or importing the Program or any portion of it." + , "" + , " 11. Patents." + , "" + , " A \"contributor\" is a copyright holder who authorizes use under this" + , "License of the Program or a work on which the Program is based. The" + , "work thus licensed is called the contributor's \"contributor version\"." + , "" + , " A contributor's \"essential patent claims\" are all patent claims" + , "owned or controlled by the contributor, whether already acquired or" + , "hereafter acquired, that would be infringed by some manner, permitted" + , "by this License, of making, using, or selling its contributor version," + , "but do not include claims that would be infringed only as a" + , "consequence of further modification of the contributor version. For" + , "purposes of this definition, \"control\" includes the right to grant" + , "patent sublicenses in a manner consistent with the requirements of" + , "this License." + , "" + , " Each contributor grants you a non-exclusive, worldwide, royalty-free" + , "patent license under the contributor's essential patent claims, to" + , "make, use, sell, offer for sale, import and otherwise run, modify and" + , "propagate the contents of its contributor version." + , "" + , " In the following three paragraphs, a \"patent license\" is any express" + , "agreement or commitment, however denominated, not to enforce a patent" + , "(such as an express permission to practice a patent or covenant not to" + , "sue for patent infringement). To \"grant\" such a patent license to a" + , "party means to make such an agreement or commitment not to enforce a" + , "patent against the party." + , "" + , " If you convey a covered work, knowingly relying on a patent license," + , "and the Corresponding Source of the work is not available for anyone" + , "to copy, free of charge and under the terms of this License, through a" + , "publicly available network server or other readily accessible means," + , "then you must either (1) cause the Corresponding Source to be so" + , "available, or (2) arrange to deprive yourself of the benefit of the" + , "patent license for this particular work, or (3) arrange, in a manner" + , "consistent with the requirements of this License, to extend the patent" + , "license to downstream recipients. \"Knowingly relying\" means you have" + , "actual knowledge that, but for the patent license, your conveying the" + , "covered work in a country, or your recipient's use of the covered work" + , "in a country, would infringe one or more identifiable patents in that" + , "country that you have reason to believe are valid." + , " " + , " If, pursuant to or in connection with a single transaction or" + , "arrangement, you convey, or propagate by procuring conveyance of, a" + , "covered work, and grant a patent license to some of the parties" + , "receiving the covered work authorizing them to use, propagate, modify" + , "or convey a specific copy of the covered work, then the patent license" + , "you grant is automatically extended to all recipients of the covered" + , "work and works based on it." + , "" + , " A patent license is \"discriminatory\" if it does not include within" + , "the scope of its coverage, prohibits the exercise of, or is" + , "conditioned on the non-exercise of one or more of the rights that are" + , "specifically granted under this License. You may not convey a covered" + , "work if you are a party to an arrangement with a third party that is" + , "in the business of distributing software, under which you make payment" + , "to the third party based on the extent of your activity of conveying" + , "the work, and under which the third party grants, to any of the" + , "parties who would receive the covered work from you, a discriminatory" + , "patent license (a) in connection with copies of the covered work" + , "conveyed by you (or copies made from those copies), or (b) primarily" + , "for and in connection with specific products or compilations that" + , "contain the covered work, unless you entered into that arrangement," + , "or that patent license was granted, prior to 28 March 2007." + , "" + , " Nothing in this License shall be construed as excluding or limiting" + , "any implied license or other defenses to infringement that may" + , "otherwise be available to you under applicable patent law." + , "" + , " 12. No Surrender of Others' Freedom." + , "" + , " If conditions are imposed on you (whether by court order, agreement or" + , "otherwise) that contradict the conditions of this License, they do not" + , "excuse you from the conditions of this License. If you cannot convey a" + , "covered work so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you may" + , "not convey it at all. For example, if you agree to terms that obligate you" + , "to collect a royalty for further conveying from those to whom you convey" + , "the Program, the only way you could satisfy both those terms and this" + , "License would be to refrain entirely from conveying the Program." + , "" + , " 13. Use with the GNU Affero General Public License." + , "" + , " Notwithstanding any other provision of this License, you have" + , "permission to link or combine any covered work with a work licensed" + , "under version 3 of the GNU Affero General Public License into a single" + , "combined work, and to convey the resulting work. The terms of this" + , "License will continue to apply to the part which is the covered work," + , "but the special requirements of the GNU Affero General Public License," + , "section 13, concerning interaction through a network will apply to the" + , "combination as such." + , "" + , " 14. Revised Versions of this License." + , "" + , " The Free Software Foundation may publish revised and/or new versions of" + , "the GNU General Public License from time to time. Such new versions will" + , "be similar in spirit to the present version, but may differ in detail to" + , "address new problems or concerns." + , "" + , " Each version is given a distinguishing version number. If the" + , "Program specifies that a certain numbered version of the GNU General" + , "Public License \"or any later version\" applies to it, you have the" + , "option of following the terms and conditions either of that numbered" + , "version or of any later version published by the Free Software" + , "Foundation. If the Program does not specify a version number of the" + , "GNU General Public License, you may choose any version ever published" + , "by the Free Software Foundation." + , "" + , " If the Program specifies that a proxy can decide which future" + , "versions of the GNU General Public License can be used, that proxy's" + , "public statement of acceptance of a version permanently authorizes you" + , "to choose that version for the Program." + , "" + , " Later license versions may give you additional or different" + , "permissions. However, no additional obligations are imposed on any" + , "author or copyright holder as a result of your choosing to follow a" + , "later version." + , "" + , " 15. Disclaimer of Warranty." + , "" + , " THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY" + , "APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT" + , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY" + , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO," + , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" + , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM" + , "IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF" + , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION." + , "" + , " 16. Limitation of Liability." + , "" + , " IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING" + , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS" + , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY" + , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE" + , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF" + , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD" + , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS)," + , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF" + , "SUCH DAMAGES." + , "" + , " 17. Interpretation of Sections 15 and 16." + , "" + , " If the disclaimer of warranty and limitation of liability provided" + , "above cannot be given local legal effect according to their terms," + , "reviewing courts shall apply local law that most closely approximates" + , "an absolute waiver of all civil liability in connection with the" + , "Program, unless a warranty or assumption of liability accompanies a" + , "copy of the Program in return for a fee." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Programs" + , "" + , " If you develop a new program, and you want it to be of the greatest" + , "possible use to the public, the best way to achieve this is to make it" + , "free software which everyone can redistribute and change under these terms." + , "" + , " To do so, attach the following notices to the program. It is safest" + , "to attach them to the start of each source file to most effectively" + , "state the exclusion of warranty; and each file should have at least" + , "the \"copyright\" line and a pointer to where the full notice is found." + , "" + , " " + , " Copyright (C) " + , "" + , " This program is free software: you can redistribute it and/or modify" + , " it under the terms of the GNU General Public License as published by" + , " the Free Software Foundation, either version 3 of the License, or" + , " (at your option) any later version." + , "" + , " This program is distributed in the hope that it will be useful," + , " but WITHOUT ANY WARRANTY; without even the implied warranty of" + , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" + , " GNU General Public License for more details." + , "" + , " You should have received a copy of the GNU General Public License" + , " along with this program. If not, see ." + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , " If the program does terminal interaction, make it output a short" + , "notice like this when it starts in an interactive mode:" + , "" + , " Copyright (C) " + , " This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'." + , " This is free software, and you are welcome to redistribute it" + , " under certain conditions; type `show c' for details." + , "" + , "The hypothetical commands `show w' and `show c' should show the appropriate" + , "parts of the General Public License. Of course, your program's commands" + , "might be different; for a GUI interface, you would use an \"about box\"." + , "" + , " You should also get your employer (if you work as a programmer) or school," + , "if any, to sign a \"copyright disclaimer\" for the program, if necessary." + , "For more information on this, and how to apply and follow the GNU GPL, see" + , "." + , "" + , " The GNU General Public License does not permit incorporating your program" + , "into proprietary programs. If your program is a subroutine library, you" + , "may consider it more useful to permit linking proprietary applications with" + , "the library. If this is what you want to do, use the GNU Lesser General" + , "Public License instead of this License. But first, please read" + , "." + , "" + ] + +lgpl2 :: License +lgpl2 = unlines + [ " GNU LIBRARY GENERAL PUBLIC LICENSE" + , " Version 2, June 1991" + , "" + , " Copyright (C) 1991 Free Software Foundation, Inc." + , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , "[This is the first released version of the library GPL. It is" + , " numbered 2 because it goes with version 2 of the ordinary GPL.]" + , "" + , " Preamble" + , "" + , " The licenses for most software are designed to take away your" + , "freedom to share and change it. By contrast, the GNU General Public" + , "Licenses are intended to guarantee your freedom to share and change" + , "free software--to make sure the software is free for all its users." + , "" + , " This license, the Library General Public License, applies to some" + , "specially designated Free Software Foundation software, and to any" + , "other libraries whose authors decide to use it. You can use it for" + , "your libraries, too." + , "" + , " When we speak of free software, we are referring to freedom, not" + , "price. Our General Public Licenses are designed to make sure that you" + , "have the freedom to distribute copies of free software (and charge for" + , "this service if you wish), that you receive source code or can get it" + , "if you want it, that you can change the software or use pieces of it" + , "in new free programs; and that you know you can do these things." + , "" + , " To protect your rights, we need to make restrictions that forbid" + , "anyone to deny you these rights or to ask you to surrender the rights." + , "These restrictions translate to certain responsibilities for you if" + , "you distribute copies of the library, or if you modify it." + , "" + , " For example, if you distribute copies of the library, whether gratis" + , "or for a fee, you must give the recipients all the rights that we gave" + , "you. You must make sure that they, too, receive or can get the source" + , "code. If you link a program with the library, you must provide" + , "complete object files to the recipients so that they can relink them" + , "with the library, after making changes to the library and recompiling" + , "it. And you must show them these terms so they know their rights." + , "" + , " Our method of protecting your rights has two steps: (1) copyright" + , "the library, and (2) offer you this license which gives you legal" + , "permission to copy, distribute and/or modify the library." + , "" + , " Also, for each distributor's protection, we want to make certain" + , "that everyone understands that there is no warranty for this free" + , "library. If the library is modified by someone else and passed on, we" + , "want its recipients to know that what they have is not the original" + , "version, so that any problems introduced by others will not reflect on" + , "the original authors' reputations." + , "" + , " Finally, any free program is threatened constantly by software" + , "patents. We wish to avoid the danger that companies distributing free" + , "software will individually obtain patent licenses, thus in effect" + , "transforming the program into proprietary software. To prevent this," + , "we have made it clear that any patent must be licensed for everyone's" + , "free use or not licensed at all." + , "" + , " Most GNU software, including some libraries, is covered by the ordinary" + , "GNU General Public License, which was designed for utility programs. This" + , "license, the GNU Library General Public License, applies to certain" + , "designated libraries. This license is quite different from the ordinary" + , "one; be sure to read it in full, and don't assume that anything in it is" + , "the same as in the ordinary license." + , "" + , " The reason we have a separate public license for some libraries is that" + , "they blur the distinction we usually make between modifying or adding to a" + , "program and simply using it. Linking a program with a library, without" + , "changing the library, is in some sense simply using the library, and is" + , "analogous to running a utility program or application program. However, in" + , "a textual and legal sense, the linked executable is a combined work, a" + , "derivative of the original library, and the ordinary General Public License" + , "treats it as such." + , "" + , " Because of this blurred distinction, using the ordinary General" + , "Public License for libraries did not effectively promote software" + , "sharing, because most developers did not use the libraries. We" + , "concluded that weaker conditions might promote sharing better." + , "" + , " However, unrestricted linking of non-free programs would deprive the" + , "users of those programs of all benefit from the free status of the" + , "libraries themselves. This Library General Public License is intended to" + , "permit developers of non-free programs to use free libraries, while" + , "preserving your freedom as a user of such programs to change the free" + , "libraries that are incorporated in them. (We have not seen how to achieve" + , "this as regards changes in header files, but we have achieved it as regards" + , "changes in the actual functions of the Library.) The hope is that this" + , "will lead to faster development of free libraries." + , "" + , " The precise terms and conditions for copying, distribution and" + , "modification follow. Pay close attention to the difference between a" + , "\"work based on the library\" and a \"work that uses the library\". The" + , "former contains code derived from the library, while the latter only" + , "works together with the library." + , "" + , " Note that it is possible for a library to be covered by the ordinary" + , "General Public License rather than by this special one." + , "" + , " GNU LIBRARY GENERAL PUBLIC LICENSE" + , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION" + , "" + , " 0. This License Agreement applies to any software library which" + , "contains a notice placed by the copyright holder or other authorized" + , "party saying it may be distributed under the terms of this Library" + , "General Public License (also called \"this License\"). Each licensee is" + , "addressed as \"you\"." + , "" + , " A \"library\" means a collection of software functions and/or data" + , "prepared so as to be conveniently linked with application programs" + , "(which use some of those functions and data) to form executables." + , "" + , " The \"Library\", below, refers to any such software library or work" + , "which has been distributed under these terms. A \"work based on the" + , "Library\" means either the Library or any derivative work under" + , "copyright law: that is to say, a work containing the Library or a" + , "portion of it, either verbatim or with modifications and/or translated" + , "straightforwardly into another language. (Hereinafter, translation is" + , "included without limitation in the term \"modification\".)" + , "" + , " \"Source code\" for a work means the preferred form of the work for" + , "making modifications to it. For a library, complete source code means" + , "all the source code for all modules it contains, plus any associated" + , "interface definition files, plus the scripts used to control compilation" + , "and installation of the library." + , "" + , " Activities other than copying, distribution and modification are not" + , "covered by this License; they are outside its scope. The act of" + , "running a program using the Library is not restricted, and output from" + , "such a program is covered only if its contents constitute a work based" + , "on the Library (independent of the use of the Library in a tool for" + , "writing it). Whether that is true depends on what the Library does" + , "and what the program that uses the Library does." + , " " + , " 1. You may copy and distribute verbatim copies of the Library's" + , "complete source code as you receive it, in any medium, provided that" + , "you conspicuously and appropriately publish on each copy an" + , "appropriate copyright notice and disclaimer of warranty; keep intact" + , "all the notices that refer to this License and to the absence of any" + , "warranty; and distribute a copy of this License along with the" + , "Library." + , "" + , " You may charge a fee for the physical act of transferring a copy," + , "and you may at your option offer warranty protection in exchange for a" + , "fee." + , "" + , " 2. You may modify your copy or copies of the Library or any portion" + , "of it, thus forming a work based on the Library, and copy and" + , "distribute such modifications or work under the terms of Section 1" + , "above, provided that you also meet all of these conditions:" + , "" + , " a) The modified work must itself be a software library." + , "" + , " b) You must cause the files modified to carry prominent notices" + , " stating that you changed the files and the date of any change." + , "" + , " c) You must cause the whole of the work to be licensed at no" + , " charge to all third parties under the terms of this License." + , "" + , " d) If a facility in the modified Library refers to a function or a" + , " table of data to be supplied by an application program that uses" + , " the facility, other than as an argument passed when the facility" + , " is invoked, then you must make a good faith effort to ensure that," + , " in the event an application does not supply such function or" + , " table, the facility still operates, and performs whatever part of" + , " its purpose remains meaningful." + , "" + , " (For example, a function in a library to compute square roots has" + , " a purpose that is entirely well-defined independent of the" + , " application. Therefore, Subsection 2d requires that any" + , " application-supplied function or table used by this function must" + , " be optional: if the application does not supply it, the square" + , " root function must still compute square roots.)" + , "" + , "These requirements apply to the modified work as a whole. If" + , "identifiable sections of that work are not derived from the Library," + , "and can be reasonably considered independent and separate works in" + , "themselves, then this License, and its terms, do not apply to those" + , "sections when you distribute them as separate works. But when you" + , "distribute the same sections as part of a whole which is a work based" + , "on the Library, the distribution of the whole must be on the terms of" + , "this License, whose permissions for other licensees extend to the" + , "entire whole, and thus to each and every part regardless of who wrote" + , "it." + , "" + , "Thus, it is not the intent of this section to claim rights or contest" + , "your rights to work written entirely by you; rather, the intent is to" + , "exercise the right to control the distribution of derivative or" + , "collective works based on the Library." + , "" + , "In addition, mere aggregation of another work not based on the Library" + , "with the Library (or with a work based on the Library) on a volume of" + , "a storage or distribution medium does not bring the other work under" + , "the scope of this License." + , "" + , " 3. You may opt to apply the terms of the ordinary GNU General Public" + , "License instead of this License to a given copy of the Library. To do" + , "this, you must alter all the notices that refer to this License, so" + , "that they refer to the ordinary GNU General Public License, version 2," + , "instead of to this License. (If a newer version than version 2 of the" + , "ordinary GNU General Public License has appeared, then you can specify" + , "that version instead if you wish.) Do not make any other change in" + , "these notices." + , "" + , " Once this change is made in a given copy, it is irreversible for" + , "that copy, so the ordinary GNU General Public License applies to all" + , "subsequent copies and derivative works made from that copy." + , "" + , " This option is useful when you wish to copy part of the code of" + , "the Library into a program that is not a library." + , "" + , " 4. You may copy and distribute the Library (or a portion or" + , "derivative of it, under Section 2) in object code or executable form" + , "under the terms of Sections 1 and 2 above provided that you accompany" + , "it with the complete corresponding machine-readable source code, which" + , "must be distributed under the terms of Sections 1 and 2 above on a" + , "medium customarily used for software interchange." + , "" + , " If distribution of object code is made by offering access to copy" + , "from a designated place, then offering equivalent access to copy the" + , "source code from the same place satisfies the requirement to" + , "distribute the source code, even though third parties are not" + , "compelled to copy the source along with the object code." + , "" + , " 5. A program that contains no derivative of any portion of the" + , "Library, but is designed to work with the Library by being compiled or" + , "linked with it, is called a \"work that uses the Library\". Such a" + , "work, in isolation, is not a derivative work of the Library, and" + , "therefore falls outside the scope of this License." + , "" + , " However, linking a \"work that uses the Library\" with the Library" + , "creates an executable that is a derivative of the Library (because it" + , "contains portions of the Library), rather than a \"work that uses the" + , "library\". The executable is therefore covered by this License." + , "Section 6 states terms for distribution of such executables." + , "" + , " When a \"work that uses the Library\" uses material from a header file" + , "that is part of the Library, the object code for the work may be a" + , "derivative work of the Library even though the source code is not." + , "Whether this is true is especially significant if the work can be" + , "linked without the Library, or if the work is itself a library. The" + , "threshold for this to be true is not precisely defined by law." + , "" + , " If such an object file uses only numerical parameters, data" + , "structure layouts and accessors, and small macros and small inline" + , "functions (ten lines or less in length), then the use of the object" + , "file is unrestricted, regardless of whether it is legally a derivative" + , "work. (Executables containing this object code plus portions of the" + , "Library will still fall under Section 6.)" + , "" + , " Otherwise, if the work is a derivative of the Library, you may" + , "distribute the object code for the work under the terms of Section 6." + , "Any executables containing that work also fall under Section 6," + , "whether or not they are linked directly with the Library itself." + , "" + , " 6. As an exception to the Sections above, you may also compile or" + , "link a \"work that uses the Library\" with the Library to produce a" + , "work containing portions of the Library, and distribute that work" + , "under terms of your choice, provided that the terms permit" + , "modification of the work for the customer's own use and reverse" + , "engineering for debugging such modifications." + , "" + , " You must give prominent notice with each copy of the work that the" + , "Library is used in it and that the Library and its use are covered by" + , "this License. You must supply a copy of this License. If the work" + , "during execution displays copyright notices, you must include the" + , "copyright notice for the Library among them, as well as a reference" + , "directing the user to the copy of this License. Also, you must do one" + , "of these things:" + , "" + , " a) Accompany the work with the complete corresponding" + , " machine-readable source code for the Library including whatever" + , " changes were used in the work (which must be distributed under" + , " Sections 1 and 2 above); and, if the work is an executable linked" + , " with the Library, with the complete machine-readable \"work that" + , " uses the Library\", as object code and/or source code, so that the" + , " user can modify the Library and then relink to produce a modified" + , " executable containing the modified Library. (It is understood" + , " that the user who changes the contents of definitions files in the" + , " Library will not necessarily be able to recompile the application" + , " to use the modified definitions.)" + , "" + , " b) Accompany the work with a written offer, valid for at" + , " least three years, to give the same user the materials" + , " specified in Subsection 6a, above, for a charge no more" + , " than the cost of performing this distribution." + , "" + , " c) If distribution of the work is made by offering access to copy" + , " from a designated place, offer equivalent access to copy the above" + , " specified materials from the same place." + , "" + , " d) Verify that the user has already received a copy of these" + , " materials or that you have already sent this user a copy." + , "" + , " For an executable, the required form of the \"work that uses the" + , "Library\" must include any data and utility programs needed for" + , "reproducing the executable from it. However, as a special exception," + , "the source code distributed need not include anything that is normally" + , "distributed (in either source or binary form) with the major" + , "components (compiler, kernel, and so on) of the operating system on" + , "which the executable runs, unless that component itself accompanies" + , "the executable." + , "" + , " It may happen that this requirement contradicts the license" + , "restrictions of other proprietary libraries that do not normally" + , "accompany the operating system. Such a contradiction means you cannot" + , "use both them and the Library together in an executable that you" + , "distribute." + , "" + , " 7. You may place library facilities that are a work based on the" + , "Library side-by-side in a single library together with other library" + , "facilities not covered by this License, and distribute such a combined" + , "library, provided that the separate distribution of the work based on" + , "the Library and of the other library facilities is otherwise" + , "permitted, and provided that you do these two things:" + , "" + , " a) Accompany the combined library with a copy of the same work" + , " based on the Library, uncombined with any other library" + , " facilities. This must be distributed under the terms of the" + , " Sections above." + , "" + , " b) Give prominent notice with the combined library of the fact" + , " that part of it is a work based on the Library, and explaining" + , " where to find the accompanying uncombined form of the same work." + , "" + , " 8. You may not copy, modify, sublicense, link with, or distribute" + , "the Library except as expressly provided under this License. Any" + , "attempt otherwise to copy, modify, sublicense, link with, or" + , "distribute the Library is void, and will automatically terminate your" + , "rights under this License. However, parties who have received copies," + , "or rights, from you under this License will not have their licenses" + , "terminated so long as such parties remain in full compliance." + , "" + , " 9. You are not required to accept this License, since you have not" + , "signed it. However, nothing else grants you permission to modify or" + , "distribute the Library or its derivative works. These actions are" + , "prohibited by law if you do not accept this License. Therefore, by" + , "modifying or distributing the Library (or any work based on the" + , "Library), you indicate your acceptance of this License to do so, and" + , "all its terms and conditions for copying, distributing or modifying" + , "the Library or works based on it." + , "" + , " 10. Each time you redistribute the Library (or any work based on the" + , "Library), the recipient automatically receives a license from the" + , "original licensor to copy, distribute, link with or modify the Library" + , "subject to these terms and conditions. You may not impose any further" + , "restrictions on the recipients' exercise of the rights granted herein." + , "You are not responsible for enforcing compliance by third parties to" + , "this License." + , "" + , " 11. If, as a consequence of a court judgment or allegation of patent" + , "infringement or for any other reason (not limited to patent issues)," + , "conditions are imposed on you (whether by court order, agreement or" + , "otherwise) that contradict the conditions of this License, they do not" + , "excuse you from the conditions of this License. If you cannot" + , "distribute so as to satisfy simultaneously your obligations under this" + , "License and any other pertinent obligations, then as a consequence you" + , "may not distribute the Library at all. For example, if a patent" + , "license would not permit royalty-free redistribution of the Library by" + , "all those who receive copies directly or indirectly through you, then" + , "the only way you could satisfy both it and this License would be to" + , "refrain entirely from distribution of the Library." + , "" + , "If any portion of this section is held invalid or unenforceable under any" + , "particular circumstance, the balance of the section is intended to apply," + , "and the section as a whole is intended to apply in other circumstances." + , "" + , "It is not the purpose of this section to induce you to infringe any" + , "patents or other property right claims or to contest validity of any" + , "such claims; this section has the sole purpose of protecting the" + , "integrity of the free software distribution system which is" + , "implemented by public license practices. Many people have made" + , "generous contributions to the wide range of software distributed" + , "through that system in reliance on consistent application of that" + , "system; it is up to the author/donor to decide if he or she is willing" + , "to distribute software through any other system and a licensee cannot" + , "impose that choice." + , "" + , "This section is intended to make thoroughly clear what is believed to" + , "be a consequence of the rest of this License." + , "" + , " 12. If the distribution and/or use of the Library is restricted in" + , "certain countries either by patents or by copyrighted interfaces, the" + , "original copyright holder who places the Library under this License may add" + , "an explicit geographical distribution limitation excluding those countries," + , "so that distribution is permitted only in or among countries not thus" + , "excluded. In such case, this License incorporates the limitation as if" + , "written in the body of this License." + , "" + , " 13. The Free Software Foundation may publish revised and/or new" + , "versions of the Library General Public License from time to time." + , "Such new versions will be similar in spirit to the present version," + , "but may differ in detail to address new problems or concerns." + , "" + , "Each version is given a distinguishing version number. If the Library" + , "specifies a version number of this License which applies to it and" + , "\"any later version\", you have the option of following the terms and" + , "conditions either of that version or of any later version published by" + , "the Free Software Foundation. If the Library does not specify a" + , "license version number, you may choose any version ever published by" + , "the Free Software Foundation." + , "" + , " 14. If you wish to incorporate parts of the Library into other free" + , "programs whose distribution conditions are incompatible with these," + , "write to the author to ask for permission. For software which is" + , "copyrighted by the Free Software Foundation, write to the Free" + , "Software Foundation; we sometimes make exceptions for this. Our" + , "decision will be guided by the two goals of preserving the free status" + , "of all derivatives of our free software and of promoting the sharing" + , "and reuse of software generally." + , "" + , " NO WARRANTY" + , "" + , " 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO" + , "WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW." + , "EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR" + , "OTHER PARTIES PROVIDE THE LIBRARY \"AS IS\" WITHOUT WARRANTY OF ANY" + , "KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE" + , "IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR" + , "PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE" + , "LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME" + , "THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION." + , "" + , " 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN" + , "WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY" + , "AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU" + , "FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR" + , "CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE" + , "LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING" + , "RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A" + , "FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF" + , "SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH" + , "DAMAGES." + , "" + , " END OF TERMS AND CONDITIONS" + , "" + , " How to Apply These Terms to Your New Libraries" + , "" + , " If you develop a new library, and you want it to be of the greatest" + , "possible use to the public, we recommend making it free software that" + , "everyone can redistribute and change. You can do so by permitting" + , "redistribution under these terms (or, alternatively, under the terms of the" + , "ordinary General Public License)." + , "" + , " To apply these terms, attach the following notices to the library. It is" + , "safest to attach them to the start of each source file to most effectively" + , "convey the exclusion of warranty; and each file should have at least the" + , "\"copyright\" line and a pointer to where the full notice is found." + , "" + , " " + , " Copyright (C) " + , "" + , " This library is free software; you can redistribute it and/or" + , " modify it under the terms of the GNU Library General Public" + , " License as published by the Free Software Foundation; either" + , " version 2 of the License, or (at your option) any later version." + , "" + , " This library is distributed in the hope that it will be useful," + , " but WITHOUT ANY WARRANTY; without even the implied warranty of" + , " MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU" + , " Library General Public License for more details." + , "" + , " You should have received a copy of the GNU Library General Public" + , " License along with this library; if not, write to the Free" + , " Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA" + , "" + , "Also add information on how to contact you by electronic and paper mail." + , "" + , "You should also get your employer (if you work as a programmer) or your" + , "school, if any, to sign a \"copyright disclaimer\" for the library, if" + , "necessary. Here is a sample; alter the names:" + , "" + , " Yoyodyne, Inc., hereby disclaims all copyright interest in the" + , " library `Frob' (a library for tweaking knobs) written by James Random Hacker." + , "" + , " , 1 April 1990" + , " Ty Coon, President of Vice" + , "" + , "That's all there is to it!" + ] + +lgpl3 :: License +lgpl3 = unlines + [ " GNU LESSER GENERAL PUBLIC LICENSE" + , " Version 3, 29 June 2007" + , "" + , " Copyright (C) 2007 Free Software Foundation, Inc. " + , " Everyone is permitted to copy and distribute verbatim copies" + , " of this license document, but changing it is not allowed." + , "" + , "" + , " This version of the GNU Lesser General Public License incorporates" + , "the terms and conditions of version 3 of the GNU General Public" + , "License, supplemented by the additional permissions listed below." + , "" + , " 0. Additional Definitions. " + , "" + , " As used herein, \"this License\" refers to version 3 of the GNU Lesser" + , "General Public License, and the \"GNU GPL\" refers to version 3 of the GNU" + , "General Public License." + , "" + , " \"The Library\" refers to a covered work governed by this License," + , "other than an Application or a Combined Work as defined below." + , "" + , " An \"Application\" is any work that makes use of an interface provided" + , "by the Library, but which is not otherwise based on the Library." + , "Defining a subclass of a class defined by the Library is deemed a mode" + , "of using an interface provided by the Library." + , "" + , " A \"Combined Work\" is a work produced by combining or linking an" + , "Application with the Library. The particular version of the Library" + , "with which the Combined Work was made is also called the \"Linked" + , "Version\"." + , "" + , " The \"Minimal Corresponding Source\" for a Combined Work means the" + , "Corresponding Source for the Combined Work, excluding any source code" + , "for portions of the Combined Work that, considered in isolation, are" + , "based on the Application, and not on the Linked Version." + , "" + , " The \"Corresponding Application Code\" for a Combined Work means the" + , "object code and/or source code for the Application, including any data" + , "and utility programs needed for reproducing the Combined Work from the" + , "Application, but excluding the System Libraries of the Combined Work." + , "" + , " 1. Exception to Section 3 of the GNU GPL." + , "" + , " You may convey a covered work under sections 3 and 4 of this License" + , "without being bound by section 3 of the GNU GPL." + , "" + , " 2. Conveying Modified Versions." + , "" + , " If you modify a copy of the Library, and, in your modifications, a" + , "facility refers to a function or data to be supplied by an Application" + , "that uses the facility (other than as an argument passed when the" + , "facility is invoked), then you may convey a copy of the modified" + , "version:" + , "" + , " a) under this License, provided that you make a good faith effort to" + , " ensure that, in the event an Application does not supply the" + , " function or data, the facility still operates, and performs" + , " whatever part of its purpose remains meaningful, or" + , "" + , " b) under the GNU GPL, with none of the additional permissions of" + , " this License applicable to that copy." + , "" + , " 3. Object Code Incorporating Material from Library Header Files." + , "" + , " The object code form of an Application may incorporate material from" + , "a header file that is part of the Library. You may convey such object" + , "code under terms of your choice, provided that, if the incorporated" + , "material is not limited to numerical parameters, data structure" + , "layouts and accessors, or small macros, inline functions and templates" + , "(ten or fewer lines in length), you do both of the following:" + , "" + , " a) Give prominent notice with each copy of the object code that the" + , " Library is used in it and that the Library and its use are" + , " covered by this License." + , "" + , " b) Accompany the object code with a copy of the GNU GPL and this license" + , " document." + , "" + , " 4. Combined Works." + , "" + , " You may convey a Combined Work under terms of your choice that," + , "taken together, effectively do not restrict modification of the" + , "portions of the Library contained in the Combined Work and reverse" + , "engineering for debugging such modifications, if you also do each of" + , "the following:" + , "" + , " a) Give prominent notice with each copy of the Combined Work that" + , " the Library is used in it and that the Library and its use are" + , " covered by this License." + , "" + , " b) Accompany the Combined Work with a copy of the GNU GPL and this license" + , " document." + , "" + , " c) For a Combined Work that displays copyright notices during" + , " execution, include the copyright notice for the Library among" + , " these notices, as well as a reference directing the user to the" + , " copies of the GNU GPL and this license document." + , "" + , " d) Do one of the following:" + , "" + , " 0) Convey the Minimal Corresponding Source under the terms of this" + , " License, and the Corresponding Application Code in a form" + , " suitable for, and under terms that permit, the user to" + , " recombine or relink the Application with a modified version of" + , " the Linked Version to produce a modified Combined Work, in the" + , " manner specified by section 6 of the GNU GPL for conveying" + , " Corresponding Source." + , "" + , " 1) Use a suitable shared library mechanism for linking with the" + , " Library. A suitable mechanism is one that (a) uses at run time" + , " a copy of the Library already present on the user's computer" + , " system, and (b) will operate properly with a modified version" + , " of the Library that is interface-compatible with the Linked" + , " Version. " + , "" + , " e) Provide Installation Information, but only if you would otherwise" + , " be required to provide such information under section 6 of the" + , " GNU GPL, and only to the extent that such information is" + , " necessary to install and execute a modified version of the" + , " Combined Work produced by recombining or relinking the" + , " Application with a modified version of the Linked Version. (If" + , " you use option 4d0, the Installation Information must accompany" + , " the Minimal Corresponding Source and Corresponding Application" + , " Code. If you use option 4d1, you must provide the Installation" + , " Information in the manner specified by section 6 of the GNU GPL" + , " for conveying Corresponding Source.)" + , "" + , " 5. Combined Libraries." + , "" + , " You may place library facilities that are a work based on the" + , "Library side by side in a single library together with other library" + , "facilities that are not Applications and are not covered by this" + , "License, and convey such a combined library under terms of your" + , "choice, if you do both of the following:" + , "" + , " a) Accompany the combined library with a copy of the same work based" + , " on the Library, uncombined with any other library facilities," + , " conveyed under the terms of this License." + , "" + , " b) Give prominent notice with the combined library that part of it" + , " is a work based on the Library, and explaining where to find the" + , " accompanying uncombined form of the same work." + , "" + , " 6. Revised Versions of the GNU Lesser General Public License." + , "" + , " The Free Software Foundation may publish revised and/or new versions" + , "of the GNU Lesser General Public License from time to time. Such new" + , "versions will be similar in spirit to the present version, but may" + , "differ in detail to address new problems or concerns." + , "" + , " Each version is given a distinguishing version number. If the" + , "Library as you received it specifies that a certain numbered version" + , "of the GNU Lesser General Public License \"or any later version\"" + , "applies to it, you have the option of following the terms and" + , "conditions either of that published version or of any later version" + , "published by the Free Software Foundation. If the Library as you" + , "received it does not specify a version number of the GNU Lesser" + , "General Public License, you may choose any version of the GNU Lesser" + , "General Public License ever published by the Free Software Foundation." + , "" + , " If the Library as you received it specifies that a proxy can decide" + , "whether future versions of the GNU Lesser General Public License shall" + , "apply, that proxy's public statement of acceptance of any version is" + , "permanent authorization for you to choose that version for the" + , "Library." + ] + diff --git a/cabal/cabal-install/Distribution/Client/Init/Types.hs b/cabal/cabal-install/Distribution/Client/Init/Types.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Init/Types.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Init.Types +-- Copyright : (c) Brent Yorgey, Benedikt Huber 2009 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Some types used by the 'cabal init' command. +-- +----------------------------------------------------------------------------- +module Distribution.Client.Init.Types where + +import Distribution.Simple.Setup + ( Flag(..) ) + +import Distribution.Version +import qualified Distribution.Package as P +import Distribution.License +import Distribution.ModuleName + +import qualified Text.PrettyPrint as Disp +import qualified Distribution.Compat.ReadP as Parse +import Distribution.Text + +import Data.Monoid + +-- | InitFlags is really just a simple type to represent certain +-- portions of a .cabal file. Rather than have a flag for EVERY +-- possible field, we just have one for each field that the user is +-- likely to want and/or that we are likely to be able to +-- intelligently guess. +data InitFlags = + InitFlags { nonInteractive :: Flag Bool + , quiet :: Flag Bool + , packageDir :: Flag FilePath + , noComments :: Flag Bool + , minimal :: Flag Bool + + , packageName :: Flag String + , version :: Flag Version + , cabalVersion :: Flag VersionRange + , license :: Flag License + , author :: Flag String + , email :: Flag String + , homepage :: Flag String + + , synopsis :: Flag String + , category :: Flag (Either String Category) + + , packageType :: Flag PackageType + + , exposedModules :: Maybe [ModuleName] + , otherModules :: Maybe [ModuleName] + + , dependencies :: Maybe [P.Dependency] + , sourceDirs :: Maybe [String] + , buildTools :: Maybe [String] + } + deriving (Show) + +data PackageType = Library | Executable + deriving (Show, Read, Eq) + +instance Text PackageType where + disp = Disp.text . show + parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable] + +instance Monoid InitFlags where + mempty = InitFlags + { nonInteractive = mempty + , quiet = mempty + , packageDir = mempty + , noComments = mempty + , minimal = mempty + , packageName = mempty + , version = mempty + , cabalVersion = mempty + , license = mempty + , author = mempty + , email = mempty + , homepage = mempty + , synopsis = mempty + , category = mempty + , packageType = mempty + , exposedModules = mempty + , otherModules = mempty + , dependencies = mempty + , sourceDirs = mempty + , buildTools = mempty + } + mappend a b = InitFlags + { nonInteractive = combine nonInteractive + , quiet = combine quiet + , packageDir = combine packageDir + , noComments = combine noComments + , minimal = combine minimal + , packageName = combine packageName + , version = combine version + , cabalVersion = combine cabalVersion + , license = combine license + , author = combine author + , email = combine email + , homepage = combine homepage + , synopsis = combine synopsis + , category = combine category + , packageType = combine packageType + , exposedModules = combine exposedModules + , otherModules = combine otherModules + , dependencies = combine dependencies + , sourceDirs = combine sourceDirs + , buildTools = combine buildTools + } + where combine field = field a `mappend` field b + +-- | Some common package categories. +data Category + = Codec + | Concurrency + | Control + | Data + | Database + | Development + | Distribution + | Game + | Graphics + | Language + | Math + | Network + | Sound + | System + | Testing + | Text + | Web + deriving (Read, Show, Eq, Ord, Bounded, Enum) + +instance Text Category where + disp = Disp.text . show + parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ] + +#if MIN_VERSION_base(3,0,0) +#else +-- Compat instance for ghc-6.6 era +instance Monoid a => Monoid (Maybe a) where + mempty = Nothing + Nothing `mappend` m = m + m `mappend` Nothing = m + Just m1 `mappend` Just m2 = Just (m1 `mappend` m2) +#endif diff --git a/cabal/cabal-install/Distribution/Client/Install.hs b/cabal/cabal-install/Distribution/Client/Install.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Install.hs @@ -0,0 +1,891 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Install +-- Copyright : (c) 2005 David Himmelstrup +-- 2007 Bjorn Bringert +-- 2007-2010 Duncan Coutts +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- High level interface to package installation. +----------------------------------------------------------------------------- +module Distribution.Client.Install ( + install, + upgrade, + ) where + +import Data.List + ( unfoldr, find, nub, sort ) +import Data.Maybe + ( isJust, fromMaybe ) +import Control.Exception as Exception + ( handleJust ) +#if MIN_VERSION_base(4,0,0) +import Control.Exception as Exception + ( Exception(toException), catches, Handler(Handler), IOException ) +import System.Exit + ( ExitCode ) +#else +import Control.Exception as Exception + ( Exception(IOException, ExitException) ) +#endif +import Distribution.Compat.ExceptionCI + ( SomeException, catchIO, catchExit ) +import Control.Monad + ( when, unless ) +import System.Directory + ( getTemporaryDirectory, doesFileExist, createDirectoryIfMissing ) +import System.FilePath + ( (), (<.>), takeDirectory ) +import System.IO + ( openFile, IOMode(AppendMode) ) +import System.IO.Error + ( isDoesNotExistError, ioeGetFileName ) + +import Distribution.Client.Targets +import Distribution.Client.Dependency +import Distribution.Client.FetchUtils +import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex) +-- import qualified Distribution.Client.Info as Info +import Distribution.Client.IndexUtils as IndexUtils + ( getSourcePackages, getInstalledPackages ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.Setup + ( GlobalFlags(..) + , ConfigFlags(..), configureCommand, filterConfigureFlags + , ConfigExFlags(..), InstallFlags(..) ) +import Distribution.Client.Config + ( defaultCabalDir ) +import Distribution.Client.Tar (extractTarGzFile) +import Distribution.Client.Types as Source +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +import Distribution.Client.SetupWrapper + ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) +import qualified Distribution.Client.BuildReports.Anonymous as BuildReports +import qualified Distribution.Client.BuildReports.Storage as BuildReports + ( storeAnonymous, storeLocal, fromInstallPlan ) +import qualified Distribution.Client.InstallSymlink as InstallSymlink + ( symlinkBinaries ) +import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade +import qualified Distribution.Client.World as World +import Paths_cabal_install (getBinDir) + +import Distribution.Simple.Compiler + ( CompilerId(..), Compiler(compilerId), compilerFlavor + , PackageDB(..), PackageDBStack ) +import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Simple.Setup + ( haddockCommand, HaddockFlags(..), emptyHaddockFlags + , buildCommand, BuildFlags(..), emptyBuildFlags + , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe ) +import qualified Distribution.Simple.Setup as Cabal + ( installCommand, InstallFlags(..), emptyInstallFlags ) +import Distribution.Simple.Utils + ( rawSystemExit, comparing ) +import Distribution.Simple.InstallDirs as InstallDirs + ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate + , initialPathTemplateEnv, installDirsTemplateEnv ) +import Distribution.Package + ( PackageIdentifier, packageName, packageVersion + , Package(..), PackageFixedDeps(..) + , Dependency(..), thisPackageVersion ) +import qualified Distribution.PackageDescription as PackageDescription +import Distribution.PackageDescription + ( PackageDescription, GenericPackageDescription(..), TestSuite(..) ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription, mapTreeData ) +import Distribution.Version + ( Version, anyVersion, thisVersion ) +import Distribution.Simple.Utils as Utils + ( notice, info, debug, warn, die, intercalate, withTempDirectory ) +import Distribution.Client.Utils + ( inDir, mergeBy, MergeResult(..) ) +import Distribution.System + ( Platform, buildPlatform, OS(Windows), buildOS ) +import Distribution.Text + ( display ) +import Distribution.Verbosity as Verbosity + ( Verbosity, showForCabal, verbose ) +import Distribution.Simple.BuildPaths ( exeExtension ) + +--TODO: +-- * assign flags to packages individually +-- * complain about flags that do not apply to any package given as target +-- so flags do not apply to dependencies, only listed, can use flag +-- constraints for dependencies +-- * only record applicable flags in world file +-- * allow flag constraints +-- * allow installed constraints +-- * allow flag and installed preferences +-- * change world file to use cabal section syntax +-- * allow persistent configure flags for each package individually + +-- ------------------------------------------------------------ +-- * Top level user actions +-- ------------------------------------------------------------ + +-- | Installs the packages needed to satisfy a list of dependencies. +-- +install, upgrade + :: Verbosity + -> PackageDBStack + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> GlobalFlags + -> ConfigFlags + -> ConfigExFlags + -> InstallFlags + -> [UserTarget] + -> IO () +install verbosity packageDBs repos comp conf + globalFlags configFlags configExFlags installFlags userTargets0 = do + + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf + sourcePkgDb <- getSourcePackages verbosity repos + + let -- For install, if no target is given it means we use the + -- current directory as the single target + userTargets | null userTargets0 = [UserTargetLocalDir "."] + | otherwise = userTargets0 + + pkgSpecifiers <- resolveUserTargets verbosity + (fromFlag $ globalWorldFile globalFlags) + (packageIndex sourcePkgDb) + userTargets + + notice verbosity "Resolving dependencies..." + installPlan <- foldProgress logMsg die return $ + planPackages + comp configFlags configExFlags installFlags + installedPkgIndex sourcePkgDb pkgSpecifiers + + printPlanMessages verbosity installedPkgIndex installPlan dryRun + + unless dryRun $ do + installPlan' <- performInstallations verbosity + context installedPkgIndex installPlan + postInstallActions verbosity context userTargets installPlan' + + where + context :: InstallContext + context = (packageDBs, repos, comp, conf, + globalFlags, configFlags, configExFlags, installFlags) + + dryRun = fromFlag (installDryRun installFlags) + logMsg message rest = debug verbosity message >> rest + + +upgrade _ _ _ _ _ _ _ _ _ _ = die $ + "Use the 'cabal install' command instead of 'cabal upgrade'.\n" + ++ "You can install the latest version of a package using 'cabal install'. " + ++ "The 'cabal upgrade' command has been removed because people found it " + ++ "confusing and it often led to broken packages.\n" + ++ "If you want the old upgrade behaviour then use the install command " + ++ "with the --upgrade-dependencies flag (but check first with --dry-run " + ++ "to see what would happen). This will try to pick the latest versions " + ++ "of all dependencies, rather than the usual behaviour of trying to pick " + ++ "installed versions of all dependencies. If you do use " + ++ "--upgrade-dependencies, it is recommended that you do not upgrade core " + ++ "packages (e.g. by using appropriate --constraint= flags)." + +type InstallContext = ( PackageDBStack + , [Repo] + , Compiler + , ProgramConfiguration + , GlobalFlags + , ConfigFlags + , ConfigExFlags + , InstallFlags ) + +-- ------------------------------------------------------------ +-- * Installation planning +-- ------------------------------------------------------------ + +planPackages :: Compiler + -> ConfigFlags + -> ConfigExFlags + -> InstallFlags + -> PackageIndex InstalledPackage + -> SourcePackageDb + -> [PackageSpecifier SourcePackage] + -> Progress String String InstallPlan +planPackages comp configFlags configExFlags installFlags + installedPkgIndex sourcePkgDb pkgSpecifiers = + + resolveDependencies + buildPlatform (compilerId comp) + resolverParams + + >>= if onlyDeps then adjustPlanOnlyDeps else return + + where + resolverParams = + + setPreferenceDefault (if upgradeDeps then PreferAllLatest + else PreferLatestForSelected) + + . addPreferences + -- preferences from the config file or command line + [ PackageVersionPreference name ver + | Dependency name ver <- configPreferences configExFlags ] + + . addConstraints + -- version constraints from the config file or command line + (map userToPackageConstraint (configExConstraints configExFlags)) + + . addConstraints + --FIXME: this just applies all flags to all targets which + -- is silly. We should check if the flags are appropriate + [ PackageConstraintFlags (pkgSpecifierTarget pkgSpecifier) flags + | let flags = configConfigurationsFlags configFlags + , not (null flags) + , pkgSpecifier <- pkgSpecifiers' ] + + . (if reinstall then reinstallTargets else id) + + $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers' + + -- Mark test suites as enabled if invoked with '--enable-tests'. This + -- ensures that test suite dependencies are included. + pkgSpecifiers' = map enableTests pkgSpecifiers + testsEnabled = fromFlagOrDefault False $ configTests configFlags + enableTests (SpecificSourcePackage pkg) = + let pkgDescr = Source.packageDescription pkg + suites = condTestSuites pkgDescr + enable = mapTreeData (\t -> t { testEnabled = testsEnabled }) + in SpecificSourcePackage $ pkg { Source.packageDescription = pkgDescr + { condTestSuites = map (\(n, t) -> (n, enable t)) suites } } + enableTests x = x + + + --TODO: this is a general feature and should be moved to D.C.Dependency + -- Also, the InstallPlan.remove should return info more precise to the + -- problem, rather than the very general PlanProblem type. + adjustPlanOnlyDeps :: InstallPlan -> Progress String String InstallPlan + adjustPlanOnlyDeps = + either (Fail . explain) Done + . InstallPlan.remove isTarget + where + isTarget pkg = packageName pkg `elem` targetnames + targetnames = map pkgSpecifierTarget pkgSpecifiers + + explain :: [InstallPlan.PlanProblem] -> String + explain problems = + "Cannot select only the dependencies (as requested by the " + ++ "'--only-dependencies' flag), " + ++ (case pkgids of + [pkgid] -> "the package " ++ display pkgid ++ " is " + _ -> "the packages " + ++ intercalate ", " (map display pkgids) ++ " are ") + ++ "required by a dependency of one of the other targets." + where + pkgids = + nub [ depid + | InstallPlan.PackageMissingDeps _ depids <- problems + , depid <- depids + , packageName depid `elem` targetnames ] + + reinstall = fromFlag (installReinstall installFlags) + upgradeDeps = fromFlag (installUpgradeDeps installFlags) + onlyDeps = fromFlag (installOnlyDeps installFlags) + +-- ------------------------------------------------------------ +-- * Informational messages +-- ------------------------------------------------------------ + +printPlanMessages :: Verbosity + -> PackageIndex InstalledPackage + -> InstallPlan + -> Bool + -> IO () +printPlanMessages verbosity installed installPlan dryRun = do + + when nothingToInstall $ + notice verbosity $ + "No packages to be installed. All the requested packages are " + ++ "already installed.\n If you want to reinstall anyway then use " + ++ "the --reinstall flag." + + when (dryRun || verbosity >= verbose) $ + printDryRun verbosity installed installPlan + + where + nothingToInstall = null (InstallPlan.ready installPlan) + + +printDryRun :: Verbosity + -> PackageIndex InstalledPackage + -> InstallPlan + -> IO () +printDryRun verbosity installedPkgIndex plan = case unfoldr next plan of + [] -> return () + pkgs + | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $ + "In order, the following would be installed:" + : map showPkgAndReason pkgs + | otherwise -> notice verbosity $ unlines $ + "In order, the following would be installed (use -v for more details):" + : map (display . packageId) pkgs + where + next plan' = case InstallPlan.ready plan' of + [] -> Nothing + (pkg:_) -> Just (pkg, InstallPlan.completed pkgid result plan') + where pkgid = packageId pkg + result = BuildOk DocsNotTried TestsNotTried + --FIXME: This is a bit of a hack, + -- pretending that each package is installed + + showPkgAndReason pkg' = display (packageId pkg') ++ " " ++ + case PackageIndex.lookupPackageName installedPkgIndex + (packageName pkg') of + [] -> "(new package)" + ps -> case find ((==packageId pkg') . packageId) ps of + Nothing -> "(new version)" + Just pkg -> "(reinstall)" ++ case changes pkg pkg' of + [] -> "" + diff -> " changes: " ++ intercalate ", " diff + changes pkg pkg' = map change . filter changed + $ mergeBy (comparing packageName) + (nub . sort . depends $ pkg) + (nub . sort . depends $ pkg') + change (OnlyInLeft pkgid) = display pkgid ++ " removed" + change (InBoth pkgid pkgid') = display pkgid ++ " -> " + ++ display (packageVersion pkgid') + change (OnlyInRight pkgid') = display pkgid' ++ " added" + changed (InBoth pkgid pkgid') = pkgid /= pkgid' + changed _ = True + +-- ------------------------------------------------------------ +-- * Post installation stuff +-- ------------------------------------------------------------ + +-- | Various stuff we do after successful or unsuccessfully installing a bunch +-- of packages. This includes: +-- +-- * build reporting, local and remote +-- * symlinking binaries +-- * updating indexes +-- * updating world file +-- * error reporting +-- +postInstallActions :: Verbosity + -> InstallContext + -> [UserTarget] + -> InstallPlan + -> IO () +postInstallActions verbosity + (packageDBs, _, comp, conf, globalFlags, configFlags, _, installFlags) + targets installPlan = do + + unless oneShot $ + World.insert verbosity worldFile + --FIXME: does not handle flags + [ World.WorldPkgInfo dep [] + | UserTargetNamed dep <- targets ] + + let buildReports = BuildReports.fromInstallPlan installPlan + BuildReports.storeLocal (installSummaryFile installFlags) buildReports + when (reportingLevel >= AnonymousReports) $ + BuildReports.storeAnonymous buildReports + when (reportingLevel == DetailedReports) $ + storeDetailedBuildReports verbosity logsDir buildReports + + regenerateHaddockIndex verbosity packageDBs comp conf + configFlags installFlags installPlan + + symlinkBinaries verbosity configFlags installFlags installPlan + + printBuildFailures installPlan + + where + reportingLevel = fromFlag (installBuildReports installFlags) + logsDir = fromFlag (globalLogsDir globalFlags) + oneShot = fromFlag (installOneShot installFlags) + worldFile = fromFlag $ globalWorldFile globalFlags + +storeDetailedBuildReports :: Verbosity -> FilePath + -> [(BuildReports.BuildReport, Repo)] -> IO () +storeDetailedBuildReports verbosity logsDir reports = sequence_ + [ do dotCabal <- defaultCabalDir + let logFileName = display (BuildReports.package report) <.> "log" + logFile = logsDir logFileName + reportsDir = dotCabal "reports" remoteRepoName remoteRepo + reportFile = reportsDir logFileName + + handleMissingLogFile $ do + buildLog <- readFile logFile + createDirectoryIfMissing True reportsDir -- FIXME + writeFile reportFile (show (BuildReports.show report, buildLog)) + + | (report, Repo { repoKind = Left remoteRepo }) <- reports + , isLikelyToHaveLogFile (BuildReports.installOutcome report) ] + + where + isLikelyToHaveLogFile BuildReports.ConfigureFailed {} = True + isLikelyToHaveLogFile BuildReports.BuildFailed {} = True + isLikelyToHaveLogFile BuildReports.InstallFailed {} = True + isLikelyToHaveLogFile BuildReports.InstallOk {} = True + isLikelyToHaveLogFile _ = False + + handleMissingLogFile = Exception.handleJust missingFile $ \ioe -> + warn verbosity $ "Missing log file for build report: " + ++ fromMaybe "" (ioeGetFileName ioe) + +#if MIN_VERSION_base(4,0,0) + missingFile ioe +#else + missingFile (IOException ioe) +#endif + | isDoesNotExistError ioe = Just ioe + missingFile _ = Nothing + + +regenerateHaddockIndex :: Verbosity + -> [PackageDB] + -> Compiler + -> ProgramConfiguration + -> ConfigFlags + -> InstallFlags + -> InstallPlan + -> IO () +regenerateHaddockIndex verbosity packageDBs comp conf + configFlags installFlags installPlan + | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do + + defaultDirs <- InstallDirs.defaultInstallDirs + (compilerFlavor comp) + (fromFlag (configUserInstall configFlags)) + True + let indexFileTemplate = fromFlag (installHaddockIndex installFlags) + indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate + + notice verbosity $ + "Updating documentation index " ++ indexFile + + --TODO: might be nice if the install plan gave us the new InstalledPackageInfo + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf + Haddock.regenerateHaddockIndex verbosity installedPkgIndex conf indexFile + + | otherwise = return () + where + haddockIndexFileIsRequested = + fromFlag (installDocumentation installFlags) + && isJust (flagToMaybe (installHaddockIndex installFlags)) + + -- We want to regenerate the index if some new documentation was actually + -- installed. Since the index is per-user, we don't do it for global + -- installs or special cases where we're installing into a specific db. + shouldRegenerateHaddockIndex = normalUserInstall + && someDocsWereInstalled installPlan + where + someDocsWereInstalled = any installedDocs . InstallPlan.toList + normalUserInstall = (UserPackageDB `elem` packageDBs) + && all (not . isSpecificPackageDB) packageDBs + + installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _)) = True + installedDocs _ = False + isSpecificPackageDB (SpecificPackageDB _) = True + isSpecificPackageDB _ = False + + substHaddockIndexFileName defaultDirs = fromPathTemplate + . substPathTemplate env + where + env = env0 ++ installDirsTemplateEnv absoluteDirs + env0 = InstallDirs.compilerTemplateEnv (compilerId comp) + ++ InstallDirs.platformTemplateEnv (buildPlatform) + absoluteDirs = InstallDirs.substituteInstallDirTemplates + env0 templateDirs + templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs configFlags) + + +symlinkBinaries :: Verbosity + -> ConfigFlags + -> InstallFlags + -> InstallPlan -> IO () +symlinkBinaries verbosity configFlags installFlags plan = do + failed <- InstallSymlink.symlinkBinaries configFlags installFlags plan + case failed of + [] -> return () + [(_, exe, path)] -> + warn verbosity $ + "could not create a symlink in " ++ bindir ++ " for " + ++ exe ++ " because the file exists there already but is not " + ++ "managed by cabal. You can create a symlink for this executable " + ++ "manually if you wish. The executable file has been installed at " + ++ path + exes -> + warn verbosity $ + "could not create symlinks in " ++ bindir ++ " for " + ++ intercalate ", " [ exe | (_, exe, _) <- exes ] + ++ " because the files exist there already and are not " + ++ "managed by cabal. You can create symlinks for these executables " + ++ "manually if you wish. The executable files have been installed at " + ++ intercalate ", " [ path | (_, _, path) <- exes ] + where + bindir = fromFlag (installSymlinkBinDir installFlags) + + +printBuildFailures :: InstallPlan -> IO () +printBuildFailures plan = + case [ (pkg, reason) + | InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of + [] -> return () + failed -> die . unlines + $ "Error: some packages failed to install:" + : [ display (packageId pkg) ++ printFailureReason reason + | (pkg, reason) <- failed ] + where + printFailureReason reason = case reason of + DependentFailed pkgid -> " depends on " ++ display pkgid + ++ " which failed to install." + DownloadFailed e -> " failed while downloading the package." + ++ " The exception was:\n " ++ show e + UnpackFailed e -> " failed while unpacking the package." + ++ " The exception was:\n " ++ show e + ConfigureFailed e -> " failed during the configure step." + ++ " The exception was:\n " ++ show e + BuildFailed e -> " failed during the building phase." + ++ " The exception was:\n " ++ show e + InstallFailed e -> " failed during the final install step." + ++ " The exception was:\n " ++ show e + + +-- ------------------------------------------------------------ +-- * Actually do the installations +-- ------------------------------------------------------------ + +data InstallMisc = InstallMisc { + rootCmd :: Maybe FilePath, + libVersion :: Maybe Version + } + +performInstallations :: Verbosity + -> InstallContext + -> PackageIndex InstalledPackage + -> InstallPlan + -> IO InstallPlan +performInstallations verbosity + (packageDBs, _, comp, conf, + globalFlags, configFlags, configExFlags, installFlags) + installedPkgIndex installPlan = do + + executeInstallPlan installPlan $ \cpkg -> + installConfiguredPackage platform compid configFlags + cpkg $ \configFlags' src pkg -> + fetchSourcePackage verbosity src $ \src' -> + installLocalPackage verbosity (packageId pkg) src' $ \mpath -> + installUnpackedPackage verbosity + (setupScriptOptions installedPkgIndex) + miscOptions configFlags' installFlags + compid pkg mpath useLogFile + + where + platform = InstallPlan.planPlatform installPlan + compid = InstallPlan.planCompiler installPlan + + setupScriptOptions index = SetupScriptOptions { + useCabalVersion = maybe anyVersion thisVersion (libVersion miscOptions), + useCompiler = Just comp, + -- Hack: we typically want to allow the UserPackageDB for finding the + -- Cabal lib when compiling any Setup.hs even if we're doing a global + -- install. However we also allow looking in a specific package db. + usePackageDB = if UserPackageDB `elem` packageDBs + then packageDBs + else let (db@GlobalPackageDB:dbs) = packageDBs + in db : UserPackageDB : dbs, + --TODO: use Ord instance: + -- insert UserPackageDB packageDBs + usePackageIndex = if UserPackageDB `elem` packageDBs + then Just index + else Nothing, + useProgramConfig = conf, + useDistPref = fromFlagOrDefault + (useDistPref defaultSetupScriptOptions) + (configDistPref configFlags), + useLoggingHandle = Nothing, + useWorkingDir = Nothing + } + reportingLevel = fromFlag (installBuildReports installFlags) + logsDir = fromFlag (globalLogsDir globalFlags) + useLogFile :: Maybe (PackageIdentifier -> FilePath) + useLogFile = fmap substLogFileName logFileTemplate + where + logFileTemplate :: Maybe PathTemplate + logFileTemplate --TODO: separate policy from mechanism + | reportingLevel == DetailedReports + = Just $ toPathTemplate $ logsDir "$pkgid" <.> "log" + | otherwise + = flagToMaybe (installLogFile installFlags) + substLogFileName template pkg = fromPathTemplate + . substPathTemplate env + $ template + where env = initialPathTemplateEnv (packageId pkg) (compilerId comp) + miscOptions = InstallMisc { + rootCmd = if fromFlag (configUserInstall configFlags) + then Nothing -- ignore --root-cmd if --user. + else flagToMaybe (installRootCmd installFlags), + libVersion = flagToMaybe (configCabalVersion configExFlags) + } + + +executeInstallPlan :: Monad m + => InstallPlan + -> (ConfiguredPackage -> m BuildResult) + -> m InstallPlan +executeInstallPlan plan installPkg = case InstallPlan.ready plan of + [] -> return plan + (pkg: _) -> do buildResult <- installPkg pkg + let plan' = updatePlan (packageId pkg) buildResult plan + executeInstallPlan plan' installPkg + where + updatePlan pkgid (Right buildSuccess) = + InstallPlan.completed pkgid buildSuccess + + updatePlan pkgid (Left buildFailure) = + InstallPlan.failed pkgid buildFailure depsFailure + where + depsFailure = DependentFailed pkgid + -- So this first pkgid failed for whatever reason (buildFailure). + -- All the other packages that depended on this pkgid, which we + -- now cannot build, we mark as failing due to 'DependentFailed' + -- which kind of means it was not their fault. + + +-- | Call an installer for an 'SourcePackage' but override the configure +-- flags with the ones given by the 'ConfiguredPackage'. In particular the +-- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly +-- versioned package dependencies. So we ignore any previous partial flag +-- assignment or dependency constraints and use the new ones. +-- +installConfiguredPackage :: Platform -> CompilerId + -> ConfigFlags -> ConfiguredPackage + -> (ConfigFlags -> PackageLocation (Maybe FilePath) + -> PackageDescription -> a) + -> a +installConfiguredPackage platform comp configFlags + (ConfiguredPackage (SourcePackage _ gpkg source) flags deps) + installPkg = installPkg configFlags { + configConfigurationsFlags = flags, + configConstraints = map thisPackageVersion deps + } source pkg + where + pkg = case finalizePackageDescription flags + (const True) + platform comp [] gpkg of + Left _ -> error "finalizePackageDescription ConfiguredPackage failed" + Right (desc, _) -> desc + +fetchSourcePackage + :: Verbosity + -> PackageLocation (Maybe FilePath) + -> (PackageLocation FilePath -> IO BuildResult) + -> IO BuildResult +fetchSourcePackage verbosity src installPkg = do + fetched <- checkFetched src + case fetched of + Just src' -> installPkg src' + Nothing -> onFailure DownloadFailed $ + fetchPackage verbosity src >>= installPkg + + +installLocalPackage + :: Verbosity -> PackageIdentifier -> PackageLocation FilePath + -> (Maybe FilePath -> IO BuildResult) + -> IO BuildResult +installLocalPackage verbosity pkgid location installPkg = case location of + + LocalUnpackedPackage dir -> + installPkg (Just dir) + + LocalTarballPackage tarballPath -> + installLocalTarballPackage verbosity pkgid tarballPath installPkg + + RemoteTarballPackage _ tarballPath -> + installLocalTarballPackage verbosity pkgid tarballPath installPkg + + RepoTarballPackage _ _ tarballPath -> + installLocalTarballPackage verbosity pkgid tarballPath installPkg + + +installLocalTarballPackage + :: Verbosity -> PackageIdentifier -> FilePath + -> (Maybe FilePath -> IO BuildResult) + -> IO BuildResult +installLocalTarballPackage verbosity pkgid tarballPath installPkg = do + tmp <- getTemporaryDirectory + withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath -> + onFailure UnpackFailed $ do + info verbosity $ "Extracting " ++ tarballPath + ++ " to " ++ tmpDirPath ++ "..." + let relUnpackedPath = display pkgid + absUnpackedPath = tmpDirPath relUnpackedPath + descFilePath = absUnpackedPath + display (packageName pkgid) <.> "cabal" + extractTarGzFile tmpDirPath relUnpackedPath tarballPath + exists <- doesFileExist descFilePath + when (not exists) $ + die $ "Package .cabal file not found: " ++ show descFilePath + installPkg (Just absUnpackedPath) + + +installUnpackedPackage :: Verbosity + -> SetupScriptOptions + -> InstallMisc + -> ConfigFlags + -> InstallFlags + -> CompilerId + -> PackageDescription + -> Maybe FilePath -- ^ Directory to change to before starting the installation. + -> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any) + -> IO BuildResult +installUnpackedPackage verbosity scriptOptions miscOptions + configFlags installConfigFlags + compid pkg workingDir useLogFile = + + -- Configure phase + onFailure ConfigureFailed $ do + setup configureCommand configureFlags + + -- Build phase + onFailure BuildFailed $ do + setup buildCommand' buildFlags + + -- Doc generation phase + docsResult <- if shouldHaddock + then (do setup haddockCommand haddockFlags + return DocsOk) + `catchIO` (\_ -> return DocsFailed) + `catchExit` (\_ -> return DocsFailed) + else return DocsNotTried + + -- Tests phase + testsResult <- return TestsNotTried --TODO: add optional tests + + -- Install phase + onFailure InstallFailed $ + withWin32SelfUpgrade verbosity configFlags compid pkg $ do + case rootCmd miscOptions of + (Just cmd) -> reexec cmd + Nothing -> setup Cabal.installCommand installFlags + return (Right (BuildOk docsResult testsResult)) + + where + configureFlags = filterConfigureFlags configFlags { + configVerbosity = toFlag verbosity' + } + buildCommand' = buildCommand defaultProgramConfiguration + buildFlags _ = emptyBuildFlags { + buildDistPref = configDistPref configFlags, + buildVerbosity = toFlag verbosity' + } + shouldHaddock = fromFlag (installDocumentation installConfigFlags) + haddockFlags _ = emptyHaddockFlags { + haddockDistPref = configDistPref configFlags, + haddockVerbosity = toFlag verbosity' + } + installFlags _ = Cabal.emptyInstallFlags { + Cabal.installDistPref = configDistPref configFlags, + Cabal.installVerbosity = toFlag verbosity' + } + verbosity' | isJust useLogFile = max Verbosity.verbose verbosity + | otherwise = verbosity + setup cmd flags = do + logFileHandle <- case useLogFile of + Nothing -> return Nothing + Just mkLogFileName -> do + let logFileName = mkLogFileName (packageId pkg) + logDir = takeDirectory logFileName + unless (null logDir) $ createDirectoryIfMissing True logDir + logFile <- openFile logFileName AppendMode + return (Just logFile) + + setupWrapper verbosity + scriptOptions { useLoggingHandle = logFileHandle + , useWorkingDir = workingDir } + (Just pkg) + cmd flags [] + reexec cmd = do + -- look for our on executable file and re-exec ourselves using + -- a helper program like sudo to elevate priviledges: + bindir <- getBinDir + let self = bindir "cabal" <.> exeExtension + weExist <- doesFileExist self + if weExist + then inDir workingDir $ + rawSystemExit verbosity cmd + [self, "install", "--only" + ,"--verbose=" ++ showForCabal verbosity] + else die $ "Unable to find cabal executable at: " ++ self + + +-- helper +onFailure :: (SomeException -> BuildFailure) -> IO BuildResult -> IO BuildResult +onFailure result action = +#if MIN_VERSION_base(4,0,0) + action `catches` + [ Handler $ \ioe -> handler (ioe :: IOException) + , Handler $ \exit -> handler (exit :: ExitCode) + ] + where + handler :: Exception e => e -> IO BuildResult + handler = return . Left . result . toException +#else + action + `catchIO` (return . Left . result . IOException) + `catchExit` (return . Left . result . ExitException) +#endif + + +-- ------------------------------------------------------------ +-- * Wierd windows hacks +-- ------------------------------------------------------------ + +withWin32SelfUpgrade :: Verbosity + -> ConfigFlags + -> CompilerId + -> PackageDescription + -> IO a -> IO a +withWin32SelfUpgrade _ _ _ _ action | buildOS /= Windows = action +withWin32SelfUpgrade verbosity configFlags compid pkg action = do + + defaultDirs <- InstallDirs.defaultInstallDirs + compFlavor + (fromFlag (configUserInstall configFlags)) + (PackageDescription.hasLibs pkg) + + Win32SelfUpgrade.possibleSelfUpgrade verbosity + (exeInstallPaths defaultDirs) action + + where + pkgid = packageId pkg + (CompilerId compFlavor _) = compid + + exeInstallPaths defaultDirs = + [ InstallDirs.bindir absoluteDirs exeName <.> exeExtension + | exe <- PackageDescription.executables pkg + , PackageDescription.buildable (PackageDescription.buildInfo exe) + , let exeName = prefix ++ PackageDescription.exeName exe ++ suffix + prefix = substTemplate prefixTemplate + suffix = substTemplate suffixTemplate ] + where + fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") + prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) + suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) + templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs configFlags) + absoluteDirs = InstallDirs.absoluteInstallDirs + pkgid compid InstallDirs.NoCopyDest templateDirs + substTemplate = InstallDirs.fromPathTemplate + . InstallDirs.substPathTemplate env + where env = InstallDirs.initialPathTemplateEnv pkgid compid diff --git a/cabal/cabal-install/Distribution/Client/InstallPlan.hs b/cabal/cabal-install/Distribution/Client/InstallPlan.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/InstallPlan.hs @@ -0,0 +1,511 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.InstallPlan +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Package installation plan +-- +----------------------------------------------------------------------------- +module Distribution.Client.InstallPlan ( + InstallPlan, + ConfiguredPackage(..), + PlanPackage(..), + + -- * Operations on 'InstallPlan's + new, + toList, + ready, + completed, + failed, + remove, + + -- ** Query functions + planPlatform, + planCompiler, + + -- * Checking valididy of plans + valid, + closed, + consistent, + acyclic, + configuredPackageValid, + + -- ** Details on invalid plans + PlanProblem(..), + showPlanProblem, + PackageProblem(..), + showPackageProblem, + problems, + configuredPackageProblems + ) where + +import Distribution.Client.Types + ( SourcePackage(packageDescription), ConfiguredPackage(..) + , InstalledPackage + , BuildFailure, BuildSuccess ) +import Distribution.Package + ( PackageIdentifier(..), PackageName(..), Package(..), packageName + , PackageFixedDeps(..), Dependency(..) ) +import Distribution.Version + ( Version, withinRange ) +import Distribution.PackageDescription + ( GenericPackageDescription(genPackageFlags) + , Flag(flagName), FlagName(..) ) +import Distribution.Client.PackageUtils + ( externalBuildDepends ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Client.PackageIndex + ( PackageIndex ) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Text + ( display ) +import Distribution.System + ( Platform ) +import Distribution.Compiler + ( CompilerId(..) ) +import Distribution.Client.Utils + ( duplicates, duplicatesBy, mergeBy, MergeResult(..) ) +import Distribution.Simple.Utils + ( comparing, intercalate ) + +import Data.List + ( sort, sortBy ) +import Data.Maybe + ( fromMaybe ) +import qualified Data.Graph as Graph +import Data.Graph (Graph) +import Control.Exception + ( assert ) + +-- When cabal tries to install a number of packages, including all their +-- dependencies it has a non-trivial problem to solve. +-- +-- The Problem: +-- +-- In general we start with a set of installed packages and a set of source +-- packages. +-- +-- Installed packages have fixed dependencies. They have already been built and +-- we know exactly what packages they were built against, including their exact +-- versions. +-- +-- Source package have somewhat flexible dependencies. They are specified as +-- version ranges, though really they're predicates. To make matters worse they +-- have conditional flexible dependencies. Configuration flags can affect which +-- packages are required and can place additional constraints on their +-- versions. +-- +-- These two sets of package can and usually do overlap. There can be installed +-- packages that are also available as source packages which means they could +-- be re-installed if required, though there will also be packages which are +-- not available as source and cannot be re-installed. Very often there will be +-- extra versions available than are installed. Sometimes we may like to prefer +-- installed packages over source ones or perhaps always prefer the latest +-- available version whether installed or not. +-- +-- The goal is to calculate an installation plan that is closed, acyclic and +-- consistent and where every configured package is valid. +-- +-- An installation plan is a set of packages that are going to be used +-- together. It will consist of a mixture of installed packages and source +-- packages along with their exact version dependencies. An installation plan +-- is closed if for every package in the set, all of its dependencies are +-- also in the set. It is consistent if for every package in the set, all +-- dependencies which target that package have the same version. + +-- Note that plans do not necessarily compose. You might have a valid plan for +-- package A and a valid plan for package B. That does not mean the composition +-- is simultaniously valid for A and B. In particular you're most likely to +-- have problems with inconsistent dependencies. +-- On the other hand it is true that every closed sub plan is valid. + +data PlanPackage = PreExisting InstalledPackage + | Configured ConfiguredPackage + | Installed ConfiguredPackage BuildSuccess + | Failed ConfiguredPackage BuildFailure + +instance Package PlanPackage where + packageId (PreExisting pkg) = packageId pkg + packageId (Configured pkg) = packageId pkg + packageId (Installed pkg _) = packageId pkg + packageId (Failed pkg _) = packageId pkg + +instance PackageFixedDeps PlanPackage where + depends (PreExisting pkg) = depends pkg + depends (Configured pkg) = depends pkg + depends (Installed pkg _) = depends pkg + depends (Failed pkg _) = depends pkg + +data InstallPlan = InstallPlan { + planIndex :: PackageIndex PlanPackage, + planGraph :: Graph, + planGraphRev :: Graph, + planPkgOf :: Graph.Vertex -> PlanPackage, + planVertexOf :: PackageIdentifier -> Graph.Vertex, + planPlatform :: Platform, + planCompiler :: CompilerId + } + +invariant :: InstallPlan -> Bool +invariant plan = + valid (planPlatform plan) (planCompiler plan) (planIndex plan) + +internalError :: String -> a +internalError msg = error $ "InstallPlan: internal error: " ++ msg + +-- | Build an installation plan from a valid set of resolved packages. +-- +new :: Platform -> CompilerId -> PackageIndex PlanPackage + -> Either [PlanProblem] InstallPlan +new platform compiler index = + case problems platform compiler index of + [] -> Right InstallPlan { + planIndex = index, + planGraph = graph, + planGraphRev = Graph.transposeG graph, + planPkgOf = vertexToPkgId, + planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex, + planPlatform = platform, + planCompiler = compiler + } + where (graph, vertexToPkgId, pkgIdToVertex) = + PackageIndex.dependencyGraph index + noSuchPkgId = internalError "package is not in the graph" + probs -> Left probs + +toList :: InstallPlan -> [PlanPackage] +toList = PackageIndex.allPackages . planIndex + +-- | Remove packages from the install plan. This will result in an +-- error if there are remaining packages that depend on any matching +-- package. This is primarily useful for obtaining an install plan for +-- the dependencies of a package or set of packages without actually +-- installing the package itself, as when doing development. +-- +remove :: (PlanPackage -> Bool) + -> InstallPlan + -> Either [PlanProblem] InstallPlan +remove shouldRemove plan = + new (planPlatform plan) (planCompiler plan) newIndex + where + newIndex = PackageIndex.fromList $ + filter (not . shouldRemove) (toList plan) + +-- | The packages that are ready to be installed. That is they are in the +-- configured state and have all their dependencies installed already. +-- The plan is complete if the result is @[]@. +-- +ready :: InstallPlan -> [ConfiguredPackage] +ready plan = assert check readyPackages + where + check = if null readyPackages then null configuredPackages else True + configuredPackages = + [ pkg | Configured pkg <- PackageIndex.allPackages (planIndex plan) ] + readyPackages = filter (all isInstalled . depends) configuredPackages + isInstalled pkg = + case PackageIndex.lookupPackageId (planIndex plan) pkg of + Just (Configured _) -> False + Just (Failed _ _) -> internalError depOnFailed + Just (PreExisting _) -> True + Just (Installed _ _) -> True + Nothing -> internalError incomplete + incomplete = "install plan is not closed" + depOnFailed = "configured package depends on failed package" + +-- | Marks a package in the graph as completed. Also saves the build result for +-- the completed package in the plan. +-- +-- * The package must exist in the graph. +-- * The package must have had no uninstalled dependent packages. +-- +completed :: PackageIdentifier + -> BuildSuccess + -> InstallPlan -> InstallPlan +completed pkgid buildResult plan = assert (invariant plan') plan' + where + plan' = plan { + planIndex = PackageIndex.insert installed (planIndex plan) + } + installed = Installed (lookupConfiguredPackage plan pkgid) buildResult + +-- | Marks a package in the graph as having failed. It also marks all the +-- packages that depended on it as having failed. +-- +-- * The package must exist in the graph and be in the configured state. +-- +failed :: PackageIdentifier -- ^ The id of the package that failed to install + -> BuildFailure -- ^ The build result to use for the failed package + -> BuildFailure -- ^ The build result to use for its dependencies + -> InstallPlan + -> InstallPlan +failed pkgid buildResult buildResult' plan = assert (invariant plan') plan' + where + plan' = plan { + planIndex = PackageIndex.merge (planIndex plan) failures + } + pkg = lookupConfiguredPackage plan pkgid + failures = PackageIndex.fromList + $ Failed pkg buildResult + : [ Failed pkg' buildResult' + | Just pkg' <- map checkConfiguredPackage + $ packagesThatDependOn plan pkgid ] + +-- | lookup the reachable packages in the reverse dependency graph +-- +packagesThatDependOn :: InstallPlan + -> PackageIdentifier -> [PlanPackage] +packagesThatDependOn plan = map (planPkgOf plan) + . tail + . Graph.reachable (planGraphRev plan) + . planVertexOf plan + +-- | lookup a package that we expect to be in the configured state +-- +lookupConfiguredPackage :: InstallPlan + -> PackageIdentifier -> ConfiguredPackage +lookupConfiguredPackage plan pkgid = + case PackageIndex.lookupPackageId (planIndex plan) pkgid of + Just (Configured pkg) -> pkg + _ -> internalError $ "not configured or no such pkg " ++ display pkgid + +-- | check a package that we expect to be in the configured or failed state +-- +checkConfiguredPackage :: PlanPackage -> Maybe ConfiguredPackage +checkConfiguredPackage (Configured pkg) = Just pkg +checkConfiguredPackage (Failed _ _) = Nothing +checkConfiguredPackage pkg = + internalError $ "not configured or no such pkg " ++ display (packageId pkg) + +-- ------------------------------------------------------------ +-- * Checking valididy of plans +-- ------------------------------------------------------------ + +-- | A valid installation plan is a set of packages that is 'acyclic', +-- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the +-- plan has to have a valid configuration (see 'configuredPackageValid'). +-- +-- * if the result is @False@ use 'problems' to get a detailed list. +-- +valid :: Platform -> CompilerId -> PackageIndex PlanPackage -> Bool +valid platform comp index = null (problems platform comp index) + +data PlanProblem = + PackageInvalid ConfiguredPackage [PackageProblem] + | PackageMissingDeps PlanPackage [PackageIdentifier] + | PackageCycle [PlanPackage] + | PackageInconsistency PackageName [(PackageIdentifier, Version)] + | PackageStateInvalid PlanPackage PlanPackage + +showPlanProblem :: PlanProblem -> String +showPlanProblem (PackageInvalid pkg packageProblems) = + "Package " ++ display (packageId pkg) + ++ " has an invalid configuration, in particular:\n" + ++ unlines [ " " ++ showPackageProblem problem + | problem <- packageProblems ] + +showPlanProblem (PackageMissingDeps pkg missingDeps) = + "Package " ++ display (packageId pkg) + ++ " depends on the following packages which are missing from the plan " + ++ intercalate ", " (map display missingDeps) + +showPlanProblem (PackageCycle cycleGroup) = + "The following packages are involved in a dependency cycle " + ++ intercalate ", " (map (display.packageId) cycleGroup) + +showPlanProblem (PackageInconsistency name inconsistencies) = + "Package " ++ display name + ++ " is required by several packages," + ++ " but they require inconsistent versions:\n" + ++ unlines [ " package " ++ display pkg ++ " requires " + ++ display (PackageIdentifier name ver) + | (pkg, ver) <- inconsistencies ] + +showPlanProblem (PackageStateInvalid pkg pkg') = + "Package " ++ display (packageId pkg) + ++ " is in the " ++ showPlanState pkg + ++ " state but it depends on package " ++ display (packageId pkg') + ++ " which is in the " ++ showPlanState pkg' + ++ " state" + where + showPlanState (PreExisting _) = "pre-existing" + showPlanState (Configured _) = "configured" + showPlanState (Installed _ _) = "installed" + showPlanState (Failed _ _) = "failed" + +-- | For an invalid plan, produce a detailed list of problems as human readable +-- error messages. This is mainly intended for debugging purposes. +-- Use 'showPlanProblem' for a human readable explanation. +-- +problems :: Platform -> CompilerId + -> PackageIndex PlanPackage -> [PlanProblem] +problems platform comp index = + [ PackageInvalid pkg packageProblems + | Configured pkg <- PackageIndex.allPackages index + , let packageProblems = configuredPackageProblems platform comp pkg + , not (null packageProblems) ] + + ++ [ PackageMissingDeps pkg missingDeps + | (pkg, missingDeps) <- PackageIndex.brokenPackages index ] + + ++ [ PackageCycle cycleGroup + | cycleGroup <- PackageIndex.dependencyCycles index ] + + ++ [ PackageInconsistency name inconsistencies + | (name, inconsistencies) <- PackageIndex.dependencyInconsistencies index ] + + ++ [ PackageStateInvalid pkg pkg' + | pkg <- PackageIndex.allPackages index + , Just pkg' <- map (PackageIndex.lookupPackageId index) (depends pkg) + , not (stateDependencyRelation pkg pkg') ] + +-- | The graph of packages (nodes) and dependencies (edges) must be acyclic. +-- +-- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out +-- which packages are involved in dependency cycles. +-- +acyclic :: PackageIndex PlanPackage -> Bool +acyclic = null . PackageIndex.dependencyCycles + +-- | An installation plan is closed if for every package in the set, all of +-- its dependencies are also in the set. That is, the set is closed under the +-- dependency relation. +-- +-- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out +-- which packages depend on packages not in the index. +-- +closed :: PackageIndex PlanPackage -> Bool +closed = null . PackageIndex.brokenPackages + +-- | An installation plan is consistent if all dependencies that target a +-- single package name, target the same version. +-- +-- This is slightly subtle. It is not the same as requiring that there be at +-- most one version of any package in the set. It only requires that of +-- packages which have more than one other package depending on them. We could +-- actually make the condition even more precise and say that different +-- versions are ok so long as they are not both in the transative closure of +-- any other package (or equivalently that their inverse closures do not +-- intersect). The point is we do not want to have any packages depending +-- directly or indirectly on two different versions of the same package. The +-- current definition is just a safe aproximation of that. +-- +-- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to +-- find out which packages are. +-- +consistent :: PackageIndex PlanPackage -> Bool +consistent = null . PackageIndex.dependencyInconsistencies + +-- | The states of packages have that depend on each other must respect +-- this relation. That is for very case where package @a@ depends on +-- package @b@ we require that @dependencyStatesOk a b = True@. +-- +stateDependencyRelation :: PlanPackage -> PlanPackage -> Bool +stateDependencyRelation (PreExisting _) (PreExisting _) = True + +stateDependencyRelation (Configured _) (PreExisting _) = True +stateDependencyRelation (Configured _) (Configured _) = True +stateDependencyRelation (Configured _) (Installed _ _) = True + +stateDependencyRelation (Installed _ _) (PreExisting _) = True +stateDependencyRelation (Installed _ _) (Installed _ _) = True + +stateDependencyRelation (Failed _ _) (PreExisting _) = True +-- failed can depends on configured because a package can depend on +-- several other packages and if one of the deps fail then we fail +-- but we still depend on the other ones that did not fail: +stateDependencyRelation (Failed _ _) (Configured _) = True +stateDependencyRelation (Failed _ _) (Installed _ _) = True +stateDependencyRelation (Failed _ _) (Failed _ _) = True + +stateDependencyRelation _ _ = False + +-- | A 'ConfiguredPackage' is valid if the flag assignment is total and if +-- in the configuration given by the flag assignment, all the package +-- dependencies are satisfied by the specified packages. +-- +configuredPackageValid :: Platform -> CompilerId -> ConfiguredPackage -> Bool +configuredPackageValid platform comp pkg = + null (configuredPackageProblems platform comp pkg) + +data PackageProblem = DuplicateFlag FlagName + | MissingFlag FlagName + | ExtraFlag FlagName + | DuplicateDeps [PackageIdentifier] + | MissingDep Dependency + | ExtraDep PackageIdentifier + | InvalidDep Dependency PackageIdentifier + +showPackageProblem :: PackageProblem -> String +showPackageProblem (DuplicateFlag (FlagName flag)) = + "duplicate flag in the flag assignment: " ++ flag + +showPackageProblem (MissingFlag (FlagName flag)) = + "missing an assignment for the flag: " ++ flag + +showPackageProblem (ExtraFlag (FlagName flag)) = + "extra flag given that is not used by the package: " ++ flag + +showPackageProblem (DuplicateDeps pkgids) = + "duplicate packages specified as selected dependencies: " + ++ intercalate ", " (map display pkgids) + +showPackageProblem (MissingDep dep) = + "the package has a dependency " ++ display dep + ++ " but no package has been selected to satisfy it." + +showPackageProblem (ExtraDep pkgid) = + "the package configuration specifies " ++ display pkgid + ++ " but (with the given flag assignment) the package does not actually" + ++ " depend on any version of that package." + +showPackageProblem (InvalidDep dep pkgid) = + "the package depends on " ++ display dep + ++ " but the configuration specifies " ++ display pkgid + ++ " which does not satisfy the dependency." + +configuredPackageProblems :: Platform -> CompilerId + -> ConfiguredPackage -> [PackageProblem] +configuredPackageProblems platform comp + (ConfiguredPackage pkg specifiedFlags specifiedDeps) = + [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ] + ++ [ MissingFlag flag | OnlyInLeft flag <- mergedFlags ] + ++ [ ExtraFlag flag | OnlyInRight flag <- mergedFlags ] + ++ [ DuplicateDeps pkgs + | pkgs <- duplicatesBy (comparing packageName) specifiedDeps ] + ++ [ MissingDep dep | OnlyInLeft dep <- mergedDeps ] + ++ [ ExtraDep pkgid | OnlyInRight pkgid <- mergedDeps ] + ++ [ InvalidDep dep pkgid | InBoth dep pkgid <- mergedDeps + , not (packageSatisfiesDependency pkgid dep) ] + where + mergedFlags = mergeBy compare + (sort $ map flagName (genPackageFlags (packageDescription pkg))) + (sort $ map fst specifiedFlags) + + mergedDeps = mergeBy + (\dep pkgid -> dependencyName dep `compare` packageName pkgid) + (sortBy (comparing dependencyName) requiredDeps) + (sortBy (comparing packageName) specifiedDeps) + + packageSatisfiesDependency + (PackageIdentifier name version) + (Dependency name' versionRange) = assert (name == name') $ + version `withinRange` versionRange + + dependencyName (Dependency name _) = name + + requiredDeps :: [Dependency] + requiredDeps = + --TODO: use something lower level than finalizePackageDescription + case finalizePackageDescription specifiedFlags + (const True) + platform comp + [] + (packageDescription pkg) of + Right (resolvedPkg, _) -> externalBuildDepends resolvedPkg + Left _ -> error "configuredPackageInvalidDeps internal error" diff --git a/cabal/cabal-install/Distribution/Client/InstallSymlink.hs b/cabal/cabal-install/Distribution/Client/InstallSymlink.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/InstallSymlink.hs @@ -0,0 +1,238 @@ +{-# OPTIONS -cpp #-} +-- OPTIONS required for ghc-6.4.x compat, and must appear first +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.InstallSymlink +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Managing installing binaries with symlinks. +----------------------------------------------------------------------------- +module Distribution.Client.InstallSymlink ( + symlinkBinaries, + symlinkBinary, + ) where + +#if mingw32_HOST_OS || mingw32_TARGET_OS + +import Distribution.Package (PackageIdentifier) +import Distribution.Client.InstallPlan (InstallPlan) +import Distribution.Client.Setup (InstallFlags) +import Distribution.Simple.Setup (ConfigFlags) + +symlinkBinaries :: ConfigFlags + -> InstallFlags + -> InstallPlan + -> IO [(PackageIdentifier, String, FilePath)] +symlinkBinaries _ _ _ = return [] + +symlinkBinary :: FilePath -> FilePath -> String -> String -> IO Bool +symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows" + +#else + +import Distribution.Client.Types + ( SourcePackage(..), ConfiguredPackage(..) ) +import Distribution.Client.Setup + ( InstallFlags(installSymlinkBinDir) ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.InstallPlan (InstallPlan) + +import Distribution.Package + ( PackageIdentifier, Package(packageId) ) +import Distribution.Compiler + ( CompilerId(..) ) +import qualified Distribution.PackageDescription as PackageDescription +import Distribution.PackageDescription + ( PackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Simple.Setup + ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe ) +import qualified Distribution.Simple.InstallDirs as InstallDirs + +import System.Posix.Files + ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink + , removeLink ) +import System.Directory + ( canonicalizePath ) +import System.FilePath + ( (), splitPath, joinPath, isAbsolute ) + +import Prelude hiding (catch, ioError) +import System.IO.Error + ( catch, isDoesNotExistError, ioError ) +import Control.Exception + ( assert ) +import Data.Maybe + ( catMaybes ) + +-- | We would like by default to install binaries into some location that is on +-- the user's PATH. For per-user installations on Unix systems that basically +-- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@ +-- directory will be on the user's PATH. However some people are a bit nervous +-- about letting a package manager install programs into @~/bin/@. +-- +-- A comprimise solution is that instead of installing binaries directly into +-- @~/bin/@, we could install them in a private location under @~/.cabal/bin@ +-- and then create symlinks in @~/bin/@. We can be careful when setting up the +-- symlinks that we do not overwrite any binary that the user installed. We can +-- check if it was a symlink we made because it would point to the private dir +-- where we install our binaries. This means we can install normally without +-- worrying and in a later phase set up symlinks, and if that fails then we +-- report it to the user, but even in this case the package is still in an ok +-- installed state. +-- +-- This is an optional feature that users can choose to use or not. It is +-- controlled from the config file. Of course it only works on posix systems +-- with symlinks so is not available to Windows users. +-- +symlinkBinaries :: ConfigFlags + -> InstallFlags + -> InstallPlan + -> IO [(PackageIdentifier, String, FilePath)] +symlinkBinaries configFlags installFlags plan = + case flagToMaybe (installSymlinkBinDir installFlags) of + Nothing -> return [] + Just symlinkBinDir + | null exes -> return [] + | otherwise -> do + publicBinDir <- canonicalizePath symlinkBinDir +-- TODO: do we want to do this here? : +-- createDirectoryIfMissing True publicBinDir + fmap catMaybes $ sequence + [ do privateBinDir <- pkgBinDir pkg + ok <- symlinkBinary + publicBinDir privateBinDir + publicExeName privateExeName + if ok + then return Nothing + else return (Just (pkgid, publicExeName, + privateBinDir privateExeName)) + | (pkg, exe) <- exes + , let publicExeName = PackageDescription.exeName exe + privateExeName = prefix ++ publicExeName ++ suffix + pkgid = packageId pkg + prefix = substTemplate pkgid prefixTemplate + suffix = substTemplate pkgid suffixTemplate ] + where + exes = + [ (pkg, exe) + | InstallPlan.Installed cpkg _ <- InstallPlan.toList plan + , let pkg = pkgDescription cpkg + , exe <- PackageDescription.executables pkg + , PackageDescription.buildable (PackageDescription.buildInfo exe) ] + + pkgDescription :: ConfiguredPackage -> PackageDescription + pkgDescription (ConfiguredPackage (SourcePackage _ pkg _) flags _) = + case finalizePackageDescription flags + (const True) + platform compilerId [] pkg of + Left _ -> error "finalizePackageDescription ConfiguredPackage failed" + Right (desc, _) -> desc + + -- This is sadly rather complicated. We're kind of re-doing part of the + -- configuration for the package. :-( + pkgBinDir :: PackageDescription -> IO FilePath + pkgBinDir pkg = do + defaultDirs <- InstallDirs.defaultInstallDirs + compilerFlavor + (fromFlag (configUserInstall configFlags)) + (PackageDescription.hasLibs pkg) + let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs configFlags) + absoluteDirs = InstallDirs.absoluteInstallDirs + (packageId pkg) compilerId InstallDirs.NoCopyDest + templateDirs + canonicalizePath (InstallDirs.bindir absoluteDirs) + + substTemplate pkgid = InstallDirs.fromPathTemplate + . InstallDirs.substPathTemplate env + where env = InstallDirs.initialPathTemplateEnv pkgid compilerId + + fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "") + prefixTemplate = fromFlagTemplate (configProgPrefix configFlags) + suffixTemplate = fromFlagTemplate (configProgSuffix configFlags) + platform = InstallPlan.planPlatform plan + compilerId@(CompilerId compilerFlavor _) = InstallPlan.planCompiler plan + +symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir + -- eg @/home/user/bin@ + -> FilePath -- ^ The canonical path of the private bin dir + -- eg @/home/user/.cabal/bin@ + -> String -- ^ The name of the executable to go in the public + -- bin dir, eg @foo@ + -> String -- ^ The name of the executable to in the private bin + -- dir, eg @foo-1.0@ + -> IO Bool -- ^ If creating the symlink was sucessful. @False@ + -- if there was another file there already that we + -- did not own. Other errors like permission errors + -- just propagate as exceptions. +symlinkBinary publicBindir privateBindir publicName privateName = do + ok <- targetOkToOverwrite (publicBindir publicName) + (privateBindir privateName) + case ok of + NotOurFile -> return False + NotExists -> mkLink >> return True + OkToOverwrite -> rmLink >> mkLink >> return True + where + relativeBindir = makeRelative publicBindir privateBindir + mkLink = createSymbolicLink (relativeBindir privateName) + (publicBindir publicName) + rmLink = removeLink (publicBindir publicName) + +-- | Check a filepath of a symlink that we would like to create to see if it +-- is ok. For it to be ok to overwrite it must either not already exist yet or +-- be a symlink to our target (in which case we can assume ownership). +-- +targetOkToOverwrite :: FilePath -- ^ The filepath of the symlink to the private + -- binary that we would like to create + -> FilePath -- ^ The canonical path of the private binary. + -- Use 'canonicalizePath' to make this. + -> IO SymlinkStatus +targetOkToOverwrite symlink target = handleNotExist $ do + status <- getSymbolicLinkStatus symlink + if not (isSymbolicLink status) + then return NotOurFile + else do target' <- canonicalizePath symlink + -- This relies on canonicalizePath handling symlinks + if target == target' + then return OkToOverwrite + else return NotOurFile + + where + handleNotExist action = catch action $ \ioexception -> + -- If the target doesn't exist then there's no problem overwriting it! + if isDoesNotExistError ioexception + then return NotExists + else ioError ioexception + +data SymlinkStatus + = NotExists -- ^ The file doesn't exist so we can make a symlink. + | OkToOverwrite -- ^ A symlink already exists, though it is ours. We'll + -- have to delete it first bemore we make a new symlink. + | NotOurFile -- ^ A file already exists and it is not one of our existing + -- symlinks (either because it is not a symlink or because + -- it points somewhere other than our managed space). + deriving Show + +-- | Take two canonical paths and produce a relative path to get from the first +-- to the second, even if it means adding @..@ path components. +-- +makeRelative :: FilePath -> FilePath -> FilePath +makeRelative a b = assert (isAbsolute a && isAbsolute b) $ + let as = splitPath a + bs = splitPath b + commonLen = length $ takeWhile id $ zipWith (==) as bs + in joinPath $ [ ".." | _ <- drop commonLen as ] + ++ [ b' | b' <- drop commonLen bs ] + +#endif diff --git a/cabal/cabal-install/Distribution/Client/List.hs b/cabal/cabal-install/Distribution/Client/List.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/List.hs @@ -0,0 +1,530 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.List +-- Copyright : (c) David Himmelstrup 2005 +-- Duncan Coutts 2008-2011 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- +-- Search for and print information about packages +----------------------------------------------------------------------------- +module Distribution.Client.List ( + list, info + ) where + +import Distribution.Package + ( PackageName(..), Package(..), packageName, packageVersion + , Dependency(..), thisPackageVersion, depends, simplifyDependency ) +import Distribution.ModuleName (ModuleName) +import Distribution.License (License) +import qualified Distribution.InstalledPackageInfo as Installed +import qualified Distribution.PackageDescription as Source +import Distribution.PackageDescription + ( Flag(..), FlagName(..) ) +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) + +import Distribution.Simple.Compiler + ( Compiler, PackageDBStack ) +import Distribution.Simple.Program (ProgramConfiguration) +import Distribution.Simple.Utils + ( equating, comparing, die, notice ) +import Distribution.Simple.Setup (fromFlag) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Version + ( Version(..), VersionRange, withinRange, anyVersion + , intersectVersionRanges, simplifyVersionRange ) +import Distribution.Verbosity (Verbosity) +import Distribution.Text + ( Text(disp), display ) + +import Distribution.Client.Types + ( SourcePackage(..), Repo, SourcePackageDb(..) + , InstalledPackage(..) ) +import Distribution.Client.Dependency.Types + ( PackageConstraint(..) ) +import Distribution.Client.Targets + ( UserTarget, resolveUserTargets, PackageSpecifier(..) ) +import Distribution.Client.Setup + ( GlobalFlags(..), ListFlags(..), InfoFlags(..) ) +import Distribution.Client.Utils + ( mergeBy, MergeResult(..) ) +import Distribution.Client.IndexUtils as IndexUtils + ( getSourcePackages, getInstalledPackages ) +import Distribution.Client.FetchUtils + ( isFetched ) + +import Data.List + ( sortBy, groupBy, sort, nub, intersperse, maximumBy, partition ) +import Data.Maybe + ( listToMaybe, fromJust, fromMaybe, isJust ) +import qualified Data.Map as Map +import Data.Tree as Tree +import Control.Monad + ( MonadPlus(mplus), join ) +import Control.Exception + ( assert ) +import Text.PrettyPrint.HughesPJ as Disp +import System.Directory + ( doesDirectoryExist ) + + +-- |Show information about packages +list :: Verbosity + -> PackageDBStack + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> ListFlags + -> [String] + -> IO () +list verbosity packageDBs repos comp conf listFlags pats = do + + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf + sourcePkgDb <- getSourcePackages verbosity repos + let sourcePkgIndex = packageIndex sourcePkgDb + prefs name = fromMaybe anyVersion + (Map.lookup name (packagePreferences sourcePkgDb)) + + pkgsInfo :: [(PackageName, [InstalledPackage], [SourcePackage])] + pkgsInfo + -- gather info for all packages + | null pats = mergePackages (PackageIndex.allPackages installedPkgIndex) + (PackageIndex.allPackages sourcePkgIndex) + + -- gather info for packages matching search term + | otherwise = mergePackages (matchingPackages installedPkgIndex) + (matchingPackages sourcePkgIndex) + + matches :: [PackageDisplayInfo] + matches = [ mergePackageInfo pref + installedPkgs sourcePkgs selectedPkg False + | (pkgname, installedPkgs, sourcePkgs) <- pkgsInfo + , not onlyInstalled || not (null installedPkgs) + , let pref = prefs pkgname + selectedPkg = latestWithPref pref sourcePkgs ] + + if simpleOutput + then putStr $ unlines + [ display (pkgName pkg) ++ " " ++ display version + | pkg <- matches + , version <- if onlyInstalled + then installedVersions pkg + else nub . sort $ installedVersions pkg + ++ sourceVersions pkg ] + -- Note: this only works because for 'list', one cannot currently + -- specify any version constraints, so listing all installed + -- and source ones works. + else + if null matches + then notice verbosity "No matches found." + else putStr $ unlines (map showPackageSummaryInfo matches) + where + onlyInstalled = fromFlag (listInstalled listFlags) + simpleOutput = fromFlag (listSimpleOutput listFlags) + + matchingPackages index = + [ pkg + | pat <- pats + , (_, pkgs) <- PackageIndex.searchByNameSubstring index pat + , pkg <- pkgs ] + +info :: Verbosity + -> PackageDBStack + -> [Repo] + -> Compiler + -> ProgramConfiguration + -> GlobalFlags + -> InfoFlags + -> [UserTarget] + -> IO () +info verbosity packageDBs repos comp conf + globalFlags _listFlags userTargets = do + + installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf + sourcePkgDb <- getSourcePackages verbosity repos + let sourcePkgIndex = packageIndex sourcePkgDb + prefs name = fromMaybe anyVersion + (Map.lookup name (packagePreferences sourcePkgDb)) + + -- Users may specify names of packages that are only installed, not + -- just available source packages, so we must resolve targets using + -- the combination of installed and source packages. + let sourcePkgs' = PackageIndex.fromList + $ map packageId (PackageIndex.allPackages installedPkgIndex) + ++ map packageId (PackageIndex.allPackages sourcePkgIndex) + pkgSpecifiers <- resolveUserTargets verbosity + (fromFlag $ globalWorldFile globalFlags) + sourcePkgs' userTargets + + pkgsinfo <- sequence + [ do pkginfo <- either die return $ + gatherPkgInfo prefs + installedPkgIndex sourcePkgIndex + pkgSpecifier + updateFileSystemPackageDetails pkginfo + | pkgSpecifier <- pkgSpecifiers ] + + putStr $ unlines (map showPackageDetailedInfo pkgsinfo) + + where + gatherPkgInfo prefs installedPkgIndex sourcePkgIndex (NamedPackage name constraints) + | null (selectedInstalledPkgs) && null (selectedSourcePkgs) + = Left $ "There is no available version of " ++ display name + ++ " that satisfies " + ++ display (simplifyVersionRange verConstraint) + + | otherwise + = Right $ mergePackageInfo pref installedPkgs + sourcePkgs selectedSourcePkg + showPkgVersion + where + pref = prefs name + installedPkgs = PackageIndex.lookupPackageName installedPkgIndex name + sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name + + selectedInstalledPkgs = PackageIndex.lookupDependency installedPkgIndex + (Dependency name verConstraint) + selectedSourcePkgs = PackageIndex.lookupDependency sourcePkgIndex + (Dependency name verConstraint) + selectedSourcePkg = latestWithPref pref selectedSourcePkgs + + -- display a specific package version if the user + -- supplied a non-trivial version constraint + showPkgVersion = not (null verConstraints) + verConstraint = foldr intersectVersionRanges anyVersion verConstraints + verConstraints = [ vr | PackageConstraintVersion _ vr <- constraints ] + + gatherPkgInfo prefs installedPkgIndex sourcePkgIndex (SpecificSourcePackage pkg) = + Right $ mergePackageInfo pref installedPkgs sourcePkgs + selectedPkg True + where + name = packageName pkg + pref = prefs name + installedPkgs = PackageIndex.lookupPackageName installedPkgIndex name + sourcePkgs = PackageIndex.lookupPackageName sourcePkgIndex name + selectedPkg = Just pkg + + +-- | The info that we can display for each package. It is information per +-- package name and covers all installed and avilable versions. +-- +data PackageDisplayInfo = PackageDisplayInfo { + pkgName :: PackageName, + selectedVersion :: Maybe Version, + selectedSourcePkg :: Maybe SourcePackage, + installedVersions :: [Version], + sourceVersions :: [Version], + preferredVersions :: VersionRange, + homepage :: String, + bugReports :: String, + sourceRepo :: String, + synopsis :: String, + description :: String, + category :: String, + license :: License, + author :: String, + maintainer :: String, + dependencies :: [Dependency], + flags :: [Flag], + hasLib :: Bool, + hasExe :: Bool, + executables :: [String], + modules :: [ModuleName], + haddockHtml :: FilePath, + haveTarball :: Bool + } + +showPackageSummaryInfo :: PackageDisplayInfo -> String +showPackageSummaryInfo pkginfo = + renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ + char '*' <+> disp (pkgName pkginfo) + $+$ + (nest 4 $ vcat [ + maybeShow (synopsis pkginfo) "Synopsis:" reflowParagraphs + , text "Default available version:" <+> + case selectedSourcePkg pkginfo of + Nothing -> text "[ Not available from any configured repository ]" + Just pkg -> disp (packageVersion pkg) + , text "Installed versions:" <+> + case installedVersions pkginfo of + [] | hasLib pkginfo -> text "[ Not installed ]" + | otherwise -> text "[ Unknown ]" + versions -> dispTopVersions 4 + (preferredVersions pkginfo) versions + , maybeShow (homepage pkginfo) "Homepage:" text + , text "License: " <+> text (display (license pkginfo)) + ]) + $+$ text "" + where + maybeShow [] _ _ = empty + maybeShow l s f = text s <+> (f l) + +showPackageDetailedInfo :: PackageDisplayInfo -> String +showPackageDetailedInfo pkginfo = + renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $ + char '*' <+> disp (pkgName pkginfo) + <> maybe empty (\v -> char '-' <> disp v) (selectedVersion pkginfo) + <+> text (replicate (16 - length (display (pkgName pkginfo))) ' ') + <> parens pkgkind + $+$ + (nest 4 $ vcat [ + entry "Synopsis" synopsis hideIfNull reflowParagraphs + , entry "Versions available" sourceVersions + (altText null "[ Not available from server ]") + (dispTopVersions 9 (preferredVersions pkginfo)) + , entry "Versions installed" installedVersions + (altText null (if hasLib pkginfo then "[ Not installed ]" + else "[ Unknown ]")) + (dispTopVersions 4 (preferredVersions pkginfo)) + , entry "Homepage" homepage orNotSpecified text + , entry "Bug reports" bugReports orNotSpecified text + , entry "Description" description hideIfNull reflowParagraphs + , entry "Category" category hideIfNull text + , entry "License" license alwaysShow disp + , entry "Author" author hideIfNull reflowLines + , entry "Maintainer" maintainer hideIfNull reflowLines + , entry "Source repo" sourceRepo orNotSpecified text + , entry "Executables" executables hideIfNull (commaSep text) + , entry "Flags" flags hideIfNull (commaSep dispFlag) + , entry "Dependencies" dependencies hideIfNull (commaSep disp) + , entry "Documentation" haddockHtml showIfInstalled text + , entry "Cached" haveTarball alwaysShow dispYesNo + , if not (hasLib pkginfo) then empty else + text "Modules:" $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo)) + ]) + $+$ text "" + where + entry fname field cond format = case cond (field pkginfo) of + Nothing -> label <+> format (field pkginfo) + Just Nothing -> empty + Just (Just other) -> label <+> text other + where + label = text fname <> char ':' <> padding + padding = text (replicate (13 - length fname ) ' ') + + normal = Nothing + hide = Just Nothing + replace msg = Just (Just msg) + + alwaysShow = const normal + hideIfNull v = if null v then hide else normal + showIfInstalled v + | not isInstalled = hide + | null v = replace "[ Not installed ]" + | otherwise = normal + altText nul msg v = if nul v then replace msg else normal + orNotSpecified = altText null "[ Not specified ]" + + commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f + dispFlag f = case flagName f of FlagName n -> text n + dispYesNo True = text "Yes" + dispYesNo False = text "No" + + isInstalled = not (null (installedVersions pkginfo)) + hasExes = length (executables pkginfo) >= 2 + --TODO: exclude non-buildable exes + pkgkind | hasLib pkginfo && hasExes = text "programs and library" + | hasLib pkginfo && hasExe pkginfo = text "program and library" + | hasLib pkginfo = text "library" + | hasExes = text "programs" + | hasExe pkginfo = text "program" + | otherwise = empty + + +reflowParagraphs :: String -> Doc +reflowParagraphs = + vcat + . intersperse (text "") -- re-insert blank lines + . map (fsep . map text . concatMap words) -- reflow paragraphs + . filter (/= [""]) + . groupBy (\x y -> "" `notElem` [x,y]) -- break on blank lines + . lines + +reflowLines :: String -> Doc +reflowLines = vcat . map text . lines + +-- | We get the 'PackageDisplayInfo' by combining the info for the installed +-- and available versions of a package. +-- +-- * We're building info about a various versions of a single named package so +-- the input package info records are all supposed to refer to the same +-- package name. +-- +mergePackageInfo :: VersionRange + -> [InstalledPackage] + -> [SourcePackage] + -> Maybe SourcePackage + -> Bool + -> PackageDisplayInfo +mergePackageInfo versionPref installedPkgs sourcePkgs selectedPkg showVer = + assert (length installedPkgs + length sourcePkgs > 0) $ + PackageDisplayInfo { + pkgName = combine packageName source + packageName installed, + selectedVersion = if showVer then fmap packageVersion selectedPkg + else Nothing, + selectedSourcePkg = sourceSelected, + installedVersions = map packageVersion installedPkgs, + sourceVersions = map packageVersion sourcePkgs, + preferredVersions = versionPref, + + license = combine Source.license source + Installed.license installed, + maintainer = combine Source.maintainer source + Installed.maintainer installed, + author = combine Source.author source + Installed.author installed, + homepage = combine Source.homepage source + Installed.homepage installed, + bugReports = maybe "" Source.bugReports source, + sourceRepo = fromMaybe "" . join + . fmap (uncons Nothing Source.repoLocation + . sortBy (comparing Source.repoKind) + . Source.sourceRepos) + $ source, + --TODO: installed package info is missing synopsis + synopsis = maybe "" Source.synopsis source, + description = combine Source.description source + Installed.description installed, + category = combine Source.category source + Installed.category installed, + flags = maybe [] Source.genPackageFlags sourceGeneric, + hasLib = isJust installed + || fromMaybe False + (fmap (isJust . Source.condLibrary) sourceGeneric), + hasExe = fromMaybe False + (fmap (not . null . Source.condExecutables) sourceGeneric), + executables = map fst (maybe [] Source.condExecutables sourceGeneric), + modules = combine Installed.exposedModules installed + (maybe [] Source.exposedModules + . Source.library) source, + dependencies = map simplifyDependency + $ combine Source.buildDepends source + (map thisPackageVersion . depends) installed', + haddockHtml = fromMaybe "" . join + . fmap (listToMaybe . Installed.haddockHTMLs) + $ installed, + haveTarball = False + } + where + combine f x g y = fromJust (fmap f x `mplus` fmap g y) + installed' = latestWithPref versionPref installedPkgs + installed = fmap (\(InstalledPackage p _) -> p) installed' + + sourceSelected + | isJust selectedPkg = selectedPkg + | otherwise = latestWithPref versionPref sourcePkgs + sourceGeneric = fmap packageDescription sourceSelected + source = fmap flattenPackageDescription sourceGeneric + + uncons :: b -> (a -> b) -> [a] -> b + uncons z _ [] = z + uncons _ f (x:_) = f x + + +-- | Not all the info is pure. We have to check if the docs really are +-- installed, because the registered package info lies. Similarly we have to +-- check if the tarball has indeed been fetched. +-- +updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo +updateFileSystemPackageDetails pkginfo = do + fetched <- maybe (return False) (isFetched . packageSource) + (selectedSourcePkg pkginfo) + docsExist <- doesDirectoryExist (haddockHtml pkginfo) + return pkginfo { + haveTarball = fetched, + haddockHtml = if docsExist then haddockHtml pkginfo else "" + } + +latestWithPref :: Package pkg => VersionRange -> [pkg] -> Maybe pkg +latestWithPref _ [] = Nothing +latestWithPref pref pkgs = Just (maximumBy (comparing prefThenVersion) pkgs) + where + prefThenVersion pkg = let ver = packageVersion pkg + in (withinRange ver pref, ver) + + +-- | Rearrange installed and source packages into groups referring to the +-- same package by name. In the result pairs, the lists are guaranteed to not +-- both be empty. +-- +mergePackages :: [InstalledPackage] + -> [SourcePackage] + -> [( PackageName + , [InstalledPackage] + , [SourcePackage] )] +mergePackages installedPkgs sourcePkgs = + map collect + $ mergeBy (\i a -> fst i `compare` fst a) + (groupOn packageName installedPkgs) + (groupOn packageName sourcePkgs) + where + collect (OnlyInLeft (name,is) ) = (name, is, []) + collect ( InBoth (_,is) (name,as)) = (name, is, as) + collect (OnlyInRight (name,as)) = (name, [], as) + +groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])] +groupOn key = map (\xs -> (key (head xs), xs)) + . groupBy (equating key) + . sortBy (comparing key) + +dispTopVersions :: Int -> VersionRange -> [Version] -> Doc +dispTopVersions n pref vs = + (Disp.fsep . Disp.punctuate (Disp.char ',') + . map (\ver -> if ispref ver then disp ver else parens (disp ver)) + . sort . take n . interestingVersions ispref + $ vs) + <+> trailingMessage + + where + ispref ver = withinRange ver pref + extra = length vs - n + trailingMessage + | extra <= 0 = Disp.empty + | otherwise = Disp.parens $ Disp.text "and" + <+> Disp.int (length vs - n) + <+> if extra == 1 then Disp.text "other" + else Disp.text "others" + +-- | Reorder a bunch of versions to put the most interesting / significant +-- versions first. A preferred version range is taken into account. +-- +-- This may be used in a user interface to select a small number of versions +-- to present to the user, e.g. +-- +-- > let selectVersions = sort . take 5 . interestingVersions pref +-- +interestingVersions :: (Version -> Bool) -> [Version] -> [Version] +interestingVersions pref = + map ((\ns -> Version ns []) . fst) . filter snd + . concat . Tree.levels + . swizzleTree + . reorderTree (\(Node (v,_) _) -> pref (Version v [])) + . reverseTree + . mkTree + . map versionBranch + + where + swizzleTree = unfoldTree (spine []) + where + spine ts' (Node x []) = (x, ts') + spine ts' (Node x (t:ts)) = spine (Node x ts:ts') t + + reorderTree _ (Node x []) = Node x [] + reorderTree p (Node x ts) = Node x (ts' ++ ts'') + where + (ts',ts'') = partition p (map (reorderTree p) ts) + + reverseTree (Node x cs) = Node x (reverse (map reverseTree cs)) + + mkTree xs = unfoldTree step (False, [], xs) + where + step (node,ns,vs) = + ( (reverse ns, node) + , [ (any null vs', n:ns, filter (not . null) vs') + | (n, vs') <- groups vs ] + ) + groups = map (\g -> (head (head g), map tail g)) + . groupBy (equating head) diff --git a/cabal/cabal-install/Distribution/Client/PackageIndex.hs b/cabal/cabal-install/Distribution/Client/PackageIndex.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/PackageIndex.hs @@ -0,0 +1,487 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.PackageIndex +-- Copyright : (c) David Himmelstrup 2005, +-- Bjorn Bringert 2007, +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- An index of packages. +-- +module Distribution.Client.PackageIndex ( + -- * Package index data type + PackageIndex, + + -- * Creating an index + fromList, + + -- * Updates + merge, + insert, + deletePackageName, + deletePackageId, + deleteDependency, + + -- * Queries + + -- ** Precise lookups + elemByPackageId, + elemByPackageName, + lookupPackageName, + lookupPackageId, + lookupDependency, + + -- ** Case-insensitive searches + searchByName, + SearchResult(..), + searchByNameSubstring, + + -- ** Bulk queries + allPackages, + allPackagesByName, + + -- ** Special queries + brokenPackages, + dependencyClosure, + reverseDependencyClosure, + topologicalOrder, + reverseTopologicalOrder, + dependencyInconsistencies, + dependencyCycles, + dependencyGraph, + ) where + +import Prelude hiding (lookup) +import Control.Exception (assert) +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Tree as Tree +import qualified Data.Graph as Graph +import qualified Data.Array as Array +import Data.Array ((!)) +import Data.List (groupBy, sortBy, nub, isInfixOf) +import Data.Monoid (Monoid(..)) +import Data.Maybe (isJust, isNothing, fromMaybe) + +import Distribution.Package + ( PackageName(..), PackageIdentifier(..) + , Package(..), packageName, packageVersion + , Dependency(Dependency), PackageFixedDeps(..) ) +import Distribution.Version + ( Version, withinRange ) +import Distribution.Simple.Utils (lowercase, equating, comparing) + + +-- | The collection of information about packages from one or more 'PackageDB's. +-- +-- It can be searched effeciently by package name and version. +-- +newtype Package pkg => PackageIndex pkg = PackageIndex + -- This index package names to all the package records matching that package + -- name case-sensitively. It includes all versions. + -- + -- This allows us to find all versions satisfying a dependency. + -- Most queries are a map lookup followed by a linear scan of the bucket. + -- + (Map PackageName [pkg]) + + deriving (Show, Read) + +instance Package pkg => Monoid (PackageIndex pkg) where + mempty = PackageIndex (Map.empty) + mappend = merge + --save one mappend with empty in the common case: + mconcat [] = mempty + mconcat xs = foldr1 mappend xs + +invariant :: Package pkg => PackageIndex pkg -> Bool +invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m) + where + goodBucket _ [] = False + goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0 + where + check pkgid [] = packageName pkgid == name + check pkgid (pkg':pkgs) = packageName pkgid == name + && pkgid < pkgid' + && check pkgid' pkgs + where pkgid' = packageId pkg' + +-- +-- * Internal helpers +-- + +mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg +mkPackageIndex index = assert (invariant (PackageIndex index)) + (PackageIndex index) + +internalError :: String -> a +internalError name = error ("PackageIndex." ++ name ++ ": internal error") + +-- | Lookup a name in the index to get all packages that match that name +-- case-sensitively. +-- +lookup :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] +lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m + +-- +-- * Construction +-- + +-- | Build an index out of a bunch of packages. +-- +-- If there are duplicates, later ones mask earlier ones. +-- +fromList :: Package pkg => [pkg] -> PackageIndex pkg +fromList pkgs = mkPackageIndex + . Map.map fixBucket + . Map.fromListWith (++) + $ [ (packageName pkg, [pkg]) + | pkg <- pkgs ] + where + fixBucket = -- out of groups of duplicates, later ones mask earlier ones + -- but Map.fromListWith (++) constructs groups in reverse order + map head + -- Eq instance for PackageIdentifier is wrong, so use Ord: + . groupBy (\a b -> EQ == comparing packageId a b) + -- relies on sortBy being a stable sort so we + -- can pick consistently among duplicates + . sortBy (comparing packageId) + +-- +-- * Updates +-- + +-- | Merge two indexes. +-- +-- Packages from the second mask packages of the same exact name +-- (case-sensitively) from the first. +-- +merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg +merge i1@(PackageIndex m1) i2@(PackageIndex m2) = + assert (invariant i1 && invariant i2) $ + mkPackageIndex (Map.unionWith mergeBuckets m1 m2) + +-- | Elements in the second list mask those in the first. +mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg] +mergeBuckets [] ys = ys +mergeBuckets xs [] = xs +mergeBuckets xs@(x:xs') ys@(y:ys') = + case packageId x `compare` packageId y of + GT -> y : mergeBuckets xs ys' + EQ -> y : mergeBuckets xs' ys' + LT -> x : mergeBuckets xs' ys + +-- | Inserts a single package into the index. +-- +-- This is equivalent to (but slightly quicker than) using 'mappend' or +-- 'merge' with a singleton index. +-- +insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg +insert pkg (PackageIndex index) = mkPackageIndex $ + Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index + where + pkgid = packageId pkg + insertNoDup [] = [pkg] + insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of + LT -> pkg : pkgs + EQ -> pkg : pkgs' + GT -> pkg' : insertNoDup pkgs' + +-- | Internal delete helper. +-- +delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg +delete name p (PackageIndex index) = mkPackageIndex $ + Map.update filterBucket name index + where + filterBucket = deleteEmptyBucket + . filter (not . p) + deleteEmptyBucket [] = Nothing + deleteEmptyBucket remaining = Just remaining + +-- | Removes a single package from the index. +-- +deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg -> PackageIndex pkg +deletePackageId pkgid = + delete (packageName pkgid) (\pkg -> packageId pkg == pkgid) + +-- | Removes all packages with this (case-sensitive) name from the index. +-- +deletePackageName :: Package pkg => PackageName -> PackageIndex pkg -> PackageIndex pkg +deletePackageName name = + delete name (\pkg -> packageName pkg == name) + +-- | Removes all packages satisfying this dependency from the index. +-- +deleteDependency :: Package pkg => Dependency -> PackageIndex pkg -> PackageIndex pkg +deleteDependency (Dependency name verstionRange) = + delete name (\pkg -> packageVersion pkg `withinRange` verstionRange) + +-- +-- * Bulk queries +-- + +-- | Get all the packages from the index. +-- +allPackages :: Package pkg => PackageIndex pkg -> [pkg] +allPackages (PackageIndex m) = concat (Map.elems m) + +-- | Get all the packages from the index. +-- +-- They are grouped by package name, case-sensitively. +-- +allPackagesByName :: Package pkg => PackageIndex pkg -> [[pkg]] +allPackagesByName (PackageIndex m) = Map.elems m + +-- +-- * Lookups +-- + +elemByPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Bool +elemByPackageId index = isJust . lookupPackageId index + +elemByPackageName :: Package pkg => PackageIndex pkg -> PackageName -> Bool +elemByPackageName index = not . null . lookupPackageName index + + +-- | Does a lookup by package id (name & version). +-- +-- Since multiple package DBs mask each other case-sensitively by package name, +-- then we get back at most one package. +-- +lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg +lookupPackageId index pkgid = + case [ pkg | pkg <- lookup index (packageName pkgid) + , packageId pkg == pkgid ] of + [] -> Nothing + [pkg] -> Just pkg + _ -> internalError "lookupPackageIdentifier" + +-- | Does a case-sensitive search by package name. +-- +lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] +lookupPackageName index name = + [ pkg | pkg <- lookup index name + , packageName pkg == name ] + +-- | Does a case-sensitive search by package name and a range of versions. +-- +-- We get back any number of versions of the specified package name, all +-- satisfying the version range constraint. +-- +lookupDependency :: Package pkg => PackageIndex pkg -> Dependency -> [pkg] +lookupDependency index (Dependency name versionRange) = + [ pkg | pkg <- lookup index name + , packageName pkg == name + , packageVersion pkg `withinRange` versionRange ] + +-- +-- * Case insensitive name lookups +-- + +-- | Does a case-insensitive search by package name. +-- +-- If there is only one package that compares case-insentiviely to this name +-- then the search is unambiguous and we get back all versions of that package. +-- If several match case-insentiviely but one matches exactly then it is also +-- unambiguous. +-- +-- If however several match case-insentiviely and none match exactly then we +-- have an ambiguous result, and we get back all the versions of all the +-- packages. The list of ambiguous results is split by exact package name. So +-- it is a non-empty list of non-empty lists. +-- +searchByName :: Package pkg => PackageIndex pkg + -> String -> [(PackageName, [pkg])] +searchByName (PackageIndex m) name = + [ pkgs + | pkgs@(PackageName name',_) <- Map.toList m + , lowercase name' == lname ] + where + lname = lowercase name + +data SearchResult a = None | Unambiguous a | Ambiguous [a] + +-- | Does a case-insensitive substring search by package name. +-- +-- That is, all packages that contain the given string in their name. +-- +searchByNameSubstring :: Package pkg => PackageIndex pkg + -> String -> [(PackageName, [pkg])] +searchByNameSubstring (PackageIndex m) searchterm = + [ pkgs + | pkgs@(PackageName name, _) <- Map.toList m + , lsearchterm `isInfixOf` lowercase name ] + where + lsearchterm = lowercase searchterm + +-- +-- * Special queries +-- + +-- | All packages that have dependencies that are not in the index. +-- +-- Returns such packages along with the dependencies that they're missing. +-- +brokenPackages :: PackageFixedDeps pkg + => PackageIndex pkg + -> [(pkg, [PackageIdentifier])] +brokenPackages index = + [ (pkg, missing) + | pkg <- allPackages index + , let missing = [ pkg' | pkg' <- depends pkg + , isNothing (lookupPackageId index pkg') ] + , not (null missing) ] + +-- | Tries to take the transative closure of the package dependencies. +-- +-- If the transative closure is complete then it returns that subset of the +-- index. Otherwise it returns the broken packages as in 'brokenPackages'. +-- +-- * Note that if the result is @Right []@ it is because at least one of +-- the original given 'PackageIdentifier's do not occur in the index. +-- +dependencyClosure :: PackageFixedDeps pkg + => PackageIndex pkg + -> [PackageIdentifier] + -> Either (PackageIndex pkg) + [(pkg, [PackageIdentifier])] +dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of + (completed, []) -> Left completed + (completed, _) -> Right (brokenPackages completed) + where + closure completed failed [] = (completed, failed) + closure completed failed (pkgid:pkgids) = case lookupPackageId index pkgid of + Nothing -> closure completed (pkgid:failed) pkgids + Just pkg -> case lookupPackageId completed (packageId pkg) of + Just _ -> closure completed failed pkgids + Nothing -> closure completed' failed pkgids' + where completed' = insert pkg completed + pkgids' = depends pkg ++ pkgids + +-- | Takes the transative closure of the packages reverse dependencies. +-- +-- * The given 'PackageIdentifier's must be in the index. +-- +reverseDependencyClosure :: PackageFixedDeps pkg + => PackageIndex pkg + -> [PackageIdentifier] + -> [pkg] +reverseDependencyClosure index = + map vertexToPkg + . concatMap Tree.flatten + . Graph.dfs reverseDepGraph + . map (fromMaybe noSuchPkgId . pkgIdToVertex) + + where + (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index + reverseDepGraph = Graph.transposeG depGraph + noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" + +topologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg] +topologicalOrder index = map toPkgId + . Graph.topSort + $ graph + where (graph, toPkgId, _) = dependencyGraph index + +reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg] +reverseTopologicalOrder index = map toPkgId + . Graph.topSort + . Graph.transposeG + $ graph + where (graph, toPkgId, _) = dependencyGraph index + +-- | Given a package index where we assume we want to use all the packages +-- (use 'dependencyClosure' if you need to get such a index subset) find out +-- if the dependencies within it use consistent versions of each package. +-- Return all cases where multiple packages depend on different versions of +-- some other package. +-- +-- Each element in the result is a package name along with the packages that +-- depend on it and the versions they require. These are guaranteed to be +-- distinct. +-- +dependencyInconsistencies :: PackageFixedDeps pkg + => PackageIndex pkg + -> [(PackageName, [(PackageIdentifier, Version)])] +dependencyInconsistencies index = + [ (name, inconsistencies) + | (name, uses) <- Map.toList inverseIndex + , let inconsistencies = duplicatesBy uses + versions = map snd inconsistencies + , reallyIsInconsistent name (nub versions) ] + + where inverseIndex = Map.fromListWith (++) + [ (packageName dep, [(packageId pkg, packageVersion dep)]) + | pkg <- allPackages index + , dep <- depends pkg ] + + duplicatesBy = (\groups -> if length groups == 1 + then [] + else concat groups) + . groupBy (equating snd) + . sortBy (comparing snd) + + reallyIsInconsistent :: PackageName -> [Version] -> Bool + reallyIsInconsistent _ [] = False + reallyIsInconsistent name [v1, v2] = + case (mpkg1, mpkg2) of + (Just pkg1, Just pkg2) -> pkgid1 `notElem` depends pkg2 + && pkgid2 `notElem` depends pkg1 + _ -> True + where + pkgid1 = PackageIdentifier name v1 + pkgid2 = PackageIdentifier name v2 + mpkg1 = lookupPackageId index pkgid1 + mpkg2 = lookupPackageId index pkgid2 + + reallyIsInconsistent _ _ = True + +-- | Find if there are any cycles in the dependency graph. If there are no +-- cycles the result is @[]@. +-- +-- This actually computes the strongly connected components. So it gives us a +-- list of groups of packages where within each group they all depend on each +-- other, directly or indirectly. +-- +dependencyCycles :: PackageFixedDeps pkg + => PackageIndex pkg + -> [[pkg]] +dependencyCycles index = + [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] + where + adjacencyList = [ (pkg, packageId pkg, depends pkg) + | pkg <- allPackages index ] + +-- | Builds a graph of the package dependencies. +-- +-- Dependencies on other packages that are not in the index are discarded. +-- You can check if there are any such dependencies with 'brokenPackages'. +-- +dependencyGraph :: PackageFixedDeps pkg + => PackageIndex pkg + -> (Graph.Graph, + Graph.Vertex -> pkg, + PackageIdentifier -> Maybe Graph.Vertex) +dependencyGraph index = (graph, vertexToPkg, pkgIdToVertex) + where + graph = Array.listArray bounds + [ [ v | Just v <- map pkgIdToVertex (depends pkg) ] + | pkg <- pkgs ] + vertexToPkg vertex = pkgTable ! vertex + pkgIdToVertex = binarySearch 0 topBound + + pkgTable = Array.listArray bounds pkgs + pkgIdTable = Array.listArray bounds (map packageId pkgs) + pkgs = sortBy (comparing packageId) (allPackages index) + topBound = length pkgs - 1 + bounds = (0, topBound) + + binarySearch a b key + | a > b = Nothing + | otherwise = case compare key (pkgIdTable ! mid) of + LT -> binarySearch a (mid-1) key + EQ -> Just mid + GT -> binarySearch (mid+1) b key + where mid = (a + b) `div` 2 diff --git a/cabal/cabal-install/Distribution/Client/PackageUtils.hs b/cabal/cabal-install/Distribution/Client/PackageUtils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/PackageUtils.hs @@ -0,0 +1,34 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.PackageUtils +-- Copyright : (c) Duncan Coutts 2010 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Various package description utils that should be in the Cabal lib +----------------------------------------------------------------------------- +module Distribution.Client.PackageUtils ( + externalBuildDepends, + ) where + +import Distribution.Package + ( packageVersion, packageName, Dependency(..) ) +import Distribution.PackageDescription + ( PackageDescription(..) ) +import Distribution.Version + ( withinRange ) + +-- | The list of dependencies that refer to external packages +-- rather than internal package components. +-- +externalBuildDepends :: PackageDescription -> [Dependency] +externalBuildDepends pkg = filter (not . internal) (buildDepends pkg) + where + -- True if this dependency is an internal one (depends on a library + -- defined in the same package). + internal (Dependency depName versionRange) = + depName == packageName pkg && + packageVersion pkg `withinRange` versionRange diff --git a/cabal/cabal-install/Distribution/Client/Setup.hs b/cabal/cabal-install/Distribution/Client/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Setup.hs @@ -0,0 +1,1023 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Setup +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- +----------------------------------------------------------------------------- +module Distribution.Client.Setup + ( globalCommand, GlobalFlags(..), globalRepos + , configureCommand, ConfigFlags(..), filterConfigureFlags + , configureExCommand, ConfigExFlags(..), defaultConfigExFlags + , configureExOptions + , installCommand, InstallFlags(..), installOptions, defaultInstallFlags + , listCommand, ListFlags(..) + , updateCommand + , upgradeCommand + , infoCommand, InfoFlags(..) + , fetchCommand, FetchFlags(..) + , checkCommand + , uploadCommand, UploadFlags(..) + , reportCommand, ReportFlags(..) + , unpackCommand, UnpackFlags(..) + , initCommand, IT.InitFlags(..) + + , parsePackageArgs + --TODO: stop exporting these: + , showRepo + , parseRepo + ) where + +import Distribution.Client.Types + ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) ) +import Distribution.Client.BuildReports.Types + ( ReportLevel(..) ) +import qualified Distribution.Client.Init.Types as IT + ( InitFlags(..), PackageType(..) ) +import Distribution.Client.Targets + ( UserConstraint, readUserConstraint ) + +import Distribution.Simple.Program + ( defaultProgramConfiguration ) +import Distribution.Simple.Command hiding (boolOpt) +import qualified Distribution.Simple.Command as Command +import qualified Distribution.Simple.Setup as Cabal + ( configureCommand ) +import Distribution.Simple.Setup + ( ConfigFlags(..) ) +import Distribution.Simple.Setup + ( Flag(..), toFlag, fromFlag, flagToList, flagToMaybe + , optionVerbosity, trueArg, falseArg ) +import Distribution.Simple.InstallDirs + ( PathTemplate, toPathTemplate, fromPathTemplate ) +import Distribution.Version + ( Version(Version), anyVersion, thisVersion ) +import Distribution.Package + ( PackageIdentifier, packageName, packageVersion, Dependency(..) ) +import Distribution.Text + ( Text(parse), display ) +import Distribution.ReadE + ( ReadE(..), readP_to_E, succeedReadE ) +import qualified Distribution.Compat.ReadP as Parse + ( ReadP, readP_to_S, char, munch1, pfail, (+++) ) +import Distribution.Verbosity + ( Verbosity, normal ) +import Distribution.Simple.Utils + ( wrapText ) + +import Data.Char + ( isSpace, isAlphaNum ) +import Data.Maybe + ( listToMaybe, maybeToList, fromMaybe ) +import Data.Monoid + ( Monoid(..) ) +import Control.Monad + ( liftM ) +import System.FilePath + ( () ) +import Network.URI + ( parseAbsoluteURI, uriToString ) + +-- ------------------------------------------------------------ +-- * Global flags +-- ------------------------------------------------------------ + +-- | Flags that apply at the top level, not to any sub-command. +data GlobalFlags = GlobalFlags { + globalVersion :: Flag Bool, + globalNumericVersion :: Flag Bool, + globalConfigFile :: Flag FilePath, + globalRemoteRepos :: [RemoteRepo], -- ^ Available Hackage servers. + globalCacheDir :: Flag FilePath, + globalLocalRepos :: [FilePath], + globalLogsDir :: Flag FilePath, + globalWorldFile :: Flag FilePath + } + +defaultGlobalFlags :: GlobalFlags +defaultGlobalFlags = GlobalFlags { + globalVersion = Flag False, + globalNumericVersion = Flag False, + globalConfigFile = mempty, + globalRemoteRepos = [], + globalCacheDir = mempty, + globalLocalRepos = mempty, + globalLogsDir = mempty, + globalWorldFile = mempty + } + +globalCommand :: CommandUI GlobalFlags +globalCommand = CommandUI { + commandName = "", + commandSynopsis = "", + commandUsage = \_ -> + "This program is the command line interface " + ++ "to the Haskell Cabal infrastructure.\n" + ++ "See http://www.haskell.org/cabal/ for more information.\n", + commandDescription = Just $ \pname -> + "For more information about a command use:\n" + ++ " " ++ pname ++ " COMMAND --help\n\n" + ++ "To install Cabal packages from hackage use:\n" + ++ " " ++ pname ++ " install foo [--dry-run]\n\n" + ++ "Occasionally you need to update the list of available packages:\n" + ++ " " ++ pname ++ " update\n", + commandDefaultFlags = defaultGlobalFlags, + commandOptions = \showOrParseArgs -> + (case showOrParseArgs of ShowArgs -> take 2; ParseArgs -> id) + [option ['V'] ["version"] + "Print version information" + globalVersion (\v flags -> flags { globalVersion = v }) + trueArg + + ,option [] ["numeric-version"] + "Print just the version number" + globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) + trueArg + + ,option [] ["config-file"] + "Set an alternate location for the config file" + globalConfigFile (\v flags -> flags { globalConfigFile = v }) + (reqArgFlag "FILE") + + ,option [] ["remote-repo"] + "The name and url for a remote repository" + globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v }) + (reqArg' "NAME:URL" (maybeToList . readRepo) (map showRepo)) + + ,option [] ["remote-repo-cache"] + "The location where downloads from all remote repos are cached" + globalCacheDir (\v flags -> flags { globalCacheDir = v }) + (reqArgFlag "DIR") + + ,option [] ["local-repo"] + "The location of a local repository" + globalLocalRepos (\v flags -> flags { globalLocalRepos = v }) + (reqArg' "DIR" (\x -> [x]) id) + + ,option [] ["logs-dir"] + "The location to put log files" + globalLogsDir (\v flags -> flags { globalLogsDir = v }) + (reqArgFlag "DIR") + + ,option [] ["world-file"] + "The location of the world file" + globalWorldFile (\v flags -> flags { globalWorldFile = v }) + (reqArgFlag "FILE") + ] + } + +instance Monoid GlobalFlags where + mempty = GlobalFlags { + globalVersion = mempty, + globalNumericVersion = mempty, + globalConfigFile = mempty, + globalRemoteRepos = mempty, + globalCacheDir = mempty, + globalLocalRepos = mempty, + globalLogsDir = mempty, + globalWorldFile = mempty + } + mappend a b = GlobalFlags { + globalVersion = combine globalVersion, + globalNumericVersion = combine globalNumericVersion, + globalConfigFile = combine globalConfigFile, + globalRemoteRepos = combine globalRemoteRepos, + globalCacheDir = combine globalCacheDir, + globalLocalRepos = combine globalLocalRepos, + globalLogsDir = combine globalLogsDir, + globalWorldFile = combine globalWorldFile + } + where combine field = field a `mappend` field b + +globalRepos :: GlobalFlags -> [Repo] +globalRepos globalFlags = remoteRepos ++ localRepos + where + remoteRepos = + [ Repo (Left remote) cacheDir + | remote <- globalRemoteRepos globalFlags + , let cacheDir = fromFlag (globalCacheDir globalFlags) + remoteRepoName remote ] + localRepos = + [ Repo (Right LocalRepo) local + | local <- globalLocalRepos globalFlags ] + +-- ------------------------------------------------------------ +-- * Config flags +-- ------------------------------------------------------------ + +configureCommand :: CommandUI ConfigFlags +configureCommand = (Cabal.configureCommand defaultProgramConfiguration) { + commandDefaultFlags = mempty + } + +configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] +configureOptions = commandOptions configureCommand + +filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags +filterConfigureFlags flags cabalLibVersion + | cabalLibVersion >= Version [1,3,10] [] = flags + -- older Cabal does not grok the constraints flag: + | otherwise = flags { configConstraints = [] } + + +-- ------------------------------------------------------------ +-- * Config extra flags +-- ------------------------------------------------------------ + +-- | cabal configure takes some extra flags beyond runghc Setup configure +-- +data ConfigExFlags = ConfigExFlags { + configCabalVersion :: Flag Version, + configExConstraints:: [UserConstraint], + configPreferences :: [Dependency] + } + +defaultConfigExFlags :: ConfigExFlags +defaultConfigExFlags = mempty + +configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) +configureExCommand = configureCommand { + commandDefaultFlags = (mempty, defaultConfigExFlags), + commandOptions = \showOrParseArgs -> + liftOptions fst setFst (filter ((/="constraint") . optionName) $ + configureOptions showOrParseArgs) + ++ liftOptions snd setSnd (configureExOptions showOrParseArgs) + } + where + setFst a (_,b) = (a,b) + setSnd b (a,_) = (a,b) + +configureExOptions :: ShowOrParseArgs -> [OptionField ConfigExFlags] +configureExOptions _showOrParseArgs = + [ option [] ["cabal-lib-version"] + ("Select which version of the Cabal lib to use to build packages " + ++ "(useful for testing).") + configCabalVersion (\v flags -> flags { configCabalVersion = v }) + (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++) + (fmap toFlag parse)) + (map display . flagToList)) + , option [] ["constraint"] + "Specify constraints on a package (version, installed/source, flags)" + configExConstraints (\v flags -> flags { configExConstraints = v }) + (reqArg "CONSTRAINT" + (fmap (\x -> [x]) (ReadE readUserConstraint)) + (map display)) + + , option [] ["preference"] + "Specify preferences (soft constraints) on the version of a package" + configPreferences (\v flags -> flags { configPreferences = v }) + (reqArg "CONSTRAINT" + (readP_to_E (const "dependency expected") + (fmap (\x -> [x]) parse)) + (map display)) + ] + +instance Monoid ConfigExFlags where + mempty = ConfigExFlags { + configCabalVersion = mempty, + configExConstraints= mempty, + configPreferences = mempty + } + mappend a b = ConfigExFlags { + configCabalVersion = combine configCabalVersion, + configExConstraints= combine configExConstraints, + configPreferences = combine configPreferences + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Fetch command +-- ------------------------------------------------------------ + +data FetchFlags = FetchFlags { +-- fetchOutput :: Flag FilePath, + fetchDeps :: Flag Bool, + fetchDryRun :: Flag Bool, + fetchVerbosity :: Flag Verbosity + } + +defaultFetchFlags :: FetchFlags +defaultFetchFlags = FetchFlags { +-- fetchOutput = mempty, + fetchDeps = toFlag True, + fetchDryRun = toFlag False, + fetchVerbosity = toFlag normal + } + +fetchCommand :: CommandUI FetchFlags +fetchCommand = CommandUI { + commandName = "fetch", + commandSynopsis = "Downloads packages for later installation.", + commandDescription = Nothing, + commandUsage = usagePackages "fetch", + commandDefaultFlags = defaultFetchFlags, + commandOptions = \_ -> [ + optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v }) + +-- , option "o" ["output"] +-- "Put the package(s) somewhere specific rather than the usual cache." +-- fetchOutput (\v flags -> flags { fetchOutput = v }) +-- (reqArgFlag "PATH") + + , option [] ["dependencies", "deps"] + "Resolve and fetch dependencies (default)" + fetchDeps (\v flags -> flags { fetchDeps = v }) + trueArg + + , option [] ["no-dependencies", "no-deps"] + "Ignore dependencies" + fetchDeps (\v flags -> flags { fetchDeps = v }) + falseArg + + , option [] ["dry-run"] + "Do not install anything, only print what would be installed." + fetchDryRun (\v flags -> flags { fetchDryRun = v }) + trueArg + ] + } + +-- ------------------------------------------------------------ +-- * Other commands +-- ------------------------------------------------------------ + +updateCommand :: CommandUI (Flag Verbosity) +updateCommand = CommandUI { + commandName = "update", + commandSynopsis = "Updates list of known packages", + commandDescription = Nothing, + commandUsage = usagePackages "update", + commandDefaultFlags = toFlag normal, + commandOptions = \_ -> [optionVerbosity id const] + } + +upgradeCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags) +upgradeCommand = configureCommand { + commandName = "upgrade", + commandSynopsis = "(command disabled, use install instead)", + commandDescription = Nothing, + commandUsage = usagePackages "upgrade", + commandDefaultFlags = (mempty, mempty, mempty), + commandOptions = commandOptions installCommand + } + +{- +cleanCommand :: CommandUI () +cleanCommand = makeCommand name shortDesc longDesc emptyFlags options + where + name = "clean" + shortDesc = "Removes downloaded files" + longDesc = Nothing + emptyFlags = () + options _ = [] +-} + +checkCommand :: CommandUI (Flag Verbosity) +checkCommand = CommandUI { + commandName = "check", + commandSynopsis = "Check the package for common mistakes", + commandDescription = Nothing, + commandUsage = \pname -> "Usage: " ++ pname ++ " check\n", + commandDefaultFlags = toFlag normal, + commandOptions = \_ -> [] + } + +-- ------------------------------------------------------------ +-- * Report flags +-- ------------------------------------------------------------ + +data ReportFlags = ReportFlags { + reportUsername :: Flag Username, + reportPassword :: Flag Password, + reportVerbosity :: Flag Verbosity + } + +defaultReportFlags :: ReportFlags +defaultReportFlags = ReportFlags { + reportUsername = mempty, + reportPassword = mempty, + reportVerbosity = toFlag normal + } + +reportCommand :: CommandUI ReportFlags +reportCommand = CommandUI { + commandName = "report", + commandSynopsis = "Upload build reports to a remote server.", + commandDescription = Just $ \_ -> + "You can store your Hackage login in the ~/.cabal/config file\n", + commandUsage = \pname -> "Usage: " ++ pname ++ " report [FLAGS]\n\n" + ++ "Flags for upload:", + commandDefaultFlags = defaultReportFlags, + commandOptions = \_ -> + [optionVerbosity reportVerbosity (\v flags -> flags { reportVerbosity = v }) + + ,option ['u'] ["username"] + "Hackage username." + reportUsername (\v flags -> flags { reportUsername = v }) + (reqArg' "USERNAME" (toFlag . Username) + (flagToList . fmap unUsername)) + + ,option ['p'] ["password"] + "Hackage password." + reportPassword (\v flags -> flags { reportPassword = v }) + (reqArg' "PASSWORD" (toFlag . Password) + (flagToList . fmap unPassword)) + ] + } + +instance Monoid ReportFlags where + mempty = ReportFlags { + reportUsername = mempty, + reportPassword = mempty, + reportVerbosity = mempty + } + mappend a b = ReportFlags { + reportUsername = combine reportUsername, + reportPassword = combine reportPassword, + reportVerbosity = combine reportVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Unpack flags +-- ------------------------------------------------------------ + +data UnpackFlags = UnpackFlags { + unpackDestDir :: Flag FilePath, + unpackVerbosity :: Flag Verbosity + } + +defaultUnpackFlags :: UnpackFlags +defaultUnpackFlags = UnpackFlags { + unpackDestDir = mempty, + unpackVerbosity = toFlag normal + } + +unpackCommand :: CommandUI UnpackFlags +unpackCommand = CommandUI { + commandName = "unpack", + commandSynopsis = "Unpacks packages for user inspection.", + commandDescription = Nothing, + commandUsage = usagePackages "unpack", + commandDefaultFlags = mempty, + commandOptions = \_ -> [ + optionVerbosity unpackVerbosity (\v flags -> flags { unpackVerbosity = v }) + + ,option "d" ["destdir"] + "where to unpack the packages, defaults to the current directory." + unpackDestDir (\v flags -> flags { unpackDestDir = v }) + (reqArgFlag "PATH") + ] + } + +instance Monoid UnpackFlags where + mempty = defaultUnpackFlags + mappend a b = UnpackFlags { + unpackDestDir = combine unpackDestDir + ,unpackVerbosity = combine unpackVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * List flags +-- ------------------------------------------------------------ + +data ListFlags = ListFlags { + listInstalled :: Flag Bool, + listSimpleOutput :: Flag Bool, + listVerbosity :: Flag Verbosity + } + +defaultListFlags :: ListFlags +defaultListFlags = ListFlags { + listInstalled = Flag False, + listSimpleOutput = Flag False, + listVerbosity = toFlag normal + } + +listCommand :: CommandUI ListFlags +listCommand = CommandUI { + commandName = "list", + commandSynopsis = "List packages matching a search string.", + commandDescription = Nothing, + commandUsage = usagePackages "list", + commandDefaultFlags = defaultListFlags, + commandOptions = \_ -> [ + optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v }) + + , option [] ["installed"] + "Only print installed packages" + listInstalled (\v flags -> flags { listInstalled = v }) + trueArg + + , option [] ["simple-output"] + "Print in a easy-to-parse format" + listSimpleOutput (\v flags -> flags { listSimpleOutput = v }) + trueArg + + ] + } + +instance Monoid ListFlags where + mempty = defaultListFlags + mappend a b = ListFlags { + listInstalled = combine listInstalled, + listSimpleOutput = combine listSimpleOutput, + listVerbosity = combine listVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Info flags +-- ------------------------------------------------------------ + +data InfoFlags = InfoFlags { + infoVerbosity :: Flag Verbosity + } + +defaultInfoFlags :: InfoFlags +defaultInfoFlags = InfoFlags { + infoVerbosity = toFlag normal + } + +infoCommand :: CommandUI InfoFlags +infoCommand = CommandUI { + commandName = "info", + commandSynopsis = "Display detailed information about a particular package.", + commandDescription = Nothing, + commandUsage = usagePackages "info", + commandDefaultFlags = defaultInfoFlags, + commandOptions = \_ -> [ + optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v }) + ] + } + +instance Monoid InfoFlags where + mempty = defaultInfoFlags + mappend a b = InfoFlags { + infoVerbosity = combine infoVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Install flags +-- ------------------------------------------------------------ + +-- | Install takes the same flags as configure along with a few extras. +-- +data InstallFlags = InstallFlags { + installDocumentation:: Flag Bool, + installHaddockIndex :: Flag PathTemplate, + installDryRun :: Flag Bool, + installReinstall :: Flag Bool, + installUpgradeDeps :: Flag Bool, + installOnly :: Flag Bool, + installOnlyDeps :: Flag Bool, + installRootCmd :: Flag String, + installSummaryFile :: [PathTemplate], + installLogFile :: Flag PathTemplate, + installBuildReports :: Flag ReportLevel, + installSymlinkBinDir:: Flag FilePath, + installOneShot :: Flag Bool + } + +defaultInstallFlags :: InstallFlags +defaultInstallFlags = InstallFlags { + installDocumentation= Flag False, + installHaddockIndex = Flag docIndexFile, + installDryRun = Flag False, + installReinstall = Flag False, + installUpgradeDeps = Flag False, + installOnly = Flag False, + installOnlyDeps = Flag False, + installRootCmd = mempty, + installSummaryFile = mempty, + installLogFile = mempty, + installBuildReports = Flag NoReports, + installSymlinkBinDir= mempty, + installOneShot = Flag False + } + where + docIndexFile = toPathTemplate ("$datadir" "doc" "index.html") + +installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags) +installCommand = CommandUI { + commandName = "install", + commandSynopsis = "Installs a list of packages.", + commandUsage = usagePackages "install", + commandDescription = Just $ \pname -> + let original = case commandDescription configureCommand of + Just desc -> desc pname ++ "\n" + Nothing -> "" + in original + ++ "Examples:\n" + ++ " " ++ pname ++ " install " + ++ " Package in the current directory\n" + ++ " " ++ pname ++ " install foo " + ++ " Package from the hackage server\n" + ++ " " ++ pname ++ " install foo-1.0 " + ++ " Specific version of a package\n" + ++ " " ++ pname ++ " install 'foo < 2' " + ++ " Constrained package version\n", + commandDefaultFlags = (mempty, mempty, mempty), + commandOptions = \showOrParseArgs -> + liftOptions get1 set1 (filter ((/="constraint") . optionName) $ + configureOptions showOrParseArgs) + ++ liftOptions get2 set2 (configureExOptions showOrParseArgs) + ++ liftOptions get3 set3 (installOptions showOrParseArgs) + } + where + get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c) + get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c) + get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c) + +installOptions :: ShowOrParseArgs -> [OptionField InstallFlags] +installOptions showOrParseArgs = + [ option "" ["documentation"] + "building of documentation" + installDocumentation (\v flags -> flags { installDocumentation = v }) + (boolOpt [] []) + + , option [] ["doc-index-file"] + "A central index of haddock API documentation (template cannot use $pkgid)" + installHaddockIndex (\v flags -> flags { installHaddockIndex = v }) + (reqArg' "TEMPLATE" (toFlag.toPathTemplate) + (flagToList . fmap fromPathTemplate)) + + , option [] ["dry-run"] + "Do not install anything, only print what would be installed." + installDryRun (\v flags -> flags { installDryRun = v }) + trueArg + + , option [] ["reinstall"] + "Install even if it means installing the same version again." + installReinstall (\v flags -> flags { installReinstall = v }) + trueArg + + , option [] ["upgrade-dependencies"] + "Pick the latest version for all dependencies, rather than trying to pick an installed version." + installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v }) + trueArg + + + , option [] ["only-dependencies"] + "Install only the dependencies necessary to build the given packages" + installOnlyDeps (\v flags -> flags { installOnlyDeps = v }) + trueArg + + + , option [] ["root-cmd"] + "Command used to gain root privileges, when installing with --global." + installRootCmd (\v flags -> flags { installRootCmd = v }) + (reqArg' "COMMAND" toFlag flagToList) + + , option [] ["symlink-bindir"] + "Add symlinks to installed executables into this directory." + installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v }) + (reqArgFlag "DIR") + + , option [] ["build-summary"] + "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)" + installSummaryFile (\v flags -> flags { installSummaryFile = v }) + (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) (map fromPathTemplate)) + + , option [] ["build-log"] + "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)" + installLogFile (\v flags -> flags { installLogFile = v }) + (reqArg' "TEMPLATE" (toFlag.toPathTemplate) + (flagToList . fmap fromPathTemplate)) + + , option [] ["remote-build-reporting"] + "Generate build reports to send to a remote server (none, anonymous or detailed)." + installBuildReports (\v flags -> flags { installBuildReports = v }) + (reqArg "LEVEL" (readP_to_E (const $ "report level must be 'none', " + ++ "'anonymous' or 'detailed'") + (toFlag `fmap` parse)) + (flagToList . fmap display)) + + , option [] ["one-shot"] + "Do not record the packages in the world file." + installOneShot (\v flags -> flags { installOneShot = v }) + trueArg + ] ++ case showOrParseArgs of -- TODO: remove when "cabal install" avoids + ParseArgs -> + option [] ["only"] + "Only installs the package in the current directory." + installOnly (\v flags -> flags { installOnly = v }) + trueArg + : [] + _ -> [] + +instance Monoid InstallFlags where + mempty = InstallFlags { + installDocumentation= mempty, + installHaddockIndex = mempty, + installDryRun = mempty, + installReinstall = mempty, + installUpgradeDeps = mempty, + installOnly = mempty, + installOnlyDeps = mempty, + installRootCmd = mempty, + installSummaryFile = mempty, + installLogFile = mempty, + installBuildReports = mempty, + installSymlinkBinDir= mempty, + installOneShot = mempty + } + mappend a b = InstallFlags { + installDocumentation= combine installDocumentation, + installHaddockIndex = combine installHaddockIndex, + installDryRun = combine installDryRun, + installReinstall = combine installReinstall, + installUpgradeDeps = combine installUpgradeDeps, + installOnly = combine installOnly, + installOnlyDeps = combine installOnlyDeps, + installRootCmd = combine installRootCmd, + installSummaryFile = combine installSummaryFile, + installLogFile = combine installLogFile, + installBuildReports = combine installBuildReports, + installSymlinkBinDir= combine installSymlinkBinDir, + installOneShot = combine installOneShot + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Upload flags +-- ------------------------------------------------------------ + +data UploadFlags = UploadFlags { + uploadCheck :: Flag Bool, + uploadUsername :: Flag Username, + uploadPassword :: Flag Password, + uploadVerbosity :: Flag Verbosity + } + +defaultUploadFlags :: UploadFlags +defaultUploadFlags = UploadFlags { + uploadCheck = toFlag False, + uploadUsername = mempty, + uploadPassword = mempty, + uploadVerbosity = toFlag normal + } + +uploadCommand :: CommandUI UploadFlags +uploadCommand = CommandUI { + commandName = "upload", + commandSynopsis = "Uploads source packages to Hackage", + commandDescription = Just $ \_ -> + "You can store your Hackage login in the ~/.cabal/config file\n", + commandUsage = \pname -> + "Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n" + ++ "Flags for upload:", + commandDefaultFlags = defaultUploadFlags, + commandOptions = \_ -> + [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v }) + + ,option ['c'] ["check"] + "Do not upload, just do QA checks." + uploadCheck (\v flags -> flags { uploadCheck = v }) + trueArg + + ,option ['u'] ["username"] + "Hackage username." + uploadUsername (\v flags -> flags { uploadUsername = v }) + (reqArg' "USERNAME" (toFlag . Username) + (flagToList . fmap unUsername)) + + ,option ['p'] ["password"] + "Hackage password." + uploadPassword (\v flags -> flags { uploadPassword = v }) + (reqArg' "PASSWORD" (toFlag . Password) + (flagToList . fmap unPassword)) + ] + } + +instance Monoid UploadFlags where + mempty = UploadFlags { + uploadCheck = mempty, + uploadUsername = mempty, + uploadPassword = mempty, + uploadVerbosity = mempty + } + mappend a b = UploadFlags { + uploadCheck = combine uploadCheck, + uploadUsername = combine uploadUsername, + uploadPassword = combine uploadPassword, + uploadVerbosity = combine uploadVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Init flags +-- ------------------------------------------------------------ + +emptyInitFlags :: IT.InitFlags +emptyInitFlags = mempty + +defaultInitFlags :: IT.InitFlags +defaultInitFlags = emptyInitFlags + +initCommand :: CommandUI IT.InitFlags +initCommand = CommandUI { + commandName = "init", + commandSynopsis = "Interactively create a .cabal file.", + commandDescription = Just $ \_ -> wrapText $ + "Cabalise a project by creating a .cabal, Setup.hs, and " + ++ "optionally a LICENSE file.\n\n" + ++ "Calling init with no arguments (recommended) uses an " + ++ "interactive mode, which will try to guess as much as " + ++ "possible and prompt you for the rest. Command-line " + ++ "arguments are provided for scripting purposes. " + ++ "If you don't want interactive mode, be sure to pass " + ++ "the -n flag.\n", + commandUsage = \pname -> + "Usage: " ++ pname ++ " init [FLAGS]\n\n" + ++ "Flags for init:", + commandDefaultFlags = defaultInitFlags, + commandOptions = \_ -> + [ option ['n'] ["non-interactive"] + "Non-interactive mode." + IT.nonInteractive (\v flags -> flags { IT.nonInteractive = v }) + trueArg + + , option ['q'] ["quiet"] + "Do not generate log messages to stdout." + IT.quiet (\v flags -> flags { IT.quiet = v }) + trueArg + + , option [] ["no-comments"] + "Do not generate explanatory comments in the .cabal file." + IT.noComments (\v flags -> flags { IT.noComments = v }) + trueArg + + , option ['m'] ["minimal"] + "Generate a minimal .cabal file, that is, do not include extra empty fields. Also implies --no-comments." + IT.minimal (\v flags -> flags { IT.minimal = v }) + trueArg + + , option [] ["package-dir"] + "Root directory of the package (default = current directory)." + IT.packageDir (\v flags -> flags { IT.packageDir = v }) + (reqArgFlag "DIRECTORY") + + , option ['p'] ["package-name"] + "Name of the Cabal package to create." + IT.packageName (\v flags -> flags { IT.packageName = v }) + (reqArgFlag "PACKAGE") + + , option [] ["version"] + "Initial version of the package." + IT.version (\v flags -> flags { IT.version = v }) + (reqArg "VERSION" (readP_to_E ("Cannot parse package version: "++) + (toFlag `fmap` parse)) + (flagToList . fmap display)) + + , option [] ["cabal-version"] + "Required version of the Cabal library." + IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v }) + (reqArg "VERSION_RANGE" (readP_to_E ("Cannot parse Cabal version range: "++) + (toFlag `fmap` parse)) + (flagToList . fmap display)) + + , option ['l'] ["license"] + "Project license." + IT.license (\v flags -> flags { IT.license = v }) + (reqArg "LICENSE" (readP_to_E ("Cannot parse license: "++) + (toFlag `fmap` parse)) + (flagToList . fmap display)) + + , option ['a'] ["author"] + "Name of the project's author." + IT.author (\v flags -> flags { IT.author = v }) + (reqArgFlag "NAME") + + , option ['e'] ["email"] + "Email address of the maintainer." + IT.email (\v flags -> flags { IT.email = v }) + (reqArgFlag "EMAIL") + + , option ['u'] ["homepage"] + "Project homepage and/or repository." + IT.homepage (\v flags -> flags { IT.homepage = v }) + (reqArgFlag "URL") + + , option ['s'] ["synopsis"] + "Short project synopsis." + IT.synopsis (\v flags -> flags { IT.synopsis = v }) + (reqArgFlag "TEXT") + + , option ['c'] ["category"] + "Project category." + IT.category (\v flags -> flags { IT.category = v }) + (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s)) + (flagToList . fmap (either id show))) + + , option [] ["is-library"] + "Build a library." + IT.packageType (\v flags -> flags { IT.packageType = v }) + (noArg (Flag IT.Library)) + + , option [] ["is-executable"] + "Build an executable." + IT.packageType + (\v flags -> flags { IT.packageType = v }) + (noArg (Flag IT.Executable)) + + , option ['o'] ["expose-module"] + "Export a module from the package." + IT.exposedModules + (\v flags -> flags { IT.exposedModules = v }) + (reqArg "MODULE" (readP_to_E ("Cannot parse module name: "++) + ((Just . (:[])) `fmap` parse)) + (fromMaybe [] . fmap (fmap display))) + + , option ['d'] ["dependency"] + "Package dependency." + IT.dependencies (\v flags -> flags { IT.dependencies = v }) + (reqArg "PACKAGE" (readP_to_E ("Cannot parse dependency: "++) + ((Just . (:[])) `fmap` parse)) + (fromMaybe [] . fmap (fmap display))) + + , option [] ["source-dir"] + "Directory containing package source." + IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v }) + (reqArg' "DIR" (Just . (:[])) + (fromMaybe [])) + + , option [] ["build-tool"] + "Required external build tool." + IT.buildTools (\v flags -> flags { IT.buildTools = v }) + (reqArg' "TOOL" (Just . (:[])) + (fromMaybe [])) + ] + } + where readMaybe s = case reads s of + [(x,"")] -> Just x + _ -> Nothing + +-- ------------------------------------------------------------ +-- * GetOpt Utils +-- ------------------------------------------------------------ + +boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a +boolOpt = Command.boolOpt flagToMaybe Flag + +reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description -> + (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b +reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList + +liftOptions :: (b -> a) -> (a -> b -> b) + -> [OptionField a] -> [OptionField b] +liftOptions get set = map (liftOption get set) + +usagePackages :: String -> String -> String +usagePackages name pname = + "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n" + ++ " or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n" + ++ "Flags for " ++ name ++ ":" + +--TODO: do we want to allow per-package flags? +parsePackageArgs :: [String] -> Either String [Dependency] +parsePackageArgs = parsePkgArgs [] + where + parsePkgArgs ds [] = Right (reverse ds) + parsePkgArgs ds (arg:args) = + case readPToMaybe parseDependencyOrPackageId arg of + Just dep -> parsePkgArgs (dep:ds) args + Nothing -> Left $ + show arg ++ " is not valid syntax for a package name or" + ++ " package dependency." + +readPToMaybe :: Parse.ReadP a a -> String -> Maybe a +readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str + , all isSpace s ] + +parseDependencyOrPackageId :: Parse.ReadP r Dependency +parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse + where + pkgidToDependency :: PackageIdentifier -> Dependency + pkgidToDependency p = case packageVersion p of + Version [] _ -> Dependency (packageName p) anyVersion + version -> Dependency (packageName p) (thisVersion version) + +showRepo :: RemoteRepo -> String +showRepo repo = remoteRepoName repo ++ ":" + ++ uriToString id (remoteRepoURI repo) [] + +readRepo :: String -> Maybe RemoteRepo +readRepo = readPToMaybe parseRepo + +parseRepo :: Parse.ReadP r RemoteRepo +parseRepo = do + name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.") + _ <- Parse.char ':' + uriStr <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~") + uri <- maybe Parse.pfail return (parseAbsoluteURI uriStr) + return $ RemoteRepo { + remoteRepoName = name, + remoteRepoURI = uri + } diff --git a/cabal/cabal-install/Distribution/Client/SetupWrapper.hs b/cabal/cabal-install/Distribution/Client/SetupWrapper.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/SetupWrapper.hs @@ -0,0 +1,320 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.SetupWrapper +-- Copyright : (c) The University of Glasgow 2006, +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : alpha +-- Portability : portable +-- +-- An interface to building and installing Cabal packages. +-- If the @Built-Type@ field is specified as something other than +-- 'Custom', and the current version of Cabal is acceptable, this performs +-- setup actions directly. Otherwise it builds the setup script and +-- runs it with the given arguments. + +module Distribution.Client.SetupWrapper ( + setupWrapper, + SetupScriptOptions(..), + defaultSetupScriptOptions, + ) where + +import Distribution.Client.Types + ( InstalledPackage ) + +import qualified Distribution.Make as Make +import qualified Distribution.Simple as Simple +import Distribution.Version + ( Version(..), VersionRange, anyVersion + , intersectVersionRanges, orLaterVersion + , withinRange ) +import Distribution.Package + ( PackageIdentifier(..), PackageName(..), Package(..), packageName + , packageVersion, Dependency(..) ) +import Distribution.PackageDescription + ( GenericPackageDescription(packageDescription) + , PackageDescription(..), specVersion, BuildType(..) ) +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.Simple.Configure + ( configCompiler ) +import Distribution.Simple.Compiler + ( CompilerFlavor(GHC), Compiler, PackageDB(..), PackageDBStack ) +import Distribution.Simple.Program + ( ProgramConfiguration, emptyProgramConfiguration + , rawSystemProgramConf, ghcProgram ) +import Distribution.Simple.BuildPaths + ( defaultDistPref, exeExtension ) +import Distribution.Simple.Command + ( CommandUI(..), commandShowOptions ) +import Distribution.Simple.GHC + ( ghcVerbosityOptions ) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.PackageIndex (PackageIndex) +import Distribution.Client.IndexUtils + ( getInstalledPackages ) +import Distribution.Simple.Utils + ( die, debug, info, cabalVersion, findPackageDesc, comparing + , createDirectoryIfMissingVerbose, rewriteFile ) +import Distribution.Client.Utils + ( moreRecentFile, inDir ) +import Distribution.Text + ( display ) +import Distribution.Verbosity + ( Verbosity ) + +import System.Directory ( doesFileExist, getCurrentDirectory ) +import System.FilePath ( (), (<.>) ) +import System.IO ( Handle ) +import System.Exit ( ExitCode(..), exitWith ) +import System.Process ( runProcess, waitForProcess ) +import Control.Monad ( when, unless ) +import Data.List ( maximumBy ) +import Data.Maybe ( fromMaybe, isJust ) +import Data.Char ( isSpace ) + +data SetupScriptOptions = SetupScriptOptions { + useCabalVersion :: VersionRange, + useCompiler :: Maybe Compiler, + usePackageDB :: PackageDBStack, + usePackageIndex :: Maybe (PackageIndex InstalledPackage), + useProgramConfig :: ProgramConfiguration, + useDistPref :: FilePath, + useLoggingHandle :: Maybe Handle, + useWorkingDir :: Maybe FilePath + } + +defaultSetupScriptOptions :: SetupScriptOptions +defaultSetupScriptOptions = SetupScriptOptions { + useCabalVersion = anyVersion, + useCompiler = Nothing, + usePackageDB = [GlobalPackageDB, UserPackageDB], + usePackageIndex = Nothing, + useProgramConfig = emptyProgramConfiguration, + useDistPref = defaultDistPref, + useLoggingHandle = Nothing, + useWorkingDir = Nothing + } + +setupWrapper :: Verbosity + -> SetupScriptOptions + -> Maybe PackageDescription + -> CommandUI flags + -> (Version -> flags) + -> [String] + -> IO () +setupWrapper verbosity options mpkg cmd flags extraArgs = do + pkg <- maybe getPkg return mpkg + let setupMethod = determineSetupMethod options' buildType' + options' = options { + useCabalVersion = intersectVersionRanges + (useCabalVersion options) + (orLaterVersion (specVersion pkg)) + } + buildType' = fromMaybe Custom (buildType pkg) + mkArgs cabalLibVersion = commandName cmd + : commandShowOptions cmd (flags cabalLibVersion) + ++ extraArgs + setupMethod verbosity options' (packageId pkg) buildType' mkArgs + where + getPkg = findPackageDesc (fromMaybe "." (useWorkingDir options)) + >>= readPackageDescription verbosity + >>= return . packageDescription + +-- | Decide if we're going to be able to do a direct internal call to the +-- entry point in the Cabal library or if we're going to have to compile +-- and execute an external Setup.hs script. +-- +determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod +determineSetupMethod options buildType' + | isJust (useLoggingHandle options) + || buildType' == Custom = externalSetupMethod + | cabalVersion `withinRange` + useCabalVersion options = internalSetupMethod + | otherwise = externalSetupMethod + +type SetupMethod = Verbosity + -> SetupScriptOptions + -> PackageIdentifier + -> BuildType + -> (Version -> [String]) -> IO () + +-- ------------------------------------------------------------ +-- * Internal SetupMethod +-- ------------------------------------------------------------ + +internalSetupMethod :: SetupMethod +internalSetupMethod verbosity options _ bt mkargs = do + let args = mkargs cabalVersion + debug verbosity $ "Using internal setup method with build-type " ++ show bt + ++ " and args:\n " ++ show args + inDir (useWorkingDir options) $ + buildTypeAction bt args + +buildTypeAction :: BuildType -> ([String] -> IO ()) +buildTypeAction Simple = Simple.defaultMainArgs +buildTypeAction Configure = Simple.defaultMainWithHooksArgs + Simple.autoconfUserHooks +buildTypeAction Make = Make.defaultMainArgs +buildTypeAction Custom = error "buildTypeAction Custom" +buildTypeAction (UnknownBuildType _) = error "buildTypeAction UnknownBuildType" + +-- ------------------------------------------------------------ +-- * External SetupMethod +-- ------------------------------------------------------------ + +externalSetupMethod :: SetupMethod +externalSetupMethod verbosity options pkg bt mkargs = do + debug verbosity $ "Using external setup method with build-type " ++ show bt + createDirectoryIfMissingVerbose verbosity True setupDir + (cabalLibVersion, options') <- cabalLibVersionToUse + debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion + setupHs <- updateSetupScript cabalLibVersion bt + debug verbosity $ "Using " ++ setupHs ++ " as setup script." + compileSetupExecutable options' cabalLibVersion setupHs + invokeSetupScript (mkargs cabalLibVersion) + + where + workingDir = case fromMaybe "" (useWorkingDir options) of + [] -> "." + dir -> dir + setupDir = workingDir useDistPref options "setup" + setupVersionFile = setupDir "setup" <.> "version" + setupProgFile = setupDir "setup" <.> exeExtension + + cabalLibVersionToUse :: IO (Version, SetupScriptOptions) + cabalLibVersionToUse = do + savedVersion <- savedCabalVersion + case savedVersion of + Just version | version `withinRange` useCabalVersion options + -> return (version, options) + _ -> do (comp, conf, options') <- configureCompiler options + version <- installedCabalVersion options comp conf + writeFile setupVersionFile (show version ++ "\n") + return (version, options') + + savedCabalVersion = do + versionString <- readFile setupVersionFile `catch` \_ -> return "" + case reads versionString of + [(version,s)] | all isSpace s -> return (Just version) + _ -> return Nothing + + installedCabalVersion :: SetupScriptOptions -> Compiler + -> ProgramConfiguration -> IO Version + installedCabalVersion _ _ _ | packageName pkg == PackageName "Cabal" = + return (packageVersion pkg) + installedCabalVersion options' comp conf = do + index <- case usePackageIndex options' of + Just index -> return index + Nothing -> getInstalledPackages verbosity + comp (usePackageDB options') conf + + let cabalDep = Dependency (PackageName "Cabal") (useCabalVersion options) + case PackageIndex.lookupDependency index cabalDep of + [] -> die $ "The package requires Cabal library version " + ++ display (useCabalVersion options) + ++ " but no suitable version is installed." + pkgs -> return $ bestVersion (map packageVersion pkgs) + where + bestVersion = maximumBy (comparing preference) + preference version = (sameVersion, sameMajorVersion + ,stableVersion, latestVersion) + where + sameVersion = version == cabalVersion + sameMajorVersion = majorVersion version == majorVersion cabalVersion + majorVersion = take 2 . versionBranch + stableVersion = case versionBranch version of + (_:x:_) -> even x + _ -> False + latestVersion = version + + configureCompiler :: SetupScriptOptions + -> IO (Compiler, ProgramConfiguration, SetupScriptOptions) + configureCompiler options' = do + (comp, conf) <- case useCompiler options' of + Just comp -> return (comp, useProgramConfig options') + Nothing -> configCompiler (Just GHC) Nothing Nothing + (useProgramConfig options') verbosity + return (comp, conf, options' { useCompiler = Just comp, + useProgramConfig = conf }) + + -- | Decide which Setup.hs script to use, creating it if necessary. + -- + updateSetupScript :: Version -> BuildType -> IO FilePath + updateSetupScript _ Custom = do + useHs <- doesFileExist setupHs + useLhs <- doesFileExist setupLhs + unless (useHs || useLhs) $ die + "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script." + return (if useHs then setupHs else setupLhs) + where + setupHs = workingDir "Setup.hs" + setupLhs = workingDir "Setup.lhs" + + updateSetupScript cabalLibVersion _ = do + rewriteFile setupHs (buildTypeScript cabalLibVersion) + return setupHs + where + setupHs = setupDir "setup.hs" + + buildTypeScript :: Version -> String + buildTypeScript cabalLibVersion = case bt of + Simple -> "import Distribution.Simple; main = defaultMain\n" + Configure -> "import Distribution.Simple; main = defaultMainWithHooks " + ++ if cabalLibVersion >= Version [1,3,10] [] + then "autoconfUserHooks\n" + else "defaultUserHooks\n" + Make -> "import Distribution.Make; main = defaultMain\n" + Custom -> error "buildTypeScript Custom" + UnknownBuildType _ -> error "buildTypeScript UnknownBuildType" + + -- | If the Setup.hs is out of date wrt the executable then recompile it. + -- Currently this is GHC only. It should really be generalised. + -- + compileSetupExecutable :: SetupScriptOptions -> Version -> FilePath -> IO () + compileSetupExecutable options' cabalLibVersion setupHsFile = do + setupHsNewer <- setupHsFile `moreRecentFile` setupProgFile + cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile + let outOfDate = setupHsNewer || cabalVersionNewer + when outOfDate $ do + debug verbosity "Setup script is out of date, compiling..." + (_, conf, _) <- configureCompiler options' + --TODO: get Cabal's GHC module to export a GhcOptions type and render func + rawSystemProgramConf verbosity ghcProgram conf $ + ghcVerbosityOptions verbosity + ++ ["--make", setupHsFile, "-o", setupProgFile + ,"-odir", setupDir, "-hidir", setupDir + ,"-i", "-i" ++ workingDir ] + ++ ghcPackageDbOptions (usePackageDB options') + ++ if packageName pkg == PackageName "Cabal" + then [] + else ["-package", display cabalPkgid] + where + cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion + + ghcPackageDbOptions :: PackageDBStack -> [String] + ghcPackageDbOptions dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs + (GlobalPackageDB:dbs) -> "-no-user-package-conf" + : concatMap specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = [ "-package-conf", db ] + specific _ = ierror + ierror = error "internal error: unexpected package db stack" + + + invokeSetupScript :: [String] -> IO () + invokeSetupScript args = do + info verbosity $ unwords (setupProgFile : args) + case useLoggingHandle options of + Nothing -> return () + Just logHandle -> info verbosity $ "Redirecting build log to " + ++ show logHandle + currentDir <- getCurrentDirectory + process <- runProcess (currentDir setupProgFile) args + (useWorkingDir options) Nothing + Nothing (useLoggingHandle options) (useLoggingHandle options) + exitCode <- waitForProcess process + unless (exitCode == ExitSuccess) $ exitWith exitCode diff --git a/cabal/cabal-install/Distribution/Client/SrcDist.hs b/cabal/cabal-install/Distribution/Client/SrcDist.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/SrcDist.hs @@ -0,0 +1,80 @@ +-- Implements the \"@.\/cabal sdist@\" command, which creates a source +-- distribution for this package. That is, packs up the source code +-- into a tarball, making use of the corresponding Cabal module. +module Distribution.Client.SrcDist ( + sdist + ) where +import Distribution.Simple.SrcDist + ( printPackageProblems, prepareTree + , prepareSnapshotTree, snapshotPackage ) +import Distribution.Client.Tar (createTarGzFile) + +import Distribution.Package + ( Package(..) ) +import Distribution.PackageDescription + ( PackageDescription ) +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.Simple.Utils + ( defaultPackageDesc, warn, notice, setupMessage + , createDirectoryIfMissingVerbose, withTempDirectory ) +import Distribution.Simple.Setup (SDistFlags(..), fromFlag) +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.PreProcess (knownSuffixHandlers) +import Distribution.Simple.BuildPaths ( srcPref) +import Distribution.Simple.Configure(maybeGetPersistBuildConfig) +import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) +import Distribution.Text + ( display ) + +import System.Time (getClockTime, toCalendarTime) +import System.FilePath ((), (<.>)) +import Control.Monad (when) +import Data.Maybe (isNothing) + +-- |Create a source distribution. +sdist :: SDistFlags -> IO () +sdist flags = do + pkg <- return . flattenPackageDescription + =<< readPackageDescription verbosity + =<< defaultPackageDesc verbosity + mb_lbi <- maybeGetPersistBuildConfig distPref + let tmpTargetDir = srcPref distPref + + -- do some QA + printPackageProblems verbosity pkg + + when (isNothing mb_lbi) $ + warn verbosity "Cannot run preprocessors. Run 'configure' command first." + + createDirectoryIfMissingVerbose verbosity True tmpTargetDir + withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do + + date <- toCalendarTime =<< getClockTime + let pkg' | snapshot = snapshotPackage date pkg + | otherwise = pkg + setupMessage verbosity "Building source dist for" (packageId pkg') + + _ <- if snapshot + then prepareSnapshotTree verbosity pkg' mb_lbi distPref tmpDir pps + else prepareTree verbosity pkg' mb_lbi distPref tmpDir pps + targzFile <- createArchive verbosity pkg' tmpDir distPref + notice verbosity $ "Source tarball created: " ++ targzFile + + where + verbosity = fromFlag (sDistVerbosity flags) + snapshot = fromFlag (sDistSnapshot flags) + distPref = fromFlag (sDistDistPref flags) + pps = knownSuffixHandlers + +-- |Create an archive from a tree of source files, and clean up the tree. +createArchive :: Verbosity + -> PackageDescription + -> FilePath + -> FilePath + -> IO FilePath +createArchive _verbosity pkg tmpDir targetPref = do + let tarBallName = display (packageId pkg) + tarBallFilePath = targetPref tarBallName <.> "tar.gz" + createTarGzFile tarBallFilePath tmpDir tarBallName + return tarBallFilePath diff --git a/cabal/cabal-install/Distribution/Client/Tar.hs b/cabal/cabal-install/Distribution/Client/Tar.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Tar.hs @@ -0,0 +1,903 @@ +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Tar +-- Copyright : (c) 2007 Bjorn Bringert, +-- 2008 Andrea Vezzosi, +-- 2008-2009 Duncan Coutts +-- License : BSD3 +-- +-- Maintainer : duncan@community.haskell.org +-- Portability : portable +-- +-- Reading, writing and manipulating \"@.tar@\" archive files. +-- +----------------------------------------------------------------------------- +module Distribution.Client.Tar ( + -- * High level \"all in one\" operations + createTarGzFile, + extractTarGzFile, + + -- * Converting between internal and external representation + read, + write, + + -- * Packing and unpacking files to\/from internal representation + pack, + unpack, + + -- * Tar entry and associated types + Entry(..), + entryPath, + EntryContent(..), + Ownership(..), + FileSize, + Permissions, + EpochTime, + DevMajor, + DevMinor, + TypeCode, + Format(..), + + -- * Constructing simple entry values + simpleEntry, + fileEntry, + directoryEntry, + + -- * TarPath type + TarPath, + toTarPath, + fromTarPath, + + -- ** Sequences of tar entries + Entries(..), + foldrEntries, + foldlEntries, + unfoldrEntries, + mapEntries, + filterEntries, + entriesIndex, + + ) where + +import Data.Char (ord) +import Data.Int (Int64) +import Data.Bits (Bits, shiftL, testBit) +import Data.List (foldl') +import Numeric (readOct, showOct) +import Control.Monad (MonadPlus(mplus), when) +import qualified Data.Map as Map +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 +import Data.ByteString.Lazy (ByteString) +import qualified Codec.Compression.GZip as GZip +import qualified Distribution.Client.GZipUtils as GZipUtils + +import System.FilePath + ( () ) +import qualified System.FilePath as FilePath.Native +import qualified System.FilePath.Windows as FilePath.Windows +import qualified System.FilePath.Posix as FilePath.Posix +import System.Directory + ( getDirectoryContents, doesDirectoryExist, getModificationTime + , getPermissions, createDirectoryIfMissing, copyFile ) +import qualified System.Directory as Permissions + ( Permissions(executable) ) +import Distribution.Compat.FilePerms + ( setFileExecutable ) +import System.Posix.Types + ( FileMode ) +import System.Time + ( ClockTime(..) ) +import System.IO + ( IOMode(ReadMode), openBinaryFile, hFileSize ) +import System.IO.Unsafe (unsafeInterleaveIO) + +import Prelude hiding (read) + + +-- +-- * High level operations +-- + +createTarGzFile :: FilePath -- ^ Full Tarball path + -> FilePath -- ^ Base directory + -> FilePath -- ^ Directory to archive, relative to base dir + -> IO () +createTarGzFile tar base dir = + BS.writeFile tar . GZip.compress . write =<< pack base [dir] + +extractTarGzFile :: FilePath -- ^ Destination directory + -> FilePath -- ^ Expected subdir (to check for tarbombs) + -> FilePath -- ^ Tarball + -> IO () +extractTarGzFile dir expected tar = do + unpack dir . checkTarbomb expected . read . GZipUtils.maybeDecompress =<< BS.readFile tar + +-- +-- * Entry type +-- + +type FileSize = Int64 +-- | The number of seconds since the UNIX epoch +type EpochTime = Int64 +type DevMajor = Int +type DevMinor = Int +type TypeCode = Char +type Permissions = FileMode + +-- | Tar archive entry. +-- +data Entry = Entry { + + -- | The path of the file or directory within the archive. This is in a + -- tar-specific form. Use 'entryPath' to get a native 'FilePath'. + entryTarPath :: !TarPath, + + -- | The real content of the entry. For 'NormalFile' this includes the + -- file data. An entry usually contains a 'NormalFile' or a 'Directory'. + entryContent :: !EntryContent, + + -- | File permissions (Unix style file mode). + entryPermissions :: !Permissions, + + -- | The user and group to which this file belongs. + entryOwnership :: !Ownership, + + -- | The time the file was last modified. + entryTime :: !EpochTime, + + -- | The tar format the archive is using. + entryFormat :: !Format + } + +-- | Native 'FilePath' of the file or directory within the archive. +-- +entryPath :: Entry -> FilePath +entryPath = fromTarPath . entryTarPath + +-- | The content of a tar archive entry, which depends on the type of entry. +-- +-- Portable archives should contain only 'NormalFile' and 'Directory'. +-- +data EntryContent = NormalFile ByteString !FileSize + | Directory + | SymbolicLink !LinkTarget + | HardLink !LinkTarget + | CharacterDevice !DevMajor !DevMinor + | BlockDevice !DevMajor !DevMinor + | NamedPipe + | OtherEntryType !TypeCode ByteString !FileSize + +data Ownership = Ownership { + -- | The owner user name. Should be set to @\"\"@ if unknown. + ownerName :: String, + + -- | The owner group name. Should be set to @\"\"@ if unknown. + groupName :: String, + + -- | Numeric owner user id. Should be set to @0@ if unknown. + ownerId :: !Int, + + -- | Numeric owner group id. Should be set to @0@ if unknown. + groupId :: !Int + } + +-- | There have been a number of extensions to the tar file format over the +-- years. They all share the basic entry fields and put more meta-data in +-- different extended headers. +-- +data Format = + + -- | This is the classic Unix V7 tar format. It does not support owner and + -- group names, just numeric Ids. It also does not support device numbers. + V7Format + + -- | The \"USTAR\" format is an extension of the classic V7 format. It was + -- later standardised by POSIX. It has some restructions but is the most + -- portable format. + -- + | UstarFormat + + -- | The GNU tar implementation also extends the classic V7 format, though + -- in a slightly different way from the USTAR format. In general for new + -- archives the standard USTAR/POSIX should be used. + -- + | GnuFormat + deriving Eq + +-- | @rw-r--r--@ for normal files +ordinaryFilePermissions :: Permissions +ordinaryFilePermissions = 0o0644 + +-- | @rwxr-xr-x@ for executable files +executableFilePermissions :: Permissions +executableFilePermissions = 0o0755 + +-- | @rwxr-xr-x@ for directories +directoryPermissions :: Permissions +directoryPermissions = 0o0755 + +isExecutable :: Permissions -> Bool +isExecutable p = testBit p 0 || testBit p 6 -- user or other exectuable + +-- | An 'Entry' with all default values except for the file name and type. It +-- uses the portable USTAR/POSIX format (see 'UstarHeader'). +-- +-- You can use this as a basis and override specific fields, eg: +-- +-- > (emptyEntry name HardLink) { linkTarget = target } +-- +simpleEntry :: TarPath -> EntryContent -> Entry +simpleEntry tarpath content = Entry { + entryTarPath = tarpath, + entryContent = content, + entryPermissions = case content of + Directory -> directoryPermissions + _ -> ordinaryFilePermissions, + entryOwnership = Ownership "" "" 0 0, + entryTime = 0, + entryFormat = UstarFormat + } + +-- | A tar 'Entry' for a file. +-- +-- Entry fields such as file permissions and ownership have default values. +-- +-- You can use this as a basis and override specific fields. For example if you +-- need an executable file you could use: +-- +-- > (fileEntry name content) { fileMode = executableFileMode } +-- +fileEntry :: TarPath -> ByteString -> Entry +fileEntry name fileContent = + simpleEntry name (NormalFile fileContent (BS.length fileContent)) + +-- | A tar 'Entry' for a directory. +-- +-- Entry fields such as file permissions and ownership have default values. +-- +directoryEntry :: TarPath -> Entry +directoryEntry name = simpleEntry name Directory + +-- +-- * Tar paths +-- + +-- | The classic tar format allowed just 100 charcters for the file name. The +-- USTAR format extended this with an extra 155 characters, however it uses a +-- complex method of splitting the name between the two sections. +-- +-- Instead of just putting any overflow into the extended area, it uses the +-- extended area as a prefix. The agrevating insane bit however is that the +-- prefix (if any) must only contain a directory prefix. That is the split +-- between the two areas must be on a directory separator boundary. So there is +-- no simple calculation to work out if a file name is too long. Instead we +-- have to try to find a valid split that makes the name fit in the two areas. +-- +-- The rationale presumably was to make it a bit more compatible with old tar +-- programs that only understand the classic format. A classic tar would be +-- able to extract the file name and possibly some dir prefix, but not the +-- full dir prefix. So the files would end up in the wrong place, but that's +-- probably better than ending up with the wrong names too. +-- +-- So it's understandable but rather annoying. +-- +-- * Tar paths use posix format (ie @\'/\'@ directory separators), irrespective +-- of the local path conventions. +-- +-- * The directory separator between the prefix and name is /not/ stored. +-- +data TarPath = TarPath FilePath -- path name, 100 characters max. + FilePath -- path prefix, 155 characters max. + deriving (Eq, Ord) + +-- | Convert a 'TarPath' to a native 'FilePath'. +-- +-- The native 'FilePath' will use the native directory separator but it is not +-- otherwise checked for validity or sanity. In particular: +-- +-- * The tar path may be invalid as a native path, eg the filename @\"nul\"@ is +-- not valid on Windows. +-- +-- * The tar path may be an absolute path or may contain @\"..\"@ components. +-- For security reasons this should not usually be allowed, but it is your +-- responsibility to check for these conditions (eg using 'checkSecurity'). +-- +fromTarPath :: TarPath -> FilePath +fromTarPath (TarPath name prefix) = adjustDirectory $ + FilePath.Native.joinPath $ FilePath.Posix.splitDirectories prefix + ++ FilePath.Posix.splitDirectories name + where + adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name + = FilePath.Native.addTrailingPathSeparator + | otherwise = id + +-- | Convert a native 'FilePath' to a 'TarPath'. +-- +-- The conversion may fail if the 'FilePath' is too long. See 'TarPath' for a +-- description of the problem with splitting long 'FilePath's. +-- +toTarPath :: Bool -- ^ Is the path for a directory? This is needed because for + -- directories a 'TarPath' must always use a trailing @\/@. + -> FilePath -> Either String TarPath +toTarPath isDir = splitLongPath + . addTrailingSep + . FilePath.Posix.joinPath + . FilePath.Native.splitDirectories + where + addTrailingSep | isDir = FilePath.Posix.addTrailingPathSeparator + | otherwise = id + +-- | Take a sanitized path, split on directory separators and try to pack it +-- into the 155 + 100 tar file name format. +-- +-- The stragey is this: take the name-directory components in reverse order +-- and try to fit as many components into the 100 long name area as possible. +-- If all the remaining components fit in the 155 name area then we win. +-- +splitLongPath :: FilePath -> Either String TarPath +splitLongPath path = + case packName nameMax (reverse (FilePath.Posix.splitPath path)) of + Left err -> Left err + Right (name, []) -> Right (TarPath name "") + Right (name, first:rest) -> case packName prefixMax remainder of + Left err -> Left err + Right (_ , (_:_)) -> Left "File name too long (cannot split)" + Right (prefix, []) -> Right (TarPath name prefix) + where + -- drop the '/' between the name and prefix: + remainder = init first : rest + + where + nameMax, prefixMax :: Int + nameMax = 100 + prefixMax = 155 + + packName _ [] = Left "File name empty" + packName maxLen (c:cs) + | n > maxLen = Left "File name too long" + | otherwise = Right (packName' maxLen n [c] cs) + where n = length c + + packName' maxLen n ok (c:cs) + | n' <= maxLen = packName' maxLen n' (c:ok) cs + where n' = n + length c + packName' _ _ ok cs = (FilePath.Posix.joinPath ok, cs) + +-- | The tar format allows just 100 ASCII charcters for the 'SymbolicLink' and +-- 'HardLink' entry types. +-- +newtype LinkTarget = LinkTarget FilePath + deriving (Eq, Ord) + +-- | Convert a tar 'LinkTarget' to a native 'FilePath'. +-- +fromLinkTarget :: LinkTarget -> FilePath +fromLinkTarget (LinkTarget path) = adjustDirectory $ + FilePath.Native.joinPath $ FilePath.Posix.splitDirectories path + where + adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path + = FilePath.Native.addTrailingPathSeparator + | otherwise = id + +-- +-- * Entries type +-- + +-- | A tar archive is a sequence of entries. +data Entries = Next Entry Entries + | Done + | Fail String + +unfoldrEntries :: (a -> Either String (Maybe (Entry, a))) -> a -> Entries +unfoldrEntries f = unfold + where + unfold x = case f x of + Left err -> Fail err + Right Nothing -> Done + Right (Just (e, x')) -> Next e (unfold x') + +foldrEntries :: (Entry -> a -> a) -> a -> (String -> a) -> Entries -> a +foldrEntries next done fail' = fold + where + fold (Next e es) = next e (fold es) + fold Done = done + fold (Fail err) = fail' err + +foldlEntries :: (a -> Entry -> a) -> a -> Entries -> Either String a +foldlEntries f = fold + where + fold a (Next e es) = (fold $! f a e) es + fold a Done = Right a + fold _ (Fail err) = Left err + +mapEntries :: (Entry -> Entry) -> Entries -> Entries +mapEntries f = foldrEntries (Next . f) Done Fail + +filterEntries :: (Entry -> Bool) -> Entries -> Entries +filterEntries p = + foldrEntries + (\entry rest -> if p entry + then Next entry rest + else rest) + Done Fail + +checkEntries :: (Entry -> Maybe String) -> Entries -> Entries +checkEntries checkEntry = + foldrEntries + (\entry rest -> case checkEntry entry of + Nothing -> Next entry rest + Just err -> Fail err) + Done Fail + +entriesIndex :: Entries -> Either String (Map.Map TarPath Entry) +entriesIndex = foldlEntries (\m e -> Map.insert (entryTarPath e) e m) Map.empty + +-- +-- * Checking +-- + +-- | This function checks a sequence of tar entries for file name security +-- problems. It checks that: +-- +-- * file paths are not absolute +-- +-- * file paths do not contain any path components that are \"@..@\" +-- +-- * file names are valid +-- +-- These checks are from the perspective of the current OS. That means we check +-- for \"@C:\blah@\" files on Windows and \"\/blah\" files on unix. For archive +-- entry types 'HardLink' and 'SymbolicLink' the same checks are done for the +-- link target. A failure in any entry terminates the sequence of entries with +-- an error. +-- +checkSecurity :: Entries -> Entries +checkSecurity = checkEntries checkEntrySecurity + +checkTarbomb :: FilePath -> Entries -> Entries +checkTarbomb expectedTopDir = checkEntries (checkEntryTarbomb expectedTopDir) + +checkEntrySecurity :: Entry -> Maybe String +checkEntrySecurity entry = case entryContent entry of + HardLink link -> check (entryPath entry) + `mplus` check (fromLinkTarget link) + SymbolicLink link -> check (entryPath entry) + `mplus` check (fromLinkTarget link) + _ -> check (entryPath entry) + + where + check name + | not (FilePath.Native.isRelative name) + = Just $ "Absolute file name in tar archive: " ++ show name + + | not (FilePath.Native.isValid name) + = Just $ "Invalid file name in tar archive: " ++ show name + + | any (=="..") (FilePath.Native.splitDirectories name) + = Just $ "Invalid file name in tar archive: " ++ show name + + | otherwise = Nothing + +checkEntryTarbomb :: FilePath -> Entry -> Maybe String +checkEntryTarbomb _ entry | nonFilesystemEntry = Nothing + where + -- Ignore some special entries we will not unpack anyway + nonFilesystemEntry = + case entryContent entry of + OtherEntryType 'g' _ _ -> True --PAX global header + OtherEntryType 'x' _ _ -> True --PAX individual header + _ -> False + +checkEntryTarbomb expectedTopDir entry = + case FilePath.Native.splitDirectories (entryPath entry) of + (topDir:_) | topDir == expectedTopDir -> Nothing + _ -> Just $ "File in tar archive is not in the expected directory " + ++ show expectedTopDir + + +-- +-- * Reading +-- + +read :: ByteString -> Entries +read = unfoldrEntries getEntry + +getEntry :: ByteString -> Either String (Maybe (Entry, ByteString)) +getEntry bs + | BS.length header < 512 = Left "truncated tar archive" + + -- Tar files end with at least two blocks of all '0'. Checking this serves + -- two purposes. It checks the format but also forces the tail of the data + -- which is necessary to close the file if it came from a lazily read file. + | BS.head bs == 0 = case BS.splitAt 1024 bs of + (end, trailing) + | BS.length end /= 1024 -> Left "short tar trailer" + | not (BS.all (== 0) end) -> Left "bad tar trailer" + | not (BS.all (== 0) trailing) -> Left "tar file has trailing junk" + | otherwise -> Right Nothing + + | otherwise = partial $ do + + case (chksum_, format_) of + (Ok chksum, _ ) | correctChecksum header chksum -> return () + (Ok _, Ok _) -> fail "tar checksum error" + _ -> fail "data is not in tar format" + + -- These fields are partial, have to check them + format <- format_; mode <- mode_; + uid <- uid_; gid <- gid_; + size <- size_; mtime <- mtime_; + devmajor <- devmajor_; devminor <- devminor_; + + let content = BS.take size (BS.drop 512 bs) + padding = (512 - size) `mod` 512 + bs' = BS.drop (512 + size + padding) bs + + entry = Entry { + entryTarPath = TarPath name prefix, + entryContent = case typecode of + '\0' -> NormalFile content size + '0' -> NormalFile content size + '1' -> HardLink (LinkTarget linkname) + '2' -> SymbolicLink (LinkTarget linkname) + '3' -> CharacterDevice devmajor devminor + '4' -> BlockDevice devmajor devminor + '5' -> Directory + '6' -> NamedPipe + '7' -> NormalFile content size + _ -> OtherEntryType typecode content size, + entryPermissions = mode, + entryOwnership = Ownership uname gname uid gid, + entryTime = mtime, + entryFormat = format + } + + return (Just (entry, bs')) + + where + header = BS.take 512 bs + + name = getString 0 100 header + mode_ = getOct 100 8 header + uid_ = getOct 108 8 header + gid_ = getOct 116 8 header + size_ = getOct 124 12 header + mtime_ = getOct 136 12 header + chksum_ = getOct 148 8 header + typecode = getByte 156 header + linkname = getString 157 100 header + magic = getChars 257 8 header + uname = getString 265 32 header + gname = getString 297 32 header + devmajor_ = getOct 329 8 header + devminor_ = getOct 337 8 header + prefix = getString 345 155 header +-- trailing = getBytes 500 12 header + + format_ = case magic of + "\0\0\0\0\0\0\0\0" -> return V7Format + "ustar\NUL00" -> return UstarFormat + "ustar \NUL" -> return GnuFormat + _ -> fail "tar entry not in a recognised format" + +correctChecksum :: ByteString -> Int -> Bool +correctChecksum header checksum = checksum == checksum' + where + -- sum of all 512 bytes in the header block, + -- treating each byte as an 8-bit unsigned value + checksum' = BS.Char8.foldl' (\x y -> x + ord y) 0 header' + -- treating the 8 bytes of chksum as blank characters. + header' = BS.concat [BS.take 148 header, + BS.Char8.replicate 8 ' ', + BS.drop 156 header] + +-- * TAR format primitive input + +getOct :: (Integral a, Bits a) => Int64 -> Int64 -> ByteString -> Partial a +getOct off len header + | BS.head bytes == 128 = parseBinInt (BS.unpack (BS.tail bytes)) + | null octstr = return 0 + | otherwise = case readOct octstr of + [(x,[])] -> return x + _ -> fail "tar header is malformed (bad numeric encoding)" + where + bytes = getBytes off len header + octstr = BS.Char8.unpack + . BS.Char8.takeWhile (\c -> c /= '\NUL' && c /= ' ') + . BS.Char8.dropWhile (== ' ') + $ bytes + + -- Some tar programs switch into a binary format when they try to represent + -- field values that will not fit in the required width when using the text + -- octal format. In particular, the UID/GID fields can only hold up to 2^21 + -- while in the binary format can hold up to 2^32. The binary format uses + -- '\128' as the header which leaves 7 bytes. Only the last 4 are used. + parseBinInt [0, 0, 0, byte3, byte2, byte1, byte0] = + return $! shiftL (fromIntegral byte3) 24 + + shiftL (fromIntegral byte2) 16 + + shiftL (fromIntegral byte1) 8 + + shiftL (fromIntegral byte0) 0 + parseBinInt _ = fail "tar header uses non-standard number encoding" + +getBytes :: Int64 -> Int64 -> ByteString -> ByteString +getBytes off len = BS.take len . BS.drop off + +getByte :: Int64 -> ByteString -> Char +getByte off bs = BS.Char8.index bs off + +getChars :: Int64 -> Int64 -> ByteString -> String +getChars off len = BS.Char8.unpack . getBytes off len + +getString :: Int64 -> Int64 -> ByteString -> String +getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0') . getBytes off len + +data Partial a = Error String | Ok a + +partial :: Partial a -> Either String a +partial (Error msg) = Left msg +partial (Ok x) = Right x + +instance Monad Partial where + return = Ok + Error m >>= _ = Error m + Ok x >>= k = k x + fail = Error + +-- +-- * Writing +-- + +-- | Create the external representation of a tar archive by serialising a list +-- of tar entries. +-- +-- * The conversion is done lazily. +-- +write :: [Entry] -> ByteString +write es = BS.concat $ map putEntry es ++ [BS.replicate (512*2) 0] + +putEntry :: Entry -> ByteString +putEntry entry = case entryContent entry of + NormalFile content size -> BS.concat [ header, content, padding size ] + OtherEntryType _ content size -> BS.concat [ header, content, padding size ] + _ -> header + where + header = putHeader entry + padding size = BS.replicate paddingSize 0 + where paddingSize = fromIntegral (negate size `mod` 512) + +putHeader :: Entry -> ByteString +putHeader entry = + BS.Char8.pack $ take 148 block + ++ putOct 7 checksum + ++ ' ' : drop 156 block + where + block = putHeaderNoChkSum entry + checksum = foldl' (\x y -> x + ord y) 0 block + +putHeaderNoChkSum :: Entry -> String +putHeaderNoChkSum Entry { + entryTarPath = TarPath name prefix, + entryContent = content, + entryPermissions = permissions, + entryOwnership = ownership, + entryTime = modTime, + entryFormat = format + } = + + concat + [ putString 100 $ name + , putOct 8 $ permissions + , putOct 8 $ ownerId ownership + , putOct 8 $ groupId ownership + , putOct 12 $ contentSize + , putOct 12 $ modTime + , fill 8 $ ' ' -- dummy checksum + , putChar8 $ typeCode + , putString 100 $ linkTarget + ] ++ + case format of + V7Format -> + fill 255 '\NUL' + UstarFormat -> concat + [ putString 8 $ "ustar\NUL00" + , putString 32 $ ownerName ownership + , putString 32 $ groupName ownership + , putOct 8 $ deviceMajor + , putOct 8 $ deviceMinor + , putString 155 $ prefix + , fill 12 $ '\NUL' + ] + GnuFormat -> concat + [ putString 8 $ "ustar \NUL" + , putString 32 $ ownerName ownership + , putString 32 $ groupName ownership + , putGnuDev 8 $ deviceMajor + , putGnuDev 8 $ deviceMinor + , putString 155 $ prefix + , fill 12 $ '\NUL' + ] + where + (typeCode, contentSize, linkTarget, + deviceMajor, deviceMinor) = case content of + NormalFile _ size -> ('0' , size, [], 0, 0) + Directory -> ('5' , 0, [], 0, 0) + SymbolicLink (LinkTarget link) -> ('2' , 0, link, 0, 0) + HardLink (LinkTarget link) -> ('1' , 0, link, 0, 0) + CharacterDevice major minor -> ('3' , 0, [], major, minor) + BlockDevice major minor -> ('4' , 0, [], major, minor) + NamedPipe -> ('6' , 0, [], 0, 0) + OtherEntryType code _ size -> (code, size, [], 0, 0) + + putGnuDev w n = case content of + CharacterDevice _ _ -> putOct w n + BlockDevice _ _ -> putOct w n + _ -> replicate w '\NUL' + +-- * TAR format primitive output + +type FieldWidth = Int + +putString :: FieldWidth -> String -> String +putString n s = take n s ++ fill (n - length s) '\NUL' + +--TODO: check integer widths, eg for large file sizes +putOct :: Integral a => FieldWidth -> a -> String +putOct n x = + let octStr = take (n-1) $ showOct x "" + in fill (n - length octStr - 1) '0' + ++ octStr + ++ putChar8 '\NUL' + +putChar8 :: Char -> String +putChar8 c = [c] + +fill :: FieldWidth -> Char -> String +fill n c = replicate n c + +-- +-- * Unpacking +-- + +unpack :: FilePath -> Entries -> IO () +unpack baseDir entries = unpackEntries [] (checkSecurity entries) + >>= emulateLinks + + where + -- We're relying here on 'checkSecurity' to make sure we're not scribbling + -- files all over the place. + + unpackEntries _ (Fail err) = fail err + unpackEntries links Done = return links + unpackEntries links (Next entry es) = case entryContent entry of + NormalFile file _ -> extractFile entry path file + >> unpackEntries links es + Directory -> extractDir path + >> unpackEntries links es + HardLink link -> (unpackEntries $! saveLink path link links) es + SymbolicLink link -> (unpackEntries $! saveLink path link links) es + _ -> unpackEntries links es --ignore other file types + where + path = entryPath entry + + extractFile entry path content = do + -- Note that tar archives do not make sure each directory is created + -- before files they contain, indeed we may have to create several + -- levels of directory. + createDirectoryIfMissing True absDir + BS.writeFile absPath content + when (isExecutable (entryPermissions entry)) + (setFileExecutable absPath) + where + absDir = baseDir FilePath.Native.takeDirectory path + absPath = baseDir path + + extractDir path = createDirectoryIfMissing True (baseDir path) + + saveLink path link links = seq (length path) + $ seq (length link') + $ (path, link'):links + where link' = fromLinkTarget link + + emulateLinks = mapM_ $ \(relPath, relLinkTarget) -> + let absPath = baseDir relPath + absTarget = FilePath.Native.takeDirectory absPath relLinkTarget + in copyFile absTarget absPath + +-- +-- * Packing +-- + +pack :: FilePath -- ^ Base directory + -> [FilePath] -- ^ Files and directories to pack, relative to the base dir + -> IO [Entry] +pack baseDir paths0 = preparePaths baseDir paths0 >>= packPaths baseDir + +preparePaths :: FilePath -> [FilePath] -> IO [FilePath] +preparePaths baseDir paths = + fmap concat $ interleave + [ do isDir <- doesDirectoryExist (baseDir path) + if isDir + then do entries <- getDirectoryContentsRecursive (baseDir path) + return (FilePath.Native.addTrailingPathSeparator path + : map (path ) entries) + else return [path] + | path <- paths ] + +packPaths :: FilePath -> [FilePath] -> IO [Entry] +packPaths baseDir paths = + interleave + [ do tarpath <- either fail return (toTarPath isDir relpath) + if isDir then packDirectoryEntry filepath tarpath + else packFileEntry filepath tarpath + | relpath <- paths + , let isDir = FilePath.Native.hasTrailingPathSeparator filepath + filepath = baseDir relpath ] + +interleave :: [IO a] -> IO [a] +interleave = unsafeInterleaveIO . go + where + go [] = return [] + go (x:xs) = do + x' <- x + xs' <- interleave xs + return (x':xs') + +packFileEntry :: FilePath -- ^ Full path to find the file on the local disk + -> TarPath -- ^ Path to use for the tar Entry in the archive + -> IO Entry +packFileEntry filepath tarpath = do + mtime <- getModTime filepath + perms <- getPermissions filepath + file <- openBinaryFile filepath ReadMode + size <- hFileSize file + content <- BS.hGetContents file + return (simpleEntry tarpath (NormalFile content (fromIntegral size))) { + entryPermissions = if Permissions.executable perms + then executableFilePermissions + else ordinaryFilePermissions, + entryTime = mtime + } + +packDirectoryEntry :: FilePath -- ^ Full path to find the file on the local disk + -> TarPath -- ^ Path to use for the tar Entry in the archive + -> IO Entry +packDirectoryEntry filepath tarpath = do + mtime <- getModTime filepath + return (directoryEntry tarpath) { + entryTime = mtime + } + +getDirectoryContentsRecursive :: FilePath -> IO [FilePath] +getDirectoryContentsRecursive dir0 = + fmap tail (recurseDirectories dir0 [""]) + +recurseDirectories :: FilePath -> [FilePath] -> IO [FilePath] +recurseDirectories _ [] = return [] +recurseDirectories base (dir:dirs) = unsafeInterleaveIO $ do + (files, dirs') <- collect [] [] =<< getDirectoryContents (base dir) + + files' <- recurseDirectories base (dirs' ++ dirs) + return (dir : files ++ files') + + where + collect files dirs' [] = return (reverse files, reverse dirs') + collect files dirs' (entry:entries) | ignore entry + = collect files dirs' entries + collect files dirs' (entry:entries) = do + let dirEntry = dir entry + dirEntry' = FilePath.Native.addTrailingPathSeparator dirEntry + isDirectory <- doesDirectoryExist (base dirEntry) + if isDirectory + then collect files (dirEntry':dirs') entries + else collect (dirEntry:files) dirs' entries + + ignore ['.'] = True + ignore ['.', '.'] = True + ignore _ = False + +getModTime :: FilePath -> IO EpochTime +getModTime path = do + (TOD s _) <- getModificationTime path + return $! fromIntegral s diff --git a/cabal/cabal-install/Distribution/Client/Targets.hs b/cabal/cabal-install/Distribution/Client/Targets.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Targets.hs @@ -0,0 +1,743 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Targets +-- Copyright : (c) Duncan Coutts 2011 +-- License : BSD-like +-- +-- Maintainer : duncan@community.haskell.org +-- +-- Handling for user-specified targets +----------------------------------------------------------------------------- +module Distribution.Client.Targets ( + -- * User targets + UserTarget(..), + readUserTargets, + + -- * Package specifiers + PackageSpecifier(..), + pkgSpecifierTarget, + pkgSpecifierConstraints, + + -- * Resolving user targets to package specifiers + resolveUserTargets, + + -- ** Detailed interface + UserTargetProblem(..), + readUserTarget, + reportUserTargetProblems, + expandUserTarget, + + PackageTarget(..), + fetchPackageTarget, + readPackageTarget, + + PackageTargetProblem(..), + reportPackageTargetProblems, + + disambiguatePackageTargets, + disambiguatePackageName, + + -- * User constraints + UserConstraint(..), + readUserConstraint, + userToPackageConstraint + + ) where + +import Distribution.Package + ( Package(..), PackageName(..) + , PackageIdentifier(..), packageName, packageVersion + , Dependency(Dependency) ) +import Distribution.Client.Types + ( SourcePackage(..), PackageLocation(..) ) +import Distribution.Client.Dependency.Types + ( PackageConstraint(..) ) + +import qualified Distribution.Client.World as World +import Distribution.Client.PackageIndex (PackageIndex) +import qualified Distribution.Client.PackageIndex as PackageIndex +import qualified Distribution.Client.Tar as Tar +import Distribution.Client.FetchUtils + +import Distribution.PackageDescription + ( GenericPackageDescription, FlagName(..), FlagAssignment ) +import Distribution.PackageDescription.Parse + ( readPackageDescription, parsePackageDescription, ParseResult(..) ) +import Distribution.Version + ( Version(Version), thisVersion, anyVersion, isAnyVersion + , VersionRange ) +import Distribution.Text + ( Text(..), display ) +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.Utils + ( die, warn, intercalate, findPackageDesc, fromUTF8, lowercase ) + +import Data.List + ( find, nub ) +import Data.Maybe + ( listToMaybe ) +import Data.Either + ( partitionEithers ) +import Data.Monoid + ( Monoid(..) ) +import qualified Data.Map as Map +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 +import qualified Distribution.Client.GZipUtils as GZipUtils +import Control.Monad (liftM) +import qualified Distribution.Compat.ReadP as Parse +import Distribution.Compat.ReadP + ( (+++), (<++) ) +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint + ( (<>), (<+>) ) +import Data.Char + ( isSpace, isAlphaNum ) +import System.FilePath + ( takeExtension, dropExtension, takeDirectory, splitPath ) +import System.Directory + ( doesFileExist, doesDirectoryExist ) +import Network.URI + ( URI(..), URIAuth(..), parseAbsoluteURI ) + +-- ------------------------------------------------------------ +-- * User targets +-- ------------------------------------------------------------ + +-- | Various ways that a user may specify a package or package collection. +-- +data UserTarget = + + -- | A partially specified package, identified by name and possibly with + -- an exact version or a version constraint. + -- + -- > cabal install foo + -- > cabal install foo-1.0 + -- > cabal install 'foo < 2' + -- + UserTargetNamed Dependency + + -- | A special virtual package that refers to the collection of packages + -- recorded in the world file that the user specifically installed. + -- + -- > cabal install world + -- + | UserTargetWorld + + -- | A specific package that is unpacked in a local directory, often the + -- current directory. + -- + -- > cabal install . + -- > cabal install ../lib/other + -- + -- * Note: in future, if multiple @.cabal@ files are allowed in a single + -- directory then this will refer to the collection of packages. + -- + | UserTargetLocalDir FilePath + + -- | A specific local unpacked package, identified by its @.cabal@ file. + -- + -- > cabal install foo.cabal + -- > cabal install ../lib/other/bar.cabal + -- + | UserTargetLocalCabalFile FilePath + + -- | A specific package that is available as a local tarball file + -- + -- > cabal install dist/foo-1.0.tar.gz + -- > cabal install ../build/baz-1.0.tar.gz + -- + | UserTargetLocalTarball FilePath + + -- | A specific package that is available as a remote tarball file + -- + -- > cabal install http://code.haskell.org/~user/foo/foo-0.9.tar.gz + -- + | UserTargetRemoteTarball URI + deriving (Show,Eq) + + +-- ------------------------------------------------------------ +-- * Package specifier +-- ------------------------------------------------------------ + +-- | A fully or partially resolved reference to a package. +-- +data PackageSpecifier pkg = + + -- | A partially specified reference to a package (either source or + -- installed). It is specified by package name and optionally some + -- additional constraints. Use a dependency resolver to pick a specific + -- package satisfying these constraints. + -- + NamedPackage PackageName [PackageConstraint] + + -- | A fully specified source package. + -- + | SpecificSourcePackage pkg + deriving Show + + +pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName +pkgSpecifierTarget (NamedPackage name _) = name +pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg + +pkgSpecifierConstraints :: Package pkg + => PackageSpecifier pkg -> [PackageConstraint] +pkgSpecifierConstraints (NamedPackage _ constraints) = constraints +pkgSpecifierConstraints (SpecificSourcePackage pkg) = + [PackageConstraintVersion (packageName pkg) + (thisVersion (packageVersion pkg))] + + +-- ------------------------------------------------------------ +-- * Parsing and checking user targets +-- ------------------------------------------------------------ + +readUserTargets :: Verbosity -> [String] -> IO [UserTarget] +readUserTargets _verbosity targetStrs = do + (problems, targets) <- liftM partitionEithers + (mapM readUserTarget targetStrs) + reportUserTargetProblems problems + return targets + + +data UserTargetProblem + = UserTargetUnexpectedFile String + | UserTargetNonexistantFile String + | UserTargetUnexpectedUriScheme String + | UserTargetUnrecognisedUri String + | UserTargetUnrecognised String + | UserTargetBadWorldPkg + deriving Show + +readUserTarget :: String -> IO (Either UserTargetProblem UserTarget) +readUserTarget targetstr = + case testNamedTargets targetstr of + Just (Dependency (PackageName "world") verrange) + | verrange == anyVersion -> return (Right UserTargetWorld) + | otherwise -> return (Left UserTargetBadWorldPkg) + Just dep -> return (Right (UserTargetNamed dep)) + Nothing -> do + fileTarget <- testFileTargets targetstr + case fileTarget of + Just target -> return target + Nothing -> + case testUriTargets targetstr of + Just target -> return target + Nothing -> return (Left (UserTargetUnrecognised targetstr)) + where + testNamedTargets = readPToMaybe parseDependencyOrPackageId + + testFileTargets filename = do + isDir <- doesDirectoryExist filename + isFile <- doesFileExist filename + parentDirExists <- case takeDirectory filename of + [] -> return False + dir -> doesDirectoryExist dir + let result + | isDir + = Just (Right (UserTargetLocalDir filename)) + + | isFile && extensionIsTarGz filename + = Just (Right (UserTargetLocalTarball filename)) + + | isFile && takeExtension filename == ".cabal" + = Just (Right (UserTargetLocalCabalFile filename)) + + | isFile + = Just (Left (UserTargetUnexpectedFile filename)) + + | parentDirExists + = Just (Left (UserTargetNonexistantFile filename)) + + | otherwise + = Nothing + return result + + testUriTargets str = + case parseAbsoluteURI str of + Just uri@URI { + uriScheme = scheme, + uriAuthority = Just URIAuth { uriRegName = host } + } + | scheme /= "http:" -> + Just (Left (UserTargetUnexpectedUriScheme targetstr)) + + | null host -> + Just (Left (UserTargetUnrecognisedUri targetstr)) + + | otherwise -> + Just (Right (UserTargetRemoteTarball uri)) + _ -> Nothing + + extensionIsTarGz f = takeExtension f == ".gz" + && takeExtension (dropExtension f) == ".tar" + + parseDependencyOrPackageId :: Parse.ReadP r Dependency + parseDependencyOrPackageId = parse + +++ liftM pkgidToDependency parse + where + pkgidToDependency :: PackageIdentifier -> Dependency + pkgidToDependency p = case packageVersion p of + Version [] _ -> Dependency (packageName p) anyVersion + version -> Dependency (packageName p) (thisVersion version) + +readPToMaybe :: Parse.ReadP a a -> String -> Maybe a +readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str + , all isSpace s ] + + +reportUserTargetProblems :: [UserTargetProblem] -> IO () +reportUserTargetProblems problems = do + case [ target | UserTargetUnrecognised target <- problems ] of + [] -> return () + target -> die + $ unlines + [ "Unrecognised target '" ++ name ++ "'." + | name <- target ] + ++ "Targets can be:\n" + ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n" + ++ " - the special 'world' target\n" + ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n" + ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'" + + case [ () | UserTargetBadWorldPkg <- problems ] of + [] -> return () + _ -> die "The special 'world' target does not take any version." + + case [ target | UserTargetNonexistantFile target <- problems ] of + [] -> return () + target -> die + $ unlines + [ "The file does not exist '" ++ name ++ "'." + | name <- target ] + + case [ target | UserTargetUnexpectedFile target <- problems ] of + [] -> return () + target -> die + $ unlines + [ "Unrecognised file target '" ++ name ++ "'." + | name <- target ] + ++ "File targets can be either package tarballs 'pkgname.tar.gz' " + ++ "or cabal files 'pkgname.cabal'." + + case [ target | UserTargetUnexpectedUriScheme target <- problems ] of + [] -> return () + target -> die + $ unlines + [ "URL target not supported '" ++ name ++ "'." + | name <- target ] + ++ "Only 'http://' URLs are supported." + + case [ target | UserTargetUnrecognisedUri target <- problems ] of + [] -> return () + target -> die + $ unlines + [ "Unrecognise URL target '" ++ name ++ "'." + | name <- target ] + + +-- ------------------------------------------------------------ +-- * Resolving user targets to package specifiers +-- ------------------------------------------------------------ + +-- | Given a bunch of user-specified targets, try to resolve what it is they +-- refer to. They can either be specific packages (local dirs, tarballs etc) +-- or they can be named packages (with or without version info). +-- +resolveUserTargets :: Package pkg + => Verbosity + -> FilePath + -> PackageIndex pkg + -> [UserTarget] + -> IO [PackageSpecifier SourcePackage] +resolveUserTargets verbosity worldFile available userTargets = do + + -- given the user targets, get a list of fully or partially resolved + -- package references + packageTargets <- mapM (readPackageTarget verbosity) + =<< mapM (fetchPackageTarget verbosity) . concat + =<< mapM (expandUserTarget worldFile) userTargets + + -- users are allowed to give package names case-insensitively, so we must + -- disambiguate named package references + let (problems, packageSpecifiers) = + disambiguatePackageTargets available availableExtra packageTargets + + -- use any extra specific available packages to help us disambiguate + availableExtra = [ packageName pkg + | PackageTargetLocation pkg <- packageTargets ] + + reportPackageTargetProblems verbosity problems + + return packageSpecifiers + + +-- ------------------------------------------------------------ +-- * Package targets +-- ------------------------------------------------------------ + +-- | An intermediate between a 'UserTarget' and a resolved 'PackageSpecifier'. +-- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package. +-- +data PackageTarget pkg = + PackageTargetNamed PackageName [PackageConstraint] UserTarget + + -- | A package identified by name, but case insensitively, so it needs + -- to be resolved to the right case-sensitive name. + | PackageTargetNamedFuzzy PackageName [PackageConstraint] UserTarget + | PackageTargetLocation pkg + deriving Show + + +-- ------------------------------------------------------------ +-- * Converting user targets to package targets +-- ------------------------------------------------------------ + +-- | Given a user-specified target, expand it to a bunch of package targets +-- (each of which refers to only one package). +-- +expandUserTarget :: FilePath + -> UserTarget + -> IO [PackageTarget (PackageLocation ())] +expandUserTarget worldFile userTarget = case userTarget of + + UserTargetNamed (Dependency name vrange) -> + let constraints = [ PackageConstraintVersion name vrange + | not (isAnyVersion vrange) ] + in return [PackageTargetNamedFuzzy name constraints userTarget] + + UserTargetWorld -> do + worldPkgs <- World.getContents worldFile + --TODO: should we warn if there are no world targets? + return [ PackageTargetNamed name constraints userTarget + | World.WorldPkgInfo (Dependency name vrange) flags <- worldPkgs + , let constraints = [ PackageConstraintVersion name vrange + | not (isAnyVersion vrange) ] + ++ [ PackageConstraintFlags name flags + | not (null flags) ] ] + + UserTargetLocalDir dir -> + return [ PackageTargetLocation (LocalUnpackedPackage dir) ] + + UserTargetLocalCabalFile file -> do + let dir = takeDirectory file + _ <- findPackageDesc dir -- just as a check + return [ PackageTargetLocation (LocalUnpackedPackage dir) ] + + UserTargetLocalTarball tarballFile -> + return [ PackageTargetLocation (LocalTarballPackage tarballFile) ] + + UserTargetRemoteTarball tarballURL -> + return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ] + + +-- ------------------------------------------------------------ +-- * Fetching and reading package targets +-- ------------------------------------------------------------ + + +-- | Fetch any remote targets so that they can be read. +-- +fetchPackageTarget :: Verbosity + -> PackageTarget (PackageLocation ()) + -> IO (PackageTarget (PackageLocation FilePath)) +fetchPackageTarget verbosity target = case target of + PackageTargetNamed n cs ut -> return (PackageTargetNamed n cs ut) + PackageTargetNamedFuzzy n cs ut -> return (PackageTargetNamedFuzzy n cs ut) + PackageTargetLocation location -> do + location' <- fetchPackage verbosity (fmap (const Nothing) location) + return (PackageTargetLocation location') + + +-- | Given a package target that has been fetched, read the .cabal file. +-- +-- This only affects targets given by location, named targets are unaffected. +-- +readPackageTarget :: Verbosity + -> PackageTarget (PackageLocation FilePath) + -> IO (PackageTarget SourcePackage) +readPackageTarget verbosity target = case target of + + PackageTargetNamed pkgname constraints userTarget -> + return (PackageTargetNamed pkgname constraints userTarget) + + PackageTargetNamedFuzzy pkgname constraints userTarget -> + return (PackageTargetNamedFuzzy pkgname constraints userTarget) + + PackageTargetLocation location -> case location of + + LocalUnpackedPackage dir -> do + pkg <- readPackageDescription verbosity =<< findPackageDesc dir + return $ PackageTargetLocation $ + SourcePackage { + packageInfoId = packageId pkg, + packageDescription = pkg, + packageSource = fmap Just location + } + + LocalTarballPackage tarballFile -> + readTarballPackageTarget location tarballFile tarballFile + + RemoteTarballPackage tarballURL tarballFile -> + readTarballPackageTarget location tarballFile (show tarballURL) + + RepoTarballPackage _repo _pkgid _ -> + error "TODO: readPackageTarget RepoTarballPackage" + -- For repo tarballs this info should be obtained from the index. + + where + readTarballPackageTarget location tarballFile tarballOriginalLoc = do + (filename, content) <- extractTarballPackageCabalFile + tarballFile tarballOriginalLoc + case parsePackageDescription' content of + Nothing -> die $ "Could not parse the cabal file " + ++ filename ++ " in " ++ tarballFile + Just pkg -> + return $ PackageTargetLocation $ + SourcePackage { + packageInfoId = packageId pkg, + packageDescription = pkg, + packageSource = fmap Just location + } + + extractTarballPackageCabalFile :: FilePath -> String + -> IO (FilePath, BS.ByteString) + extractTarballPackageCabalFile tarballFile tarballOriginalLoc = + either (die . formatErr) return + . check + . Tar.entriesIndex + . Tar.filterEntries isCabalFile + . Tar.read + . GZipUtils.maybeDecompress + =<< BS.readFile tarballFile + where + formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg + + check (Left e) = Left e + check (Right m) = case Map.elems m of + [] -> Left noCabalFile + [file] -> case Tar.entryContent file of + Tar.NormalFile content _ -> Right (Tar.entryPath file, content) + _ -> Left noCabalFile + _files -> Left multipleCabalFiles + where + noCabalFile = "No cabal file found" + multipleCabalFiles = "Multiple cabal files found" + + isCabalFile e = case splitPath (Tar.entryPath e) of + [ _dir, file] -> takeExtension file == ".cabal" + [".", _dir, file] -> takeExtension file == ".cabal" + _ -> False + + parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription + parsePackageDescription' content = + case parsePackageDescription . fromUTF8 . BS.Char8.unpack $ content of + ParseOk _ pkg -> Just pkg + _ -> Nothing + + +-- ------------------------------------------------------------ +-- * Checking package targets +-- ------------------------------------------------------------ + +data PackageTargetProblem + = PackageNameUnknown PackageName UserTarget + | PackageNameAmbigious PackageName [PackageName] UserTarget + deriving Show + + +-- | Users are allowed to give package names case-insensitively, so we must +-- disambiguate named package references. +-- +disambiguatePackageTargets :: Package pkg' + => PackageIndex pkg' + -> [PackageName] + -> [PackageTarget pkg] + -> ( [PackageTargetProblem] + , [PackageSpecifier pkg] ) +disambiguatePackageTargets availablePkgIndex availableExtra targets = + partitionEithers (map disambiguatePackageTarget targets) + where + disambiguatePackageTarget packageTarget = case packageTarget of + PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg) + + PackageTargetNamed pkgname constraints userTarget + | null (PackageIndex.lookupPackageName availablePkgIndex pkgname) + -> Left (PackageNameUnknown pkgname userTarget) + | otherwise -> Right (NamedPackage pkgname constraints) + + PackageTargetNamedFuzzy pkgname constraints userTarget -> + case disambiguatePackageName packageNameEnv pkgname of + None -> Left (PackageNameUnknown + pkgname userTarget) + Ambiguous pkgnames -> Left (PackageNameAmbigious + pkgname pkgnames userTarget) + Unambiguous pkgname' -> Right (NamedPackage pkgname' constraints') + where + constraints' = map (renamePackageConstraint pkgname') constraints + + -- use any extra specific available packages to help us disambiguate + packageNameEnv :: PackageNameEnv + packageNameEnv = mappend (indexPackageNameEnv availablePkgIndex) + (extraPackageNameEnv availableExtra) + + +-- | Report problems to the user. That is, if there are any problems +-- then raise an exception. +reportPackageTargetProblems :: Verbosity + -> [PackageTargetProblem] -> IO () +reportPackageTargetProblems verbosity problems = do + case [ pkg | PackageNameUnknown pkg originalTarget <- problems + , not (isUserTagetWorld originalTarget) ] of + [] -> return () + pkgs -> die $ unlines + [ "There is no package named '" ++ display name ++ "'. " + | name <- pkgs ] + ++ "You may need to run 'hackport update' to get the latest " + ++ "list of available packages." + + case [ (pkg, matches) | PackageNameAmbigious pkg matches _ <- problems ] of + [] -> return () + ambiguities -> die $ unlines + [ "The package name '" ++ display name + ++ "' is ambigious. It could be: " + ++ intercalate ", " (map display matches) + | (name, matches) <- ambiguities ] + + case [ pkg | PackageNameUnknown pkg UserTargetWorld <- problems ] of + [] -> return () + pkgs -> warn verbosity $ + "The following 'world' packages will be ignored because " + ++ "they refer to packages that cannot be found: " + ++ intercalate ", " (map display pkgs) ++ "\n" + ++ "You can suppress this warning by correcting the world file." + where + isUserTagetWorld UserTargetWorld = True; isUserTagetWorld _ = False + + +-- ------------------------------------------------------------ +-- * Disambiguating package names +-- ------------------------------------------------------------ + +data MaybeAmbigious a = None | Unambiguous a | Ambiguous [a] + +-- | Given a package name and a list of matching names, figure out which one it +-- might be referring to. If there is an exact case-sensitive match then that's +-- ok. If it matches just one package case-insensitively then that's also ok. +-- The only problem is if it matches multiple packages case-insensitively, in +-- that case it is ambigious. +-- +disambiguatePackageName :: PackageNameEnv + -> PackageName + -> MaybeAmbigious PackageName +disambiguatePackageName (PackageNameEnv pkgNameLookup) name = + case nub (pkgNameLookup name) of + [] -> None + [name'] -> Unambiguous name' + names -> case find (name==) names of + Just name' -> Unambiguous name' + Nothing -> Ambiguous names + + +newtype PackageNameEnv = PackageNameEnv (PackageName -> [PackageName]) + +instance Monoid PackageNameEnv where + mempty = PackageNameEnv (const []) + mappend (PackageNameEnv lookupA) (PackageNameEnv lookupB) = + PackageNameEnv (\name -> lookupA name ++ lookupB name) + +indexPackageNameEnv :: Package pkg => PackageIndex pkg -> PackageNameEnv +indexPackageNameEnv pkgIndex = PackageNameEnv pkgNameLookup + where + pkgNameLookup (PackageName name) = + map fst (PackageIndex.searchByName pkgIndex name) + +extraPackageNameEnv :: [PackageName] -> PackageNameEnv +extraPackageNameEnv names = PackageNameEnv pkgNameLookup + where + pkgNameLookup (PackageName name) = + [ PackageName name' + | let lname = lowercase name + , PackageName name' <- names + , lowercase name' == lname ] + + +-- ------------------------------------------------------------ +-- * Package constraints +-- ------------------------------------------------------------ + +data UserConstraint = + UserConstraintVersion PackageName VersionRange + | UserConstraintInstalled PackageName + | UserConstraintSource PackageName + | UserConstraintFlags PackageName FlagAssignment + deriving (Show,Eq) + + +userToPackageConstraint :: UserConstraint -> PackageConstraint +-- At the moment, the types happen to be directly equivalent +userToPackageConstraint uc = case uc of + UserConstraintVersion name ver -> PackageConstraintVersion name ver + UserConstraintInstalled name -> PackageConstraintInstalled name + UserConstraintSource name -> PackageConstraintSource name + UserConstraintFlags name flags -> PackageConstraintFlags name flags + +renamePackageConstraint :: PackageName -> PackageConstraint -> PackageConstraint +renamePackageConstraint name pc = case pc of + PackageConstraintVersion _ ver -> PackageConstraintVersion name ver + PackageConstraintInstalled _ -> PackageConstraintInstalled name + PackageConstraintSource _ -> PackageConstraintSource name + PackageConstraintFlags _ flags -> PackageConstraintFlags name flags + +readUserConstraint :: String -> Either String UserConstraint +readUserConstraint str = + case readPToMaybe parse str of + Nothing -> Left msgCannotParse + Just c -> Right c + where + msgCannotParse = + "expected a package name followed by a constraint, which is " + ++ "either a version range, 'installed', 'source' or flags" + +--FIXME: use Text instance for FlagName and FlagAssignment +instance Text UserConstraint where + disp (UserConstraintVersion pkgname verrange) = disp pkgname <+> disp verrange + disp (UserConstraintInstalled pkgname) = disp pkgname <+> Disp.text "installed" + disp (UserConstraintSource pkgname) = disp pkgname <+> Disp.text "source" + disp (UserConstraintFlags pkgname flags) = disp pkgname <+> dispFlagAssignment flags + where + dispFlagAssignment = Disp.hsep . map dispFlagValue + dispFlagValue (f, True) = Disp.char '+' <> dispFlagName f + dispFlagValue (f, False) = Disp.char '-' <> dispFlagName f + dispFlagName (FlagName f) = Disp.text f + + parse = parse >>= parseConstraint + where + parseConstraint pkgname = + (parse >>= return . UserConstraintVersion pkgname) + +++ (do Parse.skipSpaces + _ <- Parse.string "installed" + return (UserConstraintInstalled pkgname)) + +++ (do Parse.skipSpaces + _ <- Parse.string "source" + return (UserConstraintSource pkgname)) + <++ (parseFlagAssignment >>= (return . UserConstraintFlags pkgname)) + + parseFlagAssignment = Parse.many1 (Parse.skipSpaces >> parseFlagValue) + parseFlagValue = + (do Parse.optional (Parse.char '+') + f <- parseFlagName + return (f, True)) + +++ (do _ <- Parse.char '-' + f <- parseFlagName + return (f, False)) + parseFlagName = liftM FlagName ident + + ident :: Parse.ReadP r String + ident = Parse.munch1 identChar >>= \s -> check s >> return s + where + identChar c = isAlphaNum c || c == '_' || c == '-' + check ('-':_) = Parse.pfail + check _ = return () diff --git a/cabal/cabal-install/Distribution/Client/Types.hs b/cabal/cabal-install/Distribution/Client/Types.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Types.hs @@ -0,0 +1,163 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Types +-- Copyright : (c) David Himmelstrup 2005 +-- Duncan Coutts 2011 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Various common data types for the entire cabal-install system +----------------------------------------------------------------------------- +module Distribution.Client.Types where + +import Distribution.Package + ( PackageName, PackageId, Package(..), PackageFixedDeps(..) ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo ) +import Distribution.PackageDescription + ( GenericPackageDescription, FlagAssignment ) +import Distribution.Client.PackageIndex + ( PackageIndex ) +import Distribution.Version + ( VersionRange ) + +import Data.Map (Map) +import Network.URI (URI) +import Distribution.Compat.ExceptionCI + ( SomeException ) + +newtype Username = Username { unUsername :: String } +newtype Password = Password { unPassword :: String } + +-- | This is the information we get from a @00-index.tar.gz@ hackage index. +-- +data SourcePackageDb = SourcePackageDb { + packageIndex :: PackageIndex SourcePackage, + packagePreferences :: Map PackageName VersionRange +} + +-- ------------------------------------------------------------ +-- * Various kinds of information about packages +-- ------------------------------------------------------------ + +-- | TODO: This is a hack to help us transition from Cabal-1.6 to 1.8. +-- What is new in 1.8 is that installed packages and dependencies between +-- installed packages are now identified by an opaque InstalledPackageId +-- rather than a source PackageId. +-- +-- We should use simply an 'InstalledPackageInfo' here but to ease the +-- transition we are temporarily using this variant where we pretend that +-- installed packages still specify their deps in terms of PackageIds. +-- +-- Crucially this means that 'InstalledPackage' can be an instance of +-- 'PackageFixedDeps' where as 'InstalledPackageInfo' is no longer an instance +-- of that class. This means we can make 'PackageIndex'es of InstalledPackage +-- where as the InstalledPackageInfo now has its own monomorphic index type. +-- +data InstalledPackage = InstalledPackage + InstalledPackageInfo + [PackageId] + +instance Package InstalledPackage where + packageId (InstalledPackage pkg _) = packageId pkg +instance PackageFixedDeps InstalledPackage where + depends (InstalledPackage _ deps) = deps + +-- | A 'ConfiguredPackage' is a not-yet-installed package along with the +-- total configuration information. The configuration information is total in +-- the sense that it provides all the configuration information and so the +-- final configure process will be independent of the environment. +-- +data ConfiguredPackage = ConfiguredPackage + SourcePackage -- package info, including repo + FlagAssignment -- complete flag assignment for the package + [PackageId] -- set of exact dependencies. These must be + -- consistent with the 'buildDepends' in the + -- 'PackageDescrption' that you'd get by applying + -- the flag assignment. + deriving Show + +instance Package ConfiguredPackage where + packageId (ConfiguredPackage pkg _ _) = packageId pkg + +instance PackageFixedDeps ConfiguredPackage where + depends (ConfiguredPackage _ _ deps) = deps + + +-- | A package description along with the location of the package sources. +-- +data SourcePackage = SourcePackage { + packageInfoId :: PackageId, + packageDescription :: GenericPackageDescription, + packageSource :: PackageLocation (Maybe FilePath) + } + deriving Show + +instance Package SourcePackage where packageId = packageInfoId + +-- ------------------------------------------------------------ +-- * Package locations and repositories +-- ------------------------------------------------------------ + +data PackageLocation local = + + -- | An unpacked package in the given dir, or current dir + LocalUnpackedPackage FilePath + + -- | A package as a tarball that's available as a local tarball + | LocalTarballPackage FilePath + + -- | A package as a tarball from a remote URI + | RemoteTarballPackage URI local + + -- | A package available as a tarball from a repository. + -- + -- It may be from a local repository or from a remote repository, with a + -- locally cached copy. ie a package available from hackage + | RepoTarballPackage Repo PackageId local + +--TODO: +-- * add support for darcs and other SCM style remote repos with a local cache +-- | ScmPackage + deriving Show + +instance Functor PackageLocation where + fmap _ (LocalUnpackedPackage dir) = LocalUnpackedPackage dir + fmap _ (LocalTarballPackage file) = LocalTarballPackage file + fmap f (RemoteTarballPackage uri x) = RemoteTarballPackage uri (f x) + fmap f (RepoTarballPackage repo pkg x) = RepoTarballPackage repo pkg (f x) + + +data LocalRepo = LocalRepo + deriving (Show,Eq) + +data RemoteRepo = RemoteRepo { + remoteRepoName :: String, + remoteRepoURI :: URI + } + deriving (Show,Eq) + +data Repo = Repo { + repoKind :: Either RemoteRepo LocalRepo, + repoLocalDir :: FilePath + } + deriving (Show,Eq) + +-- ------------------------------------------------------------ +-- * Build results +-- ------------------------------------------------------------ + +type BuildResult = Either BuildFailure BuildSuccess +data BuildFailure = DependentFailed PackageId + | DownloadFailed SomeException + | UnpackFailed SomeException + | ConfigureFailed SomeException + | BuildFailed SomeException + | InstallFailed SomeException +data BuildSuccess = BuildOk DocsResult TestsResult + +data DocsResult = DocsNotTried | DocsFailed | DocsOk +data TestsResult = TestsNotTried | TestsFailed | TestsOk diff --git a/cabal/cabal-install/Distribution/Client/Unpack.hs b/cabal/cabal-install/Distribution/Client/Unpack.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Unpack.hs @@ -0,0 +1,123 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Unpack +-- Copyright : (c) Andrea Vezzosi 2008 +-- Duncan Coutts 2011 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- +----------------------------------------------------------------------------- +module Distribution.Client.Unpack ( + + -- * Commands + unpack, + + ) where + +import Distribution.Package + ( PackageId, packageId ) +import Distribution.Simple.Setup + ( fromFlag, fromFlagOrDefault ) +import Distribution.Simple.Utils + ( notice, die ) +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Text(display) + +import Distribution.Client.Setup + ( GlobalFlags(..), UnpackFlags(..) ) +import Distribution.Client.Types +import Distribution.Client.Targets +import Distribution.Client.Dependency +import Distribution.Client.FetchUtils +import qualified Distribution.Client.Tar as Tar (extractTarGzFile) +import Distribution.Client.IndexUtils as IndexUtils + ( getSourcePackages ) + +import System.Directory + ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist ) +import Control.Monad + ( unless, when ) +import Data.Monoid + ( mempty ) +import System.FilePath + ( (), addTrailingPathSeparator ) + + +unpack :: Verbosity + -> [Repo] + -> GlobalFlags + -> UnpackFlags + -> [UserTarget] + -> IO () +unpack verbosity _ _ _ [] = + notice verbosity "No packages requested. Nothing to do." + +unpack verbosity repos globalFlags unpackFlags userTargets = do + mapM_ checkTarget userTargets + + sourcePkgDb <- getSourcePackages verbosity repos + + pkgSpecifiers <- resolveUserTargets verbosity + (fromFlag $ globalWorldFile globalFlags) + (packageIndex sourcePkgDb) + userTargets + + pkgs <- either (die . unlines . map show) return $ + resolveWithoutDependencies + (resolverParams sourcePkgDb pkgSpecifiers) + + unless (null prefix) $ + createDirectoryIfMissing True prefix + + flip mapM_ pkgs $ \pkg -> do + location <- fetchPackage verbosity (packageSource pkg) + let pkgid = packageId pkg + case location of + LocalTarballPackage tarballPath -> + unpackPackage verbosity prefix pkgid tarballPath + + RemoteTarballPackage _tarballURL tarballPath -> + unpackPackage verbosity prefix pkgid tarballPath + + RepoTarballPackage _repo _pkgid tarballPath -> + unpackPackage verbosity prefix pkgid tarballPath + + LocalUnpackedPackage _ -> + error "Distribution.Client.Unpack.unpack: the impossible happened." + + where + resolverParams sourcePkgDb pkgSpecifiers = + --TODO: add commandline constraint and preference args for unpack + + standardInstallPolicy mempty sourcePkgDb pkgSpecifiers + + prefix = fromFlagOrDefault "" (unpackDestDir unpackFlags) + +checkTarget :: UserTarget -> IO () +checkTarget target = case target of + UserTargetLocalDir dir -> die (notTarball dir) + UserTargetLocalCabalFile file -> die (notTarball file) + _ -> return () + where + notTarball t = + "The 'unpack' command is for tarball packages. " + ++ "The target '" ++ t ++ "' is not a tarball." + +unpackPackage :: Verbosity -> FilePath -> PackageId -> FilePath -> IO () +unpackPackage verbosity prefix pkgid pkgPath = do + let pkgdirname = display pkgid + pkgdir = prefix pkgdirname + pkgdir' = addTrailingPathSeparator pkgdir + existsDir <- doesDirectoryExist pkgdir + when existsDir $ die $ + "The directory \"" ++ pkgdir' ++ "\" already exists, not unpacking." + existsFile <- doesFileExist pkgdir + when existsFile $ die $ + "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking." + notice verbosity $ "Unpacking to " ++ pkgdir' + Tar.extractTarGzFile prefix pkgdirname pkgPath diff --git a/cabal/cabal-install/Distribution/Client/Update.hs b/cabal/cabal-install/Distribution/Client/Update.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Update.hs @@ -0,0 +1,82 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Update +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- +----------------------------------------------------------------------------- +module Distribution.Client.Update + ( update + ) where + +import Distribution.Client.Types + ( Repo(..), RemoteRepo(..), LocalRepo(..), SourcePackageDb(..) ) +import Distribution.Client.FetchUtils + ( downloadIndex ) +import qualified Distribution.Client.PackageIndex as PackageIndex +import Distribution.Client.IndexUtils + ( getSourcePackages ) +import qualified Paths_cabal_install + ( version ) + +import Distribution.Package + ( PackageName(..), packageVersion ) +import Distribution.Version + ( anyVersion, withinRange ) +import Distribution.Simple.Utils + ( warn, notice, writeFileAtomic ) +import Distribution.Verbosity + ( Verbosity ) + +import qualified Data.ByteString.Lazy as BS +import qualified Data.ByteString.Lazy.Char8 as BS.Char8 +import Distribution.Client.GZipUtils (maybeDecompress) +import qualified Data.Map as Map +import System.FilePath (dropExtension) +import Data.Maybe (fromMaybe) +import Control.Monad (when) + +-- | 'update' downloads the package list from all known servers +update :: Verbosity -> [Repo] -> IO () +update verbosity [] = do + warn verbosity $ "No remote package servers have been specified. Usually " + ++ "you would have one specified in the config file." +update verbosity repos = do + mapM_ (updateRepo verbosity) repos + checkForSelfUpgrade verbosity repos + +updateRepo :: Verbosity -> Repo -> IO () +updateRepo verbosity repo = case repoKind repo of + Right LocalRepo -> return () + Left remoteRepo -> do + notice verbosity $ "Downloading the latest package list from " + ++ remoteRepoName remoteRepo + indexPath <- downloadIndex verbosity remoteRepo (repoLocalDir repo) + writeFileAtomic (dropExtension indexPath) . BS.Char8.unpack + . maybeDecompress + =<< BS.readFile indexPath + +checkForSelfUpgrade :: Verbosity -> [Repo] -> IO () +checkForSelfUpgrade verbosity repos = do + SourcePackageDb sourcePkgIndex prefs <- getSourcePackages verbosity repos + + let self = PackageName "cabal-install" + preferredVersionRange = fromMaybe anyVersion (Map.lookup self prefs) + currentVersion = Paths_cabal_install.version + laterPreferredVersions = + [ packageVersion pkg + | pkg <- PackageIndex.lookupPackageName sourcePkgIndex self + , let version = packageVersion pkg + , version > currentVersion + , version `withinRange` preferredVersionRange ] + + when (not (null laterPreferredVersions)) $ + notice verbosity $ + "Note: there is a new version of cabal-install available.\n" + ++ "To upgrade, run: cabal install cabal-install" + diff --git a/cabal/cabal-install/Distribution/Client/Upload.hs b/cabal/cabal-install/Distribution/Client/Upload.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Upload.hs @@ -0,0 +1,190 @@ +-- This is a quick hack for uploading packages to Hackage. +-- See http://hackage.haskell.org/trac/hackage/wiki/CabalUpload + +module Distribution.Client.Upload (check, upload, report) where + +import Distribution.Client.Types (Username(..), Password(..),Repo(..),RemoteRepo(..)) +import Distribution.Client.HttpUtils (proxy, isOldHackageURI) + +import Distribution.Simple.Utils (debug, notice, warn, info) +import Distribution.Verbosity (Verbosity) +import Distribution.Text (display) +import Distribution.Client.Config + +import qualified Distribution.Client.BuildReports.Anonymous as BuildReport +import qualified Distribution.Client.BuildReports.Upload as BuildReport + +import Network.Browser + ( BrowserAction, browse, request + , Authority(..), addAuthority, setAuthorityGen + , setOutHandler, setErrHandler, setProxy ) +import Network.HTTP + ( Header(..), HeaderName(..), findHeader + , Request(..), RequestMethod(..), Response(..) ) +import Network.TCP (HandleStream) +import Network.URI (URI(uriPath), parseURI) + +import Data.Char (intToDigit) +import Numeric (showHex) +import System.IO (hFlush, stdin, stdout, hGetEcho, hSetEcho + ,openBinaryFile, IOMode(ReadMode), hGetContents) +import Control.Exception (bracket) +import System.Random (randomRIO) +import System.FilePath ((), takeExtension, takeFileName) +import qualified System.FilePath.Posix as FilePath.Posix (combine) +import System.Directory +import Control.Monad (forM_) + + +--FIXME: how do we find this path for an arbitrary hackage server? +-- is it always at some fixed location relative to the server root? +legacyUploadURI :: URI +Just legacyUploadURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/protected/upload-pkg" + +checkURI :: URI +Just checkURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/check-pkg" + + +upload :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> [FilePath] -> IO () +upload verbosity repos mUsername mPassword paths = do + let uploadURI = if isOldHackageURI targetRepoURI + then legacyUploadURI + else targetRepoURI{uriPath = uriPath targetRepoURI `FilePath.Posix.combine` "upload"} + Username username <- maybe promptUsername return mUsername + Password password <- maybe promptPassword return mPassword + let auth = addAuthority AuthBasic { + auRealm = "Hackage", + auUsername = username, + auPassword = password, + auSite = uploadURI + } + flip mapM_ paths $ \path -> do + notice verbosity $ "Uploading " ++ path ++ "... " + handlePackage verbosity uploadURI auth path + where + targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given + +promptUsername :: IO Username +promptUsername = do + putStr "Hackage username: " + hFlush stdout + fmap Username getLine + +promptPassword :: IO Password +promptPassword = do + putStr "Hackage password: " + hFlush stdout + -- save/restore the terminal echoing status + passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do + hSetEcho stdin False -- no echoing for entering the password + fmap Password getLine + putStrLn "" + return passwd + +report :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> IO () +report verbosity repos mUsername mPassword = do + let uploadURI = if isOldHackageURI targetRepoURI + then legacyUploadURI + else targetRepoURI{uriPath = ""} + Username username <- maybe promptUsername return mUsername + Password password <- maybe promptPassword return mPassword + let auth = addAuthority AuthBasic { + auRealm = "Hackage", + auUsername = username, + auPassword = password, + auSite = uploadURI + } + forM_ repos $ \repo -> case repoKind repo of + Left remoteRepo + -> do dotCabal <- defaultCabalDir + let srcDir = dotCabal "reports" remoteRepoName remoteRepo + contents <- getDirectoryContents srcDir + forM_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile -> + do inp <- readFile (srcDir logFile) + let (reportStr, buildLog) = read inp :: (String,String) + case BuildReport.parse reportStr of + Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME + Right report' -> + do info verbosity $ "Uploading report for " ++ display (BuildReport.package report') + browse $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)] auth + return () + Right{} -> return () + where + targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given + +check :: Verbosity -> [FilePath] -> IO () +check verbosity paths = do + flip mapM_ paths $ \path -> do + notice verbosity $ "Checking " ++ path ++ "... " + handlePackage verbosity checkURI (return ()) path + +handlePackage :: Verbosity -> URI -> BrowserAction (HandleStream String) () + -> FilePath -> IO () +handlePackage verbosity uri auth path = + do req <- mkRequest uri path + p <- proxy verbosity + debug verbosity $ "\n" ++ show req + (_,resp) <- browse $ do + setProxy p + setErrHandler (warn verbosity . ("http error: "++)) + setOutHandler (debug verbosity) + auth + setAuthorityGen (\_ _ -> return Nothing) + request req + debug verbosity $ show resp + case rspCode resp of + (2,0,0) -> do notice verbosity "Ok" + (x,y,z) -> do notice verbosity $ "Error: " ++ path ++ ": " + ++ map intToDigit [x,y,z] ++ " " + ++ rspReason resp + case findHeader HdrContentType resp of + Just contenttype + | takeWhile (/= ';') contenttype == "text/plain" + -> notice verbosity $ rspBody resp + _ -> debug verbosity $ rspBody resp + +mkRequest :: URI -> FilePath -> IO (Request String) +mkRequest uri path = + do pkg <- readBinaryFile path + boundary <- genBoundary + let body = printMultiPart boundary (mkFormData path pkg) + return $ Request { + rqURI = uri, + rqMethod = POST, + rqHeaders = [Header HdrContentType ("multipart/form-data; boundary="++boundary), + Header HdrContentLength (show (length body)), + Header HdrAccept ("text/plain")], + rqBody = body + } + +readBinaryFile :: FilePath -> IO String +readBinaryFile path = openBinaryFile path ReadMode >>= hGetContents + +genBoundary :: IO String +genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer + return $ showHex i "" + +mkFormData :: FilePath -> String -> [BodyPart] +mkFormData path pkg = + -- yes, web browsers are that stupid (re quoting) + [BodyPart [Header hdrContentDisposition $ + "form-data; name=package; filename=\""++takeFileName path++"\"", + Header HdrContentType "application/x-gzip"] + pkg] + +hdrContentDisposition :: HeaderName +hdrContentDisposition = HdrCustom "Content-disposition" + +-- * Multipart, partly stolen from the cgi package. + +data BodyPart = BodyPart [Header] String + +printMultiPart :: String -> [BodyPart] -> String +printMultiPart boundary xs = + concatMap (printBodyPart boundary) xs ++ crlf ++ "--" ++ boundary ++ "--" ++ crlf + +printBodyPart :: String -> BodyPart -> String +printBodyPart boundary (BodyPart hs c) = crlf ++ "--" ++ boundary ++ crlf ++ concatMap show hs ++ crlf ++ c + +crlf :: String +crlf = "\r\n" diff --git a/cabal/cabal-install/Distribution/Client/Utils.hs b/cabal/cabal-install/Distribution/Client/Utils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Utils.hs @@ -0,0 +1,60 @@ +module Distribution.Client.Utils where + +import Data.List + ( sortBy, groupBy ) +import System.Directory + ( doesFileExist, getModificationTime + , getCurrentDirectory, setCurrentDirectory ) +import qualified Control.Exception as Exception + ( finally ) + +-- | Generic merging utility. For sorted input lists this is a full outer join. +-- +-- * The result list never contains @(Nothing, Nothing)@. +-- +mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b] +mergeBy cmp = merge + where + merge [] ys = [ OnlyInRight y | y <- ys] + merge xs [] = [ OnlyInLeft x | x <- xs] + merge (x:xs) (y:ys) = + case x `cmp` y of + GT -> OnlyInRight y : merge (x:xs) ys + EQ -> InBoth x y : merge xs ys + LT -> OnlyInLeft x : merge xs (y:ys) + +data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b + +duplicates :: Ord a => [a] -> [[a]] +duplicates = duplicatesBy compare + +duplicatesBy :: (a -> a -> Ordering) -> [a] -> [[a]] +duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp + where + eq a b = case cmp a b of + EQ -> True + _ -> False + moreThanOne (_:_:_) = True + moreThanOne _ = False + +-- | Compare the modification times of two files to see if the first is newer +-- than the second. The first file must exist but the second need not. +-- The expected use case is when the second file is generated using the first. +-- In this use case, if the result is True then the second file is out of date. +-- +moreRecentFile :: FilePath -> FilePath -> IO Bool +moreRecentFile a b = do + exists <- doesFileExist b + if not exists + then return True + else do tb <- getModificationTime b + ta <- getModificationTime a + return (ta > tb) + +-- | Executes the action in the specified directory. +inDir :: Maybe FilePath -> IO () -> IO () +inDir Nothing m = m +inDir (Just d) m = do + old <- getCurrentDirectory + setCurrentDirectory d + m `Exception.finally` setCurrentDirectory old diff --git a/cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs b/cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp -fffi #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.Win32SelfUpgrade +-- Copyright : (c) Duncan Coutts 2008 +-- License : BSD-like +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Support for self-upgrading executables on Windows platforms. +----------------------------------------------------------------------------- +module Distribution.Client.Win32SelfUpgrade ( +-- * Explanation +-- +-- | Windows inherited a design choice from DOS that while initially innocuous +-- has rather unfortunate consequences. It maintains the invariant that every +-- open file has a corresponding name on disk. One positive consequence of this +-- is that an executable can always find it's own executable file. The downside +-- is that a program cannot be deleted or upgraded while it is running without +-- hideous workarounds. This module implements one such hideous workaround. +-- +-- The basic idea is: +-- +-- * Move our own exe file to a new name +-- * Copy a new exe file to the previous name +-- * Run the new exe file, passing our own pid and new path +-- * Wait for the new process to start +-- * Close the new exe file +-- * Exit old process +-- +-- Then in the new process: +-- +-- * Inform the old process that we've started +-- * Wait for the old process to die +-- * Delete the old exe file +-- * Exit new process +-- + + possibleSelfUpgrade, + deleteOldExeFile, + ) where + +#if mingw32_HOST_OS || mingw32_TARGET_OS + +import qualified System.Win32 as Win32 +import qualified System.Win32.DLL as Win32 +import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR) +import Foreign.Ptr (Ptr, nullPtr) +import System.Process (runProcess) +import System.Directory (canonicalizePath) +import System.FilePath (takeBaseName, replaceBaseName, equalFilePath) + +import Distribution.Verbosity as Verbosity (Verbosity, showForCabal) +import Distribution.Simple.Utils (debug, info) + +import Prelude hiding (log) + +-- | If one of the given files is our own exe file then we arrange things such +-- that the nested action can replace our own exe file. +-- +-- We require that the new process accepts a command line invocation that +-- calls 'deleteOldExeFile', passing in the pid and exe file. +-- +possibleSelfUpgrade :: Verbosity + -> [FilePath] + -> IO a -> IO a +possibleSelfUpgrade verbosity newPaths action = do + dstPath <- canonicalizePath =<< Win32.getModuleFileName Win32.nullHANDLE + + newPaths' <- mapM canonicalizePath newPaths + let doingSelfUpgrade = any (equalFilePath dstPath) newPaths' + + if not doingSelfUpgrade + then action + else do + info verbosity $ "cabal-install does the replace-own-exe-file dance..." + tmpPath <- moveOurExeOutOfTheWay verbosity + result <- action + scheduleOurDemise verbosity dstPath tmpPath + (\pid path -> ["win32selfupgrade", pid, path + ,"--verbose=" ++ Verbosity.showForCabal verbosity]) + return result + +-- | The name of a Win32 Event object that we use to synchronise between the +-- old and new processes. We need to synchronise to make sure that the old +-- process has not yet terminated by the time the new one starts up and looks +-- for the old process. Otherwise the old one might have already terminated +-- and we could not wait on it terminating reliably (eg the pid might get +-- re-used). +-- +syncEventName :: String +syncEventName = "Local\\cabal-install-upgrade" + +-- | The first part of allowing our exe file to be replaced is to move the +-- existing exe file out of the way. Although we cannot delete our exe file +-- while we're still running, fortunately we can rename it, at least within +-- the same directory. +-- +moveOurExeOutOfTheWay :: Verbosity -> IO FilePath +moveOurExeOutOfTheWay verbosity = do + ourPID <- getCurrentProcessId + dstPath <- Win32.getModuleFileName Win32.nullHANDLE + + let tmpPath = replaceBaseName dstPath (takeBaseName dstPath ++ show ourPID) + + debug verbosity $ "moving " ++ dstPath ++ " to " ++ tmpPath + Win32.moveFile dstPath tmpPath + return tmpPath + +-- | Assuming we've now installed the new exe file in the right place, we +-- launch it and ask it to delete our exe file when we eventually terminate. +-- +scheduleOurDemise :: Verbosity -> FilePath -> FilePath + -> (String -> FilePath -> [String]) -> IO () +scheduleOurDemise verbosity dstPath tmpPath mkArgs = do + ourPID <- getCurrentProcessId + event <- createEvent syncEventName + + let args = mkArgs (show ourPID) tmpPath + log $ "launching child " ++ unwords (dstPath : map show args) + runProcess dstPath args Nothing Nothing Nothing Nothing Nothing + + log $ "waiting for the child to start up" + waitForSingleObject event (10*1000) -- wait at most 10 sec + log $ "child started ok" + + where + log msg = debug verbosity ("Win32Reinstall.parent: " ++ msg) + +-- | Assuming we're now in the new child process, we've been asked by the old +-- process to wait for it to terminate and then we can remove the old exe file +-- that it renamted itself to. +-- +deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () +deleteOldExeFile verbosity oldPID tmpPath = do + log $ "process started. Will delete exe file of process " + ++ show oldPID ++ " at path " ++ tmpPath + + log $ "getting handle of parent process " ++ show oldPID + oldPHANDLE <- Win32.openProcess Win32.sYNCHORNIZE False (fromIntegral oldPID) + + log $ "synchronising with parent" + event <- openEvent syncEventName + setEvent event + + log $ "waiting for parent process to terminate" + waitForSingleObject oldPHANDLE Win32.iNFINITE + log $ "parent process terminated" + + log $ "deleting parent's old .exe file" + Win32.deleteFile tmpPath + + where + log msg = debug verbosity ("Win32Reinstall.child: " ++ msg) + +------------------------ +-- Win32 foreign imports +-- + +-- A bunch of functions sadly not provided by the Win32 package. + +foreign import stdcall unsafe "windows.h GetCurrentProcessId" + getCurrentProcessId :: IO DWORD + +foreign import stdcall unsafe "windows.h WaitForSingleObject" + waitForSingleObject_ :: HANDLE -> DWORD -> IO DWORD + +waitForSingleObject :: HANDLE -> DWORD -> IO () +waitForSingleObject handle timeout = + Win32.failIf_ bad "WaitForSingleObject" $ + waitForSingleObject_ handle timeout + where + bad result = not (result == 0 || result == wAIT_TIMEOUT) + wAIT_TIMEOUT = 0x00000102 + +foreign import stdcall unsafe "windows.h CreateEventW" + createEvent_ :: Ptr () -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE + +createEvent :: String -> IO HANDLE +createEvent name = do + Win32.failIfNull "CreateEvent" $ + Win32.withTString name $ + createEvent_ nullPtr False False + +foreign import stdcall unsafe "windows.h OpenEventW" + openEvent_ :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE + +openEvent :: String -> IO HANDLE +openEvent name = do + Win32.failIfNull "OpenEvent" $ + Win32.withTString name $ + openEvent_ eVENT_MODIFY_STATE False + where + eVENT_MODIFY_STATE :: DWORD + eVENT_MODIFY_STATE = 0x0002 + +foreign import stdcall unsafe "windows.h SetEvent" + setEvent_ :: HANDLE -> IO BOOL + +setEvent :: HANDLE -> IO () +setEvent handle = + Win32.failIfFalse_ "SetEvent" $ + setEvent_ handle + +#else + +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.Utils (die) + +possibleSelfUpgrade :: Verbosity + -> [FilePath] + -> IO a -> IO a +possibleSelfUpgrade _ _ action = action + +deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO () +deleteOldExeFile _ _ _ = die "win32selfupgrade not needed except on win32" + +#endif diff --git a/cabal/cabal-install/Distribution/Client/World.hs b/cabal/cabal-install/Distribution/Client/World.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Client/World.hs @@ -0,0 +1,173 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Client.World +-- Copyright : (c) Peter Robinson 2009 +-- License : BSD-like +-- +-- Maintainer : thaldyron@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Interface to the world-file that contains a list of explicitly +-- requested packages. Meant to be imported qualified. +-- +-- A world file entry stores the package-name, package-version, and +-- user flags. +-- For example, the entry generated by +-- # cabal install stm-io-hooks --flags="-debug" +-- looks like this: +-- # stm-io-hooks -any --flags="-debug" +-- To rebuild/upgrade the packages in world (e.g. when updating the compiler) +-- use +-- # cabal install world +-- +----------------------------------------------------------------------------- +module Distribution.Client.World ( + WorldPkgInfo(..), + insert, + delete, + getContents, + ) where + +import Distribution.Package + ( Dependency(..) ) +import Distribution.PackageDescription + ( FlagAssignment, FlagName(FlagName) ) +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Simple.Utils + ( die, info, chattyTry, writeFileAtomic ) +import Distribution.Text + ( Text(..), display, simpleParse ) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ( (<>), (<+>) ) + + +import Data.Char as Char + +import Data.List + ( unionBy, deleteFirstsBy, nubBy ) +import Data.Maybe + ( isJust, fromJust ) +import System.IO.Error + ( isDoesNotExistError ) +import qualified Data.ByteString.Lazy.Char8 as B +import Prelude hiding (getContents) + + +data WorldPkgInfo = WorldPkgInfo Dependency FlagAssignment + deriving (Show,Eq) + +-- | Adds packages to the world file; creates the file if it doesn't +-- exist yet. Version constraints and flag assignments for a package are +-- updated if already present. IO errors are non-fatal. +insert :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO () +insert = modifyWorld $ unionBy equalUDep + +-- | Removes packages from the world file. +-- Note: Currently unused as there is no mechanism in Cabal (yet) to +-- handle uninstalls. IO errors are non-fatal. +delete :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO () +delete = modifyWorld $ flip (deleteFirstsBy equalUDep) + +-- | WorldPkgInfo values are considered equal if they refer to +-- the same package, i.e., we don't care about differing versions or flags. +equalUDep :: WorldPkgInfo -> WorldPkgInfo -> Bool +equalUDep (WorldPkgInfo (Dependency pkg1 _) _) + (WorldPkgInfo (Dependency pkg2 _) _) = pkg1 == pkg2 + +-- | Modifies the world file by applying an update-function ('unionBy' +-- for 'insert', 'deleteFirstsBy' for 'delete') to the given list of +-- packages. IO errors are considered non-fatal. +modifyWorld :: ([WorldPkgInfo] -> [WorldPkgInfo] + -> [WorldPkgInfo]) + -- ^ Function that defines how + -- the list of user packages are merged with + -- existing world packages. + -> Verbosity + -> FilePath -- ^ Location of the world file + -> [WorldPkgInfo] -- ^ list of user supplied packages + -> IO () +modifyWorld _ _ _ [] = return () +modifyWorld f verbosity world pkgs = + chattyTry "Error while updating world-file. " $ do + pkgsOldWorld <- getContents world + -- Filter out packages that are not in the world file: + let pkgsNewWorld = nubBy equalUDep $ f pkgs pkgsOldWorld + -- 'Dependency' is not an Ord instance, so we need to check for + -- equivalence the awkward way: + if not (all (`elem` pkgsOldWorld) pkgsNewWorld && + all (`elem` pkgsNewWorld) pkgsOldWorld) + then do + info verbosity "Updating world file..." + writeFileAtomic world $ unlines + [ (display pkg) | pkg <- pkgsNewWorld] + else + info verbosity "World file is already up to date." + + +-- | Returns the content of the world file as a list +getContents :: FilePath -> IO [WorldPkgInfo] +getContents world = do + content <- safelyReadFile world + let result = map simpleParse (lines $ B.unpack content) + if all isJust result + then return $ map fromJust result + else die "Could not parse world file." + where + safelyReadFile :: FilePath -> IO B.ByteString + safelyReadFile file = B.readFile file `catch` handler + where + handler e | isDoesNotExistError e = return B.empty + | otherwise = ioError e + + +instance Text WorldPkgInfo where + disp (WorldPkgInfo dep flags) = disp dep <+> dispFlags flags + where + dispFlags [] = Disp.empty + dispFlags fs = Disp.text "--flags=" + <> Disp.doubleQuotes (flagAssToDoc fs) + flagAssToDoc = foldr (\(FlagName fname,val) flagAssDoc -> + (if not val then Disp.char '-' + else Disp.empty) + Disp.<> Disp.text fname + Disp.<+> flagAssDoc) + Disp.empty + parse = do + dep <- parse + Parse.skipSpaces + flagAss <- Parse.option [] parseFlagAssignment + return $ WorldPkgInfo dep flagAss + where + parseFlagAssignment :: Parse.ReadP r FlagAssignment + parseFlagAssignment = do + _ <- Parse.string "--flags" + Parse.skipSpaces + _ <- Parse.char '=' + Parse.skipSpaces + inDoubleQuotes $ Parse.many1 flag + where + inDoubleQuotes :: Parse.ReadP r a -> Parse.ReadP r a + inDoubleQuotes = Parse.between (Parse.char '"') (Parse.char '"') + + flag = do + Parse.skipSpaces + val <- negative Parse.+++ positive + name <- ident + Parse.skipSpaces + return (FlagName name,val) + negative = do + _ <- Parse.char '-' + return False + positive = return True + + ident :: Parse.ReadP r String + ident = do + -- First character must be a letter/digit to avoid flags + -- like "+-debug": + c <- Parse.satisfy Char.isAlphaNum + cs <- Parse.munch (\ch -> Char.isAlphaNum ch || ch == '_' + || ch == '-') + return (c:cs) diff --git a/cabal/cabal-install/Distribution/Compat/ExceptionCI.hs b/cabal/cabal-install/Distribution/Compat/ExceptionCI.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Compat/ExceptionCI.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} +-- #hide +module Distribution.Compat.ExceptionCI ( + SomeException, + onException, + catchIO, + handleIO, + catchExit, + throwIOIO + ) where + +import System.Exit +import qualified Control.Exception as Exception +#if MIN_VERSION_base(4,0,0) +import Control.Exception (SomeException) +#else +import Control.Exception (Exception) +type SomeException = Exception +#endif + +onException :: IO a -> IO b -> IO a +#if MIN_VERSION_base(4,0,0) +onException = Exception.onException +#else +onException io what = io `Exception.catch` \e -> do what + Exception.throw e +#endif + +throwIOIO :: Exception.IOException -> IO a +#if MIN_VERSION_base(4,0,0) +throwIOIO = Exception.throwIO +#else +throwIOIO = Exception.throwIO . Exception.IOException +#endif + +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#if MIN_VERSION_base(4,0,0) +catchIO = Exception.catch +#else +catchIO = Exception.catchJust Exception.ioErrors +#endif + +handleIO :: (Exception.IOException -> IO a) -> IO a -> IO a +handleIO = flip catchIO + +catchExit :: IO a -> (ExitCode -> IO a) -> IO a +#if MIN_VERSION_base(4,0,0) +catchExit = Exception.catch +#else +catchExit = Exception.catchJust exitExceptions + where exitExceptions (Exception.ExitException ee) = Just ee + exitExceptions _ = Nothing +#endif diff --git a/cabal/cabal-install/Distribution/Compat/FilePerms.hs b/cabal/cabal-install/Distribution/Compat/FilePerms.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Distribution/Compat/FilePerms.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE CPP #-} +-- #hide +module Distribution.Compat.FilePerms ( + setFileOrdinary, + setFileExecutable, + ) where + +#ifndef mingw32_HOST_OS +import System.Posix.Types + ( FileMode ) +import System.Posix.Internals + ( c_chmod ) +import Foreign.C + ( withCString ) +#if MIN_VERSION_base(4,0,0) +import Foreign.C + ( throwErrnoPathIfMinus1_ ) +#else +import Foreign.C + ( throwErrnoIfMinus1_ ) +#endif +#endif /* mingw32_HOST_OS */ + +setFileOrdinary, setFileExecutable :: FilePath -> IO () +#ifndef mingw32_HOST_OS +setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r-- +setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x + +setFileMode :: FilePath -> FileMode -> IO () +setFileMode name m = + withCString name $ \s -> do +#if __GLASGOW_HASKELL__ >= 608 + throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) +#else + throwErrnoIfMinus1_ name (c_chmod s m) +#endif +#else +setFileOrdinary _ = return () +setFileExecutable _ = return () +#endif diff --git a/cabal/cabal-install/LICENSE b/cabal/cabal-install/LICENSE new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/LICENSE @@ -0,0 +1,34 @@ +Copyright (c) 2003-2008, Isaac Jones, Simon Marlow, Martin Sjögren, + Bjorn Bringert, Krasimir Angelov, + Malcolm Wallace, Ross Patterson, + Lemmih, Paolo Martini, Don Stewart, + Duncan Coutts +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/cabal/cabal-install/Main.hs b/cabal/cabal-install/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Main.hs @@ -0,0 +1,403 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Main +-- Copyright : (c) David Himmelstrup 2005 +-- License : BSD-like +-- +-- Maintainer : lemmih@gmail.com +-- Stability : provisional +-- Portability : portable +-- +-- Entry point to the default cabal-install front-end. +----------------------------------------------------------------------------- + +module Main (main) where + +import Distribution.Client.Setup + ( GlobalFlags(..), globalCommand, globalRepos + , ConfigFlags(..) + , ConfigExFlags(..), configureExCommand + , InstallFlags(..), defaultInstallFlags + , installCommand, upgradeCommand + , FetchFlags(..), fetchCommand + , checkCommand + , updateCommand + , ListFlags(..), listCommand + , InfoFlags(..), infoCommand + , UploadFlags(..), uploadCommand + , ReportFlags(..), reportCommand + , InitFlags, initCommand + , reportCommand + , unpackCommand, UnpackFlags(..) ) +import Distribution.Simple.Setup + ( BuildFlags(..), buildCommand + , HaddockFlags(..), haddockCommand + , HscolourFlags(..), hscolourCommand + , CopyFlags(..), copyCommand + , RegisterFlags(..), registerCommand + , CleanFlags(..), cleanCommand + , SDistFlags(..), sdistCommand + , TestFlags(..), testCommand + , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe ) + +import Distribution.Client.SetupWrapper + ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions ) +import Distribution.Client.Config + ( SavedConfig(..), loadConfig, defaultConfigFile ) +import Distribution.Client.Targets + ( readUserTargets ) + +import Distribution.Client.List (list, info) +import Distribution.Client.Install (install, upgrade) +import Distribution.Client.Configure (configure) +import Distribution.Client.Update (update) +import Distribution.Client.Fetch (fetch) +import Distribution.Client.Check as Check (check) +--import Distribution.Client.Clean (clean) +import Distribution.Client.Upload as Upload (upload, check, report) +import Distribution.Client.SrcDist (sdist) +import Distribution.Client.Unpack (unpack) +import Distribution.Client.Init (initCabal) +import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade + +import Distribution.Simple.Compiler + ( Compiler, PackageDB(..), PackageDBStack ) +import Distribution.Simple.Program + ( ProgramConfiguration, defaultProgramConfiguration ) +import Distribution.Simple.Command +import Distribution.Simple.Configure (configCompilerAux) +import Distribution.Simple.Utils + ( cabalVersion, die, topHandler, intercalate ) +import Distribution.Text + ( display ) +import Distribution.Verbosity as Verbosity + ( Verbosity, normal, intToVerbosity, lessVerbose ) +import qualified Paths_cabal_install (version) + +import System.Environment (getArgs, getProgName) +import System.Exit (exitFailure) +import System.FilePath (splitExtension, takeExtension) +import System.Directory (doesFileExist) +import Data.List (intersperse) +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid(..)) +import Control.Monad (unless) + +-- | Entry point +-- +main :: IO () +main = getArgs >>= mainWorker + +mainWorker :: [String] -> IO () +mainWorker ("win32selfupgrade":args) = win32SelfUpgradeAction args +mainWorker args = topHandler $ + case commandsRun globalCommand commands args of + CommandHelp help -> printGlobalHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (globalflags, commandParse) -> + case commandParse of + _ | fromFlag (globalVersion globalflags) -> printVersion + | fromFlag (globalNumericVersion globalflags) -> printNumericVersion + CommandHelp help -> printCommandHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action globalflags + + where + printCommandHelp help = do + pname <- getProgName + putStr (help pname) + printGlobalHelp help = do + pname <- getProgName + configFile <- defaultConfigFile + putStr (help pname) + putStr $ "\nYou can edit the cabal configuration file to set defaults:\n" + ++ " " ++ configFile ++ "\n" + printOptionsList = putStr . unlines + printErrors errs = die $ concat (intersperse "\n" errs) + printNumericVersion = putStrLn $ display Paths_cabal_install.version + printVersion = putStrLn $ "cabal-install version " + ++ display Paths_cabal_install.version + ++ "\nusing version " + ++ display cabalVersion + ++ " of the Cabal library " + + commands = + [installCommand `commandAddAction` installAction + ,updateCommand `commandAddAction` updateAction + ,listCommand `commandAddAction` listAction + ,infoCommand `commandAddAction` infoAction + ,fetchCommand `commandAddAction` fetchAction + ,unpackCommand `commandAddAction` unpackAction + ,checkCommand `commandAddAction` checkAction + ,sdistCommand `commandAddAction` sdistAction + ,uploadCommand `commandAddAction` uploadAction + ,reportCommand `commandAddAction` reportAction + ,initCommand `commandAddAction` initAction + ,configureExCommand `commandAddAction` configureAction + ,wrapperAction (buildCommand defaultProgramConfiguration) + buildVerbosity buildDistPref + ,wrapperAction copyCommand + copyVerbosity copyDistPref + ,wrapperAction haddockCommand + haddockVerbosity haddockDistPref + ,wrapperAction cleanCommand + cleanVerbosity cleanDistPref + ,wrapperAction hscolourCommand + hscolourVerbosity hscolourDistPref + ,wrapperAction registerCommand + regVerbosity regDistPref + ,wrapperAction testCommand + testVerbosity testDistPref + ,upgradeCommand `commandAddAction` upgradeAction + ] + +wrapperAction :: Monoid flags + => CommandUI flags + -> (flags -> Flag Verbosity) + -> (flags -> Flag String) + -> Command (GlobalFlags -> IO ()) +wrapperAction command verbosityFlag distPrefFlag = + commandAddAction command + { commandDefaultFlags = mempty } $ \flags extraArgs _globalFlags -> do + let verbosity = fromFlagOrDefault normal (verbosityFlag flags) + setupScriptOptions = defaultSetupScriptOptions { + useDistPref = fromFlagOrDefault + (useDistPref defaultSetupScriptOptions) + (distPrefFlag flags) + } + setupWrapper verbosity setupScriptOptions Nothing + command (const flags) extraArgs + +configureAction :: (ConfigFlags, ConfigExFlags) + -> [String] -> GlobalFlags -> IO () +configureAction (configFlags, configExFlags) extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + config <- loadConfig verbosity (globalConfigFile globalFlags) + (configUserInstall configFlags) + let configFlags' = savedConfigureFlags config `mappend` configFlags + configExFlags' = savedConfigureExFlags config `mappend` configExFlags + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, conf) <- configCompilerAux configFlags' + configure verbosity + (configPackageDB' configFlags') (globalRepos globalFlags') + comp conf configFlags' configExFlags' extraArgs + +installAction :: (ConfigFlags, ConfigExFlags, InstallFlags) + -> [String] -> GlobalFlags -> IO () +installAction (configFlags, _, installFlags) _ _globalFlags + | fromFlagOrDefault False (installOnly installFlags) + = let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + in setupWrapper verbosity defaultSetupScriptOptions Nothing + installCommand (const mempty) [] + +installAction (configFlags, configExFlags, installFlags) + extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + targets <- readUserTargets verbosity extraArgs + config <- loadConfig verbosity (globalConfigFile globalFlags) + (configUserInstall configFlags) + let configFlags' = savedConfigureFlags config `mappend` configFlags + configExFlags' = savedConfigureExFlags config `mappend` configExFlags + installFlags' = defaultInstallFlags `mappend` + savedInstallFlags config `mappend` installFlags + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, conf) <- configCompilerAux' configFlags' + install verbosity + (configPackageDB' configFlags') (globalRepos globalFlags') + comp conf globalFlags' configFlags' configExFlags' installFlags' + targets + +listAction :: ListFlags -> [String] -> GlobalFlags -> IO () +listAction listFlags extraArgs globalFlags = do + let verbosity = fromFlag (listVerbosity listFlags) + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, conf) <- configCompilerAux' configFlags + list verbosity + (configPackageDB' configFlags) + (globalRepos globalFlags') + comp + conf + listFlags + extraArgs + +infoAction :: InfoFlags -> [String] -> GlobalFlags -> IO () +infoAction infoFlags extraArgs globalFlags = do + let verbosity = fromFlag (infoVerbosity infoFlags) + targets <- readUserTargets verbosity extraArgs + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, conf) <- configCompilerAux configFlags + info verbosity + (configPackageDB' configFlags) + (globalRepos globalFlags') + comp + conf + globalFlags' + infoFlags + targets + +updateAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO () +updateAction verbosityFlag extraArgs globalFlags = do + unless (null extraArgs) $ do + die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs + let verbosity = fromFlag verbosityFlag + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + update verbosity (globalRepos globalFlags') + +upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags) + -> [String] -> GlobalFlags -> IO () +upgradeAction (configFlags, configExFlags, installFlags) + extraArgs globalFlags = do + let verbosity = fromFlagOrDefault normal (configVerbosity configFlags) + targets <- readUserTargets verbosity extraArgs + config <- loadConfig verbosity (globalConfigFile globalFlags) + (configUserInstall configFlags) + let configFlags' = savedConfigureFlags config `mappend` configFlags + configExFlags' = savedConfigureExFlags config `mappend` configExFlags + installFlags' = defaultInstallFlags `mappend` + savedInstallFlags config `mappend` installFlags + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, conf) <- configCompilerAux' configFlags' + upgrade verbosity + (configPackageDB' configFlags') (globalRepos globalFlags') + comp conf globalFlags' configFlags' configExFlags' installFlags' + targets + +fetchAction :: FetchFlags -> [String] -> GlobalFlags -> IO () +fetchAction fetchFlags extraArgs globalFlags = do + let verbosity = fromFlag (fetchVerbosity fetchFlags) + targets <- readUserTargets verbosity extraArgs + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let configFlags = savedConfigureFlags config + globalFlags' = savedGlobalFlags config `mappend` globalFlags + (comp, conf) <- configCompilerAux' configFlags + fetch verbosity + (configPackageDB' configFlags) (globalRepos globalFlags') + comp conf globalFlags' fetchFlags + targets + +uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO () +uploadAction uploadFlags extraArgs globalFlags = do + let verbosity = fromFlag (uploadVerbosity uploadFlags) + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let uploadFlags' = savedUploadFlags config `mappend` uploadFlags + globalFlags' = savedGlobalFlags config `mappend` globalFlags + tarfiles = extraArgs + checkTarFiles extraArgs + if fromFlag (uploadCheck uploadFlags') + then Upload.check verbosity tarfiles + else upload verbosity + (globalRepos globalFlags') + (flagToMaybe $ uploadUsername uploadFlags') + (flagToMaybe $ uploadPassword uploadFlags') + tarfiles + where + checkTarFiles tarfiles + | null tarfiles + = die "the 'upload' command expects one or more .tar.gz packages." + | not (null otherFiles) + = die $ "the 'upload' command expects only .tar.gz packages: " + ++ intercalate ", " otherFiles + | otherwise = sequence_ + [ do exists <- doesFileExist tarfile + unless exists $ die $ "file not found: " ++ tarfile + | tarfile <- tarfiles ] + + where otherFiles = filter (not . isTarGzFile) tarfiles + isTarGzFile file = case splitExtension file of + (file', ".gz") -> takeExtension file' == ".tar" + _ -> False + +checkAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO () +checkAction verbosityFlag extraArgs _globalFlags = do + unless (null extraArgs) $ do + die $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs + allOk <- Check.check (fromFlag verbosityFlag) + unless allOk exitFailure + + +sdistAction :: SDistFlags -> [String] -> GlobalFlags -> IO () +sdistAction sflags extraArgs _globalFlags = do + unless (null extraArgs) $ do + die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs + sdist sflags + +reportAction :: ReportFlags -> [String] -> GlobalFlags -> IO () +reportAction reportFlags extraArgs globalFlags = do + unless (null extraArgs) $ do + die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs + + let verbosity = fromFlag (reportVerbosity reportFlags) + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + reportFlags' = savedReportFlags config `mappend` reportFlags + + Upload.report verbosity (globalRepos globalFlags') + (flagToMaybe $ reportUsername reportFlags') + (flagToMaybe $ reportPassword reportFlags') + +unpackAction :: UnpackFlags -> [String] -> GlobalFlags -> IO () +unpackAction unpackFlags extraArgs globalFlags = do + let verbosity = fromFlag (unpackVerbosity unpackFlags) + targets <- readUserTargets verbosity extraArgs + config <- loadConfig verbosity (globalConfigFile globalFlags) mempty + let globalFlags' = savedGlobalFlags config `mappend` globalFlags + unpack verbosity + (globalRepos (savedGlobalFlags config)) + globalFlags' + unpackFlags + targets + +initAction :: InitFlags -> [String] -> GlobalFlags -> IO () +initAction flags _extraArgs _globalFlags = do + initCabal flags + +-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. +-- +win32SelfUpgradeAction :: [String] -> IO () +win32SelfUpgradeAction (pid:path:rest) = + Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path + where + verbosity = case rest of + (['-','-','v','e','r','b','o','s','e','=',n]:_) | n `elem` ['0'..'9'] + -> fromMaybe Verbosity.normal (Verbosity.intToVerbosity (read [n])) + _ -> Verbosity.normal +win32SelfUpgradeAction _ = return () + +-- +-- Utils (transitionary) +-- + +-- | Currently the user interface specifies the package dbs to use with just a +-- single valued option, a 'PackageDB'. However internally we represent the +-- stack of 'PackageDB's explictly as a list. This function converts encodes +-- the package db stack implicit in a single packagedb. +-- +-- TODO: sort this out, make it consistent with the command line UI +implicitPackageDbStack :: Bool -> Maybe PackageDB -> PackageDBStack +implicitPackageDbStack userInstall packageDbFlag + | userInstall = GlobalPackageDB : UserPackageDB : extra + | otherwise = GlobalPackageDB : extra + where + extra = case packageDbFlag of + Just (SpecificPackageDB db) -> [SpecificPackageDB db] + _ -> [] + +configPackageDB' :: ConfigFlags -> PackageDBStack +configPackageDB' cfg = + implicitPackageDbStack userInstall (flagToMaybe (configPackageDB cfg)) + where + userInstall = fromFlagOrDefault True (configUserInstall cfg) + +configCompilerAux' :: ConfigFlags + -> IO (Compiler, ProgramConfiguration) +configCompilerAux' configFlags = + configCompilerAux configFlags + --FIXME: make configCompilerAux use a sensible verbosity + { configVerbosity = fmap lessVerbose (configVerbosity configFlags) } diff --git a/cabal/cabal-install/Paths_cabal_install.hs b/cabal/cabal-install/Paths_cabal_install.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Paths_cabal_install.hs @@ -0,0 +1,8 @@ +module Paths_cabal_install ( + version, + ) where + +import Data.Version (Version(..)) + +version :: Version +version = Version {versionBranch = [0,12,0], versionTags = []} diff --git a/cabal/cabal-install/README b/cabal/cabal-install/README new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/README @@ -0,0 +1,153 @@ +The cabal-install package +========================= + +[Cabal home page](http://www.haskell.org/cabal/) + +The `cabal-install` package provides a command line tool called `cabal`. The +tool uses the `Cabal` library and provides a convenient user interface to the +Cabal/Hackage package build and distribution system. It can build and install +both local and remote packages, including dependencies. + + +Installation instructions for the cabal-install command line tool +================================================================= + +The `cabal-install` package requires a number of other packages, most of which +come with a standard ghc installation. It requires the `network` package, which +is sometimes packaged separately by Linux distributions, for example on +debian or ubuntu it is in "libghc6-network-dev". + +It requires a few other Haskell packages that are not always installed: + + * Cabal (version 1.10 or later) + * HTTP (version 4000 or later) + * zlib (version 0.4 or later) + +All of these are available from [Hackage](http://hackage.haskell.org). + +Note that on some Unix systems you may need to install an additional zlib +development package using your system package manager, for example on +debian or ubuntu it is in "zlib1g-dev". It is needed is because the +Haskell zlib package uses the system zlib C library and header files. + +The `cabal-install` package is now part of the Haskell Platform so you do not +usually need to install it separately. However if you are starting from a +minimal ghc installation then you need to install `cabal-install` manually. +Since it is just an ordinary Cabal package it can be built in the standard +way, but to make it a bit easier we have partly automated the process: + + +Quickstart on Unix systems +-------------------------- + +As a convenience for users on Unix systems there is a `bootstrap.sh` script +which will download and install each of the dependencies in turn. + + $ ./bootstrap.sh + +It will download and install the above three dependencies. The script will +install the library packages into `$HOME/.cabal/` and the `cabal` program will +be installed into `$HOME/.cabal/bin/`. + +You then have two choices: + + * put `$HOME/.cabal/bin` on your `$PATH` + * move the `cabal` program somewhere that is on your `$PATH` + +The next thing to do is to get the latest list of packages with: + + $ cabal update + +This will also create a default config file (if it does not already echo exist) +at `$HOME/.cabal/config` + +By default cabal will install programs to `$HOME/.cabal/bin`. If you do not +want to add this directory to your `$PATH` then you can change the setting in +the config file, for example you could use: + + symlink-bindir: $HOME/bin + + +Quickstart on Windows systems +----------------------------- + +For Windows users we provide a pre-compiled [cabal.exe] program. Just download +it and put it somewhere on your `%PATH%`, for example +`C:\Program Files\Haskell\bin`. + +[cabal.exe]: http://haskell.org/cabal/release/cabal-install-latest/cabal.exe + +The next thing to do is to get the latest list of packages with + + cabal update + +This will also create a default config file (if it does not already echo exist) +at `C:\Documents and Settings\username\Application Data\cabal\config` + + +Using cabal-install +=================== + +There are two sets of commands: commands for working with a local project build +tree and ones for working with distributed released packages from hackage. + +For a list of the full set of commands and the flags for each command see + + $ cabal --help + + +Commands for developers for local build trees +--------------------------------------------- + +The commands for local project build trees are almost exactly the same as the +`runghc Setup` command line interface that many people are already familiar +with. In particular there are the commands + + cabal configure + cabal build + cabal haddock + cabal clean + cabal sdist + +The `install` command is somewhat different. It is an all-in-one operation. If +you run + + $ cabal install + +in your build tree it will configure, build and install. It takes all the flags +that `configure` takes such as `--global` and `--prefix`. + +In addition, if any dependencies are not installed it will download and install +them. If can also rebuild packages to ensure a consistent set of dependencies. + + +Commands for released hackage packages +-------------------------------------- + + $ cabal update + +This command gets the latest list of packages from the hackage server. +Currently this command has to be run manually occasionally, in particular if +you want to install a newly released package. + + + $ cabal install xmonad + +This is the eponymous command. It installs one or more named packages (and all +their dependencies) from hackage. + +By default it installs the latest available version however you can optionally +specify exact versions or version ranges. For example `cabal install alex-2.2` +or `cabal install parsec < 3`. + + $ cabal upgrade xmonad + +This is a variation on the `install` command. Both mean to install the latest +version, the only difference is in the treatment of dependencies. The `install` +command tries to use existing installed versions of dependent packages while +the `upgrade` command tries to upgrade all the dependencies too. + + $ cabal list xml + +This does a search of the installed and available packages. It does a +case-insensitive substring match on the package name. diff --git a/cabal/cabal-install/Setup.hs b/cabal/cabal-install/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/cabal-install/bash-completion/cabal b/cabal/cabal-install/bash-completion/cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/bash-completion/cabal @@ -0,0 +1,24 @@ +# cabal command line completion +# Copyright 2007-2008 "Lennart Kolmodin" +# "Duncan Coutts" +# + +_cabal() +{ + # get the word currently being completed + local cur + cur=${COMP_WORDS[$COMP_CWORD]} + + # create a command line to run + local cmd + # copy all words the user has entered + cmd=( ${COMP_WORDS[@]} ) + + # replace the current word with --list-options + cmd[${COMP_CWORD}]="--list-options" + + # the resulting completions should be put into this array + COMPREPLY=( $( compgen -W "$( ${cmd[@]} )" -- $cur ) ) +} + +complete -F _cabal -o default cabal diff --git a/cabal/cabal-install/bootstrap.sh b/cabal/cabal-install/bootstrap.sh new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/bootstrap.sh @@ -0,0 +1,231 @@ +#!/bin/sh + +# A script to bootstrap cabal-install. + +# It works by downloading and installing the Cabal, zlib and +# HTTP packages. It then installs cabal-install itself. +# It expects to be run inside the cabal-install directory. + +# install settings, you can override these by setting environment vars +PREFIX=${PREFIX:-${HOME}/.cabal} +#VERBOSE +#EXTRA_CONFIGURE_OPTS + +# programs, you can override these by setting environment vars +GHC=${GHC:-ghc} +GHC_PKG=${GHC_PKG:-ghc-pkg} +WGET=${WGET:-wget} +CURL=${CURL:-curl} +FETCH=${FETCH:-fetch} +TAR=${TAR:-tar} +GUNZIP=${GUNZIP:-gunzip} +SCOPE_OF_INSTALLATION="--user" + + +for arg in $* +do + case "${arg}" in + "--user") + SCOPE_OF_INSTALLATION=${arg} + shift;; + "--global") + SCOPE_OF_INSTALLATION=${arg} + PREFIX="/usr/local" + shift;; + *) + echo "Unknown argument or option, quitting: ${arg}" + echo "usage: bootstrap.sh [OPTION]" + echo + echo "options:" + echo " --user Install for the local user (default)" + echo " --global Install systemwide (must be run as root)" + exit;; + esac +done + + +# Versions of the packages to install. +# The version regex says what existing installed versions are ok. +PARSEC_VER="3.1.1"; PARSEC_VER_REGEXP="[23]\." # == 2.* || == 3.* +NETWORK_VER="2.3.0.2"; NETWORK_VER_REGEXP="2\." # == 2.* +CABAL_VER="1.10.1.0"; CABAL_VER_REGEXP="1\.10\.[^0]" # == 1.10.* && >= 1.10.1 +TRANS_VER="0.2.2.0"; TRANS_VER_REGEXP="0\.2\." # == 0.2.* +MTL_VER="2.0.1.0"; MTL_VER_REGEXP="[12]\." # == 1.* || == 2.* +HTTP_VER="4000.1.1"; HTTP_VER_REGEXP="4000\.[01]\." # == 4000.0.* || 4000.1.* +ZLIB_VER="0.5.3.1"; ZLIB_VER_REGEXP="0\.[45]\." # == 0.4.* || ==0.5.* +TIME_VER="1.2.0.4" TIME_VER_REGEXP="1\.[12]\." # == 0.1.* || ==0.2.* + +HACKAGE_URL="http://hackage.haskell.org/packages/archive" + +die () { + echo + echo "Error during cabal-install bootstrap:" + echo $1 >&2 + exit 2 +} + +# Check we're in the right directory: +grep "cabal-install" ./cabal-install.cabal > /dev/null 2>&1 \ + || die "The bootstrap.sh script must be run in the cabal-install directory" + +${GHC} --numeric-version > /dev/null \ + || die "${GHC} not found (or could not be run). If ghc is installed make sure it is on your PATH or set the GHC and GHC_PKG vars." +${GHC_PKG} --version > /dev/null \ + || die "${GHC_PKG} not found." +GHC_VER=`${GHC} --numeric-version` +GHC_PKG_VER=`${GHC_PKG} --version | cut -d' ' -f 5` +[ ${GHC_VER} = ${GHC_PKG_VER} ] \ + || die "Version mismatch between ${GHC} and ${GHC_PKG} If you set the GHC variable then set GHC_PKG too" + +# Cache the list of packages: +echo "Checking installed packages for ghc-${GHC_VER}..." +${GHC_PKG} list --global ${SCOPE_OF_INSTALLATION} > ghc-pkg.list \ + || die "running '${GHC_PKG} list' failed" + +# Will we need to install this package, or is a suitable version installed? +need_pkg () { + PKG=$1 + VER_MATCH=$2 + if grep " ${PKG}-${VER_MATCH}" ghc-pkg.list > /dev/null 2>&1 + then + return 1; + else + return 0; + fi + #Note: we cannot use "! grep" here as Solaris 9 /bin/sh doesn't like it. +} + +info_pkg () { + PKG=$1 + VER=$2 + VER_MATCH=$3 + + if need_pkg ${PKG} ${VER_MATCH} + then + echo "${PKG}-${VER} will be downloaded and installed." + else + echo "${PKG} is already installed and the version is ok." + fi +} + +fetch_pkg () { + PKG=$1 + VER=$2 + + URL=${HACKAGE_URL}/${PKG}/${VER}/${PKG}-${VER}.tar.gz + if which ${CURL} > /dev/null + then + ${CURL} --fail -C - -O ${URL} || die "Failed to download ${PKG}." + elif which ${WGET} > /dev/null + then + ${WGET} -c ${URL} || die "Failed to download ${PKG}." + elif which ${FETCH} > /dev/null + then + ${FETCH} ${URL} || die "Failed to download ${PKG}." + else + die "Failed to find a downloader. 'curl', 'wget' or 'fetch' is required." + fi + [ -f "${PKG}-${VER}.tar.gz" ] \ + || die "Downloading ${URL} did not create ${PKG}-${VER}.tar.gz" +} + +unpack_pkg () { + PKG=$1 + VER=$2 + + rm -rf "${PKG}-${VER}.tar" "${PKG}-${VER}"/ + ${GUNZIP} -f "${PKG}-${VER}.tar.gz" \ + || die "Failed to gunzip ${PKG}-${VER}.tar.gz" + ${TAR} -xf "${PKG}-${VER}.tar" \ + || die "Failed to untar ${PKG}-${VER}.tar.gz" + [ -d "${PKG}-${VER}" ] \ + || die "Unpacking ${PKG}-${VER}.tar.gz did not create ${PKG}-${VER}/" +} + +install_pkg () { + PKG=$1 + + [ -x Setup ] && ./Setup clean + [ -f Setup ] && rm Setup + + ${GHC} --make Setup -o Setup \ + || die "Compiling the Setup script failed" + [ -x Setup ] || die "The Setup script does not exist or cannot be run" + + ./Setup configure ${SCOPE_OF_INSTALLATION} "--prefix=${PREFIX}" \ + --with-compiler=${GHC} --with-hc-pkg=${GHC_PKG} \ + ${EXTRA_CONFIGURE_OPTS} ${VERBOSE} \ + || die "Configuring the ${PKG} package failed" + + ./Setup build ${VERBOSE} \ + || die "Building the ${PKG} package failed" + + ./Setup install ${VERBOSE} \ + || die "Installing the ${PKG} package failed" +} + +do_pkg () { + PKG=$1 + VER=$2 + VER_MATCH=$3 + + if need_pkg ${PKG} ${VER_MATCH} + then + echo + echo "Downloading ${PKG}-${VER}..." + fetch_pkg ${PKG} ${VER} + unpack_pkg ${PKG} ${VER} + cd "${PKG}-${VER}" + install_pkg ${PKG} ${VER} + cd .. + fi +} + +# Actually do something! + +info_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP} +info_pkg "transformers" ${TRANS_VER} ${TRANS_VER_REGEXP} +info_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP} +info_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP} +info_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP} +info_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP} +info_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP} +info_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP} + +do_pkg "Cabal" ${CABAL_VER} ${CABAL_VER_REGEXP} +do_pkg "transformers" ${TRANS_VER} ${TRANS_VER_REGEXP} +do_pkg "mtl" ${MTL_VER} ${MTL_VER_REGEXP} +do_pkg "parsec" ${PARSEC_VER} ${PARSEC_VER_REGEXP} +do_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP} +do_pkg "time" ${TIME_VER} ${TIME_VER_REGEXP} +do_pkg "HTTP" ${HTTP_VER} ${HTTP_VER_REGEXP} +do_pkg "zlib" ${ZLIB_VER} ${ZLIB_VER_REGEXP} + +install_pkg "cabal-install" + +echo +echo "===========================================" +CABAL_BIN="$PREFIX/bin" +if [ -x "$CABAL_BIN/cabal" ] +then + echo "The 'cabal' program has been installed in $CABAL_BIN/" + echo "You should either add $CABAL_BIN to your PATH" + echo "or copy the cabal program to a directory that is on your PATH." + echo + echo "The first thing to do is to get the latest list of packages with:" + echo " cabal update" + echo "This will also create a default config file (if it does not already" + echo "exist) at $HOME/.cabal/config" + echo + echo "By default cabal will install programs to $HOME/.cabal/bin" + echo "If you do not want to add this directory to your PATH then you can" + echo "change the setting in the config file, for example you could use:" + echo "symlink-bindir: $HOME/bin" +else + echo "Sorry, something went wrong." + echo "The 'cabal' executable was not successfully installed into" + echo "$CABAL_BIN/" +fi +echo + +rm ghc-pkg.list diff --git a/cabal/cabal-install/cabal-install.cabal b/cabal/cabal-install/cabal-install.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/cabal-install.cabal @@ -0,0 +1,120 @@ +Name: cabal-install +Version: 0.11.2 +Synopsis: The command-line interface for Cabal and Hackage. +Description: + The \'cabal\' command-line program simplifies the process of managing + Haskell software by automating the fetching, configuration, compilation + and installation of Haskell libraries and programs. +homepage: http://www.haskell.org/cabal/ +bug-reports: http://hackage.haskell.org/trac/hackage/ +License: BSD3 +License-File: LICENSE +Author: Lemmih + Paolo Martini + Bjorn Bringert + Isaac Potoczny-Jones + Duncan Coutts +Maintainer: cabal-devel@haskell.org +Copyright: 2005 Lemmih + 2006 Paolo Martini + 2007 Bjorn Bringert + 2007 Isaac Potoczny-Jones + 2007-2011 Duncan Coutts +Category: Distribution +Build-type: Simple +Extra-Source-Files: README bash-completion/cabal bootstrap.sh +Cabal-Version: >= 1.6 + +source-repository head + type: darcs + location: http://darcs.haskell.org/cabal-install/ + +flag old-base + description: Old, monolithic base + default: False + +flag bytestring-in-base + +Executable cabal + Main-Is: Main.hs + -- We want assertion checking on even if people build with -O + -- although it is expensive, we want to catch problems early: + ghc-options: -Wall -fno-ignore-asserts + if impl(ghc >= 6.8) + ghc-options: -fwarn-tabs + Other-Modules: + Distribution.Client.BuildReports.Anonymous + Distribution.Client.BuildReports.Storage + Distribution.Client.BuildReports.Types + Distribution.Client.BuildReports.Upload + Distribution.Client.Check + Distribution.Client.Config + Distribution.Client.Configure + Distribution.Client.Dependency + Distribution.Client.Dependency.TopDown + Distribution.Client.Dependency.TopDown.Constraints + Distribution.Client.Dependency.TopDown.Types + Distribution.Client.Dependency.Types + Distribution.Client.Fetch + Distribution.Client.FetchUtils + Distribution.Client.GZipUtils + Distribution.Client.Haddock + Distribution.Client.HttpUtils + Distribution.Client.IndexUtils + Distribution.Client.Init + Distribution.Client.Init.Heuristics + Distribution.Client.Init.Licenses + Distribution.Client.Init.Types + Distribution.Client.Install + Distribution.Client.InstallPlan + Distribution.Client.InstallSymlink + Distribution.Client.List + Distribution.Client.PackageIndex + Distribution.Client.PackageUtils + Distribution.Client.Setup + Distribution.Client.SetupWrapper + Distribution.Client.SrcDist + Distribution.Client.Tar + Distribution.Client.Targets + Distribution.Client.Types + Distribution.Client.Unpack + Distribution.Client.Update + Distribution.Client.Upload + Distribution.Client.Utils + Distribution.Client.World + Distribution.Client.Win32SelfUpgrade + Distribution.Compat.Exception + Distribution.Compat.FilePerms + Paths_cabal_install + + build-depends: base >= 2 && < 5, + Cabal >= 1.10.1 && < 1.11.3, + filepath >= 1.0 && < 1.3, + network >= 1 && < 3, + HTTP >= 4000.0.2 && < 4001, + zlib >= 0.4 && < 0.6, + time >= 1.1 && < 1.3 + + if flag(old-base) + build-depends: base < 3 + else + build-depends: base >= 3, + process >= 1 && < 1.1, + directory >= 1 && < 1.2, + pretty >= 1 && < 1.1, + random >= 1 && < 1.1, + containers >= 0.1 && < 0.5, + array >= 0.1 && < 0.4, + old-time >= 1 && < 1.1 + + if flag(bytestring-in-base) + build-depends: base >= 2.0 && < 2.2 + else + build-depends: base < 2.0 || >= 3.0, bytestring >= 0.9 + + if os(windows) + build-depends: Win32 >= 2 && < 3 + cpp-options: -DWIN32 + else + build-depends: unix >= 1.0 && < 2.5 + extensions: CPP diff --git a/cabal/cabal-install/changelog b/cabal/cabal-install/changelog new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/changelog @@ -0,0 +1,121 @@ +-*-change-log-*- + +0.10.0 Duncan Coutts February 2011 + * New package targets: local dirs, local and remote tarballs + * Initial support for a "world" package target + * Partial fix for situation where user packages mask global ones + * Removed cabal upgrade, new --upgrade-dependencies flag + * New cabal install --only-dependencies flag + * New cabal fetch --no-dependencies and --dry-run flags + * Improved output for cabal info + * Simpler and faster bash command line completion + * Fix for broken proxies that decompress wrongly + * Fix for cabal unpack to preserve executable permissions + * Adjusted the output for the -v verbosity level in a few places + +0.8.2 Duncan Coutts March 2010 + * Fix for cabal update on Windows + * On windows switch to per-user installs (rather than global) + * Handle intra-package dependencies in dependency planning + * Minor tweaks to cabal init feature + * Fix various -Wall warnings + * Fix for cabal sdist --snapshot + +0.8.0 Duncan Coutts Dec 2009 + * Works with ghc-6.12 + * New "cabal init" command for making initial project .cabal file + * New feature to maintain an index of haddock documentation + +0.6.4 Duncan Coutts Nov 2009 + * Improve the algorithm for selecting the base package version + * Hackage errors now reported by "cabal upload [--check]" + * Improved format of messages from "cabal check" + * Config file can now be selected by an env var + * Updated tar reading/writing code + * Improve instructions in the README and bootstrap output + * Fix bootstrap.sh on Solaris 9 + * Fix bootstrap for systems where network uses parsec 3 + * Fix building with ghc-6.6 + +0.6.2 Duncan Coutts Feb 2009 + * The upgrade command has been disabled in this release + * The configure and install commands now have consistent behaviour + * Reduce the tendancy to re-install already existing packages + * The --constraint= flag now works for the install command + * New --preference= flag for soft constraints / version preferences + * Improved bootstrap.sh script, smarter and better error checking + * New cabal info command to display detailed info on packages + * New cabal unpack command to download and untar a package + * HTTP-4000 package required, should fix bugs with http proxies + * Now works with authenticated proxies. + * On Windows can now override the proxy setting using an env var + * Fix compatability with config files generated by older versions + * Warn if the hackage package list is very old + * More helpful --help output, mention config file and examples + * Better documentation in ~/.cabal/config file + * Improved command line interface for logging and build reporting + * Minor improvements to some messages + +0.6.0 Duncan Coutts Oct 2008 + * Constraint solver can now cope with base 3 and base 4 + * Allow use of package version preferences from hackage index + * More detailed output from cabal install --dry-run -v + * Improved bootstrap.sh + +0.5.2 Duncan Coutts Aug 2008 + * Suport building haddock documentaion + * Self-reinstall now works on Windows + * Allow adding symlinks to excutables into a separate bindir + * New self-documenting config file + * New install --reinstall flag + * More helpful status messages in a couple places + * Upload failures now report full text error message from the server + * Support for local package repositories + * New build logging and reporting + * New command to upload build reports to (a compatible) server + * Allow tilde in hackage server URIs + * Internal code improvements + * Many other minor improvements and bug fixes + +0.5.1 Duncan Coutts June 2008 + * Restore minimal hugs support in dependency resolver + * Fix for disabled http proxies on Windows + * Revert to global installs on Windows by default + +0.5.0 Duncan Coutts June 2008 + * New package dependency resolver, solving diamond dep problem + * Integrate cabal-setup functionality + * Integrate cabal-upload functionality + * New cabal update and check commands + * Improved behavior for install and upgrade commands + * Full Windows support + * New command line handling + * Bash command line completion + * Allow case insensitive package names on command line + * New --dry-run flag for install, upgrade and fetch commands + * New --root-cmd flag to allow installing as root + * New --cabal-lib-version flag to select different Cabal lib versions + * Support for HTTP proxies + * Improved cabal list output + * Build other non-dependent packages even when some fail + * Report a summary of all build failures at the end + * Partial support for hugs + * Partial implementation of build reporting and logging + * More consistent logging and verbosity + * Significant internal code restructuring + +0.4 Duncan Coutts Oct 2007 + * Renamed executable from 'cabal-install' to 'cabal' + * Partial Windows compatability + * Do per-user installs by default + * cabal install now installs the package in the current directory + * Allow multiple remote servers + * Use zlib lib and internal tar code and rather than external tar + * Reorganised configuration files + * Significant code restructuring + * Cope with packages with conditional dependencies + +0.3 and older versions by Lemmih, Paolo Martini and others 2006-2007 + * Switch from smart-server, dumb-client model to the reverse + * New .tar.gz based index format + * New remote and local package archive format diff --git a/cabal/cabal-install/tests/test-cabal-install b/cabal/cabal-install/tests/test-cabal-install new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/test-cabal-install @@ -0,0 +1,9 @@ +#!/bin/sh + +darcs get --partial http://darcs.haskell.org/packages/Cabal/ && \ +cd Cabal/cabal-install && \ +make && \ +sudo make install && \ +sudo cabal-install update && \ +cabal-install install --prefix=/tmp --user hnop && \ +ls -l /tmp/bin/hnop diff --git a/cabal/cabal-install/tests/test-cabal-install-user b/cabal/cabal-install/tests/test-cabal-install-user new file mode 100644 --- /dev/null +++ b/cabal/cabal-install/tests/test-cabal-install-user @@ -0,0 +1,8 @@ +#!/bin/sh + +darcs get --partial http://darcs.haskell.org/packages/Cabal/ && \ +cd Cabal/cabal-install && \ +make install-user && \ +cabal-install update && \ +cabal-install install --prefix=/tmp --user hnop && \ +ls -l /tmp/bin/hnop diff --git a/cabal/cabal/Cabal.cabal b/cabal/cabal/Cabal.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/Cabal.cabal @@ -0,0 +1,163 @@ +Name: Cabal +Version: 1.12.0 +Copyright: 2003-2006, Isaac Jones + 2005-2011, Duncan Coutts +License: BSD3 +License-File: LICENSE +Author: Isaac Jones + Duncan Coutts +Maintainer: cabal-devel@haskell.org +Homepage: http://www.haskell.org/cabal/ +bug-reports: http://hackage.haskell.org/trac/hackage/ +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 part of a larger infrastructure for distributing, + organizing, and cataloging Haskell libraries and tools. +Category: Distribution +cabal-version: >=1.10 +Build-Type: Custom +-- Even though we do use the default Setup.lhs it's vital to bootstrapping +-- that we build Setup.lhs using our own local Cabal source code. + +Extra-Source-Files: + README changelog + +source-repository head + type: darcs + location: http://darcs.haskell.org/cabal/ + +Flag base4 + Description: Choose the even newer, even smaller, split-up base package. + +Flag base3 + Description: Choose the new smaller, split-up base package. + +Library + build-depends: base >= 2 && < 5, + filepath >= 1 && < 1.3 + if flag(base4) { build-depends: base >= 4 } else { build-depends: base < 4 } + if flag(base3) { build-depends: base >= 3 } else { build-depends: base < 3 } + if flag(base3) + Build-Depends: directory >= 1 && < 1.2, + process >= 1 && < 1.2, + old-time >= 1 && < 1.1, + containers >= 0.1 && < 0.5, + array >= 0.1 && < 0.4, + pretty >= 1 && < 1.2 + + if !os(windows) + Build-Depends: unix >= 2.0 && < 2.6 + + ghc-options: -Wall -fno-ignore-asserts + if impl(ghc >= 6.8) + ghc-options: -fwarn-tabs + nhc98-Options: -K4M + + Exposed-Modules: + Distribution.Compiler, + Distribution.InstalledPackageInfo, + Distribution.License, + Distribution.Make, + Distribution.ModuleName, + Distribution.Package, + Distribution.PackageDescription, + Distribution.PackageDescription.Configuration, + Distribution.PackageDescription.Parse, + Distribution.PackageDescription.Check, + Distribution.PackageDescription.PrettyPrint, + Distribution.ParseUtils, + Distribution.ReadE, + Distribution.Simple, + Distribution.Simple.Build, + Distribution.Simple.Build.Macros, + Distribution.Simple.Build.PathsModule, + Distribution.Simple.BuildPaths, + Distribution.Simple.Command, + Distribution.Simple.Compiler, + Distribution.Simple.Configure, + Distribution.Simple.GHC, + Distribution.Simple.LHC, + Distribution.Simple.Haddock, + Distribution.Simple.Hpc, + Distribution.Simple.Hugs, + Distribution.Simple.Install, + Distribution.Simple.InstallDirs, + Distribution.Simple.JHC, + Distribution.Simple.LocalBuildInfo, + Distribution.Simple.NHC, + Distribution.Simple.PackageIndex, + Distribution.Simple.PreProcess, + Distribution.Simple.PreProcess.Unlit, + Distribution.Simple.Program, + Distribution.Simple.Program.Ar, + Distribution.Simple.Program.Builtin, + Distribution.Simple.Program.Db, + Distribution.Simple.Program.HcPkg, + Distribution.Simple.Program.Ld, + Distribution.Simple.Program.Run, + Distribution.Simple.Program.Script, + Distribution.Simple.Program.Types, + Distribution.Simple.Register, + Distribution.Simple.Setup, + Distribution.Simple.SrcDist, + Distribution.Simple.Test, + Distribution.Simple.UHC, + Distribution.Simple.UserHooks, + Distribution.Simple.Utils, + Distribution.System, + Distribution.TestSuite, + Distribution.Text, + Distribution.Verbosity, + Distribution.Version, + Distribution.Compat.ReadP, + Language.Haskell.Extension + + Other-Modules: + Distribution.GetOpt, + Distribution.Compat.Exception, + Distribution.Compat.CopyFile, + Distribution.Compat.TempFile, + Distribution.Simple.GHC.IPI641, + Distribution.Simple.GHC.IPI642, + Paths_Cabal + + Default-Language: Haskell98 + Default-Extensions: CPP + +test-suite unit-tests + type: exitcode-stdio-1.0 + main-is: suite.hs + other-modules: PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check, + PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check, + PackageTests.BuildDeps.InternalLibrary0.Check, + PackageTests.BuildDeps.InternalLibrary1.Check, + PackageTests.BuildDeps.InternalLibrary2.Check, + PackageTests.BuildDeps.InternalLibrary3.Check, + PackageTests.BuildDeps.InternalLibrary4.Check, + PackageTests.BuildDeps.TargetSpecificDeps1.Check, + PackageTests.BuildDeps.TargetSpecificDeps2.Check, + PackageTests.BuildDeps.TargetSpecificDeps3.Check, + PackageTests.BuildDeps.SameDepsAllRound.Check, + PackageTests.TestStanza.Check, + PackageTests.TestSuiteExeV10.Check, + PackageTests.PackageTester + hs-source-dirs: tests + build-depends: + base, + test-framework, + test-framework-quickcheck2, + test-framework-hunit, + HUnit, + QuickCheck >= 2.1.0.1, + Cabal, + process, + directory, + filepath, + extensible-exceptions, + bytestring, + unix + Default-Language: Haskell98 diff --git a/cabal/cabal/DefaultSetup.hs b/cabal/cabal/DefaultSetup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/DefaultSetup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal/cabal/Distribution/Compat/CopyFile.hs b/cabal/cabal/Distribution/Compat/CopyFile.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Compat/CopyFile.hs @@ -0,0 +1,115 @@ +{-# OPTIONS -cpp #-} +-- OPTIONS required for ghc-6.4.x compat, and must appear first +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} +-- #hide +module Distribution.Compat.CopyFile ( + copyFile, + copyOrdinaryFile, + copyExecutableFile, + setFileOrdinary, + setFileExecutable, + setDirOrdinary, + ) where + +#ifdef __GLASGOW_HASKELL__ + +import Control.Monad + ( when ) +import Control.Exception + ( bracket, bracketOnError ) +import Distribution.Compat.Exception + ( catchIO ) +#if __GLASGOW_HASKELL__ >= 608 +import Distribution.Compat.Exception + ( throwIOIO ) +import System.IO.Error + ( ioeSetLocation ) +#endif +import System.Directory + ( renameFile, removeFile ) +import Distribution.Compat.TempFile + ( openBinaryTempFile ) +import System.FilePath + ( takeDirectory ) +import System.IO + ( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf ) +import Foreign + ( allocaBytes ) +#endif /* __GLASGOW_HASKELL__ */ + +#ifndef mingw32_HOST_OS +#if __GLASGOW_HASKELL__ >= 611 +import System.Posix.Internals (withFilePath) +#else +import Foreign.C (withCString) +#endif +import System.Posix.Types + ( FileMode ) +import System.Posix.Internals + ( c_chmod ) +#if __GLASGOW_HASKELL__ >= 608 +import Foreign.C + ( throwErrnoPathIfMinus1_ ) +#else +import Foreign.C + ( throwErrnoIfMinus1_ ) +#endif +#endif /* mingw32_HOST_OS */ + +copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO () +copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest +copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest + +setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO () +#ifndef mingw32_HOST_OS +setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r-- +setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x + +setFileMode :: FilePath -> FileMode -> IO () +setFileMode name m = +#if __GLASGOW_HASKELL__ >= 611 + withFilePath name $ \s -> do +#else + withCString name $ \s -> do +#endif +#if __GLASGOW_HASKELL__ >= 608 + throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) +#else + throwErrnoIfMinus1_ name (c_chmod s m) +#endif +#else +setFileOrdinary _ = return () +setFileExecutable _ = return () +#endif +-- This happens to be true on Unix and currently on Windows too: +setDirOrdinary = setFileExecutable + +copyFile :: FilePath -> FilePath -> IO () +#ifdef __GLASGOW_HASKELL__ +copyFile fromFPath toFPath = + copy +#if __GLASGOW_HASKELL__ >= 608 + `catchIO` (\ioe -> throwIOIO (ioeSetLocation ioe "copyFile")) +#endif + where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom -> + bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> + do allocaBytes bufferSize $ copyContents hFrom hTmp + hClose hTmp + renameFile tmpFPath toFPath + openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp" + cleanTmp (tmpFPath, hTmp) = do + hClose hTmp `catchIO` \_ -> return () + removeFile tmpFPath `catchIO` \_ -> return () + bufferSize = 4096 + + copyContents hFrom hTo buffer = do + count <- hGetBuf hFrom buffer bufferSize + when (count > 0) $ do + hPutBuf hTo buffer count + copyContents hFrom hTo buffer +#else +copyFile fromFPath toFPath = readFile fromFPath >>= writeFile toFPath +#endif diff --git a/cabal/cabal/Distribution/Compat/Exception.hs b/cabal/cabal/Distribution/Compat/Exception.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Compat/Exception.hs @@ -0,0 +1,61 @@ +{-# OPTIONS -cpp #-} +-- OPTIONS required for ghc-6.4.x compat, and must appear first +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} + +#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610)) +#define NEW_EXCEPTION +#endif + +module Distribution.Compat.Exception ( + Exception.IOException, + onException, + catchIO, + catchExit, + throwIOIO, + tryIO, + ) where + +import System.Exit +import qualified Control.Exception as Exception + +onException :: IO a -> IO b -> IO a +#ifdef NEW_EXCEPTION +onException = Exception.onException +#else +onException io what = io `Exception.catch` \e -> do what + Exception.throw e +#endif + +throwIOIO :: Exception.IOException -> IO a +#ifdef NEW_EXCEPTION +throwIOIO = Exception.throwIO +#else +throwIOIO = Exception.throwIO . Exception.IOException +#endif + +tryIO :: IO a -> IO (Either Exception.IOException a) +#ifdef NEW_EXCEPTION +tryIO = Exception.try +#else +tryIO = Exception.tryJust Exception.ioErrors +#endif + +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#ifdef NEW_EXCEPTION +catchIO = Exception.catch +#else +catchIO = Exception.catchJust Exception.ioErrors +#endif + +catchExit :: IO a -> (ExitCode -> IO a) -> IO a +#ifdef NEW_EXCEPTION +catchExit = Exception.catch +#else +catchExit = Exception.catchJust exitExceptions + where exitExceptions (Exception.ExitException ee) = Just ee + exitExceptions _ = Nothing +#endif + diff --git a/cabal/cabal/Distribution/Compat/ReadP.hs b/cabal/cabal/Distribution/Compat/ReadP.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Compat/ReadP.hs @@ -0,0 +1,470 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Compat.ReadP +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- 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 + + -- * Properties + -- $properties + ) + where + +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 >>= _ = 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 c a -> ([c] -> [(a, [c])]) +run (Get f) (c:s) = run (f c) s +run (Look f) s = run (f s) s +run (Result x p) s = (x,s) : run p s +run (Final r) _ = r +run _ _ = [] + +-- --------------------------------------------------------------------------- +-- Operations over ReadP + +get :: ReadP r Char +-- ^ Consumes and returns the next character. +-- Fails if there is no input left. +get = R Get + +look :: ReadP r String +-- ^ Look-ahead: returns the part of the input that is left, without +-- consuming it. +look = R Look + +pfail :: ReadP r 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 a -> ReadP r a -> ReadP r a +-- ^ Local, exclusive, left-biased choice: If left parser +-- locally produces any result at all, then right parser is +-- not used. +R f <++ q = + do s <- look + probe (f return) s 0 + where + probe (Get f') (c:s) n = probe (f' c) s (n+1 :: Int) + probe (Look f') s n = probe (f' s) s n + probe p@(Result _ _) _ n = discard n >> R (p >>=) + probe (Final r) _ _ = R (Final r >>=) + probe _ _ _ = q + + discard 0 = return () + discard n = get >> discard (n-1 :: Int) + +gather :: ReadP (String -> P Char r) a -> ReadP r (String, a) +-- ^ Transforms a parser into one that does the same, but +-- in addition returns the exact characters read. +-- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument +-- 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 _ Fail = Fail + gath l (Look f) = Look (\s -> gath l (f s)) + gath l (Result k p) = k (l []) `mplus` gath l p + gath _ (Final _) = error "do not use readS_to_P in gather!" + +-- --------------------------------------------------------------------------- +-- Derived operations + +satisfy :: (Char -> Bool) -> ReadP r Char +-- ^ Consumes and returns the next character, if it satisfies the +-- specified predicate. +satisfy p = do c <- get; if p c then return c else pfail + +char :: Char -> ReadP r Char +-- ^ Parses and returns the specified character. +char c = satisfy (c ==) + +string :: String -> ReadP r 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 r 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 r String +-- ^ Parses the first one or more characters satisfying the predicate. +munch1 p = + do c <- get + if p c then do s <- munch p; return (c:s) + else pfail + +choice :: [ReadP r a] -> ReadP r a +-- ^ Combines all parsers in the specified list. +choice [] = pfail +choice [p] = p +choice (p:ps) = p +++ choice ps + +skipSpaces :: ReadP r () +-- ^ 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 r a -> ReadP r [a] +-- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of +-- results is returned. +count n p = sequence (replicate n p) + +between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a +-- ^ @ between open close p @ parses @open@, followed by @p@ and finally +-- @close@. Only the value of @p@ is returned. +between open close p = do _ <- open + x <- p + _ <- close + return x + +option :: a -> ReadP r a -> ReadP r a +-- ^ @option x p@ will either parse @p@ or return @x@ without consuming +-- any input. +option x p = p +++ return x + +optional :: ReadP r a -> ReadP r () +-- ^ @optional p@ optionally parses @p@ and always returns @()@. +optional p = (p >> return ()) +++ return () + +many :: ReadP r a -> ReadP r [a] +-- ^ Parses zero or more occurrences of the given parser. +many p = return [] +++ many1 p + +many1 :: ReadP r a -> ReadP r [a] +-- ^ Parses one or more occurrences of the given parser. +many1 p = liftM2 (:) p (many p) + +skipMany :: ReadP r a -> ReadP r () +-- ^ Like 'many', but discards the result. +skipMany p = many p >> return () + +skipMany1 :: ReadP r a -> ReadP r () +-- ^ Like 'many1', but discards the result. +skipMany1 p = p >> skipMany p + +sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@. +-- Returns a list of values returned by @p@. +sepBy p sep = sepBy1 p sep +++ return [] + +sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@. +-- Returns a list of values returned by @p@. +sepBy1 p sep = liftM2 (:) p (many (sep >> p)) + +endBy :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended +-- by @sep@. +endBy p sep = many (do x <- p ; _ <- sep ; return x) + +endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended +-- by @sep@. +endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x) + +chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a +-- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@. +-- Returns a value produced by a /right/ associative application of all +-- functions returned by @op@. If there are no occurrences of @p@, @x@ is +-- returned. +chainr p op x = chainr1 p op +++ return x + +chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a +-- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@. +-- Returns a value produced by a /left/ associative application of all +-- functions returned by @op@. If there are no occurrences of @p@, @x@ is +-- returned. +chainl p op x = chainl1 p op +++ return x + +chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a +-- ^ Like 'chainr', but parses one or more occurrences of @p@. +chainr1 p op = scan + where scan = p >>= rest + rest x = do f <- op + y <- scan + return (f x y) + +++ return x + +chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a +-- ^ Like 'chainl', but parses one or more occurrences of @p@. +chainl1 p op = p >>= rest + where rest x = do f <- op + y <- p + rest (f x y) + +++ return x + +manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a] +-- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@ +-- succeeds. Returns a list of values returned by @p@. +manyTill p end = scan + where scan = (end >> return []) <++ (liftM2 (:) p scan) + +-- --------------------------------------------------------------------------- +-- Converting between ReadP and Read + +readP_to_S :: ReadP a a -> ReadS a +-- ^ Converts a parser into a Haskell ReadS-style function. +-- This is the main way in which you can \"run\" a 'ReadP' parser: +-- the expanded type is +-- @ readP_to_S :: ReadP a -> String -> [(a,String)] @ +readP_to_S (R f) = run (f return) + +readS_to_P :: ReadS a -> ReadP r a +-- ^ Converts a Haskell ReadS-style function into a parser. +-- Warning: This introduces local backtracking in the resulting +-- parser, and therefore a possible inefficiency. +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 +-} + diff --git a/cabal/cabal/Distribution/Compat/TempFile.hs b/cabal/cabal/Distribution/Compat/TempFile.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Compat/TempFile.hs @@ -0,0 +1,204 @@ +{-# OPTIONS -cpp #-} +-- OPTIONS required for ghc-6.4.x compat, and must appear first +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} +-- #hide +module Distribution.Compat.TempFile ( + openTempFile, + openBinaryTempFile, + openNewBinaryFile, + createTempDirectory, + ) where + + +import System.FilePath (()) +import Foreign.C (eEXIST) + +#if __NHC__ || __HUGS__ +import System.IO (openFile, openBinaryFile, + Handle, IOMode(ReadWriteMode)) +import System.Directory (doesFileExist) +import System.FilePath ((<.>), splitExtension) +import System.IO.Error (try, isAlreadyExistsError) +#else +import System.IO (Handle, openTempFile, openBinaryTempFile) +import Data.Bits ((.|.)) +import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR, + o_BINARY, o_NONBLOCK, o_NOCTTY) +import System.IO.Error (isAlreadyExistsError) +#if __GLASGOW_HASKELL__ >= 611 +import System.Posix.Internals (withFilePath) +#else +import Foreign.C (withCString) +#endif +import Foreign.C (CInt) +#if __GLASGOW_HASKELL__ >= 611 +import GHC.IO.Handle.FD (fdToHandle) +#else +import GHC.Handle (fdToHandle) +#endif +import Distribution.Compat.Exception (onException, tryIO) +#endif +import Foreign.C (getErrno, errnoToIOError) + +#if __NHC__ +import System.Posix.Types (CPid(..)) +foreign import ccall unsafe "getpid" c_getpid :: IO CPid +#else +import System.Posix.Internals (c_getpid) +#endif + +#ifdef mingw32_HOST_OS +import System.Directory ( createDirectory ) +#else +import qualified System.Posix +#endif + +-- ------------------------------------------------------------ +-- * temporary files +-- ------------------------------------------------------------ + +-- This is here for Haskell implementations that do not come with +-- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9. +-- TODO: Not sure about jhc + +#if __NHC__ || __HUGS__ +-- use a temporary filename that doesn't already exist. +-- NB. *not* secure (we don't atomically lock the tmp file we get) +openTempFile :: FilePath -> String -> IO (FilePath, Handle) +openTempFile tmp_dir template + = do x <- getProcessID + findTempName x + where + (templateBase, templateExt) = splitExtension template + findTempName :: Int -> IO (FilePath, Handle) + findTempName x + = do let path = tmp_dir (templateBase ++ "-" ++ show x) <.> templateExt + b <- doesFileExist path + if b then findTempName (x+1) + else do hnd <- openFile path ReadWriteMode + return (path, hnd) + +openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle) +openBinaryTempFile tmp_dir template + = do x <- getProcessID + findTempName x + where + (templateBase, templateExt) = splitExtension template + findTempName :: Int -> IO (FilePath, Handle) + findTempName x + = do let path = tmp_dir (templateBase ++ "-" ++ show x) <.> templateExt + b <- doesFileExist path + if b then findTempName (x+1) + else do hnd <- openBinaryFile path ReadWriteMode + return (path, hnd) + +openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) +openNewBinaryFile = openBinaryTempFile + +getProcessID :: IO Int +getProcessID = fmap fromIntegral c_getpid +#else +-- This is a copy/paste of the openBinaryTempFile definition, but +-- if uses 666 rather than 600 for the permissions. The base library +-- needs to be changed to make this better. +openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) +openNewBinaryFile dir template = do + pid <- c_getpid + findTempName pid + where + -- We split off the last extension, so we can use .foo.ext files + -- for temporary files (hidden on Unix OSes). Unfortunately we're + -- below filepath in the hierarchy here. + (prefix,suffix) = + case break (== '.') $ reverse template of + -- First case: template contains no '.'s. Just re-reverse it. + (rev_suffix, "") -> (reverse rev_suffix, "") + -- Second case: template contains at least one '.'. Strip the + -- dot from the prefix and prepend it to the suffix (if we don't + -- do this, the unique number will get added after the '.' and + -- thus be part of the extension, which is wrong.) + (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) + -- Otherwise, something is wrong, because (break (== '.')) should + -- always return a pair with either the empty string or a string + -- beginning with '.' as the second component. + _ -> error "bug in System.IO.openTempFile" + + oflags = rw_flags .|. o_EXCL .|. o_BINARY + +#if __GLASGOW_HASKELL__ < 611 + withFilePath = withCString +#endif + + findTempName x = do + fd <- withFilePath filepath $ \ f -> + c_open f oflags 0o666 + if fd < 0 + then do + errno <- getErrno + if errno == eEXIST + then findTempName (x+1) + else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) + else do + -- TODO: We want to tell fdToHandle what the filepath is, + -- as any exceptions etc will only be able to report the + -- fd currently + h <- +#if __GLASGOW_HASKELL__ >= 609 + fdToHandle fd +#elif __GLASGOW_HASKELL__ <= 606 && defined(mingw32_HOST_OS) + -- fdToHandle is borked on Windows with ghc-6.6.x + openFd (fromIntegral fd) Nothing False filepath + ReadWriteMode True +#else + fdToHandle (fromIntegral fd) +#endif + `onException` c_close fd + return (filepath, h) + where + filename = prefix ++ show x ++ suffix + filepath = dir `combine` filename + + -- FIXME: bits copied from System.FilePath + combine a b + | null b = a + | null a = b + | last a == pathSeparator = a ++ b + | otherwise = a ++ [pathSeparator] ++ b + +-- FIXME: Should use filepath library +pathSeparator :: Char +#ifdef mingw32_HOST_OS +pathSeparator = '\\' +#else +pathSeparator = '/' +#endif + +-- FIXME: Copied from GHC.Handle +std_flags, output_flags, rw_flags :: CInt +std_flags = o_NONBLOCK .|. o_NOCTTY +output_flags = std_flags .|. o_CREAT +rw_flags = output_flags .|. o_RDWR +#endif + +createTempDirectory :: FilePath -> String -> IO FilePath +createTempDirectory dir template = do + pid <- c_getpid + findTempName pid + where + findTempName x = do + let dirpath = dir template ++ "-" ++ show x + r <- tryIO $ mkPrivateDir dirpath + case r of + Right _ -> return dirpath + Left e | isAlreadyExistsError e -> findTempName (x+1) + | otherwise -> ioError e + +mkPrivateDir :: String -> IO () +#ifdef mingw32_HOST_OS +mkPrivateDir s = createDirectory s +#else +mkPrivateDir s = System.Posix.createDirectory s 0o700 +#endif diff --git a/cabal/cabal/Distribution/Compiler.hs b/cabal/cabal/Distribution/Compiler.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Compiler.hs @@ -0,0 +1,158 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Compiler +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This has an enumeration of the various compilers that Cabal knows about. It +-- also specifies the default compiler. Sadly you'll often see code that does +-- case analysis on this compiler flavour enumeration like: +-- +-- > case compilerFlavor comp of +-- > GHC -> GHC.getInstalledPackages verbosity packageDb progconf +-- > JHC -> JHC.getInstalledPackages verbosity packageDb progconf +-- +-- Obviously it would be better to use the proper 'Compiler' abstraction +-- because that would keep all the compiler-specific code together. +-- Unfortunately we cannot make this change yet without breaking the +-- 'UserHooks' api, which would break all custom @Setup.hs@ files, so for the +-- moment we just have to live with this deficiency. If you're interested, see +-- ticket #50. + +{- 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 ( + -- * Compiler flavor + CompilerFlavor(..), + buildCompilerFlavor, + defaultCompilerFlavor, + parseCompilerFlavorCompat, + + -- * Compiler id + CompilerId(..), + ) where + +import Distribution.Version (Version(..)) + +import qualified System.Info (compilerName) +import Distribution.Text (Text(..), display) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>)) + +import qualified Data.Char as Char (toLower, isDigit, isAlphaNum) +import Control.Monad (when) + +data CompilerFlavor = GHC | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC + | OtherCompiler String + deriving (Show, Read, Eq, Ord) + +knownCompilerFlavors :: [CompilerFlavor] +knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC] + +instance Text CompilerFlavor where + disp (OtherCompiler name) = Disp.text name + disp NHC = Disp.text "nhc98" + disp other = Disp.text (lowercase (show other)) + + parse = do + comp <- Parse.munch1 Char.isAlphaNum + when (all Char.isDigit comp) Parse.pfail + return (classifyCompilerFlavor comp) + +classifyCompilerFlavor :: String -> CompilerFlavor +classifyCompilerFlavor s = + case lookup (lowercase s) compilerMap of + Just compiler -> compiler + Nothing -> OtherCompiler s + where + compilerMap = [ (display compiler, compiler) + | compiler <- knownCompilerFlavors ] + + +--TODO: In some future release, remove 'parseCompilerFlavorCompat' and use +-- ordinary 'parse'. Also add ("nhc", NHC) to the above 'compilerMap'. + +-- | Like 'classifyCompilerFlavor' but compatible with the old ReadS parser. +-- +-- It is compatible in the sense that it accepts only the same strings, +-- eg "GHC" but not "ghc". However other strings get mapped to 'OtherCompiler'. +-- The point of this is that we do not allow extra valid values that would +-- upset older Cabal versions that had a stricter parser however we cope with +-- new values more gracefully so that we'll be able to introduce new value in +-- future without breaking things so much. +-- +parseCompilerFlavorCompat :: Parse.ReadP r CompilerFlavor +parseCompilerFlavorCompat = do + comp <- Parse.munch1 Char.isAlphaNum + when (all Char.isDigit comp) Parse.pfail + case lookup comp compilerMap of + Just compiler -> return compiler + Nothing -> return (OtherCompiler comp) + where + compilerMap = [ (show compiler, compiler) + | compiler <- knownCompilerFlavors + , compiler /= YHC ] + +buildCompilerFlavor :: CompilerFlavor +buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName + +-- | The default compiler flavour to pick when compiling stuff. This defaults +-- to the compiler used to build the Cabal lib. +-- +-- However if it's not a recognised compiler then it's 'Nothing' and the user +-- will have to specify which compiler they want. +-- +defaultCompilerFlavor :: Maybe CompilerFlavor +defaultCompilerFlavor = case buildCompilerFlavor of + OtherCompiler _ -> Nothing + _ -> Just buildCompilerFlavor + +-- ------------------------------------------------------------ +-- * Compiler Id +-- ------------------------------------------------------------ + +data CompilerId = CompilerId CompilerFlavor Version + deriving (Eq, Ord, Read, Show) + +instance Text CompilerId where + disp (CompilerId f (Version [] _)) = disp f + disp (CompilerId f v) = disp f <> Disp.char '-' <> disp v + + parse = do + flavour <- parse + version <- (Parse.char '-' >> parse) Parse.<++ return (Version [] []) + return (CompilerId flavour version) + +lowercase :: String -> String +lowercase = map Char.toLower diff --git a/cabal/cabal/Distribution/GetOpt.hs b/cabal/cabal/Distribution/GetOpt.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/GetOpt.hs @@ -0,0 +1,335 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.GetOpt +-- Copyright : (c) Sven Panne 2002-2005 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- 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 + +import Data.List ( isPrefixOf, intersperse, find ) + +-- |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 [ (sepBy ", " (map (fmtShort ad) sos) + ,concatMap (fmtLong ad) (take 1 los) + ,d) + | Option sos los ad d <- optDescr ] + ssWidth = (maximum . map length) ss + lsWidth = (maximum . map length) ls + dsWidth = 30 `max` (80 - (ssWidth + lsWidth + 3)) + table = [ " " ++ padTo ssWidth so' ++ + " " ++ padTo lsWidth lo' ++ + " " ++ d' + | (so,lo,d) <- zip3 ss ls ds + , (so',lo',d') <- fmtOpt dsWidth so lo d ] + padTo n x = take n (x ++ repeat ' ') + sepBy s = concat . intersperse s + +fmtOpt :: Int -> String -> String -> String -> [(String, String, String)] +fmtOpt descrWidth so lo descr = + case wrapText descrWidth descr of + [] -> [(so,lo,"")] + (d:ds) -> (so,lo,d) : [ ("","",d') | d' <- ds ] + +fmtShort :: ArgDescr a -> Char -> String +fmtShort (NoArg _ ) so = "-" ++ [so] +fmtShort (ReqArg _ _) so = "-" ++ [so] +fmtShort (OptArg _ _) so = "-" ++ [so] + +fmtLong :: ArgDescr a -> String -> String +fmtLong (NoArg _ ) lo = "--" ++ lo +fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad +fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" + +wrapText :: Int -> String -> [String] +wrapText width = map unwords . wrap 0 [] . words + where wrap :: Int -> [String] -> [String] -> [[String]] + wrap 0 [] (w:ws) + | length w + 1 > width + = wrap (length w) [w] ws + wrap col line (w:ws) + | col + length w + 1 > width + = reverse line : wrap 0 [] (w:ws) + wrap col line (w:ws) + = let col' = col + length w + 1 + in wrap col' (w:line) ws + wrap _ [] [] = [] + wrap _ line [] = [reverse line] + +{-| +Process the command-line, and return the list of values that matched +(and those that didn\'t). The arguments are: + +* 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 + , find (p opt) xs /= Nothing] + 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 +----------------------------------------------------------------------------------------- +-} + +{- $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/cabal/cabal/Distribution/InstalledPackageInfo.hs b/cabal/cabal/Distribution/InstalledPackageInfo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/InstalledPackageInfo.hs @@ -0,0 +1,294 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.InstalledPackageInfo +-- Copyright : (c) The University of Glasgow 2004 +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- This is the information about an /installed/ package that +-- is communicated to the @ghc-pkg@ program in order to register +-- a package. @ghc-pkg@ now consumes this package format (as of version +-- 6.4). This is specific to GHC at the moment. +-- +-- The @.cabal@ file format is for describing a package that is not yet +-- installed. It has a lot of flexibility, like conditionals and dependency +-- ranges. As such, that format is not at all suitable for describing a package +-- that has already been built and installed. By the time we get to that stage, +-- we have resolved all conditionals and resolved dependency version +-- constraints to exact versions of dependent packages. So, this module defines +-- the 'InstalledPackageInfo' data structure that contains all the info we keep +-- about an installed package. There is a parser and pretty printer. The +-- textual format is rather simpler than the @.cabal@ format: there are no +-- sections, for example. + +{- 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_(..), InstalledPackageInfo, + ParseResult(..), PError(..), PWarning, + emptyInstalledPackageInfo, + parseInstalledPackageInfo, + showInstalledPackageInfo, + showInstalledPackageInfoField, + fieldsInstalledPackageInfo, + ) where + +import Distribution.ParseUtils + ( FieldDescr(..), ParseResult(..), PError(..), PWarning + , simpleField, listField, parseLicenseQ + , showFields, showSingleNamedField, parseFieldsFlat + , parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ + , showFilePath, showToken, boolField, parseOptVersion + , parseFreeText, showFreeText ) +import Distribution.License ( License(..) ) +import Distribution.Package + ( PackageName(..), PackageIdentifier(..), PackageId, InstalledPackageId(..) + , packageName, packageVersion ) +import qualified Distribution.Package as Package + ( Package(..) ) +import Distribution.ModuleName + ( ModuleName ) +import Distribution.Version + ( Version(..) ) +import Distribution.Text + ( Text(disp, parse) ) + +-- ----------------------------------------------------------------------------- +-- The InstalledPackageInfo type + +data InstalledPackageInfo_ m + = InstalledPackageInfo { + -- these parts are exactly the same as PackageDescription + installedPackageId :: InstalledPackageId, + sourcePackageId :: PackageId, + license :: License, + copyright :: String, + maintainer :: String, + author :: String, + stability :: String, + homepage :: String, + pkgUrl :: String, + synopsis :: String, + description :: String, + category :: String, + -- these parts are required by an installed package only: + exposed :: Bool, + exposedModules :: [m], + hiddenModules :: [m], + trusted :: Bool, + 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 :: [InstalledPackageId], + hugsOptions :: [String], + ccOptions :: [String], + ldOptions :: [String], + frameworkDirs :: [FilePath], + frameworks :: [String], + haddockInterfaces :: [FilePath], + haddockHTMLs :: [FilePath] + } + deriving (Read, Show) + +instance Package.Package (InstalledPackageInfo_ str) where + packageId = sourcePackageId + +type InstalledPackageInfo = InstalledPackageInfo_ ModuleName + +emptyInstalledPackageInfo :: InstalledPackageInfo_ m +emptyInstalledPackageInfo + = InstalledPackageInfo { + installedPackageId = InstalledPackageId "", + sourcePackageId = PackageIdentifier (PackageName "") noVersion, + license = AllRightsReserved, + copyright = "", + maintainer = "", + author = "", + stability = "", + homepage = "", + pkgUrl = "", + synopsis = "", + description = "", + category = "", + exposed = False, + exposedModules = [], + hiddenModules = [], + trusted = False, + 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 = + parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo + +-- ----------------------------------------------------------------------------- +-- Pretty-printing + +showInstalledPackageInfo :: InstalledPackageInfo -> String +showInstalledPackageInfo = showFields fieldsInstalledPackageInfo + +showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) +showInstalledPackageInfoField = showSingleNamedField fieldsInstalledPackageInfo + +-- ----------------------------------------------------------------------------- +-- Description of the fields, for parsing/printing + +fieldsInstalledPackageInfo :: [FieldDescr InstalledPackageInfo] +fieldsInstalledPackageInfo = basicFieldDescrs ++ installedFieldDescrs + +basicFieldDescrs :: [FieldDescr InstalledPackageInfo] +basicFieldDescrs = + [ simpleField "name" + disp parsePackageNameQ + packageName (\name pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgName=name}}) + , simpleField "version" + disp parseOptVersion + packageVersion (\ver pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgVersion=ver}}) + , simpleField "id" + disp parse + installedPackageId (\ipid pkg -> pkg{installedPackageId=ipid}) + , simpleField "license" + disp parseLicenseQ + license (\l pkg -> pkg{license=l}) + , simpleField "copyright" + showFreeText parseFreeText + copyright (\val pkg -> pkg{copyright=val}) + , simpleField "maintainer" + showFreeText parseFreeText + maintainer (\val pkg -> pkg{maintainer=val}) + , simpleField "stability" + showFreeText parseFreeText + stability (\val pkg -> pkg{stability=val}) + , simpleField "homepage" + showFreeText parseFreeText + homepage (\val pkg -> pkg{homepage=val}) + , simpleField "package-url" + showFreeText parseFreeText + pkgUrl (\val pkg -> pkg{pkgUrl=val}) + , simpleField "synopsis" + showFreeText parseFreeText + synopsis (\val pkg -> pkg{synopsis=val}) + , simpleField "description" + showFreeText parseFreeText + description (\val pkg -> pkg{description=val}) + , simpleField "category" + showFreeText parseFreeText + category (\val pkg -> pkg{category=val}) + , simpleField "author" + showFreeText parseFreeText + author (\val pkg -> pkg{author=val}) + ] + +installedFieldDescrs :: [FieldDescr InstalledPackageInfo] +installedFieldDescrs = [ + boolField "exposed" + exposed (\val pkg -> pkg{exposed=val}) + , listField "exposed-modules" + disp parseModuleNameQ + exposedModules (\xs pkg -> pkg{exposedModules=xs}) + , listField "hidden-modules" + disp parseModuleNameQ + hiddenModules (\xs pkg -> pkg{hiddenModules=xs}) + , boolField "trusted" + trusted (\val pkg -> pkg{trusted=val}) + , 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" + disp parse + 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}) + ] diff --git a/cabal/cabal/Distribution/License.hs b/cabal/cabal/Distribution/License.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/License.hs @@ -0,0 +1,138 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.License +-- Copyright : Isaac Jones 2003-2005 +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- The License datatype. For more information about these and other +-- open-source licenses, you may visit . +-- +-- The @.cabal@ file allows you to specify a license file. Of course you can +-- use any license you like but people often pick common open source licenses +-- and it's useful if we can automatically recognise that (eg so we can display +-- it on the hackage web pages). So you can also specify the license itself in +-- the @.cabal@ file from a short enumeration defined in this module. It +-- includes 'GPL', 'LGPL' and 'BSD3' licenses. + +{- 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(..), + knownLicenses, + ) where + +import Distribution.Version (Version(Version)) + +import Distribution.Text (Text(..), display) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>)) +import qualified Data.Char as Char (isAlphaNum) + +-- |This datatype indicates the license under which your package is +-- released. It is also wise to add your license to each source file +-- using the license-file field. The 'AllRightsReserved' constructor +-- 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 = + +--TODO: * remove BSD4 + + -- | GNU Public License. Source code must accompany alterations. + GPL (Maybe Version) + + -- | Lesser GPL, Less restrictive than GPL, useful for libraries. + | LGPL (Maybe Version) + + -- | 3-clause BSD license, newer, no advertising clause. Very free license. + | BSD3 + + -- | 4-clause BSD license, older, with advertising clause. You almost + -- certainly want to use the BSD3 license instead. + | BSD4 + + -- | The MIT license, similar to the BSD3. Very free license. + | MIT + + -- | Holder makes no claim to ownership, least restrictive license. + | PublicDomain + + -- | No rights are granted to others. Undistributable. Most restrictive. + | AllRightsReserved + + -- | Some other license. + | OtherLicense + + -- | Not a recognised license. + -- Allows us to deal with future extensions more gracefully. + | UnknownLicense String + deriving (Read, Show, Eq) + +knownLicenses :: [License] +knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3]) + , LGPL unversioned, LGPL (version [2,1]), LGPL (version [3]) + , BSD3, MIT + , PublicDomain, AllRightsReserved, OtherLicense] + where + unversioned = Nothing + version v = Just (Version v []) + +instance Text License where + disp (GPL version) = Disp.text "GPL" <> dispOptVersion version + disp (LGPL version) = Disp.text "LGPL" <> dispOptVersion version + disp (UnknownLicense other) = Disp.text other + disp other = Disp.text (show other) + + parse = do + name <- Parse.munch1 (\c -> Char.isAlphaNum c && c /= '-') + version <- Parse.option Nothing (Parse.char '-' >> fmap Just parse) + return $! case (name, version :: Maybe Version) of + ("GPL", _ ) -> GPL version + ("LGPL", _ ) -> LGPL version + ("BSD3", Nothing) -> BSD3 + ("BSD4", Nothing) -> BSD4 + ("MIT", Nothing) -> MIT + ("PublicDomain", Nothing) -> PublicDomain + ("AllRightsReserved", Nothing) -> AllRightsReserved + ("OtherLicense", Nothing) -> OtherLicense + _ -> UnknownLicense $ name + ++ maybe "" (('-':) . display) version + +dispOptVersion :: Maybe Version -> Disp.Doc +dispOptVersion Nothing = Disp.empty +dispOptVersion (Just v) = Disp.char '-' <> disp v diff --git a/cabal/cabal/Distribution/Make.hs b/cabal/cabal/Distribution/Make.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Make.hs @@ -0,0 +1,213 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Make +-- Copyright : Martin Sjögren 2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is an alternative build system that delegates everything to the @make@ +-- program. All the commands just end up calling @make@ with appropriate +-- arguments. The intention was to allow preexisting packages that used +-- makefiles to be wrapped into Cabal packages. In practice essentially all +-- such packages were converted over to the \"Simple\" build system instead. +-- Consequently this module is not used much and it certainly only sees cursory +-- maintenance and no testing. Perhaps at some point we should stop pretending +-- that it works. +-- +-- Uses the parsed command-line from "Distribution.Simple.Setup" in order to build +-- Haskell tools using a backend build system based on make. Obviously we +-- assume that there is a configure script, and that after the ConfigCmd has +-- been run, there is a Makefile. Further assumptions: +-- +-- [ConfigCmd] We assume the configure script accepts +-- @--with-hc@, +-- @--with-hc-pkg@, +-- @--prefix@, +-- @--bindir@, +-- @--libdir@, +-- @--libexecdir@, +-- @--datadir@. +-- +-- [BuildCmd] We assume that the default Makefile target will build everything. +-- +-- [InstallCmd] We assume there is an @install@ target. Note that we assume that +-- this does *not* register the package! +-- +-- [CopyCmd] We assume there is a @copy@ target, and a variable @$(destdir)@. +-- The @copy@ target should probably just invoke @make install@ +-- recursively (e.g. @$(MAKE) install prefix=$(destdir)\/$(prefix) +-- bindir=$(destdir)\/$(bindir)@. The reason we can\'t invoke @make +-- install@ directly here is that we don\'t know the value of @$(prefix)@. +-- +-- [SDistCmd] We assume there is a @dist@ target. +-- +-- [RegisterCmd] We assume there is a @register@ target and a variable @$(user)@. +-- +-- [UnregisterCmd] We assume there is an @unregister@ target. +-- +-- [HaddockCmd] We assume there is a @docs@ or @doc@ target. + + +-- copy : +-- $(MAKE) install prefix=$(destdir)/$(prefix) \ +-- bindir=$(destdir)/$(bindir) \ + +{- 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, defaultMainArgs, defaultMainNoRead + ) where + +-- local +import Distribution.Compat.Exception +import Distribution.Package --must not specify imports, since we're exporting moule. +import Distribution.Simple.Program(defaultProgramConfiguration) +import Distribution.PackageDescription +import Distribution.Simple.Setup +import Distribution.Simple.Command + +import Distribution.Simple.Utils (rawSystemExit, cabalVersion) + +import Distribution.License (License(..)) +import Distribution.Version + ( Version(..) ) +import Distribution.Text + ( display ) + +import System.Environment (getArgs, getProgName) +import Data.List (intersperse) +import System.Exit + +defaultMain :: IO () +defaultMain = getArgs >>= defaultMainArgs + +defaultMainArgs :: [String] -> IO () +defaultMainArgs = defaultMainHelper + +{-# DEPRECATED defaultMainNoRead "it ignores its PackageDescription arg" #-} +defaultMainNoRead :: PackageDescription -> IO () +defaultMainNoRead = const defaultMain + +defaultMainHelper :: [String] -> IO () +defaultMainHelper args = + case commandsRun globalCommand commands args of + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (flags, commandParse) -> + case commandParse of + _ | fromFlag (globalVersion flags) -> printVersion + | fromFlag (globalNumericVersion flags) -> printNumericVersion + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action + + where + printHelp help = getProgName >>= putStr . help + printOptionsList = putStr . unlines + printErrors errs = do + putStr (concat (intersperse "\n" errs)) + exitWith (ExitFailure 1) + printNumericVersion = putStrLn $ display cabalVersion + printVersion = putStrLn $ "Cabal library version " + ++ display cabalVersion + + progs = defaultProgramConfiguration + commands = + [configureCommand progs `commandAddAction` configureAction + ,buildCommand progs `commandAddAction` buildAction + ,installCommand `commandAddAction` installAction + ,copyCommand `commandAddAction` copyAction + ,haddockCommand `commandAddAction` haddockAction + ,cleanCommand `commandAddAction` cleanAction + ,sdistCommand `commandAddAction` sdistAction + ,registerCommand `commandAddAction` registerAction + ,unregisterCommand `commandAddAction` unregisterAction + ] + +configureAction :: ConfigFlags -> [String] -> IO () +configureAction flags args = do + noExtraFlags args + let verbosity = fromFlag (configVerbosity flags) + rawSystemExit verbosity "sh" $ + "configure" + : configureArgs backwardsCompatHack flags + where backwardsCompatHack = True + +copyAction :: CopyFlags -> [String] -> IO () +copyAction flags args = do + noExtraFlags args + let destArgs = case fromFlag $ copyDest flags of + NoCopyDest -> ["install"] + CopyTo path -> ["copy", "destdir=" ++ path] + rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs + +installAction :: InstallFlags -> [String] -> IO () +installAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ installVerbosity flags) "make" ["install"] + rawSystemExit (fromFlag $ installVerbosity flags) "make" ["register"] + +haddockAction :: HaddockFlags -> [String] -> IO () +haddockAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"] + `catchIO` \_ -> + rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"] + +buildAction :: BuildFlags -> [String] -> IO () +buildAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ buildVerbosity flags) "make" [] + +cleanAction :: CleanFlags -> [String] -> IO () +cleanAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ cleanVerbosity flags) "make" ["clean"] + +sdistAction :: SDistFlags -> [String] -> IO () +sdistAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"] + +registerAction :: RegisterFlags -> [String] -> IO () +registerAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"] + +unregisterAction :: RegisterFlags -> [String] -> IO () +unregisterAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ regVerbosity flags) "make" ["unregister"] diff --git a/cabal/cabal/Distribution/ModuleName.hs b/cabal/cabal/Distribution/ModuleName.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/ModuleName.hs @@ -0,0 +1,130 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.ModuleName +-- Copyright : Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Data type for Haskell module names. + +{- 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.ModuleName ( + ModuleName, + fromString, + components, + toFilePath, + main, + simple, + ) where + +import Distribution.Text + ( Text(..) ) + +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import qualified Data.Char as Char + ( isAlphaNum, isUpper ) +import System.FilePath + ( pathSeparator ) +import Data.List + ( intersperse ) + +-- | A valid Haskell module name. +-- +newtype ModuleName = ModuleName [String] + deriving (Eq, Ord, Read, Show) + +instance Text ModuleName where + disp (ModuleName ms) = + Disp.hcat (intersperse (Disp.char '.') (map Disp.text ms)) + + parse = do + ms <- Parse.sepBy1 component (Parse.char '.') + return (ModuleName ms) + + where + component = do + c <- Parse.satisfy Char.isUpper + cs <- Parse.munch validModuleChar + return (c:cs) + +validModuleChar :: Char -> Bool +validModuleChar c = Char.isAlphaNum c || c == '_' || c == '\'' + +validModuleComponent :: String -> Bool +validModuleComponent [] = False +validModuleComponent (c:cs) = Char.isUpper c + && all validModuleChar cs + +{-# DEPRECATED simple "use ModuleName.fromString instead" #-} +simple :: String -> ModuleName +simple str = ModuleName [str] + +-- | Construct a 'ModuleName' from a valid module name 'String'. +-- +-- This is just a convenience function intended for valid module strings. It is +-- an error if it is used with a string that is not a valid module name. If you +-- are parsing user input then use 'Distribution.Text.simpleParse' instead. +-- +fromString :: String -> ModuleName +fromString string + | all validModuleComponent components' = ModuleName components' + | otherwise = error badName + + where + components' = split string + badName = "ModuleName.fromString: invalid module name " ++ show string + + split cs = case break (=='.') cs of + (chunk,[]) -> chunk : [] + (chunk,_:rest) -> chunk : split rest + +-- | The module name @Main@. +-- +main :: ModuleName +main = ModuleName ["Main"] + +-- | The individual components of a hierarchical module name. For example +-- +-- > components (fromString "A.B.C") = ["A", "B", "C"] +-- +components :: ModuleName -> [String] +components (ModuleName ms) = ms + +-- | Convert a module name to a file path, but without any file extension. +-- For example: +-- +-- > toFilePath (fromString "A.B.C") = "A/B/C" +-- +toFilePath :: ModuleName -> FilePath +toFilePath = concat . intersperse [pathSeparator] . components diff --git a/cabal/cabal/Distribution/Package.hs b/cabal/cabal/Distribution/Package.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Package.hs @@ -0,0 +1,193 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Package +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Defines a package identifier along with a parser and pretty printer for it. +-- 'PackageIdentifier's consist of a name and an exact version. It also defines +-- a 'Dependency' data type. A dependency is a package name and a version +-- range, like @\"foo >= 1.2 && < 2\"@. + +{- 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 ( + -- * Package ids + PackageName(..), + PackageIdentifier(..), + PackageId, + + -- * Installed package identifiers + InstalledPackageId(..), + + -- * Package source dependencies + Dependency(..), + thisPackageVersion, + notThisPackageVersion, + simplifyDependency, + + -- * Package classes + Package(..), packageName, packageVersion, + PackageFixedDeps(..), + ) where + +import Distribution.Version + ( Version(..), VersionRange, anyVersion, thisVersion + , notThisVersion, simplifyVersionRange ) + +import Distribution.Text (Text(..)) +import qualified Distribution.Compat.ReadP as Parse +import Distribution.Compat.ReadP ((<++)) +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>), (<+>), text) +import qualified Data.Char as Char ( isDigit, isAlphaNum ) +import Data.List ( intersperse ) + +newtype PackageName = PackageName String + deriving (Read, Show, Eq, Ord) + +instance Text PackageName where + disp (PackageName n) = Disp.text n + parse = do + ns <- Parse.sepBy1 component (Parse.char '-') + return (PackageName (concat (intersperse "-" ns))) + where + component = do + cs <- Parse.munch1 Char.isAlphaNum + if all Char.isDigit cs then Parse.pfail else return cs + -- each component must contain an alphabetic character, to avoid + -- ambiguity in identifiers like foo-1 (the 1 is the version number). + +-- | Type alias so we can use the shorter name PackageId. +type PackageId = PackageIdentifier + +-- | The name and version of a package. +data PackageIdentifier + = PackageIdentifier { + pkgName :: PackageName, -- ^The name of this package, eg. foo + pkgVersion :: Version -- ^the version of this package, eg 1.2 + } + deriving (Read, Show, Eq, Ord) + +instance Text PackageIdentifier where + disp (PackageIdentifier n v) = case v of + Version [] _ -> disp n -- if no version, don't show version. + _ -> disp n <> Disp.char '-' <> disp v + + parse = do + n <- parse + v <- (Parse.char '-' >> parse) <++ return (Version [] []) + return (PackageIdentifier n v) + +-- ------------------------------------------------------------ +-- * Installed Package Ids +-- ------------------------------------------------------------ + +-- | An InstalledPackageId uniquely identifies an instance of an installed package. +-- There can be at most one package with a given 'InstalledPackageId' +-- in a package database, or overlay of databases. +-- +newtype InstalledPackageId = InstalledPackageId String + deriving (Read,Show,Eq,Ord) + +instance Text InstalledPackageId where + disp (InstalledPackageId str) = text str + + parse = InstalledPackageId `fmap` Parse.munch1 abi_char + where abi_char c = Char.isAlphaNum c || c `elem` ":-_." + +-- ------------------------------------------------------------ +-- * Package source dependencies +-- ------------------------------------------------------------ + +-- | Describes a dependency on a source package (API) +-- +data Dependency = Dependency PackageName VersionRange + deriving (Read, Show, Eq) + +instance Text Dependency where + disp (Dependency name ver) = + disp name <+> disp ver + + parse = do name <- parse + Parse.skipSpaces + ver <- parse <++ return anyVersion + Parse.skipSpaces + return (Dependency name ver) + +thisPackageVersion :: PackageIdentifier -> Dependency +thisPackageVersion (PackageIdentifier n v) = + Dependency n (thisVersion v) + +notThisPackageVersion :: PackageIdentifier -> Dependency +notThisPackageVersion (PackageIdentifier n v) = + Dependency n (notThisVersion v) + +-- | Simplify the 'VersionRange' expression in a 'Dependency'. +-- See 'simplifyVersionRange'. +-- +simplifyDependency :: Dependency -> Dependency +simplifyDependency (Dependency name range) = + Dependency name (simplifyVersionRange range) + +-- | Class of things that have a 'PackageIdentifier' +-- +-- Types in this class are all notions of a package. This allows us to have +-- different types for the different phases that packages go though, from +-- simple name\/id, package description, configured or installed packages. +-- +-- Not all kinds of packages can be uniquely identified by a +-- 'PackageIdentifier'. In particular, installed packages cannot, there may be +-- many installed instances of the same source package. +-- +class Package pkg where + packageId :: pkg -> PackageIdentifier + +packageName :: Package pkg => pkg -> PackageName +packageName = pkgName . packageId + +packageVersion :: Package pkg => pkg -> Version +packageVersion = pkgVersion . packageId + +instance Package PackageIdentifier where + packageId = id + +-- | Subclass of packages that have specific versioned dependencies. +-- +-- So for example a not-yet-configured package has dependencies on version +-- ranges, not specific versions. A configured or an already installed package +-- depends on exact versions. Some operations or data structures (like +-- dependency graphs) only make sense on this subclass of package types. +-- +class Package pkg => PackageFixedDeps pkg where + depends :: pkg -> [PackageIdentifier] diff --git a/cabal/cabal/Distribution/PackageDescription.hs b/cabal/cabal/Distribution/PackageDescription.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/PackageDescription.hs @@ -0,0 +1,895 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines the data structure for the @.cabal@ file format. There are +-- several parts to this structure. It has top level info and then 'Library', +-- 'Executable', and 'TestSuite' sections each of which have associated +-- 'BuildInfo' data that's used to build the library, exe, or test. To further +-- complicate things there is both a 'PackageDescription' and a +-- 'GenericPackageDescription'. This distinction relates to cabal +-- configurations. When we initially read a @.cabal@ file we get a +-- 'GenericPackageDescription' which has all the conditional sections. +-- Before actually building a package we have to decide +-- on each conditional. Once we've done that we get a 'PackageDescription'. +-- It was done this way initially to avoid breaking too much stuff when the +-- feature was introduced. It could probably do with being rationalised at some +-- point to make it simpler. + +{- 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, + specVersion, + descCabalVersion, + BuildType(..), + knownBuildTypes, + + -- ** Libraries + Library(..), + emptyLibrary, + withLib, + hasLibs, + libModules, + + -- ** Executables + Executable(..), + emptyExecutable, + withExe, + hasExes, + exeModules, + + -- * Tests + TestSuite(..), + TestSuiteInterface(..), + TestType(..), + testType, + knownTestTypes, + emptyTestSuite, + hasTests, + withTest, + testModules, + enabledTests, + + -- * Build information + BuildInfo(..), + emptyBuildInfo, + allBuildInfo, + allLanguages, + allExtensions, + usedExtensions, + hcOptions, + + -- ** Supplementary build information + HookedBuildInfo, + emptyHookedBuildInfo, + updatePackageDescription, + + -- * package configuration + GenericPackageDescription(..), + Flag(..), FlagName(..), FlagAssignment, + CondTree(..), ConfVar(..), Condition(..), + + -- * Source repositories + SourceRepo(..), + RepoKind(..), + RepoType(..), + knownRepoTypes, + ) where + +import Data.List (nub, intersperse) +import Data.Maybe (maybeToList) +import Data.Monoid (Monoid(mempty, mappend)) +import Control.Monad (MonadPlus(mplus)) +import Text.PrettyPrint.HughesPJ as Disp +import qualified Distribution.Compat.ReadP as Parse +import qualified Data.Char as Char (isAlphaNum, isDigit, toLower) + +import Distribution.Package + ( PackageName(PackageName), PackageIdentifier(PackageIdentifier) + , Dependency, Package(..) ) +import Distribution.ModuleName ( ModuleName ) +import Distribution.Version + ( Version(Version), VersionRange, anyVersion, orLaterVersion + , asVersionIntervals, LowerBound(..) ) +import Distribution.License (License(AllRightsReserved)) +import Distribution.Compiler (CompilerFlavor) +import Distribution.System (OS, Arch) +import Distribution.Text + ( Text(..), display ) +import Language.Haskell.Extension + ( Language, Extension ) + +-- ----------------------------------------------------------------------------- +-- The PackageDescription type + +-- | This data type is the internal representation of the file @pkg.cabal@. +-- It contains two kinds of information about the package: information +-- which is needed for all packages, such as the package name and version, and +-- information which is needed for the simple build system only, such as +-- the compiler options and library name. +-- +data PackageDescription + = PackageDescription { + -- the following are required by all packages: + package :: PackageIdentifier, + license :: License, + licenseFile :: FilePath, + copyright :: String, + maintainer :: String, + author :: String, + stability :: String, + testedWith :: [(CompilerFlavor,VersionRange)], + homepage :: String, + pkgUrl :: String, + bugReports :: String, + sourceRepos :: [SourceRepo], + synopsis :: String, -- ^A one-line summary of this package + description :: String, -- ^A more verbose description of this package + category :: String, + customFieldsPD :: [(String,String)], -- ^Custom fields starting + -- with x-, stored in a + -- simple assoc-list. + buildDepends :: [Dependency], + -- | The version of the Cabal spec that this package description uses. + -- For historical reasons this is specified with a version range but + -- only ranges of the form @>= v@ make sense. We are in the process of + -- transitioning to specifying just a single version, not a range. + specVersionRaw :: Either Version VersionRange, + buildType :: Maybe BuildType, + -- components + library :: Maybe Library, + executables :: [Executable], + testSuites :: [TestSuite], + dataFiles :: [FilePath], + dataDir :: FilePath, + extraSrcFiles :: [FilePath], + extraTmpFiles :: [FilePath] + } + deriving (Show, Read, Eq) + +instance Package PackageDescription where + packageId = package + +-- | The version of the Cabal spec that this package should be interpreted +-- against. +-- +-- Historically we used a version range but we are switching to using a single +-- version. Currently we accept either. This function converts into a single +-- version by ignoring upper bounds in the version range. +-- +specVersion :: PackageDescription -> Version +specVersion pkg = case specVersionRaw pkg of + Left version -> version + Right versionRange -> case asVersionIntervals versionRange of + [] -> Version [0] [] + ((LowerBound version _, _):_) -> version + +-- | The range of versions of the Cabal tools that this package is intended to +-- work with. +-- +-- This function is deprecated and should not be used for new purposes, only to +-- support old packages that rely on the old interpretation. +-- +descCabalVersion :: PackageDescription -> VersionRange +descCabalVersion pkg = case specVersionRaw pkg of + Left version -> orLaterVersion version + Right versionRange -> versionRange +{-# DEPRECATED descCabalVersion "Use specVersion instead" #-} + +emptyPackageDescription :: PackageDescription +emptyPackageDescription + = PackageDescription { + package = PackageIdentifier (PackageName "") + (Version [] []), + license = AllRightsReserved, + licenseFile = "", + specVersionRaw = Right anyVersion, + buildType = Nothing, + copyright = "", + maintainer = "", + author = "", + stability = "", + testedWith = [], + buildDepends = [], + homepage = "", + pkgUrl = "", + bugReports = "", + sourceRepos = [], + synopsis = "", + description = "", + category = "", + customFieldsPD = [], + library = Nothing, + executables = [], + testSuites = [], + dataFiles = [], + dataDir = "", + extraSrcFiles = [], + extraTmpFiles = [] + } + +-- | The type of build system used by this package. +data BuildType + = Simple -- ^ calls @Distribution.Simple.defaultMain@ + | Configure -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@, + -- which invokes @configure@ to generate additional build + -- information used by later phases. + | Make -- ^ calls @Distribution.Make.defaultMain@ + | Custom -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default) + | UnknownBuildType String + -- ^ a package that uses an unknown build type cannot actually + -- be built. Doing it this way rather than just giving a + -- parse error means we get better error messages and allows + -- you to inspect the rest of the package description. + deriving (Show, Read, Eq) + +knownBuildTypes :: [BuildType] +knownBuildTypes = [Simple, Configure, Make, Custom] + +instance Text BuildType where + disp (UnknownBuildType other) = Disp.text other + disp other = Disp.text (show other) + + parse = do + name <- Parse.munch1 Char.isAlphaNum + return $ case name of + "Simple" -> Simple + "Configure" -> Configure + "Custom" -> Custom + "Make" -> Make + _ -> UnknownBuildType name + +-- --------------------------------------------------------------------------- +-- The Library type + +data Library = Library { + exposedModules :: [ModuleName], + libExposed :: Bool, -- ^ Is the lib to be exposed by default? + libBuildInfo :: BuildInfo + } + deriving (Show, Eq, Read) + +instance Monoid Library where + mempty = Library { + exposedModules = mempty, + libExposed = True, + libBuildInfo = mempty + } + mappend a b = Library { + exposedModules = combine exposedModules, + libExposed = libExposed a && libExposed b, -- so False propagates + libBuildInfo = combine libBuildInfo + } + where combine field = field a `mappend` field b + +emptyLibrary :: Library +emptyLibrary = mempty + +-- |does this package have any libraries? +hasLibs :: PackageDescription -> Bool +hasLibs p = maybe False (buildable . libBuildInfo) (library p) + +-- |'Maybe' version of 'hasLibs' +maybeHasLibs :: PackageDescription -> Maybe Library +maybeHasLibs p = + library p >>= \lib -> if buildable (libBuildInfo lib) + then Just lib + else Nothing + +-- |If the package description has a library section, call the given +-- function with the library build info as argument. +withLib :: PackageDescription -> (Library -> IO ()) -> IO () +withLib pkg_descr f = + maybe (return ()) f (maybeHasLibs pkg_descr) + +-- | Get all the module names from the library (exposed and internal modules) +libModules :: Library -> [ModuleName] +libModules lib = exposedModules lib + ++ otherModules (libBuildInfo lib) + +-- --------------------------------------------------------------------------- +-- The Executable type + +data Executable = Executable { + exeName :: String, + modulePath :: FilePath, + buildInfo :: BuildInfo + } + deriving (Show, Read, Eq) + +instance Monoid Executable where + mempty = Executable { + exeName = mempty, + modulePath = mempty, + buildInfo = mempty + } + mappend a b = Executable{ + exeName = combine' exeName, + modulePath = combine modulePath, + buildInfo = combine buildInfo + } + where combine field = field a `mappend` field b + combine' field = case (field a, field b) of + ("","") -> "" + ("", x) -> x + (x, "") -> x + (x, y) -> error $ "Ambiguous values for executable field: '" + ++ x ++ "' and '" ++ y ++ "'" + +emptyExecutable :: Executable +emptyExecutable = mempty + +-- |does this package have any executables? +hasExes :: PackageDescription -> Bool +hasExes p = any (buildable . buildInfo) (executables p) + +-- | Perform the action on each buildable 'Executable' in the package +-- description. +withExe :: PackageDescription -> (Executable -> IO ()) -> IO () +withExe pkg_descr f = + sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)] + +-- | Get all the module names from an exe +exeModules :: Executable -> [ModuleName] +exeModules exe = otherModules (buildInfo exe) + +-- --------------------------------------------------------------------------- +-- The TestSuite type + +-- | A \"test-suite\" stanza in a cabal file. +-- +data TestSuite = TestSuite { + testName :: String, + testInterface :: TestSuiteInterface, + testBuildInfo :: BuildInfo, + testEnabled :: Bool + -- TODO: By having a 'testEnabled' field in the PackageDescription, we + -- are mixing build status information (i.e., arguments to 'configure') + -- with static package description information. This is undesirable, but + -- a better solution is waiting on the next overhaul to the + -- GenericPackageDescription -> PackageDescription resolution process. + } + deriving (Show, Read, Eq) + +-- | The test suite interfaces that are currently defined. Each test suite must +-- specify which interface it supports. +-- +-- More interfaces may be defined in future, either new revisions or totally +-- new interfaces. +-- +data TestSuiteInterface = + + -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form + -- of an executable. It returns a zero exit code for success, non-zero for + -- failure. The stdout and stderr channels may be logged. It takes no + -- command line parameters and nothing on stdin. + -- + TestSuiteExeV10 Version FilePath + + -- | Test interface \"detailed-0.9\". The test-suite takes the form of a + -- library containing a designated module that exports \"tests :: [Test]\". + -- + | TestSuiteLibV09 Version ModuleName + + -- | A test suite that does not conform to one of the above interfaces for + -- the given reason (e.g. unknown test type). + -- + | TestSuiteUnsupported TestType + deriving (Eq, Read, Show) + +instance Monoid TestSuite where + mempty = TestSuite { + testName = mempty, + testInterface = mempty, + testBuildInfo = mempty, + testEnabled = False + } + + mappend a b = TestSuite { + testName = combine' testName, + testInterface = combine testInterface, + testBuildInfo = combine testBuildInfo, + testEnabled = if testEnabled a then True else testEnabled b + } + where combine field = field a `mappend` field b + combine' f = case (f a, f b) of + ("", x) -> x + (x, "") -> x + (x, y) -> error "Ambiguous values for test field: '" + ++ x ++ "' and '" ++ y ++ "'" + +instance Monoid TestSuiteInterface where + mempty = TestSuiteUnsupported (TestTypeUnknown mempty (Version [] [])) + mappend a (TestSuiteUnsupported _) = a + mappend _ b = b + +emptyTestSuite :: TestSuite +emptyTestSuite = mempty + +-- | Does this package have any test suites? +hasTests :: PackageDescription -> Bool +hasTests = any (buildable . testBuildInfo) . testSuites + +-- | Get all the enabled test suites from a package. +enabledTests :: PackageDescription -> [TestSuite] +enabledTests = filter testEnabled . testSuites + +-- | Perform an action on each buildable 'TestSuite' in a package. +withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO () +withTest pkg_descr f = + mapM_ f $ filter (buildable . testBuildInfo) $ enabledTests pkg_descr + +-- | Get all the module names from a test suite. +testModules :: TestSuite -> [ModuleName] +testModules test = (case testInterface test of + TestSuiteLibV09 _ m -> [m] + _ -> []) + ++ otherModules (testBuildInfo test) + +-- | The \"test-type\" field in the test suite stanza. +-- +data TestType = TestTypeExe Version -- ^ \"type: exitcode-stdio-x.y\" + | TestTypeLib Version -- ^ \"type: detailed-x.y\" + | TestTypeUnknown String Version -- ^ Some unknown test type e.g. \"type: foo\" + deriving (Show, Read, Eq) + +knownTestTypes :: [TestType] +knownTestTypes = [ TestTypeExe (Version [1,0] []) + -- 'detailed-0.9' test type is disabled in Cabal-1.10.x + -- needs more work on the details of the library interface + {- , TestTypeLib (Version [0,9] []) -} ] + +instance Text TestType where + disp (TestTypeExe ver) = text "exitcode-stdio-" <> disp ver + disp (TestTypeLib ver) = text "detailed-" <> disp ver + disp (TestTypeUnknown name ver) = text name <> char '-' <> disp ver + + parse = do + cs <- Parse.sepBy1 component (Parse.char '-') + _ <- Parse.char '-' + ver <- parse + let name = concat (intersperse "-" cs) + return $! case lowercase name of + "exitcode-stdio" -> TestTypeExe ver + "detailed" -> TestTypeLib ver + _ -> TestTypeUnknown name ver + + where + component = do + cs <- Parse.munch1 Char.isAlphaNum + if all Char.isDigit cs then Parse.pfail else return cs + -- each component must contain an alphabetic character, to avoid + -- ambiguity in identifiers like foo-1 (the 1 is the version number). + +testType :: TestSuite -> TestType +testType test = case testInterface test of + TestSuiteExeV10 ver _ -> TestTypeExe ver + TestSuiteLibV09 ver _ -> TestTypeLib ver + TestSuiteUnsupported testtype -> testtype + +-- --------------------------------------------------------------------------- +-- The BuildInfo type + +-- Consider refactoring into executable and library versions. +data BuildInfo = BuildInfo { + buildable :: Bool, -- ^ component is buildable here + buildTools :: [Dependency], -- ^ tools needed to build this bit + cppOptions :: [String], -- ^ options for pre-processing Haskell code + ccOptions :: [String], -- ^ options for C compiler + ldOptions :: [String], -- ^ options for linker + pkgconfigDepends :: [Dependency], -- ^ pkg-config packages that are used + frameworks :: [String], -- ^support frameworks for Mac OS X + cSources :: [FilePath], + hsSourceDirs :: [FilePath], -- ^ where to look for the haskell module hierarchy + otherModules :: [ModuleName], -- ^ non-exposed or non-main modules + + defaultLanguage :: Maybe Language,-- ^ language used when not explicitly specified + otherLanguages :: [Language], -- ^ other languages used within the package + defaultExtensions :: [Extension], -- ^ language extensions used by all modules + otherExtensions :: [Extension], -- ^ other language extensions used within the package + oldExtensions :: [Extension], -- ^ the old extensions field, treated same as 'defaultExtensions' + + extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package + extraLibDirs :: [String], + includeDirs :: [FilePath], -- ^directories to find .h files + includes :: [FilePath], -- ^ The .h files to be found in includeDirs + installIncludes :: [FilePath], -- ^ .h files to install with the package + options :: [(CompilerFlavor,[String])], + ghcProfOptions :: [String], + ghcSharedOptions :: [String], + customFieldsBI :: [(String,String)], -- ^Custom fields starting + -- with x-, stored in a + -- simple assoc-list. + targetBuildDepends :: [Dependency] -- ^ Dependencies specific to a library or executable target + } + deriving (Show,Read,Eq) + +instance Monoid BuildInfo where + mempty = BuildInfo { + buildable = True, + buildTools = [], + cppOptions = [], + ccOptions = [], + ldOptions = [], + pkgconfigDepends = [], + frameworks = [], + cSources = [], + hsSourceDirs = [], + otherModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibDirs = [], + includeDirs = [], + includes = [], + installIncludes = [], + options = [], + ghcProfOptions = [], + ghcSharedOptions = [], + customFieldsBI = [], + targetBuildDepends = [] + } + mappend a b = BuildInfo { + buildable = buildable a && buildable b, + buildTools = combine buildTools, + cppOptions = combine cppOptions, + ccOptions = combine ccOptions, + ldOptions = combine ldOptions, + pkgconfigDepends = combine pkgconfigDepends, + frameworks = combineNub frameworks, + cSources = combineNub cSources, + hsSourceDirs = combineNub hsSourceDirs, + otherModules = combineNub otherModules, + defaultLanguage = combineMby defaultLanguage, + otherLanguages = combineNub otherLanguages, + defaultExtensions = combineNub defaultExtensions, + otherExtensions = combineNub otherExtensions, + oldExtensions = combineNub oldExtensions, + extraLibs = combine extraLibs, + extraLibDirs = combineNub extraLibDirs, + includeDirs = combineNub includeDirs, + includes = combineNub includes, + installIncludes = combineNub installIncludes, + options = combine options, + ghcProfOptions = combine ghcProfOptions, + ghcSharedOptions = combine ghcSharedOptions, + customFieldsBI = combine customFieldsBI, + targetBuildDepends = combineNub targetBuildDepends + } + where + combine field = field a `mappend` field b + combineNub field = nub (combine field) + combineMby field = field b `mplus` field a + +emptyBuildInfo :: BuildInfo +emptyBuildInfo = mempty + +-- | The 'BuildInfo' for the library (if there is one and it's buildable), and +-- all buildable executables and test suites. Useful for gathering dependencies. +allBuildInfo :: PackageDescription -> [BuildInfo] +allBuildInfo pkg_descr = [ bi | Just lib <- [library pkg_descr] + , let bi = libBuildInfo lib + , buildable bi ] + ++ [ bi | exe <- executables pkg_descr + , let bi = buildInfo exe + , buildable bi ] + ++ [ bi | tst <- testSuites pkg_descr + , let bi = testBuildInfo tst + , buildable bi + , testEnabled tst ] + --FIXME: many of the places where this is used, we actually want to look at + -- unbuildable bits too, probably need separate functions + +-- | The 'Language's used by this component +-- +allLanguages :: BuildInfo -> [Language] +allLanguages bi = maybeToList (defaultLanguage bi) + ++ otherLanguages bi + +-- | The 'Extension's that are used somewhere by this component +-- +allExtensions :: BuildInfo -> [Extension] +allExtensions bi = usedExtensions bi + ++ otherExtensions bi + +-- | The 'Extensions' that are used by all modules in this component +-- +usedExtensions :: BuildInfo -> [Extension] +usedExtensions bi = oldExtensions bi + ++ defaultExtensions bi + +type HookedBuildInfo = (Maybe BuildInfo, [(String, BuildInfo)]) + +emptyHookedBuildInfo :: HookedBuildInfo +emptyHookedBuildInfo = (Nothing, []) + +-- |Select options for a particular Haskell compiler. +hcOptions :: CompilerFlavor -> BuildInfo -> [String] +hcOptions hc bi = [ opt | (hc',opts) <- options bi + , hc' == hc + , opt <- opts ] + +-- ------------------------------------------------------------ +-- * Source repos +-- ------------------------------------------------------------ + +-- | Information about the source revision control system for a package. +-- +-- When specifying a repo it is useful to know the meaning or intention of the +-- information as doing so enables automation. There are two obvious common +-- purposes: one is to find the repo for the latest development version, the +-- other is to find the repo for this specific release. The 'ReopKind' +-- specifies which one we mean (or another custom one). +-- +-- A package can specify one or the other kind or both. Most will specify just +-- a head repo but some may want to specify a repo to reconstruct the sources +-- for this package release. +-- +-- The required information is the 'RepoType' which tells us if it's using +-- 'Darcs', 'Git' for example. The 'repoLocation' and other details are +-- interpreted according to the repo type. +-- +data SourceRepo = SourceRepo { + -- | The kind of repo. This field is required. + repoKind :: RepoKind, + + -- | The type of the source repository system for this repo, eg 'Darcs' or + -- 'Git'. This field is required. + repoType :: Maybe RepoType, + + -- | The location of the repository. For most 'RepoType's this is a URL. + -- This field is required. + repoLocation :: Maybe String, + + -- | 'CVS' can put multiple \"modules\" on one server and requires a + -- module name in addition to the location to identify a particular repo. + -- Logically this is part of the location but unfortunately has to be + -- specified separately. This field is required for the 'CVS' 'RepoType' and + -- should not be given otherwise. + repoModule :: Maybe String, + + -- | The name or identifier of the branch, if any. Many source control + -- systems have the notion of multiple branches in a repo that exist in the + -- same location. For example 'Git' and 'CVS' use this while systems like + -- 'Darcs' use different locations for different branches. This field is + -- optional but should be used if necessary to identify the sources, + -- especially for the 'RepoThis' repo kind. + repoBranch :: Maybe String, + + -- | The tag identify a particular state of the repository. This should be + -- given for the 'RepoThis' repo kind and not for 'RepoHead' kind. + -- + repoTag :: Maybe String, + + -- | Some repositories contain multiple projects in different subdirectories + -- This field specifies the subdirectory where this packages sources can be + -- found, eg the subdirectory containing the @.cabal@ file. It is interpreted + -- relative to the root of the repository. This field is optional. If not + -- given the default is \".\" ie no subdirectory. + repoSubdir :: Maybe FilePath +} + deriving (Eq, Read, Show) + +-- | What this repo info is for, what it represents. +-- +data RepoKind = + -- | The repository for the \"head\" or development version of the project. + -- This repo is where we should track the latest development activity or + -- the usual repo people should get to contribute patches. + RepoHead + + -- | The repository containing the sources for this exact package version + -- or release. For this kind of repo a tag should be given to give enough + -- information to re-create the exact sources. + | RepoThis + + | RepoKindUnknown String + deriving (Eq, Ord, Read, Show) + +-- | An enumeration of common source control systems. The fields used in the +-- 'SourceRepo' depend on the type of repo. The tools and methods used to +-- obtain and track the repo depend on the repo type. +-- +data RepoType = Darcs | Git | SVN | CVS + | Mercurial | GnuArch | Bazaar | Monotone + | OtherRepoType String + deriving (Eq, Ord, Read, Show) + +knownRepoTypes :: [RepoType] +knownRepoTypes = [Darcs, Git, SVN, CVS + ,Mercurial, GnuArch, Bazaar, Monotone] + +repoTypeAliases :: RepoType -> [String] +repoTypeAliases Bazaar = ["bzr"] +repoTypeAliases Mercurial = ["hg"] +repoTypeAliases GnuArch = ["arch"] +repoTypeAliases _ = [] + +instance Text RepoKind where + disp RepoHead = Disp.text "head" + disp RepoThis = Disp.text "this" + disp (RepoKindUnknown other) = Disp.text other + + parse = do + name <- ident + return $ case lowercase name of + "head" -> RepoHead + "this" -> RepoThis + _ -> RepoKindUnknown name + +instance Text RepoType where + disp (OtherRepoType other) = Disp.text other + disp other = Disp.text (lowercase (show other)) + parse = fmap classifyRepoType ident + +classifyRepoType :: String -> RepoType +classifyRepoType s = + case lookup (lowercase s) repoTypeMap of + Just repoType' -> repoType' + Nothing -> OtherRepoType s + where + repoTypeMap = [ (name, repoType') + | repoType' <- knownRepoTypes + , name <- display repoType' : repoTypeAliases repoType' ] + +ident :: Parse.ReadP r String +ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') + +lowercase :: String -> String +lowercase = map Char.toLower + +-- ------------------------------------------------------------ +-- * Utils +-- ------------------------------------------------------------ + +updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription +updatePackageDescription (mb_lib_bi, exe_bi) p + = p{ executables = updateExecutables exe_bi (executables p) + , library = updateLibrary mb_lib_bi (library p) + } + where + updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library + updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib}) + updateLibrary Nothing mb_lib = mb_lib + updateLibrary (Just _) Nothing = Nothing + + 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 = bi `mappend` buildInfo exe} : exes + | otherwise = exe : updateExecutable exe_bi' exes + +-- --------------------------------------------------------------------------- +-- The GenericPackageDescription type + +data GenericPackageDescription = + GenericPackageDescription { + packageDescription :: PackageDescription, + genPackageFlags :: [Flag], + condLibrary :: Maybe (CondTree ConfVar [Dependency] Library), + condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)], + condTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] + } + deriving (Show, Eq) + +instance Package GenericPackageDescription where + packageId = packageId . packageDescription + +--TODO: make PackageDescription an instance of Text. + +-- | A flag can represent a feature to be included, or a way of linking +-- a target against its dependencies, or in fact whatever you can think of. +data Flag = MkFlag + { flagName :: FlagName + , flagDescription :: String + , flagDefault :: Bool + , flagManual :: Bool + } + deriving (Show, Eq) + +-- | A 'FlagName' is the name of a user-defined configuration flag +newtype FlagName = FlagName String + deriving (Eq, Ord, Show, Read) + +-- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to +-- 'Bool' flag values. It represents the flags chosen by the user or +-- discovered during configuration. For example @--flags=foo --flags=-bar@ +-- becomes @[("foo", True), ("bar", False)]@ +-- +type FlagAssignment = [(FlagName, Bool)] + +-- | A @ConfVar@ represents the variable type used. +data ConfVar = OS OS + | Arch Arch + | Flag FlagName + | Impl CompilerFlavor VersionRange + deriving (Eq, Show) + +--instance Text ConfVar where +-- disp (OS os) = "os(" ++ display os ++ ")" +-- disp (Arch arch) = "arch(" ++ display arch ++ ")" +-- disp (Flag (ConfFlag f)) = "flag(" ++ f ++ ")" +-- disp (Impl c v) = "impl(" ++ display c +-- ++ " " ++ display v ++ ")" + +-- | A boolean expression parameterized over the variable type used. +data Condition c = Var c + | Lit Bool + | CNot (Condition c) + | COr (Condition c) (Condition c) + | CAnd (Condition c) (Condition c) + deriving (Show, Eq) + +--instance Text c => Text (Condition c) where +-- disp (Var x) = text (show x) +-- disp (Lit b) = text (show b) +-- disp (CNot c) = char '!' <> parens (ppCond c) +-- disp (COr c1 c2) = parens $ sep [ppCond c1, text "||" <+> ppCond c2] +-- disp (CAnd c1 c2) = parens $ sep [ppCond c1, text "&&" <+> ppCond c2] + +data CondTree v c a = CondNode + { condTreeData :: a + , condTreeConstraints :: c + , condTreeComponents :: [( Condition v + , CondTree v c a + , Maybe (CondTree v c a))] + } + deriving (Show, Eq) + +--instance (Text v, Text c) => Text (CondTree v c a) where +-- disp (CondNode _dat cs ifs) = +-- (text "build-depends: " <+> +-- disp cs) +-- $+$ +-- (vcat $ map ppIf ifs) +-- where +-- ppIf (c,thenTree,mElseTree) = +-- ((text "if" <+> ppCond c <> colon) $$ +-- nest 2 (ppCondTree thenTree disp)) +-- $+$ (maybe empty (\t -> text "else: " $$ nest 2 (ppCondTree t disp)) +-- mElseTree) diff --git a/cabal/cabal/Distribution/PackageDescription/Check.hs b/cabal/cabal/Distribution/PackageDescription/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/PackageDescription/Check.hs @@ -0,0 +1,1441 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription.Check +-- Copyright : Lennart Kolmodin 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This has code for checking for various problems in packages. There is one +-- set of checks that just looks at a 'PackageDescription' in isolation and +-- another set of checks that also looks at files in the package. Some of the +-- checks are basic sanity checks, others are portability standards that we'd +-- like to encourage. There is a 'PackageCheck' type that distinguishes the +-- different kinds of check so we can see which ones are appropriate to report +-- in different situations. This code gets uses when configuring a package when +-- we consider only basic problems. The higher standard is uses when when +-- preparing a source tarball and by hackage when uploading new packages. The +-- reason for this is that we want to hold packages that are expected to be +-- distributed to a higher standard than packages that are only ever expected +-- to be used on the author's own environment. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.PackageDescription.Check ( + -- * Package Checking + PackageCheck(..), + checkPackage, + checkConfiguredPackage, + + -- ** Checking package contents + checkPackageFiles, + checkPackageContent, + CheckPackageContentOps(..), + checkPackageFileNames, + ) where + +import Data.Maybe + ( isNothing, isJust, catMaybes, maybeToList, fromMaybe ) +import Data.List (sort, group, isPrefixOf, nub, find) +import Control.Monad + ( filterM, liftM ) +import qualified System.Directory as System + ( doesFileExist, doesDirectoryExist ) + +import Distribution.Package ( pkgName ) +import Distribution.PackageDescription +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription, finalizePackageDescription ) +import Distribution.Compiler + ( CompilerFlavor(..), buildCompilerFlavor, CompilerId(..) ) +import Distribution.System + ( OS(..), Arch(..), buildPlatform ) +import Distribution.License + ( License(..), knownLicenses ) +import Distribution.Simple.Utils + ( cabalVersion, intercalate, parseFileGlob, FileGlob(..), lowercase ) + +import Distribution.Version + ( Version(..) + , VersionRange(..), foldVersionRange' + , anyVersion, noVersion, thisVersion, laterVersion, earlierVersion + , orLaterVersion, orEarlierVersion + , unionVersionRanges, intersectVersionRanges + , asVersionIntervals, UpperBound(..), isNoVersion ) +import Distribution.Package + ( PackageName(PackageName), packageName, packageVersion + , Dependency(..) ) + +import Distribution.Text + ( display, disp ) +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>), (<+>)) + +import qualified Language.Haskell.Extension as Extension (deprecatedExtensions) +import Language.Haskell.Extension + ( Language(UnknownLanguage), knownLanguages, Extension(..), KnownExtension(..) ) +import System.FilePath + ( (), takeExtension, isRelative, isAbsolute + , splitDirectories, splitPath ) +import System.FilePath.Windows as FilePath.Windows + ( isValid ) + +-- | Results of some kind of failed package check. +-- +-- There are a range of severities, from merely dubious to totally insane. +-- All of them come with a human readable explanation. In future we may augment +-- them with more machine readable explanations, for example to help an IDE +-- suggest automatic corrections. +-- +data PackageCheck = + + -- | This package description is no good. There's no way it's going to + -- build sensibly. This should give an error at configure time. + PackageBuildImpossible { explanation :: String } + + -- | A problem that is likely to affect building the package, or an + -- issue that we'd like every package author to be aware of, even if + -- the package is never distributed. + | PackageBuildWarning { explanation :: String } + + -- | An issue that might not be a problem for the package author but + -- might be annoying or determental when the package is distributed to + -- users. We should encourage distributed packages to be free from these + -- issues, but occasionally there are justifiable reasons so we cannot + -- ban them entirely. + | PackageDistSuspicious { explanation :: String } + + -- | An issue that is ok in the author's environment but is almost + -- certain to be a portability problem for other environments. We can + -- quite legitimately refuse to publicly distribute packages with these + -- problems. + | PackageDistInexcusable { explanation :: String } + +instance Show PackageCheck where + show notice = explanation notice + +check :: Bool -> PackageCheck -> Maybe PackageCheck +check False _ = Nothing +check True pc = Just pc + +-- ------------------------------------------------------------ +-- * Standard checks +-- ------------------------------------------------------------ + +-- | Check for common mistakes and problems in package descriptions. +-- +-- This is the standard collection of checks covering all apsects except +-- for checks that require looking at files within the package. For those +-- see 'checkPackageFiles'. +-- +-- It requires the 'GenericPackageDescription' and optionally a particular +-- configuration of that package. If you pass 'Nothing' then we just check +-- a version of the generic description using 'flattenPackageDescription'. +-- +checkPackage :: GenericPackageDescription + -> Maybe PackageDescription + -> [PackageCheck] +checkPackage gpkg mpkg = + checkConfiguredPackage pkg + ++ checkConditionals gpkg + ++ checkPackageVersions gpkg + where + pkg = fromMaybe (flattenPackageDescription gpkg) mpkg + +--TODO: make this variant go away +-- we should alwaws know the GenericPackageDescription +checkConfiguredPackage :: PackageDescription -> [PackageCheck] +checkConfiguredPackage pkg = + checkSanity pkg + ++ checkFields pkg + ++ checkLicense pkg + ++ checkSourceRepos pkg + ++ checkGhcOptions pkg + ++ checkCCOptions pkg + ++ checkPaths pkg + ++ checkCabalVersion pkg + + +-- ------------------------------------------------------------ +-- * Basic sanity checks +-- ------------------------------------------------------------ + +-- | Check that this package description is sane. +-- +checkSanity :: PackageDescription -> [PackageCheck] +checkSanity pkg = + catMaybes [ + + check (null . (\(PackageName n) -> n) . packageName $ pkg) $ + PackageBuildImpossible "No 'name' field." + + , check (null . versionBranch . packageVersion $ pkg) $ + PackageBuildImpossible "No 'version' field." + + , check (null (executables pkg) && isNothing (library pkg)) $ + PackageBuildImpossible + "No executables and no library found. Nothing to do." + + , check (not (null exeDuplicates)) $ + PackageBuildImpossible $ "Duplicate executable sections " + ++ commaSep exeDuplicates + , check (not (null testDuplicates)) $ + PackageBuildImpossible $ "Duplicate test sections " + ++ commaSep testDuplicates + + --TODO: this seems to duplicate a check on the testsuites + , check (not (null testsThatAreExes)) $ + PackageBuildImpossible $ "These test sections share names with executable sections: " + ++ commaSep testsThatAreExes + ] + --TODO: check for name clashes case insensitively: windows file systems cannot cope. + + ++ maybe [] checkLibrary (library pkg) + ++ concatMap checkExecutable (executables pkg) + ++ concatMap (checkTestSuite pkg) (testSuites pkg) + + ++ catMaybes [ + + check (specVersion pkg > cabalVersion) $ + PackageBuildImpossible $ + "This package description follows version " + ++ display (specVersion pkg) ++ " of the Cabal specification. This " + ++ "tool only supports up to version " ++ display cabalVersion ++ "." + ] + where + exeNames = map exeName $ executables pkg + testNames = map testName $ testSuites pkg + exeDuplicates = dups exeNames + testDuplicates = dups testNames + testsThatAreExes = filter (flip elem exeNames) testNames + +checkLibrary :: Library -> [PackageCheck] +checkLibrary lib = + catMaybes [ + + check (not (null moduleDuplicates)) $ + PackageBuildWarning $ + "Duplicate modules in library: " + ++ commaSep (map display moduleDuplicates) + ] + + where + moduleDuplicates = dups (libModules lib) + +checkExecutable :: Executable -> [PackageCheck] +checkExecutable exe = + catMaybes [ + + check (null (modulePath exe)) $ + PackageBuildImpossible $ + "No 'Main-Is' field found for executable " ++ exeName exe + + , check (not (null (modulePath exe)) + && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $ + PackageBuildImpossible $ + "The 'Main-Is' field must specify a '.hs' or '.lhs' file " + ++ "(even if it is generated by a preprocessor)." + + , check (not (null moduleDuplicates)) $ + PackageBuildWarning $ + "Duplicate modules in executable '" ++ exeName exe ++ "': " + ++ commaSep (map display moduleDuplicates) + ] + where + moduleDuplicates = dups (exeModules exe) + +checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck] +checkTestSuite pkg test = + catMaybes [ + + case testInterface test of + TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $ + PackageBuildWarning $ + quote (display tt) ++ " is not a known type of test suite. " + ++ "The known test suite types are: " + ++ commaSep (map display knownTestTypes) + + TestSuiteUnsupported tt -> Just $ + PackageBuildWarning $ + quote (display tt) ++ " is not a supported test suite version. " + ++ "The known test suite types are: " + ++ commaSep (map display knownTestTypes) + _ -> Nothing + + , check (not $ null moduleDuplicates) $ + PackageBuildWarning $ + "Duplicate modules in test suite '" ++ testName test ++ "': " + ++ commaSep (map display moduleDuplicates) + + , check mainIsWrongExt $ + PackageBuildImpossible $ + "The 'main-is' field must specify a '.hs' or '.lhs' file " + ++ "(even if it is generated by a preprocessor)." + + , check exeNameClash $ + PackageBuildImpossible $ + "The test suite " ++ testName test + ++ " has the same name as an executable." + + , check libNameClash $ + PackageBuildImpossible $ + "The test suite " ++ testName test + ++ " has the same name as the package." + ] + where + moduleDuplicates = dups $ testModules test + + mainIsWrongExt = case testInterface test of + TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] + _ -> False + + exeNameClash = testName test `elem` [ exeName exe | exe <- executables pkg ] + libNameClash = testName test `elem` [ libName + | _lib <- maybeToList (library pkg) + , let PackageName libName = + pkgName (package pkg) ] + +-- ------------------------------------------------------------ +-- * Additional pure checks +-- ------------------------------------------------------------ + +checkFields :: PackageDescription -> [PackageCheck] +checkFields pkg = + catMaybes [ + + check (not . FilePath.Windows.isValid . display . packageName $ pkg) $ + PackageDistInexcusable $ + "Unfortunately, the package name '" ++ display (packageName pkg) + ++ "' is one of the reserved system file names on Windows. Many tools " + ++ "need to convert package names to file names so using this name " + ++ "would cause problems." + + , check (isNothing (buildType pkg)) $ + PackageBuildWarning $ + "No 'build-type' specified. If you do not need a custom Setup.hs or " + ++ "./configure script then use 'build-type: Simple'." + + , case buildType pkg of + Just (UnknownBuildType unknown) -> Just $ + PackageBuildWarning $ + quote unknown ++ " is not a known 'build-type'. " + ++ "The known build types are: " + ++ commaSep (map display knownBuildTypes) + _ -> Nothing + + , check (not (null unknownCompilers)) $ + PackageBuildWarning $ + "Unknown compiler " ++ commaSep (map quote unknownCompilers) + ++ " in 'tested-with' field." + + , check (not (null unknownLanguages)) $ + PackageBuildWarning $ + "Unknown languages: " ++ commaSep unknownLanguages + + , check (not (null unknownExtensions)) $ + PackageBuildWarning $ + "Unknown extensions: " ++ commaSep unknownExtensions + + , check (not (null languagesUsedAsExtensions)) $ + PackageBuildWarning $ + "Languages listed as extensions: " + ++ commaSep languagesUsedAsExtensions + ++ ". Languages must be specified in either the 'default-language' " + ++ " or the 'other-languages' field." + + , check (not (null deprecatedExtensions)) $ + PackageDistSuspicious $ + "Deprecated extensions: " + ++ commaSep (map (quote . display . fst) deprecatedExtensions) + ++ ". " ++ intercalate " " + [ "Instead of '" ++ display ext + ++ "' use '" ++ display replacement ++ "'." + | (ext, Just replacement) <- deprecatedExtensions ] + + , check (null (category pkg)) $ + PackageDistSuspicious "No 'category' field." + + , check (null (maintainer pkg)) $ + PackageDistSuspicious "No 'maintainer' field." + + , check (null (synopsis pkg) && null (description pkg)) $ + PackageDistInexcusable $ "No 'synopsis' or 'description' field." + + , check (null (description pkg) && not (null (synopsis pkg))) $ + PackageDistSuspicious "No 'description' field." + + , check (null (synopsis pkg) && not (null (description pkg))) $ + PackageDistSuspicious "No 'synopsis' field." + + --TODO: recommend the bug reports url, author and homepage fields + --TODO: recommend not using the stability field + --TODO: recommend specifying a source repo + + , check (length (synopsis pkg) >= 80) $ + PackageDistSuspicious + "The 'synopsis' field is rather long (max 80 chars is recommended)." + + -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12" + , check (not (null testedWithImpossibleRanges)) $ + PackageDistInexcusable $ + "Invalid 'tested-with' version range: " + ++ commaSep (map display testedWithImpossibleRanges) + ++ ". To indicate that you have tested a package with multiple " + ++ "different versions of the same compiler use multiple entries, " + ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not " + ++ "'tested-with: GHC==6.10.4 && ==6.12.3'." + ] + where + unknownCompilers = [ name | (OtherCompiler name, _) <- testedWith pkg ] + unknownLanguages = [ name | bi <- allBuildInfo pkg + , UnknownLanguage name <- allLanguages bi ] + unknownExtensions = [ name | bi <- allBuildInfo pkg + , UnknownExtension name <- allExtensions bi + , name `notElem` map display knownLanguages ] + deprecatedExtensions = nub $ catMaybes + [ find ((==ext) . fst) Extension.deprecatedExtensions + | bi <- allBuildInfo pkg + , ext <- allExtensions bi ] + languagesUsedAsExtensions = + [ name | bi <- allBuildInfo pkg + , UnknownExtension name <- allExtensions bi + , name `elem` map display knownLanguages ] + + testedWithImpossibleRanges = + [ Dependency (PackageName (display compiler)) vr + | (compiler, vr) <- testedWith pkg + , isNoVersion vr ] + + +checkLicense :: PackageDescription -> [PackageCheck] +checkLicense pkg = + catMaybes [ + + check (license pkg == AllRightsReserved) $ + PackageDistInexcusable + "The 'license' field is missing or specified as AllRightsReserved." + + , case license pkg of + UnknownLicense l -> Just $ + PackageBuildWarning $ + quote ("license: " ++ l) ++ " is not a recognised license. The " + ++ "known licenses are: " + ++ commaSep (map display knownLicenses) + _ -> Nothing + + , check (license pkg == BSD4) $ + PackageDistSuspicious $ + "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' " + ++ "refers to the old 4-clause BSD license with the advertising " + ++ "clause. 'BSD3' refers the new 3-clause BSD license." + + , case unknownLicenseVersion (license pkg) of + Just knownVersions -> Just $ + PackageDistSuspicious $ + "'license: " ++ display (license pkg) ++ "' is not a known " + ++ "version of that license. The known versions are " + ++ commaSep (map display knownVersions) + ++ ". If this is not a mistake and you think it should be a known " + ++ "version then please file a ticket." + _ -> Nothing + + , check (license pkg `notElem` [AllRightsReserved, PublicDomain] + -- AllRightsReserved and PublicDomain are not strictly + -- licenses so don't need license files. + && null (licenseFile pkg)) $ + PackageDistSuspicious "A 'license-file' is not specified." + ] + where + unknownLicenseVersion (GPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where knownVersions = [ v' | GPL (Just v') <- knownLicenses ] + unknownLicenseVersion (LGPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ] + unknownLicenseVersion _ = Nothing + +checkSourceRepos :: PackageDescription -> [PackageCheck] +checkSourceRepos pkg = + catMaybes $ concat [[ + + case repoKind repo of + RepoKindUnknown kind -> Just $ PackageDistInexcusable $ + quote kind ++ " is not a recognised kind of source-repository. " + ++ "The repo kind is usually 'head' or 'this'" + _ -> Nothing + + , check (repoType repo == Nothing) $ + PackageDistInexcusable + "The source-repository 'type' is a required field." + + , check (repoLocation repo == Nothing) $ + PackageDistInexcusable + "The source-repository 'location' is a required field." + + , check (repoType repo == Just CVS && repoModule repo == Nothing) $ + PackageDistInexcusable + "For a CVS source-repository, the 'module' is a required field." + + , check (repoKind repo == RepoThis && repoTag repo == Nothing) $ + PackageDistInexcusable $ + "For the 'this' kind of source-repository, the 'tag' is a required " + ++ "field. It should specify the tag corresponding to this version " + ++ "or release of the package." + + , check (maybe False System.FilePath.isAbsolute (repoSubdir repo)) $ + PackageDistInexcusable + "The 'subdir' field of a source-repository must be a relative path." + ] + | repo <- sourceRepos pkg ] + +--TODO: check location looks like a URL for some repo types. + +checkGhcOptions :: PackageDescription -> [PackageCheck] +checkGhcOptions pkg = + catMaybes [ + + check has_WerrorWall $ + PackageDistInexcusable $ + "'ghc-options: -Wall -Werror' makes the package very easy to " + ++ "break with future GHC versions because new GHC versions often " + ++ "add new warnings. Use just 'ghc-options: -Wall' instead." + + , check (not has_WerrorWall && has_Werror) $ + PackageDistSuspicious $ + "'ghc-options: -Werror' makes the package easy to " + ++ "break with future GHC versions because new GHC versions often " + ++ "add new warnings." + + , checkFlags ["-fasm"] $ + PackageDistInexcusable $ + "'ghc-options: -fasm' is unnecessary and will not work on CPU " + ++ "architectures other than x86, x86-64, ppc or sparc." + + , checkFlags ["-fvia-C"] $ + PackageDistSuspicious $ + "'ghc-options: -fvia-C' is usually unnecessary. If your package " + ++ "needs -via-C for correctness rather than performance then it " + ++ "is using the FFI incorrectly and will probably not work with GHC " + ++ "6.10 or later." + + , checkFlags ["-fhpc"] $ + PackageDistInexcusable $ + "'ghc-options: -fhpc' is not appropriate for a distributed package." + + , check (any ("-d" `isPrefixOf`) all_ghc_options) $ + PackageDistInexcusable $ + "'ghc-options: -d*' debug flags are not appropriate for a distributed package." + + , checkFlags ["-prof"] $ + PackageBuildWarning $ + "'ghc-options: -prof' is not necessary and will lead to problems " + ++ "when used on a library. Use the configure flag " + ++ "--enable-library-profiling and/or --enable-executable-profiling." + + , checkFlags ["-o"] $ + PackageBuildWarning $ + "'ghc-options: -o' is not needed. The output files are named automatically." + + , checkFlags ["-hide-package"] $ + PackageBuildWarning $ + "'ghc-options: -hide-package' is never needed. Cabal hides all packages." + + , checkFlags ["--make"] $ + PackageBuildWarning $ + "'ghc-options: --make' is never needed. Cabal uses this automatically." + + , checkFlags ["-main-is"] $ + PackageDistSuspicious $ + "'ghc-options: -main-is' is not portable." + + , checkFlags ["-O0", "-Onot"] $ + PackageDistSuspicious $ + "'ghc-options: -O0' is not needed. Use the --disable-optimization configure flag." + + , checkFlags [ "-O", "-O1"] $ + PackageDistInexcusable $ + "'ghc-options: -O' is not needed. Cabal automatically adds the '-O' flag. " + ++ "Setting it yourself interferes with the --disable-optimization flag." + + , checkFlags ["-O2"] $ + PackageDistSuspicious $ + "'ghc-options: -O2' is rarely needed. Check that it is giving a real benefit " + ++ "and not just imposing longer compile times on your users." + + , checkFlags ["-split-objs"] $ + PackageBuildWarning $ + "'ghc-options: -split-objs' is not needed. Use the --enable-split-objs configure flag." + + , checkFlags ["-optl-Wl,-s", "-optl-s"] $ + PackageDistInexcusable $ + "'ghc-options: -optl-Wl,-s' is not needed and is not portable to all" + ++ " operating systems. Cabal 1.4 and later automatically strip" + ++ " executables. Cabal also has a flag --disable-executable-stripping" + ++ " which is necessary when building packages for some Linux" + ++ " distributions and using '-optl-Wl,-s' prevents that from working." + + , checkFlags ["-fglasgow-exts"] $ + PackageDistSuspicious $ + "Instead of 'ghc-options: -fglasgow-exts' it is preferable to use the 'extensions' field." + + , check ("-threaded" `elem` lib_ghc_options) $ + PackageDistSuspicious $ + "'ghc-options: -threaded' has no effect for libraries. It should " + ++ "only be used for executables." + + , checkAlternatives "ghc-options" "extensions" + [ (flag, display extension) | flag <- all_ghc_options + , Just extension <- [ghcExtension flag] ] + + , checkAlternatives "ghc-options" "extensions" + [ (flag, extension) | flag@('-':'X':extension) <- all_ghc_options ] + + , checkAlternatives "ghc-options" "cpp-options" $ + [ (flag, flag) | flag@('-':'D':_) <- all_ghc_options ] + ++ [ (flag, flag) | flag@('-':'U':_) <- all_ghc_options ] + + , checkAlternatives "ghc-options" "include-dirs" + [ (flag, dir) | flag@('-':'I':dir) <- all_ghc_options ] + + , checkAlternatives "ghc-options" "extra-libraries" + [ (flag, lib) | flag@('-':'l':lib) <- all_ghc_options ] + + , checkAlternatives "ghc-options" "extra-lib-dirs" + [ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ] + ] + + where + has_WerrorWall = flip any ghc_options $ \opts -> + "-Werror" `elem` opts + && ("-Wall" `elem` opts || "-W" `elem` opts) + has_Werror = any (\opts -> "-Werror" `elem` opts) ghc_options + + ghc_options = [ strs | bi <- allBuildInfo pkg + , (GHC, strs) <- options bi ] + all_ghc_options = concat ghc_options + lib_ghc_options = maybe [] (hcOptions GHC . libBuildInfo) (library pkg) + + checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck + checkFlags flags = check (any (`elem` flags) all_ghc_options) + + ghcExtension ('-':'f':name) = case name of + "allow-overlapping-instances" -> Just (EnableExtension OverlappingInstances) + "no-allow-overlapping-instances" -> Just (DisableExtension OverlappingInstances) + "th" -> Just (EnableExtension TemplateHaskell) + "no-th" -> Just (DisableExtension TemplateHaskell) + "ffi" -> Just (EnableExtension ForeignFunctionInterface) + "no-ffi" -> Just (DisableExtension ForeignFunctionInterface) + "fi" -> Just (EnableExtension ForeignFunctionInterface) + "no-fi" -> Just (DisableExtension ForeignFunctionInterface) + "monomorphism-restriction" -> Just (EnableExtension MonomorphismRestriction) + "no-monomorphism-restriction" -> Just (DisableExtension MonomorphismRestriction) + "mono-pat-binds" -> Just (EnableExtension MonoPatBinds) + "no-mono-pat-binds" -> Just (DisableExtension MonoPatBinds) + "allow-undecidable-instances" -> Just (EnableExtension UndecidableInstances) + "no-allow-undecidable-instances" -> Just (DisableExtension UndecidableInstances) + "allow-incoherent-instances" -> Just (EnableExtension IncoherentInstances) + "no-allow-incoherent-instances" -> Just (DisableExtension IncoherentInstances) + "arrows" -> Just (EnableExtension Arrows) + "no-arrows" -> Just (DisableExtension Arrows) + "generics" -> Just (EnableExtension Generics) + "no-generics" -> Just (DisableExtension Generics) + "implicit-prelude" -> Just (EnableExtension ImplicitPrelude) + "no-implicit-prelude" -> Just (DisableExtension ImplicitPrelude) + "implicit-params" -> Just (EnableExtension ImplicitParams) + "no-implicit-params" -> Just (DisableExtension ImplicitParams) + "bang-patterns" -> Just (EnableExtension BangPatterns) + "no-bang-patterns" -> Just (DisableExtension BangPatterns) + "scoped-type-variables" -> Just (EnableExtension ScopedTypeVariables) + "no-scoped-type-variables" -> Just (DisableExtension ScopedTypeVariables) + "extended-default-rules" -> Just (EnableExtension ExtendedDefaultRules) + "no-extended-default-rules" -> Just (DisableExtension ExtendedDefaultRules) + _ -> Nothing + ghcExtension "-cpp" = Just (EnableExtension CPP) + ghcExtension _ = Nothing + +checkCCOptions :: PackageDescription -> [PackageCheck] +checkCCOptions pkg = + catMaybes [ + + checkAlternatives "cc-options" "include-dirs" + [ (flag, dir) | flag@('-':'I':dir) <- all_ccOptions ] + + , checkAlternatives "cc-options" "extra-libraries" + [ (flag, lib) | flag@('-':'l':lib) <- all_ccOptions ] + + , checkAlternatives "cc-options" "extra-lib-dirs" + [ (flag, dir) | flag@('-':'L':dir) <- all_ccOptions ] + + , checkAlternatives "ld-options" "extra-libraries" + [ (flag, lib) | flag@('-':'l':lib) <- all_ldOptions ] + + , checkAlternatives "ld-options" "extra-lib-dirs" + [ (flag, dir) | flag@('-':'L':dir) <- all_ldOptions ] + + , checkCCFlags [ "-O", "-Os", "-O0", "-O1", "-O2", "-O3" ] $ + PackageDistSuspicious $ + "'cc-options: -O[n]' is generally not needed. When building with " + ++ " optimisations Cabal automatically adds '-O2' for C code. " + ++ "Setting it yourself interferes with the --disable-optimization " + ++ "flag." + ] + + where all_ccOptions = [ opts | bi <- allBuildInfo pkg + , opts <- ccOptions bi ] + all_ldOptions = [ opts | bi <- allBuildInfo pkg + , opts <- ldOptions bi ] + + checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck + checkCCFlags flags = check (any (`elem` flags) all_ccOptions) + +checkAlternatives :: String -> String -> [(String, String)] -> Maybe PackageCheck +checkAlternatives badField goodField flags = + check (not (null badFlags)) $ + PackageBuildWarning $ + "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags) + ++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags) + + where (badFlags, goodFlags) = unzip flags + +checkPaths :: PackageDescription -> [PackageCheck] +checkPaths pkg = + [ PackageBuildWarning $ + quote (kind ++ ": " ++ path) + ++ " is a relative path outside of the source tree. " + ++ "This will not work when generating a tarball with 'sdist'." + | (path, kind) <- relPaths ++ absPaths + , isOutsideTree path ] + ++ + [ PackageDistInexcusable $ + quote (kind ++ ": " ++ path) ++ " is an absolute directory." + | (path, kind) <- relPaths + , isAbsolute path ] + ++ + [ PackageDistInexcusable $ + quote (kind ++ ": " ++ path) ++ " points inside the 'dist' " + ++ "directory. This is not reliable because the location of this " + ++ "directory is configurable by the user (or package manager). In " + ++ "addition the layout of the 'dist' directory is subject to change " + ++ "in future versions of Cabal." + | (path, kind) <- relPaths ++ absPaths + , isInsideDist path ] + ++ + [ PackageDistInexcusable $ + "The 'ghc-options' contains the path '" ++ path ++ "' which points " + ++ "inside the 'dist' directory. This is not reliable because the " + ++ "location of this directory is configurable by the user (or package " + ++ "manager). In addition the layout of the 'dist' directory is subject " + ++ "to change in future versions of Cabal." + | bi <- allBuildInfo pkg + , (GHC, flags) <- options bi + , path <- flags + , isInsideDist path ] + where + isOutsideTree path = case splitDirectories path of + "..":_ -> True + ".":"..":_ -> True + _ -> False + isInsideDist path = case map lowercase (splitDirectories path) of + "dist" :_ -> True + ".":"dist":_ -> True + _ -> False + -- paths that must be relative + relPaths = + [ (path, "extra-src-files") | path <- extraSrcFiles pkg ] + ++ [ (path, "extra-tmp-files") | path <- extraTmpFiles pkg ] + ++ [ (path, "data-files") | path <- dataFiles pkg ] + ++ [ (path, "data-dir") | path <- [dataDir pkg]] + ++ concat + [ [ (path, "c-sources") | path <- cSources bi ] + ++ [ (path, "install-includes") | path <- installIncludes bi ] + ++ [ (path, "hs-source-dirs") | path <- hsSourceDirs bi ] + | bi <- allBuildInfo pkg ] + -- paths that are allowed to be absolute + absPaths = concat + [ [ (path, "includes") | path <- includes bi ] + ++ [ (path, "include-dirs") | path <- includeDirs bi ] + ++ [ (path, "extra-lib-dirs") | path <- extraLibDirs bi ] + | bi <- allBuildInfo pkg ] + +--TODO: check sets of paths that would be interpreted differently between unix +-- and windows, ie case-sensitive or insensitive. Things that might clash, or +-- conversely be distinguished. + +--TODO: use the tar path checks on all the above paths + +-- | Check that the package declares the version in the @\"cabal-version\"@ +-- field correctly. +-- +checkCabalVersion :: PackageDescription -> [PackageCheck] +checkCabalVersion pkg = + catMaybes [ + + -- check syntax of cabal-version field + check (specVersion pkg >= Version [1,10] [] + && not simpleSpecVersionRangeSyntax) $ + PackageBuildWarning $ + "Packages relying on Cabal 1.10 or later must only specify a " + ++ "version range of the form 'cabal-version: >= x.y'. Use " + ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'." + + -- check syntax of cabal-version field + , check (specVersion pkg < Version [1,9] [] + && not simpleSpecVersionRangeSyntax) $ + PackageDistSuspicious $ + "It is recommended that the 'cabal-version' field only specify a " + ++ "version range of the form '>= x.y'. Use " + ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'. " + ++ "Tools based on Cabal 1.10 and later will ignore upper bounds." + + -- check syntax of cabal-version field + , checkVersion [1,12] simpleSpecVersionSyntax $ + PackageBuildWarning $ + "With Cabal 1.10 or earlier, the 'cabal-version' field must use " + ++ "range syntax rather than a simple version number. Use " + ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'." + + -- check use of test suite sections + , checkVersion [1,8] (not (null $ testSuites pkg)) $ + PackageDistInexcusable $ + "The 'test-suite' section is new in Cabal 1.10. " + ++ "Unfortunately it messes up the parser in older Cabal versions " + ++ "so you must specify at least 'cabal-version: >= 1.8', but note" + ++ "that only Cabal 1.10 and later can actually run such test suites." + + -- check use of default-language field + -- note that we do not need to do an equivalent check for the + -- other-language field since that one does not change behaviour + , checkVersion [1,10] (any isJust (buildInfoField defaultLanguage)) $ + PackageBuildWarning $ + "To use the 'default-language' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.10'." + + , check (specVersion pkg >= Version [1,10] [] + && (any isNothing (buildInfoField defaultLanguage))) $ + PackageBuildWarning $ + "Packages using 'cabal-version: >= 1.10' must specify the " + ++ "'default-language' field for each component (e.g. Haskell98 or " + ++ "Haskell2010). If a component uses different languages in " + ++ "different modules then list the other ones in the " + ++ "'other-languages' field." + + -- check use of default-extensions field + -- don't need to do the equivalent check for other-extensions + , checkVersion [1,10] (any (not . null) (buildInfoField defaultExtensions)) $ + PackageBuildWarning $ + "To use the 'default-extensions' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.10'." + + -- check use of extensions field + , check (specVersion pkg >= Version [1,10] [] + && (any (not . null) (buildInfoField oldExtensions))) $ + PackageBuildWarning $ + "For packages using 'cabal-version: >= 1.10' the 'extensions' " + ++ "field is deprecated. The new 'default-extensions' field lists " + ++ "extensions that are used in all modules in the component, while " + ++ "the 'other-extensions' field lists extensions that are used in " + ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma." + + -- check use of "foo (>= 1.0 && < 1.4) || >=1.8 " version-range syntax + , checkVersion [1,8] (not (null versionRangeExpressions)) $ + PackageDistInexcusable $ + "The package uses full version-range expressions " + ++ "in a 'build-depends' field: " + ++ commaSep (map displayRawDependency versionRangeExpressions) + ++ ". To use this new syntax the package needs to specify at least " + ++ "'cabal-version: >= 1.8'. Alternatively, if broader compatibility " + ++ "is important, then convert to conjunctive normal form, and use " + ++ "multiple 'build-depends:' lines, one conjunct per line." + + -- check use of "build-depends: foo == 1.*" syntax + , checkVersion [1,6] (not (null depsUsingWildcardSyntax)) $ + PackageDistInexcusable $ + "The package uses wildcard syntax in the 'build-depends' field: " + ++ commaSep (map display depsUsingWildcardSyntax) + ++ ". To use this new syntax the package need to specify at least " + ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatability " + ++ "is important then use: " ++ commaSep + [ display (Dependency name (eliminateWildcardSyntax versionRange)) + | Dependency name versionRange <- depsUsingWildcardSyntax ] + + -- check use of "tested-with: GHC (>= 1.0 && < 1.4) || >=1.8 " syntax + , checkVersion [1,8] (not (null testedWithVersionRangeExpressions)) $ + PackageDistInexcusable $ + "The package uses full version-range expressions " + ++ "in a 'tested-with' field: " + ++ commaSep (map displayRawDependency testedWithVersionRangeExpressions) + ++ ". To use this new syntax the package needs to specify at least " + ++ "'cabal-version: >= 1.8'." + + -- check use of "tested-with: GHC == 6.12.*" syntax + , checkVersion [1,6] (not (null testedWithUsingWildcardSyntax)) $ + PackageDistInexcusable $ + "The package uses wildcard syntax in the 'tested-with' field: " + ++ commaSep (map display testedWithUsingWildcardSyntax) + ++ ". To use this new syntax the package need to specify at least " + ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatability " + ++ "is important then use: " ++ commaSep + [ display (Dependency name (eliminateWildcardSyntax versionRange)) + | Dependency name versionRange <- testedWithUsingWildcardSyntax ] + + -- check use of "data-files: data/*.txt" syntax + , checkVersion [1,6] (not (null dataFilesUsingGlobSyntax)) $ + PackageDistInexcusable $ + "Using wildcards like " + ++ commaSep (map quote $ take 3 dataFilesUsingGlobSyntax) + ++ " in the 'data-files' field requires 'cabal-version: >= 1.6'. " + ++ "Alternatively if you require compatability with earlier Cabal " + ++ "versions then list all the files explicitly." + + -- check use of "extra-source-files: mk/*.in" syntax + , checkVersion [1,6] (not (null extraSrcFilesUsingGlobSyntax)) $ + PackageDistInexcusable $ + "Using wildcards like " + ++ commaSep (map quote $ take 3 extraSrcFilesUsingGlobSyntax) + ++ " in the 'extra-source-files' field requires " + ++ "'cabal-version: >= 1.6'. Alternatively if you require " + ++ "compatability with earlier Cabal versions then list all the files " + ++ "explicitly." + + -- check use of "source-repository" section + , checkVersion [1,6] (not (null (sourceRepos pkg))) $ + PackageDistInexcusable $ + "The 'source-repository' section is new in Cabal 1.6. " + ++ "Unfortunately it messes up the parser in earlier Cabal versions " + ++ "so you need to specify 'cabal-version: >= 1.6'." + + -- check for new licenses + , checkVersion [1,4] (license pkg `notElem` compatLicenses) $ + PackageDistInexcusable $ + "Unfortunately the license " ++ quote (display (license pkg)) + ++ " messes up the parser in earlier Cabal versions so you need to " + ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " + ++ "compatability with earlier Cabal versions then use 'OtherLicense'." + + -- check for new language extensions + , checkVersion [1,2,3] (not (null mentionedExtensionsThatNeedCabal12)) $ + PackageDistInexcusable $ + "Unfortunately the language extensions " + ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal12) + ++ " break the parser in earlier Cabal versions so you need to " + ++ "specify 'cabal-version: >= 1.2.3'. Alternatively if you require " + ++ "compatability with earlier Cabal versions then you may be able to " + ++ "use an equivalent compiler-specific flag." + + , checkVersion [1,4] (not (null mentionedExtensionsThatNeedCabal14)) $ + PackageDistInexcusable $ + "Unfortunately the language extensions " + ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal14) + ++ " break the parser in earlier Cabal versions so you need to " + ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " + ++ "compatability with earlier Cabal versions then you may be able to " + ++ "use an equivalent compiler-specific flag." + ] + where + -- Perform a check on packages that use a version of the spec less than + -- the version given. This is for cases where a new Cabal version adds + -- a new feature and we want to check that it is not used prior to that + -- version. + checkVersion :: [Int] -> Bool -> PackageCheck -> Maybe PackageCheck + checkVersion ver cond pc + | specVersion pkg >= Version ver [] = Nothing + | otherwise = check cond pc + + buildInfoField field = map field (allBuildInfo pkg) + dataFilesUsingGlobSyntax = filter usesGlobSyntax (dataFiles pkg) + extraSrcFilesUsingGlobSyntax = filter usesGlobSyntax (extraSrcFiles pkg) + usesGlobSyntax str = case parseFileGlob str of + Just (FileGlob _ _) -> True + _ -> False + + versionRangeExpressions = + [ dep | dep@(Dependency _ vr) <- buildDepends pkg + , usesNewVersionRangeSyntax vr ] + + testedWithVersionRangeExpressions = + [ Dependency (PackageName (display compiler)) vr + | (compiler, vr) <- testedWith pkg + , usesNewVersionRangeSyntax vr ] + + simpleSpecVersionRangeSyntax = + either (const True) + (foldVersionRange' + True + (\_ -> False) + (\_ -> False) (\_ -> False) + (\_ -> True) -- >= + (\_ -> False) + (\_ _ -> False) + (\_ _ -> False) (\_ _ -> False) + id) + (specVersionRaw pkg) + + -- is the cabal-version field a simple version number, rather than a range + simpleSpecVersionSyntax = + either (const True) (const False) (specVersionRaw pkg) + + usesNewVersionRangeSyntax :: VersionRange -> Bool + usesNewVersionRangeSyntax = + (> 2) -- uses the new syntax if depth is more than 2 + . foldVersionRange' + (1 :: Int) + (const 1) + (const 1) (const 1) + (const 1) (const 1) + (const (const 1)) + (+) (+) + (const 3) -- uses new ()'s syntax + + depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg + , usesWildcardSyntax vr ] + + testedWithUsingWildcardSyntax = [ Dependency (PackageName (display compiler)) vr + | (compiler, vr) <- testedWith pkg + , usesWildcardSyntax vr ] + + usesWildcardSyntax :: VersionRange -> Bool + usesWildcardSyntax = + foldVersionRange' + False (const False) + (const False) (const False) + (const False) (const False) + (\_ _ -> True) -- the wildcard case + (||) (||) id + + eliminateWildcardSyntax = + foldVersionRange' + anyVersion thisVersion + laterVersion earlierVersion + orLaterVersion orEarlierVersion + (\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v')) + intersectVersionRanges unionVersionRanges id + + compatLicenses = [ GPL Nothing, LGPL Nothing, BSD3, BSD4 + , PublicDomain, AllRightsReserved, OtherLicense ] + + mentionedExtensions = [ ext | bi <- allBuildInfo pkg + , ext <- allExtensions bi ] + mentionedExtensionsThatNeedCabal12 = + nub (filter (`elem` compatExtensionsExtra) mentionedExtensions) + + -- As of Cabal-1.4 we can add new extensions without worrying about + -- breaking old versions of cabal. + mentionedExtensionsThatNeedCabal14 = + nub (filter (`notElem` compatExtensions) mentionedExtensions) + + -- The known extensions in Cabal-1.2.3 + compatExtensions = + map EnableExtension + [ OverlappingInstances, UndecidableInstances, IncoherentInstances + , RecursiveDo, ParallelListComp, MultiParamTypeClasses + , FunctionalDependencies, Rank2Types + , RankNTypes, PolymorphicComponents, ExistentialQuantification + , ScopedTypeVariables, ImplicitParams, FlexibleContexts + , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns + , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface + , Arrows, Generics, NamedFieldPuns, PatternGuards + , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms + , HereDocuments] ++ + map DisableExtension + [MonomorphismRestriction, ImplicitPrelude] ++ + compatExtensionsExtra + + -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6 + -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8) + compatExtensionsExtra = + map EnableExtension + [ KindSignatures, MagicHash, TypeFamilies, StandaloneDeriving + , UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms + , TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields + , OverloadedStrings, GADTs, RelaxedPolyRec + , ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable + , ConstrainedClassMethods + ] ++ + map DisableExtension + [MonoPatBinds] + +-- | A variation on the normal 'Text' instance, shows any ()'s in the original +-- textual syntax. We need to show these otherwise it's confusing to users when +-- we complain of their presense but do not pretty print them! +-- +displayRawVersionRange :: VersionRange -> String +displayRawVersionRange = + Disp.render + . fst + . foldVersionRange' -- precedence: + -- All the same as the usual pretty printer, except for the parens + ( Disp.text "-any" , 0 :: Int) + (\v -> (Disp.text "==" <> disp v , 0)) + (\v -> (Disp.char '>' <> disp v , 0)) + (\v -> (Disp.char '<' <> disp v , 0)) + (\v -> (Disp.text ">=" <> disp v , 0)) + (\v -> (Disp.text "<=" <> disp v , 0)) + (\v _ -> (Disp.text "==" <> dispWild v , 0)) + (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2)) + (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1)) + (\(r, _ ) -> (Disp.parens r, 0)) -- parens + + where + dispWild (Version b _) = + Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) + <> Disp.text ".*" + punct p p' | p < p' = Disp.parens + | otherwise = id + +displayRawDependency :: Dependency -> String +displayRawDependency (Dependency pkg vr) = + display pkg ++ " " ++ displayRawVersionRange vr + + +-- ------------------------------------------------------------ +-- * Checks on the GenericPackageDescription +-- ------------------------------------------------------------ + +-- | Check the build-depends fields for any weirdness or bad practise. +-- +checkPackageVersions :: GenericPackageDescription -> [PackageCheck] +checkPackageVersions pkg = + catMaybes [ + + -- Check that the version of base is bounded above. + -- For example this bans "build-depends: base >= 3". + -- It should probably be "build-depends: base >= 3 && < 4" + -- which is the same as "build-depends: base == 3.*" + check (not (boundedAbove baseDependency)) $ + PackageDistInexcusable $ + "The dependency 'build-depends: base' does not specify an upper " + ++ "bound on the version number. Each major release of the 'base' " + ++ "package changes the API in various ways and most packages will " + ++ "need some changes to compile with it. The recommended practise " + ++ "is to specify an upper bound on the version of the 'base' " + ++ "package. This ensures your package will continue to build when a " + ++ "new major version of the 'base' package is released. If you are " + ++ "not sure what upper bound to use then use the next major " + ++ "version. For example if you have tested your package with 'base' " + ++ "version 2 and 3 then use 'build-depends: base >= 2 && < 4'." + + ] + where + -- TODO: What we really want to do is test if there exists any + -- configuration in which the base version is unboudned above. + -- However that's a bit tricky because there are many possible + -- configurations. As a cheap easy and safe approximation we will + -- pick a single "typical" configuration and check if that has an + -- open upper bound. To get a typical configuration we finalise + -- using no package index and the current platform. + finalised = finalizePackageDescription + [] (const True) buildPlatform + (CompilerId buildCompilerFlavor (Version [] [])) + [] pkg + baseDependency = case finalised of + Right (pkg', _) | not (null baseDeps) -> + foldr intersectVersionRanges anyVersion baseDeps + where + baseDeps = + [ vr | Dependency (PackageName "base") vr <- buildDepends pkg' ] + + -- Just in case finalizePackageDescription fails for any reason, + -- or if the package doesn't depend on the base package at all, + -- then we will just skip the check, since boundedAbove noVersion = True + _ -> noVersion + + boundedAbove :: VersionRange -> Bool + boundedAbove vr = case asVersionIntervals vr of + [] -> True -- this is the inconsistent version range. + intervals -> case last intervals of + (_, UpperBound _ _) -> True + (_, NoUpperBound ) -> False + + +checkConditionals :: GenericPackageDescription -> [PackageCheck] +checkConditionals pkg = + catMaybes [ + + check (not $ null unknownOSs) $ + PackageDistInexcusable $ + "Unknown operating system name " + ++ commaSep (map quote unknownOSs) + + , check (not $ null unknownArches) $ + PackageDistInexcusable $ + "Unknown architecture name " + ++ commaSep (map quote unknownArches) + + , check (not $ null unknownImpls) $ + PackageDistInexcusable $ + "Unknown compiler name " + ++ commaSep (map quote unknownImpls) + ] + where + unknownOSs = [ os | OS (OtherOS os) <- conditions ] + unknownArches = [ arch | Arch (OtherArch arch) <- conditions ] + unknownImpls = [ impl | Impl (OtherCompiler impl) _ <- conditions ] + conditions = maybe [] freeVars (condLibrary pkg) + ++ concatMap (freeVars . snd) (condExecutables pkg) + freeVars (CondNode _ _ ifs) = concatMap compfv ifs + compfv (c, ct, mct) = condfv c ++ freeVars ct ++ maybe [] freeVars mct + condfv c = case c of + Var v -> [v] + Lit _ -> [] + CNot c1 -> condfv c1 + COr c1 c2 -> condfv c1 ++ condfv c2 + CAnd c1 c2 -> condfv c1 ++ condfv c2 + +-- ------------------------------------------------------------ +-- * Checks involving files in the package +-- ------------------------------------------------------------ + +-- | Sanity check things that requires IO. It looks at the files in the +-- package and expects to find the package unpacked in at the given filepath. +-- +checkPackageFiles :: PackageDescription -> FilePath -> IO [PackageCheck] +checkPackageFiles pkg root = checkPackageContent checkFilesIO pkg + where + checkFilesIO = CheckPackageContentOps { + doesFileExist = System.doesFileExist . relative, + doesDirectoryExist = System.doesDirectoryExist . relative + } + relative path = root path + +-- | A record of operations needed to check the contents of packages. +-- Used by 'checkPackageContent'. +-- +data CheckPackageContentOps m = CheckPackageContentOps { + doesFileExist :: FilePath -> m Bool, + doesDirectoryExist :: FilePath -> m Bool + } + +-- | Sanity check things that requires looking at files in the package. +-- This is a generalised version of 'checkPackageFiles' that can work in any +-- monad for which you can provide 'CheckPackageContentOps' operations. +-- +-- The point of this extra generality is to allow doing checks in some virtual +-- file system, for example a tarball in memory. +-- +checkPackageContent :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] +checkPackageContent ops pkg = do + licenseError <- checkLicenseExists ops pkg + setupError <- checkSetupExists ops pkg + configureError <- checkConfigureExists ops pkg + localPathErrors <- checkLocalPathsExist ops pkg + vcsLocation <- checkMissingVcsInfo ops pkg + + return $ catMaybes [licenseError, setupError, configureError] + ++ localPathErrors + ++ vcsLocation + +checkLicenseExists :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m (Maybe PackageCheck) +checkLicenseExists ops pkg + | null (licenseFile pkg) = return Nothing + | otherwise = do + exists <- doesFileExist ops file + return $ check (not exists) $ + PackageBuildWarning $ + "The 'license-file' field refers to the file " ++ quote file + ++ " which does not exist." + + where + file = licenseFile pkg + +checkSetupExists :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m (Maybe PackageCheck) +checkSetupExists ops _ = do + hsexists <- doesFileExist ops "Setup.hs" + lhsexists <- doesFileExist ops "Setup.lhs" + return $ check (not hsexists && not lhsexists) $ + PackageDistInexcusable $ + "The package is missing a Setup.hs or Setup.lhs script." + +checkConfigureExists :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m (Maybe PackageCheck) +checkConfigureExists ops PackageDescription { buildType = Just Configure } = do + exists <- doesFileExist ops "configure" + return $ check (not exists) $ + PackageBuildWarning $ + "The 'build-type' is 'Configure' but there is no 'configure' script." +checkConfigureExists _ _ = return Nothing + +checkLocalPathsExist :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] +checkLocalPathsExist ops pkg = do + let dirs = [ (dir, kind) + | bi <- allBuildInfo pkg + , (dir, kind) <- + [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ] + ++ [ (dir, "include-dirs") | dir <- includeDirs bi ] + ++ [ (dir, "hs-source-dirs") | dir <- hsSourceDirs bi ] + , isRelative dir ] + missing <- filterM (liftM not . doesDirectoryExist ops . fst) dirs + return [ PackageBuildWarning { + explanation = quote (kind ++ ": " ++ dir) + ++ " directory does not exist." + } + | (dir, kind) <- missing ] + +checkMissingVcsInfo :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] +checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do + vcsInUse <- liftM or $ mapM (doesDirectoryExist ops) repoDirnames + if vcsInUse + then return [ PackageDistSuspicious message ] + else return [] + where + repoDirnames = [ dirname | repo <- knownRepoTypes + , dirname <- repoTypeDirname repo ] + message = "When distributing packages it is encouraged to specify source " + ++ "control information in the .cabal file using one or more " + ++ "'source-repository' sections. See the Cabal user guide for " + ++ "details." + +checkMissingVcsInfo _ _ = return [] + +repoTypeDirname :: RepoType -> [FilePath] +repoTypeDirname Darcs = ["_darcs"] +repoTypeDirname Git = [".git"] +repoTypeDirname SVN = [".svn"] +repoTypeDirname CVS = ["CVS"] +repoTypeDirname Mercurial = [".hg"] +repoTypeDirname GnuArch = [".arch-params"] +repoTypeDirname Bazaar = [".bzr"] +repoTypeDirname Monotone = ["_MTN"] +repoTypeDirname _ = [] + +-- ------------------------------------------------------------ +-- * Checks involving files in the package +-- ------------------------------------------------------------ + +-- | Check the names of all files in a package for portability problems. This +-- should be done for example when creating or validating a package tarball. +-- +checkPackageFileNames :: [FilePath] -> [PackageCheck] +checkPackageFileNames files = + (take 1 . catMaybes . map checkWindowsPath $ files) + ++ (take 1 . catMaybes . map checkTarPath $ files) + -- If we get any of these checks triggering then we're likely to get + -- many, and that's probably not helpful, so return at most one. + +checkWindowsPath :: FilePath -> Maybe PackageCheck +checkWindowsPath path = + check (not $ FilePath.Windows.isValid path') $ + PackageDistInexcusable $ + "Unfortunately, the file " ++ quote path ++ " is not a valid file " + ++ "name on Windows which would cause portability problems for this " + ++ "package. Windows file names cannot contain any of the characters " + ++ "\":*?<>|\" and there are a few reserved names including \"aux\", " + ++ "\"nul\", \"con\", \"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"." + where + path' = ".\\" ++ path + -- force a relative name to catch invalid file names like "f:oo" which + -- otherwise parse as file "oo" in the current directory on the 'f' drive. + +-- | Check a file name is valid for the portable POSIX tar format. +-- +-- The POSIX tar format has a restriction on the length of file names. It is +-- unfortunately not a simple restriction like a maximum length. The exact +-- restriction is that either the whole path be 100 characters or less, or it +-- be possible to split the path on a directory separator such that the first +-- part is 155 characters or less and the second part 100 characters or less. +-- +checkTarPath :: FilePath -> Maybe PackageCheck +checkTarPath path + | length path > 255 = Just longPath + | otherwise = case pack nameMax (reverse (splitPath path)) of + Left err -> Just err + Right [] -> Nothing + Right (first:rest) -> case pack prefixMax remainder of + Left err -> Just err + Right [] -> Nothing + Right (_:_) -> Just noSplit + where + -- drop the '/' between the name and prefix: + remainder = init first : rest + + where + nameMax, prefixMax :: Int + nameMax = 100 + prefixMax = 155 + + pack _ [] = Left emptyName + pack maxLen (c:cs) + | n > maxLen = Left longName + | otherwise = Right (pack' maxLen n cs) + where n = length c + + pack' maxLen n (c:cs) + | n' <= maxLen = pack' maxLen n' cs + where n' = n + length c + pack' _ _ cs = cs + + longPath = PackageDistInexcusable $ + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. The maximum length is 255 ASCII characters.\n" + ++ "The file in question is:\n " ++ path + longName = PackageDistInexcusable $ + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. The maximum length for the name part (including " + ++ "extension) is 100 ASCII characters. The maximum length for any " + ++ "individual directory component is 155.\n" + ++ "The file in question is:\n " ++ path + noSplit = PackageDistInexcusable $ + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. While the total length is less than 255 ASCII " + ++ "characters, there are unfortunately further restrictions. It has to " + ++ "be possible to split the file path on a directory separator into " + ++ "two parts such that the first part fits in 155 characters or less " + ++ "and the second part fits in 100 characters or less. Basically you " + ++ "have to make the file name or directory names shorter, or you could " + ++ "split a long directory name into nested subdirectories with shorter " + ++ "names.\nThe file in question is:\n " ++ path + emptyName = PackageDistInexcusable $ + "Encountered a file with an empty name, something is very wrong! " + ++ "Files with an empty name cannot be stored in a tar archive or in " + ++ "standard file systems." + +-- ------------------------------------------------------------ +-- * Utils +-- ------------------------------------------------------------ + +quote :: String -> String +quote s = "'" ++ s ++ "'" + +commaSep :: [String] -> String +commaSep = intercalate ", " + +dups :: Ord a => [a] -> [a] +dups xs = [ x | (x:_:_) <- group (sort xs) ] diff --git a/cabal/cabal/Distribution/PackageDescription/Configuration.hs b/cabal/cabal/Distribution/PackageDescription/Configuration.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/PackageDescription/Configuration.hs @@ -0,0 +1,618 @@ +{-# OPTIONS -cpp #-} +-- OPTIONS required for ghc-6.4.x compat, and must appear first +{-# LANGUAGE CPP #-} +-- -fno-warn-deprecations for use of Map.foldWithKey +{-# OPTIONS_GHC -cpp -fno-warn-deprecations #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Configuration +-- Copyright : Thomas Schilling, 2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is about the cabal configurations feature. It exports +-- 'finalizePackageDescription' and 'flattenPackageDescription' which are +-- functions for converting 'GenericPackageDescription's down to +-- 'PackageDescription's. It has code for working with the tree of conditions +-- and resolving or flattening conditions. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.PackageDescription.Configuration ( + finalizePackageDescription, + flattenPackageDescription, + + -- Utils + parseCondition, + freeVars, + mapCondTree, + mapTreeData, + mapTreeConds, + mapTreeConstrs, + ) where + +import Distribution.Package + ( PackageName, Dependency(..) ) +import Distribution.PackageDescription + ( GenericPackageDescription(..), PackageDescription(..) + , Library(..), Executable(..), BuildInfo(..) + , Flag(..), FlagName(..), FlagAssignment + , CondTree(..), ConfVar(..), Condition(..), TestSuite(..) ) +import Distribution.Version + ( VersionRange, anyVersion, intersectVersionRanges, withinRange ) +import Distribution.Compiler + ( CompilerId(CompilerId) ) +import Distribution.System + ( Platform(..), OS, Arch ) +import Distribution.Simple.Utils + ( currentDir, lowercase ) + +import Distribution.Text + ( Text(parse) ) +import Distribution.Compat.ReadP as ReadP hiding ( char ) +import Control.Arrow (first) +import qualified Distribution.Compat.ReadP as ReadP ( char ) + +import Data.Char ( isAlphaNum ) +import Data.Maybe ( catMaybes, maybeToList ) +import Data.Map ( Map, fromListWith, toList ) +import qualified Data.Map as Map +import Data.Monoid + +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 606) +import qualified Text.Read as R +import qualified Text.Read.Lex as L +#endif + +------------------------------------------------------------------------------ + +-- | Simplify the condition and return its free variables. +simplifyCondition :: Condition c + -> (c -> Either d Bool) -- ^ (partial) variable assignment + -> (Condition d, [d]) +simplifyCondition cond i = fv . walk $ cond + where + walk cnd = case cnd of + Var v -> either Var Lit (i v) + Lit b -> Lit b + CNot c -> case walk c of + Lit True -> Lit False + Lit False -> Lit True + c' -> CNot c' + COr c d -> case (walk c, walk d) of + (Lit False, d') -> d' + (Lit True, _) -> Lit True + (c', Lit False) -> c' + (_, Lit True) -> Lit True + (c',d') -> COr c' d' + CAnd c d -> case (walk c, walk d) of + (Lit False, _) -> Lit False + (Lit True, d') -> d' + (_, Lit False) -> Lit False + (c', Lit True) -> c' + (c',d') -> CAnd c' d' + -- gather free vars + fv c = (c, fv' c) + fv' c = case c of + Var v -> [v] + Lit _ -> [] + CNot c' -> fv' c' + COr c1 c2 -> fv' c1 ++ fv' c2 + CAnd c1 c2 -> fv' c1 ++ fv' c2 + +-- | Simplify a configuration condition using the os and arch names. Returns +-- the names of all the flags occurring in the condition. +simplifyWithSysParams :: OS -> Arch -> CompilerId -> Condition ConfVar + -> (Condition FlagName, [FlagName]) +simplifyWithSysParams os arch (CompilerId comp compVer) cond = (cond', flags) + where + (cond', flags) = simplifyCondition cond interp + interp (OS os') = Right $ os' == os + interp (Arch arch') = Right $ arch' == arch + interp (Impl comp' vr) = Right $ comp' == comp + && compVer `withinRange` vr + interp (Flag f) = Left f + +-- TODO: Add instances and check +-- +-- prop_sC_idempotent cond a o = cond' == cond'' +-- where +-- cond' = simplifyCondition cond a o +-- cond'' = simplifyCondition cond' a o +-- +-- prop_sC_noLits cond a o = isLit res || not (hasLits res) +-- where +-- res = simplifyCondition cond a o +-- hasLits (Lit _) = True +-- hasLits (CNot c) = hasLits c +-- hasLits (COr l r) = hasLits l || hasLits r +-- hasLits (CAnd l r) = hasLits l || hasLits r +-- hasLits _ = False +-- + +-- | Parse a configuration condition from a string. +parseCondition :: ReadP r (Condition ConfVar) +parseCondition = condOr + where + condOr = sepBy1 condAnd (oper "||") >>= return . foldl1 COr + condAnd = sepBy1 cond (oper "&&")>>= return . foldl1 CAnd + cond = sp >> (boolLiteral +++ inparens condOr +++ notCond +++ osCond + +++ archCond +++ flagCond +++ implCond ) + inparens = between (ReadP.char '(' >> sp) (sp >> ReadP.char ')' >> sp) + notCond = ReadP.char '!' >> sp >> cond >>= return . CNot + osCond = string "os" >> sp >> inparens osIdent >>= return . Var + archCond = string "arch" >> sp >> inparens archIdent >>= return . Var + flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var + implCond = string "impl" >> sp >> inparens implIdent >>= return . Var + boolLiteral = fmap Lit parse + archIdent = fmap Arch parse + osIdent = fmap OS parse + flagIdent = fmap (Flag . FlagName . lowercase) (munch1 isIdentChar) + isIdentChar c = isAlphaNum c || c == '_' || c == '-' + oper s = sp >> string s >> sp + sp = skipSpaces + implIdent = do i <- parse + vr <- sp >> option anyVersion parse + return $ Impl i vr + +------------------------------------------------------------------------------ + +mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w) + -> CondTree v c a -> CondTree w d b +mapCondTree fa fc fcnd (CondNode a c ifs) = + CondNode (fa a) (fc c) (map g ifs) + where + g (cnd, t, me) = (fcnd cnd, mapCondTree fa fc fcnd t, + fmap (mapCondTree fa fc fcnd) me) + +mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a +mapTreeConstrs f = mapCondTree id f id + +mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a +mapTreeConds f = mapCondTree id id f + +mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b +mapTreeData f = mapCondTree f id id + +-- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for +-- clarity. +data DepTestRslt d = DepOk | MissingDeps d + +instance Monoid d => Monoid (DepTestRslt d) where + mempty = DepOk + mappend DepOk x = x + mappend x DepOk = x + mappend (MissingDeps d) (MissingDeps d') = MissingDeps (d `mappend` d') + + +data BT a = BTN a | BTB (BT a) (BT a) -- very simple binary tree + + +-- | Try to find a flag assignment that satisfies the constaints of all trees. +-- +-- Returns either the missing dependencies, or a tuple containing the +-- resulting data, the associated dependencies, and the chosen flag +-- assignments. +-- +-- In case of failure, the _smallest_ number of of missing dependencies is +-- returned. [TODO: Could also be specified with a function argument.] +-- +-- TODO: The current algorithm is rather naive. A better approach would be to: +-- +-- * Rule out possible paths, by taking a look at the associated dependencies. +-- +-- * Infer the required values for the conditions of these paths, and +-- calculate the required domains for the variables used in these +-- conditions. Then picking a flag assignment would be linear (I guess). +-- +-- This would require some sort of SAT solving, though, thus it's not +-- implemented unless we really need it. +-- +resolveWithFlags :: + [(FlagName,[Bool])] + -- ^ Domain for each flag name, will be tested in order. + -> OS -- ^ OS as returned by Distribution.System.buildOS + -> Arch -- ^ Arch as returned by Distribution.System.buildArch + -> CompilerId -- ^ Compiler flavour + version + -> [Dependency] -- ^ Additional constraints + -> [CondTree ConfVar [Dependency] PDTagged] + -> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function. + -> Either [Dependency] (TargetSet PDTagged, FlagAssignment) + -- ^ Either the missing dependencies (error case), or a pair of + -- (set of build targets with dependencies, chosen flag assignments) +resolveWithFlags dom os arch impl constrs trees checkDeps = + case try dom [] of + Right r -> Right r + Left dbt -> Left $ findShortest dbt + where + extraConstrs = toDepMap constrs + + -- simplify trees by (partially) evaluating all conditions and converting + -- dependencies to dependency maps. + simplifiedTrees = map ( mapTreeConstrs toDepMap -- convert to maps + . mapTreeConds (fst . simplifyWithSysParams os arch impl)) + trees + + -- @try@ recursively tries all possible flag assignments in the domain and + -- either succeeds or returns a binary tree with the missing dependencies + -- encountered in each run. Since the tree is constructed lazily, we + -- avoid some computation overhead in the successful case. + try [] flags = + let targetSet = TargetSet $ flip map simplifiedTrees $ + -- apply additional constraints to all dependencies + first (`constrainBy` extraConstrs) . + simplifyCondTree (env flags) + deps = overallDependencies targetSet + in case checkDeps (fromDepMap deps) of + DepOk -> Right (targetSet, flags) + MissingDeps mds -> Left (BTN mds) + + try ((n, vals):rest) flags = + tryAll $ map (\v -> try rest ((n, v):flags)) vals + + tryAll = foldr mp mz + + -- special version of `mplus' for our local purposes + mp (Left xs) (Left ys) = (Left (BTB xs ys)) + mp (Left _) m@(Right _) = m + mp m@(Right _) _ = m + + -- `mzero' + mz = Left (BTN []) + + env flags flag = (maybe (Left flag) Right . lookup flag) flags + + -- for the error case we inspect our lazy tree of missing dependencies and + -- pick the shortest list of missing dependencies + findShortest (BTN x) = x + findShortest (BTB lt rt) = + let l = findShortest lt + r = findShortest rt + in case (l,r) of + ([], xs) -> xs -- [] is too short + (xs, []) -> xs + ([x], _) -> [x] -- single elem is optimum + (_, [x]) -> [x] + (xs, ys) -> if lazyLengthCmp xs ys + then xs else ys + -- lazy variant of @\xs ys -> length xs <= length ys@ + lazyLengthCmp [] _ = True + lazyLengthCmp _ [] = False + lazyLengthCmp (_:xs) (_:ys) = lazyLengthCmp xs ys + +-- | A map of dependencies. Newtyped since the default monoid instance is not +-- appropriate. The monoid instance uses 'intersectVersionRanges'. +newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName VersionRange } +#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 606) + deriving (Show, Read) +#else +-- The Show/Read instance for Data.Map in ghc-6.4 is useless +-- so we have to re-implement it here: +instance Show DependencyMap where + showsPrec d (DependencyMap m) = + showParen (d > 10) (showString "DependencyMap" . shows (M.toList m)) + +instance Read DependencyMap where + readPrec = parens $ R.prec 10 $ do + R.Ident "DependencyMap" <- R.lexP + xs <- R.readPrec + return (DependencyMap (M.fromList xs)) + where parens :: R.ReadPrec a -> R.ReadPrec a + parens p = optional + where + optional = p R.+++ mandatory + mandatory = paren optional + + paren :: R.ReadPrec a -> R.ReadPrec a + paren p = do L.Punc "(" <- R.lexP + x <- R.reset p + L.Punc ")" <- R.lexP + return x + + readListPrec = R.readListPrecDefault +#endif + +instance Monoid DependencyMap where + mempty = DependencyMap Map.empty + (DependencyMap a) `mappend` (DependencyMap b) = + DependencyMap (Map.unionWith intersectVersionRanges a b) + +toDepMap :: [Dependency] -> DependencyMap +toDepMap ds = + DependencyMap $ fromListWith intersectVersionRanges [ (p,vr) | Dependency p vr <- ds ] + +fromDepMap :: DependencyMap -> [Dependency] +fromDepMap m = [ Dependency p vr | (p,vr) <- toList (unDependencyMap m) ] + +simplifyCondTree :: (Monoid a, Monoid d) => + (v -> Either v Bool) + -> CondTree v d a + -> (d, a) +simplifyCondTree env (CondNode a d ifs) = + foldr mappend (d, a) $ catMaybes $ map simplifyIf ifs + where + simplifyIf (cnd, t, me) = + case simplifyCondition cnd env of + (Lit True, _) -> Just $ simplifyCondTree env t + (Lit False, _) -> fmap (simplifyCondTree env) me + _ -> error $ "Environment not defined for all free vars" + +-- | Flatten a CondTree. This will resolve the CondTree by taking all +-- possible paths into account. Note that since branches represent exclusive +-- choices this may not result in a \"sane\" result. +ignoreConditions :: (Monoid a, Monoid c) => CondTree v c a -> (a, c) +ignoreConditions (CondNode a c ifs) = (a, c) `mappend` mconcat (concatMap f ifs) + where f (_, t, me) = ignoreConditions t + : maybeToList (fmap ignoreConditions me) + +freeVars :: CondTree ConfVar c a -> [FlagName] +freeVars t = [ f | Flag f <- freeVars' t ] + where + freeVars' (CondNode _ _ ifs) = concatMap compfv ifs + compfv (c, ct, mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct + condfv c = case c of + Var v -> [v] + Lit _ -> [] + CNot c' -> condfv c' + COr c1 c2 -> condfv c1 ++ condfv c2 + CAnd c1 c2 -> condfv c1 ++ condfv c2 + + +------------------------------------------------------------------------------ + +-- | A set of targets with their package dependencies +newtype TargetSet a = TargetSet [(DependencyMap, a)] + +-- | Combine the target-specific dependencies in a TargetSet to give the +-- dependencies for the package as a whole. +overallDependencies :: TargetSet PDTagged -> DependencyMap +overallDependencies (TargetSet targets) = mconcat depss + where + (depss, _) = unzip $ filter (removeDisabledTests . snd) targets + removeDisabledTests :: PDTagged -> Bool + removeDisabledTests (Lib _) = True + removeDisabledTests (Exe _ _) = True + removeDisabledTests (Test _ t) = testEnabled t + removeDisabledTests PDNull = True + +-- Apply extra constraints to a dependency map. +-- Combines dependencies where the result will only contain keys from the left +-- (first) map. If a key also exists in the right map, both constraints will +-- be intersected. +constrainBy :: DependencyMap -- ^ Input map + -> DependencyMap -- ^ Extra constraints + -> DependencyMap +constrainBy left extra = + DependencyMap $ + Map.foldWithKey tightenConstraint (unDependencyMap left) + (unDependencyMap extra) + where tightenConstraint n c l = + case Map.lookup n l of + Nothing -> l + Just vr -> Map.insert n (intersectVersionRanges vr c) l + +-- | Collect up the targets in a TargetSet of tagged targets, storing the +-- dependencies as we go. +flattenTaggedTargets :: TargetSet PDTagged -> + (Maybe Library, [(String, Executable)], [(String, TestSuite)]) +flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], []) targets + where + untag (_, Lib _) (Just _, _, _) = bug "Only one library expected" + untag (deps, Lib l) (Nothing, exes, tests) = (Just l', exes, tests) + where + l' = l { + libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps } + } + untag (deps, Exe n e) (mlib, exes, tests) + | any ((== n) . fst) exes = bug "Exe with same name found" + | any ((== n) . fst) tests = bug "Test sharing name of exe found" + | otherwise = (mlib, exes ++ [(n, e')], tests) + where + e' = e { + buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps } + } + untag (deps, Test n t) (mlib, exes, tests) + | any ((== n) . fst) tests = bug "Test with same name found" + | any ((== n) . fst) exes = bug "Test sharing name of exe found" + | otherwise = (mlib, exes, tests ++ [(n, t')]) + where + t' = t { + testBuildInfo = (testBuildInfo t) + { targetBuildDepends = fromDepMap deps } + } + untag (_, PDNull) x = x -- actually this should not happen, but let's be liberal + + +------------------------------------------------------------------------------ +-- Convert GenericPackageDescription to PackageDescription +-- + +data PDTagged = Lib Library | Exe String Executable | Test String TestSuite | PDNull deriving Show + +instance Monoid PDTagged where + mempty = PDNull + PDNull `mappend` x = x + x `mappend` PDNull = x + Lib l `mappend` Lib l' = Lib (l `mappend` l') + Exe n e `mappend` Exe n' e' | n == n' = Exe n (e `mappend` e') + Test n t `mappend` Test n' t' | n == n' = Test n (t `mappend` t') + _ `mappend` _ = bug "Cannot combine incompatible tags" + +-- | Create a package description with all configurations resolved. +-- +-- This function takes a `GenericPackageDescription` and several environment +-- parameters and tries to generate `PackageDescription` by finding a flag +-- assignment that result in satisfiable dependencies. +-- +-- It takes as inputs a not necessarily complete specifications of flags +-- assignments, an optional package index as well as platform parameters. If +-- some flags are not assigned explicitly, this function will try to pick an +-- assignment that causes this function to succeed. The package index is +-- optional since on some platforms we cannot determine which packages have +-- been installed before. When no package index is supplied, every dependency +-- is assumed to be satisfiable, therefore all not explicitly assigned flags +-- will get their default values. +-- +-- This function will fail if it cannot find a flag assignment that leads to +-- satisfiable dependencies. (It will not try alternative assignments for +-- explicitly specified flags.) In case of failure it will return a /minimum/ +-- number of dependencies that could not be satisfied. On success, it will +-- return the package description and the full flag assignment chosen. +-- +finalizePackageDescription :: + FlagAssignment -- ^ Explicitly specified flag assignments + -> (Dependency -> Bool) -- ^ Is a given depenency satisfiable from the set of available packages? + -- If this is unknown then use True. + -> Platform -- ^ The 'Arch' and 'OS' + -> CompilerId -- ^ Compiler + Version + -> [Dependency] -- ^ Additional constraints + -> GenericPackageDescription + -> Either [Dependency] + (PackageDescription, FlagAssignment) + -- ^ Either missing dependencies or the resolved package + -- description along with the flag assignments chosen. +finalizePackageDescription userflags satisfyDep (Platform arch os) impl constraints + (GenericPackageDescription pkg flags mlib0 exes0 tests0) = + case resolveFlags of + Right ((mlib, exes', tests'), targetSet, flagVals) -> + Right ( pkg { library = mlib + , executables = exes' + , testSuites = tests' + , buildDepends = fromDepMap (overallDependencies targetSet) + --TODO: we need to find a way to avoid pulling in deps + -- for non-buildable components. However cannot simply + -- filter at this stage, since if the package were not + -- available we would have failed already. + } + , flagVals ) + + Left missing -> Left missing + where + -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data + condTrees = maybeToList (fmap (mapTreeData Lib) mlib0 ) + ++ map (\(name,tree) -> mapTreeData (Exe name) tree) exes0 + ++ map (\(name,tree) -> mapTreeData (Test name) tree) tests0 + + resolveFlags = + case resolveWithFlags flagChoices os arch impl constraints condTrees check of + Right (targetSet, fs) -> + let (mlib, exes, tests) = flattenTaggedTargets targetSet in + Right ( (fmap libFillInDefaults mlib, + map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes, + map (\(n,t) -> (testFillInDefaults t) { testName = n }) tests), + targetSet, fs) + Left missing -> Left missing + + flagChoices = map (\(MkFlag n _ d manual) -> (n, d2c manual n d)) flags + d2c manual n b = case lookup n userflags of + Just val -> [val] + Nothing + | manual -> [b] + | otherwise -> [b, not b] + --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices + check ds = if all satisfyDep ds + then DepOk + else MissingDeps $ filter (not . satisfyDep) ds + +{- +let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] []) +let tst_p2 = (CondNode [1::Int] [Distribution.Package.Dependency "a" (EarlierVersion (Version [1,0] [])), Distribution.Package.Dependency "a" (LaterVersion (Version [2,0] []))] []) + +let p_index = Distribution.Simple.PackageIndex.fromList [Distribution.Package.PackageIdentifier "a" (Version [0,5] []), Distribution.Package.PackageIdentifier "a" (Version [2,5] [])] +let look = not . null . Distribution.Simple.PackageIndex.lookupDependency p_index +let looks ds = mconcat $ map (\d -> if look d then DepOk else MissingDeps [d]) ds +resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p] looks ===> Right ... +resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p2] looks ===> Left ... +-} + +-- | Flatten a generic package description by ignoring all conditions and just +-- join the field descriptors into on package description. Note, however, +-- that this may lead to inconsistent field values, since all values are +-- joined into one field, which may not be possible in the original package +-- description, due to the use of exclusive choices (if ... else ...). +-- +-- TODO: One particularly tricky case is defaulting. In the original package +-- description, e.g., the source directory might either be the default or a +-- certain, explicitly set path. Since defaults are filled in only after the +-- package has been resolved and when no explicit value has been set, the +-- default path will be missing from the package description returned by this +-- function. +flattenPackageDescription :: GenericPackageDescription -> PackageDescription +flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0 tests0) = + pkg { library = mlib + , executables = reverse exes + , testSuites = reverse tests + , buildDepends = ldeps ++ reverse edeps ++ reverse tdeps + } + where + (mlib, ldeps) = case mlib0 of + Just lib -> let (l,ds) = ignoreConditions lib in + (Just (libFillInDefaults l), ds) + Nothing -> (Nothing, []) + (exes, edeps) = foldr flattenExe ([],[]) exes0 + (tests, tdeps) = foldr flattenTst ([],[]) tests0 + flattenExe (n, t) (es, ds) = + let (e, ds') = ignoreConditions t in + ( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds ) + flattenTst (n, t) (es, ds) = + let (e, ds') = ignoreConditions t in + ( (testFillInDefaults $ e { testName = n }) : es, ds' ++ ds ) + +-- This is in fact rather a hack. The original version just overrode the +-- default values, however, when adding conditions we had to switch to a +-- modifier-based approach. There, nothing is ever overwritten, but only +-- joined together. +-- +-- This is the cleanest way i could think of, that doesn't require +-- changing all field parsing functions to return modifiers instead. +libFillInDefaults :: Library -> Library +libFillInDefaults lib@(Library { libBuildInfo = bi }) = + lib { libBuildInfo = biFillInDefaults bi } + +exeFillInDefaults :: Executable -> Executable +exeFillInDefaults exe@(Executable { buildInfo = bi }) = + exe { buildInfo = biFillInDefaults bi } + +testFillInDefaults :: TestSuite -> TestSuite +testFillInDefaults tst@(TestSuite { testBuildInfo = bi }) = + tst { testBuildInfo = biFillInDefaults bi } + +biFillInDefaults :: BuildInfo -> BuildInfo +biFillInDefaults bi = + if null (hsSourceDirs bi) + then bi { hsSourceDirs = [currentDir] } + else bi + +bug :: String -> a +bug msg = error $ msg ++ ". Consider this a bug." diff --git a/cabal/cabal/Distribution/PackageDescription/Parse.hs b/cabal/cabal/Distribution/PackageDescription/Parse.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/PackageDescription/Parse.hs @@ -0,0 +1,1074 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription.Parse +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defined parsers and partial pretty printers for the @.cabal@ format. +-- Some of the complexity in this module is due to the fact that we have to be +-- backwards compatible with old @.cabal@ files, so there's code to translate +-- into the newer structure. + +{- 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.Parse ( + -- * Package descriptions + readPackageDescription, + writePackageDescription, + parsePackageDescription, + showPackageDescription, + + -- ** Parsing + ParseResult(..), + FieldDescr(..), + LineNo, + + -- ** Supplementary build information + readHookedBuildInfo, + parseHookedBuildInfo, + writeHookedBuildInfo, + showHookedBuildInfo, + + pkgDescrFieldDescrs, + libFieldDescrs, + executableFieldDescrs, + binfoFieldDescrs, + sourceRepoFieldDescrs, + testSuiteFieldDescrs, + flagFieldDescrs + ) where + +import Data.Char (isSpace) +import Data.Maybe (listToMaybe, isJust) +import Data.Monoid ( Monoid(..) ) +import Data.List (nub, unfoldr, partition, (\\)) +import Control.Monad (liftM, foldM, when, unless) +import System.Directory (doesFileExist) + +import Distribution.Text + ( Text(disp, parse), display, simpleParse ) +import Distribution.Compat.ReadP + ((+++), option) +import Text.PrettyPrint.HughesPJ + +import Distribution.ParseUtils hiding (parseFields) +import Distribution.PackageDescription +import Distribution.Package + ( PackageIdentifier(..), Dependency(..), packageName, packageVersion ) +import Distribution.ModuleName ( ModuleName ) +import Distribution.Version + ( Version(Version), orLaterVersion + , LowerBound(..), asVersionIntervals ) +import Distribution.Verbosity (Verbosity) +import Distribution.Compiler (CompilerFlavor(..)) +import Distribution.PackageDescription.Configuration (parseCondition, freeVars) +import Distribution.Simple.Utils + ( die, dieWithLocation, warn, intercalate, lowercase, cabalVersion + , withFileContents, withUTF8FileContents + , writeFileAtomic, writeUTF8File ) + + +-- ----------------------------------------------------------------------------- +-- The PackageDescription type + +pkgDescrFieldDescrs :: [FieldDescr PackageDescription] +pkgDescrFieldDescrs = + [ simpleField "name" + disp parse + packageName (\name pkg -> pkg{package=(package pkg){pkgName=name}}) + , simpleField "version" + disp parse + packageVersion (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}}) + , simpleField "cabal-version" + (either disp disp) (liftM Left parse +++ liftM Right parse) + specVersionRaw (\v pkg -> pkg{specVersionRaw=v}) + , simpleField "build-type" + (maybe empty disp) (fmap Just parse) + buildType (\t pkg -> pkg{buildType=t}) + , simpleField "license" + disp parseLicenseQ + license (\l pkg -> pkg{license=l}) + , simpleField "license-file" + showFilePath parseFilePathQ + licenseFile (\l pkg -> pkg{licenseFile=l}) + , simpleField "copyright" + showFreeText parseFreeText + copyright (\val pkg -> pkg{copyright=val}) + , simpleField "maintainer" + showFreeText parseFreeText + maintainer (\val pkg -> pkg{maintainer=val}) + , commaListField "build-depends" + disp parse + buildDepends (\xs pkg -> pkg{buildDepends=xs}) + , simpleField "stability" + showFreeText parseFreeText + stability (\val pkg -> pkg{stability=val}) + , simpleField "homepage" + showFreeText parseFreeText + homepage (\val pkg -> pkg{homepage=val}) + , simpleField "package-url" + showFreeText parseFreeText + pkgUrl (\val pkg -> pkg{pkgUrl=val}) + , simpleField "bug-reports" + showFreeText parseFreeText + bugReports (\val pkg -> pkg{bugReports=val}) + , simpleField "synopsis" + showFreeText parseFreeText + synopsis (\val pkg -> pkg{synopsis=val}) + , simpleField "description" + showFreeText parseFreeText + description (\val pkg -> pkg{description=val}) + , simpleField "category" + showFreeText parseFreeText + category (\val pkg -> pkg{category=val}) + , simpleField "author" + showFreeText parseFreeText + author (\val pkg -> pkg{author=val}) + , listField "tested-with" + showTestedWith parseTestedWithQ + testedWith (\val pkg -> pkg{testedWith=val}) + , listField "data-files" + showFilePath parseFilePathQ + dataFiles (\val pkg -> pkg{dataFiles=val}) + , simpleField "data-dir" + showFilePath parseFilePathQ + dataDir (\val pkg -> pkg{dataDir=val}) + , listField "extra-source-files" + showFilePath parseFilePathQ + extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val}) + , listField "extra-tmp-files" + showFilePath parseFilePathQ + extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val}) + ] + +-- | Store any fields beginning with "x-" in the customFields field of +-- a PackageDescription. All other fields will generate a warning. +storeXFieldsPD :: UnrecFieldParser PackageDescription +storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD = + (customFieldsPD pkg) ++ [(f,val)]} +storeXFieldsPD _ _ = Nothing + +-- --------------------------------------------------------------------------- +-- The Library type + +libFieldDescrs :: [FieldDescr Library] +libFieldDescrs = + [ listField "exposed-modules" disp parseModuleNameQ + exposedModules (\mods lib -> lib{exposedModules=mods}) + + , boolField "exposed" + libExposed (\val lib -> lib{libExposed=val}) + ] ++ map biToLib binfoFieldDescrs + where biToLib = liftField libBuildInfo (\bi lib -> lib{libBuildInfo=bi}) + +storeXFieldsLib :: UnrecFieldParser Library +storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) = + Just $ l {libBuildInfo = bi{ customFieldsBI = (customFieldsBI bi) ++ [(f,val)]}} +storeXFieldsLib _ _ = Nothing + +-- --------------------------------------------------------------------------- +-- The Executable type + + +executableFieldDescrs :: [FieldDescr Executable] +executableFieldDescrs = + [ -- note ordering: configuration must come first, for + -- showPackageDescription. + simpleField "executable" + showToken parseTokenQ + exeName (\xs exe -> exe{exeName=xs}) + , simpleField "main-is" + showFilePath parseFilePathQ + modulePath (\xs exe -> exe{modulePath=xs}) + ] + ++ map biToExe binfoFieldDescrs + where biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi}) + +storeXFieldsExe :: UnrecFieldParser Executable +storeXFieldsExe (f@('x':'-':_), val) e@(Executable { buildInfo = bi }) = + Just $ e {buildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}} +storeXFieldsExe _ _ = Nothing + +-- --------------------------------------------------------------------------- +-- The TestSuite type + +-- | An intermediate type just used for parsing the test-suite stanza. +-- After validation it is converted into the proper 'TestSuite' type. +data TestSuiteStanza = TestSuiteStanza { + testStanzaTestType :: Maybe TestType, + testStanzaMainIs :: Maybe FilePath, + testStanzaTestModule :: Maybe ModuleName, + testStanzaBuildInfo :: BuildInfo + } + +emptyTestStanza :: TestSuiteStanza +emptyTestStanza = TestSuiteStanza Nothing Nothing Nothing mempty + +testSuiteFieldDescrs :: [FieldDescr TestSuiteStanza] +testSuiteFieldDescrs = + [ simpleField "type" + (maybe empty disp) (fmap Just parse) + testStanzaTestType (\x suite -> suite { testStanzaTestType = x }) + , simpleField "main-is" + (maybe empty showFilePath) (fmap Just parseFilePathQ) + testStanzaMainIs (\x suite -> suite { testStanzaMainIs = x }) + , simpleField "test-module" + (maybe empty disp) (fmap Just parseModuleNameQ) + testStanzaTestModule (\x suite -> suite { testStanzaTestModule = x }) + ] + ++ map biToTest binfoFieldDescrs + where + biToTest = liftField testStanzaBuildInfo + (\bi suite -> suite { testStanzaBuildInfo = bi }) + +storeXFieldsTest :: UnrecFieldParser TestSuiteStanza +storeXFieldsTest (f@('x':'-':_), val) t@(TestSuiteStanza { testStanzaBuildInfo = bi }) = + Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}} +storeXFieldsTest _ _ = Nothing + +validateTestSuite :: LineNo -> TestSuiteStanza -> ParseResult TestSuite +validateTestSuite line stanza = + case testStanzaTestType stanza of + Nothing -> return $ + emptyTestSuite { testBuildInfo = testStanzaBuildInfo stanza } + + Just tt@(TestTypeUnknown _ _) -> + return emptyTestSuite { + testInterface = TestSuiteUnsupported tt, + testBuildInfo = testStanzaBuildInfo stanza + } + + Just tt | tt `notElem` knownTestTypes -> + return emptyTestSuite { + testInterface = TestSuiteUnsupported tt, + testBuildInfo = testStanzaBuildInfo stanza + } + + Just tt@(TestTypeExe ver) -> + case testStanzaMainIs stanza of + Nothing -> syntaxError line (missingField "main-is" tt) + Just file -> do + when (isJust (testStanzaTestModule stanza)) $ + warning (extraField "test-module" tt) + return emptyTestSuite { + testInterface = TestSuiteExeV10 ver file, + testBuildInfo = testStanzaBuildInfo stanza + } + + Just tt@(TestTypeLib ver) -> + case testStanzaTestModule stanza of + Nothing -> syntaxError line (missingField "test-module" tt) + Just module_ -> do + when (isJust (testStanzaMainIs stanza)) $ + warning (extraField "main-is" tt) + return emptyTestSuite { + testInterface = TestSuiteLibV09 ver module_, + testBuildInfo = testStanzaBuildInfo stanza + } + + where + missingField name tt = "The '" ++ name ++ "' field is required for the " + ++ display tt ++ " test suite type." + + extraField name tt = "The '" ++ name ++ "' field is not used for the '" + ++ display tt ++ "' test suite type." + + +-- --------------------------------------------------------------------------- +-- The BuildInfo type + + +binfoFieldDescrs :: [FieldDescr BuildInfo] +binfoFieldDescrs = + [ boolField "buildable" + buildable (\val binfo -> binfo{buildable=val}) + , commaListField "build-tools" + disp parseBuildTool + buildTools (\xs binfo -> binfo{buildTools=xs}) + , spaceListField "cpp-options" + showToken parseTokenQ' + cppOptions (\val binfo -> binfo{cppOptions=val}) + , spaceListField "cc-options" + showToken parseTokenQ' + ccOptions (\val binfo -> binfo{ccOptions=val}) + , spaceListField "ld-options" + showToken parseTokenQ' + ldOptions (\val binfo -> binfo{ldOptions=val}) + , commaListField "pkgconfig-depends" + disp parsePkgconfigDependency + pkgconfigDepends (\xs binfo -> binfo{pkgconfigDepends=xs}) + , listField "frameworks" + showToken parseTokenQ + frameworks (\val binfo -> binfo{frameworks=val}) + , listField "c-sources" + showFilePath parseFilePathQ + cSources (\paths binfo -> binfo{cSources=paths}) + + , simpleField "default-language" + (maybe empty disp) (option Nothing (fmap Just parseLanguageQ)) + defaultLanguage (\lang binfo -> binfo{defaultLanguage=lang}) + , listField "other-languages" + disp parseLanguageQ + otherLanguages (\langs binfo -> binfo{otherLanguages=langs}) + , listField "default-extensions" + disp parseExtensionQ + defaultExtensions (\exts binfo -> binfo{defaultExtensions=exts}) + , listField "other-extensions" + disp parseExtensionQ + otherExtensions (\exts binfo -> binfo{otherExtensions=exts}) + , listField "extensions" + disp parseExtensionQ + oldExtensions (\exts binfo -> binfo{oldExtensions=exts}) + + , listField "extra-libraries" + showToken parseTokenQ + extraLibs (\xs binfo -> binfo{extraLibs=xs}) + , listField "extra-lib-dirs" + showFilePath parseFilePathQ + extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs}) + , listField "includes" + showFilePath parseFilePathQ + includes (\paths binfo -> binfo{includes=paths}) + , listField "install-includes" + showFilePath parseFilePathQ + installIncludes (\paths binfo -> binfo{installIncludes=paths}) + , listField "include-dirs" + showFilePath parseFilePathQ + includeDirs (\paths binfo -> binfo{includeDirs=paths}) + , listField "hs-source-dirs" + showFilePath parseFilePathQ + hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths}) + , listField "other-modules" + disp parseModuleNameQ + otherModules (\val binfo -> binfo{otherModules=val}) + , listField "ghc-prof-options" + text parseTokenQ + ghcProfOptions (\val binfo -> binfo{ghcProfOptions=val}) + , listField "ghc-shared-options" + text parseTokenQ + ghcSharedOptions (\val binfo -> binfo{ghcSharedOptions=val}) + , optsField "ghc-options" GHC + options (\path binfo -> binfo{options=path}) + , optsField "hugs-options" Hugs + options (\path binfo -> binfo{options=path}) + , optsField "nhc98-options" NHC + options (\path binfo -> binfo{options=path}) + , optsField "jhc-options" JHC + options (\path binfo -> binfo{options=path}) + ] + +storeXFieldsBI :: UnrecFieldParser BuildInfo +storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):(customFieldsBI bi) } +storeXFieldsBI _ _ = Nothing + +------------------------------------------------------------------------------ + +flagFieldDescrs :: [FieldDescr Flag] +flagFieldDescrs = + [ simpleField "description" + showFreeText parseFreeText + flagDescription (\val fl -> fl{ flagDescription = val }) + , boolField "default" + flagDefault (\val fl -> fl{ flagDefault = val }) + , boolField "manual" + flagManual (\val fl -> fl{ flagManual = val }) + ] + +------------------------------------------------------------------------------ + +sourceRepoFieldDescrs :: [FieldDescr SourceRepo] +sourceRepoFieldDescrs = + [ simpleField "type" + (maybe empty disp) (fmap Just parse) + repoType (\val repo -> repo { repoType = val }) + , simpleField "location" + (maybe empty showFreeText) (fmap Just parseFreeText) + repoLocation (\val repo -> repo { repoLocation = val }) + , simpleField "module" + (maybe empty showToken) (fmap Just parseTokenQ) + repoModule (\val repo -> repo { repoModule = val }) + , simpleField "branch" + (maybe empty showToken) (fmap Just parseTokenQ) + repoBranch (\val repo -> repo { repoBranch = val }) + , simpleField "tag" + (maybe empty showToken) (fmap Just parseTokenQ) + repoTag (\val repo -> repo { repoTag = val }) + , simpleField "subdir" + (maybe empty showFilePath) (fmap Just parseFilePathQ) + repoSubdir (\val repo -> repo { repoSubdir = val }) + ] + +-- --------------------------------------------------------------- +-- Parsing + +-- | Given a parser and a filename, return the parse of the file, +-- after checking if the file exists. +readAndParseFile :: (FilePath -> (String -> IO a) -> IO a) + -> (String -> ParseResult a) + -> Verbosity + -> FilePath -> IO a +readAndParseFile withFileContents' parser verbosity fpath = do + exists <- doesFileExist fpath + when (not exists) (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.") + withFileContents' fpath $ \str -> case parser str of + ParseFailed e -> do + let (line, message) = locatedErrorMsg e + dieWithLocation fpath line message + ParseOk warnings x -> do + mapM_ (warn verbosity . showPWarning fpath) $ reverse warnings + return x + +readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo +readHookedBuildInfo = + readAndParseFile withFileContents parseHookedBuildInfo + +-- |Parse the given package file. +readPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription +readPackageDescription = + readAndParseFile withUTF8FileContents parsePackageDescription + +stanzas :: [Field] -> [[Field]] +stanzas [] = [] +stanzas (f:fields) = (f:this) : stanzas rest + where + (this, rest) = break isStanzaHeader fields + +isStanzaHeader :: Field -> Bool +isStanzaHeader (F _ f _) = f == "executable" +isStanzaHeader _ = False + +------------------------------------------------------------------------------ + + +mapSimpleFields :: (Field -> ParseResult Field) -> [Field] + -> ParseResult [Field] +mapSimpleFields f fs = mapM walk fs + where + walk fld@(F _ _ _) = f fld + walk (IfBlock l c fs1 fs2) = do + fs1' <- mapM walk fs1 + fs2' <- mapM walk fs2 + return (IfBlock l c fs1' fs2') + walk (Section ln n l fs1) = do + fs1' <- mapM walk fs1 + return (Section ln n l fs1') + +-- prop_isMapM fs = mapSimpleFields return fs == return fs + + +-- names of fields that represents dependencies, thus consrca +constraintFieldNames :: [String] +constraintFieldNames = ["build-depends"] + +-- Possible refactoring would be to have modifiers be explicit about what +-- they add and define an accessor that specifies what the dependencies +-- are. This way we would completely reuse the parsing knowledge from the +-- field descriptor. +parseConstraint :: Field -> ParseResult [Dependency] +parseConstraint (F l n v) + | n == "build-depends" = runP l n (parseCommaList parse) v +parseConstraint f = bug $ "Constraint was expected (got: " ++ show f ++ ")" + +{- +headerFieldNames :: [String] +headerFieldNames = filter (\n -> not (n `elem` constraintFieldNames)) + . map fieldName $ pkgDescrFieldDescrs +-} + +libFieldNames :: [String] +libFieldNames = map fieldName libFieldDescrs + ++ buildInfoNames ++ constraintFieldNames + +-- exeFieldNames :: [String] +-- exeFieldNames = map fieldName executableFieldDescrs +-- ++ buildInfoNames + +buildInfoNames :: [String] +buildInfoNames = map fieldName binfoFieldDescrs + ++ map fst deprecatedFieldsBuildInfo + +-- A minimal implementation of the StateT monad transformer to avoid depending +-- on the 'mtl' package. +newtype StT s m a = StT { runStT :: s -> m (a,s) } + +instance Monad m => Monad (StT s m) where + return a = StT (\s -> return (a,s)) + StT f >>= g = StT $ \s -> do + (a,s') <- f s + runStT (g a) s' + +get :: Monad m => StT s m s +get = StT $ \s -> return (s, s) + +modify :: Monad m => (s -> s) -> StT s m () +modify f = StT $ \s -> return ((),f s) + +lift :: Monad m => m a -> StT s m a +lift m = StT $ \s -> m >>= \a -> return (a,s) + +evalStT :: Monad m => StT s m a -> s -> m a +evalStT st s = runStT st s >>= return . fst + +-- Our monad for parsing a list/tree of fields. +-- +-- The state represents the remaining fields to be processed. +type PM a = StT [Field] ParseResult a + + + +-- return look-ahead field or nothing if we're at the end of the file +peekField :: PM (Maybe Field) +peekField = get >>= return . listToMaybe + +-- Unconditionally discard the first field in our state. Will error when it +-- reaches end of file. (Yes, that's evil.) +skipField :: PM () +skipField = modify tail + +--FIXME: this should take a ByteString, not a String. We have to be able to +-- decode UTF8 and handle the BOM. + +-- | Parses the given file into a 'GenericPackageDescription'. +-- +-- In Cabal 1.2 the syntax for package descriptions was changed to a format +-- with sections and possibly indented property descriptions. +parsePackageDescription :: String -> ParseResult GenericPackageDescription +parsePackageDescription file = do + + -- This function is quite complex because it needs to be able to parse + -- both pre-Cabal-1.2 and post-Cabal-1.2 files. Additionally, it contains + -- a lot of parser-related noise since we do not want to depend on Parsec. + -- + -- If we detect an pre-1.2 file we implicitly convert it to post-1.2 + -- style. See 'sectionizeFields' below for details about the conversion. + + fields0 <- readFields file `catchParseError` \err -> + let tabs = findIndentTabs file in + case err of + -- In case of a TabsError report them all at once. + TabsError tabLineNo -> reportTabsError + -- but only report the ones including and following + -- the one that caused the actual error + [ t | t@(lineNo',_) <- tabs + , lineNo' >= tabLineNo ] + _ -> parseFail err + + let cabalVersionNeeded = + head $ [ minVersionBound versionRange + | Just versionRange <- [ simpleParse v + | F _ "cabal-version" v <- fields0 ] ] + ++ [Version [0] []] + minVersionBound versionRange = + case asVersionIntervals versionRange of + [] -> Version [0] [] + ((LowerBound version _, _):_) -> version + + handleFutureVersionParseFailure cabalVersionNeeded $ do + + let sf = sectionizeFields fields0 -- ensure 1.2 format + + -- figure out and warn about deprecated stuff (warnings are collected + -- inside our parsing monad) + fields <- mapSimpleFields deprecField sf + + -- Our parsing monad takes the not-yet-parsed fields as its state. + -- After each successful parse we remove the field from the state + -- ('skipField') and move on to the next one. + -- + -- Things are complicated a bit, because fields take a tree-like + -- structure -- they can be sections or "if"/"else" conditionals. + + flip evalStT fields $ do + + -- The header consists of all simple fields up to the first section + -- (flag, library, executable). + header_fields <- getHeader [] + + -- Parses just the header fields and stores them in a + -- 'PackageDescription'. Note that our final result is a + -- 'GenericPackageDescription'; for pragmatic reasons we just store + -- the partially filled-out 'PackageDescription' inside the + -- 'GenericPackageDescription'. + pkg <- lift $ parseFields pkgDescrFieldDescrs + storeXFieldsPD + emptyPackageDescription + header_fields + + -- 'getBody' assumes that the remaining fields only consist of + -- flags, lib and exe sections. + (repos, flags, mlib, exes, tests) <- getBody + warnIfRest -- warn if getBody did not parse up to the last field. + -- warn about using old/new syntax with wrong cabal-version: + maybeWarnCabalVersion (not $ oldSyntax fields0) pkg + checkForUndefinedFlags flags mlib exes tests + return $ GenericPackageDescription + pkg { sourceRepos = repos } + flags mlib exes tests + + where + oldSyntax flds = all isSimpleField flds + reportTabsError tabs = + syntaxError (fst (head tabs)) $ + "Do not use tabs for indentation (use spaces instead)\n" + ++ " Tabs were used at (line,column): " ++ show tabs + + maybeWarnCabalVersion newsyntax pkg + | newsyntax && specVersion pkg < Version [1,2] [] + = lift $ warning $ + "A package using section syntax must specify at least\n" + ++ "'cabal-version: >= 1.2'." + + maybeWarnCabalVersion newsyntax pkg + | not newsyntax && specVersion pkg >= Version [1,2] [] + = lift $ warning $ + "A package using 'cabal-version: " + ++ displaySpecVersion (specVersionRaw pkg) + ++ "' must use section syntax. See the Cabal user guide for details." + where + displaySpecVersion (Left version) = display version + displaySpecVersion (Right versionRange) = + case asVersionIntervals versionRange of + [] {- impossible -} -> display versionRange + ((LowerBound version _, _):_) -> display (orLaterVersion version) + + maybeWarnCabalVersion _ _ = return () + + + handleFutureVersionParseFailure cabalVersionNeeded parseBody = + (unless versionOk (warning message) >> parseBody) + `catchParseError` \parseError -> case parseError of + TabsError _ -> parseFail parseError + _ | versionOk -> parseFail parseError + | otherwise -> fail message + where versionOk = cabalVersionNeeded <= cabalVersion + message = "This package requires at least Cabal version " + ++ display cabalVersionNeeded + + -- "Sectionize" an old-style Cabal file. A sectionized file has: + -- + -- * all global fields at the beginning, followed by + -- + -- * all flag declarations, followed by + -- + -- * an optional library section, and an arbitrary number of executable + -- sections (in any order). + -- + -- The current implementatition just gathers all library-specific fields + -- in a library section and wraps all executable stanzas in an executable + -- section. + sectionizeFields :: [Field] -> [Field] + sectionizeFields fs + | oldSyntax fs = + let + -- "build-depends" is a local field now. To be backwards + -- compatible, we still allow it as a global field in old-style + -- package description files and translate it to a local field by + -- adding it to every non-empty section + (hdr0, exes0) = break ((=="executable") . fName) fs + (hdr, libfs0) = partition (not . (`elem` libFieldNames) . fName) hdr0 + + (deps, libfs) = partition ((== "build-depends") . fName) + libfs0 + + exes = unfoldr toExe exes0 + toExe [] = Nothing + toExe (F l e n : r) + | e == "executable" = + let (efs, r') = break ((=="executable") . fName) r + in Just (Section l "executable" n (deps ++ efs), r') + toExe _ = bug "unexpeced input to 'toExe'" + in + hdr ++ + (if null libfs then [] + else [Section (lineNo (head libfs)) "library" "" (deps ++ libfs)]) + ++ exes + | otherwise = fs + + isSimpleField (F _ _ _) = True + isSimpleField _ = False + + -- warn if there's something at the end of the file + warnIfRest :: PM () + warnIfRest = do + s <- get + case s of + [] -> return () + _ -> lift $ warning "Ignoring trailing declarations." -- add line no. + + -- all simple fields at the beginning of the file are (considered) header + -- fields + getHeader :: [Field] -> PM [Field] + getHeader acc = peekField >>= \mf -> case mf of + Just f@(F _ _ _) -> skipField >> getHeader (f:acc) + _ -> return (reverse acc) + + -- + -- body ::= { repo | flag | library | executable | test }+ -- at most one lib + -- + -- The body consists of an optional sequence of declarations of flags and + -- an arbitrary number of executables and at most one library. + getBody :: PM ([SourceRepo], [Flag] + ,Maybe (CondTree ConfVar [Dependency] Library) + ,[(String, CondTree ConfVar [Dependency] Executable)] + ,[(String, CondTree ConfVar [Dependency] TestSuite)]) + getBody = peekField >>= \mf -> case mf of + Just (Section line_no sec_type sec_label sec_fields) + | sec_type == "executable" -> do + when (null sec_label) $ lift $ syntaxError line_no + "'executable' needs one argument (the executable's name)" + exename <- lift $ runP line_no "executable" parseTokenQ sec_label + flds <- collectFields parseExeFields sec_fields + skipField + (repos, flags, lib, exes, tests) <- getBody + return (repos, flags, lib, (exename, flds): exes, tests) + + | sec_type == "test-suite" -> do + when (null sec_label) $ lift $ syntaxError line_no + "'test-suite' needs one argument (the test suite's name)" + testname <- lift $ runP line_no "test" parseTokenQ sec_label + flds <- collectFields (parseTestFields line_no) sec_fields + + -- Check that a valid test suite type has been chosen. A type + -- field may be given inside a conditional block, so we must + -- check for that before complaining that a type field has not + -- been given. The test suite must always have a valid type, so + -- we need to check both the 'then' and 'else' blocks, though + -- the blocks need not have the same type. + let checkTestType ts ct = + let ts' = mappend ts $ condTreeData ct + -- If a conditional has only a 'then' block and no + -- 'else' block, then it cannot have a valid type + -- in every branch, unless the type is specified at + -- a higher level in the tree. + checkComponent (_, _, Nothing) = False + -- If a conditional has a 'then' block and an 'else' + -- block, both must specify a test type, unless the + -- type is specified higher in the tree. + checkComponent (_, t, Just e) = + checkTestType ts' t && checkTestType ts' e + -- Does the current node specify a test type? + hasTestType = testInterface ts' + /= testInterface emptyTestSuite + components = condTreeComponents ct + -- If the current level of the tree specifies a type, + -- then we are done. If not, then one of the conditional + -- branches below the current node must specify a type. + -- Each node may have multiple immediate children; we + -- only one need one to specify a type because the + -- configure step uses 'mappend' to join together the + -- results of flag resolution. + in hasTestType || (any checkComponent components) + if checkTestType emptyTestSuite flds + then do + skipField + (repos, flags, lib, exes, tests) <- getBody + return (repos, flags, lib, exes, (testname, flds) : tests) + else lift $ syntaxError line_no $ + "Test suite \"" ++ testname + ++ "\" is missing required field \"type\" or the field " + ++ "is not present in all conditional branches. The " + ++ "available test types are: " + ++ intercalate ", " (map display knownTestTypes) + + | sec_type == "library" -> do + when (not (null sec_label)) $ lift $ + syntaxError line_no "'library' expects no argument" + flds <- collectFields parseLibFields sec_fields + skipField + (repos, flags, lib, exes, tests) <- getBody + when (isJust lib) $ lift $ syntaxError line_no + "There can only be one library section in a package description." + return (repos, flags, Just flds, exes, tests) + + | sec_type == "flag" -> do + when (null sec_label) $ lift $ + syntaxError line_no "'flag' needs one argument (the flag's name)" + flag <- lift $ parseFields + flagFieldDescrs + warnUnrec + (MkFlag (FlagName (lowercase sec_label)) "" True False) + sec_fields + skipField + (repos, flags, lib, exes, tests) <- getBody + return (repos, flag:flags, lib, exes, tests) + + | sec_type == "source-repository" -> do + when (null sec_label) $ lift $ syntaxError line_no $ + "'source-repository' needs one argument, " + ++ "the repo kind which is usually 'head' or 'this'" + kind <- case simpleParse sec_label of + Just kind -> return kind + Nothing -> lift $ syntaxError line_no $ + "could not parse repo kind: " ++ sec_label + repo <- lift $ parseFields + sourceRepoFieldDescrs + warnUnrec + (SourceRepo { + repoKind = kind, + repoType = Nothing, + repoLocation = Nothing, + repoModule = Nothing, + repoBranch = Nothing, + repoTag = Nothing, + repoSubdir = Nothing + }) + sec_fields + skipField + (repos, flags, lib, exes, tests) <- getBody + return (repo:repos, flags, lib, exes, tests) + + | otherwise -> do + lift $ warning $ "Ignoring unknown section type: " ++ sec_type + skipField + getBody + Just f -> do + _ <- lift $ syntaxError (lineNo f) $ + "Construct not supported at this position: " ++ show f + skipField + getBody + Nothing -> return ([], [], Nothing, [], []) + + -- Extracts all fields in a block and returns a 'CondTree'. + -- + -- We have to recurse down into conditionals and we treat fields that + -- describe dependencies specially. + collectFields :: ([Field] -> PM a) -> [Field] + -> PM (CondTree ConfVar [Dependency] a) + collectFields parser allflds = do + + let simplFlds = [ F l n v | F l n v <- allflds ] + condFlds = [ f | f@(IfBlock _ _ _ _) <- allflds ] + + let (depFlds, dataFlds) = partition isConstraint simplFlds + + a <- parser dataFlds + deps <- liftM concat . mapM (lift . parseConstraint) $ depFlds + + ifs <- mapM processIfs condFlds + + return (CondNode a deps ifs) + where + isConstraint (F _ n _) = n `elem` constraintFieldNames + isConstraint _ = False + + processIfs (IfBlock l c t e) = do + cnd <- lift $ runP l "if" parseCondition c + t' <- collectFields parser t + e' <- case e of + [] -> return Nothing + es -> do fs <- collectFields parser es + return (Just fs) + return (cnd, t', e') + processIfs _ = bug "processIfs called with wrong field type" + + parseLibFields :: [Field] -> PM Library + parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary + + -- Note: we don't parse the "executable" field here, hence the tail hack. + parseExeFields :: [Field] -> PM Executable + parseExeFields = lift . parseFields (tail executableFieldDescrs) storeXFieldsExe emptyExecutable + + parseTestFields :: LineNo -> [Field] -> PM TestSuite + parseTestFields line fields = do + x <- lift $ parseFields testSuiteFieldDescrs storeXFieldsTest + emptyTestStanza fields + lift $ validateTestSuite line x + + checkForUndefinedFlags :: + [Flag] -> + Maybe (CondTree ConfVar [Dependency] Library) -> + [(String, CondTree ConfVar [Dependency] Executable)] -> + [(String, CondTree ConfVar [Dependency] TestSuite)] -> + PM () + checkForUndefinedFlags flags mlib exes tests = do + let definedFlags = map flagName flags + maybe (return ()) (checkCondTreeFlags definedFlags) mlib + mapM_ (checkCondTreeFlags definedFlags . snd) exes + mapM_ (checkCondTreeFlags definedFlags . snd) tests + + checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM () + checkCondTreeFlags definedFlags ct = do + let fv = nub $ freeVars ct + when (not . all (`elem` definedFlags) $ fv) $ + fail $ "These flags are used without having been defined: " + ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ] + + +-- | Parse a list of fields, given a list of field descriptions, +-- a structure to accumulate the parsed fields, and a function +-- that can decide what to do with fields which don't match any +-- of the field descriptions. +parseFields :: [FieldDescr a] -- ^ descriptions of fields we know how to + -- parse + -> UnrecFieldParser a -- ^ possibly do something with + -- unrecognized fields + -> a -- ^ accumulator + -> [Field] -- ^ fields to be parsed + -> ParseResult a +parseFields descrs unrec ini fields = + do (a, unknowns) <- foldM (parseField descrs unrec) (ini, []) fields + when (not (null unknowns)) $ do + warning $ render $ + text "Unknown fields:" <+> + commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")") + (reverse unknowns)) + $+$ + text "Fields allowed in this section:" $$ + nest 4 (commaSep $ map fieldName descrs) + return a + where + commaSep = fsep . punctuate comma . map text + +parseField :: [FieldDescr a] -- ^ list of parseable fields + -> UnrecFieldParser a -- ^ possibly do something with + -- unrecognized fields + -> (a,[(Int,String)]) -- ^ accumulated result and warnings + -> Field -- ^ the field to be parsed + -> ParseResult (a, [(Int,String)]) +parseField ((FieldDescr name _ parser):fields) unrec (a, us) (F line f val) + | name == f = parser line val a >>= \a' -> return (a',us) + | otherwise = parseField fields unrec (a,us) (F line f val) +parseField [] unrec (a,us) (F l f val) = return $ + case unrec (f,val) a of -- no fields matched, see if the 'unrec' + Just a' -> (a',us) -- function wants to do anything with it + Nothing -> (a, ((l,f):us)) +parseField _ _ _ _ = bug "'parseField' called on a non-field" + +deprecatedFields :: [(String,String)] +deprecatedFields = + deprecatedFieldsPkgDescr ++ deprecatedFieldsBuildInfo + +deprecatedFieldsPkgDescr :: [(String,String)] +deprecatedFieldsPkgDescr = [ ("other-files", "extra-source-files") ] + +deprecatedFieldsBuildInfo :: [(String,String)] +deprecatedFieldsBuildInfo = [ ("hs-source-dir","hs-source-dirs") ] + +-- Handle deprecated fields +deprecField :: Field -> ParseResult Field +deprecField (F line fld val) = do + fld' <- case lookup fld deprecatedFields of + Nothing -> return fld + Just newName -> do + warning $ "The field \"" ++ fld + ++ "\" is deprecated, please use \"" ++ newName ++ "\"" + return newName + return (F line fld' val) +deprecField _ = bug "'deprecField' called on a non-field" + + +parseHookedBuildInfo :: String -> ParseResult HookedBuildInfo +parseHookedBuildInfo inp = do + fields <- readFields inp + let ss@(mLibFields:exes) = stanzas fields + mLib <- parseLib mLibFields + biExes <- mapM parseExe (maybe ss (const exes) mLib) + return (mLib, biExes) + where + parseLib :: [Field] -> ParseResult (Maybe BuildInfo) + parseLib (bi@((F _ inFieldName _):_)) + | lowercase inFieldName /= "executable" = liftM Just (parseBI bi) + parseLib _ = return Nothing + + parseExe :: [Field] -> ParseResult (String, BuildInfo) + parseExe ((F line inFieldName mName):bi) + | lowercase inFieldName == "executable" + = do bis <- parseBI bi + return (mName, bis) + | otherwise = syntaxError line "expecting 'executable' at top of stanza" + parseExe (_:_) = bug "`parseExe' called on a non-field" + parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza" + + parseBI st = parseFields binfoFieldDescrs storeXFieldsBI emptyBuildInfo st + +-- --------------------------------------------------------------------------- +-- Pretty printing + +writePackageDescription :: FilePath -> PackageDescription -> IO () +writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg) + +--TODO: make this use section syntax +-- add equivalent for GenericPackageDescription +showPackageDescription :: PackageDescription -> String +showPackageDescription pkg = render $ + ppPackage pkg + $$ ppCustomFields (customFieldsPD pkg) + $$ (case library pkg of + Nothing -> empty + Just lib -> ppLibrary lib) + $$ vcat [ space $$ ppExecutable exe | exe <- executables pkg ] + where + ppPackage = ppFields pkgDescrFieldDescrs + ppLibrary = ppFields libFieldDescrs + ppExecutable = ppFields executableFieldDescrs + +ppCustomFields :: [(String,String)] -> Doc +ppCustomFields flds = vcat (map ppCustomField flds) + +ppCustomField :: (String,String) -> Doc +ppCustomField (name,val) = text name <> colon <+> showFreeText val + +writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO () +writeHookedBuildInfo fpath = writeFileAtomic fpath . showHookedBuildInfo + +showHookedBuildInfo :: HookedBuildInfo -> String +showHookedBuildInfo (mb_lib_bi, ex_bis) = render $ + (case mb_lib_bi of + Nothing -> empty + Just bi -> ppBuildInfo bi) + $$ vcat [ space + $$ text "executable:" <+> text name + $$ ppBuildInfo bi + | (name, bi) <- ex_bis ] + where + ppBuildInfo bi = ppFields binfoFieldDescrs bi + $$ ppCustomFields (customFieldsBI bi) + +-- replace all tabs used as indentation with whitespace, also return where +-- tabs were found +findIndentTabs :: String -> [(Int,Int)] +findIndentTabs = concatMap checkLine + . zip [1..] + . lines + where + checkLine (lineno, l) = + let (indent, _content) = span isSpace l + tabCols = map fst . filter ((== '\t') . snd) . zip [0..] + addLineNo = map (\col -> (lineno,col)) + in addLineNo (tabCols indent) + +--test_findIndentTabs = findIndentTabs $ unlines $ +-- [ "foo", " bar", " \t baz", "\t biz\t", "\t\t \t mib" ] + +bug :: String -> a +bug msg = error $ msg ++ ". Consider this a bug." diff --git a/cabal/cabal/Distribution/PackageDescription/PrettyPrint.hs b/cabal/cabal/Distribution/PackageDescription/PrettyPrint.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/PackageDescription/PrettyPrint.hs @@ -0,0 +1,238 @@ +----------------------------------------------------------------------------- +-- +-- Module : Distribution.PackageDescription.PrettyPrint +-- Copyright : Jürgen Nicklisch-Franken 2010 +-- License : AllRightsReserved +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- | Pretty printing for cabal files +-- +----------------------------------------------------------------------------- +{- 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.PrettyPrint ( + writeGenericPackageDescription, + showGenericPackageDescription, +) where + +import Distribution.PackageDescription + ( TestSuite(..), TestSuiteInterface(..), testType + , SourceRepo(..), + customFieldsBI, CondTree(..), Condition(..), + FlagName(..), ConfVar(..), Executable(..), Library(..), + Flag(..), PackageDescription(..), + GenericPackageDescription(..)) +import Text.PrettyPrint + (hsep, comma, punctuate, fsep, parens, char, nest, empty, + isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render) +import Distribution.Simple.Utils (writeUTF8File) +import Distribution.ParseUtils (showFreeText, FieldDescr(..)) +import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs, + sourceRepoFieldDescrs) +import Distribution.Package (Dependency(..)) +import Distribution.Text (Text(..)) +import Data.Maybe (isJust, fromJust, isNothing) + +indentWith :: Int +indentWith = 4 + +-- | Recompile with false for regression testing +simplifiedPrinting :: Bool +simplifiedPrinting = False + +-- | Writes a .cabal file from a generic package description +writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO () +writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg) + +-- | Writes a generic package description to a string +showGenericPackageDescription :: GenericPackageDescription -> String +showGenericPackageDescription = render . ppGenericPackageDescription + +ppGenericPackageDescription :: GenericPackageDescription -> Doc +ppGenericPackageDescription gpd = + ppPackageDescription (packageDescription gpd) + $+$ ppGenPackageFlags (genPackageFlags gpd) + $+$ ppLibrary (condLibrary gpd) + $+$ ppExecutables (condExecutables gpd) + $+$ ppTestSuites (condTestSuites gpd) + +ppPackageDescription :: PackageDescription -> Doc +ppPackageDescription pd = ppFields pkgDescrFieldDescrs pd + $+$ ppCustomFields (customFieldsPD pd) + $+$ ppSourceRepos (sourceRepos pd) + +ppSourceRepos :: [SourceRepo] -> Doc +ppSourceRepos [] = empty +ppSourceRepos (hd:tl) = ppSourceRepo hd $+$ ppSourceRepos tl + +ppSourceRepo :: SourceRepo -> Doc +ppSourceRepo repo = + emptyLine $ text "source-repository" <+> disp (repoKind repo) $+$ + (nest indentWith (ppFields sourceRepoFieldDescrs' repo)) + where + sourceRepoFieldDescrs' = [fd | fd <- sourceRepoFieldDescrs, fieldName fd /= "kind"] + +ppFields :: [FieldDescr a] -> a -> Doc +ppFields fields x = + vcat [ ppField name (getter x) + | FieldDescr name getter _ <- fields] + +ppField :: String -> Doc -> Doc +ppField name fielddoc | isEmpty fielddoc = empty + | otherwise = text name <> colon <+> fielddoc + +ppDiffFields :: [FieldDescr a] -> a -> a -> Doc +ppDiffFields fields x y = + vcat [ ppField name (getter x) + | FieldDescr name getter _ <- fields, + render (getter x) /= render (getter y)] + +ppCustomFields :: [(String,String)] -> Doc +ppCustomFields flds = vcat [ppCustomField f | f <- flds] + +ppCustomField :: (String,String) -> Doc +ppCustomField (name,val) = text name <> colon <+> showFreeText val + +ppGenPackageFlags :: [Flag] -> Doc +ppGenPackageFlags flds = vcat [ppFlag f | f <- flds] + +ppFlag :: Flag -> Doc +ppFlag (MkFlag name desc dflt manual) = + emptyLine $ text "flag" <+> ppFlagName name $+$ + (nest indentWith ((if null desc + then empty + else text "Description: " <+> showFreeText desc) $+$ + (if dflt then empty else text "Default: False") $+$ + (if manual then text "Manual: True" else empty))) + +ppLibrary :: (Maybe (CondTree ConfVar [Dependency] Library)) -> Doc +ppLibrary Nothing = empty +ppLibrary (Just condTree) = + emptyLine $ text "library" $+$ nest indentWith (ppCondTree condTree Nothing ppLib) + where + ppLib lib Nothing = ppFields libFieldDescrs lib + $$ ppCustomFields (customFieldsBI (libBuildInfo lib)) + ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib + $$ ppCustomFields (customFieldsBI (libBuildInfo lib)) + +ppExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] -> Doc +ppExecutables exes = + vcat [emptyLine $ text ("executable " ++ n) + $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes] + where + ppExe (Executable _ modulePath' buildInfo') Nothing = + (if modulePath' == "" then empty else text "main-is:" <+> text modulePath') + $+$ ppFields binfoFieldDescrs buildInfo' + $+$ ppCustomFields (customFieldsBI buildInfo') + ppExe (Executable _ modulePath' buildInfo') + (Just (Executable _ modulePath2 buildInfo2)) = + (if modulePath' == "" || modulePath' == modulePath2 + then empty else text "main-is:" <+> text modulePath') + $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2 + $+$ ppCustomFields (customFieldsBI buildInfo') + +ppTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] -> Doc +ppTestSuites suites = + emptyLine $ vcat [ text ("test-suite " ++ n) + $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite) + | (n,condTree) <- suites] + where + ppTestSuite testsuite Nothing = + text "type:" <+> disp (testType testsuite) + $+$ maybe empty (\f -> text "main-is:" <+> text f) + (testSuiteMainIs testsuite) + $+$ maybe empty (\m -> text "test-module:" <+> disp m) + (testSuiteModule testsuite) + $+$ ppFields binfoFieldDescrs (testBuildInfo testsuite) + $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite)) + + ppTestSuite (TestSuite _ _ buildInfo' _) + (Just (TestSuite _ _ buildInfo2 _)) = + ppDiffFields binfoFieldDescrs buildInfo' buildInfo2 + $+$ ppCustomFields (customFieldsBI buildInfo') + + testSuiteMainIs test = case testInterface test of + TestSuiteExeV10 _ f -> Just f + _ -> Nothing + + testSuiteModule test = case testInterface test of + TestSuiteLibV09 _ m -> Just m + _ -> Nothing + +ppCondition :: Condition ConfVar -> Doc +ppCondition (Var x) = ppConfVar x +ppCondition (Lit b) = text (show b) +ppCondition (CNot c) = char '!' <> (ppCondition c) +ppCondition (COr c1 c2) = parens (hsep [ppCondition c1, text "||" + <+> ppCondition c2]) +ppCondition (CAnd c1 c2) = parens (hsep [ppCondition c1, text "&&" + <+> ppCondition c2]) +ppConfVar :: ConfVar -> Doc +ppConfVar (OS os) = text "os" <> parens (disp os) +ppConfVar (Arch arch) = text "arch" <> parens (disp arch) +ppConfVar (Flag name) = text "flag" <> parens (ppFlagName name) +ppConfVar (Impl c v) = text "impl" <> parens (disp c <+> disp v) + +ppFlagName :: FlagName -> Doc +ppFlagName (FlagName name) = text name + +ppCondTree :: CondTree ConfVar [Dependency] a -> Maybe a -> (a -> Maybe a -> Doc) -> Doc +ppCondTree ct@(CondNode it deps ifs) mbIt ppIt = + let res = ppDeps deps + $+$ (vcat $ map ppIf ifs) + $+$ ppIt it mbIt + in if isJust mbIt && isEmpty res + then ppCondTree ct Nothing ppIt + else res + where + ppIf (c,thenTree,mElseTree) = + ((emptyLine $ text "if" <+> ppCondition c) $$ + nest indentWith (ppCondTree thenTree + (if simplifiedPrinting then (Just it) else Nothing) ppIt)) + $+$ (if isNothing mElseTree + then empty + else text "else" + $$ nest indentWith (ppCondTree (fromJust mElseTree) + (if simplifiedPrinting then (Just it) else Nothing) ppIt)) + +ppDeps :: [Dependency] -> Doc +ppDeps [] = empty +ppDeps deps = + text "build-depends:" <+> fsep (punctuate comma (map disp deps)) + +emptyLine :: Doc -> Doc +emptyLine d = text " " $+$ d + + + diff --git a/cabal/cabal/Distribution/ParseUtils.hs b/cabal/cabal/Distribution/ParseUtils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/ParseUtils.hs @@ -0,0 +1,715 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.ParseUtils +-- Copyright : (c) The University of Glasgow 2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Utilities for parsing 'PackageDescription' and 'InstalledPackageInfo'. +-- +-- The @.cabal@ file format is not trivial, especially with the introduction +-- of configurations and the section syntax that goes with that. This module +-- has a bunch of parsing functions that is used by the @.cabal@ parser and a +-- couple others. It has the parsing framework code and also little parsers for +-- many of the formats we get in various @.cabal@ file fields, like module +-- names, comma separated lists etc. + +{- 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, syntaxError, warning, + runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning, + Field(..), fName, lineNo, + FieldDescr(..), ppField, ppFields, readFields, readFieldsFlat, + showFields, showSingleNamedField, parseFields, parseFieldsFlat, + parseFilePathQ, parseTokenQ, parseTokenQ', + parseModuleNameQ, parseBuildTool, parsePkgconfigDependency, + parseOptVersion, parsePackageNameQ, parseVersionRangeQ, + parseTestedWithQ, parseLicenseQ, parseLanguageQ, parseExtensionQ, + parseSepList, parseCommaList, parseOptCommaList, + showFilePath, showToken, showTestedWith, showFreeText, parseFreeText, + field, simpleField, listField, spaceListField, commaListField, + optsField, liftField, boolField, parseQuoted, + + UnrecFieldParser, warnUnrec, ignoreUnrec, + ) where + +import Distribution.Compiler (CompilerFlavor, parseCompilerFlavorCompat) +import Distribution.License +import Distribution.Version + ( Version(..), VersionRange, anyVersion ) +import Distribution.Package ( PackageName(..), Dependency(..) ) +import Distribution.ModuleName (ModuleName) +import Distribution.Compat.ReadP as ReadP hiding (get) +import Distribution.ReadE +import Distribution.Text + ( Text(..) ) +import Distribution.Simple.Utils + ( comparing, intercalate, lowercase, normaliseLineEndings ) +import Language.Haskell.Extension + ( Language, Extension ) + +import Text.PrettyPrint.HughesPJ hiding (braces) +import Data.Char (isSpace, toLower, isAlphaNum, isDigit) +import Data.Maybe (fromMaybe) +import Data.Tree as Tree (Tree(..), flatten) +import qualified Data.Map as Map +import Control.Monad (foldM) +import System.FilePath (normalise) +import Data.List (sortBy) + +-- ----------------------------------------------------------------------------- + +type LineNo = Int + +data PError = AmbigousParse String LineNo + | NoParse String LineNo + | TabsError LineNo + | FromString String (Maybe LineNo) + deriving Show + +data PWarning = PWarning String + | UTFWarning LineNo String + deriving Show + +showPWarning :: FilePath -> PWarning -> String +showPWarning fpath (PWarning msg) = + normalise fpath ++ ": " ++ msg +showPWarning fpath (UTFWarning line fname) = + normalise fpath ++ ":" ++ show line + ++ ": Invalid UTF-8 text in the '" ++ fname ++ "' field." + +data ParseResult a = ParseFailed PError | ParseOk [PWarning] a + deriving Show + +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) + +catchParseError :: ParseResult a -> (PError -> ParseResult a) + -> ParseResult a +p@(ParseOk _ _) `catchParseError` _ = p +ParseFailed e `catchParseError` k = k e + +parseFail :: PError -> ParseResult a +parseFail = ParseFailed + +runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a +runP line fieldname p s = + case [ x | (x,"") <- results ] of + [a] -> ParseOk (utf8Warnings line fieldname s) a + --TODO: what is this double parse thing all about? + -- Can't we just do the all isSpace test the first time? + [] -> case [ x | (x,ys) <- results, all isSpace ys ] of + [a] -> ParseOk (utf8Warnings line fieldname s) a + [] -> ParseFailed (NoParse fieldname line) + _ -> ParseFailed (AmbigousParse fieldname line) + _ -> ParseFailed (AmbigousParse fieldname line) + where results = readP_to_S p s + +runE :: LineNo -> String -> ReadE a -> String -> ParseResult a +runE line fieldname p s = + case runReadE p s of + Right a -> ParseOk (utf8Warnings line fieldname s) a + Left e -> syntaxError line $ + "Parse of field '" ++ fieldname ++ "' failed (" ++ e ++ "): " ++ s + +utf8Warnings :: LineNo -> String -> String -> [PWarning] +utf8Warnings line fieldname s = + take 1 [ UTFWarning n fieldname + | (n,l) <- zip [line..] (lines s) + , '\xfffd' `elem` l ] + +locatedErrorMsg :: PError -> (Maybe LineNo, String) +locatedErrorMsg (AmbigousParse f n) = (Just n, "Ambiguous parse in field '"++f++"'.") +locatedErrorMsg (NoParse f n) = (Just n, "Parse of field '"++f++"' failed.") +locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.") +locatedErrorMsg (FromString s n) = (n, s) + +syntaxError :: LineNo -> String -> ParseResult a +syntaxError n s = ParseFailed $ FromString s (Just n) + +tabsError :: LineNo -> ParseResult a +tabsError ln = ParseFailed $ TabsError ln + +warning :: String -> ParseResult () +warning s = ParseOk [PWarning s] () + +-- | Field descriptor. The parameter @a@ parameterizes over where the field's +-- value is stored in. +data FieldDescr a + = FieldDescr + { fieldName :: String + , fieldGet :: a -> Doc + , fieldSet :: LineNo -> String -> a -> ParseResult a + -- ^ @fieldSet n str x@ Parses the field value from the given input + -- string @str@ and stores the result in @x@ if the parse was + -- successful. Otherwise, reports an error on line number @n@. + } + +field :: String -> (a -> Doc) -> (ReadP a a) -> FieldDescr a +field name showF readF = + FieldDescr name showF (\line val _st -> runP line name readF val) + +-- Lift a field descriptor storing into an 'a' to a field descriptor storing +-- into a 'b'. +liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b +liftField get set (FieldDescr name showF parseF) + = FieldDescr name (\b -> showF (get b)) + (\line str b -> do + a <- parseF line str (get b) + return (set a b)) + +-- Parser combinator for simple fields. Takes a field name, a pretty printer, +-- a parser function, an accessor, and a setter, returns a FieldDescr over the +-- compoid structure. +simpleField :: String -> (a -> Doc) -> (ReadP a a) + -> (b -> a) -> (a -> b -> b) -> FieldDescr b +simpleField name showF readF get set + = liftField get set $ field name showF readF + +commaListField :: String -> (a -> Doc) -> (ReadP [a] a) + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +commaListField name showF readF get set = + liftField get set' $ + field name (fsep . punctuate comma . map showF) (parseCommaList readF) + where + set' xs b = set (get b ++ xs) b + +spaceListField :: String -> (a -> Doc) -> (ReadP [a] a) + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +spaceListField name showF readF get set = + liftField get set' $ + field name (fsep . map showF) (parseSpaceList readF) + where + set' xs b = set (get b ++ xs) b + +listField :: String -> (a -> Doc) -> (ReadP [a] a) + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +listField name showF readF get set = + liftField get set' $ + field name (fsep . map showF) (parseOptCommaList readF) + where + set' xs b = set (get b ++ xs) b + +optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b +optsField name flavor get set = + liftField (fromMaybe [] . lookup flavor . get) + (\opts b -> set (reorder (update flavor opts (get b))) b) $ + field name (hsep . map text) + (sepBy parseTokenQ' (munch1 isSpace)) + where + update _ opts l | all null opts = l --empty opts as if no opts + update f opts [] = [(f,opts)] + update f opts ((f',opts'):rest) + | f == f' = (f, opts' ++ opts) : rest + | otherwise = (f',opts') : update f opts rest + reorder = sortBy (comparing fst) + +-- TODO: this is a bit smelly hack. It's because we want to parse bool fields +-- liberally but not accept new parses. We cannot do that with ReadP +-- because it does not support warnings. We need a new parser framwork! +boolField :: String -> (b -> Bool) -> (Bool -> b -> b) -> FieldDescr b +boolField name get set = liftField get set (FieldDescr name showF readF) + where + showF = text . show + readF line str _ + | str == "True" = ParseOk [] True + | str == "False" = ParseOk [] False + | lstr == "true" = ParseOk [caseWarning] True + | lstr == "false" = ParseOk [caseWarning] False + | otherwise = ParseFailed (NoParse name line) + where + lstr = lowercase str + caseWarning = PWarning $ + "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'." + +ppFields :: [FieldDescr a] -> a -> Doc +ppFields fields x = vcat [ ppField name (getter x) + | FieldDescr name getter _ <- fields] + +ppField :: String -> Doc -> Doc +ppField name fielddoc = text name <> colon <+> fielddoc + +showFields :: [FieldDescr a] -> a -> String +showFields fields = render . ($+$ text "") . ppFields fields + +showSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String) +showSingleNamedField fields f = + case [ get | (FieldDescr f' get _) <- fields, f' == f ] of + [] -> Nothing + (get:_) -> Just (render . ppField f . get) + +parseFields :: [FieldDescr a] -> a -> String -> ParseResult a +parseFields fields initial = \str -> + readFields str >>= accumFields fields initial + +parseFieldsFlat :: [FieldDescr a] -> a -> String -> ParseResult a +parseFieldsFlat fields initial = \str -> + readFieldsFlat str >>= accumFields fields initial + +accumFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a +accumFields fields = foldM setField + where + fieldMap = Map.fromList + [ (name, f) | f@(FieldDescr name _ _) <- fields ] + setField accum (F line name value) = case Map.lookup name fieldMap of + Just (FieldDescr _ _ set) -> set line value accum + Nothing -> do + warning ("Unrecognized field " ++ name ++ " on line " ++ show line) + return accum + setField accum f = do + warning ("Unrecognized stanza on line " ++ show (lineNo f)) + return accum + +-- | The type of a function which, given a name-value pair of an +-- unrecognized field, and the current structure being built, +-- decides whether to incorporate the unrecognized field +-- (by returning Just x, where x is a possibly modified version +-- of the structure being built), or not (by returning Nothing). +type UnrecFieldParser a = (String,String) -> a -> Maybe a + +-- | A default unrecognized field parser which simply returns Nothing, +-- i.e. ignores all unrecognized fields, so warnings will be generated. +warnUnrec :: UnrecFieldParser a +warnUnrec _ _ = Nothing + +-- | A default unrecognized field parser which silently (i.e. no +-- warnings will be generated) ignores unrecognized fields, by +-- returning the structure being built unmodified. +ignoreUnrec :: UnrecFieldParser a +ignoreUnrec _ x = Just x + +------------------------------------------------------------------------------ + +-- The data type for our three syntactic categories +data Field + = F LineNo String String + -- ^ A regular @: @ field + | Section LineNo String String [Field] + -- ^ A section with a name and possible parameter. The syntactic + -- structure is: + -- + -- @ + -- { + -- * + -- } + -- @ + | IfBlock LineNo String [Field] [Field] + -- ^ A conditional block with an optional else branch: + -- + -- @ + -- if { + -- * + -- } else { + -- * + -- } + -- @ + deriving (Show + ,Eq) -- for testing + +lineNo :: Field -> LineNo +lineNo (F n _ _) = n +lineNo (Section n _ _ _) = n +lineNo (IfBlock n _ _ _) = n + +fName :: Field -> String +fName (F _ n _) = n +fName (Section _ n _ _) = n +fName _ = error "fname: not a field or section" + +readFields :: String -> ParseResult [Field] +readFields input = ifelse + =<< mapM (mkField 0) + =<< mkTree tokens + + where ls = (lines . normaliseLineEndings) input + tokens = (concatMap tokeniseLine . trimLines) ls + +readFieldsFlat :: String -> ParseResult [Field] +readFieldsFlat input = mapM (mkField 0) + =<< mkTree tokens + where ls = (lines . normaliseLineEndings) input + tokens = (concatMap tokeniseLineFlat . trimLines) ls + +-- attach line number and determine indentation +trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)] +trimLines ls = [ (lineno, indent, hastabs, (trimTrailing l')) + | (lineno, l) <- zip [1..] ls + , let (sps, l') = span isSpace l + indent = length sps + hastabs = '\t' `elem` sps + , validLine l' ] + where validLine ('-':'-':_) = False -- Comment + validLine [] = False -- blank line + validLine _ = True + +-- | We parse generically based on indent level and braces '{' '}'. To do that +-- we split into lines and then '{' '}' tokens and other spans within a line. +data Token = + -- | The 'Line' token is for bits that /start/ a line, eg: + -- + -- > "\n blah blah { blah" + -- + -- tokenises to: + -- + -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"] + -- + -- so lines are the only ones that can have nested layout, since they + -- have a known indentation level. + -- + -- eg: we can't have this: + -- + -- > if ... { + -- > } else + -- > other + -- + -- because other cannot nest under else, since else doesn't start a line + -- so cannot have nested layout. It'd have to be: + -- + -- > if ... { + -- > } + -- > else + -- > other + -- + -- but that's not so common, people would normally use layout or + -- brackets not both in a single @if else@ construct. + -- + -- > if ... { foo : bar } + -- > else + -- > other + -- + -- this is ok + Line LineNo Indent HasTabs String + | Span LineNo String -- ^ span in a line, following brackets + | OpenBracket LineNo | CloseBracket LineNo + +type Indent = Int +type HasTabs = Bool + +-- | Tokenise a single line, splitting on '{' '}' and the spans inbetween. +-- Also trims leading & trailing space on those spans within the line. +tokeniseLine :: (LineNo, Indent, HasTabs, String) -> [Token] +tokeniseLine (n0, i, t, l) = case split n0 l of + (Span _ l':ss) -> Line n0 i t l' :ss + cs -> cs + where split _ "" = [] + split n s = case span (\c -> c /='}' && c /= '{') s of + ("", '{' : s') -> OpenBracket n : split n s' + (w , '{' : s') -> mkspan n w (OpenBracket n : split n s') + ("", '}' : s') -> CloseBracket n : split n s' + (w , '}' : s') -> mkspan n w (CloseBracket n : split n s') + (w , _) -> mkspan n w [] + + mkspan n s ss | null s' = ss + | otherwise = Span n s' : ss + where s' = trimTrailing (trimLeading s) + +tokeniseLineFlat :: (LineNo, Indent, HasTabs, String) -> [Token] +tokeniseLineFlat (n0, i, t, l) + | null l' = [] + | otherwise = [Line n0 i t l'] + where + l' = trimTrailing (trimLeading l) + +trimLeading, trimTrailing :: String -> String +trimLeading = dropWhile isSpace +trimTrailing = reverse . dropWhile isSpace . reverse + + +type SyntaxTree = Tree (LineNo, HasTabs, String) + +-- | Parse the stream of tokens into a tree of them, based on indent \/ layout +mkTree :: [Token] -> ParseResult [SyntaxTree] +mkTree toks = + layout 0 [] toks >>= \(trees, trailing) -> case trailing of + [] -> return trees + OpenBracket n:_ -> syntaxError n "mismatched backets, unexpected {" + CloseBracket n:_ -> syntaxError n "mismatched backets, unexpected }" + -- the following two should never happen: + Span n l :_ -> syntaxError n $ "unexpected span: " ++ show l + Line n _ _ l :_ -> syntaxError n $ "unexpected line: " ++ show l + + +-- | Parse the stream of tokens into a tree of them, based on indent +-- This parse state expect to be in a layout context, though possibly +-- nested within a braces context so we may still encounter closing braces. +layout :: Indent -- ^ indent level of the parent\/previous line + -> [SyntaxTree] -- ^ accumulating param, trees in this level + -> [Token] -- ^ remaining tokens + -> ParseResult ([SyntaxTree], [Token]) + -- ^ collected trees on this level and trailing tokens +layout _ a [] = return (reverse a, []) +layout i a (s@(Line _ i' _ _):ss) | i' < i = return (reverse a, s:ss) +layout i a (Line n _ t l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + layout i (Node (n,t,l) sub:a) ss' + +layout i a (Span n l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + layout i (Node (n,False,l) sub:a) ss' + +-- look ahead to see if following lines are more indented, giving a sub-tree +layout i a (Line n i' t l:ss) = do + lookahead <- layout (i'+1) [] ss + case lookahead of + ([], _) -> layout i (Node (n,t,l) [] :a) ss + (ts, ss') -> layout i (Node (n,t,l) ts :a) ss' + +layout _ _ ( OpenBracket n :_) = syntaxError n $ "unexpected '{'" +layout _ a (s@(CloseBracket _):ss) = return (reverse a, s:ss) +layout _ _ ( Span n l : _) = syntaxError n $ "unexpected span: " + ++ show l + +-- | Parse the stream of tokens into a tree of them, based on explicit braces +-- This parse state expects to find a closing bracket. +braces :: LineNo -- ^ line of the '{', used for error messages + -> [SyntaxTree] -- ^ accumulating param, trees in this level + -> [Token] -- ^ remaining tokens + -> ParseResult ([SyntaxTree],[Token]) + -- ^ collected trees on this level and trailing tokens +braces m a (Line n _ t l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + braces m (Node (n,t,l) sub:a) ss' + +braces m a (Span n l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + braces m (Node (n,False,l) sub:a) ss' + +braces m a (Line n i t l:ss) = do + lookahead <- layout (i+1) [] ss + case lookahead of + ([], _) -> braces m (Node (n,t,l) [] :a) ss + (ts, ss') -> braces m (Node (n,t,l) ts :a) ss' + +braces m a (Span n l:ss) = braces m (Node (n,False,l) []:a) ss +braces _ a (CloseBracket _:ss) = return (reverse a, ss) +braces n _ [] = syntaxError n $ "opening brace '{'" + ++ "has no matching closing brace '}'" +braces _ _ (OpenBracket n:_) = syntaxError n "unexpected '{'" + +-- | Convert the parse tree into the Field AST +-- Also check for dodgy uses of tabs in indentation. +mkField :: Int -> SyntaxTree -> ParseResult Field +mkField d (Node (n,t,_) _) | d >= 1 && t = tabsError n +mkField d (Node (n,_,l) ts) = case span (\c -> isAlphaNum c || c == '-') l of + ([], _) -> syntaxError n $ "unrecognised field or section: " ++ show l + (name, rest) -> case trimLeading rest of + (':':rest') -> do let followingLines = concatMap Tree.flatten ts + tabs = not (null [()| (_,True,_) <- followingLines ]) + if tabs && d >= 1 + then tabsError n + else return $ F n (map toLower name) + (fieldValue rest' followingLines) + rest' -> do ts' <- mapM (mkField (d+1)) ts + return (Section n (map toLower name) rest' ts') + where fieldValue firstLine followingLines = + let firstLine' = trimLeading firstLine + followingLines' = map (\(_,_,s) -> stripDot s) followingLines + allLines | null firstLine' = followingLines' + | otherwise = firstLine' : followingLines' + in intercalate "\n" allLines + stripDot "." = "" + stripDot s = s + +-- | Convert if/then/else 'Section's to 'IfBlock's +ifelse :: [Field] -> ParseResult [Field] +ifelse [] = return [] +ifelse (Section n "if" cond thenpart + :Section _ "else" as elsepart:fs) + | null cond = syntaxError n "'if' with missing condition" + | null thenpart = syntaxError n "'then' branch of 'if' is empty" + | not (null as) = syntaxError n "'else' takes no arguments" + | null elsepart = syntaxError n "'else' branch of 'if' is empty" + | otherwise = do tp <- ifelse thenpart + ep <- ifelse elsepart + fs' <- ifelse fs + return (IfBlock n cond tp ep:fs') +ifelse (Section n "if" cond thenpart:fs) + | null cond = syntaxError n "'if' with missing condition" + | null thenpart = syntaxError n "'then' branch of 'if' is empty" + | otherwise = do tp <- ifelse thenpart + fs' <- ifelse fs + return (IfBlock n cond tp []:fs') +ifelse (Section n "else" _ _:_) = syntaxError n "stray 'else' with no preceding 'if'" +ifelse (Section n s a fs':fs) = do fs'' <- ifelse fs' + fs''' <- ifelse fs + return (Section n s a fs'' : fs''') +ifelse (f:fs) = do fs' <- ifelse fs + return (f : fs') + +------------------------------------------------------------------------------ + +-- |parse a module name +parseModuleNameQ :: ReadP r ModuleName +parseModuleNameQ = parseQuoted parse <++ parse + +parseFilePathQ :: ReadP r FilePath +parseFilePathQ = parseTokenQ + -- removed until normalise is no longer broken, was: + -- liftM normalise parseTokenQ + +parseBuildTool :: ReadP r Dependency +parseBuildTool = do name <- parseBuildToolNameQ + skipSpaces + ver <- parseVersionRangeQ <++ return anyVersion + skipSpaces + return $ Dependency name ver + +parseBuildToolNameQ :: ReadP r PackageName +parseBuildToolNameQ = parseQuoted parseBuildToolName <++ parseBuildToolName + +-- like parsePackageName but accepts symbols in components +parseBuildToolName :: ReadP r PackageName +parseBuildToolName = do ns <- sepBy1 component (ReadP.char '-') + return (PackageName (intercalate "-" ns)) + where component = do + cs <- munch1 (\c -> isAlphaNum c || c == '+' || c == '_') + if all isDigit cs then pfail else return cs + +-- pkg-config allows versions and other letters in package names, +-- eg "gtk+-2.0" is a valid pkg-config package _name_. +-- It then has a package version number like 2.10.13 +parsePkgconfigDependency :: ReadP r Dependency +parsePkgconfigDependency = do name <- munch1 (\c -> isAlphaNum c || c `elem` "+-._") + skipSpaces + ver <- parseVersionRangeQ <++ return anyVersion + skipSpaces + return $ Dependency (PackageName name) ver + +parsePackageNameQ :: ReadP r PackageName +parsePackageNameQ = parseQuoted parse <++ parse + +parseVersionRangeQ :: ReadP r VersionRange +parseVersionRangeQ = parseQuoted parse <++ parse + +parseOptVersion :: ReadP r Version +parseOptVersion = parseQuoted ver <++ ver + where ver :: ReadP r Version + ver = parse <++ return noVersion + noVersion = Version{ versionBranch=[], versionTags=[] } + +parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange) +parseTestedWithQ = parseQuoted tw <++ tw + where + tw :: ReadP r (CompilerFlavor,VersionRange) + tw = do compiler <- parseCompilerFlavorCompat + skipSpaces + version <- parse <++ return anyVersion + skipSpaces + return (compiler,version) + +parseLicenseQ :: ReadP r License +parseLicenseQ = parseQuoted parse <++ parse + +-- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a +-- because the "compat" version of ReadP isn't quite powerful enough. In +-- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a +-- Hence the trick above to make 'lic' polymorphic. + +parseLanguageQ :: ReadP r Language +parseLanguageQ = parseQuoted parse <++ parse + +parseExtensionQ :: ReadP r Extension +parseExtensionQ = parseQuoted parse <++ parse + +parseHaskellString :: ReadP r String +parseHaskellString = readS_to_P reads + +parseTokenQ :: ReadP r String +parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',') + +parseTokenQ' :: ReadP r String +parseTokenQ' = parseHaskellString <++ munch1 (\x -> not (isSpace x)) + +parseSepList :: ReadP r b + -> ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseSepList sepr p = sepBy p separator + where separator = skipSpaces >> sepr >> skipSpaces + +parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseSpaceList p = sepBy p skipSpaces + +parseCommaList :: ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseCommaList = parseSepList (ReadP.char ',') + +parseOptCommaList :: ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseOptCommaList = parseSepList (optional (ReadP.char ',')) + +parseQuoted :: ReadP r a -> ReadP r a +parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p + +parseFreeText :: ReadP.ReadP s String +parseFreeText = ReadP.munch (const True) + +-- -------------------------------------------- +-- ** 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) <+> disp version + +-- | Pretty-print free-format text, ensuring that it is vertically aligned, +-- and with blank lines replaced by dots for correct re-parsing. +showFreeText :: String -> Doc +showFreeText "" = empty +showFreeText ('\n' :r) = text " " $+$ text "." $+$ showFreeText r +showFreeText s = vcat [text (if null l then "." else l) | l <- lines_ s] + +-- | 'lines_' breaks a string up into a list of strings at newline +-- characters. The resulting strings do not contain newlines. +lines_ :: String -> [String] +lines_ [] = [""] +lines_ s = let (l, s') = break (== '\n') s + in l : case s' of + [] -> [] + (_:s'') -> lines_ s'' diff --git a/cabal/cabal/Distribution/ReadE.hs b/cabal/cabal/Distribution/ReadE.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/ReadE.hs @@ -0,0 +1,81 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.ReadE +-- Copyright : Jose Iborra 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Simple parsing with failure + +{- Copyright (c) 2007, Jose Iborra +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.ReadE ( + -- * ReadE + ReadE(..), succeedReadE, failReadE, + -- * Projections + parseReadE, readEOrFail, + readP_to_E + ) where + +import Distribution.Compat.ReadP +import Data.Char ( isSpace ) + +-- | Parser with simple error reporting +newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a} +type ErrorMsg = String + +instance Functor ReadE where + fmap f (ReadE p) = ReadE $ \txt -> case p txt of + Right a -> Right (f a) + Left err -> Left err + +succeedReadE :: (String -> a) -> ReadE a +succeedReadE f = ReadE (Right . f) + +failReadE :: ErrorMsg -> ReadE a +failReadE = ReadE . const Left + +parseReadE :: ReadE a -> ReadP r a +parseReadE (ReadE p) = do + txt <- look + either fail return (p txt) + +readEOrFail :: ReadE a -> (String -> a) +readEOrFail r = either error id . runReadE r + +readP_to_E :: (String -> ErrorMsg) -> ReadP a a -> ReadE a +readP_to_E err r = + ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt + , all isSpace s ] + of [] -> Left (err txt) + (p:_) -> Right p diff --git a/cabal/cabal/Distribution/Simple.hs b/cabal/cabal/Distribution/Simple.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple.hs @@ -0,0 +1,677 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the command line front end to the Simple build system. When given +-- the parsed command-line args and package information, is able to perform +-- basic commands like configure, build, install, register, etc. +-- +-- This module exports the main functions that Setup.hs scripts use. It +-- re-exports the 'UserHooks' type, the standard entry points like +-- 'defaultMain' and 'defaultMainWithHooks' and the predefined sets of +-- 'UserHooks' that custom @Setup.hs@ scripts can extend to add their own +-- behaviour. +-- +-- 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. +-- +-- The original idea was that there could be different build systems that all +-- presented the same compatible command line interfaces. There is still a +-- "Distribution.Make" system but in practice no packages use it. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +{- +Work around this warning: +libraries/Cabal/Distribution/Simple.hs:78:0: + Warning: In the use of `runTests' + (imported from Distribution.Simple.UserHooks): + Deprecated: "Please use the new testing interface instead!" +-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +module Distribution.Simple ( + module Distribution.Package, + module Distribution.Version, + module Distribution.License, + module Distribution.Simple.Compiler, + module Language.Haskell.Extension, + -- * Simple interface + defaultMain, defaultMainNoRead, defaultMainArgs, + -- * Customization + UserHooks(..), Args, + defaultMainWithHooks, defaultMainWithHooksArgs, + -- ** Standard sets of hooks + simpleUserHooks, + autoconfUserHooks, + defaultUserHooks, emptyUserHooks, + -- ** Utils + defaultHookedPackageDesc + ) where + +-- local +import Distribution.Simple.Compiler hiding (Flag) +import Distribution.Simple.UserHooks +import Distribution.Package --must not specify imports, since we're exporting moule. +import Distribution.PackageDescription + ( PackageDescription(..), GenericPackageDescription, Executable(..) + , updatePackageDescription, hasLibs + , HookedBuildInfo, emptyHookedBuildInfo ) +import Distribution.PackageDescription.Parse + ( readPackageDescription, readHookedBuildInfo ) +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) +import Distribution.Simple.Program + ( defaultProgramConfiguration, addKnownPrograms, builtinPrograms + , restoreProgramConfiguration, reconfigurePrograms ) +import Distribution.Simple.PreProcess (knownSuffixHandlers, PPSuffixHandler) +import Distribution.Simple.Setup +import Distribution.Simple.Command + +import Distribution.Simple.Build ( build ) +import Distribution.Simple.SrcDist ( sdist ) +import Distribution.Simple.Register + ( register, unregister ) + +import Distribution.Simple.Configure + ( getPersistBuildConfig, maybeGetPersistBuildConfig + , writePersistBuildConfig, checkPersistBuildConfigOutdated + , configure, checkForeignDeps ) + +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) +import Distribution.Simple.BuildPaths ( srcPref) +import Distribution.Simple.Test (test) +import Distribution.Simple.Install (install) +import Distribution.Simple.Haddock (haddock, hscolour) +import Distribution.Simple.Utils + (die, notice, info, warn, setupMessage, chattyTry, + defaultPackageDesc, defaultHookedPackageDesc, + rawSystemExitWithEnv, cabalVersion, topHandler ) +import Distribution.System + ( OS(..), buildOS ) +import Distribution.Verbosity +import Language.Haskell.Extension +import Distribution.Version +import Distribution.License +import Distribution.Text + ( display ) + +-- Base +import System.Environment(getArgs, getProgName, getEnvironment) +import System.Directory(removeFile, doesFileExist, + doesDirectoryExist, removeDirectoryRecursive) +import System.Exit +import System.IO.Error (isDoesNotExistError) +import Distribution.Compat.Exception (catchIO, throwIOIO) + +import Control.Monad (when) +import Data.List (intersperse, unionBy, nub, (\\)) + +-- | 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 >>= defaultMainHelper simpleUserHooks + +-- | A version of 'defaultMain' that is passed the command line +-- arguments, rather than getting them from the environment. +defaultMainArgs :: [String] -> IO () +defaultMainArgs = defaultMainHelper simpleUserHooks + +-- | A customizable version of 'defaultMain'. +defaultMainWithHooks :: UserHooks -> IO () +defaultMainWithHooks hooks = getArgs >>= defaultMainHelper hooks + +-- | A customizable version of 'defaultMain' that also takes the command +-- line arguments. +defaultMainWithHooksArgs :: UserHooks -> [String] -> IO () +defaultMainWithHooksArgs = defaultMainHelper + +-- | Like 'defaultMain', but accepts the package description as input +-- rather than using IO to read it. +defaultMainNoRead :: GenericPackageDescription -> IO () +defaultMainNoRead pkg_descr = + getArgs >>= + defaultMainHelper simpleUserHooks { readDesc = return (Just pkg_descr) } + +defaultMainHelper :: UserHooks -> Args -> IO () +defaultMainHelper hooks args = topHandler $ + case commandsRun globalCommand commands args of + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (flags, commandParse) -> + case commandParse of + _ | fromFlag (globalVersion flags) -> printVersion + | fromFlag (globalNumericVersion flags) -> printNumericVersion + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action + + where + printHelp help = getProgName >>= putStr . help + printOptionsList = putStr . unlines + printErrors errs = do + putStr (concat (intersperse "\n" errs)) + exitWith (ExitFailure 1) + printNumericVersion = putStrLn $ display cabalVersion + printVersion = putStrLn $ "Cabal library version " + ++ display cabalVersion + + progs = addKnownPrograms (hookedPrograms hooks) defaultProgramConfiguration + commands = + [configureCommand progs `commandAddAction` \fs as -> + configureAction hooks fs as >> return () + ,buildCommand progs `commandAddAction` buildAction hooks + ,installCommand `commandAddAction` installAction hooks + ,copyCommand `commandAddAction` copyAction hooks + ,haddockCommand `commandAddAction` haddockAction hooks + ,cleanCommand `commandAddAction` cleanAction hooks + ,sdistCommand `commandAddAction` sdistAction hooks + ,hscolourCommand `commandAddAction` hscolourAction hooks + ,registerCommand `commandAddAction` registerAction hooks + ,unregisterCommand `commandAddAction` unregisterAction hooks + ,testCommand `commandAddAction` testAction hooks + ] + +-- | Combine the preprocessors in the given hooks with the +-- preprocessors built into cabal. +allSuffixHandlers :: UserHooks + -> [PPSuffixHandler] +allSuffixHandlers hooks + = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers + where + overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] + overridesPP = unionBy (\x y -> fst x == fst y) + +configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo +configureAction hooks flags args = do + let distPref = fromFlag $ configDistPref flags + pbi <- preConf hooks args flags + + (mb_pd_file, pkg_descr0) <- confPkgDescr + + -- get_pkg_descr (configVerbosity flags') + --let pkg_descr = updatePackageDescription pbi pkg_descr0 + let epkg_descr = (pkg_descr0, pbi) + + --(warns, ers) <- sanityCheckPackage pkg_descr + --errorOut (configVerbosity flags') warns ers + + localbuildinfo0 <- confHook hooks epkg_descr flags + + -- remember the .cabal filename if we know it + -- and all the extra command line args + let localbuildinfo = localbuildinfo0 { + pkgDescrFile = mb_pd_file, + extraConfigArgs = args + } + writePersistBuildConfig distPref localbuildinfo + + let pkg_descr = localPkgDescr localbuildinfo + postConf hooks args flags pkg_descr localbuildinfo + return localbuildinfo + where + verbosity = fromFlag (configVerbosity flags) + confPkgDescr :: IO (Maybe FilePath, GenericPackageDescription) + confPkgDescr = do + mdescr <- readDesc hooks + case mdescr of + Just descr -> return (Nothing, descr) + Nothing -> do + pdfile <- defaultPackageDesc verbosity + descr <- readPackageDescription verbosity pdfile + return (Just pdfile, descr) + +buildAction :: UserHooks -> BuildFlags -> Args -> IO () +buildAction hooks flags args = do + let distPref = fromFlag $ buildDistPref flags + verbosity = fromFlag $ buildVerbosity flags + + lbi <- getBuildConfig hooks verbosity distPref + progs <- reconfigurePrograms verbosity + (buildProgramPaths flags) + (buildProgramArgs flags) + (withPrograms lbi) + + hookedAction preBuild buildHook postBuild + (return lbi { withPrograms = progs }) + hooks flags args + +hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO () +hscolourAction hooks flags args + = do let distPref = fromFlag $ hscolourDistPref flags + verbosity = fromFlag $ hscolourVerbosity flags + hookedAction preHscolour hscolourHook postHscolour + (getBuildConfig hooks verbosity distPref) + hooks flags args + +haddockAction :: UserHooks -> HaddockFlags -> Args -> IO () +haddockAction hooks flags args = do + let distPref = fromFlag $ haddockDistPref flags + verbosity = fromFlag $ haddockVerbosity flags + + lbi <- getBuildConfig hooks verbosity distPref + progs <- reconfigurePrograms verbosity + (haddockProgramPaths flags) + (haddockProgramArgs flags) + (withPrograms lbi) + + hookedAction preHaddock haddockHook postHaddock + (return lbi { withPrograms = progs }) + hooks flags args + +cleanAction :: UserHooks -> CleanFlags -> Args -> IO () +cleanAction hooks flags args = do + pbi <- preClean hooks args flags + + pdfile <- defaultPackageDesc verbosity + ppd <- readPackageDescription verbosity pdfile + let pkg_descr0 = flattenPackageDescription ppd + -- We don't sanity check for clean as an error + -- here would prevent cleaning: + --sanityCheckHookedBuildInfo pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + + cleanHook hooks pkg_descr () hooks flags + postClean hooks args flags pkg_descr () + where verbosity = fromFlag (cleanVerbosity flags) + +copyAction :: UserHooks -> CopyFlags -> Args -> IO () +copyAction hooks flags args + = do let distPref = fromFlag $ copyDistPref flags + verbosity = fromFlag $ copyVerbosity flags + hookedAction preCopy copyHook postCopy + (getBuildConfig hooks verbosity distPref) + hooks flags args + +installAction :: UserHooks -> InstallFlags -> Args -> IO () +installAction hooks flags args + = do let distPref = fromFlag $ installDistPref flags + verbosity = fromFlag $ installVerbosity flags + hookedAction preInst instHook postInst + (getBuildConfig hooks verbosity distPref) + hooks flags args + +sdistAction :: UserHooks -> SDistFlags -> Args -> IO () +sdistAction hooks flags args = do + let distPref = fromFlag $ sDistDistPref flags + pbi <- preSDist hooks args flags + + mlbi <- maybeGetPersistBuildConfig distPref + pdfile <- defaultPackageDesc verbosity + ppd <- readPackageDescription verbosity pdfile + let pkg_descr0 = flattenPackageDescription ppd + sanityCheckHookedBuildInfo pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + + sDistHook hooks pkg_descr mlbi hooks flags + postSDist hooks args flags pkg_descr mlbi + where verbosity = fromFlag (sDistVerbosity flags) + +testAction :: UserHooks -> TestFlags -> Args -> IO () +testAction hooks flags args = do + let distPref = fromFlag $ testDistPref flags + verbosity = fromFlag $ testVerbosity flags + localBuildInfo <- getBuildConfig hooks verbosity distPref + let pkg_descr = localPkgDescr localBuildInfo + -- It is safe to do 'runTests' before the new test handler because the + -- default action is a no-op and if the package uses the old test interface + -- the new handler will find no tests. + runTests hooks args False pkg_descr localBuildInfo + --FIXME: this is a hack, passing the args inside the flags + -- it's because the args to not get passed to the main test hook + let flags' = flags { testList = Flag args } + hookedAction preTest testHook postTest + (getBuildConfig hooks verbosity distPref) + hooks flags' args + +registerAction :: UserHooks -> RegisterFlags -> Args -> IO () +registerAction hooks flags args + = do let distPref = fromFlag $ regDistPref flags + verbosity = fromFlag $ regVerbosity flags + hookedAction preReg regHook postReg + (getBuildConfig hooks verbosity distPref) + hooks flags args + +unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO () +unregisterAction hooks flags args + = do let distPref = fromFlag $ regDistPref flags + verbosity = fromFlag $ regVerbosity flags + hookedAction preUnreg unregHook postUnreg + (getBuildConfig hooks verbosity distPref) + hooks flags args + +hookedAction :: (UserHooks -> Args -> flags -> IO HookedBuildInfo) + -> (UserHooks -> PackageDescription -> LocalBuildInfo + -> UserHooks -> flags -> IO ()) + -> (UserHooks -> Args -> flags -> PackageDescription + -> LocalBuildInfo -> IO ()) + -> IO LocalBuildInfo + -> UserHooks -> flags -> Args -> IO () +hookedAction pre_hook cmd_hook post_hook get_build_config hooks flags args = do + pbi <- pre_hook hooks args flags + localbuildinfo <- get_build_config + let pkg_descr0 = localPkgDescr localbuildinfo + --pkg_descr0 <- get_pkg_descr (get_verbose flags) + sanityCheckHookedBuildInfo pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + -- TODO: should we write the modified package descr back to the + -- localbuildinfo? + cmd_hook hooks pkg_descr localbuildinfo hooks flags + post_hook hooks args flags pkg_descr localbuildinfo + +sanityCheckHookedBuildInfo :: PackageDescription -> HookedBuildInfo -> IO () +sanityCheckHookedBuildInfo PackageDescription { library = Nothing } (Just _,_) + = die $ "The buildinfo contains info for a library, " + ++ "but the package does not have a library." + +sanityCheckHookedBuildInfo pkg_descr (_, hookExes) + | not (null nonExistant) + = die $ "The buildinfo contains info for an executable called '" + ++ head nonExistant ++ "' but the package does not have a " + ++ "executable with that name." + where + pkgExeNames = nub (map exeName (executables pkg_descr)) + hookExeNames = nub (map fst hookExes) + nonExistant = hookExeNames \\ pkgExeNames + +sanityCheckHookedBuildInfo _ _ = return () + + +getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo +getBuildConfig hooks verbosity distPref = do + lbi_wo_programs <- getPersistBuildConfig distPref + -- Restore info about unconfigured programs, since it is not serialized + let lbi = lbi_wo_programs { + withPrograms = restoreProgramConfiguration + (builtinPrograms ++ hookedPrograms hooks) + (withPrograms lbi_wo_programs) + } + + case pkgDescrFile lbi of + Nothing -> return lbi + Just pkg_descr_file -> do + outdated <- checkPersistBuildConfigOutdated distPref pkg_descr_file + if outdated + then reconfigure pkg_descr_file lbi + else return lbi + + where + reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo + reconfigure pkg_descr_file lbi = do + notice verbosity $ pkg_descr_file ++ " has been changed. " + ++ "Re-configuring with most recently used options. " + ++ "If this fails, please run configure manually.\n" + let cFlags = configFlags lbi + let cFlags' = cFlags { + -- Since the list of unconfigured programs is not serialized, + -- restore it to the same value as normally used at the beginning + -- of a conigure run: + configPrograms = restoreProgramConfiguration + (builtinPrograms ++ hookedPrograms hooks) + (configPrograms cFlags), + + -- Use the current, not saved verbosity level: + configVerbosity = Flag verbosity + } + configureAction hooks cFlags' (extraConfigArgs lbi) + + +-- -------------------------------------------------------------------------- +-- Cleaning + +clean :: PackageDescription -> CleanFlags -> IO () +clean pkg_descr flags = do + let distPref = fromFlag $ cleanDistPref flags + notice verbosity "cleaning..." + + maybeConfig <- if fromFlag (cleanSaveConf flags) + then maybeGetPersistBuildConfig distPref + else return Nothing + + -- remove the whole dist/ directory rather than tracking exactly what files + -- we created in there. + chattyTry "removing dist/" $ do + exists <- doesDirectoryExist distPref + when exists (removeDirectoryRecursive distPref) + + -- Any extra files the user wants to remove + mapM_ removeFileOrDirectory (extraTmpFiles pkg_descr) + + -- If the user wanted to save the config, write it back + maybe (return ()) (writePersistBuildConfig distPref) maybeConfig + + where + 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 () + verbosity = fromFlag (cleanVerbosity flags) + +-- -------------------------------------------------------------------------- +-- Default hooks + +-- | Hooks that correspond to a plain instantiation of the +-- \"simple\" build system +simpleUserHooks :: UserHooks +simpleUserHooks = + emptyUserHooks { + confHook = configure, + postConf = finalChecks, + buildHook = defaultBuildHook, + copyHook = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params + testHook = defaultTestHook, + instHook = defaultInstallHook, + sDistHook = \p l h f -> sdist p l f srcPref (allSuffixHandlers h), + cleanHook = \p _ _ f -> clean p f, + hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f, + haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f, + regHook = defaultRegHook, + unregHook = \p l _ f -> unregister p l f + } + where + finalChecks _args flags pkg_descr lbi = + checkForeignDeps pkg_descr lbi (lessVerbose verbosity) + where + verbosity = fromFlag (configVerbosity flags) + +-- | Basic autoconf 'UserHooks': +-- +-- * '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. + +{-# DEPRECATED defaultUserHooks + "Use simpleUserHooks or autoconfUserHooks, unless you need Cabal-1.2\n compatibility in which case you must stick with defaultUserHooks" #-} +defaultUserHooks :: UserHooks +defaultUserHooks = autoconfUserHooks { + confHook = \pkg flags -> do + let verbosity = fromFlag (configVerbosity flags) + warn verbosity $ + "defaultUserHooks in Setup script is deprecated." + confHook autoconfUserHooks pkg flags, + postConf = oldCompatPostConf + } + -- This is the annoying old version that only runs configure if it exists. + -- It's here for compatibility with existing Setup.hs scripts. See: + -- http://hackage.haskell.org/trac/hackage/ticket/165 + where oldCompatPostConf args flags pkg_descr lbi + = do let verbosity = fromFlag (configVerbosity flags) + noExtraFlags args + confExists <- doesFileExist "configure" + when confExists $ + runConfigureScript verbosity + backwardsCompatHack flags lbi + + pbi <- getHookedBuildInfo verbosity + sanityCheckHookedBuildInfo pkg_descr pbi + let pkg_descr' = updatePackageDescription pbi pkg_descr + postConf simpleUserHooks args flags pkg_descr' lbi + + backwardsCompatHack = True + +autoconfUserHooks :: UserHooks +autoconfUserHooks + = simpleUserHooks + { + postConf = defaultPostConf, + preBuild = readHook buildVerbosity, + preClean = readHook cleanVerbosity, + preCopy = readHook copyVerbosity, + preInst = readHook installVerbosity, + preHscolour = readHook hscolourVerbosity, + preHaddock = readHook haddockVerbosity, + preReg = readHook regVerbosity, + preUnreg = readHook regVerbosity + } + where defaultPostConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () + defaultPostConf args flags pkg_descr lbi + = do let verbosity = fromFlag (configVerbosity flags) + noExtraFlags args + confExists <- doesFileExist "configure" + if confExists + then runConfigureScript verbosity + backwardsCompatHack flags lbi + else die "configure script not found." + + pbi <- getHookedBuildInfo verbosity + sanityCheckHookedBuildInfo pkg_descr pbi + let pkg_descr' = updatePackageDescription pbi pkg_descr + postConf simpleUserHooks args flags pkg_descr' lbi + + backwardsCompatHack = False + + readHook :: (a -> Flag Verbosity) -> Args -> a -> IO HookedBuildInfo + readHook get_verbosity a flags = do + noExtraFlags a + getHookedBuildInfo verbosity + where + verbosity = fromFlag (get_verbosity flags) + +runConfigureScript :: Verbosity -> Bool -> ConfigFlags -> LocalBuildInfo + -> IO () +runConfigureScript verbosity backwardsCompatHack flags lbi = do + + env <- getEnvironment + let programConfig = withPrograms lbi + (ccProg, ccFlags) <- configureCCompiler verbosity programConfig + -- The C compiler's compilation and linker flags (e.g. + -- "C compiler flags" and "Gcc Linker flags" from GHC) have already + -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS + -- to ccFlags + -- We don't try and tell configure which ld to use, as we don't have + -- a way to pass its flags too + let env' = appendToEnvironment ("CFLAGS", unwords ccFlags) + env + args' = args ++ ["--with-gcc=" ++ ccProg] + handleNoWindowsSH $ + rawSystemExitWithEnv verbosity "sh" args' env' + + where + args = "configure" : configureArgs backwardsCompatHack flags + + appendToEnvironment (key, val) [] = [(key, val)] + appendToEnvironment (key, val) (kv@(k, v) : rest) + | key == k = (key, v ++ " " ++ val) : rest + | otherwise = kv : appendToEnvironment (key, val) rest + + handleNoWindowsSH action + | buildOS /= Windows + = action + + | otherwise + = action + `catchIO` \ioe -> if isDoesNotExistError ioe + then die notFoundMsg + else throwIOIO ioe + + notFoundMsg = "The package has a './configure' script. This requires a " + ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin." + +getHookedBuildInfo :: Verbosity -> IO HookedBuildInfo +getHookedBuildInfo verbosity = do + maybe_infoFile <- defaultHookedPackageDesc + case maybe_infoFile of + Nothing -> return emptyHookedBuildInfo + Just infoFile -> do + info verbosity $ "Reading parameters from " ++ infoFile + readHookedBuildInfo verbosity infoFile + +defaultTestHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> TestFlags -> IO () +defaultTestHook pkg_descr localbuildinfo _ flags = + test pkg_descr localbuildinfo flags + +defaultInstallHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> InstallFlags -> IO () +defaultInstallHook pkg_descr localbuildinfo _ flags = do + let copyFlags = defaultCopyFlags { + copyDistPref = installDistPref flags, + copyDest = toFlag NoCopyDest, + copyVerbosity = installVerbosity flags + } + install pkg_descr localbuildinfo copyFlags + let registerFlags = defaultRegisterFlags { + regDistPref = installDistPref flags, + regInPlace = installInPlace flags, + regPackageDB = installPackageDB flags, + regVerbosity = installVerbosity flags + } + when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags + +defaultBuildHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> BuildFlags -> IO () +defaultBuildHook pkg_descr localbuildinfo hooks flags = + build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) + +defaultRegHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> RegisterFlags -> IO () +defaultRegHook pkg_descr localbuildinfo _ flags = + if hasLibs pkg_descr + then register pkg_descr localbuildinfo flags + else setupMessage verbosity + "Package contains no library to register:" (packageId pkg_descr) + where verbosity = fromFlag (regVerbosity flags) diff --git a/cabal/cabal/Distribution/Simple/Build.hs b/cabal/cabal/Distribution/Simple/Build.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Build.hs @@ -0,0 +1,274 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Build +-- Copyright : Isaac Jones 2003-2005, +-- Ross Paterson 2006, +-- Duncan Coutts 2007-2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point to actually building the modules in a package. It +-- doesn't actually do much itself, most of the work is delegated to +-- compiler-specific actions. It does do some non-compiler specific bits like +-- running pre-processors. +-- + +{- 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, + + initialBuildSteps, + writeAutogenFiles, + ) where + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.JHC as JHC +import qualified Distribution.Simple.LHC as LHC +import qualified Distribution.Simple.NHC as NHC +import qualified Distribution.Simple.Hugs as Hugs +import qualified Distribution.Simple.UHC as UHC + +import qualified Distribution.Simple.Build.Macros as Build.Macros +import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule + +import Distribution.Package + ( Package(..), PackageName(..), PackageIdentifier(..) + , thisPackageVersion ) +import Distribution.Simple.Compiler + ( CompilerFlavor(..), compilerFlavor, PackageDB(..) ) +import Distribution.PackageDescription + ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..) + , TestSuite(..), TestSuiteInterface(..) ) +import qualified Distribution.InstalledPackageInfo as IPI +import qualified Distribution.ModuleName as ModuleName + +import Distribution.Simple.Setup + ( BuildFlags(..), fromFlag ) +import Distribution.Simple.PreProcess + ( preprocessComponent, PPSuffixHandler ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(compiler, buildDir, withPackageDB) + , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI + , inplacePackageId ) +import Distribution.Simple.BuildPaths + ( autogenModulesDir, autogenModuleName, cppHeaderName ) +import Distribution.Simple.Register + ( registerPackage, inplaceInstalledPackageInfo ) +import Distribution.Simple.Test ( stubFilePath, stubName ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, rewriteFile + , die, info, setupMessage ) + +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Text + ( display ) + +import Data.Maybe + ( maybeToList ) +import Control.Monad + ( unless ) +import System.FilePath + ( (), (<.>) ) +import System.Directory + ( getCurrentDirectory ) + +-- ----------------------------------------------------------------------------- +-- |Build the libraries and executables in this package. + +build :: PackageDescription -- ^ Mostly information from the .cabal file + -> LocalBuildInfo -- ^ Configuration information + -> BuildFlags -- ^ Flags that the user passed to build + -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling + -> IO () +build pkg_descr lbi flags suffixes = do + let distPref = fromFlag (buildDistPref flags) + verbosity = fromFlag (buildVerbosity flags) + initialBuildSteps distPref pkg_descr lbi verbosity + setupMessage verbosity "Building" (packageId pkg_descr) + + internalPackageDB <- createInternalPackageDB distPref + + let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes + lbi' = lbi {withPackageDB = withPackageDB lbi ++ [internalPackageDB]} + -- Use the internal package DB for the exes. + withComponentsLBI pkg_descr lbi $ \comp clbi -> do + pre comp + case comp of + CLib lib -> do + info verbosity "Building library..." + buildLib verbosity pkg_descr lbi lib clbi + + -- Register the library in-place, so exes can depend + -- on internally defined libraries. + pwd <- getCurrentDirectory + let installedPkgInfo = + (inplaceInstalledPackageInfo pwd distPref pkg_descr lib lbi clbi) { + -- The inplace registration uses the "-inplace" suffix, + -- not an ABI hash. + IPI.installedPackageId = inplacePackageId (packageId installedPkgInfo) + } + registerPackage verbosity + installedPkgInfo pkg_descr lbi True -- True meaning inplace + (withPackageDB lbi ++ [internalPackageDB]) + + CExe exe -> do + info verbosity $ "Building executable " ++ exeName exe ++ "..." + buildExe verbosity pkg_descr lbi' exe clbi + + CTest test -> do + case testInterface test of + TestSuiteExeV10 _ f -> do + let exe = Executable + { exeName = testName test + , modulePath = f + , buildInfo = testBuildInfo test + } + info verbosity $ "Building test suite " ++ testName test ++ "..." + buildExe verbosity pkg_descr lbi' exe clbi + TestSuiteLibV09 _ m -> do + pwd <- getCurrentDirectory + let lib = Library + { exposedModules = [ m ] + , libExposed = True + , libBuildInfo = testBuildInfo test + } + pkg = pkg_descr + { package = (package pkg_descr) + { pkgName = PackageName $ testName test + } + , buildDepends = targetBuildDepends $ testBuildInfo test + , executables = [] + , testSuites = [] + , library = Just lib + } + ipi = (inplaceInstalledPackageInfo + pwd distPref pkg lib lbi clbi) + { IPI.installedPackageId = inplacePackageId $ packageId ipi + } + testDir = buildDir lbi' stubName test + stubName test ++ "-tmp" + testLibDep = thisPackageVersion $ package pkg + exe = Executable + { exeName = stubName test + , modulePath = stubFilePath test + , buildInfo = (testBuildInfo test) + { hsSourceDirs = [ testDir ] + , targetBuildDepends = testLibDep + : (targetBuildDepends $ testBuildInfo test) + } + } + -- | The stub executable needs a new 'ComponentLocalBuildInfo' + -- that exposes the relevant test suite library. + exeClbi = clbi + { componentPackageDeps = + (IPI.installedPackageId ipi, packageId ipi) + : (filter (\(_, x) -> let PackageName name = pkgName x in name == "Cabal" || name == "base") + $ componentPackageDeps clbi) + } + info verbosity $ "Building test suite " ++ testName test ++ "..." + buildLib verbosity pkg lbi' lib clbi + registerPackage verbosity ipi pkg lbi' True $ withPackageDB lbi' + buildExe verbosity pkg_descr lbi' exe exeClbi + TestSuiteUnsupported tt -> die $ "No support for building test suite " + ++ "type " ++ display tt + +-- | Initialize a new package db file for libraries defined +-- internally to the package. +createInternalPackageDB :: FilePath -> IO PackageDB +createInternalPackageDB distPref = do + let dbFile = distPref "package.conf.inplace" + packageDB = SpecificPackageDB dbFile + writeFile dbFile "[]" + return packageDB + +-- TODO: build separate libs in separate dirs so that we can build +-- multiple libs, e.g. for 'LibTest' library-style testsuites +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.buildLib verbosity pkg_descr lbi lib clbi + JHC -> JHC.buildLib verbosity pkg_descr lbi lib clbi + LHC -> LHC.buildLib verbosity pkg_descr lbi lib clbi + Hugs -> Hugs.buildLib verbosity pkg_descr lbi lib clbi + NHC -> NHC.buildLib verbosity pkg_descr lbi lib clbi + UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi + _ -> die "Building is not supported with this compiler." + +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity pkg_descr lbi exe clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.buildExe verbosity pkg_descr lbi exe clbi + JHC -> JHC.buildExe verbosity pkg_descr lbi exe clbi + LHC -> LHC.buildExe verbosity pkg_descr lbi exe clbi + Hugs -> Hugs.buildExe verbosity pkg_descr lbi exe clbi + NHC -> NHC.buildExe verbosity pkg_descr lbi exe clbi + UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi + _ -> die "Building is not supported with this compiler." + +initialBuildSteps :: FilePath -- ^"dist" prefix + -> PackageDescription -- ^mostly information from the .cabal file + -> LocalBuildInfo -- ^Configuration information + -> Verbosity -- ^The verbosity to use + -> IO () +initialBuildSteps _distPref pkg_descr lbi verbosity = 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 = display (packageId pkg_descr) + die ("Package " ++ name ++ " can't be built on this system.") + + createDirectoryIfMissingVerbose verbosity True (buildDir lbi) + + writeAutogenFiles verbosity pkg_descr lbi + +-- | Generate and write out the Paths_.hs and cabal_macros.h files +-- +writeAutogenFiles :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> IO () +writeAutogenFiles verbosity pkg lbi = do + createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi) + + let pathsModulePath = autogenModulesDir lbi + ModuleName.toFilePath (autogenModuleName pkg) <.> "hs" + rewriteFile pathsModulePath (Build.PathsModule.generate pkg lbi) + + let cppHeaderPath = autogenModulesDir lbi cppHeaderName + rewriteFile cppHeaderPath (Build.Macros.generate pkg lbi) diff --git a/cabal/cabal/Distribution/Simple/Build/Macros.hs b/cabal/cabal/Distribution/Simple/Build/Macros.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Build/Macros.hs @@ -0,0 +1,57 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Build.Macros +-- Copyright : Simon Marlow 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Generate cabal_macros.h - CPP macros for package version testing +-- +-- When using CPP you get +-- +-- > VERSION_ +-- > MIN_VERSION_(A,B,C) +-- +-- for each /package/ in @build-depends@, which is true if the version of +-- /package/ in use is @>= A.B.C@, using the normal ordering on version +-- numbers. +-- +module Distribution.Simple.Build.Macros ( + generate + ) where + +import Distribution.Package + ( PackageIdentifier(PackageIdentifier) ) +import Distribution.Version + ( Version(versionBranch) ) +import Distribution.PackageDescription + ( PackageDescription ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo, externalPackageDeps ) +import Distribution.Text + ( display ) + +-- ------------------------------------------------------------ +-- * Generate cabal_macros.h +-- ------------------------------------------------------------ + +generate :: PackageDescription -> LocalBuildInfo -> String +generate _pkg_descr lbi = concat $ + "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" : + [ concat + ["/* package ",display pkgid," */\n" + ,"#define VERSION_",pkgname," ",show (display version),"\n" + ,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) (\\\n" + ," (major1) < ",major1," || \\\n" + ," (major1) == ",major1," && (major2) < ",major2," || \\\n" + ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" + ,"\n\n" + ] + | (_, pkgid@(PackageIdentifier name version)) <- externalPackageDeps lbi + , let (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) + pkgname = map fixchar (display name) + ] + where fixchar '-' = '_' + fixchar c = c + diff --git a/cabal/cabal/Distribution/Simple/Build/PathsModule.hs b/cabal/cabal/Distribution/Simple/Build/PathsModule.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Build/PathsModule.hs @@ -0,0 +1,258 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Build.Macros +-- Copyright : Isaac Jones 2003-2005, +-- Ross Paterson 2006, +-- Duncan Coutts 2007-2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Generating the Paths_pkgname module. +-- +-- This is a module that Cabal generates for the benefit of packages. It +-- enables them to find their version number and find any installed data files +-- at runtime. This code should probably be split off into another module. +-- +module Distribution.Simple.Build.PathsModule ( + generate, pkgPathEnvVar + ) where + +import Distribution.System + ( OS(Windows), buildOS ) +import Distribution.Simple.Compiler + ( CompilerFlavor(..), compilerFlavor, compilerVersion ) +import Distribution.Package + ( packageId, packageName, packageVersion ) +import Distribution.PackageDescription + ( PackageDescription(..), hasLibs ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), InstallDirs(..) + , absoluteInstallDirs, prefixRelativeInstallDirs ) +import Distribution.Simple.Setup ( CopyDest(NoCopyDest) ) +import Distribution.Simple.BuildPaths + ( autogenModuleName ) +import Distribution.Text + ( display ) +import Distribution.Version + ( Version(..), orLaterVersion, withinRange ) + +import System.FilePath + ( pathSeparator ) +import Data.Maybe + ( fromJust, isNothing ) + +-- ------------------------------------------------------------ +-- * Building Paths_.hs +-- ------------------------------------------------------------ + +generate :: PackageDescription -> LocalBuildInfo -> String +generate pkg_descr lbi = + let pragmas + | absolute || isHugs = "" + | supports_language_pragma = + "{-# LANGUAGE ForeignFunctionInterface #-}\n" + | otherwise = + "{-# OPTIONS_GHC -fffi #-}\n"++ + "{-# OPTIONS_JHC -fffi #-}\n" + + foreign_imports + | absolute = "" + | isHugs = "import System.Environment\n" + | otherwise = + "import Foreign\n"++ + "import Foreign.C\n" + + header = + pragmas++ + "module " ++ display paths_modulename ++ " (\n"++ + " version,\n"++ + " getBinDir, getLibDir, getDataDir, getLibexecDir,\n"++ + " getDataFileName\n"++ + " ) where\n"++ + "\n"++ + foreign_imports++ + "import qualified Control.Exception as Exception\n"++ + "import Data.Version (Version(..))\n"++ + "import System.Environment (getEnv)"++ + "\n"++ + "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++ + "catchIO = Exception.catch\n" ++ + "\n"++ + "\nversion :: Version"++ + "\nversion = " ++ show (packageVersion pkg_descr) + + body + | absolute = + "\nbindir, libdir, datadir, libexecdir :: FilePath\n"++ + "\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 = "++mkGetEnvOr "bindir" "return bindir"++"\n"++ + "getLibDir = "++mkGetEnvOr "libdir" "return libdir"++"\n"++ + "getDataDir = "++mkGetEnvOr "datadir" "return datadir"++"\n"++ + "getLibexecDir = "++mkGetEnvOr "libexecdir" "return libexecdir"++"\n"++ + "\n"++ + "getDataFileName :: FilePath -> IO FilePath\n"++ + "getDataFileName name = do\n"++ + " dir <- getDataDir\n"++ + " return (dir ++ "++path_sep++" ++ name)\n" + | otherwise = + "\nprefix, bindirrel :: FilePath" ++ + "\nprefix = " ++ show flat_prefix ++ + "\nbindirrel = " ++ show (fromJust flat_bindirrel) ++ + "\n\n"++ + "getBinDir :: 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 = "++ mkGetEnvOr "datadir" + (mkGetDir flat_datadir flat_datadirrel)++"\n\n"++ + "getLibexecDir :: IO FilePath\n"++ + "getLibexecDir = "++mkGetDir flat_libexecdir flat_libexecdirrel++"\n\n"++ + "getDataFileName :: FilePath -> IO FilePath\n"++ + "getDataFileName name = do\n"++ + " dir <- getDataDir\n"++ + " return (dir `joinFileName` name)\n"++ + "\n"++ + get_prefix_stuff++ + "\n"++ + filename_stuff + in header++body + + where + InstallDirs { + prefix = flat_prefix, + bindir = flat_bindir, + libdir = flat_libdir, + datadir = flat_datadir, + libexecdir = flat_libexecdir + } = absoluteInstallDirs pkg_descr lbi NoCopyDest + InstallDirs { + bindir = flat_bindirrel, + libdir = flat_libdirrel, + datadir = flat_datadirrel, + libexecdir = flat_libexecdirrel, + progdir = flat_progdirrel + } = prefixRelativeInstallDirs (packageId pkg_descr) lbi + + mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel + mkGetDir dir Nothing = "return " ++ show dir + + mkGetEnvOr var expr = "catchIO (getEnv \""++var'++"\")"++ + " (\\_ -> "++expr++")" + where var' = pkgPathEnvVar pkg_descr var + + -- In several cases we cannot make relocatable installations + absolute = + hasLibs pkg_descr -- we can only make progs relocatable + || isNothing flat_bindirrel -- if the bin dir is an absolute path + || (isHugs && isNothing flat_progdirrel) + || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) + + supportsRelocatableProgs Hugs = True + supportsRelocatableProgs GHC = case buildOS of + Windows -> True + _ -> False + supportsRelocatableProgs _ = False + + paths_modulename = autogenModuleName pkg_descr + + isHugs = compilerFlavor (compiler lbi) == Hugs + get_prefix_stuff + | isHugs = "progdirrel :: String\n"++ + "progdirrel = "++show (fromJust flat_progdirrel)++"\n\n"++ + get_prefix_hugs + | otherwise = get_prefix_win32 + + path_sep = show [pathSeparator] + + supports_language_pragma = + compilerFlavor (compiler lbi) == GHC && + (compilerVersion (compiler lbi) + `withinRange` orLaterVersion (Version [6,6,1] [])) + +-- | Generates the name of the environment variable controlling the path +-- component of interest. +pkgPathEnvVar :: PackageDescription + -> String -- ^ path component; one of \"bindir\", \"libdir\", + -- \"datadir\" or \"libexecdir\" + -> String -- ^ environment variable name +pkgPathEnvVar pkg_descr var = + showPkgName (packageName pkg_descr) ++ "_" ++ var + where + showPkgName = map fixchar . display + fixchar '-' = '_' + fixchar c = c + +get_prefix_win32 :: String +get_prefix_win32 = + "getPrefixDirRel :: FilePath -> IO FilePath\n"++ + "getPrefixDirRel dirRel = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.\n"++ + " where\n"++ + " try_size size = allocaArray (fromIntegral size) $ \\buf -> do\n"++ + " ret <- c_GetModuleFileName nullPtr buf size\n"++ + " case ret of\n"++ + " 0 -> return (prefix `joinFileName` dirRel)\n"++ + " _ | ret < size -> do\n"++ + " exePath <- peekCWString buf\n"++ + " let (bindir,_) = splitFileName exePath\n"++ + " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"++ + " | otherwise -> try_size (size * 2)\n"++ + "\n"++ + "foreign import stdcall unsafe \"windows.h GetModuleFileNameW\"\n"++ + " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" + + +get_prefix_hugs :: String +get_prefix_hugs = + "getPrefixDirRel :: FilePath -> IO FilePath\n"++ + "getPrefixDirRel dirRel = do\n"++ + " mainPath <- getProgName\n"++ + " let (progPath,_) = splitFileName mainPath\n"++ + " let (progdir,_) = splitFileName progPath\n"++ + " return ((progdir `minusFileName` progdirrel) `joinFileName` dirRel)\n" + +filename_stuff :: String +filename_stuff = + "minusFileName :: FilePath -> String -> FilePath\n"++ + "minusFileName dir \"\" = dir\n"++ + "minusFileName dir \".\" = dir\n"++ + "minusFileName dir suffix =\n"++ + " minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n"++ + "\n"++ + "joinFileName :: String -> String -> FilePath\n"++ + "joinFileName \"\" fname = fname\n"++ + "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 :: FilePath -> (String, String)\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"++ + (case buildOS of + Windows -> "pathSeparator = '\\\\'\n" + _ -> "pathSeparator = '/'\n") ++ + "\n"++ + "isPathSeparator :: Char -> Bool\n"++ + (case buildOS of + Windows -> "isPathSeparator c = c == '/' || c == '\\\\'\n" + _ -> "isPathSeparator c = c == '/'\n") diff --git a/cabal/cabal/Distribution/Simple/BuildPaths.hs b/cabal/cabal/Distribution/Simple/BuildPaths.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/BuildPaths.hs @@ -0,0 +1,150 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.BuildPaths +-- Copyright : Isaac Jones 2003-2004, +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A bunch of dirs, paths and file names used for intermediate build steps. +-- + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.BuildPaths ( + defaultDistPref, srcPref, + hscolourPref, haddockPref, + autogenModulesDir, + + autogenModuleName, + cppHeaderName, + haddockName, + + mkLibName, + mkProfLibName, + mkSharedLibName, + + exeExtension, + objExtension, + dllExtension, + + ) where + + +import System.FilePath ((), (<.>)) + +import Distribution.Package + ( PackageIdentifier, packageName ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Compiler + ( CompilerId(..) ) +import Distribution.PackageDescription (PackageDescription) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(buildDir)) +import Distribution.Simple.Setup (defaultDistPref) +import Distribution.Text + ( display ) +import Distribution.System (OS(..), buildOS) + +-- --------------------------------------------------------------------------- +-- Build directories and files + +srcPref :: FilePath -> FilePath +srcPref distPref = distPref "src" + +hscolourPref :: FilePath -> PackageDescription -> FilePath +hscolourPref = haddockPref + +haddockPref :: FilePath -> PackageDescription -> FilePath +haddockPref distPref pkg_descr + = distPref "doc" "html" display (packageName pkg_descr) + +-- |The directory in which we put auto-generated modules +autogenModulesDir :: LocalBuildInfo -> String +autogenModulesDir lbi = buildDir lbi "autogen" + +cppHeaderName :: String +cppHeaderName = "cabal_macros.h" + +-- |The name of the auto-generated module associated with a package +autogenModuleName :: PackageDescription -> ModuleName +autogenModuleName pkg_descr = + ModuleName.fromString $ + "Paths_" ++ map fixchar (display (packageName pkg_descr)) + where fixchar '-' = '_' + fixchar c = c + +haddockName :: PackageDescription -> FilePath +haddockName pkg_descr = display (packageName pkg_descr) <.> "haddock" + +-- --------------------------------------------------------------------------- +-- Library file names + +mkLibName :: PackageIdentifier -> String +mkLibName lib = "libHS" ++ display lib <.> "a" + +mkProfLibName :: PackageIdentifier -> String +mkProfLibName lib = "libHS" ++ display lib ++ "_p" <.> "a" + +-- Implement proper name mangling for dynamical shared objects +-- libHS- +-- e.g. libHSbase-2.1-ghc6.6.1.so +mkSharedLibName :: PackageIdentifier -> CompilerId -> String +mkSharedLibName lib (CompilerId compilerFlavor compilerVersion) + = "libHS" ++ display lib ++ "-" ++ comp <.> dllExtension + where comp = display compilerFlavor ++ display compilerVersion + +-- ------------------------------------------------------------ +-- * Platform file extensions +-- ------------------------------------------------------------ + +-- ToDo: This should be determined via autoconf (AC_EXEEXT) +-- | Extension for executable files +-- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2) +exeExtension :: String +exeExtension = case buildOS of + Windows -> "exe" + _ -> "" + +-- ToDo: This should be determined via autoconf (AC_OBJEXT) +-- | Extension for object files. For GHC and NHC the extension is @\"o\"@. +-- Hugs uses either @\"o\"@ or @\"obj\"@ depending on the used C compiler. +objExtension :: String +objExtension = "o" + +-- | Extension for dynamically linked (or shared) libraries +-- (typically @\"so\"@ on Unix and @\"dll\"@ on Windows) +dllExtension :: String +dllExtension = case buildOS of + Windows -> "dll" + OSX -> "dylib" + _ -> "so" diff --git a/cabal/cabal/Distribution/Simple/Command.hs b/cabal/cabal/Distribution/Simple/Command.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Command.hs @@ -0,0 +1,545 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Command +-- Copyright : Duncan Coutts 2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is to do with command line handling. The Cabal command line is +-- organised into a number of named sub-commands (much like darcs). The +-- 'CommandUI' abstraction represents one of these sub-commands, with a name, +-- description, a set of flags. Commands can be associated with actions and +-- run. It handles some common stuff automatically, like the @--help@ and +-- command line completion flags. It is designed to allow other tools make +-- derived commands. This feature is used heavily in @cabal-install@. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.Command ( + + -- * Command interface + CommandUI(..), + commandShowOptions, + CommandParse(..), + commandParseArgs, + + -- ** Constructing commands + ShowOrParseArgs(..), + makeCommand, + + -- ** Associating actions with commands + Command, + commandAddAction, + noExtraFlags, + + -- ** Running commands + commandsRun, + +-- * Option Fields + OptionField(..), Name, + +-- ** Constructing Option Fields + option, multiOption, + +-- ** Liftings & Projections + liftOption, viewAsFieldDescr, + +-- * Option Descriptions + OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder, + +-- ** OptDescr 'smart' constructors + MkOptDescr, + reqArg, reqArg', optArg, optArg', noArg, + boolOpt, boolOpt', choiceOpt, choiceOptFromEnum + + ) where + +import Control.Monad +import Data.Char (isAlpha, toLower) +import Data.List (sortBy) +import Data.Maybe +import Data.Monoid +import qualified Distribution.GetOpt as GetOpt +import Distribution.Text + ( Text(disp, parse) ) +import Distribution.ParseUtils +import Distribution.ReadE +import Distribution.Simple.Utils (die, intercalate) +import Text.PrettyPrint.HughesPJ ( punctuate, cat, comma, text, empty) + +data CommandUI flags = CommandUI { + -- | The name of the command as it would be entered on the command line. + -- For example @\"build\"@. + commandName :: String, + -- | A short, one line description of the command to use in help texts. + commandSynopsis :: String, + -- | The useage line summary for this command + commandUsage :: String -> String, + -- | Additional explanation of the command to use in help texts. + commandDescription :: Maybe (String -> String), + -- | Initial \/ empty flags + commandDefaultFlags :: flags, + -- | All the Option fields for this command + commandOptions :: ShowOrParseArgs -> [OptionField flags] + } + +data ShowOrParseArgs = ShowArgs | ParseArgs + +type Name = String +type Description = String + +-- | We usually have a datatype for storing configuration values, where +-- every field stores a configuration option, and the user sets +-- the value either via command line flags or a configuration file. +-- An individual OptionField models such a field, and we usually +-- build a list of options associated to a configuration datatype. +data OptionField a = OptionField { + optionName :: Name, + optionDescr :: [OptDescr a] } + +-- | An OptionField takes one or more OptDescrs, describing the command line interface for the field. +data OptDescr a = ReqArg Description OptFlags ArgPlaceHolder (ReadE (a->a)) (a -> [String]) + | OptArg Description OptFlags ArgPlaceHolder (ReadE (a->a)) (a->a) (a -> [Maybe String]) + | ChoiceOpt [(Description, OptFlags, a->a, a -> Bool)] + | BoolOpt Description OptFlags{-True-} OptFlags{-False-} (Bool -> a -> a) (a-> Maybe Bool) + +-- | Short command line option strings +type SFlags = [Char] +-- | Long command line option strings +type LFlags = [String] +type OptFlags = (SFlags,LFlags) +type ArgPlaceHolder = String + + +-- | Create an option taking a single OptDescr. +-- No explicit Name is given for the Option, the name is the first LFlag given. +option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a -> OptionField a +option sf lf@(n:_) d get set arg = OptionField n [arg sf lf d get set] +option _ _ _ _ _ _ = error "Distribution.command.option: An OptionField must have at least one LFlag" + +-- | Create an option taking several OptDescrs. +-- You will have to give the flags and description individually to the OptDescr constructor. +multiOption :: Name -> get -> set + -> [get -> set -> OptDescr a] -- ^MkOptDescr constructors partially applied to flags and description. + -> OptionField a +multiOption n get set args = OptionField n [arg get set | arg <- args] + +type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set -> OptDescr a + +-- | Create a string-valued command line interface. +reqArg :: Monoid b => ArgPlaceHolder -> ReadE b -> (b -> [String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +reqArg ad mkflag showflag sf lf d get set = + ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) (showflag . get) + +-- | Create a string-valued command line interface with a default value. +optArg :: Monoid b => ArgPlaceHolder -> ReadE b -> b -> (b -> [Maybe String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +optArg ad mkflag def showflag sf lf d get set = + OptArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) + (\b -> set (get b `mappend` def) b) + (showflag . get) + +-- | (String -> a) variant of "reqArg" +reqArg' :: Monoid b => ArgPlaceHolder -> (String -> b) -> (b -> [String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +reqArg' ad mkflag showflag = + reqArg ad (succeedReadE mkflag) showflag + +-- | (String -> a) variant of "optArg" +optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b) -> (b -> [Maybe String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +optArg' ad mkflag showflag = + optArg ad (succeedReadE (mkflag . Just)) def showflag + where def = mkflag Nothing + +noArg :: (Eq b, Monoid b) => b -> MkOptDescr (a -> b) (b -> a -> a) a +noArg flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d + +boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags -> MkOptDescr (a -> b) (b -> a -> a) a +boolOpt g s sfT sfF _sf _lf@(n:_) d get set = + BoolOpt d (sfT, ["enable-"++n]) (sfF, ["disable-"++n]) (set.s) (g.get) +boolOpt _ _ _ _ _ _ _ _ _ = error "Distribution.Simple.Setup.boolOpt: unreachable" + +boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags -> MkOptDescr (a -> b) (b -> a -> a) a +boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set.s) (g . get) + +-- | create a Choice option +choiceOpt :: Eq b => [(b,OptFlags,Description)] -> MkOptDescr (a -> b) (b -> a -> a) a +choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts + where alts = [(d,flags, set alt, (==alt) . get) | (alt,flags,d) <- aa_ff] + +-- | create a Choice option out of an enumeration type. +-- As long flags, the Show output is used. As short flags, the first character +-- which does not conflict with a previous one is used. +choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) => MkOptDescr (a -> b) (b -> a -> a) a +choiceOptFromEnum _sf _lf d get = choiceOpt [ (x, (sf, [map toLower $ show x]), d') + | (x, sf) <- sflags' + , let d' = d ++ show x] + _sf _lf d get + where sflags' = foldl f [] [firstOne..] + f prev x = let prevflags = concatMap snd prev in + prev ++ take 1 [(x, [toLower sf]) | sf <- show x, isAlpha sf + , toLower sf `notElem` prevflags] + firstOne = minBound `asTypeOf` get undefined + +commandGetOpts :: ShowOrParseArgs -> CommandUI flags -> [GetOpt.OptDescr (flags -> flags)] +commandGetOpts showOrParse command = + concatMap viewAsGetOpt (commandOptions command showOrParse) + +viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a->a)] +viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa + where + optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) = + [GetOpt.Option cs ss (GetOpt.ReqArg set' arg_desc) d] + where set' = readEOrFail set + optDescrToGetOpt (OptArg d (cs,ss) arg_desc set def _) = + [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d] + where set' Nothing = def + set' (Just txt) = readEOrFail set txt + optDescrToGetOpt (ChoiceOpt alts) = + [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ] + optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set _) = + [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d) + , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ] + +-- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool > Choice > Opt) and consider only the first one. +viewAsFieldDescr :: OptionField a -> FieldDescr a +viewAsFieldDescr (OptionField _n []) = error "Distribution.command.viewAsFieldDescr: unexpected" +viewAsFieldDescr (OptionField n dd) = FieldDescr n get set + where optDescr = head $ sortBy cmp dd + ReqArg{} `cmp` ReqArg{} = EQ + ReqArg{} `cmp` _ = GT + BoolOpt{} `cmp` ReqArg{} = LT + BoolOpt{} `cmp` BoolOpt{} = EQ + BoolOpt{} `cmp` _ = GT + ChoiceOpt{} `cmp` ReqArg{} = LT + ChoiceOpt{} `cmp` BoolOpt{} = LT + ChoiceOpt{} `cmp` ChoiceOpt{} = EQ + ChoiceOpt{} `cmp` _ = GT + OptArg{} `cmp` OptArg{} = EQ + OptArg{} `cmp` _ = LT + get t = case optDescr of + ReqArg _ _ _ _ ppr -> + (cat . punctuate comma . map text . ppr) t + OptArg _ _ _ _ _ ppr -> + case ppr t of + [] -> empty + (Nothing : _) -> text "True" + (Just a : _) -> text a + ChoiceOpt alts -> + fromMaybe empty $ listToMaybe + [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t] + BoolOpt _ _ _ _ enabled -> (maybe empty disp . enabled) t + set line val a = + case optDescr of + ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val + -- We parse for a single value instead of a list, + -- as one can't really implement parseList :: ReadE a -> ReadE [a] + -- with the current ReadE definition + ChoiceOpt{} -> case getChoiceByLongFlag optDescr val of + Just f -> return (f a) + _ -> syntaxError line val + BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runP line n parse val + OptArg _ _ _ _readE _ _ -> -- The behaviour in this case is not clear, and it has no use so far, + -- so we avoid future surprises by not implementing it. + error "Command.optionToFieldDescr: feature not implemented" + +getChoiceByLongFlag :: OptDescr b -> String -> Maybe (b->b) +getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe [ set | (_,(_sf,lf:_), set, _) <- alts + , lf == val] + +getChoiceByLongFlag _ _ = error "Distribution.command.getChoiceByLongFlag: expected a choice option" + +getCurrentChoice :: OptDescr a -> a -> [String] +getCurrentChoice (ChoiceOpt alts) a = + [ lf | (_,(_sf,lf:_), _, currentChoice) <- alts, currentChoice a] + +getCurrentChoice _ _ = error "Command.getChoice: expected a Choice OptDescr" + + +liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b +liftOption get' set' opt = opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt} + + +liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b +liftOptDescr get' set' (ChoiceOpt opts) = + ChoiceOpt [ (d, ff, liftSet get' set' set , (get . get')) + | (d, ff, set, get) <- opts] + +liftOptDescr get' set' (OptArg d ff ad set def get) = + OptArg d ff ad (liftSet get' set' `fmap` set) (liftSet get' set' def) (get . get') + +liftOptDescr get' set' (ReqArg d ff ad set get) = + ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get') + +liftOptDescr get' set' (BoolOpt d ffT ffF set get) = + BoolOpt d ffT ffF (liftSet get' set' . set) (get . get') + +liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b +liftSet get' set' set x = set' (set $ get' x) x + +-- | Show flags in the standard long option command line format +commandShowOptions :: CommandUI flags -> flags -> [String] +commandShowOptions command v = concat + [ showOptDescr v od | o <- commandOptions command ParseArgs + , od <- optionDescr o] + where + showOptDescr :: a -> OptDescr a -> [String] + showOptDescr x (BoolOpt _ (_,lfT:_) (_,lfF:_) _ enabled) + = case enabled x of + Nothing -> [] + Just True -> ["--" ++ lfT] + Just False -> ["--" ++ lfF] + showOptDescr x c@ChoiceOpt{} + = ["--" ++ val | val <- getCurrentChoice c x] + showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag) + = [ "--"++lf++"="++flag + | flag <- showflag x ] + showOptDescr x (OptArg _ (_ssff,lf:_) _ _ _ showflag) + = [ case flag of + Just s -> "--"++lf++"="++s + Nothing -> "--"++lf + | flag <- showflag x ] + showOptDescr _ _ + = error "Distribution.Simple.Command.showOptDescr: unreachable" + + +commandListOptions :: CommandUI flags -> [String] +commandListOptions command = + concatMap listOption $ + addCommonFlags ShowArgs $ -- This is a slight hack, we don't want + -- "--list-options" showing up in the + -- list options output, so use ShowArgs + commandGetOpts ShowArgs command + where + listOption (GetOpt.Option shortNames longNames _ _) = + [ "-" ++ [name] | name <- shortNames ] + ++ [ "--" ++ name | name <- longNames ] + +-- | The help text for this command with descriptions of all the options. +commandHelp :: CommandUI flags -> String -> String +commandHelp command pname = + commandUsage command pname + ++ (GetOpt.usageInfo "" + . addCommonFlags ShowArgs + $ commandGetOpts ShowArgs command) + ++ case commandDescription command of + Nothing -> "" + Just desc -> '\n': desc pname + +-- | Make a Command from standard 'GetOpt' options. +makeCommand :: String -- ^ name + -> String -- ^ short description + -> Maybe (String -> String) -- ^ long description + -> flags -- ^ initial\/empty flags + -> (ShowOrParseArgs -> [OptionField flags]) -- ^ options + -> CommandUI flags +makeCommand name shortDesc longDesc defaultFlags options = + CommandUI { + commandName = name, + commandSynopsis = shortDesc, + commandDescription = longDesc, + commandUsage = usage, + commandDefaultFlags = defaultFlags, + commandOptions = options + } + where usage pname = "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n" + ++ "Flags for " ++ name ++ ":" + +-- | Common flags that apply to every command +data CommonFlag = HelpFlag | ListOptionsFlag + +commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag] +commonFlags showOrParseArgs = case showOrParseArgs of + ShowArgs -> [help] + ParseArgs -> [help, list] + where + help = GetOpt.Option helpShortFlags ["help"] (GetOpt.NoArg HelpFlag) + "Show this help text" + helpShortFlags = case showOrParseArgs of + ShowArgs -> ['h'] + ParseArgs -> ['h', '?'] + list = GetOpt.Option [] ["list-options"] (GetOpt.NoArg ListOptionsFlag) + "Print a list of command line flags" + +addCommonFlags :: ShowOrParseArgs + -> [GetOpt.OptDescr a] + -> [GetOpt.OptDescr (Either CommonFlag a)] +addCommonFlags showOrParseArgs options = + map (fmapOptDesc Left) (commonFlags showOrParseArgs) + ++ map (fmapOptDesc Right) options + where fmapOptDesc f (GetOpt.Option s l d m) = + GetOpt.Option s l (fmapArgDesc f d) m + fmapArgDesc f (GetOpt.NoArg a) = GetOpt.NoArg (f a) + fmapArgDesc f (GetOpt.ReqArg s d) = GetOpt.ReqArg (f . s) d + fmapArgDesc f (GetOpt.OptArg s d) = GetOpt.OptArg (f . s) d + +-- | Parse a bunch of command line arguments +-- +commandParseArgs :: CommandUI flags + -> Bool -- ^ Is the command a global or subcommand? + -> [String] + -> CommandParse (flags -> flags, [String]) +commandParseArgs command global args = + let options = addCommonFlags ParseArgs + $ commandGetOpts ParseArgs command + order | global = GetOpt.RequireOrder + | otherwise = GetOpt.Permute + in case GetOpt.getOpt' order options args of + (flags, _, _, _) + | any listFlag flags -> CommandList (commandListOptions command) + | any helpFlag flags -> CommandHelp (commandHelp command) + where listFlag (Left ListOptionsFlag) = True; listFlag _ = False + helpFlag (Left HelpFlag) = True; helpFlag _ = False + (flags, opts, opts', []) + | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts') + | otherwise -> CommandErrors (unrecognised opts') + (_, _, _, errs) -> CommandErrors errs + + where -- Note: It is crucial to use reverse function composition here or to + -- reverse the flags here as we want to process the flags left to right + -- but data flow in function compsition is right to left. + accum flags = foldr (flip (.)) id [ f | Right f <- flags ] + unrecognised opts = [ "unrecognized option `" ++ opt ++ "'\n" + | opt <- opts ] + -- For unrecognised global flags we put them in the position just after + -- the command, if there is one. This gives us a chance to parse them + -- as sub-command rather than global flags. + mix [] ys = ys + mix (x:xs) ys = x:ys++xs + +data CommandParse flags = CommandHelp (String -> String) + | CommandList [String] + | CommandErrors [String] + | CommandReadyToGo flags +instance Functor CommandParse where + fmap _ (CommandHelp help) = CommandHelp help + fmap _ (CommandList opts) = CommandList opts + fmap _ (CommandErrors errs) = CommandErrors errs + fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags) + + +data Command action = Command String String ([String] -> CommandParse action) + +commandAddAction :: CommandUI flags + -> (flags -> [String] -> action) + -> Command action +commandAddAction command action = + Command (commandName command) + (commandSynopsis command) + (fmap (uncurry applyDefaultArgs) + . commandParseArgs command False) + + where applyDefaultArgs mkflags args = + let flags = mkflags (commandDefaultFlags command) + in action flags args + +commandsRun :: CommandUI a + -> [Command action] + -> [String] + -> CommandParse (a, CommandParse action) +commandsRun globalCommand commands args = + case commandParseArgs globalCommand' True args of + CommandHelp help -> CommandHelp help + CommandList opts -> CommandList (opts ++ commandNames) + CommandErrors errs -> CommandErrors errs + CommandReadyToGo (mkflags, args') -> case args' of + ("help":cmdArgs) -> handleHelpCommand cmdArgs + (name:cmdArgs) -> case lookupCommand name of + [Command _ _ action] -> CommandReadyToGo (flags, action cmdArgs) + _ -> CommandReadyToGo (flags, badCommand name) + [] -> CommandReadyToGo (flags, noCommand) + where flags = mkflags (commandDefaultFlags globalCommand) + + where + lookupCommand cname = [ cmd | cmd@(Command cname' _ _) <- commands' + , cname'==cname ] + noCommand = CommandErrors ["no command given (try --help)\n"] + badCommand cname = CommandErrors ["unrecognised command: " ++ cname + ++ " (try --help)\n"] + commands' = commands ++ [commandAddAction helpCommandUI undefined] + commandNames = [ name | Command name _ _ <- commands' ] + globalCommand' = globalCommand { + commandUsage = \pname -> + (case commandUsage globalCommand pname of + "" -> "" + original -> original ++ "\n") + ++ "Usage: " ++ pname ++ " COMMAND [FLAGS]\n" + ++ " or: " ++ pname ++ " [GLOBAL FLAGS]\n\n" + ++ "Global flags:", + commandDescription = Just $ \pname -> + "Commands:\n" + ++ unlines [ " " ++ align name ++ " " ++ description + | Command name description _ <- commands' ] + ++ case commandDescription globalCommand of + Nothing -> "" + Just desc -> '\n': desc pname + } + where maxlen = maximum [ length name | Command name _ _ <- commands' ] + align str = str ++ replicate (maxlen - length str) ' ' + + -- A bit of a hack: support "prog help" as a synonym of "prog --help" + -- furthermore, support "prog help command" as "prog command --help" + handleHelpCommand cmdArgs = + case commandParseArgs helpCommandUI True cmdArgs of + CommandHelp help -> CommandHelp help + CommandList list -> CommandList (list ++ commandNames) + CommandErrors _ -> CommandHelp globalHelp + CommandReadyToGo (_,[]) -> CommandHelp globalHelp + CommandReadyToGo (_,(name:cmdArgs')) -> + case lookupCommand name of + [Command _ _ action] -> + case action ("--help":cmdArgs') of + CommandHelp help -> CommandHelp help + CommandList _ -> CommandList [] + _ -> CommandHelp globalHelp + _ -> badCommand name + + where globalHelp = commandHelp globalCommand' + helpCommandUI = + (makeCommand "help" "Help about commands" Nothing () (const [])) { + commandUsage = \pname -> + "Usage: " ++ pname ++ " help [FLAGS]\n" + ++ " or: " ++ pname ++ " help COMMAND [FLAGS]\n\n" + ++ "Flags for help:" + } + +-- | Utility function, many commands do not accept additional flags. This +-- action fails with a helpful error message if the user supplies any extra. +-- +noExtraFlags :: [String] -> IO () +noExtraFlags [] = return () +noExtraFlags extraFlags = + die $ "Unrecognised flags: " ++ intercalate ", " extraFlags +--TODO: eliminate this function and turn it into a variant on commandAddAction +-- instead like commandAddActionNoArgs that doesn't supply the [String] diff --git a/cabal/cabal/Distribution/Simple/Compiler.hs b/cabal/cabal/Distribution/Simple/Compiler.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Compiler.hs @@ -0,0 +1,194 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Compiler +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This should be a much more sophisticated abstraction than it is. Currently +-- it's just a bit of data about the compiler, like it's flavour and name and +-- version. The reason it's just data is because currently it has to be in +-- 'Read' and 'Show' so it can be saved along with the 'LocalBuildInfo'. The +-- only interesting bit of info it contains is a mapping between language +-- extensions and compiler command line flags. This module also defines a +-- 'PackageDB' type which is used to refer to package databases. Most compilers +-- only know about a single global package collection but GHC has a global and +-- per-user one and it lets you create arbitrary other package databases. We do +-- not yet fully support this latter feature. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.Compiler ( + -- * Haskell implementations + module Distribution.Compiler, + Compiler(..), + showCompilerId, compilerFlavor, compilerVersion, + + -- * Support for package databases + PackageDB(..), + PackageDBStack, + registrationPackageDB, + + -- * Support for optimisation levels + OptimisationLevel(..), + flagToOptimisationLevel, + + -- * Support for language extensions + Flag, + languageToFlags, + unsupportedLanguages, + extensionsToFlags, + unsupportedExtensions + ) where + +import Distribution.Compiler +import Distribution.Version (Version(..)) +import Distribution.Text (display) +import Language.Haskell.Extension (Language(Haskell98), Extension) + +import Data.List (nub) +import Data.Maybe (catMaybes, isNothing) + +data Compiler = Compiler { + compilerId :: CompilerId, + compilerLanguages :: [(Language, Flag)], + compilerExtensions :: [(Extension, Flag)] + } + deriving (Show, Read) + +showCompilerId :: Compiler -> String +showCompilerId = display . compilerId + +compilerFlavor :: Compiler -> CompilerFlavor +compilerFlavor = (\(CompilerId f _) -> f) . compilerId + +compilerVersion :: Compiler -> Version +compilerVersion = (\(CompilerId _ v) -> v) . compilerId + +-- ------------------------------------------------------------ +-- * Package databases +-- ------------------------------------------------------------ + +-- |Some compilers have a notion of a database of available packages. +-- For some there is just one global db of packages, other compilers +-- support a per-user or an arbitrary db specified at some location in +-- the file system. This can be used to build isloated environments of +-- packages, for example to build a collection of related packages +-- without installing them globally. +-- +data PackageDB = GlobalPackageDB + | UserPackageDB + | SpecificPackageDB FilePath + deriving (Eq, Ord, Show, Read) + +-- | We typically get packages from several databases, and stack them +-- together. This type lets us be explicit about that stacking. For example +-- typical stacks include: +-- +-- > [GlobalPackageDB] +-- > [GlobalPackageDB, UserPackageDB] +-- > [GlobalPackageDB, SpecificPackageDB "package.conf.inplace"] +-- +-- Note that the 'GlobalPackageDB' is invariably at the bottom since it +-- contains the rts, base and other special compiler-specific packages. +-- +-- We are not restricted to using just the above combinations. In particular +-- we can use several custom package dbs and the user package db together. +-- +-- When it comes to writing, the top most (last) package is used. +-- +type PackageDBStack = [PackageDB] + +-- | Return the package that we should register into. This is the package db at +-- the top of the stack. +-- +registrationPackageDB :: PackageDBStack -> PackageDB +registrationPackageDB [] = error "internal error: empty package db set" +registrationPackageDB dbs = last dbs + +-- ------------------------------------------------------------ +-- * Optimisation levels +-- ------------------------------------------------------------ + +-- | Some compilers support optimising. Some have different levels. +-- For compliers that do not the level is just capped to the level +-- they do support. +-- +data OptimisationLevel = NoOptimisation + | NormalOptimisation + | MaximumOptimisation + deriving (Eq, Show, Read, Enum, Bounded) + +flagToOptimisationLevel :: Maybe String -> OptimisationLevel +flagToOptimisationLevel Nothing = NormalOptimisation +flagToOptimisationLevel (Just s) = case reads s of + [(i, "")] + | i >= fromEnum (minBound :: OptimisationLevel) + && i <= fromEnum (maxBound :: OptimisationLevel) + -> toEnum i + | otherwise -> error $ "Bad optimisation level: " ++ show i + ++ ". Valid values are 0..2" + _ -> error $ "Can't parse optimisation level " ++ s + +-- ------------------------------------------------------------ +-- * Languages and Extensions +-- ------------------------------------------------------------ + +unsupportedLanguages :: Compiler -> [Language] -> [Language] +unsupportedLanguages comp langs = + [ lang | lang <- langs + , isNothing (languageToFlag comp lang) ] + +languageToFlags :: Compiler -> Maybe Language -> [Flag] +languageToFlags comp = filter (not . null) + . catMaybes . map (languageToFlag comp) + . maybe [Haskell98] (\x->[x]) + +languageToFlag :: Compiler -> Language -> Maybe Flag +languageToFlag comp ext = lookup ext (compilerLanguages comp) + + +-- |For the given compiler, return the extensions it does not support. +unsupportedExtensions :: Compiler -> [Extension] -> [Extension] +unsupportedExtensions comp exts = + [ ext | ext <- exts + , isNothing (extensionToFlag comp ext) ] + +type Flag = String + +-- |For the given compiler, return the flags for the supported extensions. +extensionsToFlags :: Compiler -> [Extension] -> [Flag] +extensionsToFlags comp = nub . filter (not . null) + . catMaybes . map (extensionToFlag comp) + +extensionToFlag :: Compiler -> Extension -> Maybe Flag +extensionToFlag comp ext = lookup ext (compilerExtensions comp) diff --git a/cabal/cabal/Distribution/Simple/Configure.hs b/cabal/cabal/Distribution/Simple/Configure.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Configure.hs @@ -0,0 +1,1036 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Configure +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This deals with the /configure/ phase. It provides the 'configure' action +-- which is given the package description and configure flags. It then tries +-- to: configure the compiler; resolves any conditionals in the package +-- description; resolve the package dependencies; check if all the extensions +-- used by this package are supported by the compiler; check that all the build +-- tools are available (including version checks if appropriate); checks for +-- any required @pkg-config@ packages (updating the 'BuildInfo' with the +-- results) +-- +-- Then based on all this it saves the info in the 'LocalBuildInfo' and writes +-- it out to the @dist\/setup-config@ file. It also displays various details to +-- the user, the amount of information displayed depending on the verbosity +-- level. + +{- 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 (configure, + writePersistBuildConfig, + getPersistBuildConfig, + checkPersistBuildConfigOutdated, + maybeGetPersistBuildConfig, + localBuildInfoFile, + getInstalledPackages, + configCompiler, configCompilerAux, + ccLdOptionsBuildInfo, + tryGetConfigStateFile, + checkForeignDeps, + ) + where + +import Distribution.Simple.Compiler + ( CompilerFlavor(..), Compiler(compilerId), compilerFlavor, compilerVersion + , showCompilerId, unsupportedLanguages, unsupportedExtensions + , PackageDB(..), PackageDBStack ) +import Distribution.Package + ( PackageName(PackageName), PackageIdentifier(..), PackageId + , packageName, packageVersion, Package(..) + , Dependency(Dependency), simplifyDependency + , InstalledPackageId(..) ) +import Distribution.InstalledPackageInfo as Installed + ( InstalledPackageInfo, InstalledPackageInfo_(..) + , emptyInstalledPackageInfo ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (PackageIndex) +import Distribution.PackageDescription as PD + ( PackageDescription(..), specVersion, GenericPackageDescription(..) + , Library(..), hasLibs, Executable(..), BuildInfo(..), allExtensions + , HookedBuildInfo, updatePackageDescription, allBuildInfo + , FlagName(..), TestSuite(..) ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription, mapTreeData ) +import Distribution.PackageDescription.Check + ( PackageCheck(..), checkPackage, checkPackageFiles ) +import Distribution.Simple.Hpc ( enableCoverage ) +import Distribution.Simple.Program + ( Program(..), ProgramLocation(..), ConfiguredProgram(..) + , ProgramConfiguration, defaultProgramConfiguration + , configureAllKnownPrograms, knownPrograms, lookupKnownProgram, addKnownProgram + , userSpecifyArgss, userSpecifyPaths + , requireProgram, requireProgramVersion + , pkgConfigProgram, gccProgram, rawSystemProgramStdoutConf ) +import Distribution.Simple.Setup + ( ConfigFlags(..), CopyDest(..), fromFlag, fromFlagOrDefault, flagToMaybe ) +import Distribution.Simple.InstallDirs + ( InstallDirs(..), defaultInstallDirs, combineInstallDirs ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) + , absoluteInstallDirs, prefixRelativeInstallDirs, inplacePackageId + , allComponentsBy, Component(..), foldComponent, ComponentName(..) ) +import Distribution.Simple.BuildPaths + ( autogenModulesDir ) +import Distribution.Simple.Utils + ( die, warn, info, setupMessage, createDirectoryIfMissingVerbose + , intercalate, cabalVersion + , withFileContents, writeFileAtomic + , withTempFile ) +import Distribution.System + ( OS(..), buildOS, buildPlatform ) +import Distribution.Version + ( Version(..), anyVersion, orLaterVersion, withinRange, isAnyVersion ) +import Distribution.Verbosity + ( Verbosity, lessVerbose ) + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.JHC as JHC +import qualified Distribution.Simple.LHC as LHC +import qualified Distribution.Simple.NHC as NHC +import qualified Distribution.Simple.Hugs as Hugs +import qualified Distribution.Simple.UHC as UHC + +import Control.Monad + ( when, unless, foldM, filterM, forM ) +import Data.List + ( nub, partition, isPrefixOf, inits, find ) +import Data.Maybe + ( isNothing, catMaybes, mapMaybe ) +import Data.Monoid + ( Monoid(..) ) +import Data.Graph + ( SCC(..), graphFromEdges, transposeG, vertices, stronglyConnCompR ) +import System.Directory + ( doesFileExist, getModificationTime, createDirectoryIfMissing, getTemporaryDirectory ) +import System.Exit + ( ExitCode(..), exitWith ) +import System.FilePath + ( (), isAbsolute ) +import qualified System.Info + ( compilerName, compilerVersion ) +import System.IO + ( hPutStrLn, stderr, hClose ) +import Distribution.Text + ( Text(disp), display, simpleParse ) +import Text.PrettyPrint.HughesPJ + ( comma, punctuate, render, nest, sep ) +import Distribution.Compat.Exception ( catchExit, catchIO ) + +import Prelude hiding (catch) + +tryGetConfigStateFile :: (Read a) => FilePath -> IO (Either String a) +tryGetConfigStateFile filename = do + exists <- doesFileExist filename + if not exists + then return (Left missing) + else withFileContents filename $ \str -> + case lines str of + [headder, rest] -> case checkHeader headder of + Just msg -> return (Left msg) + Nothing -> case reads rest of + [(bi,_)] -> return (Right bi) + _ -> return (Left cantParse) + _ -> return (Left cantParse) + where + checkHeader :: String -> Maybe String + checkHeader header = case parseHeader header of + Just (cabalId, compId) + | cabalId + == currentCabalId -> Nothing + | otherwise -> Just (badVersion cabalId compId) + Nothing -> Just cantParse + + missing = "Run the 'configure' command first." + cantParse = "Saved package config file seems to be corrupt. " + ++ "Try re-running the 'configure' command." + badVersion cabalId compId + = "You need to re-run the 'configure' command. " + ++ "The version of Cabal being used has changed (was " + ++ display cabalId ++ ", now " + ++ display currentCabalId ++ ")." + ++ badcompiler compId + badcompiler compId | compId == currentCompilerId = "" + | otherwise + = " Additionally the compiler is different (was " + ++ display compId ++ ", now " + ++ display currentCompilerId + ++ ") which is probably the cause of the problem." + +-- internal function +tryGetPersistBuildConfig :: FilePath -> IO (Either String LocalBuildInfo) +tryGetPersistBuildConfig distPref + = tryGetConfigStateFile (localBuildInfoFile distPref) + +-- |Read the 'localBuildInfoFile'. Error if it doesn't exist. Also +-- fail if the file containing LocalBuildInfo is older than the .cabal +-- file, indicating that a re-configure is required. +getPersistBuildConfig :: FilePath -> IO LocalBuildInfo +getPersistBuildConfig distPref = do + lbi <- tryGetPersistBuildConfig distPref + either die return lbi + +-- |Try to read the 'localBuildInfoFile'. +maybeGetPersistBuildConfig :: FilePath -> IO (Maybe LocalBuildInfo) +maybeGetPersistBuildConfig distPref = do + lbi <- tryGetPersistBuildConfig distPref + return $ either (const Nothing) Just lbi + +-- |After running configure, output the 'LocalBuildInfo' to the +-- 'localBuildInfoFile'. +writePersistBuildConfig :: FilePath -> LocalBuildInfo -> IO () +writePersistBuildConfig distPref lbi = do + createDirectoryIfMissing False distPref + writeFileAtomic (localBuildInfoFile distPref) + (showHeader pkgid ++ '\n' : show lbi) + where + pkgid = packageId (localPkgDescr lbi) + +showHeader :: PackageIdentifier -> String +showHeader pkgid = + "Saved package config for " ++ display pkgid + ++ " written by " ++ display currentCabalId + ++ " using " ++ display currentCompilerId + where + +currentCabalId :: PackageIdentifier +currentCabalId = PackageIdentifier (PackageName "Cabal") cabalVersion + +currentCompilerId :: PackageIdentifier +currentCompilerId = PackageIdentifier (PackageName System.Info.compilerName) + System.Info.compilerVersion + +parseHeader :: String -> Maybe (PackageIdentifier, PackageIdentifier) +parseHeader header = case words header of + ["Saved", "package", "config", "for", pkgid, + "written", "by", cabalid, "using", compilerid] + -> case (simpleParse pkgid :: Maybe PackageIdentifier, + simpleParse cabalid, + simpleParse compilerid) of + (Just _, + Just cabalid', + Just compilerid') -> Just (cabalid', compilerid') + _ -> Nothing + _ -> Nothing + +-- |Check that localBuildInfoFile is up-to-date with respect to the +-- .cabal file. +checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool +checkPersistBuildConfigOutdated distPref pkg_descr_file = do + t0 <- getModificationTime pkg_descr_file + t1 <- getModificationTime $ localBuildInfoFile distPref + return (t0 > t1) + +-- |@dist\/setup-config@ +localBuildInfoFile :: FilePath -> FilePath +localBuildInfoFile distPref = distPref "setup-config" + +-- ----------------------------------------------------------------------------- +-- * Configuration +-- ----------------------------------------------------------------------------- + +-- |Perform the \"@.\/setup configure@\" action. +-- Returns the @.setup-config@ file. +configure :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags -> IO LocalBuildInfo +configure (pkg_descr0, pbi) cfg + = do let distPref = fromFlag (configDistPref cfg) + buildDir' = distPref "build" + verbosity = fromFlag (configVerbosity cfg) + + setupMessage verbosity "Configuring" (packageId pkg_descr0) + + createDirectoryIfMissingVerbose (lessVerbose verbosity) True distPref + + let programsConfig = userSpecifyArgss (configProgramArgs cfg) + . userSpecifyPaths (configProgramPaths cfg) + $ configPrograms cfg + userInstall = fromFlag (configUserInstall cfg) + packageDbs = implicitPackageDbStack userInstall + (flagToMaybe $ configPackageDB cfg) + + -- detect compiler + (comp, programsConfig') <- configCompiler + (flagToMaybe $ configHcFlavor cfg) + (flagToMaybe $ configHcPath cfg) (flagToMaybe $ configHcPkg cfg) + programsConfig (lessVerbose verbosity) + let version = compilerVersion comp + flavor = compilerFlavor comp + + -- Create a PackageIndex that makes *any libraries that might be* + -- defined internally to this package look like installed packages, in + -- case an executable should refer to any of them as dependencies. + -- + -- It must be *any libraries that might be* defined rather than the + -- actual definitions, because these depend on conditionals in the .cabal + -- file, and we haven't resolved them yet. finalizePackageDescription + -- does the resolution of conditionals, and it takes internalPackageSet + -- as part of its input. + -- + -- Currently a package can define no more than one library (which has + -- the same name as the package) but we could extend this later. + -- If we later allowed private internal libraries, then here we would + -- need to pre-scan the conditional data to make a list of all private + -- libraries that could possibly be defined by the .cabal file. + let pid = packageId pkg_descr0 + internalPackage = emptyInstalledPackageInfo { + --TODO: should use a per-compiler method to map the source + -- package ID into an installed package id we can use + -- for the internal package set. The open-codes use of + -- InstalledPackageId . display here is a hack. + Installed.installedPackageId = InstalledPackageId $ display $ pid, + Installed.sourcePackageId = pid + } + internalPackageSet = PackageIndex.fromList [internalPackage] + installedPackageSet <- getInstalledPackages (lessVerbose verbosity) comp + packageDbs programsConfig' + + let -- Constraint test function for the solver + dependencySatisfiable = + not . null . PackageIndex.lookupDependency pkgs' + where + pkgs' = PackageIndex.insert internalPackage installedPackageSet + enableTest t = t { testEnabled = fromFlag (configTests cfg) } + flaggedTests = map (\(n, t) -> (n, mapTreeData enableTest t)) + (condTestSuites pkg_descr0) + pkg_descr0'' = pkg_descr0 { condTestSuites = flaggedTests } + + (pkg_descr0', flags) <- + case finalizePackageDescription + (configConfigurationsFlags cfg) + dependencySatisfiable + Distribution.System.buildPlatform + (compilerId comp) + (configConstraints cfg) + pkg_descr0'' + of Right r -> return r + Left missing -> + die $ "At least the following dependencies are missing:\n" + ++ (render . nest 4 . sep . punctuate comma + . map (disp . simplifyDependency) + $ missing) + + -- add extra include/lib dirs as specified in cfg + -- we do it here so that those get checked too + let pkg_descr = + enableCoverage (fromFlag (configLibCoverage cfg)) distPref + $ addExtraIncludeLibDirs pkg_descr0' + + when (not (null flags)) $ + info verbosity $ "Flags chosen: " + ++ intercalate ", " [ name ++ "=" ++ display value + | (FlagName name, value) <- flags ] + + checkPackageProblems verbosity pkg_descr0 + (updatePackageDescription pbi pkg_descr) + + let selectDependencies = + (\xs -> ([ x | Left x <- xs ], [ x | Right x <- xs ])) + . map (selectDependency internalPackageSet installedPackageSet) + + (failedDeps, allPkgDeps) = selectDependencies (buildDepends pkg_descr) + + internalPkgDeps = [ pkgid | InternalDependency _ pkgid <- allPkgDeps ] + externalPkgDeps = [ pkg | ExternalDependency _ pkg <- allPkgDeps ] + + when (not (null internalPkgDeps) && not (newPackageDepsBehaviour pkg_descr)) $ + die $ "The field 'build-depends: " + ++ intercalate ", " (map (display . packageName) internalPkgDeps) + ++ "' refers to a library which is defined within the same " + ++ "package. To use this feature the package must specify at " + ++ "least 'cabal-version: >= 1.8'." + + reportFailedDependencies failedDeps + reportSelectedDependencies verbosity allPkgDeps + + packageDependsIndex <- + case PackageIndex.dependencyClosure installedPackageSet + (map Installed.installedPackageId externalPkgDeps) of + Left packageDependsIndex -> return packageDependsIndex + Right broken -> + die $ "The following installed packages are broken because other" + ++ " packages they depend on are missing. These broken " + ++ "packages must be rebuilt before they can be used.\n" + ++ unlines [ "package " + ++ display (packageId pkg) + ++ " is broken due to missing package " + ++ intercalate ", " (map display deps) + | (pkg, deps) <- broken ] + + let pseudoTopPkg = emptyInstalledPackageInfo { + Installed.installedPackageId = InstalledPackageId (display (packageId pkg_descr)), + Installed.sourcePackageId = packageId pkg_descr, + Installed.depends = map Installed.installedPackageId externalPkgDeps + } + case PackageIndex.dependencyInconsistencies + . PackageIndex.insert pseudoTopPkg + $ packageDependsIndex of + [] -> return () + inconsistencies -> + warn verbosity $ + "This package indirectly depends on multiple versions of the same " + ++ "package. This is highly likely to cause a compile failure.\n" + ++ unlines [ "package " ++ display pkg ++ " requires " + ++ display (PackageIdentifier name ver) + | (name, uses) <- inconsistencies + , (pkg, ver) <- uses ] + + -- installation directories + defaultDirs <- defaultInstallDirs flavor userInstall (hasLibs pkg_descr) + let installDirs = combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs cfg) + + -- check languages and extensions + let langlist = nub $ catMaybes $ map defaultLanguage (allBuildInfo pkg_descr) + let langs = unsupportedLanguages comp langlist + when (not (null langs)) $ + die $ "The package " ++ display (packageId pkg_descr0) + ++ " requires the following languages which are not " + ++ "supported by " ++ display (compilerId comp) ++ ": " + ++ intercalate ", " (map display langs) + let extlist = nub $ concatMap allExtensions (allBuildInfo pkg_descr) + let exts = unsupportedExtensions comp extlist + when (not (null exts)) $ + die $ "The package " ++ display (packageId pkg_descr0) + ++ " requires the following language extensions which are not " + ++ "supported by " ++ display (compilerId comp) ++ ": " + ++ intercalate ", " (map display exts) + + -- configured known/required programs & build tools + let requiredBuildTools = concatMap buildTools (allBuildInfo pkg_descr) + + -- add all exes built by this package ("internal exes") to the program + -- conf; this makes the namespace of build-tools include intrapackage + -- references to executables + let programsConfig'' = foldr (addInternalExe buildDir') programsConfig' + (executables pkg_descr) + + programsConfig''' <- + configureAllKnownPrograms (lessVerbose verbosity) programsConfig'' + >>= configureRequiredPrograms verbosity requiredBuildTools + + (pkg_descr', programsConfig'''') <- + configurePkgconfigPackages verbosity pkg_descr programsConfig''' + + split_objs <- + if not (fromFlag $ configSplitObjs cfg) + then return False + else case flavor of + GHC | version >= Version [6,5] [] -> return True + _ -> do warn verbosity + ("this compiler does not support " ++ + "--enable-split-objs; ignoring") + return False + + -- The allPkgDeps contains all the package deps for the whole package + -- but we need to select the subset for this specific component. + -- we just take the subset for the package names this component + -- needs. Note, this only works because we cannot yet depend on two + -- versions of the same package. + let configLib lib = configComponent (libBuildInfo lib) + configExe exe = (exeName exe, configComponent (buildInfo exe)) + configTest test = (testName test, + configComponent(testBuildInfo test)) + configComponent bi = ComponentLocalBuildInfo { + componentPackageDeps = + if newPackageDepsBehaviour pkg_descr' + then [ (installedPackageId pkg, packageId pkg) + | pkg <- selectSubset bi externalPkgDeps ] + ++ [ (inplacePackageId pkgid, pkgid) + | pkgid <- selectSubset bi internalPkgDeps ] + else [ (installedPackageId pkg, packageId pkg) + | pkg <- externalPkgDeps ] + } + selectSubset :: Package pkg => BuildInfo -> [pkg] -> [pkg] + selectSubset bi pkgs = + [ pkg | pkg <- pkgs, packageName pkg `elem` names ] + where + names = [ name | Dependency name _ <- targetBuildDepends bi ] + + -- Obtains the intrapackage dependencies for the given component + let ipDeps component = + mapMaybe exeDepToComp (buildTools bi) + ++ mapMaybe libDepToComp (targetBuildDepends bi) + where + bi = foldComponent libBuildInfo buildInfo testBuildInfo component + exeDepToComp (Dependency (PackageName name) _) = + CExe `fmap` find ((==) name . exeName) + (executables pkg_descr') + libDepToComp (Dependency pn _) + | pn `elem` map packageName internalPkgDeps = + CLib `fmap` library pkg_descr' + libDepToComp _ = Nothing + + let sccs = (stronglyConnCompR . map lkup . vertices . transposeG) g + where (g, lkup, _) = graphFromEdges + $ allComponentsBy pkg_descr' + $ \c -> (c, key c, map key (ipDeps c)) + key = foldComponent (const "library") exeName testName + + -- check for cycles in the dependency graph + buildOrder <- forM sccs $ \scc -> case scc of + AcyclicSCC (c,_,_) -> return (foldComponent (const CLibName) + (CExeName . exeName) + (CTestName . testName) + c) + CyclicSCC vs -> + die $ "Found cycle in intrapackage dependency graph:\n " + ++ intercalate " depends on " + (map (\(_,k,_) -> "'" ++ k ++ "'") (vs ++ [head vs])) + + let lbi = LocalBuildInfo { + configFlags = cfg, + extraConfigArgs = [], -- Currently configure does not + -- take extra args, but if it + -- did they would go here. + installDirTemplates = installDirs, + compiler = comp, + buildDir = buildDir', + scratchDir = fromFlagOrDefault + (distPref "scratch") + (configScratchDir cfg), + libraryConfig = configLib `fmap` library pkg_descr', + executableConfigs = configExe `fmap` executables pkg_descr', + testSuiteConfigs = configTest `fmap` testSuites pkg_descr', + compBuildOrder = buildOrder, + installedPkgs = packageDependsIndex, + pkgDescrFile = Nothing, + localPkgDescr = pkg_descr', + withPrograms = programsConfig'''', + withVanillaLib = fromFlag $ configVanillaLib cfg, + withProfLib = fromFlag $ configProfLib cfg, + withSharedLib = fromFlag $ configSharedLib cfg, + withDynExe = fromFlag $ configDynExe cfg, + withProfExe = fromFlag $ configProfExe cfg, + withOptimization = fromFlag $ configOptimization cfg, + withGHCiLib = fromFlag $ configGHCiLib cfg, + splitObjs = split_objs, + stripExes = fromFlag $ configStripExes cfg, + withPackageDB = packageDbs, + progPrefix = fromFlag $ configProgPrefix cfg, + progSuffix = fromFlag $ configProgSuffix cfg + } + + let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest + relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi + + unless (isAbsolute (prefix dirs)) $ die $ + "expected an absolute directory name for --prefix: " ++ prefix dirs + + info verbosity $ "Using " ++ display currentCabalId + ++ " compiled by " ++ display currentCompilerId + info verbosity $ "Using compiler: " ++ showCompilerId comp + info verbosity $ "Using install prefix: " ++ prefix dirs + + let dirinfo name dir isPrefixRelative = + info verbosity $ name ++ " installed in: " ++ dir ++ relNote + where relNote = case buildOS of + Windows | not (hasLibs pkg_descr) + && isNothing isPrefixRelative + -> " (fixed location)" + _ -> "" + + dirinfo "Binaries" (bindir dirs) (bindir relative) + dirinfo "Libraries" (libdir dirs) (libdir relative) + dirinfo "Private binaries" (libexecdir dirs) (libexecdir relative) + dirinfo "Data files" (datadir dirs) (datadir relative) + dirinfo "Documentation" (docdir dirs) (docdir relative) + + sequence_ [ reportProgram verbosity prog configuredProg + | (prog, configuredProg) <- knownPrograms programsConfig'''' ] + + return lbi + + where + addInternalExe bd exe = + let nm = exeName exe in + addKnownProgram Program { + programName = nm, + programFindLocation = \_ -> return $ Just $ bd nm nm, + programFindVersion = \_ _ -> return Nothing, + programPostConf = \_ _ -> return [] + } + + addExtraIncludeLibDirs pkg_descr = + let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg + , PD.includeDirs = configExtraIncludeDirs cfg} + modifyLib l = l{ libBuildInfo = libBuildInfo l `mappend` extraBi } + modifyExecutable e = e{ buildInfo = buildInfo e `mappend` extraBi} + in pkg_descr{ library = modifyLib `fmap` library pkg_descr + , executables = modifyExecutable `map` executables pkg_descr} + +-- ----------------------------------------------------------------------------- +-- Configuring package dependencies + +reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO () +reportProgram verbosity prog Nothing + = info verbosity $ "No " ++ programName prog ++ " found" +reportProgram verbosity prog (Just configuredProg) + = info verbosity $ "Using " ++ programName prog ++ version ++ location + where location = case programLocation configuredProg of + FoundOnSystem p -> " found on system at: " ++ p + UserSpecified p -> " given by user at: " ++ p + version = case programVersion configuredProg of + Nothing -> "" + Just v -> " version " ++ display v + +hackageUrl :: String +hackageUrl = "http://hackage.haskell.org/package/" + +data ResolvedDependency = ExternalDependency Dependency InstalledPackageInfo + | InternalDependency Dependency PackageId -- should be a lib name + +data FailedDependency = DependencyNotExists PackageName + | DependencyNoVersion Dependency + +-- | Test for a package dependency and record the version we have installed. +selectDependency :: PackageIndex -- ^ Internally defined packages + -> PackageIndex -- ^ Installed packages + -> Dependency + -> Either FailedDependency ResolvedDependency +selectDependency internalIndex installedIndex + dep@(Dependency pkgname vr) = + -- If the dependency specification matches anything in the internal package + -- index, then we prefer that match to anything in the second. + -- For example: + -- + -- Name: MyLibrary + -- Version: 0.1 + -- Library + -- .. + -- Executable my-exec + -- build-depends: MyLibrary + -- + -- We want "build-depends: MyLibrary" always to match the internal library + -- even if there is a newer installed library "MyLibrary-0.2". + -- However, "build-depends: MyLibrary >= 0.2" should match the installed one. + case PackageIndex.lookupPackageName internalIndex pkgname of + [(_,[pkg])] | packageVersion pkg `withinRange` vr + -> Right $ InternalDependency dep (packageId pkg) + + _ -> case PackageIndex.lookupDependency installedIndex dep of + [] -> Left $ DependencyNotExists pkgname + pkgs -> Right $ ExternalDependency dep $ + -- by default we just pick the latest + case last pkgs of + (_ver, instances) -> head instances -- the first preference + +reportSelectedDependencies :: Verbosity + -> [ResolvedDependency] -> IO () +reportSelectedDependencies verbosity deps = + info verbosity $ unlines + [ "Dependency " ++ display (simplifyDependency dep) + ++ ": using " ++ display pkgid + | resolved <- deps + , let (dep, pkgid) = case resolved of + ExternalDependency dep' pkg' -> (dep', packageId pkg') + InternalDependency dep' pkgid' -> (dep', pkgid') ] + +reportFailedDependencies :: [FailedDependency] -> IO () +reportFailedDependencies [] = return () +reportFailedDependencies failed = + die (intercalate "\n\n" (map reportFailedDependency failed)) + + where + reportFailedDependency (DependencyNotExists pkgname) = + "there is no version of " ++ display pkgname ++ " installed.\n" + ++ "Perhaps you need to download and install it from\n" + ++ hackageUrl ++ display pkgname ++ "?" + + reportFailedDependency (DependencyNoVersion dep) = + "cannot satisfy dependency " ++ display (simplifyDependency dep) ++ "\n" + +getInstalledPackages :: Verbosity -> Compiler + -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity comp packageDBs progconf = do + info verbosity "Reading installed packages..." + case compilerFlavor comp of + GHC -> GHC.getInstalledPackages verbosity packageDBs progconf + Hugs->Hugs.getInstalledPackages verbosity packageDBs progconf + JHC -> JHC.getInstalledPackages verbosity packageDBs progconf + LHC -> LHC.getInstalledPackages verbosity packageDBs progconf + NHC -> NHC.getInstalledPackages verbosity packageDBs progconf + UHC -> UHC.getInstalledPackages verbosity comp packageDBs progconf + flv -> die $ "don't know how to find the installed packages for " + ++ display flv + +-- | Currently the user interface specifies the package dbs to use with just a +-- single valued option, a 'PackageDB'. However internally we represent the +-- stack of 'PackageDB's explictly as a list. This function converts encodes +-- the package db stack implicit in a single packagedb. +-- +implicitPackageDbStack :: Bool -> Maybe PackageDB -> PackageDBStack +implicitPackageDbStack userInstall maybePackageDB + | userInstall = GlobalPackageDB : UserPackageDB : extra + | otherwise = GlobalPackageDB : extra + where + extra = case maybePackageDB of + Just (SpecificPackageDB db) -> [SpecificPackageDB db] + _ -> [] + +newPackageDepsBehaviourMinVersion :: Version +newPackageDepsBehaviourMinVersion = Version { versionBranch = [1,7,1], versionTags = [] } + +-- In older cabal versions, there was only one set of package dependencies for +-- the whole package. In this version, we can have separate dependencies per +-- target, but we only enable this behaviour if the minimum cabal version +-- specified is >= a certain minimum. Otherwise, for compatibility we use the +-- old behaviour. +newPackageDepsBehaviour :: PackageDescription -> Bool +newPackageDepsBehaviour pkg = + specVersion pkg >= newPackageDepsBehaviourMinVersion + +-- ----------------------------------------------------------------------------- +-- Configuring program dependencies + +configureRequiredPrograms :: Verbosity -> [Dependency] -> ProgramConfiguration -> IO ProgramConfiguration +configureRequiredPrograms verbosity deps conf = + foldM (configureRequiredProgram verbosity) conf deps + +configureRequiredProgram :: Verbosity -> ProgramConfiguration -> Dependency -> IO ProgramConfiguration +configureRequiredProgram verbosity conf (Dependency (PackageName progName) verRange) = + case lookupKnownProgram progName conf of + Nothing -> die ("Unknown build tool " ++ progName) + Just prog + -- requireProgramVersion always requires the program have a version + -- but if the user says "build-depends: foo" ie no version constraint + -- then we should not fail if we cannot discover the program version. + | verRange == anyVersion -> do + (_, conf') <- requireProgram verbosity prog conf + return conf' + | otherwise -> do + (_, _, conf') <- requireProgramVersion verbosity prog verRange conf + return conf' + +-- ----------------------------------------------------------------------------- +-- Configuring pkg-config package dependencies + +configurePkgconfigPackages :: Verbosity -> PackageDescription + -> ProgramConfiguration + -> IO (PackageDescription, ProgramConfiguration) +configurePkgconfigPackages verbosity pkg_descr conf + | null allpkgs = return (pkg_descr, conf) + | otherwise = do + (_, _, conf') <- requireProgramVersion + (lessVerbose verbosity) pkgConfigProgram + (orLaterVersion $ Version [0,9,0] []) conf + mapM_ requirePkg allpkgs + lib' <- updateLibrary (library pkg_descr) + exes' <- mapM updateExecutable (executables pkg_descr) + let pkg_descr' = pkg_descr { library = lib', executables = exes' } + return (pkg_descr', conf') + + where + allpkgs = concatMap pkgconfigDepends (allBuildInfo pkg_descr) + pkgconfig = rawSystemProgramStdoutConf (lessVerbose verbosity) + pkgConfigProgram conf + + requirePkg dep@(Dependency (PackageName pkg) range) = do + version <- pkgconfig ["--modversion", pkg] + `catchIO` (\_ -> die notFound) + `catchExit` (\_ -> die notFound) + case simpleParse version of + Nothing -> die "parsing output of pkg-config --modversion failed" + Just v | not (withinRange v range) -> die (badVersion v) + | otherwise -> info verbosity (depSatisfied v) + where + notFound = "The pkg-config package " ++ pkg ++ versionRequirement + ++ " is required but it could not be found." + badVersion v = "The pkg-config package " ++ pkg ++ versionRequirement + ++ " is required but the version installed on the" + ++ " system is version " ++ display v + depSatisfied v = "Dependency " ++ display dep + ++ ": using version " ++ display v + + versionRequirement + | isAnyVersion range = "" + | otherwise = " version " ++ display range + + updateLibrary Nothing = return Nothing + updateLibrary (Just lib) = do + bi <- pkgconfigBuildInfo (pkgconfigDepends (libBuildInfo lib)) + return $ Just lib { libBuildInfo = libBuildInfo lib `mappend` bi } + + updateExecutable exe = do + bi <- pkgconfigBuildInfo (pkgconfigDepends (buildInfo exe)) + return exe { buildInfo = buildInfo exe `mappend` bi } + + pkgconfigBuildInfo :: [Dependency] -> IO BuildInfo + pkgconfigBuildInfo [] = return mempty + pkgconfigBuildInfo pkgdeps = do + let pkgs = nub [ display pkg | Dependency pkg _ <- pkgdeps ] + ccflags <- pkgconfig ("--cflags" : pkgs) + ldflags <- pkgconfig ("--libs" : pkgs) + return (ccLdOptionsBuildInfo (words ccflags) (words ldflags)) + +-- | Makes a 'BuildInfo' from C compiler and linker flags. +-- +-- This can be used with the output from configuration programs like pkg-config +-- and similar package-specific programs like mysql-config, freealut-config etc. +-- For example: +-- +-- > ccflags <- rawSystemProgramStdoutConf verbosity prog conf ["--cflags"] +-- > ldflags <- rawSystemProgramStdoutConf verbosity prog conf ["--libs"] +-- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags)) +-- +ccLdOptionsBuildInfo :: [String] -> [String] -> BuildInfo +ccLdOptionsBuildInfo cflags ldflags = + let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags + (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags + (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags' + in mempty { + PD.includeDirs = map (drop 2) includeDirs', + PD.extraLibs = map (drop 2) extraLibs', + PD.extraLibDirs = map (drop 2) extraLibDirs', + PD.ccOptions = cflags', + PD.ldOptions = ldflags'' + } + +-- ----------------------------------------------------------------------------- +-- Determining the compiler details + +configCompilerAux :: ConfigFlags -> IO (Compiler, ProgramConfiguration) +configCompilerAux cfg = configCompiler (flagToMaybe $ configHcFlavor cfg) + (flagToMaybe $ configHcPath cfg) + (flagToMaybe $ configHcPkg cfg) + programsConfig + (fromFlag (configVerbosity cfg)) + where + programsConfig = userSpecifyArgss (configProgramArgs cfg) + . userSpecifyPaths (configProgramPaths cfg) + $ defaultProgramConfiguration + +configCompiler :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> Verbosity + -> IO (Compiler, ProgramConfiguration) +configCompiler Nothing _ _ _ _ = die "Unknown compiler" +configCompiler (Just hcFlavor) hcPath hcPkg conf verbosity = do + case hcFlavor of + GHC -> GHC.configure verbosity hcPath hcPkg conf + JHC -> JHC.configure verbosity hcPath hcPkg conf + LHC -> do (_,ghcConf) <- GHC.configure verbosity Nothing hcPkg conf + LHC.configure verbosity hcPath Nothing ghcConf + Hugs -> Hugs.configure verbosity hcPath hcPkg conf + NHC -> NHC.configure verbosity hcPath hcPkg conf + UHC -> UHC.configure verbosity hcPath hcPkg conf + _ -> die "Unknown compiler" + + +-- Try to build a test C program which includes every header and links every +-- lib. If that fails, try to narrow it down by preprocessing (only) and linking +-- with individual headers and libs. If none is the obvious culprit then give a +-- generic error message. +-- TODO: produce a log file from the compiler errors, if any. +checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () +checkForeignDeps pkg lbi verbosity = do + ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling lucky + (return ()) + (do missingLibs <- findMissingLibs + missingHdr <- findOffendingHdr + explainErrors missingHdr missingLibs) + where + allHeaders = collectField PD.includes + allLibs = collectField PD.extraLibs + + ifBuildsWith headers args success failure = do + ok <- builds (makeProgram headers) args + if ok then success else failure + + findOffendingHdr = + ifBuildsWith allHeaders ccArgs + (return Nothing) + (go . tail . inits $ allHeaders) + where + go [] = return Nothing -- cannot happen + go (hdrs:hdrsInits) = + -- Try just preprocessing first + ifBuildsWith hdrs cppArgs + -- If that works, try compiling too + (ifBuildsWith hdrs ccArgs + (go hdrsInits) + (return . Just . Right . last $ hdrs)) + (return . Just . Left . last $ hdrs) + + cppArgs = "-E":commonCppArgs -- preprocess only + ccArgs = "-c":commonCcArgs -- don't try to link + + findMissingLibs = ifBuildsWith [] (makeLdArgs allLibs) + (return []) + (filterM (fmap not . libExists) allLibs) + + libExists lib = builds (makeProgram []) (makeLdArgs [lib]) + + commonCppArgs = hcDefines (compiler lbi) + ++ [ "-I" ++ autogenModulesDir lbi ] + ++ [ "-I" ++ dir | dir <- collectField PD.includeDirs ] + ++ ["-I."] + ++ collectField PD.cppOptions + ++ collectField PD.ccOptions + ++ [ "-I" ++ dir + | dep <- deps + , dir <- Installed.includeDirs dep ] + ++ [ opt + | dep <- deps + , opt <- Installed.ccOptions dep ] + + commonCcArgs = commonCppArgs + ++ collectField PD.ccOptions + ++ [ opt + | dep <- deps + , opt <- Installed.ccOptions dep ] + + commonLdArgs = [ "-L" ++ dir | dir <- collectField PD.extraLibDirs ] + ++ collectField PD.ldOptions + ++ [ "-L" ++ dir + | dep <- deps + , dir <- Installed.libraryDirs dep ] + --TODO: do we also need dependent packages' ld options? + makeLdArgs libs = [ "-l"++lib | lib <- libs ] ++ commonLdArgs + + makeProgram hdrs = unlines $ + [ "#include \"" ++ hdr ++ "\"" | hdr <- hdrs ] ++ + ["int main(int argc, char** argv) { return 0; }"] + + collectField f = concatMap f allBi + allBi = allBuildInfo pkg + deps = PackageIndex.topologicalOrder (installedPkgs lbi) + + builds program args = do + tempDir <- getTemporaryDirectory + withTempFile tempDir ".c" $ \cName cHnd -> + withTempFile tempDir "" $ \oNname oHnd -> do + hPutStrLn cHnd program + hClose cHnd + hClose oHnd + _ <- rawSystemProgramStdoutConf verbosity + gccProgram (withPrograms lbi) (cName:"-o":oNname:args) + return True + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) + + explainErrors Nothing [] = return () -- should be impossible! + explainErrors hdr libs = die $ unlines $ + [ if plural + then "Missing dependencies on foreign libraries:" + else "Missing dependency on a foreign library:" + | missing ] + ++ case hdr of + Just (Left h) -> ["* Missing (or bad) header file: " ++ h ] + _ -> [] + ++ case libs of + [] -> [] + [lib] -> ["* Missing C library: " ++ lib] + _ -> ["* Missing C libraries: " ++ intercalate ", " libs] + ++ [if plural then messagePlural else messageSingular | missing] + ++ case hdr of + Just (Left _) -> [ headerCppMessage ] + Just (Right h) -> [ (if missing then "* " else "") + ++ "Bad header file: " ++ h + , headerCcMessage ] + _ -> [] + + where + plural = length libs >= 2 + -- Is there something missing? (as opposed to broken) + missing = not (null libs) + || case hdr of Just (Left _) -> True; _ -> False + + messageSingular = + "This problem can usually be solved by installing the system " + ++ "package that provides this library (you may need the " + ++ "\"-dev\" version). If the library is already installed " + ++ "but in a non-standard location then you can use the flags " + ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " + ++ "where it is." + messagePlural = + "This problem can usually be solved by installing the system " + ++ "packages that provide these libraries (you may need the " + ++ "\"-dev\" versions). If the libraries are already installed " + ++ "but in a non-standard location then you can use the flags " + ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " + ++ "where they are." + headerCppMessage = + "If the header file does exist, it may contain errors that " + ++ "are caught by the C compiler at the preprocessing stage. " + ++ "In this case you can re-run configure with the verbosity " + ++ "flag -v3 to see the error messages." + headerCcMessage = + "The header file contains a compile error. " + ++ "You can re-run configure with the verbosity flag " + ++ "-v3 to see the error messages from the C compiler." + + --FIXME: share this with the PreProcessor module + hcDefines :: Compiler -> [String] + hcDefines comp = + case compilerFlavor comp of + GHC -> ["-D__GLASGOW_HASKELL__=" ++ versionInt version] + JHC -> ["-D__JHC__=" ++ versionInt version] + NHC -> ["-D__NHC__=" ++ versionInt version] + Hugs -> ["-D__HUGS__"] + _ -> [] + where + version = compilerVersion comp + -- TODO: move this into the compiler abstraction + -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all + -- the other compilers. Check if that's really what they want. + versionInt :: Version -> String + versionInt (Version { versionBranch = [] }) = "1" + versionInt (Version { versionBranch = [n] }) = show n + versionInt (Version { versionBranch = n1:n2:_ }) + = -- 6.8.x -> 608 + -- 6.10.x -> 610 + let s1 = show n1 + s2 = show n2 + middle = case s2 of + _ : _ : _ -> "" + _ -> "0" + in s1 ++ middle ++ s2 + +-- | Output package check warnings and errors. Exit if any errors. +checkPackageProblems :: Verbosity + -> GenericPackageDescription + -> PackageDescription + -> IO () +checkPackageProblems verbosity gpkg pkg = do + ioChecks <- checkPackageFiles pkg "." + let pureChecks = checkPackage gpkg (Just pkg) + errors = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ] + warnings = [ w | PackageBuildWarning w <- pureChecks ++ ioChecks ] + if null errors + then mapM_ (warn verbosity) warnings + else do mapM_ (hPutStrLn stderr . ("Error: " ++)) errors + exitWith (ExitFailure 1) diff --git a/cabal/cabal/Distribution/Simple/GHC.hs b/cabal/cabal/Distribution/Simple/GHC.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/GHC.hs @@ -0,0 +1,1079 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.GHC +-- Copyright : Isaac Jones 2003-2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is a fairly large module. It contains most of the GHC-specific code for +-- configuring, building and installing packages. It also exports a function +-- for finding out what packages are already installed. Configuring involves +-- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions +-- this version of ghc supports and returning a 'Compiler' value. +-- +-- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out +-- what packages are installed. +-- +-- Building is somewhat complex as there is quite a bit of information to take +-- into account. We have to build libs and programs, possibly for profiling and +-- shared libs. We have to support building libraries that will be usable by +-- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files +-- using ghc. Linking, especially for @split-objs@ is remarkably complex, +-- partly because there tend to be 1,000's of @.o@ files and this can often be +-- more than we can pass to the @ld@ or @ar@ programs in one go. +-- +-- Installing for libs and exes involves finding the right files and copying +-- them to the right places. One of the more tricky things about this module is +-- remembering the layout of files in the build directory (which is not +-- explicitly documented) and thus what search dirs are used for various kinds +-- of files. + +{- 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 ( + configure, getInstalledPackages, + buildLib, buildExe, + installLib, installExe, + libAbiHash, + registerPackage, + ghcOptions, + ghcVerbosityOptions, + ghcPackageDbOptions, + ghcLibDir, + ) where + +import qualified Distribution.Simple.GHC.IPI641 as IPI641 +import qualified Distribution.Simple.GHC.IPI642 as IPI642 +import Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(..), Executable(..) + , Library(..), libModules, hcOptions, usedExtensions, allExtensions ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo ) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo + ( InstalledPackageInfo_(..) ) +import Distribution.Simple.PackageIndex (PackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) + , absoluteInstallDirs ) +import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs ) +import Distribution.Simple.BuildPaths +import Distribution.Simple.Utils +import Distribution.Package + ( PackageIdentifier, Package(..), PackageName(..) ) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Simple.Program + ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg + , ProgramLocation(..), rawSystemProgram, rawSystemProgramConf + , rawSystemProgramStdout, rawSystemProgramStdoutConf + , requireProgramVersion, requireProgram, getProgramOutput + , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram + , ghcProgram, ghcPkgProgram, hsc2hsProgram + , arProgram, ranlibProgram, ldProgram + , gccProgram, stripProgram ) +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import qualified Distribution.Simple.Program.Ar as Ar +import qualified Distribution.Simple.Program.Ld as Ld +import Distribution.Simple.Compiler + ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion + , OptimisationLevel(..), PackageDB(..), PackageDBStack + , Flag, languageToFlags, extensionsToFlags ) +import Distribution.Version + ( Version(..), anyVersion, orLaterVersion ) +import Distribution.System + ( OS(..), buildOS ) +import Distribution.Verbosity +import Distribution.Text + ( display, simpleParse ) +import Language.Haskell.Extension (Language(..), Extension(..), KnownExtension(..)) + +import Control.Monad ( unless, when, liftM ) +import Data.Char ( isSpace ) +import Data.List +import Data.Maybe ( catMaybes ) +import Data.Monoid ( Monoid(..) ) +import System.Directory + ( removeFile, getDirectoryContents, doesFileExist + , getTemporaryDirectory ) +import System.FilePath ( (), (<.>), takeExtension, + takeDirectory, replaceExtension, splitExtension ) +import System.IO (hClose, hPutStrLn) +import Distribution.Compat.Exception (catchExit, catchIO) + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) +configure verbosity hcPath hcPkgPath conf0 = do + + (ghcProg, ghcVersion, conf1) <- + requireProgramVersion verbosity ghcProgram + (orLaterVersion (Version [6,4] [])) + (userMaybeSpecifyPath "ghc" hcPath conf0) + + -- This is slightly tricky, we have to configure ghc first, then we use the + -- location of ghc to help find ghc-pkg in the case that the user did not + -- specify the location of ghc-pkg directly: + (ghcPkgProg, ghcPkgVersion, conf2) <- + requireProgramVersion verbosity ghcPkgProgram { + programFindLocation = guessGhcPkgFromGhcPath ghcProg + } + anyVersion (userMaybeSpecifyPath "ghc-pkg" hcPkgPath conf1) + + when (ghcVersion /= ghcPkgVersion) $ die $ + "Version mismatch between ghc and ghc-pkg: " + ++ programPath ghcProg ++ " is version " ++ display ghcVersion ++ " " + ++ programPath ghcPkgProg ++ " is version " ++ display ghcPkgVersion + + -- Likewise we try to find the matching hsc2hs program. + let hsc2hsProgram' = hsc2hsProgram { + programFindLocation = guessHsc2hsFromGhcPath ghcProg + } + conf3 = addKnownProgram hsc2hsProgram' conf2 + + languages <- getLanguages verbosity ghcProg + extensions <- getExtensions verbosity ghcProg + + ghcInfo <- if ghcVersion >= Version [6,7] [] + then do xs <- getProgramOutput verbosity ghcProg ["--info"] + case reads xs of + [(i, ss)] + | all isSpace ss -> + return i + _ -> + die "Can't parse --info output of GHC" + else return [] + + let comp = Compiler { + compilerId = CompilerId GHC ghcVersion, + compilerLanguages = languages, + compilerExtensions = extensions + } + conf4 = configureToolchain ghcProg ghcInfo conf3 -- configure gcc and ld + return (comp, conf4) + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find +-- the corresponding tool; e.g. if the tool is ghc-pkg, we try looking +-- for a versioned or unversioned ghc-pkg in the same dir, that is: +-- +-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg(.exe) +-- +guessToolFromGhcPath :: FilePath -> ConfiguredProgram -> Verbosity + -> IO (Maybe FilePath) +guessToolFromGhcPath tool ghcProg verbosity + = do let path = programPath ghcProg + dir = takeDirectory path + versionSuffix = takeVersionSuffix (dropExeExtension path) + guessNormal = dir tool <.> exeExtension + guessGhcVersioned = dir (tool ++ "-ghc" ++ versionSuffix) <.> exeExtension + guessVersioned = dir (tool ++ versionSuffix) <.> exeExtension + guesses | null versionSuffix = [guessNormal] + | otherwise = [guessGhcVersioned, + guessVersioned, + guessNormal] + info verbosity $ "looking for tool " ++ show tool ++ " near compiler in " ++ dir + exists <- mapM doesFileExist guesses + case [ file | (file, True) <- zip guesses exists ] of + [] -> return Nothing + (fp:_) -> do info verbosity $ "found " ++ tool ++ " in " ++ fp + return (Just fp) + + where takeVersionSuffix :: FilePath -> String + takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") . reverse + + dropExeExtension :: FilePath -> FilePath + dropExeExtension filepath = + case splitExtension filepath of + (filepath', extension) | extension == exeExtension -> filepath' + | otherwise -> filepath + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a +-- corresponding ghc-pkg, we try looking for both a versioned and unversioned +-- ghc-pkg in the same dir, that is: +-- +-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg(.exe) +-- +guessGhcPkgFromGhcPath :: ConfiguredProgram -> Verbosity -> IO (Maybe FilePath) +guessGhcPkgFromGhcPath = guessToolFromGhcPath "ghc-pkg" + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a +-- corresponding hsc2hs, we try looking for both a versioned and unversioned +-- hsc2hs in the same dir, that is: +-- +-- > /usr/local/bin/hsc2hs-ghc-6.6.1(.exe) +-- > /usr/local/bin/hsc2hs-6.6.1(.exe) +-- > /usr/local/bin/hsc2hs(.exe) +-- +guessHsc2hsFromGhcPath :: ConfiguredProgram -> Verbosity -> IO (Maybe FilePath) +guessHsc2hsFromGhcPath = guessToolFromGhcPath "hsc2hs" + +-- | Adjust the way we find and configure gcc and ld +-- +configureToolchain :: ConfiguredProgram -> [(String, String)] + -> ProgramConfiguration + -> ProgramConfiguration +configureToolchain ghcProg ghcInfo = + addKnownProgram gccProgram { + programFindLocation = findProg gccProgram + [ if ghcVersion >= Version [6,12] [] + then mingwBinDir "gcc.exe" + else baseDir "gcc.exe" ], + programPostConf = configureGcc + } + . addKnownProgram ldProgram { + programFindLocation = findProg ldProgram + [ if ghcVersion >= Version [6,12] [] + then mingwBinDir "ld.exe" + else libDir "ld.exe" ], + programPostConf = configureLd + } + . addKnownProgram arProgram { + programFindLocation = findProg arProgram + [ if ghcVersion >= Version [6,12] [] + then mingwBinDir "ar.exe" + else libDir "ar.exe" ] + } + where + Just ghcVersion = programVersion ghcProg + compilerDir = takeDirectory (programPath ghcProg) + baseDir = takeDirectory compilerDir + mingwBinDir = baseDir "mingw" "bin" + libDir = baseDir "gcc-lib" + includeDir = baseDir "include" "mingw" + isWindows = case buildOS of Windows -> True; _ -> False + + -- on Windows finding and configuring ghc's gcc and ld is a bit special + findProg :: Program -> [FilePath] -> Verbosity -> IO (Maybe FilePath) + findProg prog locations + | isWindows = \verbosity -> look locations verbosity + | otherwise = programFindLocation prog + where + look [] verbosity = do + warn verbosity ("Couldn't find " ++ programName prog ++ " where I expected it. Trying the search path.") + programFindLocation prog verbosity + look (f:fs) verbosity = do + exists <- doesFileExist f + if exists then return (Just f) + else look fs verbosity + + ccFlags = getFlags "C compiler flags" + gccLinkerFlags = getFlags "Gcc Linker flags" + ldLinkerFlags = getFlags "Ld Linker flags" + + getFlags key = case lookup key ghcInfo of + Nothing -> [] + Just flags -> + case reads flags of + [(args, "")] -> args + _ -> [] -- XXX Should should be an error really + + configureGcc :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + configureGcc v cp = liftM (++ (ccFlags ++ gccLinkerFlags)) + $ configureGcc' v cp + + configureGcc' :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + configureGcc' + | isWindows = \_ gccProg -> case programLocation gccProg of + -- if it's found on system then it means we're using the result + -- of programFindLocation above rather than a user-supplied path + -- Pre GHC 6.12, that meant we should add these flags to tell + -- ghc's gcc where it lives and thus where gcc can find its + -- various files: + FoundOnSystem {} + | ghcVersion < Version [6,11] [] -> + return ["-B" ++ libDir, "-I" ++ includeDir] + _ -> return [] + | otherwise = \_ _ -> return [] + + configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + configureLd v cp = liftM (++ ldLinkerFlags) $ configureLd' v cp + + -- we need to find out if ld supports the -x flag + configureLd' :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + configureLd' verbosity ldProg = do + tempDir <- getTemporaryDirectory + ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> + withTempFile tempDir ".o" $ \testofile testohnd -> do + hPutStrLn testchnd "int foo() {}" + hClose testchnd; hClose testohnd + rawSystemProgram verbosity ghcProg ["-c", testcfile, + "-o", testofile] + withTempFile tempDir ".o" $ \testofile' testohnd' -> + do + hClose testohnd' + _ <- rawSystemProgramStdout verbosity ldProg + ["-x", "-r", testofile, "-o", testofile'] + return True + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) + if ldx + then return ["-x"] + else return [] + +getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)] +getLanguages _ ghcProg + -- TODO: should be using --supported-languages rather than hard coding + | ghcVersion >= Version [7] [] = return [(Haskell98, "-XHaskell98") + ,(Haskell2010, "-XHaskell2010")] + | otherwise = return [(Haskell98, "")] + where + Just ghcVersion = programVersion ghcProg + +getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)] +getExtensions verbosity ghcProg + | ghcVersion >= Version [6,7] [] = do + + str <- rawSystemStdout verbosity (programPath ghcProg) + ["--supported-languages"] + let extStrs = if ghcVersion >= Version [7] [] + then lines str + else -- Older GHCs only gave us either Foo or NoFoo, + -- so we have to work out the other one ourselves + [ extStr'' + | extStr <- lines str + , let extStr' = case extStr of + 'N' : 'o' : xs -> xs + _ -> "No" ++ extStr + , extStr'' <- [extStr, extStr'] + ] + let extensions0 = [ (ext, "-X" ++ display ext) + | Just ext <- map simpleParse extStrs ] + extensions1 = if ghcVersion >= Version [6,8] [] && + ghcVersion < Version [6,10] [] + then -- ghc-6.8 introduced RecordPuns however it + -- should have been NamedFieldPuns. We now + -- encourage packages to use NamedFieldPuns + -- so for compatability we fake support for + -- it in ghc-6.8 by making it an alias for + -- the old RecordPuns extension. + (EnableExtension NamedFieldPuns, "-XRecordPuns") : + (DisableExtension NamedFieldPuns, "-XNoRecordPuns") : + extensions0 + else extensions0 + extensions2 = if ghcVersion < Version [7,1] [] + then -- ghc-7.2 split NondecreasingIndentation off + -- into a proper extension. Before that it + -- was always on. + (EnableExtension NondecreasingIndentation, "") : + (DisableExtension NondecreasingIndentation, "") : + extensions1 + else extensions1 + return extensions2 + + | otherwise = return oldLanguageExtensions + + where + Just ghcVersion = programVersion ghcProg + +-- | For GHC 6.6.x and earlier, the mapping from supported extensions to flags +oldLanguageExtensions :: [(Extension, Flag)] +oldLanguageExtensions = + let doFlag (f, (enable, disable)) = [(EnableExtension f, enable), + (DisableExtension f, disable)] + fglasgowExts = ("-fglasgow-exts", + "") -- This is wrong, but we don't want to turn + -- all the extensions off when asked to just + -- turn one off + fFlag flag = ("-f" ++ flag, "-fno-" ++ flag) + in concatMap doFlag + [(OverlappingInstances , fFlag "allow-overlapping-instances") + ,(TypeSynonymInstances , fglasgowExts) + ,(TemplateHaskell , fFlag "th") + ,(ForeignFunctionInterface , fFlag "ffi") + ,(MonomorphismRestriction , fFlag "monomorphism-restriction") + ,(MonoPatBinds , fFlag "mono-pat-binds") + ,(UndecidableInstances , fFlag "allow-undecidable-instances") + ,(IncoherentInstances , fFlag "allow-incoherent-instances") + ,(Arrows , fFlag "arrows") + ,(Generics , fFlag "generics") + ,(ImplicitPrelude , fFlag "implicit-prelude") + ,(ImplicitParams , fFlag "implicit-params") + ,(CPP , ("-cpp", ""{- Wrong -})) + ,(BangPatterns , fFlag "bang-patterns") + ,(KindSignatures , fglasgowExts) + ,(RecursiveDo , fglasgowExts) + ,(ParallelListComp , fglasgowExts) + ,(MultiParamTypeClasses , fglasgowExts) + ,(FunctionalDependencies , fglasgowExts) + ,(Rank2Types , fglasgowExts) + ,(RankNTypes , fglasgowExts) + ,(PolymorphicComponents , fglasgowExts) + ,(ExistentialQuantification , fglasgowExts) + ,(ScopedTypeVariables , fFlag "scoped-type-variables") + ,(FlexibleContexts , fglasgowExts) + ,(FlexibleInstances , fglasgowExts) + ,(EmptyDataDecls , fglasgowExts) + ,(PatternGuards , fglasgowExts) + ,(GeneralizedNewtypeDeriving , fglasgowExts) + ,(MagicHash , fglasgowExts) + ,(UnicodeSyntax , fglasgowExts) + ,(PatternSignatures , fglasgowExts) + ,(UnliftedFFITypes , fglasgowExts) + ,(LiberalTypeSynonyms , fglasgowExts) + ,(TypeOperators , fglasgowExts) + ,(GADTs , fglasgowExts) + ,(RelaxedPolyRec , fglasgowExts) + ,(ExtendedDefaultRules , fFlag "extended-default-rules") + ,(UnboxedTuples , fglasgowExts) + ,(DeriveDataTypeable , fglasgowExts) + ,(ConstrainedClassMethods , fglasgowExts) + ] + +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity packagedbs conf = do + checkPackageDbStack packagedbs + pkgss <- getInstalledPackages' verbosity packagedbs conf + topDir <- ghcLibDir' verbosity ghcProg + let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs) + | (_, pkgs) <- pkgss ] + return $! hackRtsPackage (mconcat indexes) + + where + -- On Windows, various fields have $topdir/foo rather than full + -- paths. We need to substitute the right value in so that when + -- we, for example, call gcc, we have proper paths to give it + Just ghcProg = lookupProgram ghcProgram conf + + hackRtsPackage index = + case PackageIndex.lookupPackageName index (PackageName "rts") of + [(_,[rts])] + -> PackageIndex.insert (removeMingwIncludeDir rts) index + _ -> index -- No (or multiple) ghc rts package is registered!! + -- Feh, whatever, the ghc testsuite does some crazy stuff. + +ghcLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath +ghcLibDir verbosity lbi = + (reverse . dropWhile isSpace . reverse) `fmap` + rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ["--print-libdir"] + +ghcLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath +ghcLibDir' verbosity ghcProg = + (reverse . dropWhile isSpace . reverse) `fmap` + rawSystemProgramStdout verbosity ghcProg ["--print-libdir"] + +checkPackageDbStack :: PackageDBStack -> IO () +checkPackageDbStack (GlobalPackageDB:rest) + | GlobalPackageDB `notElem` rest = return () +checkPackageDbStack _ = + die $ "GHC.getInstalledPackages: the global package db must be " + ++ "specified first and cannot be specified multiple times" + +-- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This +-- breaks when you want to use a different gcc, so we need to filter +-- it out. +removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo +removeMingwIncludeDir pkg = + let ids = InstalledPackageInfo.includeDirs pkg + ids' = filter (not . ("mingw" `isSuffixOf`)) ids + in pkg { InstalledPackageInfo.includeDirs = ids' } + +-- | Get the packages from specific PackageDBs, not cumulative. +-- +getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration + -> IO [(PackageDB, [InstalledPackageInfo])] +getInstalledPackages' verbosity packagedbs conf + | ghcVersion >= Version [6,9] [] = + sequence + [ do pkgs <- HcPkg.dump verbosity ghcPkgProg packagedb + return (packagedb, pkgs) + | packagedb <- packagedbs ] + + where + Just ghcPkgProg = lookupProgram ghcPkgProgram conf + Just ghcProg = lookupProgram ghcProgram conf + Just ghcVersion = programVersion ghcProg + +getInstalledPackages' verbosity packagedbs conf = do + str <- rawSystemProgramStdoutConf verbosity ghcPkgProgram conf ["list"] + let pkgFiles = [ init line | line <- lines str, last line == ':' ] + dbFile packagedb = case (packagedb, pkgFiles) of + (GlobalPackageDB, global:_) -> return $ Just global + (UserPackageDB, _global:user:_) -> return $ Just user + (UserPackageDB, _global:_) -> return $ Nothing + (SpecificPackageDB specific, _) -> return $ Just specific + _ -> die "cannot read ghc-pkg package listing" + pkgFiles' <- mapM dbFile packagedbs + sequence [ withFileContents file $ \content -> do + pkgs <- readPackages file content + return (db, pkgs) + | (db , Just file) <- zip packagedbs pkgFiles' ] + where + -- Depending on the version of ghc we use a different type's Read + -- instance to parse the package file and then convert. + -- It's a bit yuck. But that's what we get for using Read/Show. + readPackages + | ghcVersion >= Version [6,4,2] [] + = \file content -> case reads content of + [(pkgs, _)] -> return (map IPI642.toCurrent pkgs) + _ -> failToRead file + | otherwise + = \file content -> case reads content of + [(pkgs, _)] -> return (map IPI641.toCurrent pkgs) + _ -> failToRead file + Just ghcProg = lookupProgram ghcProgram conf + Just ghcVersion = programVersion ghcProg + failToRead file = die $ "cannot read ghc package database " ++ file + +substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo +substTopDir topDir ipo + = ipo { + InstalledPackageInfo.importDirs + = map f (InstalledPackageInfo.importDirs ipo), + InstalledPackageInfo.libraryDirs + = map f (InstalledPackageInfo.libraryDirs ipo), + InstalledPackageInfo.includeDirs + = map f (InstalledPackageInfo.includeDirs ipo), + InstalledPackageInfo.frameworkDirs + = map f (InstalledPackageInfo.frameworkDirs ipo), + InstalledPackageInfo.haddockInterfaces + = map f (InstalledPackageInfo.haddockInterfaces ipo), + InstalledPackageInfo.haddockHTMLs + = map f (InstalledPackageInfo.haddockHTMLs ipo) + } + where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest + f x = x + +-- ----------------------------------------------------------------------------- +-- Building + +-- | Build a library with GHC. +-- +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + let pref = buildDir lbi + pkgid = packageId pkg_descr + runGhcProg = rawSystemProgramConf verbosity ghcProgram (withPrograms lbi) + ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi) + ifProfLib = when (withProfLib lbi) + ifSharedLib = when (withSharedLib lbi) + ifGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi) + comp = compiler lbi + + libBi <- hackThreadedFlag verbosity + comp (withProfLib lbi) (libBuildInfo lib) + + let libTargetDir = pref + forceVanillaLib = EnableExtension TemplateHaskell `elem` allExtensions libBi + -- TH always needs vanilla libs, even when building for profiling + + createDirectoryIfMissingVerbose verbosity True libTargetDir + -- TODO: do we need to put hs-boot files into place for mutually recurive modules? + let ghcArgs = + "--make" + : ["-package-name", display pkgid ] + ++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity + ++ map display (libModules lib) + ghcArgsProf = ghcArgs + ++ ["-prof", + "-hisuf", "p_hi", + "-osuf", "p_o" + ] + ++ ghcProfOptions libBi + ghcArgsShared = ghcArgs + ++ ["-dynamic", + "-hisuf", "dyn_hi", + "-osuf", "dyn_o", "-fPIC" + ] + ++ ghcSharedOptions libBi + unless (null (libModules lib)) $ + do ifVanillaLib forceVanillaLib (runGhcProg ghcArgs) + ifProfLib (runGhcProg ghcArgsProf) + ifSharedLib (runGhcProg ghcArgsShared) + + -- build any C sources + unless (null (cSources libBi)) $ do + info verbosity "Building C Sources..." + sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi clbi pref + filename verbosity + False + (withProfLib lbi) + createDirectoryIfMissingVerbose verbosity True odir + runGhcProg args + ifSharedLib (runGhcProg (args ++ ["-fPIC", "-osuf dyn_o"])) + | filename <- cSources libBi] + + -- link: + info verbosity "Linking..." + let cObjs = map (`replaceExtension` objExtension) (cSources libBi) + cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi) + vanillaLibFilePath = libTargetDir mkLibName pkgid + profileLibFilePath = libTargetDir mkProfLibName pkgid + sharedLibFilePath = libTargetDir mkSharedLibName pkgid + (compilerId (compiler lbi)) + ghciLibFilePath = libTargetDir mkGHCiLibName pkgid + libInstallPath = libdir $ absoluteInstallDirs pkg_descr lbi NoCopyDest + sharedLibInstallPath = libInstallPath mkSharedLibName pkgid + (compilerId (compiler lbi)) + + stubObjs <- fmap catMaybes $ sequence + [ findFileWithExtension [objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | x <- libModules lib ] + stubProfObjs <- fmap catMaybes $ sequence + [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | x <- libModules lib ] + stubSharedObjs <- fmap catMaybes $ sequence + [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | x <- libModules lib ] + + hObjs <- getHaskellObjects lib lbi + pref objExtension True + hProfObjs <- + if (withProfLib lbi) + then getHaskellObjects lib lbi + pref ("p_" ++ objExtension) True + else return [] + hSharedObjs <- + if (withSharedLib lbi) + then getHaskellObjects lib lbi + pref ("dyn_" ++ objExtension) False + else return [] + + unless (null hObjs && null cObjs && null stubObjs) $ do + -- first remove library files if they exists + sequence_ + [ removeFile libFilePath `catchIO` \_ -> return () + | libFilePath <- [vanillaLibFilePath, profileLibFilePath + ,sharedLibFilePath, ghciLibFilePath] ] + + let staticObjectFiles = + hObjs + ++ map (pref ) cObjs + ++ stubObjs + profObjectFiles = + hProfObjs + ++ map (pref ) cObjs + ++ stubProfObjs + ghciObjFiles = + hObjs + ++ map (pref ) cObjs + ++ stubObjs + dynamicObjectFiles = + hSharedObjs + ++ map (pref ) cSharedObjs + ++ stubSharedObjs + -- After the relocation lib is created we invoke ghc -shared + -- with the dependencies spelled out as -package arguments + -- and ghc invokes the linker with the proper library paths + ghcSharedLinkArgs = + [ "-no-auto-link-packages", + "-shared", + "-dynamic", + "-o", sharedLibFilePath ] + -- For dynamic libs, Mac OS/X needs to know the install location + -- at build time. + ++ (if buildOS == OSX + then ["-dylib-install-name", sharedLibInstallPath] + else []) + ++ dynamicObjectFiles + ++ ["-package-name", display pkgid ] + ++ ghcPackageFlags lbi clbi + ++ ["-l"++extraLib | extraLib <- extraLibs libBi] + ++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs libBi] + + ifVanillaLib False $ do + (arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi) + Ar.createArLibArchive verbosity arProg + vanillaLibFilePath staticObjectFiles + + ifProfLib $ do + (arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi) + Ar.createArLibArchive verbosity arProg + profileLibFilePath profObjectFiles + + ifGHCiLib $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles verbosity ldProg + ghciLibFilePath ghciObjFiles + + ifSharedLib $ + runGhcProg ghcSharedLinkArgs + + +-- | Build an executable with GHC. +-- +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity _pkg_descr lbi + exe@Executable { exeName = exeName', modulePath = modPath } clbi = do + let pref = buildDir lbi + runGhcProg = rawSystemProgramConf verbosity ghcProgram (withPrograms lbi) + + exeBi <- hackThreadedFlag verbosity + (compiler lbi) (withProfExe lbi) (buildInfo exe) + + -- exeNameReal, the name that GHC really uses (with .exe on Windows) + let exeNameReal = exeName' <.> + (if null $ takeExtension exeName' then exeExtension else "") + + let targetDir = pref exeName' + let exeDir = targetDir (exeName' ++ "-tmp") + createDirectoryIfMissingVerbose verbosity True targetDir + createDirectoryIfMissingVerbose verbosity True exeDir + -- TODO: do we need to put hs-boot files into place for mutually recursive modules? + -- FIX: what about exeName.hi-boot? + + -- build executables + unless (null (cSources exeBi)) $ do + info verbosity "Building C Sources." + sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi clbi + exeDir filename verbosity + (withDynExe lbi) (withProfExe lbi) + createDirectoryIfMissingVerbose verbosity True odir + runGhcProg args + | filename <- cSources exeBi] + + srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath + + let cObjs = map (`replaceExtension` objExtension) (cSources exeBi) + let binArgs linkExe dynExe profExe = + "--make" + : (if linkExe + then ["-o", targetDir exeNameReal] + else ["-c"]) + ++ constructGHCCmdLine lbi exeBi clbi exeDir verbosity + ++ [exeDir x | x <- cObjs] + ++ [srcMainFile] + ++ ["-optl" ++ opt | opt <- PD.ldOptions exeBi] + ++ ["-l"++lib | lib <- extraLibs exeBi] + ++ ["-L"++libDir | libDir <- extraLibDirs exeBi] + ++ concat [["-framework", f] | f <- PD.frameworks exeBi] + ++ if dynExe + then ["-dynamic"] + else [] + ++ if profExe + then ["-prof", + "-hisuf", "p_hi", + "-osuf", "p_o" + ] ++ 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 && EnableExtension TemplateHaskell `elem` allExtensions exeBi) + (runGhcProg (binArgs False (withDynExe lbi) False)) + + runGhcProg (binArgs True (withDynExe lbi) (withProfExe lbi)) + +-- | Filter the "-threaded" flag when profiling as it does not +-- work with ghc-6.8 and older. +hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo +hackThreadedFlag verbosity comp prof bi + | not mustFilterThreaded = return bi + | otherwise = do + warn verbosity $ "The ghc flag '-threaded' is not compatible with " + ++ "profiling in ghc-6.8 and older. It will be disabled." + return bi { options = filterHcOptions (/= "-threaded") (options bi) } + where + mustFilterThreaded = prof && compilerVersion comp < Version [6, 10] [] + && "-threaded" `elem` hcOptions GHC bi + filterHcOptions p hcoptss = + [ (hc, if hc == GHC then filter p opts else opts) + | (hc, opts) <- hcoptss ] + +-- when using -split-objs, we need to search for object files in the +-- Module_split directory for each module. +getHaskellObjects :: Library -> LocalBuildInfo + -> FilePath -> String -> Bool -> IO [FilePath] +getHaskellObjects lib lbi pref wanted_obj_ext allow_split_objs + | splitObjs lbi && allow_split_objs = do + let splitSuffix = if compilerVersion (compiler lbi) < + Version [6, 11] [] + then "_split" + else "_" ++ wanted_obj_ext ++ "_split" + dirs = [ pref (ModuleName.toFilePath x ++ splitSuffix) + | x <- libModules lib ] + objss <- mapM getDirectoryContents dirs + let objs = [ dir obj + | (objs',dir) <- zip objss dirs, obj <- objs', + let obj_ext = takeExtension obj, + '.':wanted_obj_ext == obj_ext ] + return objs + | otherwise = + return [ pref ModuleName.toFilePath x <.> wanted_obj_ext + | x <- libModules lib ] + +-- | Extracts a String representing a hash of the ABI of a built +-- library. It can fail if the library has not yet been built. +-- +libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO String +libAbiHash verbosity pkg_descr lbi lib clbi = do + libBi <- hackThreadedFlag verbosity + (compiler lbi) (withProfLib lbi) (libBuildInfo lib) + let + ghcArgs = + "--abi-hash" + : ["-package-name", display (packageId pkg_descr) ] + ++ constructGHCCmdLine lbi libBi clbi (buildDir lbi) verbosity + ++ map display (exposedModules lib) + -- + rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ghcArgs + + +constructGHCCmdLine + :: LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> Verbosity + -> [String] +constructGHCCmdLine lbi bi clbi odir verbosity = + ghcVerbosityOptions verbosity + -- Unsupported extensions have already been checked by configure + ++ ghcOptions lbi bi clbi odir + +ghcVerbosityOptions :: Verbosity -> [String] +ghcVerbosityOptions verbosity + | verbosity >= deafening = ["-v"] + | verbosity >= normal = [] + | otherwise = ["-w", "-v0"] + +ghcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> [String] +ghcOptions lbi bi clbi odir + = ["-hide-all-packages"] + ++ ["-fbuilding-cabal-package" | ghcVer >= Version [6,11] [] ] + ++ ghcPackageDbOptions (withPackageDB lbi) + ++ ["-split-objs" | splitObjs lbi ] + ++ ["-i"] + ++ ["-i" ++ odir] + ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] + ++ ["-i" ++ autogenModulesDir lbi] + ++ ["-I" ++ autogenModulesDir lbi] + ++ ["-I" ++ odir] + ++ ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ ["-optP" ++ opt | opt <- cppOptions bi] + ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi cppHeaderName) ] + ++ [ "-#include \"" ++ inc ++ "\"" | ghcVer < Version [6,11] [] + , inc <- PD.includes bi ] + ++ [ "-odir", odir, "-hidir", odir ] + ++ concat [ ["-stubdir", odir] | ghcVer >= Version [6,8] [] ] + ++ ghcPackageFlags lbi clbi + ++ (case withOptimization lbi of + NoOptimisation -> [] + NormalOptimisation -> ["-O"] + MaximumOptimisation -> ["-O2"]) + ++ hcOptions GHC bi + ++ languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) + where + ghcVer = compilerVersion (compiler lbi) + +ghcPackageFlags :: LocalBuildInfo -> ComponentLocalBuildInfo -> [String] +ghcPackageFlags lbi clbi + | ghcVer >= Version [6,11] [] + = concat [ ["-package-id", display ipkgid] + | (ipkgid, _) <- componentPackageDeps clbi ] + + | otherwise = concat [ ["-package", display pkgid] + | (_, pkgid) <- componentPackageDeps clbi ] + where + ghcVer = compilerVersion (compiler lbi) + +ghcPackageDbOptions :: PackageDBStack -> [String] +ghcPackageDbOptions dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs + (GlobalPackageDB:dbs) -> "-no-user-package-conf" + : concatMap specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = [ "-package-conf", db ] + specific _ = ierror + ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) + +constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> FilePath -> Verbosity -> Bool -> Bool + ->(FilePath,[String]) +constructCcCmdLine lbi bi clbi pref filename verbosity dynamic profiling + = let odir | compilerVersion (compiler lbi) >= Version [6,4,1] [] = pref + | otherwise = pref takeDirectory filename + -- ghc 6.4.1 fixed a bug in -odir handling + -- for C compilations. + in + (odir, + ghcCcOptions lbi bi clbi odir + ++ (if verbosity >= deafening then ["-v"] else []) + ++ ["-c",filename] + -- Note: When building with profiling enabled, we pass the -prof + -- option to ghc here when compiling C code, so that the PROFILING + -- macro gets defined. The macro is used in ghc's Rts.h in the + -- definitions of closure layouts (Closures.h). + ++ ["-dynamic" | dynamic] + ++ ["-prof" | profiling]) + +ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> [String] +ghcCcOptions lbi bi clbi odir + = ["-I" ++ dir | dir <- odir : PD.includeDirs bi] + ++ ghcPackageDbOptions (withPackageDB lbi) + ++ ghcPackageFlags lbi clbi + ++ ["-optc" ++ opt | opt <- PD.ccOptions bi] + ++ (case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-optc-O2"]) + ++ ["-odir", odir] + +mkGHCiLibName :: PackageIdentifier -> String +mkGHCiLibName lib = "HS" ++ display lib <.> "o" + +-- ----------------------------------------------------------------------------- +-- Installing + +-- |Install executables for GHC. +installExe :: Verbosity + -> LocalBuildInfo + -> InstallDirs FilePath -- ^Where to copy the files to + -> FilePath -- ^Build location + -> (FilePath, FilePath) -- ^Executable (prefix,suffix) + -> PackageDescription + -> Executable + -> IO () +installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do + let binDir = bindir installDirs + createDirectoryIfMissingVerbose verbosity True binDir + let exeFileName = exeName exe <.> exeExtension + fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix + installBinary dest = do + installExecutableFile verbosity + (buildPref exeName exe exeFileName) + (dest <.> exeExtension) + stripExe verbosity lbi exeFileName (dest <.> exeExtension) + installBinary (binDir fixedExeBaseName) + +stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO () +stripExe verbosity lbi name path = when (stripExes lbi) $ + case lookupProgram stripProgram (withPrograms lbi) of + Just strip -> rawSystemProgram verbosity strip args + Nothing -> unless (buildOS == Windows) $ + -- Don't bother warning on windows, we don't expect them to + -- have the strip program anyway. + warn verbosity $ "Unable to strip executable '" ++ name + ++ "' (missing the 'strip' program)" + where + args = path : case buildOS of + OSX -> ["-x"] -- By default, stripping the ghc binary on at least + -- some OS X installations causes: + -- HSbase-3.0.o: unknown symbol `_environ'" + -- The -x flag fixes that. + _ -> [] + +-- |Install for ghc, .hi, .a and, if --with-ghci given, .o +installLib :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^install location + -> FilePath -- ^install location for dynamic librarys + -> FilePath -- ^Build location + -> PackageDescription + -> Library + -> IO () +installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do + -- copy .hi files over: + let copyHelper installFun src dst n = do + createDirectoryIfMissingVerbose verbosity True dst + installFun verbosity (src n) (dst n) + copy = copyHelper installOrdinaryFile + copyShared = copyHelper installExecutableFile + copyModuleFiles ext = + findModuleFiles [builtDir] [ext] (libModules lib) + >>= installOrdinaryFiles verbosity targetDir + ifVanilla $ copyModuleFiles "hi" + ifProf $ copyModuleFiles "p_hi" + ifShared $ copyModuleFiles "dyn_hi" + + -- copy the built library files over: + ifVanilla $ copy builtDir targetDir vanillaLibName + ifProf $ copy builtDir targetDir profileLibName + ifGHCi $ copy builtDir targetDir ghciLibName + ifShared $ copyShared builtDir dynlibTargetDir sharedLibName + + -- run ranlib if necessary: + ifVanilla $ updateLibArchive verbosity lbi + (targetDir vanillaLibName) + ifProf $ updateLibArchive verbosity lbi + (targetDir profileLibName) + + where + vanillaLibName = mkLibName pkgid + profileLibName = mkProfLibName pkgid + ghciLibName = mkGHCiLibName pkgid + sharedLibName = mkSharedLibName pkgid (compilerId (compiler lbi)) + + pkgid = packageId pkg + + hasLib = not $ null (libModules lib) + && null (cSources (libBuildInfo lib)) + ifVanilla = when (hasLib && withVanillaLib lbi) + ifProf = when (hasLib && withProfLib lbi) + ifGHCi = when (hasLib && withGHCiLib lbi) + ifShared = when (hasLib && withSharedLib lbi) + +-- | On MacOS X we have to call @ranlib@ to regenerate the archive index after +-- copying. This is because the silly MacOS X linker checks that the archive +-- index is not older than the file itself, which means simply +-- copying/installing the file breaks it!! +-- +updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO () +updateLibArchive verbosity lbi path + | buildOS == OSX = do + (ranlib, _) <- requireProgram verbosity ranlibProgram (withPrograms lbi) + rawSystemProgram verbosity ranlib [path] + | otherwise = return () + + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage + :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do + let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi) + HcPkg.reregister verbosity ghcPkg packageDbs (Right installedPkgInfo) diff --git a/cabal/cabal/Distribution/Simple/GHC/IPI641.hs b/cabal/cabal/Distribution/Simple/GHC/IPI641.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/GHC/IPI641.hs @@ -0,0 +1,129 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.GHC.IPI641 +-- Copyright : (c) The University of Glasgow 2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- + +{- 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. -} + +module Distribution.Simple.GHC.IPI641 ( + InstalledPackageInfo, + toCurrent, + ) where + +import qualified Distribution.InstalledPackageInfo as Current +import qualified Distribution.Package as Current hiding (depends) +import Distribution.Text (display) + +import Distribution.Simple.GHC.IPI642 + ( PackageIdentifier, convertPackageId + , License, convertLicense, convertModuleName ) + +-- | This is the InstalledPackageInfo type used by ghc-6.4 and 6.4.1. +-- +-- It's here purely for the 'Read' instance so that we can read the package +-- database used by those ghc versions. It is a little hacky to read the +-- package db directly, but we do need the info and until ghc-6.9 there was +-- no better method. +-- +-- In ghc-6.4.2 the format changed a bit. See "Distribution.Simple.GHC.IPI642" +-- +data InstalledPackageInfo = InstalledPackageInfo { + package :: PackageIdentifier, + license :: License, + copyright :: String, + maintainer :: String, + author :: String, + stability :: String, + homepage :: String, + pkgUrl :: String, + description :: String, + category :: String, + exposed :: Bool, + exposedModules :: [String], + hiddenModules :: [String], + importDirs :: [FilePath], + libraryDirs :: [FilePath], + hsLibraries :: [String], + extraLibraries :: [String], + includeDirs :: [FilePath], + includes :: [String], + depends :: [PackageIdentifier], + hugsOptions :: [String], + ccOptions :: [String], + ldOptions :: [String], + frameworkDirs :: [FilePath], + frameworks :: [String], + haddockInterfaces :: [FilePath], + haddockHTMLs :: [FilePath] + } + deriving Read + +mkInstalledPackageId :: Current.PackageIdentifier -> Current.InstalledPackageId +mkInstalledPackageId = Current.InstalledPackageId . display + +toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo +toCurrent ipi@InstalledPackageInfo{} = Current.InstalledPackageInfo { + Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)), + Current.sourcePackageId = convertPackageId (package ipi), + Current.license = convertLicense (license ipi), + Current.copyright = copyright ipi, + Current.maintainer = maintainer ipi, + Current.author = author ipi, + Current.stability = stability ipi, + Current.homepage = homepage ipi, + Current.pkgUrl = pkgUrl ipi, + Current.synopsis = "", + Current.description = description ipi, + Current.category = category ipi, + Current.exposed = exposed ipi, + Current.exposedModules = map convertModuleName (exposedModules ipi), + Current.hiddenModules = map convertModuleName (hiddenModules ipi), + Current.trusted = False, + Current.importDirs = importDirs ipi, + Current.libraryDirs = libraryDirs ipi, + Current.hsLibraries = hsLibraries ipi, + Current.extraLibraries = extraLibraries ipi, + Current.extraGHCiLibraries = [], + Current.includeDirs = includeDirs ipi, + Current.includes = includes ipi, + Current.depends = map (mkInstalledPackageId.convertPackageId) (depends ipi), + Current.hugsOptions = hugsOptions ipi, + Current.ccOptions = ccOptions ipi, + Current.ldOptions = ldOptions ipi, + Current.frameworkDirs = frameworkDirs ipi, + Current.frameworks = frameworks ipi, + Current.haddockInterfaces = haddockInterfaces ipi, + Current.haddockHTMLs = haddockHTMLs ipi + } diff --git a/cabal/cabal/Distribution/Simple/GHC/IPI642.hs b/cabal/cabal/Distribution/Simple/GHC/IPI642.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/GHC/IPI642.hs @@ -0,0 +1,164 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.GHC.IPI642 +-- Copyright : (c) The University of Glasgow 2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- + +{- 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. -} + +module Distribution.Simple.GHC.IPI642 ( + InstalledPackageInfo, + toCurrent, + + -- Don't use these, they're only for conversion purposes + PackageIdentifier, convertPackageId, + License, convertLicense, + convertModuleName + ) where + +import qualified Distribution.InstalledPackageInfo as Current +import qualified Distribution.Package as Current hiding (depends) +import qualified Distribution.License as Current + +import Distribution.Version (Version) +import Distribution.ModuleName (ModuleName) +import Distribution.Text (simpleParse,display) + +import Data.Maybe + +-- | This is the InstalledPackageInfo type used by ghc-6.4.2 and later. +-- +-- It's here purely for the 'Read' instance so that we can read the package +-- database used by those ghc versions. It is a little hacky to read the +-- package db directly, but we do need the info and until ghc-6.9 there was +-- no better method. +-- +-- In ghc-6.4.1 and before the format was slightly different. +-- See "Distribution.Simple.GHC.IPI642" +-- +data InstalledPackageInfo = InstalledPackageInfo { + package :: PackageIdentifier, + license :: License, + copyright :: String, + maintainer :: String, + author :: String, + stability :: String, + homepage :: String, + pkgUrl :: String, + description :: String, + category :: String, + exposed :: Bool, + exposedModules :: [String], + hiddenModules :: [String], + importDirs :: [FilePath], + libraryDirs :: [FilePath], + hsLibraries :: [String], + extraLibraries :: [String], + extraGHCiLibraries:: [String], + includeDirs :: [FilePath], + includes :: [String], + depends :: [PackageIdentifier], + hugsOptions :: [String], + ccOptions :: [String], + ldOptions :: [String], + frameworkDirs :: [FilePath], + frameworks :: [String], + haddockInterfaces :: [FilePath], + haddockHTMLs :: [FilePath] + } + deriving Read + +data PackageIdentifier = PackageIdentifier { + pkgName :: String, + pkgVersion :: Version + } + deriving Read + +data License = GPL | LGPL | BSD3 | BSD4 + | PublicDomain | AllRightsReserved | OtherLicense + deriving Read + +convertPackageId :: PackageIdentifier -> Current.PackageIdentifier +convertPackageId PackageIdentifier { pkgName = n, pkgVersion = v } = + Current.PackageIdentifier (Current.PackageName n) v + +mkInstalledPackageId :: Current.PackageIdentifier -> Current.InstalledPackageId +mkInstalledPackageId = Current.InstalledPackageId . display + +convertModuleName :: String -> ModuleName +convertModuleName s = fromJust $ simpleParse s + +convertLicense :: License -> Current.License +convertLicense GPL = Current.GPL Nothing +convertLicense LGPL = Current.LGPL Nothing +convertLicense BSD3 = Current.BSD3 +convertLicense BSD4 = Current.BSD4 +convertLicense PublicDomain = Current.PublicDomain +convertLicense AllRightsReserved = Current.AllRightsReserved +convertLicense OtherLicense = Current.OtherLicense + +toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo +toCurrent ipi@InstalledPackageInfo{} = Current.InstalledPackageInfo { + Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)), + Current.sourcePackageId = convertPackageId (package ipi), + Current.license = convertLicense (license ipi), + Current.copyright = copyright ipi, + Current.maintainer = maintainer ipi, + Current.author = author ipi, + Current.stability = stability ipi, + Current.homepage = homepage ipi, + Current.pkgUrl = pkgUrl ipi, + Current.synopsis = "", + Current.description = description ipi, + Current.category = category ipi, + Current.exposed = exposed ipi, + Current.exposedModules = map convertModuleName (exposedModules ipi), + Current.hiddenModules = map convertModuleName (hiddenModules ipi), + Current.trusted = False, + Current.importDirs = importDirs ipi, + Current.libraryDirs = libraryDirs ipi, + Current.hsLibraries = hsLibraries ipi, + Current.extraLibraries = extraLibraries ipi, + Current.extraGHCiLibraries = extraGHCiLibraries ipi, + Current.includeDirs = includeDirs ipi, + Current.includes = includes ipi, + Current.depends = map (mkInstalledPackageId.convertPackageId) (depends ipi), + Current.hugsOptions = hugsOptions ipi, + Current.ccOptions = ccOptions ipi, + Current.ldOptions = ldOptions ipi, + Current.frameworkDirs = frameworkDirs ipi, + Current.frameworks = frameworks ipi, + Current.haddockInterfaces = haddockInterfaces ipi, + Current.haddockHTMLs = haddockHTMLs ipi + } diff --git a/cabal/cabal/Distribution/Simple/Haddock.hs b/cabal/cabal/Distribution/Simple/Haddock.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Haddock.hs @@ -0,0 +1,629 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Haddock +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module deals with the @haddock@ and @hscolour@ commands. Sadly this is +-- a rather complicated module. It deals with two versions of haddock (0.x and +-- 2.x). It has to do pre-processing for haddock 0.x which involves +-- \'unlit\'ing and using @-DHADDOCK@ for any source code that uses @cpp@. It +-- uses information about installed packages (from @ghc-pkg@) to find the +-- locations of documentation for dependent packages, so it can create links. +-- +-- The @hscolour@ support allows generating html versions of the original +-- source, with coloured syntax highlighting. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.Haddock ( + haddock, hscolour + ) where + +-- local +import Distribution.Package + ( PackageIdentifier, Package(..), packageName ) +import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(..), allExtensions + , Library(..), hasLibs, Executable(..) ) +import Distribution.Simple.Compiler + ( Compiler(..), compilerVersion ) +import Distribution.Simple.GHC ( ghcLibDir ) +import Distribution.Simple.Program + ( ConfiguredProgram(..), requireProgramVersion + , rawSystemProgram, rawSystemProgramStdout + , hscolourProgram, haddockProgram ) +import Distribution.Simple.PreProcess (ppCpp', ppUnlit + , PPSuffixHandler, runSimplePreProcessor + , preprocessComponent) +import Distribution.Simple.Setup + ( defaultHscolourFlags, Flag(..), flagToMaybe, fromFlag + , HaddockFlags(..), HscolourFlags(..) ) +import Distribution.Simple.Build (initialBuildSteps) +import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplate, + PathTemplateVariable(..), + toPathTemplate, fromPathTemplate, + substPathTemplate, + initialPathTemplateEnv) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), externalPackageDeps + , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI ) +import Distribution.Simple.BuildPaths ( haddockName, + hscolourPref, autogenModulesDir, + ) +import Distribution.Simple.PackageIndex (dependencyClosure) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo + ( InstalledPackageInfo_(..) ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo ) +import Distribution.Simple.Utils + ( die, warn, notice, intercalate, setupMessage + , createDirectoryIfMissingVerbose, withTempFile, copyFileVerbose + , withTempDirectory + , findFileWithExtension, findFile ) +import Distribution.Simple.GHC (ghcOptions) +import Distribution.Text + ( display, simpleParse ) + +import Distribution.Verbosity +import Language.Haskell.Extension +-- Base +import System.Directory(removeFile, doesFileExist, createDirectoryIfMissing) + +import Control.Monad ( when, guard ) +import Control.Exception (assert) +import Data.Monoid +import Data.Maybe ( fromMaybe, listToMaybe ) + +import System.FilePath((), (<.>), splitFileName, splitExtension, + normalise, splitPath, joinPath) +import System.IO (hClose, hPutStrLn) +import Distribution.Version + +-- Types + +-- | record that represents the arguments to the haddock executable, a product monoid. +data HaddockArgs = HaddockArgs { + argInterfaceFile :: Flag FilePath, -- ^ path of the interface file, relative to argOutputDir, required. + argPackageName :: Flag PackageIdentifier, -- ^ package name, required. + argHideModules :: (All,[ModuleName.ModuleName]), -- ^ (hide modules ?, modules to hide) + argIgnoreExports :: Any, -- ^ ingore export lists in modules? + argLinkSource :: Flag (Template,Template), -- ^ (template for modules, template for symbols) + argCssFile :: Flag FilePath, -- ^ optinal custom css file. + argVerbose :: Any, + argOutput :: Flag [Output], -- ^ Html or Hoogle doc or both? required. + argInterfaces :: [(FilePath, Maybe FilePath)], -- ^ [(interface file, path to the html docs for links)] + argOutputDir :: Directory, -- ^ where to generate the documentation. + argTitle :: Flag String, -- ^ page's title, required. + argPrologue :: Flag String, -- ^ prologue text, required. + argGhcFlags :: [String], -- ^ additional flags to pass to ghc for haddock-2 + argGhcLibDir :: Flag FilePath, -- ^ to find the correct ghc, required by haddock-2. + argTargets :: [FilePath] -- ^ modules to process. +} + +-- | the FilePath of a directory, it's a monoid under () +newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord) + +unDir :: Directory -> FilePath +unDir = joinPath . filter (\p -> p /="./" && p /= ".") . splitPath . unDir' + +type Template = String + +data Output = Html | Hoogle + +-- -------------------------------------------------------------------------- +-- Haddock support + +haddock :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO () +haddock pkg_descr _ _ haddockFlags + | not (hasLibs pkg_descr) + && not (fromFlag $ haddockExecutables haddockFlags) = + warn (fromFlag $ haddockVerbosity haddockFlags) $ + "No documentation was generated as this package does not contain " + ++ "a library. Perhaps you want to use the --executables flag." + +haddock pkg_descr lbi suffixes flags = do + + setupMessage verbosity "Running Haddock for" (packageId pkg_descr) + (confHaddock, version, _) <- + requireProgramVersion verbosity haddockProgram + (orLaterVersion (Version [0,6] [])) (withPrograms lbi) + + -- various sanity checks + let isVersion2 = version >= Version [2,0] [] + + when ( flag haddockHoogle + && version > Version [2] [] + && version < Version [2,2] []) $ + die "haddock 2.0 and 2.1 do not support the --hoogle flag." + + when (flag haddockHscolour && version < Version [0,8] []) $ + die "haddock --hyperlink-source requires Haddock version 0.8 or later" + + when isVersion2 $ do + haddockGhcVersionStr <- rawSystemProgramStdout verbosity confHaddock + ["--ghc-version"] + case simpleParse haddockGhcVersionStr of + Nothing -> die "Could not get GHC version from Haddock" + Just haddockGhcVersion + | haddockGhcVersion == ghcVersion -> return () + | otherwise -> die $ + "Haddock's internal GHC version must match the configured " + ++ "GHC version.\n" + ++ "The GHC version is " ++ display ghcVersion ++ " but " + ++ "haddock is using GHC version " ++ display haddockGhcVersion + where ghcVersion = compilerVersion (compiler lbi) + + -- the tools match the requests, we can proceed + + initialBuildSteps (flag haddockDistPref) pkg_descr lbi verbosity + + when (flag haddockHscolour) $ hscolour' pkg_descr lbi suffixes $ + defaultHscolourFlags `mappend` haddockToHscolour flags + + args <- fmap mconcat . sequence $ + [ getInterfaces verbosity lbi (flagToMaybe (haddockHtmlLocation flags)) + , getGhcLibDir verbosity lbi isVersion2 ] + ++ map return + [ fromFlags flags + , fromPackageDescription pkg_descr ] + + let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes + withComponentsLBI pkg_descr lbi $ \comp clbi -> do + pre comp + case comp of + CLib lib -> do + withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do + let bi = libBuildInfo lib + libArgs <- fromLibrary tmp lbi lib clbi + libArgs' <- prepareSources verbosity tmp + lbi isVersion2 bi (args `mappend` libArgs) + runHaddock verbosity confHaddock libArgs' + CExe exe -> when (flag haddockExecutables) $ do + withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do + let bi = buildInfo exe + exeArgs <- fromExecutable tmp lbi exe clbi + exeArgs' <- prepareSources verbosity tmp + lbi isVersion2 bi (args `mappend` exeArgs) + runHaddock verbosity confHaddock exeArgs' + _ -> return () + where + verbosity = flag haddockVerbosity + flag f = fromFlag $ f flags + +-- | performs cpp and unlit preprocessing where needed on the files in +-- | argTargets, which must have an .hs or .lhs extension. +prepareSources :: Verbosity + -> FilePath + -> LocalBuildInfo + -> Bool -- haddock == 2.* + -> BuildInfo + -> HaddockArgs + -> IO HaddockArgs +prepareSources verbosity tmp lbi isVersion2 bi args@HaddockArgs{argTargets=files} = + mapM (mockPP tmp) files >>= \targets -> return args {argTargets=targets} + where + mockPP pref file = do + let (filePref, fileName) = splitFileName file + targetDir = pref filePref + targetFile = targetDir fileName + (targetFileNoext, targetFileExt) = splitExtension $ targetFile + hsFile = targetFileNoext <.> "hs" + + assert (targetFileExt `elem` [".lhs",".hs"]) $ return () + + createDirectoryIfMissing True targetDir + + if needsCpp + then do + runSimplePreProcessor (ppCpp' defines bi lbi) + file targetFile verbosity + else + copyFileVerbose verbosity file targetFile + + when (targetFileExt == ".lhs") $ do + runSimplePreProcessor ppUnlit targetFile hsFile verbosity + removeFile targetFile + + return hsFile + needsCpp = EnableExtension CPP `elem` allExtensions bi + defines | isVersion2 = [] + | otherwise = ["-D__HADDOCK__"] + +-------------------------------------------------------------------------------------------------- +-- constributions to HaddockArgs + +fromFlags :: HaddockFlags -> HaddockArgs +fromFlags flags = + mempty { + argHideModules = (maybe mempty (All . not) $ flagToMaybe (haddockInternal flags), mempty), + argLinkSource = if fromFlag (haddockHscolour flags) + then Flag ("src/%{MODULE/./-}.html" + ,"src/%{MODULE/./-}.html#%{NAME}") + else NoFlag, + argCssFile = haddockCss flags, + argVerbose = maybe mempty (Any . (>= deafening)) . flagToMaybe $ haddockVerbosity flags, + argOutput = + Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++ + [ Hoogle | Flag True <- [haddockHoogle flags] ] + of [] -> [ Html ] + os -> os, + argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags + } + +fromPackageDescription :: PackageDescription -> HaddockArgs +fromPackageDescription pkg_descr = + mempty { + argInterfaceFile = Flag $ haddockName pkg_descr, + argPackageName = Flag $ packageId $ pkg_descr, + argOutputDir = Dir $ "doc" "html" display (packageName pkg_descr), + argPrologue = Flag $ if null desc then synopsis pkg_descr else desc, + argTitle = Flag $ showPkg ++ subtitle + } + where + desc = PD.description pkg_descr + showPkg = display (packageId pkg_descr) + subtitle | null (synopsis pkg_descr) = "" + | otherwise = ": " ++ synopsis pkg_descr + +fromLibrary :: FilePath + -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo + -> IO HaddockArgs +fromLibrary tmp lbi lib clbi = + do inFiles <- map snd `fmap` getLibSourceFiles lbi lib + return $ mempty { + argHideModules = (mempty,otherModules $ bi), + argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi) + -- Noooooooooo!!!!!111 + -- haddock stomps on our precious .hi + -- and .o files. Workaround by telling + -- haddock to write them elsewhere. + ++ [ "-odir", tmp, "-hidir", tmp + , "-stubdir", tmp ], + argTargets = inFiles + } + where + bi = libBuildInfo lib + +fromExecutable :: FilePath + -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo + -> IO HaddockArgs +fromExecutable tmp lbi exe clbi = + do inFiles <- map snd `fmap` getExeSourceFiles lbi exe + return $ mempty { + argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi) + -- Noooooooooo!!!!!111 + -- haddock stomps on our precious .hi + -- and .o files. Workaround by telling + -- haddock to write them elsewhere. + ++ [ "-odir", tmp, "-hidir", tmp + , "-stubdir", tmp ], + argOutputDir = Dir (exeName exe), + argTitle = Flag (exeName exe), + argTargets = inFiles + } + where + bi = buildInfo exe + +getInterfaces :: Verbosity + -> LocalBuildInfo + -> Maybe String -- ^ template for html location + -> IO HaddockArgs +getInterfaces verbosity lbi location = do + let htmlTemplate = fmap toPathTemplate $ location + (packageFlags, warnings) <- haddockPackageFlags lbi htmlTemplate + maybe (return ()) (warn verbosity) warnings + return $ mempty { + argInterfaces = packageFlags + } + +getGhcLibDir :: Verbosity -> LocalBuildInfo + -> Bool -- ^ are we using haddock-2.x ? + -> IO HaddockArgs +getGhcLibDir verbosity lbi isVersion2 + | isVersion2 = + do l <- ghcLibDir verbosity lbi + return $ mempty { argGhcLibDir = Flag l } + | otherwise = + return mempty + +---------------------------------------------------------------------------------------------- + +-- | Call haddock with the specified arguments. +runHaddock :: Verbosity -> ConfiguredProgram -> HaddockArgs -> IO () +runHaddock verbosity confHaddock args = do + let haddockVersion = fromMaybe (error "unable to determine haddock version") + (programVersion confHaddock) + renderArgs verbosity haddockVersion args $ \(flags,result)-> do + + rawSystemProgram verbosity confHaddock flags + + notice verbosity $ "Documentation created: " ++ result + + +renderArgs :: Verbosity + -> Version + -> HaddockArgs + -> (([[Char]], FilePath) -> IO a) + -> IO a +renderArgs verbosity version args k = do + createDirectoryIfMissingVerbose verbosity True outputDir + withTempFile outputDir "haddock-prolog.txt" $ \prologFileName h -> do + do + hPutStrLn h $ fromFlag $ argPrologue args + hClose h + let pflag = (:[]).("--prologue="++) $ prologFileName + k $ (pflag ++ renderPureArgs version args, result) + where + isVersion2 = version >= Version [2,0] [] + outputDir = (unDir $ argOutputDir args) + result = intercalate ", " + . map (\o -> outputDir + case o of + Html -> "index.html" + Hoogle -> pkgstr <.> "txt") + $ arg argOutput + where + pkgstr | isVersion2 = display $ packageName pkgid + | otherwise = display pkgid + pkgid = arg argPackageName + arg f = fromFlag $ f args + +renderPureArgs :: Version -> HaddockArgs -> [[Char]] +renderPureArgs version args = concat + [ + (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) f) + . fromFlag . argInterfaceFile $ args, + (\pkgName -> if isVersion2 + then ["--optghc=-package-name", "--optghc=" ++ pkgName] + else ["--package=" ++ pkgName]) . display . fromFlag . argPackageName $ args, + (\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b) . argHideModules $ args, + bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args, + maybe [] (\(m,e) -> ["--source-module=" ++ m + ,"--source-entity=" ++ e]) . flagToMaybe . argLinkSource $ args, + maybe [] ((:[]).("--css="++)) . flagToMaybe . argCssFile $ args, + bool [] [verbosityFlag] . getAny . argVerbose $ args, + map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html") . fromFlag . argOutput $ args, + renderInterfaces . argInterfaces $ args, + (:[]).("--odir="++) . unDir . argOutputDir $ args, + (:[]).("--title="++) . (bool (++" (internal documentation)") id (getAny $ argIgnoreExports args)) + . fromFlag . argTitle $ args, + bool id (const []) isVersion2 . map ("--optghc=" ++) . argGhcFlags $ args, + maybe [] (\l -> ["-B"++l]) $ guard isVersion2 >> flagToMaybe (argGhcLibDir args), -- error if isVersion2 and Nothing? + argTargets $ args + ] + where + renderInterfaces = map (\(i,mh) -> "--read-interface=" ++ maybe "" (++",") mh ++ i) + bool a b c = if c then a else b + isVersion2 = version >= Version [2,0] [] + isVersion2_5 = version >= Version [2,5] [] + verbosityFlag + | isVersion2_5 = "--verbosity=1" + | otherwise = "--verbose" + +----------------------------------------------------------------------------------------------------------- + +haddockPackageFlags :: LocalBuildInfo + -> Maybe PathTemplate + -> IO ([(FilePath,Maybe FilePath)], Maybe String) +haddockPackageFlags lbi htmlTemplate = do + let allPkgs = installedPkgs lbi + directDeps = map fst (externalPackageDeps lbi) + transitiveDeps <- case dependencyClosure allPkgs directDeps of + Left x -> return x + Right _ -> die "Can't find transitive deps for haddock" + interfaces <- sequence + [ case interfaceAndHtmlPath ipkg of + Nothing -> return (Left (packageId ipkg)) + Just (interface, html) -> do + exists <- doesFileExist interface + if exists + then return (Right (interface, html)) + else return (Left (packageId ipkg)) + | ipkg <- PackageIndex.allPackages transitiveDeps ] + + let missing = [ pkgid | Left pkgid <- interfaces ] + warning = "The documentation for the following packages are not " + ++ "installed. No links will be generated to these packages: " + ++ intercalate ", " (map display missing) + flags = [ (interface, if null html then Nothing else Just html) + | Right (interface, html) <- interfaces ] + + return (flags, if null missing then Nothing else Just warning) + + where + interfaceAndHtmlPath :: InstalledPackageInfo -> Maybe (FilePath, FilePath) + interfaceAndHtmlPath pkg = do + interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg) + html <- case htmlTemplate of + Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg) + Just htmlPathTemplate -> Just (expandTemplateVars htmlPathTemplate) + return (interface, html) + + where expandTemplateVars = fromPathTemplate . substPathTemplate env + env = (PrefixVar, prefix (installDirTemplates lbi)) + : initialPathTemplateEnv (packageId pkg) (compilerId (compiler lbi)) + +-- -------------------------------------------------------------------------- +-- hscolour support + +hscolour :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags -> IO () +hscolour pkg_descr lbi suffixes flags = do + -- we preprocess even if hscolour won't be found on the machine + -- will this upset someone? + initialBuildSteps distPref pkg_descr lbi verbosity + hscolour' pkg_descr lbi suffixes flags + where + verbosity = fromFlag (hscolourVerbosity flags) + distPref = fromFlag $ hscolourDistPref flags + +hscolour' :: PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HscolourFlags + -> IO () +hscolour' pkg_descr lbi suffixes flags = do + let distPref = fromFlag $ hscolourDistPref flags + (hscolourProg, _, _) <- + requireProgramVersion + verbosity hscolourProgram + (orLaterVersion (Version [1,8] [])) (withPrograms lbi) + + setupMessage verbosity "Running hscolour for" (packageId pkg_descr) + createDirectoryIfMissingVerbose verbosity True $ hscolourPref distPref pkg_descr + + let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes + withComponentsLBI pkg_descr lbi $ \comp _ -> do + pre comp + case comp of + CLib lib -> do + let outputDir = hscolourPref distPref pkg_descr "src" + runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib + CExe exe | fromFlag (hscolourExecutables flags) -> do + let outputDir = hscolourPref distPref pkg_descr exeName exe "src" + runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe + _ -> return () + where + stylesheet = flagToMaybe (hscolourCSS flags) + + verbosity = fromFlag (hscolourVerbosity flags) + + runHsColour prog outputDir moduleFiles = do + createDirectoryIfMissingVerbose verbosity True outputDir + + case stylesheet of -- copy the CSS file + Nothing | programVersion prog >= Just (Version [1,9] []) -> + rawSystemProgram verbosity prog + ["-print-css", "-o" ++ outputDir "hscolour.css"] + | otherwise -> return () + Just s -> copyFileVerbose verbosity s (outputDir "hscolour.css") + + flip mapM_ moduleFiles $ \(m, inFile) -> + rawSystemProgram verbosity prog + ["-css", "-anchor", "-o" ++ outFile m, inFile] + where + outFile m = outputDir intercalate "-" (ModuleName.components m) <.> "html" + +haddockToHscolour :: HaddockFlags -> HscolourFlags +haddockToHscolour flags = + HscolourFlags { + hscolourCSS = haddockHscolourCss flags, + hscolourExecutables = haddockExecutables flags, + hscolourVerbosity = haddockVerbosity flags, + hscolourDistPref = haddockDistPref flags + } +---------------------------------------------------------------------------------------------- +-- TODO these should be moved elsewhere. + +getLibSourceFiles :: LocalBuildInfo + -> Library + -> IO [(ModuleName.ModuleName, FilePath)] +getLibSourceFiles lbi lib = getSourceFiles searchpaths modules + where + bi = libBuildInfo lib + modules = PD.exposedModules lib ++ otherModules bi + searchpaths = autogenModulesDir lbi : buildDir lbi : hsSourceDirs bi + +getExeSourceFiles :: LocalBuildInfo + -> Executable + -> IO [(ModuleName.ModuleName, FilePath)] +getExeSourceFiles lbi exe = do + moduleFiles <- getSourceFiles searchpaths modules + srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe) + return ((ModuleName.main, srcMainPath) : moduleFiles) + where + bi = buildInfo exe + modules = otherModules bi + searchpaths = autogenModulesDir lbi : exeBuildDir lbi exe : hsSourceDirs bi + +getSourceFiles :: [FilePath] + -> [ModuleName.ModuleName] + -> IO [(ModuleName.ModuleName, FilePath)] +getSourceFiles dirs modules = flip mapM modules $ \m -> fmap ((,) m) $ + findFileWithExtension ["hs", "lhs"] dirs (ModuleName.toFilePath m) + >>= maybe (notFound m) (return . normalise) + where + notFound module_ = die $ "can't find source for module " ++ display module_ + +-- | The directory where we put build results for an executable +exeBuildDir :: LocalBuildInfo -> Executable -> FilePath +exeBuildDir lbi exe = buildDir lbi exeName exe exeName exe ++ "-tmp" + +--------------------------------------------------------------------------------------------- + + + + +-- boilerplate monoid instance. +instance Monoid HaddockArgs where + mempty = HaddockArgs { + argInterfaceFile = mempty, + argPackageName = mempty, + argHideModules = mempty, + argIgnoreExports = mempty, + argLinkSource = mempty, + argCssFile = mempty, + argVerbose = mempty, + argOutput = mempty, + argInterfaces = mempty, + argOutputDir = mempty, + argTitle = mempty, + argPrologue = mempty, + argGhcFlags = mempty, + argGhcLibDir = mempty, + argTargets = mempty + } + mappend a b = HaddockArgs { + argInterfaceFile = mult argInterfaceFile, + argPackageName = mult argPackageName, + argHideModules = mult argHideModules, + argIgnoreExports = mult argIgnoreExports, + argLinkSource = mult argLinkSource, + argCssFile = mult argCssFile, + argVerbose = mult argVerbose, + argOutput = mult argOutput, + argInterfaces = mult argInterfaces, + argOutputDir = mult argOutputDir, + argTitle = mult argTitle, + argPrologue = mult argPrologue, + argGhcFlags = mult argGhcFlags, + argGhcLibDir = mult argGhcLibDir, + argTargets = mult argTargets + } + where mult f = f a `mappend` f b + +instance Monoid Directory where + mempty = Dir "." + mappend (Dir m) (Dir n) = Dir $ m n diff --git a/cabal/cabal/Distribution/Simple/Hpc.hs b/cabal/cabal/Distribution/Simple/Hpc.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Hpc.hs @@ -0,0 +1,185 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Hpc +-- Copyright : Thomas Tuegel 2011 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides functions for locating various HPC-related paths and +-- a function for adding the necessary options to a PackageDescription to +-- build test suites with HPC enabled. + +{- 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.Hpc + ( hpcDir + , enableCoverage + , tixDir + , tixFilePath + , doHpcMarkup + , findTixFiles + ) where + +import Control.Exception ( bracket ) +import Control.Monad ( unless, when ) +import Distribution.Compiler ( CompilerFlavor(..) ) +import Distribution.ModuleName ( main ) +import Distribution.PackageDescription + ( BuildInfo(..) + , Library(..) + , PackageDescription(..) + , TestSuite(..) + , testModules + ) +import Distribution.Simple.Utils ( die, notice ) +import Distribution.Text +import Distribution.Verbosity ( Verbosity() ) +import System.Directory ( doesFileExist, getDirectoryContents, removeFile ) +import System.Exit ( ExitCode(..) ) +import System.FilePath +import System.IO ( hClose, IOMode(..), openFile, openTempFile ) +import System.Process ( runProcess, waitForProcess ) + +-- ------------------------------------------------------------------------- +-- Haskell Program Coverage + +-- | Conditionally enable Haskell Program Coverage by adding the necessary +-- GHC options to a PackageDescription. +-- +-- TODO: do this differently in the build stage by constructing local build +-- info, not by modifying the original PackageDescription. +-- +enableCoverage :: Bool -- ^ Enable coverage? + -> String -- ^ \"dist/\" prefix + -> PackageDescription + -> PackageDescription +enableCoverage False _ x = x +enableCoverage True distPref p = + p { library = fmap enableLibCoverage (library p) + , testSuites = map enableTestCoverage (testSuites p) + } + where + enableBICoverage name oldBI = + let oldOptions = options oldBI + oldGHCOpts = lookup GHC oldOptions + newGHCOpts = case oldGHCOpts of + Just xs -> (GHC, hpcOpts ++ xs) + _ -> (GHC, hpcOpts) + newOptions = (:) newGHCOpts $ filter ((== GHC) . fst) oldOptions + hpcOpts = ["-fhpc", "-hpcdir", hpcDir distPref name] + in oldBI { options = newOptions } + enableLibCoverage l = + l { libBuildInfo = enableBICoverage (display $ package p) + (libBuildInfo l) + } + enableTestCoverage t = + t { testBuildInfo = enableBICoverage (testName t) (testBuildInfo t) } + +hpcDir :: FilePath -- ^ \"dist/\" prefix + -> FilePath -- ^ Component subdirectory name + -> FilePath -- ^ Directory containing component's HPC .mix files +hpcDir distPref name = distPref "hpc" name + +tixDir :: FilePath -- ^ \"dist/\" prefix + -> TestSuite -- ^ Test suite + -> FilePath -- ^ Directory containing test suite's .tix files +tixDir distPref suite = distPref "test" testName suite + +-- | Path to the .tix file containing a test suite's sum statistics. +tixFilePath :: FilePath -- ^ \"dist/\" prefix + -> TestSuite -- ^ Test suite + -> FilePath -- Path to test suite's .tix file +tixFilePath distPref suite = tixDir distPref suite testName suite <.> "tix" + +-- | Returns a list of all the .tix files in a test suite's .tix file +-- directory. Returned paths are the complete relative path to each file. +findTixFiles :: FilePath -- ^ \"dist/\" prefix + -> TestSuite -- ^ Test suite + -> IO [FilePath] -- ^ All .tix files belonging to test suite +findTixFiles distPref suite = do + files <- getDirectoryContents $ tixDir distPref suite + let tixFiles = flip filter files $ \x -> takeExtension x == ".tix" + return $ map (tixDir distPref suite ) tixFiles + +-- | Generate the HTML markup for a test suite. +doHpcMarkup :: Verbosity + -> FilePath -- ^ \"dist/\" prefix + -> String -- ^ Library name + -> TestSuite + -> IO () +doHpcMarkup verbosity distPref libName suite = do + tixFiles <- findTixFiles distPref suite + when (not $ null tixFiles) $ do + let hpcOptions = map (\x -> "--exclude=" ++ display x) excluded + unionOptions = [ "sum" + , "--union" + , "--output=" ++ tixFilePath distPref suite + ] + ++ hpcOptions ++ tixFiles + markupOptions = [ "markup" + , tixFilePath distPref suite + , "--hpcdir=" ++ hpcDir distPref libName + , "--destdir=" ++ tixDir distPref suite + ] + ++ hpcOptions + excluded = testModules suite ++ [ main ] + --TODO: use standard process utilities from D.S.Utils + runHpc opts h = runProcess "hpc" opts Nothing Nothing Nothing + (Just h) (Just h) + bracket (openHpcTemp $ tixDir distPref suite) deleteIfExists + $ \hpcOut -> do + hUnion <- openFile hpcOut AppendMode + procUnion <- runHpc unionOptions hUnion + exitUnion <- waitForProcess procUnion + success <- case exitUnion of + ExitSuccess -> do + hMarkup <- openFile hpcOut AppendMode + procMarkup <- runHpc markupOptions hMarkup + exitMarkup <- waitForProcess procMarkup + case exitMarkup of + ExitSuccess -> return True + _ -> return False + _ -> return False + unless success $ do + errs <- readFile hpcOut + die $ "HPC failed:\n" ++ errs + when success $ notice verbosity + $ "Test coverage report written to " + ++ tixDir distPref suite "hpc_index" + <.> "html" + return () + where openHpcTemp dir = do + (f, h) <- openTempFile dir $ "cabal-test-hpc-" <.> "log" + hClose h >> return f + deleteIfExists path = do + exists <- doesFileExist path + when exists $ removeFile path diff --git a/cabal/cabal/Distribution/Simple/Hugs.hs b/cabal/cabal/Distribution/Simple/Hugs.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Hugs.hs @@ -0,0 +1,632 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Hugs +-- Copyright : Isaac Jones 2003-2006 +-- Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains most of the NHC-specific code for configuring, building +-- and installing packages. + +{- 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 ( + configure, + getInstalledPackages, + buildLib, + buildExe, + install, + registerPackage, + ) where + +import Distribution.Package + ( PackageName, PackageIdentifier(..), InstalledPackageId(..) + , packageName ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo, emptyInstalledPackageInfo + , InstalledPackageInfo_( InstalledPackageInfo, installedPackageId + , sourcePackageId ) + , parseInstalledPackageInfo, showInstalledPackageInfo ) +import Distribution.PackageDescription + ( PackageDescription(..), BuildInfo(..), hcOptions, allExtensions + , Executable(..), withExe, Library(..), withLib, libModules ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Simple.Compiler + ( CompilerFlavor(..), CompilerId(..) + , Compiler(..), Flag, languageToFlags, extensionsToFlags + , PackageDB(..), PackageDBStack ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (PackageIndex) +import Distribution.Simple.Program + ( Program(programFindVersion) + , ProgramConfiguration, userMaybeSpecifyPath + , requireProgram, requireProgramVersion + , rawSystemProgramConf, programPath + , ffihugsProgram, hugsProgram ) +import Distribution.Version + ( Version(..), orLaterVersion ) +import Distribution.Simple.PreProcess ( ppCpp, runSimplePreProcessor ) +import Distribution.Simple.PreProcess.Unlit + ( unlit ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) + , InstallDirs(..), absoluteInstallDirs ) +import Distribution.Simple.BuildPaths + ( autogenModuleName, autogenModulesDir, + dllExtension ) +import Distribution.Simple.Setup + ( CopyDest(..) ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose + , installOrdinaryFiles, setFileExecutable + , withUTF8FileContents, writeFileAtomic, writeUTF8File + , copyFileVerbose, findFile, findFileWithExtension, findModuleFiles + , rawSystemStdInOut + , die, info, notice ) +import Language.Haskell.Extension + ( Language(Haskell98), Extension(..), KnownExtension(..) ) +import System.FilePath ( (), takeExtension, (<.>), + searchPathSeparator, normalise, takeDirectory ) +import Distribution.System + ( OS(..), buildOS ) +import Distribution.Text + ( display, simpleParse ) +import Distribution.ParseUtils + ( ParseResult(..) ) +import Distribution.Verbosity + +import Data.Char ( isSpace ) +import Data.Maybe ( mapMaybe, catMaybes ) +import Data.Monoid ( Monoid(..) ) +import Control.Monad ( unless, when, filterM ) +import Data.List ( nub, sort, isSuffixOf ) +import System.Directory + ( doesFileExist, doesDirectoryExist, getDirectoryContents + , removeDirectoryRecursive, getHomeDirectory ) +import System.Exit + ( ExitCode(ExitSuccess) ) +import Distribution.Compat.Exception + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) +configure verbosity hcPath _hcPkgPath conf = do + + (_ffihugsProg, conf') <- requireProgram verbosity ffihugsProgram + (userMaybeSpecifyPath "ffihugs" hcPath conf) + (_hugsProg, version, conf'') + <- requireProgramVersion verbosity hugsProgram' + (orLaterVersion (Version [2006] [])) conf' + + let comp = Compiler { + compilerId = CompilerId Hugs version, + compilerLanguages = hugsLanguages, + compilerExtensions = hugsLanguageExtensions + } + return (comp, conf'') + + where + hugsProgram' = hugsProgram { programFindVersion = getVersion } + +getVersion :: Verbosity -> FilePath -> IO (Maybe Version) +getVersion verbosity hugsPath = do + (output, _err, exit) <- rawSystemStdInOut verbosity hugsPath [] + (Just (":quit", False)) False + if exit == ExitSuccess + then return $! findVersion output + else return Nothing + + where + findVersion output = do + (monthStr, yearStr) <- selectWords output + year <- convertYear yearStr + month <- convertMonth monthStr + return (Version [year, month] []) + + selectWords output = + case [ (month, year) + | [_,_,"Version:", month, year,_] <- map words (lines output) ] of + [(month, year)] -> Just (month, year) + _ -> Nothing + convertYear year = case reads year of + [(y, [])] | y >= 1999 && y < 2020 -> Just y + _ -> Nothing + convertMonth month = lookup month (zip months [1..]) + months = [ "January", "February", "March", "April", "May", "June", "July" + , "August", "September", "October", "November", "December" ] + +hugsLanguages :: [(Language, Flag)] +hugsLanguages = [(Haskell98, "")] --default is 98 mode + +-- | The flags for the supported extensions +hugsLanguageExtensions :: [(Extension, Flag)] +hugsLanguageExtensions = + let doFlag (f, (enable, disable)) = [(EnableExtension f, enable), + (DisableExtension f, disable)] + alwaysOn = ("", ""{- wrong -}) + ext98 = ("-98", ""{- wrong -}) + in concatMap doFlag + [(OverlappingInstances , ("+o", "-o")) + ,(IncoherentInstances , ("+oO", "-O")) + ,(HereDocuments , ("+H", "-H")) + ,(TypeSynonymInstances , ext98) + ,(RecursiveDo , ext98) + ,(ParallelListComp , ext98) + ,(MultiParamTypeClasses , ext98) + ,(FunctionalDependencies , ext98) + ,(Rank2Types , ext98) + ,(PolymorphicComponents , ext98) + ,(ExistentialQuantification , ext98) + ,(ScopedTypeVariables , ext98) + ,(ImplicitParams , ext98) + ,(ExtensibleRecords , ext98) + ,(RestrictedTypeSynonyms , ext98) + ,(FlexibleContexts , ext98) + ,(FlexibleInstances , ext98) + ,(ForeignFunctionInterface , alwaysOn) + ,(EmptyDataDecls , alwaysOn) + ,(CPP , alwaysOn) + ] + +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity packagedbs conf = do + homedir <- getHomeDirectory + (hugsProg, _) <- requireProgram verbosity hugsProgram conf + let hugsbindir = takeDirectory (programPath hugsProg) + hugslibdir = takeDirectory hugsbindir "lib" "hugs" + dbdirs = nub (concatMap (packageDbPaths homedir hugslibdir) packagedbs) + indexes <- mapM getIndividualDBPackages dbdirs + return $! mconcat indexes + + where + getIndividualDBPackages :: FilePath -> IO PackageIndex + getIndividualDBPackages dbdir = do + pkgdirs <- getPackageDbDirs dbdir + pkgs <- sequence [ getInstalledPackage pkgname pkgdir + | (pkgname, pkgdir) <- pkgdirs ] + let pkgs' = map setInstalledPackageId (catMaybes pkgs) + return (PackageIndex.fromList pkgs') + +packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] +packageDbPaths home hugslibdir db = case db of + GlobalPackageDB -> [ hugslibdir "packages" + , "/usr/local/lib/hugs/packages" ] + UserPackageDB -> [ home "lib/hugs/packages" ] + SpecificPackageDB path -> [ path ] + +getPackageDbDirs :: FilePath -> IO [(PackageName, FilePath)] +getPackageDbDirs dbdir = do + dbexists <- doesDirectoryExist dbdir + if not dbexists + then return [] + else do + entries <- getDirectoryContents dbdir + pkgdirs <- sequence + [ do pkgdirExists <- doesDirectoryExist pkgdir + return (pkgname, pkgdir, pkgdirExists) + | (entry, Just pkgname) <- [ (entry, simpleParse entry) + | entry <- entries ] + , let pkgdir = dbdir entry ] + return [ (pkgname, pkgdir) | (pkgname, pkgdir, True) <- pkgdirs ] + +getInstalledPackage :: PackageName -> FilePath -> IO (Maybe InstalledPackageInfo) +getInstalledPackage pkgname pkgdir = do + let pkgconfFile = pkgdir "package.conf" + pkgconfExists <- doesFileExist pkgconfFile + + let pathsModule = pkgdir ("Paths_" ++ display pkgname) <.> "hs" + pathsModuleExists <- doesFileExist pathsModule + + case () of + _ | pkgconfExists -> getFullInstalledPackageInfo pkgname pkgconfFile + | pathsModuleExists -> getPhonyInstalledPackageInfo pkgname pathsModule + | otherwise -> return Nothing + +getFullInstalledPackageInfo :: PackageName -> FilePath + -> IO (Maybe InstalledPackageInfo) +getFullInstalledPackageInfo pkgname pkgconfFile = + withUTF8FileContents pkgconfFile $ \contents -> + case parseInstalledPackageInfo contents of + ParseOk _ pkginfo | packageName pkginfo == pkgname + -> return (Just pkginfo) + _ -> return Nothing + +-- | This is a backup option for existing versions of Hugs which do not supply +-- proper installed package info files for the bundled libs. Instead we look +-- for the Paths_pkgname.hs file and extract the package version from that. +-- We don't know any other details for such packages, in particular we pretend +-- that they have no dependencies. +-- +getPhonyInstalledPackageInfo :: PackageName -> FilePath + -> IO (Maybe InstalledPackageInfo) +getPhonyInstalledPackageInfo pkgname pathsModule = do + content <- readFile pathsModule + case extractVersion content of + Nothing -> return Nothing + Just version -> return (Just pkginfo) + where + pkgid = PackageIdentifier pkgname version + pkginfo = emptyInstalledPackageInfo { sourcePackageId = pkgid } + where + -- search through the Paths_pkgname.hs file, looking for a line like: + -- + -- > version = Version {versionBranch = [2,0], versionTags = []} + -- + -- and parse it using 'Read'. Yes we are that evil. + -- + extractVersion content = + case [ version + | ("version":"=":rest) <- map words (lines content) + , (version, []) <- reads (concat rest) ] of + [version] -> Just version + _ -> Nothing + +-- Older installed package info files did not have the installedPackageId +-- field, so if it is missing then we fill it as the source package ID. +setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo +setInstalledPackageId pkginfo@InstalledPackageInfo { + installedPackageId = InstalledPackageId "", + sourcePackageId = pkgid + } + = pkginfo { + --TODO use a proper named function for the conversion + -- from source package id to installed package id + installedPackageId = InstalledPackageId (display pkgid) + } +setInstalledPackageId pkginfo = pkginfo + +-- ----------------------------------------------------------------------------- +-- Building + +-- |Building a package for Hugs. +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib _clbi = do + let pref = scratchDir lbi + createDirectoryIfMissingVerbose verbosity True pref + copyFileVerbose verbosity (autogenModulesDir lbi paths_modulename) + (pref paths_modulename) + compileBuildInfo verbosity pref [] (libModules lib) (libBuildInfo lib) lbi + where + paths_modulename = ModuleName.toFilePath (autogenModuleName pkg_descr) + <.> ".hs" + --TODO: switch to using autogenModulesDir as a search dir, rather than + -- always copying the file over. + +-- |Building an executable for Hugs. +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity pkg_descr lbi + exe@Executable {modulePath=mainPath, buildInfo=bi} _clbi = do + let pref = scratchDir lbi + createDirectoryIfMissingVerbose verbosity True pref + + let destDir = pref "programs" + let exeMods = otherModules bi + srcMainFile <- findFile (hsSourceDirs bi) mainPath + let exeDir = destDir exeName exe + let destMainFile = exeDir hugsMainFilename exe + copyModule verbosity (EnableExtension CPP `elem` allExtensions bi) bi lbi srcMainFile destMainFile + let destPathsFile = exeDir paths_modulename + copyFileVerbose verbosity (autogenModulesDir lbi paths_modulename) + destPathsFile + compileBuildInfo verbosity exeDir + (maybe [] (hsSourceDirs . libBuildInfo) (library pkg_descr)) exeMods bi lbi + compileFiles verbosity bi lbi exeDir [destMainFile, destPathsFile] + + where + paths_modulename = ModuleName.toFilePath (autogenModuleName pkg_descr) + <.> ".hs" + +compileBuildInfo :: Verbosity + -> FilePath -- ^output directory + -> [FilePath] -- ^library source dirs, if building exes + -> [ModuleName] -- ^Modules + -> BuildInfo + -> LocalBuildInfo + -> IO () +--TODO: should not be using mLibSrcDirs at all +compileBuildInfo verbosity destDir mLibSrcDirs mods bi lbi = do + -- Pass 1: copy or cpp files from build directory to scratch directory + let useCpp = EnableExtension CPP `elem` allExtensions bi + let srcDir = buildDir lbi + srcDirs = nub $ srcDir : hsSourceDirs bi ++ mLibSrcDirs + info verbosity $ "Source directories: " ++ show srcDirs + flip mapM_ mods $ \ m -> do + fs <- findFileWithExtension suffixes srcDirs (ModuleName.toFilePath m) + case fs of + Nothing -> + die ("can't find source for module " ++ display m) + Just srcFile -> do + let ext = takeExtension srcFile + copyModule verbosity useCpp bi lbi srcFile + (destDir ModuleName.toFilePath m <.> ext) + -- Pass 2: compile foreign stubs in scratch directory + stubsFileLists <- fmap catMaybes $ sequence + [ findFileWithExtension suffixes [destDir] (ModuleName.toFilePath modu) + | modu <- mods] + compileFiles verbosity bi lbi destDir stubsFileLists + +suffixes :: [String] +suffixes = ["hs", "lhs"] + +-- Copy or cpp a file from the source directory to the build directory. +copyModule :: Verbosity -> Bool -> BuildInfo -> LocalBuildInfo -> FilePath -> FilePath -> IO () +copyModule verbosity cppAll bi lbi srcFile destFile = do + createDirectoryIfMissingVerbose verbosity True (takeDirectory destFile) + (exts, opts, _) <- getOptionsFromSource srcFile + let ghcOpts = [ op | (GHC, ops) <- opts, op <- ops ] + if cppAll || EnableExtension CPP `elem` exts || "-cpp" `elem` ghcOpts then do + runSimplePreProcessor (ppCpp bi lbi) srcFile destFile verbosity + return () + else + copyFileVerbose verbosity srcFile destFile + +compileFiles :: Verbosity -> BuildInfo -> LocalBuildInfo -> FilePath -> [FilePath] -> IO () +compileFiles verbosity bi lbi modDir fileList = do + ffiFileList <- filterM testFFI fileList + unless (null ffiFileList) $ do + notice verbosity "Compiling FFI stubs" + mapM_ (compileFFI verbosity bi lbi modDir) ffiFileList + +-- Only compile FFI stubs for a file if it contains some FFI stuff +testFFI :: FilePath -> IO Bool +testFFI file = + withHaskellFile file $ \inp -> + return $! "foreign" `elem` symbols (stripComments False inp) + +compileFFI :: Verbosity -> BuildInfo -> LocalBuildInfo -> FilePath -> FilePath -> IO () +compileFFI verbosity bi lbi modDir file = do + (_, opts, file_incs) <- getOptionsFromSource file + let ghcOpts = [ op | (GHC, ops) <- opts, op <- ops ] + let pkg_incs = ["\"" ++ inc ++ "\"" | inc <- includes bi] + let incs = nub (sort (file_incs ++ includeOpts ghcOpts ++ pkg_incs)) + let pathFlag = "-P" ++ modDir ++ [searchPathSeparator] + 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] + rawSystemProgramConf verbosity ffihugsProgram (withPrograms lbi) + (hugsArgs ++ file : cArgs) + +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 = + withHaskellFile file $ \inp -> + let cfiles = + [ normalise cfile + | "{-#" : "CFILES" : rest <- map words + $ lines + $ stripComments True inp + , last rest == "#-}" + , cfile <- init rest] + in seq (length cfiles) (return cfiles) + +-- 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. +withHaskellFile :: FilePath -> (String -> IO a) -> IO a +withHaskellFile file action = + withUTF8FileContents file $ \text -> + if ".lhs" `isSuffixOf` file + then either action die (unlit file text) + else action 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 = + withHaskellFile file $ + (return $!) + . foldr appendOptions ([],[],[]) . map getOptions + . takeWhileJust . map getPragma + . filter textLine . map (dropWhile isSpace) . lines + . stripComments True + + 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 (_: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 + :: Verbosity -- ^verbosity + -> LocalBuildInfo + -> FilePath -- ^Library install location + -> FilePath -- ^Program install location + -> FilePath -- ^Executable install location + -> FilePath -- ^Program location on target system + -> FilePath -- ^Build location + -> (FilePath,FilePath) -- ^Executable (prefix,suffix) + -> PackageDescription + -> IO () +--FIXME: this script should be generated at build time, just installed at this stage +install verbosity lbi libDir installProgDir binDir targetProgDir buildPref (progprefix,progsuffix) pkg_descr = do + removeDirectoryRecursive libDir `catchIO` \_ -> return () + withLib pkg_descr $ \ lib -> + findModuleFiles [buildPref] hugsInstallSuffixes (libModules lib) + >>= installOrdinaryFiles verbosity libDir + let buildProgDir = buildPref "programs" + when (any (buildable . buildInfo) (executables pkg_descr)) $ + createDirectoryIfMissingVerbose verbosity True binDir + withExe pkg_descr $ \ exe -> do + let bi = buildInfo exe + let theBuildDir = buildProgDir exeName exe + let installDir = installProgDir exeName exe + let targetDir = targetProgDir exeName exe + removeDirectoryRecursive installDir `catchIO` \_ -> return () + findModuleFiles [theBuildDir] hugsInstallSuffixes + (ModuleName.main : autogenModuleName pkg_descr + : otherModules (buildInfo exe)) + >>= installOrdinaryFiles verbosity installDir + let targetName = "\"" ++ (targetDir hugsMainFilename exe) ++ "\"" + let hugsOptions = hcOptions Hugs (buildInfo exe) + ++ languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (allExtensions bi) + --TODO: also need to consider options, extensions etc of deps + -- see ticket #43 + let baseExeFile = progprefix ++ (exeName exe) ++ progsuffix + let exeFile = case buildOS of + Windows -> binDir baseExeFile <.> ".bat" + _ -> binDir baseExeFile + let script = case buildOS of + Windows -> + let args = hugsOptions ++ [targetName, "%*"] + in unlines ["@echo off", + unwords ("runhugs" : args)] + _ -> + let args = hugsOptions ++ [targetName, "\"$@\""] + in unlines ["#! /bin/sh", + unwords ("runhugs" : args)] + writeFileAtomic exeFile script + setFileExecutable exeFile + +hugsInstallSuffixes :: [String] +hugsInstallSuffixes = [".hs", ".lhs", dllExtension] + +-- |Filename used by Hugs for the main module of an executable. +-- This is a simple filename, so that Hugs will look for any auxiliary +-- modules it uses relative to the directory it's in. +hugsMainFilename :: Executable -> FilePath +hugsMainFilename exe = "Main" <.> ext + where ext = takeExtension (modulePath exe) + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage + :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do + --TODO: prefer to have it based on the packageDbs, but how do we know + -- the package subdir based on the name? the user can set crazy libsubdir + let installDirs = absoluteInstallDirs pkg lbi NoCopyDest + pkgdir | inplace = buildDir lbi + | otherwise = libdir installDirs + createDirectoryIfMissingVerbose verbosity True pkgdir + writeUTF8File (pkgdir "package.conf") + (showInstalledPackageInfo installedPkgInfo) diff --git a/cabal/cabal/Distribution/Simple/Install.hs b/cabal/cabal/Distribution/Simple/Install.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Install.hs @@ -0,0 +1,214 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Install +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point into installing a built package. Performs the +-- \"@.\/setup install@\" and \"@.\/setup copy@\" actions. It moves files into +-- place based on the prefix argument. It does the generic bits and then calls +-- compiler-specific functions to do the rest. + +{- 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, + ) where + +import Distribution.PackageDescription ( + PackageDescription(..), BuildInfo(..), Library(..), + hasLibs, withLib, hasExes, withExe ) +import Distribution.Package (Package(..)) +import Distribution.Simple.LocalBuildInfo ( + LocalBuildInfo(..), InstallDirs(..), absoluteInstallDirs, + substPathTemplate) +import Distribution.Simple.BuildPaths (haddockName, haddockPref) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, installDirectoryContents + , installOrdinaryFile, die, info, notice, matchDirFileGlob ) +import Distribution.Simple.Compiler + ( CompilerFlavor(..), compilerFlavor ) +import Distribution.Simple.Setup (CopyFlags(..), CopyDest(..), fromFlag) + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.NHC as NHC +import qualified Distribution.Simple.JHC as JHC +import qualified Distribution.Simple.LHC as LHC +import qualified Distribution.Simple.Hugs as Hugs +import qualified Distribution.Simple.UHC as UHC + +import Control.Monad (when, unless) +import System.Directory + ( doesDirectoryExist, doesFileExist ) +import System.FilePath + ( takeFileName, takeDirectory, (), isAbsolute ) + +import Distribution.Verbosity +import Distribution.Text + ( display ) + +-- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" +-- actions. Move files into place based on the prefix argument. FIX: +-- nhc isn't implemented yet. + +install :: PackageDescription -- ^information from the .cabal file + -> LocalBuildInfo -- ^information from the configure step + -> CopyFlags -- ^flags sent to copy or install + -> IO () +install pkg_descr lbi flags = do + let distPref = fromFlag (copyDistPref flags) + verbosity = fromFlag (copyVerbosity flags) + copydest = fromFlag (copyDest flags) + installDirs@(InstallDirs { + bindir = binPref, + libdir = libPref, +-- dynlibdir = dynlibPref, --see TODO below + datadir = dataPref, + progdir = progPref, + docdir = docPref, + htmldir = htmlPref, + haddockdir = interfacePref, + includedir = incPref}) + = absoluteInstallDirs pkg_descr lbi copydest + + --TODO: decide if we need the user to be able to control the libdir + -- for shared libs independently of the one for static libs. If so + -- it should also have a flag in the command line UI + -- For the moment use dynlibdir = libdir + dynlibPref = libPref + progPrefixPref = substPathTemplate (packageId pkg_descr) lbi (progPrefix lbi) + progSuffixPref = substPathTemplate (packageId pkg_descr) lbi (progSuffix lbi) + + docExists <- doesDirectoryExist $ haddockPref distPref pkg_descr + info verbosity ("directory " ++ haddockPref distPref pkg_descr ++ + " does exist: " ++ show docExists) + + installDataFiles verbosity pkg_descr dataPref + + when docExists $ do + createDirectoryIfMissingVerbose verbosity True htmlPref + installDirectoryContents verbosity + (haddockPref distPref pkg_descr) htmlPref + -- setPermissionsRecursive [Read] htmlPref + -- The haddock interface file actually already got installed + -- in the recursive copy, but now we install it where we actually + -- want it to be (normally the same place). We could remove the + -- copy in htmlPref first. + let haddockInterfaceFileSrc = haddockPref distPref pkg_descr + haddockName pkg_descr + haddockInterfaceFileDest = interfacePref haddockName pkg_descr + -- We only generate the haddock interface file for libs, So if the + -- package consists only of executables there will not be one: + exists <- doesFileExist haddockInterfaceFileSrc + when exists $ do + createDirectoryIfMissingVerbose verbosity True interfacePref + installOrdinaryFile verbosity haddockInterfaceFileSrc + haddockInterfaceFileDest + + let lfile = licenseFile pkg_descr + unless (null lfile) $ do + createDirectoryIfMissingVerbose verbosity True docPref + installOrdinaryFile verbosity lfile (docPref takeFileName lfile) + + let buildPref = buildDir lbi + when (hasLibs pkg_descr) $ + notice verbosity ("Installing library in " ++ libPref) + when (hasExes pkg_descr) $ + notice verbosity ("Installing executable(s) in " ++ binPref) + + -- install include files for all compilers - they may be needed to compile + -- haskell files (using the CPP extension) + when (hasLibs pkg_descr) $ installIncludeFiles verbosity pkg_descr incPref + + case compilerFlavor (compiler lbi) of + GHC -> do withLib pkg_descr $ + GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr + withExe pkg_descr $ + GHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr + LHC -> do withLib pkg_descr $ + LHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr + withExe pkg_descr $ + LHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr + JHC -> do withLib pkg_descr $ + JHC.installLib verbosity libPref buildPref pkg_descr + withExe pkg_descr $ + JHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) pkg_descr + Hugs -> do + let targetProgPref = progdir (absoluteInstallDirs pkg_descr lbi NoCopyDest) + let scratchPref = scratchDir lbi + Hugs.install verbosity lbi libPref progPref binPref targetProgPref scratchPref (progPrefixPref, progSuffixPref) pkg_descr + NHC -> do withLib pkg_descr $ NHC.installLib verbosity libPref buildPref (packageId pkg_descr) + withExe pkg_descr $ NHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) + UHC -> do withLib pkg_descr $ UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr + _ -> die $ "installing with " + ++ display (compilerFlavor (compiler lbi)) + ++ " is not implemented" + return () + -- register step should be performed by caller. + +-- | Install the files listed in data-files +-- +installDataFiles :: Verbosity -> PackageDescription -> FilePath -> IO () +installDataFiles verbosity pkg_descr destDataDir = + flip mapM_ (dataFiles pkg_descr) $ \ file -> do + let srcDataDir = dataDir pkg_descr + files <- matchDirFileGlob srcDataDir file + let dir = takeDirectory file + createDirectoryIfMissingVerbose verbosity True (destDataDir dir) + sequence_ [ installOrdinaryFile verbosity (srcDataDir file') + (destDataDir file') + | file' <- files ] + +-- | Install the files listed in install-includes +-- +installIncludeFiles :: Verbosity -> PackageDescription -> FilePath -> IO () +installIncludeFiles verbosity + PackageDescription { library = Just lib } destIncludeDir = do + + incs <- mapM (findInc relincdirs) (installIncludes lbi) + sequence_ + [ do createDirectoryIfMissingVerbose verbosity True destDir + installOrdinaryFile verbosity srcFile destFile + | (relFile, srcFile) <- incs + , let destFile = destIncludeDir relFile + destDir = takeDirectory destFile ] + where + relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) + lbi = libBuildInfo lib + + findInc [] file = die ("can't find include file " ++ file) + findInc (dir:dirs) file = do + let path = dir file + exists <- doesFileExist path + if exists then return (file, path) else findInc dirs file +installIncludeFiles _ _ _ = die "installIncludeFiles: Can't happen?" diff --git a/cabal/cabal/Distribution/Simple/InstallDirs.hs b/cabal/cabal/Distribution/Simple/InstallDirs.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/InstallDirs.hs @@ -0,0 +1,600 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp -fffi #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.InstallDirs +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This manages everything to do with where files get installed (though does +-- not get involved with actually doing any installation). It provides an +-- 'InstallDirs' type which is a set of directories for where to install +-- things. It also handles the fact that we use templates in these install +-- dirs. For example most install dirs are relative to some @$prefix@ and by +-- changing the prefix all other dirs still end up changed appropriately. So it +-- provides a 'PathTemplate' type and functions for substituting for these +-- templates. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.InstallDirs ( + InstallDirs(..), + InstallDirTemplates, + defaultInstallDirs, + combineInstallDirs, + absoluteInstallDirs, + CopyDest(..), + prefixRelativeInstallDirs, + substituteInstallDirTemplates, + + PathTemplate, + PathTemplateVariable(..), + toPathTemplate, + fromPathTemplate, + substPathTemplate, + initialPathTemplateEnv, + platformTemplateEnv, + compilerTemplateEnv, + packageTemplateEnv, + installDirsTemplateEnv, + ) where + + +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid(..)) +import System.Directory (getAppUserDataDirectory) +import System.FilePath ((), isPathSeparator, pathSeparator) +#if __HUGS__ || __GLASGOW_HASKELL__ > 606 +import System.FilePath (dropDrive) +#endif + +import Distribution.Package + ( PackageIdentifier, packageName, packageVersion ) +import Distribution.System + ( OS(..), buildOS, Platform(..), buildPlatform ) +import Distribution.Compiler + ( CompilerId, CompilerFlavor(..) ) +import Distribution.Text + ( display ) + +#if mingw32_HOST_OS || mingw32_TARGET_OS +import Foreign +import Foreign.C +#endif + +-- --------------------------------------------------------------------------- +-- Instalation directories + + +-- | The directories where we will install files for packages. +-- +-- We have several different directories for different types of files since +-- many systems have conventions whereby different types of files in a package +-- are installed in different direcotries. This is particularly the case on +-- unix style systems. +-- +data InstallDirs dir = InstallDirs { + prefix :: dir, + bindir :: dir, + libdir :: dir, + libsubdir :: dir, + dynlibdir :: dir, + libexecdir :: dir, + progdir :: dir, + includedir :: dir, + datadir :: dir, + datasubdir :: dir, + docdir :: dir, + mandir :: dir, + htmldir :: dir, + haddockdir :: dir + } deriving (Read, Show) + +instance Functor InstallDirs where + fmap f dirs = InstallDirs { + prefix = f (prefix dirs), + bindir = f (bindir dirs), + libdir = f (libdir dirs), + libsubdir = f (libsubdir dirs), + dynlibdir = f (dynlibdir dirs), + libexecdir = f (libexecdir dirs), + progdir = f (progdir dirs), + includedir = f (includedir dirs), + datadir = f (datadir dirs), + datasubdir = f (datasubdir dirs), + docdir = f (docdir dirs), + mandir = f (mandir dirs), + htmldir = f (htmldir dirs), + haddockdir = f (haddockdir dirs) + } + +instance Monoid dir => Monoid (InstallDirs dir) where + mempty = InstallDirs { + prefix = mempty, + bindir = mempty, + libdir = mempty, + libsubdir = mempty, + dynlibdir = mempty, + libexecdir = mempty, + progdir = mempty, + includedir = mempty, + datadir = mempty, + datasubdir = mempty, + docdir = mempty, + mandir = mempty, + htmldir = mempty, + haddockdir = mempty + } + mappend = combineInstallDirs mappend + +combineInstallDirs :: (a -> b -> c) + -> InstallDirs a + -> InstallDirs b + -> InstallDirs c +combineInstallDirs combine a b = InstallDirs { + prefix = prefix a `combine` prefix b, + bindir = bindir a `combine` bindir b, + libdir = libdir a `combine` libdir b, + libsubdir = libsubdir a `combine` libsubdir b, + dynlibdir = dynlibdir a `combine` dynlibdir b, + libexecdir = libexecdir a `combine` libexecdir b, + progdir = progdir a `combine` progdir b, + includedir = includedir a `combine` includedir b, + datadir = datadir a `combine` datadir b, + datasubdir = datasubdir a `combine` datasubdir b, + docdir = docdir a `combine` docdir b, + mandir = mandir a `combine` mandir b, + htmldir = htmldir a `combine` htmldir b, + haddockdir = haddockdir a `combine` haddockdir b + } + +appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a +appendSubdirs append dirs = dirs { + libdir = libdir dirs `append` libsubdir dirs, + datadir = datadir dirs `append` datasubdir dirs, + libsubdir = error "internal error InstallDirs.libsubdir", + datasubdir = error "internal error InstallDirs.datasubdir" + } + +-- | The installation directories in terms of 'PathTemplate's that contain +-- variables. +-- +-- The defaults for most of the directories are relative to each other, in +-- particular they are all relative to a single prefix. This makes it +-- convenient for the user to override the default installation directory +-- by only having to specify --prefix=... rather than overriding each +-- individually. This is done by allowing $-style variables in the dirs. +-- These are expanded by textual substituion (see 'substPathTemplate'). +-- +-- A few of these installation directories are split into two components, the +-- dir and subdir. The full installation path is formed by combining the two +-- together with @\/@. The reason for this is compatibility with other unix +-- build systems which also support @--libdir@ and @--datadir@. We would like +-- users to be able to configure @--libdir=\/usr\/lib64@ for example but +-- because by default we want to support installing multiple versions of +-- packages and building the same package for multiple compilers we append the +-- libsubdir to get: @\/usr\/lib64\/$pkgid\/$compiler@. +-- +-- An additional complication is the need to support relocatable packages on +-- systems which support such things, like Windows. +-- +type InstallDirTemplates = InstallDirs PathTemplate + +-- --------------------------------------------------------------------------- +-- Default installation directories + +defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates +defaultInstallDirs comp userInstall _hasLibs = do + installPrefix <- + if userInstall + then getAppUserDataDirectory "cabal" + else case buildOS of + Windows -> do windowsProgramFilesDir <- getWindowsProgramFilesDir + return (windowsProgramFilesDir "Haskell") + _ -> return "/usr/local" + installLibDir <- + case buildOS of + Windows -> return "$prefix" + _ -> case comp of + LHC | userInstall -> getAppUserDataDirectory "lhc" + _ -> return ("$prefix" "lib") + return $ fmap toPathTemplate $ InstallDirs { + prefix = installPrefix, + bindir = "$prefix" "bin", + libdir = installLibDir, + libsubdir = case comp of + Hugs -> "hugs" "packages" "$pkg" + JHC -> "$compiler" + LHC -> "$compiler" + UHC -> "$pkgid" + _other -> "$pkgid" "$compiler", + dynlibdir = "$libdir", + libexecdir = case buildOS of + Windows -> "$prefix" "$pkgid" + _other -> "$prefix" "libexec", + progdir = "$libdir" "hugs" "programs", + includedir = "$libdir" "$libsubdir" "include", + datadir = case buildOS of + Windows -> "$prefix" + _other -> "$prefix" "share", + datasubdir = "$pkgid", + docdir = "$datadir" "doc" "$pkgid", + mandir = "$datadir" "man", + htmldir = "$docdir" "html", + haddockdir = "$htmldir" + } + +-- --------------------------------------------------------------------------- +-- Converting directories, absolute or prefix-relative + +-- | Substitute the install dir templates into each other. +-- +-- To prevent cyclic substitutions, only some variables are allowed in +-- particular dir templates. If out of scope vars are present, they are not +-- substituted for. Checking for any remaining unsubstituted vars can be done +-- as a subsequent operation. +-- +-- The reason it is done this way is so that in 'prefixRelativeInstallDirs' we +-- can replace 'prefix' with the 'PrefixVar' and get resulting +-- 'PathTemplate's that still have the 'PrefixVar' in them. Doing this makes it +-- each to check which paths are relative to the $prefix. +-- +substituteInstallDirTemplates :: PathTemplateEnv + -> InstallDirTemplates -> InstallDirTemplates +substituteInstallDirTemplates env dirs = dirs' + where + dirs' = InstallDirs { + -- So this specifies exactly which vars are allowed in each template + prefix = subst prefix [], + bindir = subst bindir [prefixVar], + libdir = subst libdir [prefixVar, bindirVar], + libsubdir = subst libsubdir [], + dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar], + libexecdir = subst libexecdir prefixBinLibVars, + progdir = subst progdir prefixBinLibVars, + includedir = subst includedir prefixBinLibVars, + datadir = subst datadir prefixBinLibVars, + datasubdir = subst datasubdir [], + docdir = subst docdir prefixBinLibDataVars, + mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar]), + htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]), + haddockdir = subst haddockdir (prefixBinLibDataVars ++ + [docdirVar, htmldirVar]) + } + subst dir env' = substPathTemplate (env'++env) (dir dirs) + + prefixVar = (PrefixVar, prefix dirs') + bindirVar = (BindirVar, bindir dirs') + libdirVar = (LibdirVar, libdir dirs') + libsubdirVar = (LibsubdirVar, libsubdir dirs') + datadirVar = (DatadirVar, datadir dirs') + datasubdirVar = (DatasubdirVar, datasubdir dirs') + docdirVar = (DocdirVar, docdir dirs') + htmldirVar = (HtmldirVar, htmldir dirs') + prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar] + prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar] + +-- | Convert from abstract install directories to actual absolute ones by +-- substituting for all the variables in the abstract paths, to get real +-- absolute path. +absoluteInstallDirs :: PackageIdentifier -> CompilerId -> CopyDest + -> InstallDirs PathTemplate + -> InstallDirs FilePath +absoluteInstallDirs pkgId compilerId copydest dirs = + (case copydest of + CopyTo destdir -> fmap ((destdir ) . dropDrive) + _ -> id) + . appendSubdirs () + . fmap fromPathTemplate + $ substituteInstallDirTemplates env dirs + where + env = initialPathTemplateEnv pkgId compilerId + + +-- |The location prefix for the /copy/ command. +data CopyDest + = NoCopyDest + | CopyTo FilePath + deriving (Eq, Show) + +-- | Check which of the paths are relative to the installation $prefix. +-- +-- If any of the paths are not relative, ie they are absolute paths, then it +-- prevents us from making a relocatable package (also known as a \"prefix +-- independent\" package). +-- +prefixRelativeInstallDirs :: PackageIdentifier -> CompilerId + -> InstallDirTemplates + -> InstallDirs (Maybe FilePath) +prefixRelativeInstallDirs pkgId compilerId dirs = + fmap relative + . appendSubdirs combinePathTemplate + $ -- substitute the path template into each other, except that we map + -- \$prefix back to $prefix. We're trying to end up with templates that + -- mention no vars except $prefix. + substituteInstallDirTemplates env dirs { + prefix = PathTemplate [Variable PrefixVar] + } + where + env = initialPathTemplateEnv pkgId compilerId + + -- If it starts with $prefix then it's relative and produce the relative + -- path by stripping off $prefix/ or $prefix + relative dir = case dir of + PathTemplate cs -> fmap (fromPathTemplate . PathTemplate) (relative' cs) + relative' (Variable PrefixVar : Ordinary (s:rest) : rest') + | isPathSeparator s = Just (Ordinary rest : rest') + relative' (Variable PrefixVar : rest) = Just rest + relative' _ = Nothing + +-- --------------------------------------------------------------------------- +-- Path templates + +-- | An abstract path, posibly containing variables that need to be +-- substituted for to get a real 'FilePath'. +-- +newtype PathTemplate = PathTemplate [PathComponent] + +data PathComponent = + Ordinary FilePath + | Variable PathTemplateVariable + deriving Eq + +data PathTemplateVariable = + PrefixVar -- ^ The @$prefix@ path variable + | BindirVar -- ^ The @$bindir@ path variable + | LibdirVar -- ^ The @$libdir@ path variable + | LibsubdirVar -- ^ The @$libsubdir@ path variable + | DatadirVar -- ^ The @$datadir@ path variable + | DatasubdirVar -- ^ The @$datasubdir@ path variable + | DocdirVar -- ^ The @$docdir@ path variable + | HtmldirVar -- ^ The @$htmldir@ path variable + | PkgNameVar -- ^ The @$pkg@ package name path variable + | PkgVerVar -- ^ The @$version@ package version path variable + | PkgIdVar -- ^ The @$pkgid@ package Id path variable, eg @foo-1.0@ + | CompilerVar -- ^ The compiler name and version, eg @ghc-6.6.1@ + | OSVar -- ^ The operating system name, eg @windows@ or @linux@ + | ArchVar -- ^ The cpu architecture name, eg @i386@ or @x86_64@ + | ExecutableNameVar -- ^ The executable name; used in shell wrappers + | TestSuiteNameVar -- ^ The name of the test suite being run + | TestSuiteResultVar -- ^ The result of the test suite being run, eg @pass@, @fail@, or @error@. + deriving Eq + +type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)] + +-- | Convert a 'FilePath' to a 'PathTemplate' including any template vars. +-- +toPathTemplate :: FilePath -> PathTemplate +toPathTemplate = PathTemplate . read + +-- | Convert back to a path, any remaining vars are included +-- +fromPathTemplate :: PathTemplate -> FilePath +fromPathTemplate (PathTemplate template) = show template + +combinePathTemplate :: PathTemplate -> PathTemplate -> PathTemplate +combinePathTemplate (PathTemplate t1) (PathTemplate t2) = + PathTemplate (t1 ++ [Ordinary [pathSeparator]] ++ t2) + +substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate +substPathTemplate environment (PathTemplate template) = + PathTemplate (concatMap subst template) + + where subst component@(Ordinary _) = [component] + subst component@(Variable variable) = + case lookup variable environment of + Just (PathTemplate components) -> components + Nothing -> [component] + +-- | The initial environment has all the static stuff but no paths +initialPathTemplateEnv :: PackageIdentifier -> CompilerId -> PathTemplateEnv +initialPathTemplateEnv pkgId compilerId = + packageTemplateEnv pkgId + ++ compilerTemplateEnv compilerId + ++ platformTemplateEnv buildPlatform -- platform should be param if we want + -- to do cross-platform configuation + +packageTemplateEnv :: PackageIdentifier -> PathTemplateEnv +packageTemplateEnv pkgId = + [(PkgNameVar, PathTemplate [Ordinary $ display (packageName pkgId)]) + ,(PkgVerVar, PathTemplate [Ordinary $ display (packageVersion pkgId)]) + ,(PkgIdVar, PathTemplate [Ordinary $ display pkgId]) + ] + +compilerTemplateEnv :: CompilerId -> PathTemplateEnv +compilerTemplateEnv compilerId = + [(CompilerVar, PathTemplate [Ordinary $ display compilerId]) + ] + +platformTemplateEnv :: Platform -> PathTemplateEnv +platformTemplateEnv (Platform arch os) = + [(OSVar, PathTemplate [Ordinary $ display os]) + ,(ArchVar, PathTemplate [Ordinary $ display arch]) + ] + +installDirsTemplateEnv :: InstallDirs PathTemplate -> PathTemplateEnv +installDirsTemplateEnv dirs = + [(PrefixVar, prefix dirs) + ,(BindirVar, bindir dirs) + ,(LibdirVar, libdir dirs) + ,(LibsubdirVar, libsubdir dirs) + ,(DatadirVar, datadir dirs) + ,(DatasubdirVar, datasubdir dirs) + ,(DocdirVar, docdir dirs) + ,(HtmldirVar, htmldir dirs) + ] + + +-- --------------------------------------------------------------------------- +-- Parsing and showing path templates: + +-- The textual format is that of an ordinary Haskell String, eg +-- "$prefix/bin" +-- and this gets parsed to the internal representation as a sequence of path +-- spans which are either strings or variables, eg: +-- PathTemplate [Variable PrefixVar, Ordinary "/bin" ] + +instance Show PathTemplateVariable where + show PrefixVar = "prefix" + show BindirVar = "bindir" + show LibdirVar = "libdir" + show LibsubdirVar = "libsubdir" + show DatadirVar = "datadir" + show DatasubdirVar = "datasubdir" + show DocdirVar = "docdir" + show HtmldirVar = "htmldir" + show PkgNameVar = "pkg" + show PkgVerVar = "version" + show PkgIdVar = "pkgid" + show CompilerVar = "compiler" + show OSVar = "os" + show ArchVar = "arch" + show ExecutableNameVar = "executablename" + show TestSuiteNameVar = "test-suite" + show TestSuiteResultVar = "result" + +instance Read PathTemplateVariable where + readsPrec _ s = + take 1 + [ (var, drop (length varStr) s) + | (varStr, var) <- vars + , varStr `isPrefixOf` s ] + where vars = [("prefix", PrefixVar) + ,("bindir", BindirVar) + ,("libdir", LibdirVar) + ,("libsubdir", LibsubdirVar) + ,("datadir", DatadirVar) + ,("datasubdir", DatasubdirVar) + ,("docdir", DocdirVar) + ,("htmldir", HtmldirVar) + ,("pkgid", PkgIdVar) + ,("pkg", PkgNameVar) + ,("version", PkgVerVar) + ,("compiler", CompilerVar) + ,("os", OSVar) + ,("arch", ArchVar) + ,("executablename", ExecutableNameVar) + ,("test-suite", TestSuiteNameVar) + ,("result", TestSuiteResultVar)] + +instance Show PathComponent where + show (Ordinary path) = path + show (Variable var) = '$':show var + showList = foldr (\x -> (shows x .)) id + +instance Read PathComponent where + -- for some reason we colapse multiple $ symbols here + readsPrec _ = lex0 + where lex0 [] = [] + lex0 ('$':'$':s') = lex0 ('$':s') + lex0 ('$':s') = case [ (Variable var, s'') + | (var, s'') <- reads s' ] of + [] -> lex1 "$" s' + ok -> ok + lex0 s' = lex1 [] s' + lex1 "" "" = [] + lex1 acc "" = [(Ordinary (reverse acc), "")] + lex1 acc ('$':'$':s) = lex1 acc ('$':s) + lex1 acc ('$':s) = [(Ordinary (reverse acc), '$':s)] + lex1 acc (c:s) = lex1 (c:acc) s + readList [] = [([],"")] + readList s = [ (component:components, s'') + | (component, s') <- reads s + , (components, s'') <- readList s' ] + +instance Show PathTemplate where + show (PathTemplate template) = show (show template) + +instance Read PathTemplate where + readsPrec p s = [ (PathTemplate template, s') + | (path, s') <- readsPrec p s + , (template, "") <- reads path ] + +-- --------------------------------------------------------------------------- +-- Internal utilities + +getWindowsProgramFilesDir :: IO FilePath +getWindowsProgramFilesDir = do +#if mingw32_HOST_OS || mingw32_TARGET_OS + m <- shGetFolderPath csidl_PROGRAM_FILES +#else + let m = Nothing +#endif + return (fromMaybe "C:\\Program Files" m) + +#if mingw32_HOST_OS || mingw32_TARGET_OS +shGetFolderPath :: CInt -> IO (Maybe FilePath) +shGetFolderPath n = +# if __HUGS__ + return Nothing +# else + allocaArray long_path_size $ \pPath -> do + r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath + if (r /= 0) + then return Nothing + else do s <- peekCWString pPath; return (Just s) + where + long_path_size = 1024 -- MAX_PATH is 260, this should be plenty +# endif + +csidl_PROGRAM_FILES :: CInt +csidl_PROGRAM_FILES = 0x0026 +-- csidl_PROGRAM_FILES_COMMON :: CInt +-- csidl_PROGRAM_FILES_COMMON = 0x002b + +foreign import stdcall unsafe "shlobj.h SHGetFolderPathW" + c_SHGetFolderPath :: Ptr () + -> CInt + -> Ptr () + -> CInt + -> CWString + -> IO CInt +#endif + +#if !(__HUGS__ || __GLASGOW_HASKELL__ > 606) +-- Compat: this function only appears in FilePath > 1.0 +-- (which at the time of writing is unreleased) +dropDrive :: FilePath -> FilePath +dropDrive (c:cs) | isPathSeparator c = cs +dropDrive (_:':':c:cs) | isWindows + && isPathSeparator c = cs -- path with drive letter +dropDrive (_:':':cs) | isWindows = cs +dropDrive cs = cs + +isWindows :: Bool +isWindows = case buildOS of + Windows -> True + _ -> False +#endif diff --git a/cabal/cabal/Distribution/Simple/JHC.hs b/cabal/cabal/Distribution/Simple/JHC.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/JHC.hs @@ -0,0 +1,221 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.JHC +-- Copyright : Isaac Jones 2003-2006 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains most of the JHC-specific code for configuring, building +-- and installing packages. + +{- +Copyright (c) 2009, Henning Thielemann +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 ( + configure, getInstalledPackages, + buildLib, buildExe, + installLib, installExe + ) where + +import Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(..), Executable(..) + , Library(..), libModules, hcOptions, usedExtensions ) +import Distribution.InstalledPackageInfo + ( emptyInstalledPackageInfo, ) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import Distribution.Simple.PackageIndex (PackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) +import Distribution.Simple.BuildPaths + ( autogenModulesDir, exeExtension ) +import Distribution.Simple.Compiler + ( CompilerFlavor(..), CompilerId(..), Compiler(..) + , PackageDBStack, Flag, languageToFlags, extensionsToFlags ) +import Language.Haskell.Extension + ( Language(Haskell98), Extension(..), KnownExtension(..)) +import Distribution.Simple.Program + ( ConfiguredProgram(..), jhcProgram, ProgramConfiguration + , userMaybeSpecifyPath, requireProgramVersion, lookupProgram + , rawSystemProgram, rawSystemProgramStdoutConf ) +import Distribution.Version + ( Version(..), orLaterVersion ) +import Distribution.Package + ( Package(..), InstalledPackageId(InstalledPackageId), + pkgName, pkgVersion, ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, writeFileAtomic + , installOrdinaryFile, installExecutableFile + , intercalate ) +import System.FilePath ( () ) +import Distribution.Verbosity +import Distribution.Text + ( Text(parse), display ) +import Distribution.Compat.ReadP + ( readP_to_S, string, skipSpaces ) + +import Data.List ( nub ) +import Data.Char ( isSpace ) +import Data.Maybe ( fromMaybe ) + + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) +configure verbosity hcPath _hcPkgPath conf = do + + (jhcProg, _, conf') <- requireProgramVersion verbosity + jhcProgram (orLaterVersion (Version [0,7,2] [])) + (userMaybeSpecifyPath "jhc" hcPath conf) + + let Just version = programVersion jhcProg + comp = Compiler { + compilerId = CompilerId JHC version, + compilerLanguages = jhcLanguages, + compilerExtensions = jhcLanguageExtensions + } + return (comp, conf') + +jhcLanguages :: [(Language, Flag)] +jhcLanguages = [(Haskell98, "")] + +-- | The flags for the supported extensions +jhcLanguageExtensions :: [(Extension, Flag)] +jhcLanguageExtensions = + [(EnableExtension TypeSynonymInstances , "") + ,(DisableExtension TypeSynonymInstances , "") + ,(EnableExtension ForeignFunctionInterface , "") + ,(DisableExtension ForeignFunctionInterface , "") + ,(EnableExtension ImplicitPrelude , "") -- Wrong + ,(DisableExtension ImplicitPrelude , "--noprelude") + ,(EnableExtension CPP , "-fcpp") + ,(DisableExtension CPP , "-fno-cpp") + ] + +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity _packageDBs conf = do + -- jhc --list-libraries lists all available libraries. + -- How shall I find out, whether they are global or local + -- without checking all files and locations? + str <- rawSystemProgramStdoutConf verbosity jhcProgram conf ["--list-libraries"] + let pCheck :: [(a, String)] -> [a] + pCheck rs = [ r | (r,s) <- rs, all isSpace s ] + let parseLine ln = + pCheck (readP_to_S + (skipSpaces >> string "Name:" >> skipSpaces >> parse) ln) + return $ + PackageIndex.fromList $ + map (\p -> emptyInstalledPackageInfo { + InstalledPackageInfo.installedPackageId = + InstalledPackageId (display p), + InstalledPackageInfo.sourcePackageId = p + }) $ + concatMap parseLine $ + lines str + +-- ----------------------------------------------------------------------------- +-- Building + +-- | Building a package for JHC. +-- Currently C source files are not supported. +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + let Just jhcProg = lookupProgram jhcProgram (withPrograms lbi) + let libBi = libBuildInfo lib + let args = constructJHCCmdLine lbi libBi clbi (buildDir lbi) verbosity + let pkgid = display (packageId pkg_descr) + pfile = buildDir lbi "jhc-pkg.conf" + hlfile= buildDir lbi (pkgid ++ ".hl") + writeFileAtomic pfile $ jhcPkgConf pkg_descr + rawSystemProgram verbosity jhcProg $ + ["--build-hl="++pfile, "-o", hlfile] ++ + args ++ map display (libModules lib) + +-- | Building an executable for JHC. +-- Currently C source files are not supported. +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity _pkg_descr lbi exe clbi = do + let Just jhcProg = lookupProgram jhcProgram (withPrograms lbi) + let exeBi = buildInfo exe + let out = buildDir lbi exeName exe + let args = constructJHCCmdLine lbi exeBi clbi (buildDir lbi) verbosity + rawSystemProgram verbosity jhcProg (["-o",out] ++ args ++ [modulePath exe]) + +constructJHCCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> Verbosity -> [String] +constructJHCCmdLine lbi bi clbi _odir verbosity = + (if verbosity >= deafening then ["-v"] else []) + ++ hcOptions JHC bi + ++ languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) + ++ ["--noauto","-i-"] + ++ concat [["-i", l] | l <- nub (hsSourceDirs bi)] + ++ ["-i", autogenModulesDir lbi] + ++ ["-optc" ++ opt | opt <- PD.ccOptions bi] + -- It would be better if JHC would accept package names with versions, + -- but JHC-0.7.2 doesn't accept this. + -- Thus, we have to strip the version with 'pkgName'. + ++ (concat [ ["-p", display (pkgName pkgid)] + | (_, pkgid) <- componentPackageDeps clbi ]) + +jhcPkgConf :: PackageDescription -> String +jhcPkgConf pd = + let sline name sel = name ++ ": "++sel pd + lib = fromMaybe (error "no library available") . library + comma = intercalate "," . map display + in unlines [sline "name" (display . pkgName . packageId) + ,sline "version" (display . pkgVersion . packageId) + ,sline "exposed-modules" (comma . PD.exposedModules . lib) + ,sline "hidden-modules" (comma . otherModules . libBuildInfo . lib) + ] + +installLib :: Verbosity -> FilePath -> FilePath -> PackageDescription -> Library -> IO () +installLib verb dest build_dir pkg_descr _ = do + let p = display (packageId pkg_descr)++".hl" + createDirectoryIfMissingVerbose verb True dest + installOrdinaryFile verb (build_dir p) (dest p) + +installExe :: Verbosity -> FilePath -> FilePath -> (FilePath,FilePath) -> PackageDescription -> Executable -> IO () +installExe verb dest build_dir (progprefix,progsuffix) _ exe = do + let exe_name = exeName exe + src = exe_name exeExtension + out = (progprefix ++ exe_name ++ progsuffix) exeExtension + createDirectoryIfMissingVerbose verb True dest + installExecutableFile verb (build_dir src) (dest out) + diff --git a/cabal/cabal/Distribution/Simple/LHC.hs b/cabal/cabal/Distribution/Simple/LHC.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/LHC.hs @@ -0,0 +1,805 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.LHC +-- Copyright : Isaac Jones 2003-2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is a fairly large module. It contains most of the GHC-specific code for +-- configuring, building and installing packages. It also exports a function +-- for finding out what packages are already installed. Configuring involves +-- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions +-- this version of ghc supports and returning a 'Compiler' value. +-- +-- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out +-- what packages are installed. +-- +-- Building is somewhat complex as there is quite a bit of information to take +-- into account. We have to build libs and programs, possibly for profiling and +-- shared libs. We have to support building libraries that will be usable by +-- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files +-- using ghc. Linking, especially for @split-objs@ is remarkably complex, +-- partly because there tend to be 1,000's of @.o@ files and this can often be +-- more than we can pass to the @ld@ or @ar@ programs in one go. +-- +-- Installing for libs and exes involves finding the right files and copying +-- them to the right places. One of the more tricky things about this module is +-- remembering the layout of files in the build directory (which is not +-- explicitly documented) and thus what search dirs are used for various kinds +-- of files. + +{- 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.LHC ( + configure, getInstalledPackages, + buildLib, buildExe, + installLib, installExe, + registerPackage, + ghcOptions, + ghcVerbosityOptions + ) where + +import Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(..), Executable(..) + , Library(..), libModules, hcOptions, usedExtensions, allExtensions ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo + , parseInstalledPackageInfo ) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo + ( InstalledPackageInfo_(..) ) +import Distribution.Simple.PackageIndex +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.ParseUtils ( ParseResult(..) ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) +import Distribution.Simple.InstallDirs +import Distribution.Simple.BuildPaths +import Distribution.Simple.Utils +import Distribution.Package + ( PackageIdentifier, Package(..) ) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Simple.Program + ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg + , ProgramLocation(..), rawSystemProgram, rawSystemProgramConf + , rawSystemProgramStdout, rawSystemProgramStdoutConf + , requireProgramVersion + , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram + , arProgram, ranlibProgram, ldProgram + , gccProgram, stripProgram + , lhcProgram, lhcPkgProgram ) +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import Distribution.Simple.Compiler + ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion + , OptimisationLevel(..), PackageDB(..), PackageDBStack + , Flag, languageToFlags, extensionsToFlags ) +import Distribution.Version + ( Version(..), orLaterVersion ) +import Distribution.System + ( OS(..), buildOS ) +import Distribution.Verbosity +import Distribution.Text + ( display, simpleParse ) +import Language.Haskell.Extension + ( Language(Haskell98), Extension(..), KnownExtension(..) ) + +import Control.Monad ( unless, when ) +import Data.List +import Data.Maybe ( catMaybes ) +import Data.Monoid ( Monoid(..) ) +import System.Directory ( removeFile, renameFile, + getDirectoryContents, doesFileExist, + getTemporaryDirectory ) +import System.FilePath ( (), (<.>), takeExtension, + takeDirectory, replaceExtension ) +import System.IO (hClose, hPutStrLn) +import Distribution.Compat.Exception (catchExit, catchIO) + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) +configure verbosity hcPath hcPkgPath conf = do + + (lhcProg, lhcVersion, conf') <- + requireProgramVersion verbosity lhcProgram + (orLaterVersion (Version [0,7] [])) + (userMaybeSpecifyPath "lhc" hcPath conf) + + (lhcPkgProg, lhcPkgVersion, conf'') <- + requireProgramVersion verbosity lhcPkgProgram + (orLaterVersion (Version [0,7] [])) + (userMaybeSpecifyPath "lhc-pkg" hcPkgPath conf') + + when (lhcVersion /= lhcPkgVersion) $ die $ + "Version mismatch between lhc and lhc-pkg: " + ++ programPath lhcProg ++ " is version " ++ display lhcVersion ++ " " + ++ programPath lhcPkgProg ++ " is version " ++ display lhcPkgVersion + + languages <- getLanguages verbosity lhcProg + extensions <- getExtensions verbosity lhcProg + + let comp = Compiler { + compilerId = CompilerId LHC lhcVersion, + compilerLanguages = languages, + compilerExtensions = extensions + } + conf''' = configureToolchain lhcProg conf'' -- configure gcc and ld + return (comp, conf''') + +-- | Adjust the way we find and configure gcc and ld +-- +configureToolchain :: ConfiguredProgram -> ProgramConfiguration + -> ProgramConfiguration +configureToolchain lhcProg = + addKnownProgram gccProgram { + programFindLocation = findProg gccProgram (baseDir "gcc.exe"), + programPostConf = configureGcc + } + . addKnownProgram ldProgram { + programFindLocation = findProg ldProgram (libDir "ld.exe"), + programPostConf = configureLd + } + where + compilerDir = takeDirectory (programPath lhcProg) + baseDir = takeDirectory compilerDir + libDir = baseDir "gcc-lib" + includeDir = baseDir "include" "mingw" + isWindows = case buildOS of Windows -> True; _ -> False + + -- on Windows finding and configuring ghc's gcc and ld is a bit special + findProg :: Program -> FilePath -> Verbosity -> IO (Maybe FilePath) + findProg prog location | isWindows = \verbosity -> do + exists <- doesFileExist location + if exists then return (Just location) + else do warn verbosity ("Couldn't find " ++ programName prog ++ " where I expected it. Trying the search path.") + programFindLocation prog verbosity + | otherwise = programFindLocation prog + + configureGcc :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + configureGcc + | isWindows = \_ gccProg -> case programLocation gccProg of + -- if it's found on system then it means we're using the result + -- of programFindLocation above rather than a user-supplied path + -- that means we should add this extra flag to tell ghc's gcc + -- where it lives and thus where gcc can find its various files: + FoundOnSystem {} -> return ["-B" ++ libDir, "-I" ++ includeDir] + UserSpecified {} -> return [] + | otherwise = \_ _ -> return [] + + -- we need to find out if ld supports the -x flag + configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + configureLd verbosity ldProg = do + tempDir <- getTemporaryDirectory + ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> + withTempFile tempDir ".o" $ \testofile testohnd -> do + hPutStrLn testchnd "int foo() {}" + hClose testchnd; hClose testohnd + rawSystemProgram verbosity lhcProg ["-c", testcfile, + "-o", testofile] + withTempFile tempDir ".o" $ \testofile' testohnd' -> + do + hClose testohnd' + _ <- rawSystemProgramStdout verbosity ldProg + ["-x", "-r", testofile, "-o", testofile'] + return True + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) + if ldx + then return ["-x"] + else return [] + +getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)] +getLanguages _ _ = return [(Haskell98, "")] +--FIXME: does lhc support -XHaskell98 flag? from what version? + +getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)] +getExtensions verbosity lhcProg = do + exts <- rawSystemStdout verbosity (programPath lhcProg) + ["--supported-languages"] + -- GHC has the annoying habit of inverting some of the extensions + -- so we have to try parsing ("No" ++ ghcExtensionName) first + let readExtension str = do + ext <- simpleParse ("No" ++ str) + case ext of + UnknownExtension _ -> simpleParse str + _ -> return ext + return $ [ (ext, "-X" ++ display ext) + | Just ext <- map readExtension (lines exts) ] + +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity packagedbs conf = do + checkPackageDbStack packagedbs + pkgss <- getInstalledPackages' verbosity packagedbs conf + let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs) + | (_, pkgs) <- pkgss ] + return $! (mconcat indexes) + + where + -- On Windows, various fields have $topdir/foo rather than full + -- paths. We need to substitute the right value in so that when + -- we, for example, call gcc, we have proper paths to give it + Just ghcProg = lookupProgram lhcProgram conf + compilerDir = takeDirectory (programPath ghcProg) + topDir = takeDirectory compilerDir + +checkPackageDbStack :: PackageDBStack -> IO () +checkPackageDbStack (GlobalPackageDB:rest) + | GlobalPackageDB `notElem` rest = return () +checkPackageDbStack _ = + die $ "GHC.getInstalledPackages: the global package db must be " + ++ "specified first and cannot be specified multiple times" + +-- | Get the packages from specific PackageDBs, not cumulative. +-- +getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration + -> IO [(PackageDB, [InstalledPackageInfo])] +getInstalledPackages' verbosity packagedbs conf + = + sequence + [ do str <- rawSystemProgramStdoutConf verbosity lhcPkgProgram conf + ["dump", packageDbGhcPkgFlag packagedb] + `catchExit` \_ -> die $ "ghc-pkg dump failed" + case parsePackages str of + Left ok -> return (packagedb, ok) + _ -> die "failed to parse output of 'ghc-pkg dump'" + | packagedb <- packagedbs ] + + where + parsePackages str = + let parsed = map parseInstalledPackageInfo (splitPkgs str) + in case [ msg | ParseFailed msg <- parsed ] of + [] -> Left [ pkg | ParseOk _ pkg <- parsed ] + msgs -> Right msgs + + splitPkgs :: String -> [String] + splitPkgs = map unlines . splitWith ("---" ==) . lines + where + splitWith :: (a -> Bool) -> [a] -> [[a]] + splitWith p xs = ys : case zs of + [] -> [] + _:ws -> splitWith p ws + where (ys,zs) = break p xs + + packageDbGhcPkgFlag GlobalPackageDB = "--global" + packageDbGhcPkgFlag UserPackageDB = "--user" + packageDbGhcPkgFlag (SpecificPackageDB path) = "--package-conf=" ++ path + + +substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo +substTopDir topDir ipo + = ipo { + InstalledPackageInfo.importDirs + = map f (InstalledPackageInfo.importDirs ipo), + InstalledPackageInfo.libraryDirs + = map f (InstalledPackageInfo.libraryDirs ipo), + InstalledPackageInfo.includeDirs + = map f (InstalledPackageInfo.includeDirs ipo), + InstalledPackageInfo.frameworkDirs + = map f (InstalledPackageInfo.frameworkDirs ipo), + InstalledPackageInfo.haddockInterfaces + = map f (InstalledPackageInfo.haddockInterfaces ipo), + InstalledPackageInfo.haddockHTMLs + = map f (InstalledPackageInfo.haddockHTMLs ipo) + } + where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest + f x = x + +-- ----------------------------------------------------------------------------- +-- Building + +-- | Build a library with LHC. +-- +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + let pref = buildDir lbi + pkgid = packageId pkg_descr + runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) + ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi) + ifProfLib = when (withProfLib lbi) + ifSharedLib = when (withSharedLib lbi) + ifGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi) + + libBi <- hackThreadedFlag verbosity + (compiler lbi) (withProfLib lbi) (libBuildInfo lib) + + let libTargetDir = pref + forceVanillaLib = EnableExtension TemplateHaskell `elem` allExtensions libBi + -- TH always needs vanilla libs, even when building for profiling + + createDirectoryIfMissingVerbose verbosity True libTargetDir + -- TODO: do we need to put hs-boot files into place for mutually recurive modules? + let ghcArgs = + ["-package-name", display pkgid ] + ++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity + ++ map display (libModules lib) + lhcWrap x = ["--build-library", "--ghc-opts=" ++ unwords x] + ghcArgsProf = ghcArgs + ++ ["-prof", + "-hisuf", "p_hi", + "-osuf", "p_o" + ] + ++ ghcProfOptions libBi + ghcArgsShared = ghcArgs + ++ ["-dynamic", + "-hisuf", "dyn_hi", + "-osuf", "dyn_o", "-fPIC" + ] + ++ ghcSharedOptions libBi + unless (null (libModules lib)) $ + do ifVanillaLib forceVanillaLib (runGhcProg $ lhcWrap ghcArgs) + ifProfLib (runGhcProg $ lhcWrap ghcArgsProf) + ifSharedLib (runGhcProg $ lhcWrap ghcArgsShared) + + -- build any C sources + unless (null (cSources libBi)) $ do + info verbosity "Building C Sources..." + sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi clbi pref + filename verbosity + createDirectoryIfMissingVerbose verbosity True odir + runGhcProg args + ifSharedLib (runGhcProg (args ++ ["-fPIC", "-osuf dyn_o"])) + | filename <- cSources libBi] + + -- link: + info verbosity "Linking..." + let cObjs = map (`replaceExtension` objExtension) (cSources libBi) + cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi) + vanillaLibFilePath = libTargetDir mkLibName pkgid + profileLibFilePath = libTargetDir mkProfLibName pkgid + sharedLibFilePath = libTargetDir mkSharedLibName pkgid + (compilerId (compiler lbi)) + ghciLibFilePath = libTargetDir mkGHCiLibName pkgid + + stubObjs <- fmap catMaybes $ sequence + [ findFileWithExtension [objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | x <- libModules lib ] + stubProfObjs <- fmap catMaybes $ sequence + [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | x <- libModules lib ] + stubSharedObjs <- fmap catMaybes $ sequence + [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | x <- libModules lib ] + + hObjs <- getHaskellObjects lib lbi + pref objExtension True + hProfObjs <- + if (withProfLib lbi) + then getHaskellObjects lib lbi + pref ("p_" ++ objExtension) True + else return [] + hSharedObjs <- + if (withSharedLib lbi) + then getHaskellObjects lib lbi + pref ("dyn_" ++ objExtension) False + else return [] + + unless (null hObjs && null cObjs && null stubObjs) $ do + -- first remove library files if they exists + sequence_ + [ removeFile libFilePath `catchIO` \_ -> return () + | libFilePath <- [vanillaLibFilePath, profileLibFilePath + ,sharedLibFilePath, ghciLibFilePath] ] + + let arVerbosity | verbosity >= deafening = "v" + | verbosity >= normal = "" + | otherwise = "c" + arArgs = ["q"++ arVerbosity] + ++ [vanillaLibFilePath] + arObjArgs = + hObjs + ++ map (pref ) cObjs + ++ stubObjs + arProfArgs = ["q"++ arVerbosity] + ++ [profileLibFilePath] + arProfObjArgs = + hProfObjs + ++ map (pref ) cObjs + ++ stubProfObjs + ldArgs = ["-r"] + ++ ["-o", ghciLibFilePath <.> "tmp"] + ldObjArgs = + hObjs + ++ map (pref ) cObjs + ++ stubObjs + ghcSharedObjArgs = + hSharedObjs + ++ map (pref ) cSharedObjs + ++ stubSharedObjs + -- After the relocation lib is created we invoke ghc -shared + -- with the dependencies spelled out as -package arguments + -- and ghc invokes the linker with the proper library paths + ghcSharedLinkArgs = + [ "-no-auto-link-packages", + "-shared", + "-dynamic", + "-o", sharedLibFilePath ] + ++ ghcSharedObjArgs + ++ ["-package-name", display pkgid ] + ++ ghcPackageFlags lbi clbi + ++ ["-l"++extraLib | extraLib <- extraLibs libBi] + ++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs libBi] + + runLd ldLibName args = do + exists <- doesFileExist ldLibName + -- This method is called iteratively by xargs. The + -- output goes to .tmp, and any existing file + -- named is included when linking. The + -- output is renamed to . + rawSystemProgramConf verbosity ldProgram (withPrograms lbi) + (args ++ if exists then [ldLibName] else []) + renameFile (ldLibName <.> "tmp") ldLibName + + runAr = rawSystemProgramConf verbosity arProgram (withPrograms lbi) + + --TODO: discover this at configure time or runtime on unix + -- The value is 32k on Windows and posix specifies a minimum of 4k + -- but all sensible unixes use more than 4k. + -- we could use getSysVar ArgumentLimit but that's in the unix lib + maxCommandLineSize = 30 * 1024 + + ifVanillaLib False $ xargs maxCommandLineSize + runAr arArgs arObjArgs + + ifProfLib $ xargs maxCommandLineSize + runAr arProfArgs arProfObjArgs + + ifGHCiLib $ xargs maxCommandLineSize + (runLd ghciLibFilePath) ldArgs ldObjArgs + + ifSharedLib $ runGhcProg ghcSharedLinkArgs + + +-- | Build an executable with LHC. +-- +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity _pkg_descr lbi + exe@Executable { exeName = exeName', modulePath = modPath } clbi = do + let pref = buildDir lbi + runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) + + exeBi <- hackThreadedFlag verbosity + (compiler lbi) (withProfExe lbi) (buildInfo exe) + + -- exeNameReal, the name that GHC really uses (with .exe on Windows) + let exeNameReal = exeName' <.> + (if null $ takeExtension exeName' then exeExtension else "") + + let targetDir = pref exeName' + let exeDir = targetDir (exeName' ++ "-tmp") + createDirectoryIfMissingVerbose verbosity True targetDir + createDirectoryIfMissingVerbose verbosity True exeDir + -- TODO: do we need to put hs-boot files into place for mutually recursive modules? + -- FIX: what about exeName.hi-boot? + + -- build executables + unless (null (cSources exeBi)) $ do + info verbosity "Building C Sources." + sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi clbi + exeDir filename verbosity + createDirectoryIfMissingVerbose verbosity True odir + runGhcProg args + | filename <- cSources exeBi] + + srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath + + let cObjs = map (`replaceExtension` objExtension) (cSources exeBi) + let lhcWrap x = ("--ghc-opts\"":x) ++ ["\""] + let binArgs linkExe profExe = + (if linkExe + then ["-o", targetDir exeNameReal] + else ["-c"]) + ++ constructGHCCmdLine lbi exeBi clbi exeDir verbosity + ++ [exeDir x | x <- cObjs] + ++ [srcMainFile] + ++ ["-optl" ++ opt | opt <- PD.ldOptions exeBi] + ++ ["-l"++lib | lib <- extraLibs exeBi] + ++ ["-L"++libDir | libDir <- extraLibDirs exeBi] + ++ concat [["-framework", f] | f <- PD.frameworks exeBi] + ++ if profExe + then ["-prof", + "-hisuf", "p_hi", + "-osuf", "p_o" + ] ++ 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 && EnableExtension TemplateHaskell `elem` allExtensions exeBi) + (runGhcProg $ lhcWrap (binArgs False False)) + + runGhcProg (binArgs True (withProfExe lbi)) + +-- | Filter the "-threaded" flag when profiling as it does not +-- work with ghc-6.8 and older. +hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo +hackThreadedFlag verbosity comp prof bi + | not mustFilterThreaded = return bi + | otherwise = do + warn verbosity $ "The ghc flag '-threaded' is not compatible with " + ++ "profiling in ghc-6.8 and older. It will be disabled." + return bi { options = filterHcOptions (/= "-threaded") (options bi) } + where + mustFilterThreaded = prof && compilerVersion comp < Version [6, 10] [] + && "-threaded" `elem` hcOptions GHC bi + filterHcOptions p hcoptss = + [ (hc, if hc == GHC then filter p opts else opts) + | (hc, opts) <- hcoptss ] + +-- when using -split-objs, we need to search for object files in the +-- Module_split directory for each module. +getHaskellObjects :: Library -> LocalBuildInfo + -> FilePath -> String -> Bool -> IO [FilePath] +getHaskellObjects lib lbi pref wanted_obj_ext allow_split_objs + | splitObjs lbi && allow_split_objs = do + let dirs = [ pref (ModuleName.toFilePath x ++ "_split") + | x <- libModules lib ] + objss <- mapM getDirectoryContents dirs + let objs = [ dir obj + | (objs',dir) <- zip objss dirs, obj <- objs', + let obj_ext = takeExtension obj, + '.':wanted_obj_ext == obj_ext ] + return objs + | otherwise = + return [ pref ModuleName.toFilePath x <.> wanted_obj_ext + | x <- libModules lib ] + + +constructGHCCmdLine + :: LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> Verbosity + -> [String] +constructGHCCmdLine lbi bi clbi odir verbosity = + ["--make"] + ++ ghcVerbosityOptions verbosity + -- Unsupported extensions have already been checked by configure + ++ ghcOptions lbi bi clbi odir + +ghcVerbosityOptions :: Verbosity -> [String] +ghcVerbosityOptions verbosity + | verbosity >= deafening = ["-v"] + | verbosity >= normal = [] + | otherwise = ["-w", "-v0"] + +ghcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> [String] +ghcOptions lbi bi clbi odir + = ["-hide-all-packages"] + ++ ghcPackageDbOptions (withPackageDB lbi) + ++ (if splitObjs lbi then ["-split-objs"] else []) + ++ ["-i"] + ++ ["-i" ++ odir] + ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] + ++ ["-i" ++ autogenModulesDir lbi] + ++ ["-I" ++ autogenModulesDir lbi] + ++ ["-I" ++ odir] + ++ ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ ["-optP" ++ opt | opt <- cppOptions bi] + ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi cppHeaderName) ] + ++ [ "-#include \"" ++ inc ++ "\"" | inc <- PD.includes bi ] + ++ [ "-odir", odir, "-hidir", odir ] + ++ (if compilerVersion c >= Version [6,8] [] + then ["-stubdir", odir] else []) + ++ ghcPackageFlags lbi clbi + ++ (case withOptimization lbi of + NoOptimisation -> [] + NormalOptimisation -> ["-O"] + MaximumOptimisation -> ["-O2"]) + ++ hcOptions GHC bi + ++ languageToFlags c (defaultLanguage bi) + ++ extensionsToFlags c (usedExtensions bi) + where c = compiler lbi + +ghcPackageFlags :: LocalBuildInfo -> ComponentLocalBuildInfo -> [String] +ghcPackageFlags lbi clbi + | ghcVer >= Version [6,11] [] + = concat [ ["-package-id", display ipkgid] + | (ipkgid, _) <- componentPackageDeps clbi ] + + | otherwise = concat [ ["-package", display pkgid] + | (_, pkgid) <- componentPackageDeps clbi ] + where + ghcVer = compilerVersion (compiler lbi) + +ghcPackageDbOptions :: PackageDBStack -> [String] +ghcPackageDbOptions dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs + (GlobalPackageDB:dbs) -> "-no-user-package-conf" + : concatMap specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = [ "-package-conf", db ] + specific _ = ierror + ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) + +constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> FilePath -> Verbosity -> (FilePath,[String]) +constructCcCmdLine lbi bi clbi pref filename verbosity + = let odir | compilerVersion (compiler lbi) >= Version [6,4,1] [] = pref + | otherwise = pref takeDirectory filename + -- ghc 6.4.1 fixed a bug in -odir handling + -- for C compilations. + in + (odir, + ghcCcOptions lbi bi clbi odir + ++ (if verbosity >= deafening then ["-v"] else []) + ++ ["-c",filename]) + + +ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> [String] +ghcCcOptions lbi bi clbi odir + = ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ ghcPackageDbOptions (withPackageDB lbi) + ++ ghcPackageFlags lbi clbi + ++ ["-optc" ++ opt | opt <- PD.ccOptions bi] + ++ (case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-optc-O2"]) + ++ ["-odir", odir] + +mkGHCiLibName :: PackageIdentifier -> String +mkGHCiLibName lib = "HS" ++ display lib <.> "o" + +-- ----------------------------------------------------------------------------- +-- Installing + +-- |Install executables for GHC. +installExe :: Verbosity + -> LocalBuildInfo + -> InstallDirs FilePath -- ^Where to copy the files to + -> FilePath -- ^Build location + -> (FilePath, FilePath) -- ^Executable (prefix,suffix) + -> PackageDescription + -> Executable + -> IO () +installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do + let binDir = bindir installDirs + createDirectoryIfMissingVerbose verbosity True binDir + let exeFileName = exeName exe <.> exeExtension + fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix + installBinary dest = do + installExecutableFile verbosity + (buildPref exeName exe exeFileName) + (dest <.> exeExtension) + stripExe verbosity lbi exeFileName (dest <.> exeExtension) + installBinary (binDir fixedExeBaseName) + +stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO () +stripExe verbosity lbi name path = when (stripExes lbi) $ + case lookupProgram stripProgram (withPrograms lbi) of + Just strip -> rawSystemProgram verbosity strip args + Nothing -> unless (buildOS == Windows) $ + -- Don't bother warning on windows, we don't expect them to + -- have the strip program anyway. + warn verbosity $ "Unable to strip executable '" ++ name + ++ "' (missing the 'strip' program)" + where + args = path : case buildOS of + OSX -> ["-x"] -- By default, stripping the ghc binary on at least + -- some OS X installations causes: + -- HSbase-3.0.o: unknown symbol `_environ'" + -- The -x flag fixes that. + _ -> [] + +-- |Install for ghc, .hi, .a and, if --with-ghci given, .o +installLib :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^install location + -> FilePath -- ^install location for dynamic librarys + -> FilePath -- ^Build location + -> PackageDescription + -> Library + -> IO () +installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do + -- copy .hi files over: + let copy src dst n = do + createDirectoryIfMissingVerbose verbosity True dst + installOrdinaryFile verbosity (src n) (dst n) + copyModuleFiles ext = + findModuleFiles [builtDir] [ext] (libModules lib) + >>= installOrdinaryFiles verbosity targetDir + ifVanilla $ copyModuleFiles "hi" + ifProf $ copyModuleFiles "p_hi" + hcrFiles <- findModuleFiles (builtDir : hsSourceDirs (libBuildInfo lib)) ["hcr"] (libModules lib) + flip mapM_ hcrFiles $ \(srcBase, srcFile) -> runLhc ["--install-library", srcBase srcFile] + + -- copy the built library files over: + ifVanilla $ copy builtDir targetDir vanillaLibName + ifProf $ copy builtDir targetDir profileLibName + ifGHCi $ copy builtDir targetDir ghciLibName + ifShared $ copy builtDir dynlibTargetDir sharedLibName + + -- run ranlib if necessary: + ifVanilla $ updateLibArchive verbosity lbi + (targetDir vanillaLibName) + ifProf $ updateLibArchive verbosity lbi + (targetDir profileLibName) + + where + vanillaLibName = mkLibName pkgid + profileLibName = mkProfLibName pkgid + ghciLibName = mkGHCiLibName pkgid + sharedLibName = mkSharedLibName pkgid (compilerId (compiler lbi)) + + pkgid = packageId pkg + + hasLib = not $ null (libModules lib) + && null (cSources (libBuildInfo lib)) + ifVanilla = when (hasLib && withVanillaLib lbi) + ifProf = when (hasLib && withProfLib lbi) + ifGHCi = when (hasLib && withGHCiLib lbi) + ifShared = when (hasLib && withSharedLib lbi) + + runLhc = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) + +-- | use @ranlib@ or @ar -s@ to build an index. This is necessary on systems +-- like MacOS X. If we can't find those, don't worry too much about it. +-- +updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO () +updateLibArchive verbosity lbi path = + case lookupProgram ranlibProgram (withPrograms lbi) of + Just ranlib -> rawSystemProgram verbosity ranlib [path] + Nothing -> case lookupProgram arProgram (withPrograms lbi) of + Just ar -> rawSystemProgram verbosity ar ["-s", path] + Nothing -> warn verbosity $ + "Unable to generate a symbol index for the static " + ++ "library '" ++ path + ++ "' (missing the 'ranlib' and 'ar' programs)" + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage + :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do + let Just lhcPkg = lookupProgram lhcPkgProgram (withPrograms lbi) + HcPkg.reregister verbosity lhcPkg packageDbs (Right installedPkgInfo) diff --git a/cabal/cabal/Distribution/Simple/LocalBuildInfo.hs b/cabal/cabal/Distribution/Simple/LocalBuildInfo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/LocalBuildInfo.hs @@ -0,0 +1,306 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.LocalBuildInfo +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Once a package has been configured we have resolved conditionals and +-- dependencies, configured the compiler and other needed external programs. +-- The 'LocalBuildInfo' is used to hold all this information. It holds the +-- install dirs, the compiler, the exact package dependencies, the configured +-- programs, the package database to use and a bunch of miscellaneous configure +-- flags. It gets saved and reloaded from a file (@dist\/setup-config@). It gets +-- passed in to very many subsequent build actions. + +{- 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(..), + externalPackageDeps, + inplacePackageId, + + -- * Buildable package components + Component(..), + foldComponent, + allComponentsBy, + ComponentName(..), + ComponentLocalBuildInfo(..), + withComponentsLBI, + withLibLBI, + withExeLBI, + withTestLBI, + + -- * Installation directories + module Distribution.Simple.InstallDirs, + absoluteInstallDirs, prefixRelativeInstallDirs, + substPathTemplate + ) where + + +import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs, + prefixRelativeInstallDirs, + substPathTemplate, ) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Simple.Program (ProgramConfiguration) +import Distribution.PackageDescription + ( PackageDescription(..), withLib, Library(libBuildInfo), withExe + , Executable(exeName, buildInfo), withTest, TestSuite(..) + , BuildInfo(buildable) ) +import Distribution.Package + ( PackageId, Package(..), InstalledPackageId(..) ) +import Distribution.Simple.Compiler + ( Compiler(..), PackageDBStack, OptimisationLevel ) +import Distribution.Simple.PackageIndex + ( PackageIndex ) +import Distribution.Simple.Utils + ( die ) +import Distribution.Simple.Setup + ( ConfigFlags ) +import Distribution.Text + ( display ) + +import Data.List (nub, find) + +-- | Data cached after configuration step. See also +-- 'Distribution.Simple.Setup.ConfigFlags'. +data LocalBuildInfo = LocalBuildInfo { + configFlags :: ConfigFlags, + -- ^ Options passed to the configuration step. + -- Needed to re-run configuration when .cabal is out of date + extraConfigArgs :: [String], + -- ^ Extra args on the command line for the configuration step. + -- Needed to re-run configuration when .cabal is out of date + installDirTemplates :: InstallDirTemplates, + -- ^ The installation directories for the various differnt + -- kinds of files + --TODO: inplaceDirTemplates :: InstallDirs FilePath + compiler :: Compiler, + -- ^ The compiler we're building with + buildDir :: FilePath, + -- ^ Where to build the package. + --TODO: eliminate hugs's scratchDir, use builddir + scratchDir :: FilePath, + -- ^ Where to put the result of the Hugs build. + libraryConfig :: Maybe ComponentLocalBuildInfo, + executableConfigs :: [(String, ComponentLocalBuildInfo)], + compBuildOrder :: [ComponentName], + -- ^ All the components to build, ordered by topological sort + -- over the intrapackage dependency graph + testSuiteConfigs :: [(String, ComponentLocalBuildInfo)], + installedPkgs :: PackageIndex, + -- ^ All the info about the installed packages that the + -- current package depends on (directly or indirectly). + pkgDescrFile :: Maybe FilePath, + -- ^ the filename containing the .cabal file, if available + localPkgDescr :: PackageDescription, + -- ^ The resolved package description, that does not contain + -- any conditionals. + withPrograms :: ProgramConfiguration, -- ^Location and args for all programs + withPackageDB :: PackageDBStack, -- ^What package database to use, global\/user + withVanillaLib:: Bool, -- ^Whether to build normal libs. + withProfLib :: Bool, -- ^Whether to build profiling versions of libs. + withSharedLib :: Bool, -- ^Whether to build shared versions of libs. + withDynExe :: Bool, -- ^Whether to link executables dynamically + withProfExe :: Bool, -- ^Whether to build executables for profiling. + withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (if available). + withGHCiLib :: Bool, -- ^Whether to build libs suitable for use with GHCi. + splitObjs :: Bool, -- ^Use -split-objs with GHC, if available + stripExes :: Bool, -- ^Whether to strip executables during install + progPrefix :: PathTemplate, -- ^Prefix to be prepended to installed executables + progSuffix :: PathTemplate -- ^Suffix to be appended to installed executables + } deriving (Read, Show) + +-- | External package dependencies for the package as a whole, the union of the +-- individual 'targetPackageDeps'. +externalPackageDeps :: LocalBuildInfo -> [(InstalledPackageId, PackageId)] +externalPackageDeps lbi = nub $ + -- TODO: what about non-buildable components? + maybe [] componentPackageDeps (libraryConfig lbi) + ++ concatMap (componentPackageDeps . snd) (executableConfigs lbi) + +-- | The installed package Id we use for local packages registered in the local +-- package db. This is what is used for intra-package deps between components. +-- +inplacePackageId :: PackageId -> InstalledPackageId +inplacePackageId pkgid = InstalledPackageId (display pkgid ++ "-inplace") + +-- ----------------------------------------------------------------------------- +-- Buildable components + +data Component = CLib Library + | CExe Executable + | CTest TestSuite + deriving (Show, Eq, Read) + +data ComponentName = CLibName -- currently only a single lib + | CExeName String + | CTestName String + deriving (Show, Eq, Read) + +data ComponentLocalBuildInfo = ComponentLocalBuildInfo { + -- | Resolved internal and external package dependencies for this component. + -- The 'BuildInfo' 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. + componentPackageDeps :: [(InstalledPackageId, PackageId)] + } + deriving (Read, Show) + +foldComponent :: (Library -> a) + -> (Executable -> a) + -> (TestSuite -> a) + -> Component + -> a +foldComponent f _ _ (CLib lib) = f lib +foldComponent _ f _ (CExe exe) = f exe +foldComponent _ _ f (CTest tst) = f tst + +-- | Obtains all components (libs, exes, or test suites), transformed by the +-- given function. Useful for gathering dependencies with component context. +allComponentsBy :: PackageDescription + -> (Component -> a) + -> [a] +allComponentsBy pkg_descr f = + [ f (CLib lib) | Just lib <- [library pkg_descr] + , buildable (libBuildInfo lib) ] + ++ [ f (CExe exe) | exe <- executables pkg_descr + , buildable (buildInfo exe) ] + ++ [ f (CTest tst) | tst <- testSuites pkg_descr + , buildable (testBuildInfo tst) + , testEnabled tst ] + +-- |If the package description has a library section, call the given +-- function with the library build info as argument. Extended version of +-- 'withLib' that also gives corresponding build info. +withLibLBI :: PackageDescription -> LocalBuildInfo + -> (Library -> ComponentLocalBuildInfo -> IO ()) -> IO () +withLibLBI pkg_descr lbi f = withLib pkg_descr $ \lib -> + case libraryConfig lbi of + Just clbi -> f lib clbi + Nothing -> die missingLibConf + +-- | Perform the action on each buildable 'Executable' in the package +-- description. Extended version of 'withExe' that also gives corresponding +-- build info. +withExeLBI :: PackageDescription -> LocalBuildInfo + -> (Executable -> ComponentLocalBuildInfo -> IO ()) -> IO () +withExeLBI pkg_descr lbi f = withExe pkg_descr $ \exe -> + case lookup (exeName exe) (executableConfigs lbi) of + Just clbi -> f exe clbi + Nothing -> die (missingExeConf (exeName exe)) + +withTestLBI :: PackageDescription -> LocalBuildInfo + -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO () +withTestLBI pkg_descr lbi f = withTest pkg_descr $ \test -> + case lookup (testName test) (testSuiteConfigs lbi) of + Just clbi -> f test clbi + Nothing -> die (missingTestConf (testName test)) + +-- | Perform the action on each buildable 'Library' or 'Executable' (Component) +-- in the PackageDescription, subject to the build order specified by the +-- 'compBuildOrder' field of the given 'LocalBuildInfo' +withComponentsLBI :: PackageDescription -> LocalBuildInfo + -> (Component -> ComponentLocalBuildInfo -> IO ()) + -> IO () +withComponentsLBI pkg_descr lbi f = mapM_ compF (compBuildOrder lbi) + where + compF CLibName = + case library pkg_descr of + Nothing -> die missinglib + Just lib -> case libraryConfig lbi of + Nothing -> die missingLibConf + Just clbi -> f (CLib lib) clbi + where + missinglib = "internal error: component list includes a library " + ++ "but the package description contains no library" + + compF (CExeName name) = + case find (\exe -> exeName exe == name) (executables pkg_descr) of + Nothing -> die missingexe + Just exe -> case lookup name (executableConfigs lbi) of + Nothing -> die (missingExeConf name) + Just clbi -> f (CExe exe) clbi + where + missingexe = "internal error: component list includes an executable " + ++ name ++ " but the package contains no such executable." + + compF (CTestName name) = + case find (\tst -> testName tst == name) (testSuites pkg_descr) of + Nothing -> die missingtest + Just tst -> case lookup name (testSuiteConfigs lbi) of + Nothing -> die (missingTestConf name) + Just clbi -> f (CTest tst) clbi + where + missingtest = "internal error: component list includes a test suite " + ++ name ++ " but the package contains no such test suite." + +missingLibConf :: String +missingExeConf, missingTestConf :: String -> String + +missingLibConf = "internal error: the package contains a library " + ++ "but there is no corresponding configuration data" +missingExeConf name = "internal error: the package contains an executable " + ++ name ++ " but there is no corresponding configuration data" +missingTestConf name = "internal error: the package contains a test suite " + ++ name ++ " but there is no corresponding configuration data" + + +-- ----------------------------------------------------------------------------- +-- Wrappers for a couple functions from InstallDirs + +-- |See 'InstallDirs.absoluteInstallDirs' +absoluteInstallDirs :: PackageDescription -> LocalBuildInfo -> CopyDest + -> InstallDirs FilePath +absoluteInstallDirs pkg lbi copydest = + InstallDirs.absoluteInstallDirs + (packageId pkg) + (compilerId (compiler lbi)) + copydest + (installDirTemplates lbi) + +-- |See 'InstallDirs.prefixRelativeInstallDirs' +prefixRelativeInstallDirs :: PackageId -> LocalBuildInfo + -> InstallDirs (Maybe FilePath) +prefixRelativeInstallDirs pkg_descr lbi = + InstallDirs.prefixRelativeInstallDirs + (packageId pkg_descr) + (compilerId (compiler lbi)) + (installDirTemplates lbi) + +substPathTemplate :: PackageId -> LocalBuildInfo + -> PathTemplate -> FilePath +substPathTemplate pkgid lbi = fromPathTemplate + . ( InstallDirs.substPathTemplate env ) + where env = initialPathTemplateEnv + pkgid + (compilerId (compiler lbi)) diff --git a/cabal/cabal/Distribution/Simple/NHC.hs b/cabal/cabal/Distribution/Simple/NHC.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/NHC.hs @@ -0,0 +1,424 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.NHC +-- Copyright : Isaac Jones 2003-2006 +-- Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains most of the NHC-specific code for configuring, building +-- and installing packages. + +{- 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 ( + configure, + getInstalledPackages, + buildLib, + buildExe, + installLib, + installExe, + ) where + +import Distribution.Package + ( PackageName, PackageIdentifier(..), InstalledPackageId(..) + , packageId, packageName ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo + , InstalledPackageInfo_( InstalledPackageInfo, installedPackageId + , sourcePackageId ) + , emptyInstalledPackageInfo, parseInstalledPackageInfo ) +import Distribution.PackageDescription + ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..) + , hcOptions, usedExtensions ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) +import Distribution.Simple.BuildPaths + ( mkLibName, objExtension, exeExtension ) +import Distribution.Simple.Compiler + ( CompilerFlavor(..), CompilerId(..), Compiler(..) + , Flag, languageToFlags, extensionsToFlags + , PackageDB(..), PackageDBStack ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (PackageIndex) +import Language.Haskell.Extension + ( Language(Haskell98), Extension(..), KnownExtension(..) ) +import Distribution.Simple.Program + ( ProgramConfiguration, userMaybeSpecifyPath, programPath + , requireProgram, requireProgramVersion, lookupProgram + , nhcProgram, hmakeProgram, ldProgram, arProgram + , rawSystemProgramConf ) +import Distribution.Simple.Utils + ( die, info, findFileWithExtension, findModuleFiles + , installOrdinaryFile, installExecutableFile, installOrdinaryFiles + , createDirectoryIfMissingVerbose, withUTF8FileContents ) +import Distribution.Version + ( Version(..), orLaterVersion ) +import Distribution.Verbosity +import Distribution.Text + ( display, simpleParse ) +import Distribution.ParseUtils + ( ParseResult(..) ) + +import System.FilePath + ( (), (<.>), normalise, takeDirectory, dropExtension ) +import System.Directory + ( doesFileExist, doesDirectoryExist, getDirectoryContents + , removeFile, getHomeDirectory ) + +import Data.Char ( toLower ) +import Data.List ( nub ) +import Data.Maybe ( catMaybes ) +import Data.Monoid ( Monoid(..) ) +import Control.Monad ( when, unless ) +import Distribution.Compat.Exception + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) +configure verbosity hcPath _hcPkgPath conf = do + + (_nhcProg, nhcVersion, conf') <- + requireProgramVersion verbosity nhcProgram + (orLaterVersion (Version [1,20] [])) + (userMaybeSpecifyPath "nhc98" hcPath conf) + + (_hmakeProg, _hmakeVersion, conf'') <- + requireProgramVersion verbosity hmakeProgram + (orLaterVersion (Version [3,13] [])) conf' + (_ldProg, conf''') <- requireProgram verbosity ldProgram conf'' + (_arProg, conf'''') <- requireProgram verbosity arProgram conf''' + + --TODO: put this stuff in a monad so we can say just: + -- requireProgram hmakeProgram (orLaterVersion (Version [3,13] [])) + -- requireProgram ldProgram anyVersion + -- requireProgram ldPrograrProgramam anyVersion + -- unless (null (cSources bi)) $ requireProgram ccProgram anyVersion + + let comp = Compiler { + compilerId = CompilerId NHC nhcVersion, + compilerLanguages = nhcLanguages, + compilerExtensions = nhcLanguageExtensions + } + return (comp, conf'''') + +nhcLanguages :: [(Language, Flag)] +nhcLanguages = [(Haskell98, "-98")] + +-- | The flags for the supported extensions +nhcLanguageExtensions :: [(Extension, Flag)] +nhcLanguageExtensions = + -- TODO: pattern guards in 1.20 + -- NHC doesn't enforce the monomorphism restriction at all. + -- Technically it therefore doesn't support MonomorphismRestriction, + -- but that would mean it doesn't support Haskell98, so we pretend + -- that it does. + [(EnableExtension MonomorphismRestriction, "") + ,(DisableExtension MonomorphismRestriction, "") + -- Similarly, I assume the FFI is always on + ,(EnableExtension ForeignFunctionInterface, "") + ,(DisableExtension ForeignFunctionInterface, "") + -- Similarly, I assume existential quantification is always on + ,(EnableExtension ExistentialQuantification, "") + ,(DisableExtension ExistentialQuantification, "") + -- Similarly, I assume empty data decls is always on + ,(EnableExtension EmptyDataDecls, "") + ,(DisableExtension EmptyDataDecls, "") + ,(EnableExtension NamedFieldPuns, "-puns") + ,(DisableExtension NamedFieldPuns, "-nopuns") + -- CPP can't actually be turned off, but we pretend that it can + ,(EnableExtension CPP, "-cpp") + ,(DisableExtension CPP, "") + ] + +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity packagedbs conf = do + homedir <- getHomeDirectory + (nhcProg, _) <- requireProgram verbosity nhcProgram conf + let bindir = takeDirectory (programPath nhcProg) + incdir = takeDirectory bindir "include" "nhc98" + dbdirs = nub (concatMap (packageDbPaths homedir incdir) packagedbs) + indexes <- mapM getIndividualDBPackages dbdirs + return $! mconcat indexes + + where + getIndividualDBPackages :: FilePath -> IO PackageIndex + getIndividualDBPackages dbdir = do + pkgdirs <- getPackageDbDirs dbdir + pkgs <- sequence [ getInstalledPackage pkgname pkgdir + | (pkgname, pkgdir) <- pkgdirs ] + let pkgs' = map setInstalledPackageId (catMaybes pkgs) + return (PackageIndex.fromList pkgs') + +packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] +packageDbPaths _home incdir db = case db of + GlobalPackageDB -> [ incdir "packages" ] + UserPackageDB -> [] --TODO any standard per-user db? + SpecificPackageDB path -> [ path ] + +getPackageDbDirs :: FilePath -> IO [(PackageName, FilePath)] +getPackageDbDirs dbdir = do + dbexists <- doesDirectoryExist dbdir + if not dbexists + then return [] + else do + entries <- getDirectoryContents dbdir + pkgdirs <- sequence + [ do pkgdirExists <- doesDirectoryExist pkgdir + return (pkgname, pkgdir, pkgdirExists) + | (entry, Just pkgname) <- [ (entry, simpleParse entry) + | entry <- entries ] + , let pkgdir = dbdir entry ] + return [ (pkgname, pkgdir) | (pkgname, pkgdir, True) <- pkgdirs ] + +getInstalledPackage :: PackageName -> FilePath -> IO (Maybe InstalledPackageInfo) +getInstalledPackage pkgname pkgdir = do + let pkgconfFile = pkgdir "package.conf" + pkgconfExists <- doesFileExist pkgconfFile + + let cabalFile = pkgdir <.> "cabal" + cabalExists <- doesFileExist cabalFile + + case () of + _ | pkgconfExists -> getFullInstalledPackageInfo pkgname pkgconfFile + | cabalExists -> getPhonyInstalledPackageInfo pkgname cabalFile + | otherwise -> return Nothing + +getFullInstalledPackageInfo :: PackageName -> FilePath + -> IO (Maybe InstalledPackageInfo) +getFullInstalledPackageInfo pkgname pkgconfFile = + withUTF8FileContents pkgconfFile $ \contents -> + case parseInstalledPackageInfo contents of + ParseOk _ pkginfo | packageName pkginfo == pkgname + -> return (Just pkginfo) + _ -> return Nothing + +-- | This is a backup option for existing versions of nhc98 which do not supply +-- proper installed package info files for the bundled libs. Instead we look +-- for the .cabal file and extract the package version from that. +-- We don't know any other details for such packages, in particular we pretend +-- that they have no dependencies. +-- +getPhonyInstalledPackageInfo :: PackageName -> FilePath + -> IO (Maybe InstalledPackageInfo) +getPhonyInstalledPackageInfo pkgname pathsModule = do + content <- readFile pathsModule + case extractVersion content of + Nothing -> return Nothing + Just version -> return (Just pkginfo) + where + pkgid = PackageIdentifier pkgname version + pkginfo = emptyInstalledPackageInfo { sourcePackageId = pkgid } + where + -- search through the .cabal file, looking for a line like: + -- + -- > version: 2.0 + -- + extractVersion :: String -> Maybe Version + extractVersion content = + case catMaybes (map extractVersionLine (lines content)) of + [version] -> Just version + _ -> Nothing + extractVersionLine :: String -> Maybe Version + extractVersionLine line = + case words line of + [versionTag, ":", versionStr] + | map toLower versionTag == "version" -> simpleParse versionStr + [versionTag, versionStr] + | map toLower versionTag == "version:" -> simpleParse versionStr + _ -> Nothing + +-- Older installed package info files did not have the installedPackageId +-- field, so if it is missing then we fill it as the source package ID. +setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo +setInstalledPackageId pkginfo@InstalledPackageInfo { + installedPackageId = InstalledPackageId "", + sourcePackageId = pkgid + } + = pkginfo { + --TODO use a proper named function for the conversion + -- from source package id to installed package id + installedPackageId = InstalledPackageId (display pkgid) + } +setInstalledPackageId pkginfo = pkginfo + +-- ----------------------------------------------------------------------------- +-- Building + +-- |FIX: For now, the target must contain a main module. Not used +-- ATM. Re-add later. +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + let conf = withPrograms lbi + Just nhcProg = lookupProgram nhcProgram conf + let bi = libBuildInfo lib + modules = exposedModules lib ++ otherModules bi + -- Unsupported extensions have already been checked by configure + languageFlags = languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) + inFiles <- getModulePaths lbi bi modules + let targetDir = buildDir lbi + srcDirs = nub (map takeDirectory inFiles) + destDirs = map (targetDir ) srcDirs + mapM_ (createDirectoryIfMissingVerbose verbosity True) destDirs + rawSystemProgramConf verbosity hmakeProgram conf $ + ["-hc=" ++ programPath nhcProg] + ++ nhcVerbosityOptions verbosity + ++ ["-d", targetDir, "-hidir", targetDir] + ++ maybe [] (hcOptions NHC . libBuildInfo) + (library pkg_descr) + ++ languageFlags + ++ concat [ ["-package", display (packageName pkgid) ] + | (_, pkgid) <- componentPackageDeps clbi ] + ++ inFiles +{- + -- build any C sources + unless (null (cSources bi)) $ do + info verbosity "Building C Sources..." + let commonCcArgs = (if verbosity >= deafening then ["-v"] else []) + ++ ["-I" ++ dir | dir <- includeDirs bi] + ++ [opt | opt <- ccOptions bi] + ++ (if withOptimization lbi then ["-O2"] else []) + flip mapM_ (cSources bi) $ \cfile -> do + let ofile = targetDir cfile `replaceExtension` objExtension + createDirectoryIfMissingVerbose verbosity True (takeDirectory ofile) + rawSystemProgramConf verbosity hmakeProgram conf + (commonCcArgs ++ ["-c", cfile, "-o", ofile]) +-} + -- link: + info verbosity "Linking..." + let --cObjs = [ targetDir cFile `replaceExtension` objExtension + -- | cFile <- cSources bi ] + libFilePath = targetDir mkLibName (packageId pkg_descr) + hObjs = [ targetDir ModuleName.toFilePath m <.> objExtension + | m <- modules ] + + unless (null hObjs {-&& null cObjs-}) $ do + -- first remove library if it exists + removeFile libFilePath `catchIO` \_ -> return () + + let arVerbosity | verbosity >= deafening = "v" + | verbosity >= normal = "" + | otherwise = "c" + + rawSystemProgramConf verbosity arProgram (withPrograms lbi) $ + ["q"++ arVerbosity, libFilePath] + ++ hObjs +-- ++ cObjs + +-- | Building an executable for NHC. +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity pkg_descr lbi exe clbi = do + let conf = withPrograms lbi + Just nhcProg = lookupProgram nhcProgram conf + when (dropExtension (modulePath exe) /= exeName exe) $ + die $ "hmake does not support exe names that do not match the name of " + ++ "the 'main-is' file. You will have to rename your executable to " + ++ show (dropExtension (modulePath exe)) + let bi = buildInfo exe + modules = otherModules bi + -- Unsupported extensions have already been checked by configure + languageFlags = languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) + inFiles <- getModulePaths lbi bi modules + let targetDir = buildDir lbi exeName exe + exeDir = targetDir (exeName exe ++ "-tmp") + srcDirs = nub (map takeDirectory (modulePath exe : inFiles)) + destDirs = map (exeDir ) srcDirs + mapM_ (createDirectoryIfMissingVerbose verbosity True) destDirs + rawSystemProgramConf verbosity hmakeProgram conf $ + ["-hc=" ++ programPath nhcProg] + ++ nhcVerbosityOptions verbosity + ++ ["-d", targetDir, "-hidir", targetDir] + ++ maybe [] (hcOptions NHC . libBuildInfo) + (library pkg_descr) + ++ languageFlags + ++ concat [ ["-package", display (packageName pkgid) ] + | (_, pkgid) <- componentPackageDeps clbi ] + ++ inFiles + ++ [exeName exe] + +nhcVerbosityOptions :: Verbosity -> [String] +nhcVerbosityOptions verbosity + | verbosity >= deafening = ["-v"] + | verbosity >= normal = [] + | otherwise = ["-q"] + +--TODO: where to put this? it's duplicated in .Simple too +getModulePaths :: LocalBuildInfo -> BuildInfo -> [ModuleName] -> IO [FilePath] +getModulePaths lbi bi modules = sequence + [ findFileWithExtension ["hs", "lhs"] (buildDir lbi : hsSourceDirs bi) + (ModuleName.toFilePath module_) >>= maybe (notFound module_) (return . normalise) + | module_ <- modules ] + where notFound module_ = die $ "can't find source for module " ++ display module_ + +-- ----------------------------------------------------------------------------- +-- Installing + +-- |Install executables for NHC. +installExe :: Verbosity -- ^verbosity + -> FilePath -- ^install location + -> FilePath -- ^Build location + -> (FilePath, FilePath) -- ^Executable (prefix,suffix) + -> Executable + -> IO () +installExe verbosity pref buildPref (progprefix,progsuffix) exe + = do createDirectoryIfMissingVerbose verbosity True pref + let exeBaseName = exeName exe + exeFileName = exeBaseName <.> exeExtension + fixedExeFileName = (progprefix ++ exeBaseName ++ progsuffix) <.> exeExtension + installExecutableFile verbosity + (buildPref exeBaseName exeFileName) + (pref fixedExeFileName) + +-- |Install for nhc98: .hi and .a files +installLib :: Verbosity -- ^verbosity + -> FilePath -- ^install location + -> FilePath -- ^Build location + -> PackageIdentifier + -> Library + -> IO () +installLib verbosity pref buildPref pkgid lib + = do let bi = libBuildInfo lib + modules = exposedModules lib ++ otherModules bi + findModuleFiles [buildPref] ["hi"] modules + >>= installOrdinaryFiles verbosity pref + let libName = mkLibName pkgid + installOrdinaryFile verbosity (buildPref libName) (pref libName) diff --git a/cabal/cabal/Distribution/Simple/PackageIndex.hs b/cabal/cabal/Distribution/Simple/PackageIndex.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/PackageIndex.hs @@ -0,0 +1,562 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.PackageIndex +-- Copyright : (c) David Himmelstrup 2005, +-- Bjorn Bringert 2007, +-- Duncan Coutts 2008-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- An index of packages. +-- +module Distribution.Simple.PackageIndex ( + -- * Package index data type + PackageIndex, + + -- * Creating an index + fromList, + + -- * Updates + merge, + + insert, + + deleteInstalledPackageId, + deleteSourcePackageId, + deletePackageName, +-- deleteDependency, + + -- * Queries + + -- ** Precise lookups + lookupInstalledPackageId, + lookupSourcePackageId, + lookupPackageName, + lookupDependency, + + -- ** Case-insensitive searches + searchByName, + SearchResult(..), + searchByNameSubstring, + + -- ** Bulk queries + allPackages, + allPackagesByName, + + -- ** Special queries + brokenPackages, + dependencyClosure, + reverseDependencyClosure, + topologicalOrder, + reverseTopologicalOrder, + dependencyInconsistencies, + dependencyCycles, + dependencyGraph, + moduleNameIndex, + ) where + +import Prelude hiding (lookup) +import Control.Exception (assert) +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Tree as Tree +import qualified Data.Graph as Graph +import qualified Data.Array as Array +import Data.Array ((!)) +import Data.List as List + ( null, foldl', sort + , groupBy, sortBy, find, isInfixOf, nubBy, deleteBy, deleteFirstsBy ) +import Data.Monoid (Monoid(..)) +import Data.Maybe (isNothing, fromMaybe) + +import Distribution.Package + ( PackageName(..), PackageId + , Package(..), packageName, packageVersion + , Dependency(Dependency)--, --PackageFixedDeps(..) + , InstalledPackageId(..) ) +import Distribution.ModuleName + ( ModuleName ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo, installedPackageId ) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Version + ( Version, withinRange ) +import Distribution.Simple.Utils (lowercase, comparing, equating) + + +-- | The collection of information about packages from one or more 'PackageDB's. +-- +-- Packages are uniquely identified in by their 'InstalledPackageId', they can +-- also be effeciently looked up by package name or by name and version. +-- +data PackageIndex = PackageIndex + -- The primary index. Each InstalledPackageInfo record is uniquely identified + -- by its InstalledPackageId. + -- + !(Map InstalledPackageId InstalledPackageInfo) + + -- This auxillary index maps package names (case-sensitively) to all the + -- versions and instances of that package. This allows us to find all + -- versions satisfying a dependency. + -- + -- It is a three-level index. The first level is the package name, + -- the second is the package version and the final level is instances + -- of the same package version. These are unique by InstalledPackageId + -- and are kept in preference order. + -- + !(Map PackageName (Map Version [InstalledPackageInfo])) + + deriving (Show, Read) + +instance Monoid PackageIndex where + mempty = PackageIndex Map.empty Map.empty + mappend = merge + --save one mappend with empty in the common case: + mconcat [] = mempty + mconcat xs = foldr1 mappend xs + +invariant :: PackageIndex -> Bool +invariant (PackageIndex pids pnames) = + map installedPackageId (Map.elems pids) + == sort + [ assert pinstOk (installedPackageId pinst) + | (pname, pvers) <- Map.toList pnames + , let pversOk = not (Map.null pvers) + , (pver, pinsts) <- assert pversOk $ Map.toList pvers + , let pinsts' = sortBy (comparing installedPackageId) pinsts + pinstsOk = all (\g -> length g == 1) + (groupBy (equating installedPackageId) pinsts') + , pinst <- assert pinstsOk $ pinsts' + , let pinstOk = packageName pinst == pname + && packageVersion pinst == pver + ] + + +-- +-- * Internal helpers +-- + +mkPackageIndex :: Map InstalledPackageId InstalledPackageInfo + -> Map PackageName (Map Version [InstalledPackageInfo]) + -> PackageIndex +mkPackageIndex pids pnames = assert (invariant index) index + where index = PackageIndex pids pnames + + +-- +-- * Construction +-- + +-- | Build an index out of a bunch of packages. +-- +-- If there are duplicates by 'InstalledPackageId' then later ones mask earlier +-- ones. +-- +fromList :: [InstalledPackageInfo] -> PackageIndex +fromList pkgs = mkPackageIndex pids pnames + where + pids = Map.fromList [ (installedPackageId pkg, pkg) | pkg <- pkgs ] + pnames = + Map.fromList + [ (packageName (head pkgsN), pvers) + | pkgsN <- groupBy (equating packageName) + . sortBy (comparing packageId) + $ pkgs + , let pvers = + Map.fromList + [ (packageVersion (head pkgsNV), + nubBy (equating installedPackageId) (reverse pkgsNV)) + | pkgsNV <- groupBy (equating packageVersion) pkgsN + ] + ] + +-- +-- * Updates +-- + +-- | Merge two indexes. +-- +-- Packages from the second mask packages from the first if they have the exact +-- same 'InstalledPackageId'. +-- +-- For packages with the same source 'PackageId', packages from the second are +-- \"preferred\" over those from the first. Being preferred means they are top +-- result when we do a lookup by source 'PackageId'. This is the mechanism we +-- use to prefer user packages over global packages. +-- +merge :: PackageIndex -> PackageIndex -> PackageIndex +merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) = + mkPackageIndex (Map.union pids1 pids2) + (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2) + where + -- Packages in the second list mask those in the first, however preferred + -- packages go first in the list. + mergeBuckets xs ys = ys ++ (xs \\ ys) + (\\) = deleteFirstsBy (equating installedPackageId) + + +-- | Inserts a single package into the index. +-- +-- This is equivalent to (but slightly quicker than) using 'mappend' or +-- 'merge' with a singleton index. +-- +insert :: InstalledPackageInfo -> PackageIndex -> PackageIndex +insert pkg (PackageIndex pids pnames) = + mkPackageIndex pids' pnames' + + where + pids' = Map.insert (installedPackageId pkg) pkg pids + pnames' = insertPackageName pnames + insertPackageName = + Map.insertWith' (\_ -> insertPackageVersion) + (packageName pkg) + (Map.singleton (packageVersion pkg) [pkg]) + + insertPackageVersion = + Map.insertWith' (\_ -> insertPackageInstance) + (packageVersion pkg) [pkg] + + insertPackageInstance pkgs = + pkg : deleteBy (equating installedPackageId) pkg pkgs + + +-- | Removes a single installed package from the index. +-- +deleteInstalledPackageId :: InstalledPackageId -> PackageIndex -> PackageIndex +deleteInstalledPackageId ipkgid original@(PackageIndex pids pnames) = + case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of + (Nothing, _) -> original + (Just spkgid, pids') -> mkPackageIndex pids' + (deletePkgName spkgid pnames) + + where + deletePkgName spkgid = + Map.update (deletePkgVersion spkgid) (packageName spkgid) + + deletePkgVersion spkgid = + (\m -> if Map.null m then Nothing else Just m) + . Map.update deletePkgInstance (packageVersion spkgid) + + deletePkgInstance = + (\xs -> if List.null xs then Nothing else Just xs) + . List.deleteBy (\_ pkg -> installedPackageId pkg == ipkgid) undefined + + +-- | Removes all packages with this source 'PackageId' from the index. +-- +deleteSourcePackageId :: PackageId -> PackageIndex -> PackageIndex +deleteSourcePackageId pkgid original@(PackageIndex pids pnames) = + case Map.lookup (packageName pkgid) pnames of + Nothing -> original + Just pvers -> case Map.lookup (packageVersion pkgid) pvers of + Nothing -> original + Just pkgs -> mkPackageIndex + (foldl' (flip (Map.delete . installedPackageId)) pids pkgs) + (deletePkgName pnames) + where + deletePkgName = + Map.update deletePkgVersion (packageName pkgid) + + deletePkgVersion = + (\m -> if Map.null m then Nothing else Just m) + . Map.delete (packageVersion pkgid) + + +-- | Removes all packages with this (case-sensitive) name from the index. +-- +deletePackageName :: PackageName -> PackageIndex -> PackageIndex +deletePackageName name original@(PackageIndex pids pnames) = + case Map.lookup name pnames of + Nothing -> original + Just pvers -> mkPackageIndex + (foldl' (flip (Map.delete . installedPackageId)) pids + (concat (Map.elems pvers))) + (Map.delete name pnames) + +{- +-- | Removes all packages satisfying this dependency from the index. +-- +deleteDependency :: Dependency -> PackageIndex -> PackageIndex +deleteDependency (Dependency name verstionRange) = + delete' name (\pkg -> packageVersion pkg `withinRange` verstionRange) +-} + +-- +-- * Bulk queries +-- + +-- | Get all the packages from the index. +-- +allPackages :: PackageIndex -> [InstalledPackageInfo] +allPackages (PackageIndex pids _) = Map.elems pids + +-- | Get all the packages from the index. +-- +-- They are grouped by package name, case-sensitively. +-- +allPackagesByName :: PackageIndex -> [[InstalledPackageInfo]] +allPackagesByName (PackageIndex _ pnames) = + concatMap Map.elems (Map.elems pnames) + +-- +-- * Lookups +-- + +-- | Does a lookup by source package id (name & version). +-- +-- Since multiple package DBs mask each other by 'InstalledPackageId', +-- then we get back at most one package. +-- +lookupInstalledPackageId :: PackageIndex -> InstalledPackageId + -> Maybe InstalledPackageInfo +lookupInstalledPackageId (PackageIndex pids _) pid = Map.lookup pid pids + + +-- | Does a lookup by source package id (name & version). +-- +-- There can be multiple installed packages with the same source 'PackageId' +-- but different 'InstalledPackageId'. They are returned in order of +-- preference, with the most preferred first. +-- +lookupSourcePackageId :: PackageIndex -> PackageId -> [InstalledPackageInfo] +lookupSourcePackageId (PackageIndex _ pnames) pkgid = + case Map.lookup (packageName pkgid) pnames of + Nothing -> [] + Just pvers -> case Map.lookup (packageVersion pkgid) pvers of + Nothing -> [] + Just pkgs -> pkgs -- in preference order + + +-- | Does a lookup by source package name. +-- +lookupPackageName :: PackageIndex -> PackageName + -> [(Version, [InstalledPackageInfo])] +lookupPackageName (PackageIndex _ pnames) name = + case Map.lookup name pnames of + Nothing -> [] + Just pvers -> Map.toList pvers + + +-- | Does a lookup by source package name and a range of versions. +-- +-- We get back any number of versions of the specified package name, all +-- satisfying the version range constraint. +-- +lookupDependency :: PackageIndex -> Dependency + -> [(Version, [InstalledPackageInfo])] +lookupDependency (PackageIndex _ pnames) (Dependency name versionRange) = + case Map.lookup name pnames of + Nothing -> [] + Just pvers -> [ entry + | entry@(ver, _) <- Map.toList pvers + , ver `withinRange` versionRange ] + +-- +-- * Case insensitive name lookups +-- + +-- | Does a case-insensitive search by package name. +-- +-- If there is only one package that compares case-insentiviely to this name +-- then the search is unambiguous and we get back all versions of that package. +-- If several match case-insentiviely but one matches exactly then it is also +-- unambiguous. +-- +-- If however several match case-insentiviely and none match exactly then we +-- have an ambiguous result, and we get back all the versions of all the +-- packages. The list of ambiguous results is split by exact package name. So +-- it is a non-empty list of non-empty lists. +-- +searchByName :: PackageIndex -> String -> SearchResult [InstalledPackageInfo] +searchByName (PackageIndex _ pnames) name = + case [ pkgs | pkgs@(PackageName name',_) <- Map.toList pnames + , lowercase name' == lname ] of + [] -> None + [(_,pvers)] -> Unambiguous (concat (Map.elems pvers)) + pkgss -> case find ((PackageName name==) . fst) pkgss of + Just (_,pvers) -> Unambiguous (concat (Map.elems pvers)) + Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss) + where lname = lowercase name + +data SearchResult a = None | Unambiguous a | Ambiguous [a] + +-- | Does a case-insensitive substring search by package name. +-- +-- That is, all packages that contain the given string in their name. +-- +searchByNameSubstring :: PackageIndex -> String -> [InstalledPackageInfo] +searchByNameSubstring (PackageIndex _ pnames) searchterm = + [ pkg + | (PackageName name, pvers) <- Map.toList pnames + , lsearchterm `isInfixOf` lowercase name + , pkgs <- Map.elems pvers + , pkg <- pkgs ] + where lsearchterm = lowercase searchterm + + +-- +-- * Special queries +-- + +-- None of the stuff below depends on the internal representation of the index. +-- + +-- | Find if there are any cycles in the dependency graph. If there are no +-- cycles the result is @[]@. +-- +-- This actually computes the strongly connected components. So it gives us a +-- list of groups of packages where within each group they all depend on each +-- other, directly or indirectly. +-- +dependencyCycles :: PackageIndex -> [[InstalledPackageInfo]] +dependencyCycles index = + [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] + where + adjacencyList = [ (pkg, installedPackageId pkg, IPI.depends pkg) + | pkg <- allPackages index ] + + +-- | All packages that have immediate dependencies that are not in the index. +-- +-- Returns such packages along with the dependencies that they're missing. +-- +brokenPackages :: PackageIndex -> [(InstalledPackageInfo, [InstalledPackageId])] +brokenPackages index = + [ (pkg, missing) + | pkg <- allPackages index + , let missing = [ pkg' | pkg' <- IPI.depends pkg + , isNothing (lookupInstalledPackageId index pkg') ] + , not (null missing) ] + + +-- | Tries to take the transitive closure of the package dependencies. +-- +-- If the transitive closure is complete then it returns that subset of the +-- index. Otherwise it returns the broken packages as in 'brokenPackages'. +-- +-- * Note that if the result is @Right []@ it is because at least one of +-- the original given 'PackageId's do not occur in the index. +-- +dependencyClosure :: PackageIndex + -> [InstalledPackageId] + -> Either PackageIndex + [(InstalledPackageInfo, [InstalledPackageId])] +dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of + (completed, []) -> Left completed + (completed, _) -> Right (brokenPackages completed) + where + closure completed failed [] = (completed, failed) + closure completed failed (pkgid:pkgids) = case lookupInstalledPackageId index pkgid of + Nothing -> closure completed (pkgid:failed) pkgids + Just pkg -> case lookupInstalledPackageId completed (installedPackageId pkg) of + Just _ -> closure completed failed pkgids + Nothing -> closure completed' failed pkgids' + where completed' = insert pkg completed + pkgids' = IPI.depends pkg ++ pkgids + +-- | Takes the transitive closure of the packages reverse dependencies. +-- +-- * The given 'PackageId's must be in the index. +-- +reverseDependencyClosure :: PackageIndex + -> [InstalledPackageId] + -> [InstalledPackageInfo] +reverseDependencyClosure index = + map vertexToPkg + . concatMap Tree.flatten + . Graph.dfs reverseDepGraph + . map (fromMaybe noSuchPkgId . pkgIdToVertex) + + where + (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index + reverseDepGraph = Graph.transposeG depGraph + noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" + +topologicalOrder :: PackageIndex -> [InstalledPackageInfo] +topologicalOrder index = map toPkgId + . Graph.topSort + $ graph + where (graph, toPkgId, _) = dependencyGraph index + +reverseTopologicalOrder :: PackageIndex -> [InstalledPackageInfo] +reverseTopologicalOrder index = map toPkgId + . Graph.topSort + . Graph.transposeG + $ graph + where (graph, toPkgId, _) = dependencyGraph index + +-- | Builds a graph of the package dependencies. +-- +-- Dependencies on other packages that are not in the index are discarded. +-- You can check if there are any such dependencies with 'brokenPackages'. +-- +dependencyGraph :: PackageIndex + -> (Graph.Graph, + Graph.Vertex -> InstalledPackageInfo, + InstalledPackageId -> Maybe Graph.Vertex) +dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex) + where + graph = Array.listArray bounds + [ [ v | Just v <- map id_to_vertex (IPI.depends pkg) ] + | pkg <- pkgs ] + + pkgs = sortBy (comparing packageId) (allPackages index) + vertices = zip (map installedPackageId pkgs) [0..] + vertex_map = Map.fromList vertices + id_to_vertex pid = Map.lookup pid vertex_map + + vertex_to_pkg vertex = pkgTable ! vertex + + pkgTable = Array.listArray bounds pkgs + topBound = length pkgs - 1 + bounds = (0, topBound) + +-- | Given a package index where we assume we want to use all the packages +-- (use 'dependencyClosure' if you need to get such a index subset) find out +-- if the dependencies within it use consistent versions of each package. +-- Return all cases where multiple packages depend on different versions of +-- some other package. +-- +-- Each element in the result is a package name along with the packages that +-- depend on it and the versions they require. These are guaranteed to be +-- distinct. +-- +dependencyInconsistencies :: PackageIndex + -> [(PackageName, [(PackageId, Version)])] +dependencyInconsistencies index = + [ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids]) + | (name, ipid_map) <- Map.toList inverseIndex + , let uses = Map.elems ipid_map + , reallyIsInconsistent (map fst uses) ] + + where -- for each PackageName, + -- for each package with that name, + -- the InstalledPackageInfo and the package Ids of packages + -- that depend on it. + inverseIndex :: Map PackageName + (Map InstalledPackageId + (InstalledPackageInfo, [PackageId])) + inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b'))) + [ (packageName dep, + Map.fromList [(ipid,(dep,[packageId pkg]))]) + | pkg <- allPackages index + , ipid <- IPI.depends pkg + , Just dep <- [lookupInstalledPackageId index ipid] + ] + + reallyIsInconsistent :: [InstalledPackageInfo] -> Bool + reallyIsInconsistent [] = False + reallyIsInconsistent [_p] = False + reallyIsInconsistent [p1, p2] = + installedPackageId p1 `notElem` IPI.depends p2 + && installedPackageId p2 `notElem` IPI.depends p1 + reallyIsInconsistent _ = True + + +moduleNameIndex :: PackageIndex -> Map ModuleName [InstalledPackageInfo] +moduleNameIndex index = + Map.fromListWith (++) + [ (moduleName, [pkg]) + | pkg <- allPackages index + , moduleName <- IPI.exposedModules pkg ] diff --git a/cabal/cabal/Distribution/Simple/PreProcess.hs b/cabal/cabal/Distribution/Simple/PreProcess.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/PreProcess.hs @@ -0,0 +1,596 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.PreProcess +-- Copyright : (c) 2003-2005, Isaac Jones, Malcolm Wallace +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines a 'PreProcessor' abstraction which represents a pre-processor +-- that can transform one kind of file into another. There is also a +-- 'PPSuffixHandler' which is a combination of a file extension and a function +-- for configuring a 'PreProcessor'. It defines a bunch of known built-in +-- preprocessors like @cpp@, @cpphs@, @c2hs@, @hsc2hs@, @happy@, @alex@ etc and +-- lists them in 'knownSuffixHandlers'. On top of this it provides a function +-- for actually preprocessing some sources given a bunch of known suffix +-- handlers. This module is not as good as it could be, it could really do with +-- a rewrite to address some of the problems we have with pre-processors. + +{- Copyright (c) 2003-2005, Isaac Jones, Malcolm Wallace +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.PreProcess (preprocessComponent, knownSuffixHandlers, + ppSuffixes, PPSuffixHandler, PreProcessor(..), + mkSimplePreProcessor, runSimplePreProcessor, + ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs, + ppHappy, ppAlex, ppUnlit + ) + where + + +import Control.Monad +import Distribution.Simple.PreProcess.Unlit (unlit) +import Distribution.Package + ( Package(..), PackageName(..) ) +import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(..) + , Executable(..) + , Library(..), libModules + , TestSuite(..), testModules + , TestSuiteInterface(..) ) +import qualified Distribution.InstalledPackageInfo as Installed + ( InstalledPackageInfo_(..) ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.Compiler + ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), Component(..) ) +import Distribution.Simple.BuildPaths (autogenModulesDir,cppHeaderName) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File + , die, setupMessage, intercalate, copyFileVerbose + , findFileWithExtension, findFileWithExtension' ) +import Distribution.Simple.Program + ( Program(..), ConfiguredProgram(..), programPath + , lookupProgram, requireProgram, requireProgramVersion + , rawSystemProgramConf, rawSystemProgram + , greencardProgram, cpphsProgram, hsc2hsProgram, c2hsProgram + , happyProgram, alexProgram, haddockProgram, ghcProgram, gccProgram ) +import Distribution.Simple.Test ( writeSimpleTestStub, stubFilePath, stubName ) +import Distribution.System + ( OS(OSX, Windows), buildOS ) +import Distribution.Text +import Distribution.Version + ( Version(..), anyVersion, orLaterVersion ) +import Distribution.Verbosity + +import Data.Maybe (fromMaybe) +import Data.List (nub) +import System.Directory (getModificationTime, doesFileExist) +import System.Info (os, arch) +import System.FilePath (splitExtension, dropExtensions, (), (<.>), + takeDirectory, normalise, replaceExtension) + +-- |The interface to a preprocessor, which may be implemented using an +-- external program, but need not be. The arguments are the name of +-- the input file, the name of the output file and a verbosity level. +-- Here is a simple example that merely prepends a comment to the given +-- source file: +-- +-- > ppTestHandler :: PreProcessor +-- > ppTestHandler = +-- > PreProcessor { +-- > platformIndependent = True, +-- > runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> +-- > do info verbosity (inFile++" has been preprocessed to "++outFile) +-- > stuff <- readFile inFile +-- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff) +-- > return ExitSuccess +-- +-- We split the input and output file names into a base directory and the +-- rest of the file name. The input base dir is the path in the list of search +-- dirs that this file was found in. The output base dir is the build dir where +-- all the generated source files are put. +-- +-- The reason for splitting it up this way is that some pre-processors don't +-- simply generate one output .hs file from one input file but have +-- dependencies on other genereated files (notably c2hs, where building one +-- .hs file may require reading other .chi files, and then compiling the .hs +-- file may require reading a generated .h file). In these cases the generated +-- files need to embed relative path names to each other (eg the generated .hs +-- file mentions the .h file in the FFI imports). This path must be relative to +-- the base directory where the genereated files are located, it cannot be +-- relative to the top level of the build tree because the compilers do not +-- look for .h files relative to there, ie we do not use \"-I .\", instead we +-- use \"-I dist\/build\" (or whatever dist dir has been set by the user) +-- +-- Most pre-processors do not care of course, so mkSimplePreProcessor and +-- runSimplePreProcessor functions handle the simple case. +-- +data PreProcessor = PreProcessor { + + -- Is the output of the pre-processor platform independent? eg happy output + -- is portable haskell but c2hs's output is platform dependent. + -- This matters since only platform independent generated code can be + -- inlcuded into a source tarball. + platformIndependent :: Bool, + + -- TODO: deal with pre-processors that have implementaion dependent output + -- eg alex and happy have --ghc flags. However we can't really inlcude + -- ghc-specific code into supposedly portable source tarballs. + + runPreProcessor :: (FilePath, FilePath) -- Location of the source file relative to a base dir + -> (FilePath, FilePath) -- Output file name, relative to an output base dir + -> Verbosity -- verbosity + -> IO () -- Should exit if the preprocessor fails + } + +mkSimplePreProcessor :: (FilePath -> FilePath -> Verbosity -> IO ()) + -> (FilePath, FilePath) + -> (FilePath, FilePath) -> Verbosity -> IO () +mkSimplePreProcessor simplePP + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) verbosity = simplePP inFile outFile verbosity + where inFile = normalise (inBaseDir inRelativeFile) + outFile = normalise (outBaseDir outRelativeFile) + +runSimplePreProcessor :: PreProcessor -> FilePath -> FilePath -> Verbosity + -> IO () +runSimplePreProcessor pp inFile outFile verbosity = + runPreProcessor pp (".", inFile) (".", outFile) verbosity + +-- |A preprocessor for turning non-Haskell files with the given extension +-- into plain Haskell source files. +type PPSuffixHandler + = (String, BuildInfo -> LocalBuildInfo -> PreProcessor) + +-- | Apply preprocessors to the sources from 'hsSourceDirs' for a given +-- component (lib, exe, or test suite). +preprocessComponent :: PackageDescription + -> Component + -> LocalBuildInfo + -> Bool + -> Verbosity + -> [PPSuffixHandler] + -> IO () +preprocessComponent pd comp lbi isSrcDist verbosity handlers = case comp of + (CLib lib@Library{ libBuildInfo = bi }) -> do + let dirs = hsSourceDirs bi ++ [autogenModulesDir lbi] + setupMessage verbosity "Preprocessing library" (packageId pd) + forM_ (map ModuleName.toFilePath $ libModules lib) $ + pre dirs (buildDir lbi) (localHandlers bi) + (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do + let exeDir = buildDir lbi nm nm ++ "-tmp" + dirs = hsSourceDirs bi ++ [autogenModulesDir lbi] + setupMessage verbosity ("Preprocessing executable '" ++ nm ++ "' for") (packageId pd) + forM_ (map ModuleName.toFilePath $ otherModules bi) $ + pre dirs exeDir (localHandlers bi) + pre (hsSourceDirs bi) exeDir (localHandlers bi) $ + dropExtensions (modulePath exe) + CTest test@TestSuite{ testName = nm } -> do + setupMessage verbosity ("Preprocessing test suite '" ++ nm ++ "' for") (packageId pd) + case testInterface test of + TestSuiteExeV10 _ f -> + preProcessTest test f $ buildDir lbi testName test + testName test ++ "-tmp" + TestSuiteLibV09 _ _ -> do + let testDir = buildDir lbi stubName test + stubName test ++ "-tmp" + writeSimpleTestStub test testDir + preProcessTest test (stubFilePath test) testDir + TestSuiteUnsupported tt -> die $ "No support for preprocessing test " + ++ "suite type " ++ display tt + where + builtinSuffixes + | NHC == compilerFlavor (compiler lbi) = ["hs", "lhs", "gc"] + | otherwise = ["hs", "lhs"] + localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers] + pre dirs dir lhndlrs fp = + preprocessFile dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs + preProcessTest test exePath testDir = do + let bi = testBuildInfo test + biHandlers = localHandlers bi + sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ] + sequence_ [ preprocessFile sourceDirs (buildDir lbi) isSrcDist + (ModuleName.toFilePath modu) verbosity builtinSuffixes + biHandlers + | modu <- testModules test ] + preprocessFile (testDir : (hsSourceDirs bi)) testDir isSrcDist + (dropExtensions $ exePath) verbosity + builtinSuffixes biHandlers + +--TODO: try to list all the modules that could not be found +-- not just the first one. It's annoying and slow due to the need +-- to reconfigure after editing the .cabal file each time. + +-- |Find the first extension of the file that exists, and preprocess it +-- if required. +preprocessFile + :: [FilePath] -- ^source directories + -> FilePath -- ^build directory + -> Bool -- ^preprocess for sdist + -> FilePath -- ^module file name + -> Verbosity -- ^verbosity + -> [String] -- ^builtin suffixes + -> [(String, PreProcessor)] -- ^possible preprocessors + -> IO () +preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers = do + -- look for files in the various source dirs with this module name + -- and a file extension of a known preprocessor + psrcFiles <- findFileWithExtension' (map fst handlers) searchLoc baseFile + case psrcFiles of + -- no preprocessor file exists, look for an ordinary source file + -- just to make sure one actually exists at all for this module. + -- Note: by looking in the target/output build dir too, we allow + -- source files to appear magically in the target build dir without + -- any corresponding "real" source file. This lets custom Setup.hs + -- files generate source modules directly into the build dir without + -- the rest of the build system being aware of it (somewhat dodgy) + Nothing -> do + bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : searchLoc) baseFile + case bsrcFiles of + Nothing -> die $ "can't find source for " ++ baseFile + ++ " in " ++ intercalate ", " searchLoc + _ -> return () + -- found a pre-processable file in one of the source dirs + Just (psrcLoc, psrcRelFile) -> do + let (srcStem, ext) = splitExtension psrcRelFile + psrcFile = psrcLoc psrcRelFile + pp = fromMaybe (error "Internal error in preProcess module: Just expected") + (lookup (tailNotNull ext) handlers) + -- Preprocessing files for 'sdist' is different from preprocessing + -- for 'build'. When preprocessing for sdist we preprocess to + -- avoid that the user has to have the preprocessors available. + -- ATM, we don't have a way to specify which files are to be + -- preprocessed and which not, so for sdist we only process + -- platform independent files and put them into the 'buildLoc' + -- (which we assume is set to the temp. directory that will become + -- the tarball). + --TODO: eliminate sdist variant, just supply different handlers + when (not forSDist || forSDist && platformIndependent pp) $ do + -- look for existing pre-processed source file in the dest dir to + -- see if we really have to re-run the preprocessor. + ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile + recomp <- case ppsrcFiles of + Nothing -> return True + Just ppsrcFile -> do + btime <- getModificationTime ppsrcFile + ptime <- getModificationTime psrcFile + return (btime < ptime) + when recomp $ do + let destDir = buildLoc dirName srcStem + createDirectoryIfMissingVerbose verbosity True destDir + runPreProcessorWithHsBootHack pp + (psrcLoc, psrcRelFile) + (buildLoc, srcStem <.> "hs") + + where + dirName = takeDirectory + tailNotNull [] = [] + tailNotNull x = tail x + + -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files + -- be in the same place as the hs files, so if we put the hs file in dist/ + -- then we need to copy the hs-boot file there too. This should probably be + -- done another way. Possibly we should also be looking for .lhs-boot + -- files, but I think that preprocessors only produce .hs files. + runPreProcessorWithHsBootHack pp + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) = do + runPreProcessor pp + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) verbosity + + exists <- doesFileExist inBoot + when exists $ copyFileVerbose verbosity inBoot outBoot + + where + inBoot = replaceExtension inFile "hs-boot" + outBoot = replaceExtension outFile "hs-boot" + + inFile = normalise (inBaseDir inRelativeFile) + outFile = normalise (outBaseDir outRelativeFile) + +-- ------------------------------------------------------------ +-- * known preprocessors +-- ------------------------------------------------------------ + +ppGreenCard :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppGreenCard _ lbi + = PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + rawSystemProgramConf verbosity greencardProgram (withPrograms lbi) + (["-tffi", "-o" ++ outFile, inFile]) + } + +-- This one is useful for preprocessors that can't handle literate source. +-- We also need a way to chain preprocessors. +ppUnlit :: PreProcessor +ppUnlit = + PreProcessor { + platformIndependent = True, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile _verbosity -> + withUTF8FileContents inFile $ \contents -> + either (writeUTF8File outFile) die (unlit inFile contents) + } + +ppCpp :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppCpp = ppCpp' [] + +ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor +ppCpp' extraArgs bi lbi = + case compilerFlavor (compiler lbi) of + GHC -> ppGhcCpp (cppArgs ++ extraArgs) bi lbi + _ -> ppCpphs (cppArgs ++ extraArgs) bi lbi + + where cppArgs = getCppOptions bi lbi + +ppGhcCpp :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor +ppGhcCpp extraArgs _bi lbi = + PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (ghcProg, ghcVersion, _) <- requireProgramVersion verbosity + ghcProgram anyVersion (withPrograms lbi) + rawSystemProgram verbosity ghcProg $ + ["-E", "-cpp"] + -- This is a bit of an ugly hack. We're going to + -- unlit the file ourselves later on if appropriate, + -- so we need GHC not to unlit it now or it'll get + -- double-unlitted. In the future we might switch to + -- using cpphs --unlit instead. + ++ (if ghcVersion >= Version [6,6] [] then ["-x", "hs"] else []) + ++ (if use_optP_P lbi then ["-optP-P"] else []) + ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi cppHeaderName) ] + ++ ["-o", outFile, inFile] + ++ extraArgs + } + +ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor +ppCpphs extraArgs _bi lbi = + PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (cpphsProg, cpphsVersion, _) <- requireProgramVersion verbosity + cpphsProgram anyVersion (withPrograms lbi) + rawSystemProgram verbosity cpphsProg $ + ("-O" ++ outFile) : inFile + : "--noline" : "--strip" + : (if cpphsVersion >= Version [1,6] [] + then ["--include="++ (autogenModulesDir lbi cppHeaderName)] + else []) + ++ extraArgs + } + +-- Haddock versions before 0.8 choke on #line and #file pragmas. Those +-- pragmas are necessary for correct links when we preprocess. So use +-- -optP-P only if the Haddock version is prior to 0.8. +use_optP_P :: LocalBuildInfo -> Bool +use_optP_P lbi + = case lookupProgram haddockProgram (withPrograms lbi) of + Just (ConfiguredProgram { programVersion = Just version }) + | version >= Version [0,8] [] -> False + _ -> True + +ppHsc2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppHsc2hs bi lbi = + PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + rawSystemProgramConf verbosity hsc2hsProgram (withPrograms lbi) $ + [ "--cc=" ++ programPath gccProg + , "--ld=" ++ programPath gccProg ] + + -- Additional gcc options + ++ [ "--cflag=" ++ opt | opt <- programDefaultArgs gccProg + ++ programOverrideArgs gccProg ] + ++ [ "--lflag=" ++ opt | opt <- programDefaultArgs gccProg + ++ programOverrideArgs gccProg ] + + -- OSX frameworks: + ++ [ what ++ "=-F" ++ opt + | isOSX + , opt <- nub (concatMap Installed.frameworkDirs pkgs) + , what <- ["--cflag", "--lflag"] ] + ++ [ "--lflag=" ++ arg + | isOSX + , opt <- PD.frameworks bi ++ concatMap Installed.frameworks pkgs + , arg <- ["-framework", opt] ] + + -- Note that on ELF systems, wherever we use -L, we must also use -R + -- because presumably that -L dir is not on the normal path for the + -- system's dynamic linker. This is needed because hsc2hs works by + -- compiling a C program and then running it. + + ++ [ "--cflag=" ++ opt | opt <- hcDefines (compiler lbi) ] + ++ [ "--cflag=" ++ opt | opt <- sysDefines ] + + -- Options from the current package: + ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs bi ] + ++ [ "--cflag=" ++ opt | opt <- PD.ccOptions bi + ++ PD.cppOptions bi ] + ++ [ "--lflag=-L" ++ opt | opt <- PD.extraLibDirs bi ] + ++ [ "--lflag=-Wl,-R," ++ opt | isELF + , opt <- PD.extraLibDirs bi ] + ++ [ "--lflag=-l" ++ opt | opt <- PD.extraLibs bi ] + ++ [ "--lflag=" ++ opt | opt <- PD.ldOptions bi ] + + -- Options from dependent packages + ++ [ "--cflag=" ++ opt + | pkg <- pkgs + , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] + ++ [ opt | opt <- Installed.ccOptions pkg ] + ++ [ "-I" ++ autogenModulesDir lbi, + "-include", autogenModulesDir lbi cppHeaderName ] ] + ++ [ "--lflag=" ++ opt + | pkg <- pkgs + , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs pkg ] + ++ [ "-Wl,-R," ++ opt | isELF + , opt <- Installed.libraryDirs pkg ] + ++ [ "-l" ++ opt | opt <- Installed.extraLibraries pkg ] + ++ [ opt | opt <- Installed.ldOptions pkg ] ] + ++ ["-o", outFile, inFile] + } + where + pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi)) + isOSX = case buildOS of OSX -> True; _ -> False + isELF = case buildOS of OSX -> False; Windows -> False; _ -> True; + packageHacks = case compilerFlavor (compiler lbi) of + GHC -> hackRtsPackage + _ -> id + -- We don't link in the actual Haskell libraries of our dependencies, so + -- the -u flags in the ldOptions of the rts package mean linking fails on + -- OS X (it's ld is a tad stricter than gnu ld). Thus we remove the + -- ldOptions for GHC's rts package: + hackRtsPackage index = + case PackageIndex.lookupPackageName index (PackageName "rts") of + [(_, [rts])] + -> PackageIndex.insert rts { Installed.ldOptions = [] } index + _ -> error "No (or multiple) ghc rts package is registered!!" + + +ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppC2hs bi lbi = + PreProcessor { + platformIndependent = False, + runPreProcessor = \(inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) verbosity -> do + (c2hsProg, _, _) <- requireProgramVersion verbosity + c2hsProgram (orLaterVersion (Version [0,15] [])) + (withPrograms lbi) + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + rawSystemProgram verbosity c2hsProg $ + + -- Options from the current package: + [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ] + ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ] + ++ [ "--include=" ++ outBaseDir ] + + -- Options from dependent packages + ++ [ "--cppopts=" ++ opt + | pkg <- pkgs + , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] + ++ [ opt | opt@('-':c:_) <- Installed.ccOptions pkg + , c `elem` "DIU" ] ] + --TODO: install .chi files for packages, so we can --include + -- those dirs here, for the dependencies + + -- input and output files + ++ [ "--output-dir=" ++ outBaseDir + , "--output=" ++ outRelativeFile + , inBaseDir inRelativeFile ] + } + where + pkgs = PackageIndex.topologicalOrder (installedPkgs lbi) + +--TODO: perhaps use this with hsc2hs too +--TODO: remove cc-options from cpphs for cabal-version: >= 1.10 +getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] +getCppOptions bi lbi + = hcDefines (compiler lbi) + ++ sysDefines + ++ cppOptions bi + ++ ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ [opt | opt@('-':c:_) <- PD.ccOptions bi, c `elem` "DIU"] + +sysDefines :: [String] +sysDefines = ["-D" ++ os ++ "_" ++ loc ++ "_OS" | loc <- locations] + ++ ["-D" ++ arch ++ "_" ++ loc ++ "_ARCH" | loc <- locations] + where + locations = ["BUILD", "HOST"] + +hcDefines :: Compiler -> [String] +hcDefines comp = + case compilerFlavor comp of + GHC -> ["-D__GLASGOW_HASKELL__=" ++ versionInt version] + JHC -> ["-D__JHC__=" ++ versionInt version] + NHC -> ["-D__NHC__=" ++ versionInt version] + Hugs -> ["-D__HUGS__"] + _ -> [] + where version = compilerVersion comp + +-- TODO: move this into the compiler abstraction +-- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all the other +-- compilers. Check if that's really what they want. +versionInt :: Version -> String +versionInt (Version { versionBranch = [] }) = "1" +versionInt (Version { versionBranch = [n] }) = show n +versionInt (Version { versionBranch = n1:n2:_ }) + = -- 6.8.x -> 608 + -- 6.10.x -> 610 + let s1 = show n1 + s2 = show n2 + middle = case s2 of + _ : _ : _ -> "" + _ -> "0" + in s1 ++ middle ++ s2 + +ppHappy :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppHappy _ lbi = pp { platformIndependent = True } + where pp = standardPP lbi happyProgram (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-agc"] + hcFlags _ = [] + +ppAlex :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppAlex _ lbi = pp { platformIndependent = True } + where pp = standardPP lbi alexProgram (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-g"] + hcFlags _ = [] + +standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor +standardPP lbi prog args = + PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + rawSystemProgramConf verbosity prog (withPrograms lbi) + (args ++ ["-o", outFile, inFile]) + } + +-- |Convenience function; get the suffixes of these preprocessors. +ppSuffixes :: [ PPSuffixHandler ] -> [String] +ppSuffixes = map fst + +-- |Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs. +knownSuffixHandlers :: [ PPSuffixHandler ] +knownSuffixHandlers = + [ ("gc", ppGreenCard) + , ("chs", ppC2hs) + , ("hsc", ppHsc2hs) + , ("x", ppAlex) + , ("y", ppHappy) + , ("ly", ppHappy) + , ("cpphs", ppCpp) + ] diff --git a/cabal/cabal/Distribution/Simple/PreProcess/Unlit.hs b/cabal/cabal/Distribution/Simple/PreProcess/Unlit.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/PreProcess/Unlit.hs @@ -0,0 +1,165 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.PreProcess.Unlit +-- Copyright : ... +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Remove the \"literal\" markups from a Haskell source file, including +-- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\" + +-- This version is interesting because instead of striping comment lines, it +-- turns them into "-- " style comments. This allows using haddock markup +-- in literate scripts without having to use "> --" prefix. + +module Distribution.Simple.PreProcess.Unlit (unlit,plain) where + +import Data.Char +import Data.List + +data Classified = BirdTrack String | Blank String | Ordinary String + | Line !Int String | CPP String + | BeginCode | EndCode + -- output only: + | Error String | Comment String + +-- | No unliteration. +plain :: String -> String -> String +plain _ hs = hs + +classify :: String -> Classified +classify ('>':s) = BirdTrack s +classify ('#':s) = case tokens s of + (line:file:_) | all isDigit line + && length file >= 2 + && head file == '"' + && last file == '"' + -> Line (read line) (tail (init file)) + _ -> CPP s + where tokens = unfoldr $ \str -> case lex str of + (t@(_:_), str'):_ -> Just (t, str') + _ -> Nothing +classify ('\\':s) + | "begin{code}" `isPrefixOf` s = BeginCode + | "end{code}" `isPrefixOf` s = EndCode +classify s | all isSpace s = Blank s +classify s = Ordinary s + +-- So the weird exception for comment indenting is to make things work with +-- haddock, see classifyAndCheckForBirdTracks below. +unclassify :: Bool -> Classified -> String +unclassify _ (BirdTrack s) = ' ':s +unclassify _ (Blank s) = s +unclassify _ (Ordinary s) = s +unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file +unclassify _ (CPP s) = '#':s +unclassify True (Comment "") = " --" +unclassify True (Comment s) = " -- " ++ s +unclassify False (Comment "") = "--" +unclassify False (Comment s) = "-- " ++ s +unclassify _ _ = internalError + +-- | 'unlit' takes a filename (for error reports), and transforms the +-- given string, to eliminate the literate comments from the program text. +unlit :: FilePath -> String -> Either String String +unlit file input = + let (usesBirdTracks, classified) = classifyAndCheckForBirdTracks + . inlines + $ input + in either (Left . unlines . map (unclassify usesBirdTracks)) + Right + . checkErrors + . reclassify + $ classified + + where + -- So haddock requires comments and code to align, since it treats comments + -- as following the layout rule. This is a pain for us since bird track + -- style literate code typically gets indented by two since ">" is replaced + -- by " " and people usually use one additional space of indent ie + -- "> then the code". On the other hand we cannot just go and indent all + -- the comments by two since that does not work for latex style literate + -- code. So the hacky solution we use here is that if we see any bird track + -- style code then we'll indent all comments by two, otherwise by none. + -- Of course this will not work for mixed latex/bird track .lhs files but + -- nobody does that, it's silly and specifically recommended against in the + -- H98 unlit spec. + -- + classifyAndCheckForBirdTracks = + flip mapAccumL False $ \seenBirdTrack line -> + let classification = classify line + in (seenBirdTrack || isBirdTrack classification, classification) + + isBirdTrack (BirdTrack _) = True + isBirdTrack _ = False + + checkErrors ls = case [ e | Error e <- ls ] of + [] -> Left ls + (message:_) -> Right (f ++ ":" ++ show n ++ ": " ++ message) + where (f, n) = errorPos file 1 ls + errorPos f n [] = (f, n) + errorPos f n (Error _:_) = (f, n) + errorPos _ _ (Line n' f':ls) = errorPos f' n' ls + errorPos f n (_ :ls) = errorPos f (n+1) ls + +-- Here we model a state machine, with each state represented by +-- a local function. We only have four states (well, five, +-- if you count the error state), but the rules +-- to transition between then are not so simple. +-- Would it be simpler to have more states? +-- +-- Each state represents the type of line that was last read +-- i.e. are we in a comment section, or a latex-code section, +-- or a bird-code section, etc? +reclassify :: [Classified] -> [Classified] +reclassify = blank -- begin in blank state + where + latex [] = [] + latex (EndCode :ls) = Blank "" : comment ls + latex (BeginCode :_ ) = [Error "\\begin{code} in code section"] + latex (BirdTrack l:ls) = Ordinary ('>':l) : latex ls + latex ( l:ls) = l : latex ls + + blank [] = [] + blank (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] + blank (BeginCode :ls) = Blank "" : latex ls + blank (BirdTrack l:ls) = BirdTrack l : bird ls + blank (Ordinary l:ls) = Comment l : comment ls + blank ( l:ls) = l : blank ls + + bird [] = [] + bird (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] + bird (BeginCode :ls) = Blank "" : latex ls + bird (Blank l :ls) = Blank l : blank ls + bird (Ordinary _:_ ) = [Error "program line before comment line"] + bird ( l:ls) = l : bird ls + + comment [] = [] + comment (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] + comment (BeginCode :ls) = Blank "" : latex ls + comment (CPP l :ls) = CPP l : comment ls + comment (BirdTrack _:_ ) = [Error "comment line before program line"] + -- a blank line and another ordinary line following a comment + -- will be treated as continuing the comment. Otherwise it's + -- then end of the comment, with a blank line. + comment (Blank l:ls@(Ordinary _:_)) = Comment l : comment ls + comment (Blank l:ls) = Blank l : blank ls + comment (Line n f :ls) = Line n f : comment ls + comment (Ordinary l:ls) = Comment l : comment ls + comment (Comment _: _) = internalError + comment (Error _: _) = internalError + +-- Re-implementation of 'lines', for better efficiency (but decreased laziness). +-- Also, importantly, accepts non-standard DOS and Mac line ending characters. +inlines :: String -> [String] +inlines xs = lines' xs id + where + lines' [] acc = [acc []] + lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS + lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS + lines' ('\n':s) acc = acc [] : lines' s id -- Unix + lines' (c:s) acc = lines' s (acc . (c:)) + +internalError :: a +internalError = error "unlit: internal error" diff --git a/cabal/cabal/Distribution/Simple/Program.hs b/cabal/cabal/Distribution/Simple/Program.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Program.hs @@ -0,0 +1,217 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This provides an abstraction which deals with configuring and running +-- programs. A 'Program' is a static notion of a known program. A +-- 'ConfiguredProgram' is a 'Program' that has been found on the current +-- machine and is ready to be run (possibly with some user-supplied default +-- args). Configuring a program involves finding its location and if necessary +-- finding its version. There is also a 'ProgramConfiguration' type which holds +-- configured and not-yet configured programs. It is the parameter to lots of +-- actions elsewhere in Cabal that need to look up and run programs. If we had +-- a Cabal monad, the 'ProgramConfiguration' would probably be a reader or +-- state component of it. +-- +-- The module also defines all the known built-in 'Program's and the +-- 'defaultProgramConfiguration' which contains them all. +-- +-- One nice thing about using it is that any program that is +-- registered with Cabal will get some \"configure\" and \".cabal\" +-- helpers like --with-foo-args --foo-path= and extra-foo-args. +-- +-- There's also good default behavior for trying to find \"foo\" in +-- PATH, being able to override its location, etc. +-- +-- There's also a hook for adding programs in a Setup.lhs script. See +-- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a +-- hook user the ability to get the above flags and such so that they +-- don't have to write all the PATH logic inside Setup.lhs. + +module Distribution.Simple.Program ( + -- * Program and functions for constructing them + Program(..) + , simpleProgram + , findProgramLocation + , findProgramVersion + + -- * Configured program and related functions + , ConfiguredProgram(..) + , programPath + , ProgArg + , ProgramLocation(..) + , runProgram + , getProgramOutput + + -- * Program invocations + , ProgramInvocation(..) + , emptyProgramInvocation + , simpleProgramInvocation + , programInvocation + , runProgramInvocation + , getProgramInvocationOutput + + -- * The collection of unconfigured and configured progams + , builtinPrograms + + -- * The collection of configured programs we can run + , ProgramConfiguration + , emptyProgramConfiguration + , defaultProgramConfiguration + , restoreProgramConfiguration + , addKnownProgram + , addKnownPrograms + , lookupKnownProgram + , knownPrograms + , userSpecifyPath + , userSpecifyPaths + , userMaybeSpecifyPath + , userSpecifyArgs + , userSpecifyArgss + , userSpecifiedArgs + , lookupProgram + , updateProgram + , configureProgram + , configureAllKnownPrograms + , reconfigurePrograms + , requireProgram + , requireProgramVersion + , runDbProgram + , getDbProgramOutput + + -- * Programs that Cabal knows about + , ghcProgram + , ghcPkgProgram + , lhcProgram + , lhcPkgProgram + , nhcProgram + , hmakeProgram + , jhcProgram + , hugsProgram + , ffihugsProgram + , uhcProgram + , gccProgram + , ranlibProgram + , arProgram + , stripProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , hscolourProgram + , haddockProgram + , greencardProgram + , ldProgram + , tarProgram + , cppProgram + , pkgConfigProgram + + -- * deprecated + , rawSystemProgram + , rawSystemProgramStdout + , rawSystemProgramConf + , rawSystemProgramStdoutConf + , findProgramOnPath + + ) where + +import Distribution.Simple.Program.Types +import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Builtin + +import Distribution.Simple.Utils + ( die, findProgramLocation, findProgramVersion ) +import Distribution.Verbosity + ( Verbosity ) + + +-- | Runs the given configured program. +-- +runProgram :: Verbosity -- ^Verbosity + -> ConfiguredProgram -- ^The program to run + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO () +runProgram verbosity prog args = + runProgramInvocation verbosity (programInvocation prog args) + + +-- | Runs the given configured program and gets the output. +-- +getProgramOutput :: Verbosity -- ^Verbosity + -> ConfiguredProgram -- ^The program to run + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO String +getProgramOutput verbosity prog args = + getProgramInvocationOutput verbosity (programInvocation prog args) + + +-- | Looks up the given program in the program database and runs it. +-- +runDbProgram :: Verbosity -- ^verbosity + -> Program -- ^The program to run + -> ProgramDb -- ^look up the program here + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO () +runDbProgram verbosity prog programDb args = + case lookupProgram prog programDb of + Nothing -> die notFound + Just configuredProg -> runProgram verbosity configuredProg args + where + notFound = "The program " ++ programName prog + ++ " is required but it could not be found" + +-- | Looks up the given program in the program database and runs it. +-- +getDbProgramOutput :: Verbosity -- ^verbosity + -> Program -- ^The program to run + -> ProgramDb -- ^look up the program here + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO String +getDbProgramOutput verbosity prog programDb args = + case lookupProgram prog programDb of + Nothing -> die notFound + Just configuredProg -> getProgramOutput verbosity configuredProg args + where + notFound = "The program " ++ programName prog + ++ " is required but it could not be found" + + +--------------------- +-- Deprecated aliases +-- + +rawSystemProgram :: Verbosity -> ConfiguredProgram + -> [ProgArg] -> IO () +rawSystemProgram = runProgram + +rawSystemProgramStdout :: Verbosity -> ConfiguredProgram + -> [ProgArg] -> IO String +rawSystemProgramStdout = getProgramOutput + +rawSystemProgramConf :: Verbosity -> Program -> ProgramConfiguration + -> [ProgArg] -> IO () +rawSystemProgramConf = runDbProgram + +rawSystemProgramStdoutConf :: Verbosity -> Program -> ProgramConfiguration + -> [ProgArg] -> IO String +rawSystemProgramStdoutConf = getDbProgramOutput + +type ProgramConfiguration = ProgramDb + +emptyProgramConfiguration, defaultProgramConfiguration :: ProgramConfiguration +emptyProgramConfiguration = emptyProgramDb +defaultProgramConfiguration = defaultProgramDb + +restoreProgramConfiguration :: [Program] -> ProgramConfiguration + -> ProgramConfiguration +restoreProgramConfiguration = restoreProgramDb + +{-# DEPRECATED findProgramOnPath "use findProgramLocation instead" #-} +findProgramOnPath :: String -> Verbosity -> IO (Maybe FilePath) +findProgramOnPath = flip findProgramLocation diff --git a/cabal/cabal/Distribution/Simple/Program/Ar.hs b/cabal/cabal/Distribution/Simple/Program/Ar.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Program/Ar.hs @@ -0,0 +1,70 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Ar +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @ar@ program. + +module Distribution.Simple.Program.Ar ( + createArLibArchive, + multiStageProgramInvocation, + ) where + +import Distribution.Simple.Program.Types + ( ConfiguredProgram(..) ) +import Distribution.Simple.Program.Run + ( programInvocation, multiStageProgramInvocation + , runProgramInvocation ) +import Distribution.System + ( OS(..), buildOS ) +import Distribution.Verbosity + ( Verbosity, deafening, verbose ) + +-- | Call @ar@ to create a library archive from a bunch of object files. +-- +createArLibArchive :: Verbosity -> ConfiguredProgram + -> FilePath -> [FilePath] -> IO () +createArLibArchive verbosity ar target files = + + -- The args to use with "ar" are actually rather subtle and system-dependent. + -- In particular we have the following issues: + -- + -- -- On OS X, "ar q" does not make an archive index. Archives with no + -- index cannot be used. + -- + -- -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us + -- do that. We have duplicates because of modules like "A.M" and "B.M" + -- both make an object file "M.o" and ar does not consider the directory. + -- + -- Our solution is to use "ar r" in the simple case when one call is enough. + -- When we need to call ar multiple times we use "ar q" and for the last + -- call on OSX we use "ar qs" so that it'll make the index. + + let simpleArgs = case buildOS of + OSX -> ["-r", "-s"] + _ -> ["-r"] + + initialArgs = ["-q"] + finalArgs = case buildOS of + OSX -> ["-q", "-s"] + _ -> ["-q"] + + extraArgs = verbosityOpts verbosity ++ [target] + + simple = programInvocation ar (simpleArgs ++ extraArgs) + initial = programInvocation ar (initialArgs ++ extraArgs) + middle = initial + final = programInvocation ar (finalArgs ++ extraArgs) + + in sequence_ + [ runProgramInvocation verbosity inv + | inv <- multiStageProgramInvocation + simple (initial, middle, final) files ] + + where + verbosityOpts v | v >= deafening = ["-v"] + | v >= verbose = [] + | otherwise = ["-c"] diff --git a/cabal/cabal/Distribution/Simple/Program/Builtin.hs b/cabal/cabal/Distribution/Simple/Program/Builtin.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Program/Builtin.hs @@ -0,0 +1,259 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Builtin +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- The module defines all the known built-in 'Program's. +-- +-- Where possible we try to find their version numbers. +-- +module Distribution.Simple.Program.Builtin ( + + -- * The collection of unconfigured and configured progams + builtinPrograms, + + -- * Programs that Cabal knows about + ghcProgram, + ghcPkgProgram, + lhcProgram, + lhcPkgProgram, + nhcProgram, + hmakeProgram, + jhcProgram, + hugsProgram, + ffihugsProgram, + uhcProgram, + gccProgram, + ranlibProgram, + arProgram, + stripProgram, + happyProgram, + alexProgram, + hsc2hsProgram, + c2hsProgram, + cpphsProgram, + hscolourProgram, + haddockProgram, + greencardProgram, + ldProgram, + tarProgram, + cppProgram, + pkgConfigProgram, + ) where + +import Distribution.Simple.Program.Types + ( Program(..), simpleProgram ) +import Distribution.Simple.Utils + ( findProgramLocation, findProgramVersion ) + +-- ------------------------------------------------------------ +-- * Known programs +-- ------------------------------------------------------------ + +-- | The default list of programs. +-- These programs are typically used internally to Cabal. +builtinPrograms :: [Program] +builtinPrograms = + [ + -- compilers and related progs + ghcProgram + , ghcPkgProgram + , hugsProgram + , ffihugsProgram + , nhcProgram + , hmakeProgram + , jhcProgram + , lhcProgram + , lhcPkgProgram + , uhcProgram + -- preprocessors + , hscolourProgram + , haddockProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , greencardProgram + -- platform toolchain + , gccProgram + , ranlibProgram + , arProgram + , stripProgram + , ldProgram + , tarProgram + -- configuration tools + , pkgConfigProgram + ] + +ghcProgram :: Program +ghcProgram = (simpleProgram "ghc") { + programFindVersion = findProgramVersion "--numeric-version" id + } + +ghcPkgProgram :: Program +ghcPkgProgram = (simpleProgram "ghc-pkg") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "ghc-pkg --version" gives a string like + -- "GHC package manager version 6.4.1" + case words str of + (_:_:_:_:ver:_) -> ver + _ -> "" + } + +lhcProgram :: Program +lhcProgram = (simpleProgram "lhc") { + programFindVersion = findProgramVersion "--numeric-version" id + } + +lhcPkgProgram :: Program +lhcPkgProgram = (simpleProgram "lhc-pkg") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "lhc-pkg --version" gives a string like + -- "LHC package manager version 0.7" + case words str of + (_:_:_:_:ver:_) -> ver + _ -> "" + } + +nhcProgram :: Program +nhcProgram = (simpleProgram "nhc98") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "nhc98 --version" gives a string like + -- "/usr/local/bin/nhc98: v1.20 (2007-11-22)" + case words str of + (_:('v':ver):_) -> ver + _ -> "" + } + +hmakeProgram :: Program +hmakeProgram = (simpleProgram "hmake") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "hmake --version" gives a string line + -- "/usr/local/bin/hmake: 3.13 (2006-11-01)" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +jhcProgram :: Program +jhcProgram = (simpleProgram "jhc") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- invoking "jhc --version" gives a string like + -- "jhc 0.3.20080208 (wubgipkamcep-2) + -- compiled by ghc-6.8 on a x86_64 running linux" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +uhcProgram :: Program +uhcProgram = (simpleProgram "uhc") { + programFindVersion = findProgramVersion "--version-dotted" id + } + + +-- AArgh! Finding the version of hugs or ffihugs is almost impossible. +hugsProgram :: Program +hugsProgram = simpleProgram "hugs" + +ffihugsProgram :: Program +ffihugsProgram = simpleProgram "ffihugs" + +happyProgram :: Program +happyProgram = (simpleProgram "happy") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "happy --version" gives a string like + -- "Happy Version 1.16 Copyright (c) ...." + case words str of + (_:_:ver:_) -> ver + _ -> "" + } + +alexProgram :: Program +alexProgram = (simpleProgram "alex") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "alex --version" gives a string like + -- "Alex version 2.1.0, (c) 2003 Chris Dornan and Simon Marlow" + case words str of + (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver + _ -> "" + } + +gccProgram :: Program +gccProgram = (simpleProgram "gcc") { + programFindVersion = findProgramVersion "-dumpversion" id + } + +ranlibProgram :: Program +ranlibProgram = simpleProgram "ranlib" + +arProgram :: Program +arProgram = simpleProgram "ar" + +stripProgram :: Program +stripProgram = simpleProgram "strip" + +hsc2hsProgram :: Program +hsc2hsProgram = (simpleProgram "hsc2hs") { + programFindVersion = + findProgramVersion "--version" $ \str -> + -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66" + case words str of + (_:_:ver:_) -> ver + _ -> "" + } + +c2hsProgram :: Program +c2hsProgram = (simpleProgram "c2hs") { + programFindVersion = findProgramVersion "--numeric-version" id + } + +cpphsProgram :: Program +cpphsProgram = (simpleProgram "cpphs") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "cpphs --version" gives a string like "cpphs 1.3" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +hscolourProgram :: Program +hscolourProgram = (simpleProgram "hscolour") { + programFindLocation = \v -> findProgramLocation v "HsColour", + programFindVersion = findProgramVersion "-version" $ \str -> + -- Invoking "HsColour -version" gives a string like "HsColour 1.7" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +haddockProgram :: Program +haddockProgram = (simpleProgram "haddock") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "haddock --version" gives a string like + -- "Haddock version 0.8, (c) Simon Marlow 2006" + case words str of + (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver + _ -> "" + } + +greencardProgram :: Program +greencardProgram = simpleProgram "greencard" + +ldProgram :: Program +ldProgram = simpleProgram "ld" + +tarProgram :: Program +tarProgram = simpleProgram "tar" + +cppProgram :: Program +cppProgram = simpleProgram "cpp" + +pkgConfigProgram :: Program +pkgConfigProgram = (simpleProgram "pkg-config") { + programFindVersion = findProgramVersion "--version" id + } diff --git a/cabal/cabal/Distribution/Simple/Program/Db.hs b/cabal/cabal/Distribution/Simple/Program/Db.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Program/Db.hs @@ -0,0 +1,409 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Db +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This provides a 'ProgramDb' type which holds configured and not-yet +-- configured programs. It is the parameter to lots of actions elsewhere in +-- Cabal that need to look up and run programs. If we had a Cabal monad, +-- the 'ProgramDb' would probably be a reader or state component of it. +-- +-- One nice thing about using it is that any program that is +-- registered with Cabal will get some \"configure\" and \".cabal\" +-- helpers like --with-foo-args --foo-path= and extra-foo-args. +-- +-- There's also a hook for adding programs in a Setup.lhs script. See +-- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a +-- hook user the ability to get the above flags and such so that they +-- don't have to write all the PATH logic inside Setup.lhs. + +module Distribution.Simple.Program.Db ( + -- * The collection of configured programs we can run + ProgramDb, + emptyProgramDb, + defaultProgramDb, + restoreProgramDb, + + -- ** Query and manipulate the program db + addKnownProgram, + addKnownPrograms, + lookupKnownProgram, + knownPrograms, + userSpecifyPath, + userSpecifyPaths, + userMaybeSpecifyPath, + userSpecifyArgs, + userSpecifyArgss, + userSpecifiedArgs, + lookupProgram, + updateProgram, + + -- ** Query and manipulate the program db + configureProgram, + configureAllKnownPrograms, + reconfigurePrograms, + requireProgram, + requireProgramVersion, + + ) where + +import Distribution.Simple.Program.Types + ( Program(..), ProgArg, ConfiguredProgram(..), ProgramLocation(..) ) +import Distribution.Simple.Program.Builtin + ( builtinPrograms ) +import Distribution.Simple.Utils + ( die, findProgramLocation ) +import Distribution.Version + ( Version, VersionRange, isAnyVersion, withinRange ) +import Distribution.Text + ( display ) +import Distribution.Verbosity + ( Verbosity ) + +import Data.List + ( foldl' ) +import Data.Maybe + ( catMaybes ) +import qualified Data.Map as Map +import Control.Monad + ( join, foldM ) +import System.Directory + ( doesFileExist ) + + +-- ------------------------------------------------------------ +-- * Programs database +-- ------------------------------------------------------------ + +-- | The configuration is a collection of information about programs. It +-- contains information both about configured programs and also about programs +-- that we are yet to configure. +-- +-- The idea is that we start from a collection of unconfigured programs and one +-- by one we try to configure them at which point we move them into the +-- configured collection. For unconfigured programs we record not just the +-- 'Program' but also any user-provided arguments and location for the program. +data ProgramDb = ProgramDb { + unconfiguredProgs :: UnconfiguredProgs, + configuredProgs :: ConfiguredProgs + } + +type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg]) +type UnconfiguredProgs = Map.Map String UnconfiguredProgram +type ConfiguredProgs = Map.Map String ConfiguredProgram + + +emptyProgramDb :: ProgramDb +emptyProgramDb = ProgramDb Map.empty Map.empty + + +defaultProgramDb :: ProgramDb +defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb + + +-- internal helpers: +updateUnconfiguredProgs :: (UnconfiguredProgs -> UnconfiguredProgs) + -> ProgramDb -> ProgramDb +updateUnconfiguredProgs update conf = + conf { unconfiguredProgs = update (unconfiguredProgs conf) } + +updateConfiguredProgs :: (ConfiguredProgs -> ConfiguredProgs) + -> ProgramDb -> ProgramDb +updateConfiguredProgs update conf = + conf { configuredProgs = update (configuredProgs conf) } + + +-- Read & Show instances are based on listToFM +-- Note that we only serialise the configured part of the database, this is +-- because we don't need the unconfigured part after the configure stage, and +-- additionally because we cannot read/show 'Program' as it contains functions. +instance Show ProgramDb where + show = show . Map.toAscList . configuredProgs + +instance Read ProgramDb where + readsPrec p s = + [ (emptyProgramDb { configuredProgs = Map.fromList s' }, r) + | (s', r) <- readsPrec p s ] + + +-- | The Read\/Show instance does not preserve all the unconfigured 'Programs' +-- because 'Program' is not in Read\/Show because it contains functions. So to +-- fully restore a deserialised 'ProgramDb' use this function to add +-- back all the known 'Program's. +-- +-- * It does not add the default programs, but you probably want them, use +-- 'builtinPrograms' in addition to any extra you might need. +-- +restoreProgramDb :: [Program] -> ProgramDb -> ProgramDb +restoreProgramDb = addKnownPrograms + + +-- ------------------------------- +-- Managing unconfigured programs + +-- | Add a known program that we may configure later +-- +addKnownProgram :: Program -> ProgramDb -> ProgramDb +addKnownProgram prog = updateUnconfiguredProgs $ + Map.insertWith combine (programName prog) (prog, Nothing, []) + where combine _ (_, path, args) = (prog, path, args) + + +addKnownPrograms :: [Program] -> ProgramDb -> ProgramDb +addKnownPrograms progs conf = foldl' (flip addKnownProgram) conf progs + + +lookupKnownProgram :: String -> ProgramDb -> Maybe Program +lookupKnownProgram name = + fmap (\(p,_,_)->p) . Map.lookup name . unconfiguredProgs + + +knownPrograms :: ProgramDb -> [(Program, Maybe ConfiguredProgram)] +knownPrograms conf = + [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs conf) + , let p' = Map.lookup (programName p) (configuredProgs conf) ] + + +-- |User-specify this path. Basically override any path information +-- for this program in the configuration. If it's not a known +-- program ignore it. +-- +userSpecifyPath :: String -- ^Program name + -> FilePath -- ^user-specified path to the program + -> ProgramDb -> ProgramDb +userSpecifyPath name path = updateUnconfiguredProgs $ + flip Map.update name $ \(prog, _, args) -> Just (prog, Just path, args) + + +userMaybeSpecifyPath :: String -> Maybe FilePath + -> ProgramDb -> ProgramDb +userMaybeSpecifyPath _ Nothing conf = conf +userMaybeSpecifyPath name (Just path) conf = userSpecifyPath name path conf + + +-- |User-specify the arguments for this program. Basically override +-- any args information for this program in the configuration. If it's +-- not a known program, ignore it.. +userSpecifyArgs :: String -- ^Program name + -> [ProgArg] -- ^user-specified args + -> ProgramDb + -> ProgramDb +userSpecifyArgs name args' = + updateUnconfiguredProgs + (flip Map.update name $ + \(prog, path, args) -> Just (prog, path, args ++ args')) + . updateConfiguredProgs + (flip Map.update name $ + \prog -> Just prog { programOverrideArgs = programOverrideArgs prog + ++ args' }) + + +-- | Like 'userSpecifyPath' but for a list of progs and their paths. +-- +userSpecifyPaths :: [(String, FilePath)] + -> ProgramDb + -> ProgramDb +userSpecifyPaths paths conf = + foldl' (\conf' (prog, path) -> userSpecifyPath prog path conf') conf paths + + +-- | Like 'userSpecifyPath' but for a list of progs and their args. +-- +userSpecifyArgss :: [(String, [ProgArg])] + -> ProgramDb + -> ProgramDb +userSpecifyArgss argss conf = + foldl' (\conf' (prog, args) -> userSpecifyArgs prog args conf') conf argss + + +-- | Get the path that has been previously specified for a program, if any. +-- +userSpecifiedPath :: Program -> ProgramDb -> Maybe FilePath +userSpecifiedPath prog = + join . fmap (\(_,p,_)->p) . Map.lookup (programName prog) . unconfiguredProgs + + +-- | Get any extra args that have been previously specified for a program. +-- +userSpecifiedArgs :: Program -> ProgramDb -> [ProgArg] +userSpecifiedArgs prog = + maybe [] (\(_,_,as)->as) . Map.lookup (programName prog) . unconfiguredProgs + + +-- ----------------------------- +-- Managing configured programs + +-- | Try to find a configured program +lookupProgram :: Program -> ProgramDb -> Maybe ConfiguredProgram +lookupProgram prog = Map.lookup (programName prog) . configuredProgs + + +-- | Update a configured program in the database. +updateProgram :: ConfiguredProgram -> ProgramDb + -> ProgramDb +updateProgram prog = updateConfiguredProgs $ + Map.insert (programId prog) prog + + +-- --------------------------- +-- Configuring known programs + +-- | Try to configure a specific program. If the program is already included in +-- the colleciton of unconfigured programs then we use any user-supplied +-- location and arguments. If the program gets configured sucessfully it gets +-- added to the configured collection. +-- +-- Note that it is not a failure if the program cannot be configured. It's only +-- a failure if the user supplied a location and the program could not be found +-- at that location. +-- +-- The reason for it not being a failure at this stage is that we don't know up +-- front all the programs we will need, so we try to configure them all. +-- To verify that a program was actually sucessfully configured use +-- 'requireProgram'. +-- +configureProgram :: Verbosity + -> Program + -> ProgramDb + -> IO ProgramDb +configureProgram verbosity prog conf = do + let name = programName prog + maybeLocation <- case userSpecifiedPath prog conf of + Nothing -> programFindLocation prog verbosity + >>= return . fmap FoundOnSystem + Just path -> do + absolute <- doesFileExist path + if absolute + then return (Just (UserSpecified path)) + else findProgramLocation verbosity path + >>= maybe (die notFound) (return . Just . UserSpecified) + where notFound = "Cannot find the program '" ++ name ++ "' at '" + ++ path ++ "' or on the path" + case maybeLocation of + Nothing -> return conf + Just location -> do + version <- programFindVersion prog verbosity (locationPath location) + let configuredProg = ConfiguredProgram { + programId = name, + programVersion = version, + programDefaultArgs = [], + programOverrideArgs = userSpecifiedArgs prog conf, + programLocation = location + } + extraArgs <- programPostConf prog verbosity configuredProg + let configuredProg' = configuredProg { + programDefaultArgs = extraArgs + } + return (updateConfiguredProgs (Map.insert name configuredProg') conf) + + +-- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'. +-- +configurePrograms :: Verbosity + -> [Program] + -> ProgramDb + -> IO ProgramDb +configurePrograms verbosity progs conf = + foldM (flip (configureProgram verbosity)) conf progs + + +-- | Try to configure all the known programs that have not yet been configured. +-- +configureAllKnownPrograms :: Verbosity + -> ProgramDb + -> IO ProgramDb +configureAllKnownPrograms verbosity conf = + configurePrograms verbosity + [ prog | (prog,_,_) <- Map.elems notYetConfigured ] conf + where + notYetConfigured = unconfiguredProgs conf + `Map.difference` configuredProgs conf + + +-- | reconfigure a bunch of programs given new user-specified args. It takes +-- the same inputs as 'userSpecifyPath' and 'userSpecifyArgs' and for all progs +-- with a new path it calls 'configureProgram'. +-- +reconfigurePrograms :: Verbosity + -> [(String, FilePath)] + -> [(String, [ProgArg])] + -> ProgramDb + -> IO ProgramDb +reconfigurePrograms verbosity paths argss conf = do + configurePrograms verbosity progs + . userSpecifyPaths paths + . userSpecifyArgss argss + $ conf + + where + progs = catMaybes [ lookupKnownProgram name conf | (name,_) <- paths ] + + +-- | Check that a program is configured and available to be run. +-- +-- It raises an exception if the program could not be configured, otherwise +-- it returns the configured program. +-- +requireProgram :: Verbosity -> Program -> ProgramDb + -> IO (ConfiguredProgram, ProgramDb) +requireProgram verbosity prog conf = do + + -- If it's not already been configured, try to configure it now + conf' <- case lookupProgram prog conf of + Nothing -> configureProgram verbosity prog conf + Just _ -> return conf + + case lookupProgram prog conf' of + Nothing -> die notFound + Just configuredProg -> return (configuredProg, conf') + + where notFound = "The program " ++ programName prog + ++ " is required but it could not be found." + + +-- | Check that a program is configured and available to be run. +-- +-- Additionally check that the version of the program number is suitable and +-- return it. For example you could require 'AnyVersion' or +-- @'orLaterVersion' ('Version' [1,0] [])@ +-- +-- It raises an exception if the program could not be configured or the version +-- is unsuitable, otherwise it returns the configured program and its version +-- number. +-- +requireProgramVersion :: Verbosity -> Program -> VersionRange + -> ProgramDb + -> IO (ConfiguredProgram, Version, ProgramDb) +requireProgramVersion verbosity prog range conf = do + + -- If it's not already been configured, try to configure it now + conf' <- case lookupProgram prog conf of + Nothing -> configureProgram verbosity prog conf + Just _ -> return conf + + case lookupProgram prog conf' of + Nothing -> die notFound + Just configuredProg@ConfiguredProgram { programLocation = location } -> + case programVersion configuredProg of + Just version + | withinRange version range -> return (configuredProg, version, conf') + | otherwise -> die (badVersion version location) + Nothing -> die (noVersion location) + + where notFound = "The program " + ++ programName prog ++ versionRequirement + ++ " is required but it could not be found." + badVersion v l = "The program " + ++ programName prog ++ versionRequirement + ++ " is required but the version found at " + ++ locationPath l ++ " is version " ++ display v + noVersion l = "The program " + ++ programName prog ++ versionRequirement + ++ " is required but the version of " + ++ locationPath l ++ " could not be determined." + versionRequirement + | isAnyVersion range = "" + | otherwise = " version " ++ display range diff --git a/cabal/cabal/Distribution/Simple/Program/HcPkg.hs b/cabal/cabal/Distribution/Simple/Program/HcPkg.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Program/HcPkg.hs @@ -0,0 +1,338 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.HcPkg +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @hc-pkg@ program. +-- Currently only GHC and LHC have hc-pkg programs. + +module Distribution.Simple.Program.HcPkg ( + register, + reregister, + unregister, + expose, + hide, + dump, + + -- * Program invocations + registerInvocation, + reregisterInvocation, + unregisterInvocation, + exposeInvocation, + hideInvocation, + dumpInvocation, + ) where + +import Distribution.Package + ( PackageId, InstalledPackageId(..) ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo, InstalledPackageInfo_(..) + , showInstalledPackageInfo + , emptyInstalledPackageInfo, fieldsInstalledPackageInfo ) +import Distribution.ParseUtils +import Distribution.Simple.Compiler + ( PackageDB(..), PackageDBStack ) +import Distribution.Simple.Program.Types + ( ConfiguredProgram(programId, programVersion) ) +import Distribution.Simple.Program.Run + ( ProgramInvocation(..), IOEncoding(..), programInvocation + , runProgramInvocation, getProgramInvocationOutput ) +import Distribution.Version + ( Version(..) ) +import Distribution.Text + ( display ) +import Distribution.Simple.Utils + ( die ) +import Distribution.Verbosity + ( Verbosity, deafening, silent ) +import Distribution.Compat.Exception + ( catchExit ) + +import Data.Char + ( isSpace ) +import Data.Maybe + ( fromMaybe ) +import Data.List + ( stripPrefix ) +import System.FilePath as FilePath + ( (), splitPath, splitDirectories, joinPath, isPathSeparator ) +import qualified System.FilePath.Posix as FilePath.Posix + + +-- | Call @hc-pkg@ to register a package. +-- +-- > hc-pkg register {filename | -} [--user | --global | --package-conf] +-- +register :: Verbosity -> ConfiguredProgram -> PackageDBStack + -> Either FilePath + InstalledPackageInfo + -> IO () +register verbosity hcPkg packagedb pkgFile = + runProgramInvocation verbosity + (registerInvocation hcPkg verbosity packagedb pkgFile) + + +-- | Call @hc-pkg@ to re-register a package. +-- +-- > hc-pkg register {filename | -} [--user | --global | --package-conf] +-- +reregister :: Verbosity -> ConfiguredProgram -> PackageDBStack + -> Either FilePath + InstalledPackageInfo + -> IO () +reregister verbosity hcPkg packagedb pkgFile = + runProgramInvocation verbosity + (reregisterInvocation hcPkg verbosity packagedb pkgFile) + + +-- | Call @hc-pkg@ to unregister a package +-- +-- > hc-pkg unregister [pkgid] [--user | --global | --package-conf] +-- +unregister :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO () +unregister verbosity hcPkg packagedb pkgid = + runProgramInvocation verbosity + (unregisterInvocation hcPkg verbosity packagedb pkgid) + + +-- | Call @hc-pkg@ to expose a package. +-- +-- > hc-pkg expose [pkgid] [--user | --global | --package-conf] +-- +expose :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO () +expose verbosity hcPkg packagedb pkgid = + runProgramInvocation verbosity + (exposeInvocation hcPkg verbosity packagedb pkgid) + + +-- | Call @hc-pkg@ to expose a package. +-- +-- > hc-pkg expose [pkgid] [--user | --global | --package-conf] +-- +hide :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO () +hide verbosity hcPkg packagedb pkgid = + runProgramInvocation verbosity + (hideInvocation hcPkg verbosity packagedb pkgid) + + +-- | Call @hc-pkg@ to get all the installed packages. +-- +dump :: Verbosity -> ConfiguredProgram -> PackageDB -> IO [InstalledPackageInfo] +dump verbosity hcPkg packagedb = do + + output <- getProgramInvocationOutput verbosity + (dumpInvocation hcPkg verbosity packagedb) + `catchExit` \_ -> die $ programId hcPkg ++ " dump failed" + + case parsePackages output of + Left ok -> return ok + _ -> die $ "failed to parse output of '" + ++ programId hcPkg ++ " dump'" + + where + parsePackages str = + let parsed = map parseInstalledPackageInfo' (splitPkgs str) + in case [ msg | ParseFailed msg <- parsed ] of + [] -> Left [ setInstalledPackageId + . maybe id mungePackagePaths pkgroot + $ pkg + | ParseOk _ (pkgroot, pkg) <- parsed ] + msgs -> Right msgs + + parseInstalledPackageInfo' = + parseFieldsFlat fields (Nothing, emptyInstalledPackageInfo) + where + fields = liftFieldFst pkgrootField + : map liftFieldSnd fieldsInstalledPackageInfo + + pkgrootField = + simpleField "pkgroot" + showFilePath parseFilePathQ + (fromMaybe "") (\x _ -> Just x) + + liftFieldFst = liftField fst (\x (_x,y) -> (x,y)) + liftFieldSnd = liftField snd (\y (x,_y) -> (x,y)) + + --TODO: this could be a lot faster. We're doing normaliseLineEndings twice + -- and converting back and forth with lines/unlines. + splitPkgs :: String -> [String] + splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines + where + -- Handle the case of there being no packages at all. + checkEmpty [s] | all isSpace s = [] + checkEmpty ss = ss + + splitWith :: (a -> Bool) -> [a] -> [[a]] + splitWith p xs = ys : case zs of + [] -> [] + _:ws -> splitWith p ws + where (ys,zs) = break p xs + +mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo +-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec +-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) +-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. +-- The "pkgroot" is the directory containing the package database. +mungePackagePaths pkgroot pkginfo = + pkginfo { + importDirs = mungePaths (importDirs pkginfo), + includeDirs = mungePaths (includeDirs pkginfo), + libraryDirs = mungePaths (libraryDirs pkginfo), + frameworkDirs = mungePaths (frameworkDirs pkginfo), + haddockInterfaces = mungePaths (haddockInterfaces pkginfo), + haddockHTMLs = mungeUrls (haddockHTMLs pkginfo) + } + where + mungePaths = map mungePath + mungeUrls = map mungeUrl + + mungePath p = case stripVarPrefix "${pkgroot}" p of + Just p' -> pkgroot p' + Nothing -> p + + mungeUrl p = case stripVarPrefix "${pkgrooturl}" p of + Just p' -> toUrlPath pkgroot p' + Nothing -> p + + toUrlPath r p = "file:///" + -- URLs always use posix style '/' separators: + ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p) + + stripVarPrefix var p = + case splitPath p of + (root:path') -> case stripPrefix var root of + Just [sep] | isPathSeparator sep -> Just (joinPath path') + _ -> Nothing + _ -> Nothing + + +-- Older installed package info files did not have the installedPackageId +-- field, so if it is missing then we fill it as the source package ID. +setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo +setInstalledPackageId pkginfo@InstalledPackageInfo { + installedPackageId = InstalledPackageId "", + sourcePackageId = pkgid + } + = pkginfo { + --TODO use a proper named function for the conversion + -- from source package id to installed package id + installedPackageId = InstalledPackageId (display pkgid) + } +setInstalledPackageId pkginfo = pkginfo + + +-------------------------- +-- The program invocations +-- + +registerInvocation, reregisterInvocation + :: ConfiguredProgram -> Verbosity -> PackageDBStack + -> Either FilePath InstalledPackageInfo + -> ProgramInvocation +registerInvocation = registerInvocation' "register" +reregisterInvocation = registerInvocation' "update" + + +registerInvocation' :: String + -> ConfiguredProgram -> Verbosity -> PackageDBStack + -> Either FilePath InstalledPackageInfo + -> ProgramInvocation +registerInvocation' cmdname hcPkg verbosity packagedbs (Left pkgFile) = + programInvocation hcPkg args + where + args = [cmdname, pkgFile] + ++ (if legacyVersion hcPkg + then [packageDbOpts (last packagedbs)] + else packageDbStackOpts packagedbs) + ++ verbosityOpts hcPkg verbosity + +registerInvocation' cmdname hcPkg verbosity packagedbs (Right pkgInfo) = + (programInvocation hcPkg args) { + progInvokeInput = Just (showInstalledPackageInfo pkgInfo), + progInvokeInputEncoding = IOEncodingUTF8 + } + where + args = [cmdname, "-"] + ++ (if legacyVersion hcPkg + then [packageDbOpts (last packagedbs)] + else packageDbStackOpts packagedbs) + ++ verbosityOpts hcPkg verbosity + + +unregisterInvocation :: ConfiguredProgram + -> Verbosity -> PackageDB -> PackageId + -> ProgramInvocation +unregisterInvocation hcPkg verbosity packagedb pkgid = + programInvocation hcPkg $ + ["unregister", packageDbOpts packagedb, display pkgid] + ++ verbosityOpts hcPkg verbosity + + +exposeInvocation :: ConfiguredProgram + -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation +exposeInvocation hcPkg verbosity packagedb pkgid = + programInvocation hcPkg $ + ["expose", packageDbOpts packagedb, display pkgid] + ++ verbosityOpts hcPkg verbosity + + +hideInvocation :: ConfiguredProgram + -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation +hideInvocation hcPkg verbosity packagedb pkgid = + programInvocation hcPkg $ + ["hide", packageDbOpts packagedb, display pkgid] + ++ verbosityOpts hcPkg verbosity + + +dumpInvocation :: ConfiguredProgram + -> Verbosity -> PackageDB -> ProgramInvocation +dumpInvocation hcPkg _verbosity packagedb = + (programInvocation hcPkg args) { + progInvokeOutputEncoding = IOEncodingUTF8 + } + where + args = ["dump", packageDbOpts packagedb] + ++ verbosityOpts hcPkg silent + -- We use verbosity level 'silent' because it is important that we + -- do not contaminate the output with info/debug messages. + + +packageDbStackOpts :: PackageDBStack -> [String] +packageDbStackOpts dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> "--global" + : "--user" + : map specific dbs + (GlobalPackageDB:dbs) -> "--global" + : "--no-user-package-conf" + : map specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = "--package-conf=" ++ db + specific _ = ierror + ierror :: a + ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) + +packageDbOpts :: PackageDB -> String +packageDbOpts GlobalPackageDB = "--global" +packageDbOpts UserPackageDB = "--user" +packageDbOpts (SpecificPackageDB db) = "--package-conf=" ++ db + +verbosityOpts :: ConfiguredProgram -> Verbosity -> [String] +verbosityOpts hcPkg v + + -- ghc-pkg < 6.11 does not support -v + | programId hcPkg == "ghc-pkg" + && programVersion hcPkg < Just (Version [6,11] []) + = [] + + | v >= deafening = ["-v2"] + | v == silent = ["-v0"] + | otherwise = [] + +-- Handle quirks in ghc-pkg 6.8 and older +legacyVersion :: ConfiguredProgram -> Bool +legacyVersion hcPkg = programId hcPkg == "ghc-pkg" + && programVersion hcPkg < Just (Version [6,9] []) diff --git a/cabal/cabal/Distribution/Simple/Program/Ld.hs b/cabal/cabal/Distribution/Simple/Program/Ld.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Program/Ld.hs @@ -0,0 +1,62 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Ld +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @ld@ linker program. + +module Distribution.Simple.Program.Ld ( + combineObjectFiles, + ) where + +import Distribution.Simple.Program.Types + ( ConfiguredProgram(..) ) +import Distribution.Simple.Program.Run + ( programInvocation, multiStageProgramInvocation + , runProgramInvocation ) +import Distribution.Verbosity + ( Verbosity ) + +import System.Directory + ( renameFile ) +import System.FilePath + ( (<.>) ) + +-- | Call @ld -r@ to link a bunch of object files together. +-- +combineObjectFiles :: Verbosity -> ConfiguredProgram + -> FilePath -> [FilePath] -> IO () +combineObjectFiles verbosity ld target files = + + -- Unlike "ar", the "ld" tool is not designed to be used with xargs. That is, + -- if we have more object files than fit on a single command line then we + -- have a slight problem. What we have to do is link files in batches into + -- a temp object file and then include that one in the next batch. + + let simpleArgs = ["-r", "-o", target] + + initialArgs = ["-r", "-o", target] + middleArgs = ["-r", "-o", target, tmpfile] + finalArgs = middleArgs + + simple = programInvocation ld simpleArgs + initial = programInvocation ld initialArgs + middle = programInvocation ld middleArgs + final = programInvocation ld finalArgs + + invocations = multiStageProgramInvocation + simple (initial, middle, final) files + + in run invocations + + where + tmpfile = target <.> "tmp" -- perhaps should use a proper temp file + + run [] = return () + run [inv] = runProgramInvocation verbosity inv + run (inv:invs) = do runProgramInvocation verbosity inv + renameFile target tmpfile + run invs diff --git a/cabal/cabal/Distribution/Simple/Program/Run.hs b/cabal/cabal/Distribution/Simple/Program/Run.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Program/Run.hs @@ -0,0 +1,218 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Run +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides a data type for program invocations and functions to +-- run them. + +module Distribution.Simple.Program.Run ( + ProgramInvocation(..), + IOEncoding(..), + emptyProgramInvocation, + simpleProgramInvocation, + programInvocation, + multiStageProgramInvocation, + + runProgramInvocation, + getProgramInvocationOutput, + + ) where + +import Distribution.Simple.Program.Types + ( ConfiguredProgram(..), programPath ) +import Distribution.Simple.Utils + ( die, rawSystemExit, rawSystemStdInOut + , toUTF8, fromUTF8, normaliseLineEndings ) +import Distribution.Verbosity + ( Verbosity ) + +import Data.List + ( foldl', unfoldr ) +import Control.Monad + ( when ) +import System.Exit + ( ExitCode(..) ) + +-- | Represents a specific invocation of a specific program. +-- +-- This is used as an intermediate type between deciding how to call a program +-- and actually doing it. This provides the opportunity to the caller to +-- adjust how the program will be called. These invocations can either be run +-- directly or turned into shell or batch scripts. +-- +data ProgramInvocation = ProgramInvocation { + progInvokePath :: FilePath, + progInvokeArgs :: [String], + progInvokeEnv :: [(String, String)], + progInvokeCwd :: Maybe FilePath, + progInvokeInput :: Maybe String, + progInvokeInputEncoding :: IOEncoding, + progInvokeOutputEncoding :: IOEncoding + } + +data IOEncoding = IOEncodingText -- locale mode text + | IOEncodingUTF8 -- always utf8 + +emptyProgramInvocation :: ProgramInvocation +emptyProgramInvocation = + ProgramInvocation { + progInvokePath = "", + progInvokeArgs = [], + progInvokeEnv = [], + progInvokeCwd = Nothing, + progInvokeInput = Nothing, + progInvokeInputEncoding = IOEncodingText, + progInvokeOutputEncoding = IOEncodingText + } + +simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation +simpleProgramInvocation path args = + emptyProgramInvocation { + progInvokePath = path, + progInvokeArgs = args + } + +programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation +programInvocation prog args = + emptyProgramInvocation { + progInvokePath = programPath prog, + progInvokeArgs = programDefaultArgs prog + ++ args + ++ programOverrideArgs prog + } + + +runProgramInvocation :: Verbosity -> ProgramInvocation -> IO () +runProgramInvocation verbosity + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = [], + progInvokeCwd = Nothing, + progInvokeInput = Nothing + } = + rawSystemExit verbosity path args + +runProgramInvocation verbosity + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = [], + progInvokeCwd = Nothing, + progInvokeInput = Just inputStr, + progInvokeInputEncoding = encoding + } = do + (_, errors, exitCode) <- rawSystemStdInOut verbosity + path args + (Just input) False + when (exitCode /= ExitSuccess) $ + die errors + where + input = case encoding of + IOEncodingText -> (inputStr, False) + IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8 + +runProgramInvocation _ _ = + die "runProgramInvocation: not yet implemented for this form of invocation" + + +getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String +getProgramInvocationOutput verbosity + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = [], + progInvokeCwd = Nothing, + progInvokeInput = Nothing, + progInvokeOutputEncoding = encoding + } = do + let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False + decode | utf8 = fromUTF8 . normaliseLineEndings + | otherwise = id + (output, errors, exitCode) <- rawSystemStdInOut verbosity + path args + Nothing utf8 + when (exitCode /= ExitSuccess) $ + die errors + return (decode output) + + +getProgramInvocationOutput _ _ = + die "getProgramInvocationOutput: not yet implemented for this form of invocation" + + +-- | 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. +-- +-- It takes four template invocations corresponding to the simple, initial, +-- middle and last invocations. If the number of args given is small enough +-- that we can get away with just a single invocation then the simple one is +-- used: +-- +-- > $ simple args +-- +-- If the number of args given means that we need to use multiple invocations +-- then the templates for the initial, middle and last invocations are used: +-- +-- > $ initial args_0 +-- > $ middle args_1 +-- > $ middle args_2 +-- > ... +-- > $ final args_n +-- +multiStageProgramInvocation + :: ProgramInvocation + -> (ProgramInvocation, ProgramInvocation, ProgramInvocation) + -> [String] + -> [ProgramInvocation] +multiStageProgramInvocation simple (initial, middle, final) args = + + let argSize inv = length (progInvokePath inv) + + foldl' (\s a -> length a + 1 + s) 1 (progInvokeArgs inv) + fixedArgSize = maximum (map argSize [simple, initial, middle, final]) + chunkSize = maxCommandLineSize - fixedArgSize + + in case splitChunks chunkSize args of + [] -> [ simple ] + + [c] -> [ simple `appendArgs` c ] + + [c,c'] -> [ initial `appendArgs` c ] + ++ [ final `appendArgs` c'] + + (c:cs) -> [ initial `appendArgs` c ] + ++ [ middle `appendArgs` c'| c' <- init cs ] + ++ [ final `appendArgs` c'| let c' = last cs ] + + where + inv `appendArgs` as = inv { progInvokeArgs = progInvokeArgs inv ++ as } + + splitChunks len = unfoldr $ \s -> + if null s then Nothing + else Just (chunk len s) + + chunk len (s:_) | length s >= len = error toolong + chunk len ss = chunk' [] len ss + + chunk' acc _ [] = (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 + + toolong = "multiStageProgramInvocation: a single program arg is larger " + ++ "than the maximum command line length!" + + +--FIXME: discover this at configure time or runtime on unix +-- The value is 32k on Windows and posix specifies a minimum of 4k +-- but all sensible unixes use more than 4k. +-- we could use getSysVar ArgumentLimit but that's in the unix lib +-- +maxCommandLineSize :: Int +maxCommandLineSize = 30 * 1024 diff --git a/cabal/cabal/Distribution/Simple/Program/Script.hs b/cabal/cabal/Distribution/Simple/Program/Script.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Program/Script.hs @@ -0,0 +1,105 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Script +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @hc-pkg@ program. +-- Currently only GHC and LHC have hc-pkg programs. + +module Distribution.Simple.Program.Script ( + + invocationAsSystemScript, + invocationAsShellScript, + invocationAsBatchFile, + ) where + +import Distribution.Simple.Program.Run + ( ProgramInvocation(..) ) +import Distribution.System + ( OS(..) ) + +import Data.Maybe + ( maybeToList ) + +-- | Generate a system script, either POSIX shell script or Windows batch file +-- as appropriate for the given system. +-- +invocationAsSystemScript :: OS -> ProgramInvocation -> String +invocationAsSystemScript Windows = invocationAsBatchFile +invocationAsSystemScript _ = invocationAsShellScript + + +-- | Generate a POSIX shell script that invokes a program. +-- +invocationAsShellScript :: ProgramInvocation -> String +invocationAsShellScript + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = envExtra, + progInvokeCwd = mcwd, + progInvokeInput = minput + } = unlines $ + [ "#!/bin/sh" ] + ++ [ "export " ++ var ++ "=" ++ quote val + | (var,val) <- envExtra ] + ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ] + ++ [ (case minput of + Nothing -> "" + Just input -> "echo " ++ quote input ++ " | ") + ++ unwords (map quote $ path : args) ++ " \"$@\""] + + where + quote :: String -> String + quote s = "'" ++ escape s ++ "'" + + escape [] = [] + escape ('\'':cs) = "'\\''" ++ escape cs + escape (c :cs) = c : escape cs + + +-- | Generate a Windows batch file that invokes a program. +-- +invocationAsBatchFile :: ProgramInvocation -> String +invocationAsBatchFile + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = envExtra, + progInvokeCwd = mcwd, + progInvokeInput = minput + } = unlines $ + [ "@echo off" ] + ++ [ "set " ++ var ++ "=" ++ escape val | (var,val) <- envExtra ] + ++ [ "cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd ] + ++ case minput of + Nothing -> + [ path ++ concatMap (' ':) args ] + + Just input -> + [ "(" ] + ++ [ "echo " ++ escape line | line <- lines input ] + ++ [ ") | " + ++ "\"" ++ path ++ "\"" + ++ concatMap (\arg -> ' ':quote arg) args ] + + where + quote :: String -> String + quote s = "\"" ++ escapeQ s ++ "\"" + + escapeQ [] = [] + escapeQ ('"':cs) = "\"\"\"" ++ escapeQ cs + escapeQ (c :cs) = c : escapeQ cs + + escape [] = [] + escape ('|':cs) = "^|" ++ escape cs + escape ('<':cs) = "^<" ++ escape cs + escape ('>':cs) = "^>" ++ escape cs + escape ('&':cs) = "^&" ++ escape cs + escape ('(':cs) = "^(" ++ escape cs + escape (')':cs) = "^)" ++ escape cs + escape ('^':cs) = "^^" ++ escape cs + escape (c :cs) = c : escape cs diff --git a/cabal/cabal/Distribution/Simple/Program/Types.hs b/cabal/cabal/Distribution/Simple/Program/Types.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Program/Types.hs @@ -0,0 +1,122 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Types +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This provides an abstraction which deals with configuring and running +-- programs. A 'Program' is a static notion of a known program. A +-- 'ConfiguredProgram' is a 'Program' that has been found on the current +-- machine and is ready to be run (possibly with some user-supplied default +-- args). Configuring a program involves finding its location and if necessary +-- finding its version. There's reasonable default behavior for trying to find +-- \"foo\" in PATH, being able to override its location, etc. +-- +module Distribution.Simple.Program.Types ( + -- * Program and functions for constructing them + Program(..), + internalProgram, + simpleProgram, + + -- * Configured program and related functions + ConfiguredProgram(..), + programPath, + ProgArg, + ProgramLocation(..), + ) where + +import Data.List (nub) +import System.FilePath (()) + +import Distribution.Simple.Utils + ( findProgramLocation, findFirstFile ) +import Distribution.Version + ( Version ) +import Distribution.Verbosity + ( Verbosity ) + +-- | Represents a program which can be configured. +data Program = Program { + -- | The simple name of the program, eg. ghc + programName :: String, + + -- | A function to search for the program if it's location was not + -- specified by the user. Usually this will just be a + programFindLocation :: Verbosity -> IO (Maybe FilePath), + + -- | Try to find the version of the program. For many programs this is + -- not possible or is not necessary so it's ok to return Nothing. + programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version), + + -- | A function to do any additional configuration after we have + -- located the program (and perhaps identified its version). It is + -- allowed to return additional flags that will be passed to the + -- program on every invocation. + programPostConf :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + } + +type ProgArg = String + +data ConfiguredProgram = ConfiguredProgram { + -- | Just the name again + programId :: String, + + -- | The version of this program, if it is known. + programVersion :: Maybe Version, + + -- | Default command-line args for this program. + -- These flags will appear first on the command line, so they can be + -- overridden by subsequent flags. + programDefaultArgs :: [String], + + -- | Override command-line args for this program. + -- These flags will appear last on the command line, so they override + -- all earlier flags. + programOverrideArgs :: [String], + + -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@ + programLocation :: ProgramLocation + } deriving (Read, Show, Eq) + +-- | Where a program was found. Also tells us whether it's specifed by user or +-- not. This includes not just the path, but the program as well. +data ProgramLocation + = UserSpecified { locationPath :: FilePath } + -- ^The user gave the path to this program, + -- eg. --ghc-path=\/usr\/bin\/ghc-6.6 + | FoundOnSystem { locationPath :: FilePath } + -- ^The location of the program, as located by searching PATH. + deriving (Read, Show, Eq) + +-- | The full path of a configured program. +programPath :: ConfiguredProgram -> FilePath +programPath = locationPath . programLocation + +-- | Make a simple named program. +-- +-- By default we'll just search for it in the path and not try to find the +-- version name. You can override these behaviours if necessary, eg: +-- +-- > simpleProgram "foo" { programFindLocation = ... , programFindVersion ... } +-- +simpleProgram :: String -> Program +simpleProgram name = Program { + programName = name, + programFindLocation = \v -> findProgramLocation v name, + programFindVersion = \_ _ -> return Nothing, + programPostConf = \_ _ -> return [] + } + +-- | Make a simple 'internal' program; that is, one that was built as an +-- executable already and is expected to be found in the build directory +internalProgram :: [FilePath] -> String -> Program +internalProgram paths name = Program { + programName = name, + programFindLocation = \_v -> + findFirstFile id [ path name | path <- nub paths ], + programFindVersion = \_ _ -> return Nothing, + programPostConf = \_ _ -> return [] + } + diff --git a/cabal/cabal/Distribution/Simple/Register.hs b/cabal/cabal/Distribution/Simple/Register.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Register.hs @@ -0,0 +1,390 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Register +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module deals with registering and unregistering packages. There are a +-- couple ways it can do this, one is to do it directly. Another is to generate +-- a script that can be run later to do it. The idea here being that the user +-- is shielded from the details of what command to use for package registration +-- for a particular compiler. In practice this aspect was not especially +-- popular so we also provide a way to simply generate the package registration +-- file which then must be manually passed to @ghc-pkg@. It is possible to +-- generate registration information for where the package is to be installed, +-- or alternatively to register the package inplace in the build tree. The +-- latter is occasionally handy, and will become more important when we try to +-- build multi-package systems. +-- +-- This module does not delegate anything to the per-compiler modules but just +-- mixes it all in in this module, which is rather unsatisfactory. The script +-- generation and the unregister feature are not well used or tested. + +{- 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, + + registerPackage, + generateRegistrationInfo, + inplaceInstalledPackageInfo, + absoluteInstalledPackageInfo, + generalInstalledPackageInfo, + ) where + +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) + , InstallDirs(..), absoluteInstallDirs ) +import Distribution.Simple.BuildPaths (haddockName) +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.LHC as LHC +import qualified Distribution.Simple.Hugs as Hugs +import qualified Distribution.Simple.UHC as UHC +import Distribution.Simple.Compiler + ( compilerVersion, CompilerFlavor(..), compilerFlavor + , PackageDBStack, registrationPackageDB ) +import Distribution.Simple.Program + ( ConfiguredProgram, runProgramInvocation + , requireProgram, lookupProgram, ghcPkgProgram, lhcPkgProgram ) +import Distribution.Simple.Program.Script + ( invocationAsSystemScript ) +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import Distribution.Simple.Setup + ( RegisterFlags(..), CopyDest(..) + , fromFlag, fromFlagOrDefault, flagToMaybe ) +import Distribution.PackageDescription + ( PackageDescription(..), Library(..), BuildInfo(..), hcOptions ) +import Distribution.Package + ( Package(..), packageName, InstalledPackageId(..) ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo, InstalledPackageInfo_(InstalledPackageInfo) + , showInstalledPackageInfo ) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Simple.Utils + ( writeUTF8File, writeFileAtomic, setFileExecutable + , die, notice, setupMessage ) +import Distribution.System + ( OS(..), buildOS ) +import Distribution.Text + ( display ) +import Distribution.Version ( Version(..) ) +import Distribution.Verbosity as Verbosity + ( Verbosity, normal ) +import Distribution.Compat.Exception + ( tryIO ) + +import System.FilePath ((), (<.>), isAbsolute) +import System.Directory + ( getCurrentDirectory, removeDirectoryRecursive ) + +import Data.Maybe + ( isJust, fromMaybe, maybeToList ) +import Data.List + ( partition, nub ) + + +-- ----------------------------------------------------------------------------- +-- Registration + +register :: PackageDescription -> LocalBuildInfo + -> RegisterFlags -- ^Install in the user's database?; verbose + -> IO () +register pkg@PackageDescription { library = Just lib } + lbi@LocalBuildInfo { libraryConfig = Just clbi } regFlags + = do + + installedPkgInfo <- generateRegistrationInfo + verbosity pkg lib lbi clbi inplace distPref + + -- Three different modes: + case () of + _ | modeGenerateRegFile -> writeRegistrationFile installedPkgInfo + | modeGenerateRegScript -> writeRegisterScript installedPkgInfo + | otherwise -> registerPackage verbosity + installedPkgInfo pkg lbi inplace packageDbs + + where + modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) + regFile = fromMaybe (display (packageId pkg) <.> "conf") + (fromFlag (regGenPkgConf regFlags)) + + modeGenerateRegScript = fromFlag (regGenScript regFlags) + + inplace = fromFlag (regInPlace regFlags) + -- FIXME: there's really no guarantee this will work. + -- registering into a totally different db stack can + -- fail if dependencies cannot be satisfied. + packageDbs = nub $ withPackageDB lbi + ++ maybeToList (flagToMaybe (regPackageDB regFlags)) + distPref = fromFlag (regDistPref regFlags) + verbosity = fromFlag (regVerbosity regFlags) + + writeRegistrationFile installedPkgInfo = do + notice verbosity ("Creating package registration file: " ++ regFile) + writeUTF8File regFile (showInstalledPackageInfo installedPkgInfo) + + writeRegisterScript installedPkgInfo = + case compilerFlavor (compiler lbi) of + GHC -> do (ghcPkg, _) <- requireProgram verbosity ghcPkgProgram (withPrograms lbi) + writeHcPkgRegisterScript verbosity installedPkgInfo ghcPkg packageDbs + LHC -> do (lhcPkg, _) <- requireProgram verbosity lhcPkgProgram (withPrograms lbi) + writeHcPkgRegisterScript verbosity installedPkgInfo lhcPkg packageDbs + Hugs -> notice verbosity "Registration scripts not needed for hugs" + JHC -> notice verbosity "Registration scripts not needed for jhc" + NHC -> notice verbosity "Registration scripts not needed for nhc98" + UHC -> notice verbosity "Registration scripts not needed for uhc" + _ -> die "Registration scripts are not implemented for this compiler" + +register _ _ regFlags = notice verbosity "No package to register" + where + verbosity = fromFlag (regVerbosity regFlags) + + +generateRegistrationInfo :: Verbosity + -> PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Bool + -> FilePath + -> IO InstalledPackageInfo +generateRegistrationInfo verbosity pkg lib lbi clbi inplace distPref = do + --TODO: eliminate pwd! + pwd <- getCurrentDirectory + + --TODO: the method of setting the InstalledPackageId is compiler specific + -- this aspect should be delegated to a per-compiler helper. + let comp = compiler lbi + ipid <- + case compilerFlavor comp of + GHC | compilerVersion comp >= Version [6,11] [] -> do + s <- GHC.libAbiHash verbosity pkg lbi lib clbi + return (InstalledPackageId (display (packageId pkg) ++ '-':s)) + _other -> do + return (InstalledPackageId (display (packageId pkg))) + + let installedPkgInfo + | inplace = inplaceInstalledPackageInfo pwd distPref + pkg lib lbi clbi + | otherwise = absoluteInstalledPackageInfo + pkg lib lbi clbi + + return installedPkgInfo{ IPI.installedPackageId = ipid } + + +registerPackage :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs = do + setupMessage verbosity "Registering" (packageId pkg) + case compilerFlavor (compiler lbi) of + GHC -> GHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs + LHC -> LHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs + Hugs -> Hugs.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs + UHC -> UHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs + JHC -> notice verbosity "Registering for jhc (nothing to do)" + NHC -> notice verbosity "Registering for nhc98 (nothing to do)" + _ -> die "Registering is not implemented for this compiler" + + +writeHcPkgRegisterScript :: Verbosity + -> InstalledPackageInfo + -> ConfiguredProgram + -> PackageDBStack + -> IO () +writeHcPkgRegisterScript verbosity installedPkgInfo hcPkg packageDbs = do + let invocation = HcPkg.reregisterInvocation hcPkg Verbosity.normal + packageDbs (Right installedPkgInfo) + regScript = invocationAsSystemScript buildOS invocation + + notice verbosity ("Creating package registration script: " ++ regScriptFileName) + writeUTF8File regScriptFileName regScript + setFileExecutable regScriptFileName + +regScriptFileName :: FilePath +regScriptFileName = case buildOS of + Windows -> "register.bat" + _ -> "register.sh" + + +-- ----------------------------------------------------------------------------- +-- Making the InstalledPackageInfo + +-- | Construct 'InstalledPackageInfo' for a library in a package, given a set +-- of installation directories. +-- +generalInstalledPackageInfo + :: ([FilePath] -> [FilePath]) -- ^ Translate relative include dir paths to + -- absolute paths. + -> PackageDescription + -> Library + -> ComponentLocalBuildInfo + -> InstallDirs FilePath + -> InstalledPackageInfo +generalInstalledPackageInfo adjustRelIncDirs pkg lib clbi installDirs = + InstalledPackageInfo { + --TODO: do not open-code this conversion from PackageId to InstalledPackageId + IPI.installedPackageId = InstalledPackageId (display (packageId pkg)), + IPI.sourcePackageId = packageId pkg, + IPI.license = license pkg, + IPI.copyright = copyright pkg, + IPI.maintainer = maintainer pkg, + IPI.author = author pkg, + IPI.stability = stability pkg, + IPI.homepage = homepage pkg, + IPI.pkgUrl = pkgUrl pkg, + IPI.synopsis = synopsis pkg, + IPI.description = description pkg, + IPI.category = category pkg, + IPI.exposed = libExposed lib, + IPI.exposedModules = exposedModules lib, + IPI.hiddenModules = otherModules bi, + IPI.trusted = False, + IPI.importDirs = [ libdir installDirs | hasModules ], + IPI.libraryDirs = if hasLibrary + then libdir installDirs : extraLibDirs bi + else extraLibDirs bi, + IPI.hsLibraries = [ "HS" ++ display (packageId pkg) | hasLibrary ], + IPI.extraLibraries = extraLibs bi, + IPI.extraGHCiLibraries = [], + IPI.includeDirs = absinc ++ adjustRelIncDirs relinc, + IPI.includes = includes bi, + IPI.depends = map fst (componentPackageDeps clbi), + IPI.hugsOptions = hcOptions Hugs bi, + IPI.ccOptions = [], -- Note. NOT ccOptions bi! + -- We don't want cc-options to be propagated + -- to C compilations in other packages. + IPI.ldOptions = ldOptions bi, + IPI.frameworkDirs = [], + IPI.frameworks = frameworks bi, + IPI.haddockInterfaces = [haddockdir installDirs haddockName pkg], + IPI.haddockHTMLs = [htmldir installDirs] + } + where + bi = libBuildInfo lib + (absinc, relinc) = partition isAbsolute (includeDirs bi) + hasModules = not $ null (exposedModules lib) + && null (otherModules bi) + hasLibrary = hasModules || not (null (cSources bi)) + + +-- | Construct 'InstalledPackageInfo' for a library that is inplace in the +-- build tree. +-- +-- This function knows about the layout of inplace packages. +-- +inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree + -> FilePath -- ^ location of the dist tree + -> PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstalledPackageInfo +inplaceInstalledPackageInfo inplaceDir distPref pkg lib lbi clbi = + generalInstalledPackageInfo adjustReativeIncludeDirs pkg lib clbi installDirs + where + adjustReativeIncludeDirs = map (inplaceDir ) + installDirs = + (absoluteInstallDirs pkg lbi NoCopyDest) { + libdir = inplaceDir buildDir lbi, + datadir = inplaceDir, + datasubdir = distPref, + docdir = inplaceDocdir, + htmldir = inplaceHtmldir, + haddockdir = inplaceHtmldir + } + inplaceDocdir = inplaceDir distPref "doc" + inplaceHtmldir = inplaceDocdir "html" display (packageName pkg) + + +-- | Construct 'InstalledPackageInfo' for the final install location of a +-- library package. +-- +-- This function knows about the layout of installed packages. +-- +absoluteInstalledPackageInfo :: PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstalledPackageInfo +absoluteInstalledPackageInfo pkg lib lbi clbi = + generalInstalledPackageInfo adjustReativeIncludeDirs pkg lib clbi installDirs + where + -- For installed packages we install all include files into one dir, + -- whereas in the build tree they may live in multiple local dirs. + adjustReativeIncludeDirs _ + | null (installIncludes bi) = [] + | otherwise = [includedir installDirs] + bi = libBuildInfo lib + installDirs = absoluteInstallDirs pkg lbi NoCopyDest + +-- ----------------------------------------------------------------------------- +-- Unregistration + +unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () +unregister pkg lbi regFlags = do + let pkgid = packageId pkg + genScript = fromFlag (regGenScript regFlags) + verbosity = fromFlag (regVerbosity regFlags) + packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi)) + (regPackageDB regFlags) + installDirs = absoluteInstallDirs pkg lbi NoCopyDest + setupMessage verbosity "Unregistering" pkgid + case compilerFlavor (compiler lbi) of + GHC -> + let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi) + invocation = HcPkg.unregisterInvocation ghcPkg Verbosity.normal + packageDb pkgid + in if genScript + then writeFileAtomic unregScriptFileName + (invocationAsSystemScript buildOS invocation) + else runProgramInvocation verbosity invocation + Hugs -> do + _ <- tryIO $ removeDirectoryRecursive (libdir installDirs) + return () + NHC -> do + _ <- tryIO $ removeDirectoryRecursive (libdir installDirs) + return () + _ -> + die ("only unregistering with GHC and Hugs is implemented") + +unregScriptFileName :: FilePath +unregScriptFileName = case buildOS of + Windows -> "unregister.bat" + _ -> "unregister.sh" diff --git a/cabal/cabal/Distribution/Simple/Setup.hs b/cabal/cabal/Distribution/Simple/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Setup.hs @@ -0,0 +1,1584 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Setup +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is a big module, but not very complicated. The code is very regular +-- and repetitive. It defines the command line interface for all the Cabal +-- commands. For each command (like @configure@, @build@ etc) it defines a type +-- that holds all the flags, the default set of flags and a 'CommandUI' that +-- maps command line flags to and from the corresponding flags type. +-- +-- All the flags types are instances of 'Monoid', see +-- +-- for an explanation. +-- +-- The types defined here get used in the front end and especially in +-- @cabal-install@ which has to do quite a bit of manipulating sets of command +-- line flags. +-- +-- This is actually relatively nice, it works quite well. The main change it +-- needs is to unify it with the code for managing sets of fields that can be +-- read and written from files. This would allow us to save configure flags in +-- config files. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.Setup ( + + GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand, + ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand, + CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand, + InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand, + HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand, + HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand, + BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand, + buildVerbose, + CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand, + RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand, + unregisterCommand, + SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand, + TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand, + TestShowDetails(..), + CopyDest(..), + configureArgs, configureOptions, configureCCompiler, configureLinker, + installDirsOptions, + + defaultDistPref, + + Flag(..), + toFlag, + fromFlag, + fromFlagOrDefault, + flagToMaybe, + flagToList, + boolOpt, boolOpt', trueArg, falseArg, optionVerbosity ) where + +import Distribution.Compiler () +import Distribution.ReadE +import Distribution.Text + ( Text(..), display ) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Distribution.Package ( Dependency(..) ) +import Distribution.PackageDescription + ( FlagName(..), FlagAssignment ) +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import qualified Distribution.Simple.Command as Command +import Distribution.Simple.Compiler + ( CompilerFlavor(..), defaultCompilerFlavor, PackageDB(..) + , OptimisationLevel(..), flagToOptimisationLevel ) +import Distribution.Simple.Utils + ( wrapLine, lowercase, intercalate ) +import Distribution.Simple.Program (Program(..), ProgramConfiguration, + requireProgram, + programInvocation, progInvokePath, progInvokeArgs, + knownPrograms, + addKnownProgram, emptyProgramConfiguration, + haddockProgram, ghcProgram, gccProgram, ldProgram) +import Distribution.Simple.InstallDirs + ( InstallDirs(..), CopyDest(..), + PathTemplate, toPathTemplate, fromPathTemplate ) +import Distribution.Verbosity + +import Data.List ( sort ) +import Data.Char ( isSpace, isAlpha ) +import Data.Monoid ( Monoid(..) ) + +-- FIXME Not sure where this should live +defaultDistPref :: FilePath +defaultDistPref = "dist" + +-- ------------------------------------------------------------ +-- * Flag type +-- ------------------------------------------------------------ + +-- | All flags are monoids, they come in two flavours: +-- +-- 1. list flags eg +-- +-- > --ghc-option=foo --ghc-option=bar +-- +-- gives us all the values ["foo", "bar"] +-- +-- 2. singular value flags, eg: +-- +-- > --enable-foo --disable-foo +-- +-- gives us Just False +-- So this Flag type is for the latter singular kind of flag. +-- Its monoid instance gives us the behaviour where it starts out as +-- 'NoFlag' and later flags override earlier ones. +-- +data Flag a = Flag a | NoFlag deriving (Show, Read, Eq) + +instance Functor Flag where + fmap f (Flag x) = Flag (f x) + fmap _ NoFlag = NoFlag + +instance Monoid (Flag a) where + mempty = NoFlag + _ `mappend` f@(Flag _) = f + f `mappend` NoFlag = f + +instance Bounded a => Bounded (Flag a) where + minBound = toFlag minBound + maxBound = toFlag maxBound + +instance Enum a => Enum (Flag a) where + fromEnum = fromEnum . fromFlag + toEnum = toFlag . toEnum + enumFrom (Flag a) = map toFlag . enumFrom $ a + enumFrom _ = [] + enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b + enumFromThen _ _ = [] + enumFromTo (Flag a) (Flag b) = toFlag `map` enumFromTo a b + enumFromTo _ _ = [] + enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c + enumFromThenTo _ _ _ = [] + +toFlag :: a -> Flag a +toFlag = Flag + +fromFlag :: Flag a -> a +fromFlag (Flag x) = x +fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault" + +fromFlagOrDefault :: a -> Flag a -> a +fromFlagOrDefault _ (Flag x) = x +fromFlagOrDefault def NoFlag = def + +flagToMaybe :: Flag a -> Maybe a +flagToMaybe (Flag x) = Just x +flagToMaybe NoFlag = Nothing + +flagToList :: Flag a -> [a] +flagToList (Flag x) = [x] +flagToList NoFlag = [] + +-- ------------------------------------------------------------ +-- * Global flags +-- ------------------------------------------------------------ + +-- In fact since individual flags types are monoids and these are just sets of +-- flags then they are also monoids pointwise. This turns out to be really +-- useful. The mempty is the set of empty flags and mappend allows us to +-- override specific flags. For example we can start with default flags and +-- override with the ones we get from a file or the command line, or both. + +-- | Flags that apply at the top level, not to any sub-command. +data GlobalFlags = GlobalFlags { + globalVersion :: Flag Bool, + globalNumericVersion :: Flag Bool + } + +defaultGlobalFlags :: GlobalFlags +defaultGlobalFlags = GlobalFlags { + globalVersion = Flag False, + globalNumericVersion = Flag False + } + +globalCommand :: CommandUI GlobalFlags +globalCommand = CommandUI { + commandName = "", + commandSynopsis = "", + commandUsage = \_ -> + "This Setup program uses the Haskell Cabal Infrastructure.\n" + ++ "See http://www.haskell.org/cabal/ for more information.\n", + commandDescription = Just $ \pname -> + "For more information about a command use\n" + ++ " " ++ pname ++ " COMMAND --help\n\n" + ++ "Typical steps for installing Cabal packages:\n" + ++ concat [ " " ++ pname ++ " " ++ x ++ "\n" + | x <- ["configure", "build", "install"]], + commandDefaultFlags = defaultGlobalFlags, + commandOptions = \_ -> + [option ['V'] ["version"] + "Print version information" + globalVersion (\v flags -> flags { globalVersion = v }) + trueArg + ,option [] ["numeric-version"] + "Print just the version number" + globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) + trueArg + ] + } + +emptyGlobalFlags :: GlobalFlags +emptyGlobalFlags = mempty + +instance Monoid GlobalFlags where + mempty = GlobalFlags { + globalVersion = mempty, + globalNumericVersion = mempty + } + mappend a b = GlobalFlags { + globalVersion = combine globalVersion, + globalNumericVersion = combine globalNumericVersion + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Config flags +-- ------------------------------------------------------------ + +-- | Flags to @configure@ command +data ConfigFlags = ConfigFlags { + --FIXME: the configPrograms is only here to pass info through to configure + -- because the type of configure is constrained by the UserHooks. + -- when we change UserHooks next we should pass the initial + -- ProgramConfiguration directly and not via ConfigFlags + configPrograms :: ProgramConfiguration, -- ^All programs that cabal may run + + configProgramPaths :: [(String, FilePath)], -- ^user specifed programs paths + configProgramArgs :: [(String, [String])], -- ^user specifed programs args + configHcFlavor :: Flag CompilerFlavor, -- ^The \"flavor\" of the compiler, sugh as GHC or Hugs. + configHcPath :: Flag FilePath, -- ^given compiler location + configHcPkg :: Flag FilePath, -- ^given hc-pkg location + configVanillaLib :: Flag Bool, -- ^Enable vanilla library + configProfLib :: Flag Bool, -- ^Enable profiling in the library + configSharedLib :: Flag Bool, -- ^Build shared library + configDynExe :: Flag Bool, -- ^Enable dynamic linking of the executables. + configProfExe :: Flag Bool, -- ^Enable profiling in the executables. + configConfigureArgs :: [String], -- ^Extra arguments to @configure@ + configOptimization :: Flag OptimisationLevel, -- ^Enable optimization. + configProgPrefix :: Flag PathTemplate, -- ^Installed executable prefix. + configProgSuffix :: Flag PathTemplate, -- ^Installed executable suffix. + configInstallDirs :: InstallDirs (Flag PathTemplate), -- ^Installation paths + configScratchDir :: Flag FilePath, + configExtraLibDirs :: [FilePath], -- ^ path to search for extra libraries + configExtraIncludeDirs :: [FilePath], -- ^ path to search for header files + + configDistPref :: Flag FilePath, -- ^"dist" prefix + configVerbosity :: Flag Verbosity, -- ^verbosity level + configUserInstall :: Flag Bool, -- ^The --user\/--global flag + configPackageDB :: Flag PackageDB, -- ^Which package DB to use + configGHCiLib :: Flag Bool, -- ^Enable compiling library for GHCi + configSplitObjs :: Flag Bool, -- ^Enable -split-objs with GHC + configStripExes :: Flag Bool, -- ^Enable executable stripping + configConstraints :: [Dependency], -- ^Additional constraints for + -- dependencies + configConfigurationsFlags :: FlagAssignment, + configTests :: Flag Bool, -- ^Enable test suite compilation + configLibCoverage :: Flag Bool -- ^ Enable test suite program coverage + } + deriving (Read,Show) + +defaultConfigFlags :: ProgramConfiguration -> ConfigFlags +defaultConfigFlags progConf = emptyConfigFlags { + configPrograms = progConf, + configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor, + configVanillaLib = Flag True, + configProfLib = Flag False, + configSharedLib = Flag False, + configDynExe = Flag False, + configProfExe = Flag False, + configOptimization = Flag NormalOptimisation, + configProgPrefix = Flag (toPathTemplate ""), + configProgSuffix = Flag (toPathTemplate ""), + configDistPref = Flag defaultDistPref, + configVerbosity = Flag normal, + configUserInstall = Flag False, --TODO: reverse this + configGHCiLib = Flag True, + configSplitObjs = Flag False, -- takes longer, so turn off by default + configStripExes = Flag True, + configTests = Flag False, + configLibCoverage = Flag False + } + +configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags +configureCommand progConf = makeCommand name shortDesc longDesc defaultFlags options + where + name = "configure" + shortDesc = "Prepare to build the package." + longDesc = Just (\_ -> programFlagsDescription progConf) + defaultFlags = defaultConfigFlags progConf + options showOrParseArgs = + configureOptions showOrParseArgs + ++ programConfigurationPaths progConf showOrParseArgs + configProgramPaths (\v fs -> fs { configProgramPaths = v }) + ++ programConfigurationOptions progConf showOrParseArgs + configProgramArgs (\v fs -> fs { configProgramArgs = v }) + + +configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] +configureOptions showOrParseArgs = + [optionVerbosity configVerbosity (\v flags -> flags { configVerbosity = v }) + ,optionDistPref + configDistPref (\d flags -> flags { configDistPref = d }) + showOrParseArgs + + ,option [] ["compiler"] "compiler" + configHcFlavor (\v flags -> flags { configHcFlavor = v }) + (choiceOpt [ (Flag GHC, ("g", ["ghc"]), "compile with GHC") + , (Flag NHC, ([] , ["nhc98"]), "compile with NHC") + , (Flag JHC, ([] , ["jhc"]), "compile with JHC") + , (Flag LHC, ([] , ["lhc"]), "compile with LHC") + , (Flag Hugs,([] , ["hugs"]), "compile with Hugs") + , (Flag UHC, ([] , ["uhc"]), "compile with UHC")]) + + ,option "w" ["with-compiler"] + "give the path to a particular compiler" + configHcPath (\v flags -> flags { configHcPath = v }) + (reqArgFlag "PATH") + + ,option "" ["with-hc-pkg"] + "give the path to the package tool" + configHcPkg (\v flags -> flags { configHcPkg = v }) + (reqArgFlag "PATH") + ] + ++ map liftInstallDirs installDirsOptions + ++ [option "b" ["scratchdir"] + "directory to receive the built package (hugs-only)" + configScratchDir (\v flags -> flags { configScratchDir = v }) + (reqArgFlag "DIR") + --TODO: eliminate scratchdir flag + + ,option "" ["program-prefix"] + "prefix to be applied to installed executables" + configProgPrefix + (\v flags -> flags { configProgPrefix = v }) + (reqPathTemplateArgFlag "PREFIX") + + ,option "" ["program-suffix"] + "suffix to be applied to installed executables" + configProgSuffix (\v flags -> flags { configProgSuffix = v } ) + (reqPathTemplateArgFlag "SUFFIX") + + ,option "" ["library-vanilla"] + "Vanilla libraries" + configVanillaLib (\v flags -> flags { configVanillaLib = v }) + (boolOpt [] []) + + ,option "p" ["library-profiling"] + "Library profiling" + configProfLib (\v flags -> flags { configProfLib = v }) + (boolOpt "p" []) + + ,option "" ["shared"] + "Shared library" + configSharedLib (\v flags -> flags { configSharedLib = v }) + (boolOpt [] []) + + ,option "" ["executable-dynamic"] + "Executable dynamic linking" + configDynExe (\v flags -> flags { configDynExe = v }) + (boolOpt [] []) + + ,option "" ["executable-profiling"] + "Executable profiling" + configProfExe (\v flags -> flags { configProfExe = v }) + (boolOpt [] []) + + ,multiOption "optimization" + configOptimization (\v flags -> flags { configOptimization = v }) + [optArg' "n" (Flag . flagToOptimisationLevel) + (\f -> case f of + Flag NoOptimisation -> [] + Flag NormalOptimisation -> [Nothing] + Flag MaximumOptimisation -> [Just "2"] + _ -> []) + "O" ["enable-optimization","enable-optimisation"] + "Build with optimization (n is 0--2, default is 1)", + noArg (Flag NoOptimisation) [] + ["disable-optimization","disable-optimisation"] + "Build without optimization" + ] + + ,option "" ["library-for-ghci"] + "compile library for use with GHCi" + configGHCiLib (\v flags -> flags { configGHCiLib = v }) + (boolOpt [] []) + + ,option "" ["split-objs"] + "split library into smaller objects to reduce binary sizes (GHC 6.6+)" + configSplitObjs (\v flags -> flags { configSplitObjs = v }) + (boolOpt [] []) + + ,option "" ["executable-stripping"] + "strip executables upon installation to reduce binary sizes" + configStripExes (\v flags -> flags { configStripExes = v }) + (boolOpt [] []) + + ,option "" ["configure-option"] + "Extra option for configure" + configConfigureArgs (\v flags -> flags { configConfigureArgs = v }) + (reqArg' "OPT" (\x -> [x]) id) + + ,option "" ["user-install"] + "doing a per-user installation" + configUserInstall (\v flags -> flags { configUserInstall = v }) + (boolOpt' ([],["user"]) ([], ["global"])) + + ,option "" ["package-db"] + "Use a specific package database (to satisfy dependencies and register in)" + configPackageDB (\v flags -> flags { configPackageDB = v }) + (reqArg' "PATH" (Flag . SpecificPackageDB) + (\f -> case f of + Flag (SpecificPackageDB db) -> [db] + _ -> [])) + + ,option "f" ["flags"] + "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false." + configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v }) + (reqArg' "FLAGS" readFlagList showFlagList) + + ,option "" ["extra-include-dirs"] + "A list of directories to search for header files" + configExtraIncludeDirs (\v flags -> flags {configExtraIncludeDirs = v}) + (reqArg' "PATH" (\x -> [x]) id) + + ,option "" ["extra-lib-dirs"] + "A list of directories to search for external libraries" + configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v}) + (reqArg' "PATH" (\x -> [x]) id) + ,option "" ["constraint"] + "A list of additional constraints on the dependencies." + configConstraints (\v flags -> flags { configConstraints = v}) + (reqArg "DEPENDENCY" + (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse)) + (map (\x -> display x))) + ,option "" ["tests"] + "dependency checking and compilation for test suites listed in the package description file." + configTests (\v flags -> flags { configTests = v }) + (boolOpt [] []) + ,option "" ["library-coverage"] + "build library and test suites with Haskell Program Coverage enabled. (GHC only)" + configLibCoverage (\v flags -> flags { configLibCoverage = v }) + (boolOpt [] []) + ] + where + readFlagList :: String -> FlagAssignment + readFlagList = map tagWithValue . words + where tagWithValue ('-':fname) = (FlagName (lowercase fname), False) + tagWithValue fname = (FlagName (lowercase fname), True) + + showFlagList :: FlagAssignment -> [String] + showFlagList fs = [ if not set then '-':fname else fname + | (FlagName fname, set) <- fs] + + liftInstallDirs = + liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v }) + + reqPathTemplateArgFlag title _sf _lf d get set = + reqArgFlag title _sf _lf d + (fmap fromPathTemplate . get) (set . fmap toPathTemplate) + +installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] +installDirsOptions = + [ option "" ["prefix"] + "bake this prefix in preparation of installation" + prefix (\v flags -> flags { prefix = v }) + installDirArg + + , option "" ["bindir"] + "installation directory for executables" + bindir (\v flags -> flags { bindir = v }) + installDirArg + + , option "" ["libdir"] + "installation directory for libraries" + libdir (\v flags -> flags { libdir = v }) + installDirArg + + , option "" ["libsubdir"] + "subdirectory of libdir in which libs are installed" + libsubdir (\v flags -> flags { libsubdir = v }) + installDirArg + + , option "" ["libexecdir"] + "installation directory for program executables" + libexecdir (\v flags -> flags { libexecdir = v }) + installDirArg + + , option "" ["datadir"] + "installation directory for read-only data" + datadir (\v flags -> flags { datadir = v }) + installDirArg + + , option "" ["datasubdir"] + "subdirectory of datadir in which data files are installed" + datasubdir (\v flags -> flags { datasubdir = v }) + installDirArg + + , option "" ["docdir"] + "installation directory for documentation" + docdir (\v flags -> flags { docdir = v }) + installDirArg + + , option "" ["htmldir"] + "installation directory for HTML documentation" + htmldir (\v flags -> flags { htmldir = v }) + installDirArg + + , option "" ["haddockdir"] + "installation directory for haddock interfaces" + haddockdir (\v flags -> flags { haddockdir = v }) + installDirArg + ] + where + installDirArg _sf _lf d get set = + reqArgFlag "DIR" _sf _lf d + (fmap fromPathTemplate . get) (set . fmap toPathTemplate) + +emptyConfigFlags :: ConfigFlags +emptyConfigFlags = mempty + +instance Monoid ConfigFlags where + mempty = ConfigFlags { + configPrograms = error "FIXME: remove configPrograms", + configProgramPaths = mempty, + configProgramArgs = mempty, + configHcFlavor = mempty, + configHcPath = mempty, + configHcPkg = mempty, + configVanillaLib = mempty, + configProfLib = mempty, + configSharedLib = mempty, + configDynExe = mempty, + configProfExe = mempty, + configConfigureArgs = mempty, + configOptimization = mempty, + configProgPrefix = mempty, + configProgSuffix = mempty, + configInstallDirs = mempty, + configScratchDir = mempty, + configDistPref = mempty, + configVerbosity = mempty, + configUserInstall = mempty, + configPackageDB = mempty, + configGHCiLib = mempty, + configSplitObjs = mempty, + configStripExes = mempty, + configExtraLibDirs = mempty, + configConstraints = mempty, + configExtraIncludeDirs = mempty, + configConfigurationsFlags = mempty, + configTests = mempty, + configLibCoverage = mempty + } + mappend a b = ConfigFlags { + configPrograms = configPrograms b, + configProgramPaths = combine configProgramPaths, + configProgramArgs = combine configProgramArgs, + configHcFlavor = combine configHcFlavor, + configHcPath = combine configHcPath, + configHcPkg = combine configHcPkg, + configVanillaLib = combine configVanillaLib, + configProfLib = combine configProfLib, + configSharedLib = combine configSharedLib, + configDynExe = combine configDynExe, + configProfExe = combine configProfExe, + configConfigureArgs = combine configConfigureArgs, + configOptimization = combine configOptimization, + configProgPrefix = combine configProgPrefix, + configProgSuffix = combine configProgSuffix, + configInstallDirs = combine configInstallDirs, + configScratchDir = combine configScratchDir, + configDistPref = combine configDistPref, + configVerbosity = combine configVerbosity, + configUserInstall = combine configUserInstall, + configPackageDB = combine configPackageDB, + configGHCiLib = combine configGHCiLib, + configSplitObjs = combine configSplitObjs, + configStripExes = combine configStripExes, + configExtraLibDirs = combine configExtraLibDirs, + configConstraints = combine configConstraints, + configExtraIncludeDirs = combine configExtraIncludeDirs, + configConfigurationsFlags = combine configConfigurationsFlags, + configTests = combine configTests, + configLibCoverage = combine configLibCoverage + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Copy flags +-- ------------------------------------------------------------ + +-- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity) +data CopyFlags = CopyFlags { + copyDest :: Flag CopyDest, + copyDistPref :: Flag FilePath, + copyVerbosity :: Flag Verbosity + } + deriving Show + +defaultCopyFlags :: CopyFlags +defaultCopyFlags = CopyFlags { + copyDest = Flag NoCopyDest, + copyDistPref = Flag defaultDistPref, + copyVerbosity = Flag normal + } + +copyCommand :: CommandUI CopyFlags +copyCommand = makeCommand name shortDesc longDesc defaultCopyFlags options + where + name = "copy" + shortDesc = "Copy the files into the install locations." + longDesc = Just $ \_ -> + "Does not call register, and allows a prefix at install time\n" + ++ "Without the --destdir flag, configure determines location.\n" + options showOrParseArgs = + [optionVerbosity copyVerbosity (\v flags -> flags { copyVerbosity = v }) + + ,optionDistPref + copyDistPref (\d flags -> flags { copyDistPref = d }) + showOrParseArgs + + ,option "" ["destdir"] + "directory to copy files to, prepended to installation directories" + copyDest (\v flags -> flags { copyDest = v }) + (reqArg "DIR" (succeedReadE (Flag . CopyTo)) + (\f -> case f of Flag (CopyTo p) -> [p]; _ -> [])) + ] + +emptyCopyFlags :: CopyFlags +emptyCopyFlags = mempty + +instance Monoid CopyFlags where + mempty = CopyFlags { + copyDest = mempty, + copyDistPref = mempty, + copyVerbosity = mempty + } + mappend a b = CopyFlags { + copyDest = combine copyDest, + copyDistPref = combine copyDistPref, + copyVerbosity = combine copyVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Install flags +-- ------------------------------------------------------------ + +-- | Flags to @install@: (package db, verbosity) +data InstallFlags = InstallFlags { + installPackageDB :: Flag PackageDB, + installDistPref :: Flag FilePath, + installUseWrapper :: Flag Bool, + installInPlace :: Flag Bool, + installVerbosity :: Flag Verbosity + } + deriving Show + +defaultInstallFlags :: InstallFlags +defaultInstallFlags = InstallFlags { + installPackageDB = NoFlag, + installDistPref = Flag defaultDistPref, + installUseWrapper = Flag False, + installInPlace = Flag False, + installVerbosity = Flag normal + } + +installCommand :: CommandUI InstallFlags +installCommand = makeCommand name shortDesc longDesc defaultInstallFlags options + where + name = "install" + shortDesc = "Copy the files into the install locations. Run register." + longDesc = Just $ \_ -> + "Unlike the copy command, install calls the register command.\n" + ++ "If you want to install into a location that is not what was\n" + ++ "specified in the configure step, use the copy command.\n" + options showOrParseArgs = + [optionVerbosity installVerbosity (\v flags -> flags { installVerbosity = v }) + ,optionDistPref + installDistPref (\d flags -> flags { installDistPref = d }) + showOrParseArgs + + ,option "" ["inplace"] + "install the package in the install subdirectory of the dist prefix, so it can be used without being installed" + installInPlace (\v flags -> flags { installInPlace = v }) + trueArg + + ,option "" ["shell-wrappers"] + "using shell script wrappers around executables" + installUseWrapper (\v flags -> flags { installUseWrapper = v }) + (boolOpt [] []) + + ,option "" ["package-db"] "" + installPackageDB (\v flags -> flags { installPackageDB = v }) + (choiceOpt [ (Flag UserPackageDB, ([],["user"]), + "upon configuration register this package in the user's local package database") + , (Flag GlobalPackageDB, ([],["global"]), + "(default) upon configuration register this package in the system-wide package database")]) + ] + +emptyInstallFlags :: InstallFlags +emptyInstallFlags = mempty + +instance Monoid InstallFlags where + mempty = InstallFlags{ + installPackageDB = mempty, + installDistPref = mempty, + installUseWrapper = mempty, + installInPlace = mempty, + installVerbosity = mempty + } + mappend a b = InstallFlags{ + installPackageDB = combine installPackageDB, + installDistPref = combine installDistPref, + installUseWrapper = combine installUseWrapper, + installInPlace = combine installInPlace, + installVerbosity = combine installVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * SDist flags +-- ------------------------------------------------------------ + +-- | Flags to @sdist@: (snapshot, verbosity) +data SDistFlags = SDistFlags { + sDistSnapshot :: Flag Bool, + sDistDirectory :: Flag FilePath, + sDistDistPref :: Flag FilePath, + sDistVerbosity :: Flag Verbosity + } + deriving Show + +defaultSDistFlags :: SDistFlags +defaultSDistFlags = SDistFlags { + sDistSnapshot = Flag False, + sDistDirectory = mempty, + sDistDistPref = Flag defaultDistPref, + sDistVerbosity = Flag normal + } + +sdistCommand :: CommandUI SDistFlags +sdistCommand = makeCommand name shortDesc longDesc defaultSDistFlags options + where + name = "sdist" + shortDesc = "Generate a source distribution file (.tar.gz)." + longDesc = Nothing + options showOrParseArgs = + [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v }) + ,optionDistPref + sDistDistPref (\d flags -> flags { sDistDistPref = d }) + showOrParseArgs + + ,option "" ["snapshot"] + "Produce a snapshot source distribution" + sDistSnapshot (\v flags -> flags { sDistSnapshot = v }) + trueArg + + ,option "" ["output-directory"] + "Generate a source distribution in the given directory" + sDistDirectory (\v flags -> flags { sDistDirectory = v }) + (reqArgFlag "DIR") + ] + +emptySDistFlags :: SDistFlags +emptySDistFlags = mempty + +instance Monoid SDistFlags where + mempty = SDistFlags { + sDistSnapshot = mempty, + sDistDirectory = mempty, + sDistDistPref = mempty, + sDistVerbosity = mempty + } + mappend a b = SDistFlags { + sDistSnapshot = combine sDistSnapshot, + sDistDirectory = combine sDistDirectory, + sDistDistPref = combine sDistDistPref, + sDistVerbosity = combine sDistVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Register flags +-- ------------------------------------------------------------ + +-- | Flags to @register@ and @unregister@: (user package, gen-script, +-- in-place, verbosity) +data RegisterFlags = RegisterFlags { + regPackageDB :: Flag PackageDB, + regGenScript :: Flag Bool, + regGenPkgConf :: Flag (Maybe FilePath), + regInPlace :: Flag Bool, + regDistPref :: Flag FilePath, + regVerbosity :: Flag Verbosity + } + deriving Show + +defaultRegisterFlags :: RegisterFlags +defaultRegisterFlags = RegisterFlags { + regPackageDB = NoFlag, + regGenScript = Flag False, + regGenPkgConf = NoFlag, + regInPlace = Flag False, + regDistPref = Flag defaultDistPref, + regVerbosity = Flag normal + } + +registerCommand :: CommandUI RegisterFlags +registerCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options + where + name = "register" + shortDesc = "Register this package with the compiler." + longDesc = Nothing + options showOrParseArgs = + [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) + ,optionDistPref + regDistPref (\d flags -> flags { regDistPref = d }) + showOrParseArgs + + ,option "" ["packageDB"] "" + regPackageDB (\v flags -> flags { regPackageDB = v }) + (choiceOpt [ (Flag UserPackageDB, ([],["user"]), + "upon registration, register this package in the user's local package database") + , (Flag GlobalPackageDB, ([],["global"]), + "(default)upon registration, register this package in the system-wide package database")]) + + ,option "" ["inplace"] + "register the package in the build location, so it can be used without being installed" + regInPlace (\v flags -> flags { regInPlace = v }) + trueArg + + ,option "" ["gen-script"] + "instead of registering, generate a script to register later" + regGenScript (\v flags -> flags { regGenScript = v }) + trueArg + + ,option "" ["gen-pkg-config"] + "instead of registering, generate a package registration file" + regGenPkgConf (\v flags -> flags { regGenPkgConf = v }) + (optArg' "PKG" Flag flagToList) + ] + +unregisterCommand :: CommandUI RegisterFlags +unregisterCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options + where + name = "unregister" + shortDesc = "Unregister this package with the compiler." + longDesc = Nothing + options showOrParseArgs = + [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) + ,optionDistPref + regDistPref (\d flags -> flags { regDistPref = d }) + showOrParseArgs + + ,option "" ["user"] "" + regPackageDB (\v flags -> flags { regPackageDB = v }) + (choiceOpt [ (Flag UserPackageDB, ([],["user"]), + "unregister this package in the user's local package database") + , (Flag GlobalPackageDB, ([],["global"]), + "(default) unregister this package in the system-wide package database")]) + + ,option "" ["gen-script"] + "Instead of performing the unregister command, generate a script to unregister later" + regGenScript (\v flags -> flags { regGenScript = v }) + trueArg + ] + +emptyRegisterFlags :: RegisterFlags +emptyRegisterFlags = mempty + +instance Monoid RegisterFlags where + mempty = RegisterFlags { + regPackageDB = mempty, + regGenScript = mempty, + regGenPkgConf = mempty, + regInPlace = mempty, + regDistPref = mempty, + regVerbosity = mempty + } + mappend a b = RegisterFlags { + regPackageDB = combine regPackageDB, + regGenScript = combine regGenScript, + regGenPkgConf = combine regGenPkgConf, + regInPlace = combine regInPlace, + regDistPref = combine regDistPref, + regVerbosity = combine regVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * HsColour flags +-- ------------------------------------------------------------ + +data HscolourFlags = HscolourFlags { + hscolourCSS :: Flag FilePath, + hscolourExecutables :: Flag Bool, + hscolourDistPref :: Flag FilePath, + hscolourVerbosity :: Flag Verbosity + } + deriving Show + +emptyHscolourFlags :: HscolourFlags +emptyHscolourFlags = mempty + +defaultHscolourFlags :: HscolourFlags +defaultHscolourFlags = HscolourFlags { + hscolourCSS = NoFlag, + hscolourExecutables = Flag False, + hscolourDistPref = Flag defaultDistPref, + hscolourVerbosity = Flag normal + } + +instance Monoid HscolourFlags where + mempty = HscolourFlags { + hscolourCSS = mempty, + hscolourExecutables = mempty, + hscolourDistPref = mempty, + hscolourVerbosity = mempty + } + mappend a b = HscolourFlags { + hscolourCSS = combine hscolourCSS, + hscolourExecutables = combine hscolourExecutables, + hscolourDistPref = combine hscolourDistPref, + hscolourVerbosity = combine hscolourVerbosity + } + where combine field = field a `mappend` field b + +hscolourCommand :: CommandUI HscolourFlags +hscolourCommand = makeCommand name shortDesc longDesc defaultHscolourFlags options + where + name = "hscolour" + shortDesc = "Generate HsColour colourised code, in HTML format." + longDesc = Just (\_ -> "Requires hscolour.\n") + options showOrParseArgs = + [optionVerbosity hscolourVerbosity (\v flags -> flags { hscolourVerbosity = v }) + ,optionDistPref + hscolourDistPref (\d flags -> flags { hscolourDistPref = d }) + showOrParseArgs + + ,option "" ["executables"] + "Run hscolour for Executables targets" + hscolourExecutables (\v flags -> flags { hscolourExecutables = v }) + trueArg + + ,option "" ["css"] + "Use a cascading style sheet" + hscolourCSS (\v flags -> flags { hscolourCSS = v }) + (reqArgFlag "PATH") + ] + +-- ------------------------------------------------------------ +-- * Haddock flags +-- ------------------------------------------------------------ + +data HaddockFlags = HaddockFlags { + haddockProgramPaths :: [(String, FilePath)], + haddockProgramArgs :: [(String, [String])], + haddockHoogle :: Flag Bool, + haddockHtml :: Flag Bool, + haddockHtmlLocation :: Flag String, + haddockExecutables :: Flag Bool, + haddockInternal :: Flag Bool, + haddockCss :: Flag FilePath, + haddockHscolour :: Flag Bool, + haddockHscolourCss :: Flag FilePath, + haddockDistPref :: Flag FilePath, + haddockVerbosity :: Flag Verbosity + } + deriving Show + +defaultHaddockFlags :: HaddockFlags +defaultHaddockFlags = HaddockFlags { + haddockProgramPaths = mempty, + haddockProgramArgs = [], + haddockHoogle = Flag False, + haddockHtml = Flag False, + haddockHtmlLocation = NoFlag, + haddockExecutables = Flag False, + haddockInternal = Flag False, + haddockCss = NoFlag, + haddockHscolour = Flag False, + haddockHscolourCss = NoFlag, + haddockDistPref = Flag defaultDistPref, + haddockVerbosity = Flag normal + } + +haddockCommand :: CommandUI HaddockFlags +haddockCommand = makeCommand name shortDesc longDesc defaultHaddockFlags options + where + name = "haddock" + shortDesc = "Generate Haddock HTML documentation." + longDesc = Just $ \_ -> "Requires the program haddock, either version 0.x or 2.x.\n" + options showOrParseArgs = + [optionVerbosity haddockVerbosity (\v flags -> flags { haddockVerbosity = v }) + ,optionDistPref + haddockDistPref (\d flags -> flags { haddockDistPref = d }) + showOrParseArgs + + ,option "" ["hoogle"] + "Generate a hoogle database" + haddockHoogle (\v flags -> flags { haddockHoogle = v }) + trueArg + + ,option "" ["html"] + "Generate HTML documentation (the default)" + haddockHtml (\v flags -> flags { haddockHtml = v }) + trueArg + + ,option "" ["html-location"] + "Location of HTML documentation for pre-requisite packages" + haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v }) + (reqArgFlag "URL") + + ,option "" ["executables"] + "Run haddock for Executables targets" + haddockExecutables (\v flags -> flags { haddockExecutables = v }) + trueArg + + ,option "" ["internal"] + "Run haddock for internal modules and include all symbols" + haddockInternal (\v flags -> flags { haddockInternal = v }) + trueArg + + ,option "" ["css"] + "Use PATH as the haddock stylesheet" + haddockCss (\v flags -> flags { haddockCss = v }) + (reqArgFlag "PATH") + + ,option "" ["hyperlink-source","hyperlink-sources"] + "Hyperlink the documentation to the source code (using HsColour)" + haddockHscolour (\v flags -> flags { haddockHscolour = v }) + trueArg + + ,option "" ["hscolour-css"] + "Use PATH as the HsColour stylesheet" + haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v }) + (reqArgFlag "PATH") + ] + ++ programConfigurationPaths progConf ParseArgs + haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v}) + ++ programConfigurationOptions progConf ParseArgs + haddockProgramArgs (\v flags -> flags { haddockProgramArgs = v}) + progConf = addKnownProgram haddockProgram + $ addKnownProgram ghcProgram + $ emptyProgramConfiguration + +emptyHaddockFlags :: HaddockFlags +emptyHaddockFlags = mempty + +instance Monoid HaddockFlags where + mempty = HaddockFlags { + haddockProgramPaths = mempty, + haddockProgramArgs = mempty, + haddockHoogle = mempty, + haddockHtml = mempty, + haddockHtmlLocation = mempty, + haddockExecutables = mempty, + haddockInternal = mempty, + haddockCss = mempty, + haddockHscolour = mempty, + haddockHscolourCss = mempty, + haddockDistPref = mempty, + haddockVerbosity = mempty + } + mappend a b = HaddockFlags { + haddockProgramPaths = combine haddockProgramPaths, + haddockProgramArgs = combine haddockProgramArgs, + haddockHoogle = combine haddockHoogle, + haddockHtml = combine haddockHoogle, + haddockHtmlLocation = combine haddockHtmlLocation, + haddockExecutables = combine haddockExecutables, + haddockInternal = combine haddockInternal, + haddockCss = combine haddockCss, + haddockHscolour = combine haddockHscolour, + haddockHscolourCss = combine haddockHscolourCss, + haddockDistPref = combine haddockDistPref, + haddockVerbosity = combine haddockVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Clean flags +-- ------------------------------------------------------------ + +data CleanFlags = CleanFlags { + cleanSaveConf :: Flag Bool, + cleanDistPref :: Flag FilePath, + cleanVerbosity :: Flag Verbosity + } + deriving Show + +defaultCleanFlags :: CleanFlags +defaultCleanFlags = CleanFlags { + cleanSaveConf = Flag False, + cleanDistPref = Flag defaultDistPref, + cleanVerbosity = Flag normal + } + +cleanCommand :: CommandUI CleanFlags +cleanCommand = makeCommand name shortDesc longDesc defaultCleanFlags options + where + name = "clean" + shortDesc = "Clean up after a build." + longDesc = Just (\_ -> "Removes .hi, .o, preprocessed sources, etc.\n") + options showOrParseArgs = + [optionVerbosity cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) + ,optionDistPref + cleanDistPref (\d flags -> flags { cleanDistPref = d }) + showOrParseArgs + + ,option "s" ["save-configure"] + "Do not remove the configuration file (dist/setup-config) during cleaning. Saves need to reconfigure." + cleanSaveConf (\v flags -> flags { cleanSaveConf = v }) + trueArg + ] + +emptyCleanFlags :: CleanFlags +emptyCleanFlags = mempty + +instance Monoid CleanFlags where + mempty = CleanFlags { + cleanSaveConf = mempty, + cleanDistPref = mempty, + cleanVerbosity = mempty + } + mappend a b = CleanFlags { + cleanSaveConf = combine cleanSaveConf, + cleanDistPref = combine cleanDistPref, + cleanVerbosity = combine cleanVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Build flags +-- ------------------------------------------------------------ + +data BuildFlags = BuildFlags { + buildProgramPaths :: [(String, FilePath)], + buildProgramArgs :: [(String, [String])], + buildDistPref :: Flag FilePath, + buildVerbosity :: Flag Verbosity + } + deriving Show + +{-# DEPRECATED buildVerbose "Use buildVerbosity instead" #-} +buildVerbose :: BuildFlags -> Verbosity +buildVerbose = fromFlagOrDefault normal . buildVerbosity + +defaultBuildFlags :: BuildFlags +defaultBuildFlags = BuildFlags { + buildProgramPaths = mempty, + buildProgramArgs = [], + buildDistPref = Flag defaultDistPref, + buildVerbosity = Flag normal + } + +buildCommand :: ProgramConfiguration -> CommandUI BuildFlags +buildCommand progConf = makeCommand name shortDesc longDesc defaultBuildFlags options + where + name = "build" + shortDesc = "Make this package ready for installation." + longDesc = Nothing + options showOrParseArgs = + optionVerbosity buildVerbosity (\v flags -> flags { buildVerbosity = v }) + : optionDistPref + buildDistPref (\d flags -> flags { buildDistPref = d }) + showOrParseArgs + + : programConfigurationPaths progConf showOrParseArgs + buildProgramPaths (\v flags -> flags { buildProgramPaths = v}) + + ++ programConfigurationOptions progConf showOrParseArgs + buildProgramArgs (\v flags -> flags { buildProgramArgs = v}) + +emptyBuildFlags :: BuildFlags +emptyBuildFlags = mempty + +instance Monoid BuildFlags where + mempty = BuildFlags { + buildProgramPaths = mempty, + buildProgramArgs = mempty, + buildVerbosity = mempty, + buildDistPref = mempty + } + mappend a b = BuildFlags { + buildProgramPaths = combine buildProgramPaths, + buildProgramArgs = combine buildProgramArgs, + buildVerbosity = combine buildVerbosity, + buildDistPref = combine buildDistPref + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Test flags +-- ------------------------------------------------------------ + +data TestShowDetails = Never | Failures | Always + deriving (Eq, Ord, Enum, Bounded, Show) + +knownTestShowDetails :: [TestShowDetails] +knownTestShowDetails = [minBound..maxBound] + +instance Text TestShowDetails where + disp = Disp.text . lowercase . show + + parse = maybe Parse.pfail return . classify =<< ident + where + ident = Parse.munch1 (\c -> isAlpha c || c == '_' || c == '-') + classify str = lookup (lowercase str) enumMap + enumMap :: [(String, TestShowDetails)] + enumMap = [ (display x, x) + | x <- knownTestShowDetails ] + +--TODO: do we need this instance? +instance Monoid TestShowDetails where + mempty = Never + mappend a b = if a < b then b else a + +data TestFlags = TestFlags { + testDistPref :: Flag FilePath, + testVerbosity :: Flag Verbosity, + testHumanLog :: Flag PathTemplate, + testMachineLog :: Flag PathTemplate, + testShowDetails :: Flag TestShowDetails, + testKeepTix :: Flag Bool, + --TODO: eliminate the test list and pass it directly as positional args to the testHook + testList :: Flag [String], + -- TODO: think about if/how options are passed to test exes + testOptions :: Flag [PathTemplate] + } + +defaultTestFlags :: TestFlags +defaultTestFlags = TestFlags { + testDistPref = Flag defaultDistPref, + testVerbosity = Flag normal, + testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log", + testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log", + testShowDetails = toFlag Failures, + testKeepTix = toFlag False, + testList = Flag [], + testOptions = Flag [] + } + +testCommand :: CommandUI TestFlags +testCommand = makeCommand name shortDesc longDesc defaultTestFlags options + where + name = "test" + shortDesc = "Run the test suite, if any (configure with UserHooks)." + longDesc = Nothing + options showOrParseArgs = + [ optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v }) + , optionDistPref + testDistPref (\d flags -> flags { testDistPref = d }) + showOrParseArgs + , option [] ["log"] + ("Log all test suite results to file (name template can use " + ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)") + testHumanLog (\v flags -> flags { testHumanLog = v }) + (reqArg' "TEMPLATE" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate)) + , option [] ["machine-log"] + ("Produce a machine-readable log file (name template can use " + ++ "$pkgid, $compiler, $os, $arch, $result)") + testMachineLog (\v flags -> flags { testMachineLog = v }) + (reqArg' "TEMPLATE" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate)) + , option [] ["show-details"] + ("'always': always show results of individual test cases. " + ++ "'never': never show results of individual test cases. " + ++ "'failures': show results of failing test cases.") + testShowDetails (\v flags -> flags { testShowDetails = v }) + (reqArg "FILTER" + (readP_to_E (\_ -> "--show-details flag expects one of " + ++ intercalate ", " + (map display knownTestShowDetails)) + (fmap toFlag parse)) + (flagToList . fmap display)) + , option [] ["keep-tix-files"] + "keep .tix files for HPC between test runs" + testKeepTix (\v flags -> flags { testKeepTix = v}) + trueArg + , option [] ["test-options"] + ("give extra options to test executables " + ++ "(name templates can use $pkgid, $compiler, " + ++ "$os, $arch, $test-suite)") + testOptions (\v flags -> flags { testOptions = v }) + (reqArg' "TEMPLATES" (toFlag . map toPathTemplate . splitArgs) + (map fromPathTemplate . fromFlagOrDefault [])) + , option [] ["test-option"] + ("give extra option to test executables " + ++ "(no need to quote options containing spaces, " + ++ "name template can use $pkgid, $compiler, " + ++ "$os, $arch, $test-suite)") + testOptions (\v flags -> flags { testOptions = v }) + (reqArg' "TEMPLATE" (\x -> toFlag [toPathTemplate x]) + (map fromPathTemplate . fromFlagOrDefault [])) + ] + +emptyTestFlags :: TestFlags +emptyTestFlags = mempty + +instance Monoid TestFlags where + mempty = TestFlags { + testDistPref = mempty, + testVerbosity = mempty, + testHumanLog = mempty, + testMachineLog = mempty, + testShowDetails = mempty, + testKeepTix = mempty, + testList = mempty, + testOptions = mempty + } + mappend a b = TestFlags { + testDistPref = combine testDistPref, + testVerbosity = combine testVerbosity, + testHumanLog = combine testHumanLog, + testMachineLog = combine testMachineLog, + testShowDetails = combine testShowDetails, + testKeepTix = combine testKeepTix, + testList = combine testList, + testOptions = combine testOptions + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Shared options utils +-- ------------------------------------------------------------ + +programFlagsDescription :: ProgramConfiguration -> String +programFlagsDescription progConf = + "The flags --with-PROG and --PROG-option(s) can be used with" + ++ " the following programs:" + ++ (concatMap (\line -> "\n " ++ unwords line) . wrapLine 77 . sort) + [ programName prog | (prog, _) <- knownPrograms progConf ] + ++ "\n" + +programConfigurationPaths + :: ProgramConfiguration + -> ShowOrParseArgs + -> (flags -> [(String, FilePath)]) + -> ([(String, FilePath)] -> (flags -> flags)) + -> [OptionField flags] +programConfigurationPaths progConf showOrParseArgs get set = + case showOrParseArgs of + -- we don't want a verbose help text list so we just show a generic one: + ShowArgs -> [withProgramPath "PROG"] + ParseArgs -> map (withProgramPath . programName . fst) (knownPrograms progConf) + where + withProgramPath prog = + option "" ["with-" ++ prog] + ("give the path to " ++ prog) + get set + (reqArg' "PATH" (\path -> [(prog, path)]) + (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ])) + +programConfigurationOptions + :: ProgramConfiguration + -> ShowOrParseArgs + -> (flags -> [(String, [String])]) + -> ([(String, [String])] -> (flags -> flags)) + -> [OptionField flags] +programConfigurationOptions progConf showOrParseArgs get set = + case showOrParseArgs of + -- we don't want a verbose help text list so we just show a generic one: + ShowArgs -> [programOptions "PROG", programOption "PROG"] + ParseArgs -> map (programOptions . programName . fst) (knownPrograms progConf) + ++ map (programOption . programName . fst) (knownPrograms progConf) + where + programOptions prog = + option "" [prog ++ "-options"] + ("give extra options to " ++ prog) + get set + (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const [])) + + programOption prog = + option "" [prog ++ "-option"] + ("give an extra option to " ++ prog ++ + " (no need to quote options containing spaces)") + get set + (reqArg' "OPT" (\arg -> [(prog, [arg])]) + (\progArgs -> concat [ args | (prog', args) <- progArgs, prog==prog' ])) + + +-- ------------------------------------------------------------ +-- * GetOpt Utils +-- ------------------------------------------------------------ + +boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a +boolOpt = Command.boolOpt flagToMaybe Flag + +boolOpt' :: OptFlags -> OptFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a +boolOpt' = Command.boolOpt' flagToMaybe Flag + +trueArg, falseArg :: SFlags -> LFlags -> Description -> (b -> Flag Bool) -> + (Flag Bool -> (b -> b)) -> OptDescr b +trueArg = noArg (Flag True) +falseArg = noArg (Flag False) + +reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description -> + (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b +reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList + +optionDistPref :: (flags -> Flag FilePath) + -> (Flag FilePath -> flags -> flags) + -> ShowOrParseArgs + -> OptionField flags +optionDistPref get set = \showOrParseArgs -> + option "" (distPrefFlagName showOrParseArgs) + ( "The directory where Cabal puts generated build files " + ++ "(default " ++ defaultDistPref ++ ")") + get set + (reqArgFlag "DIR") + where + distPrefFlagName ShowArgs = ["builddir"] + distPrefFlagName ParseArgs = ["builddir", "distdir", "distpref"] + +optionVerbosity :: (flags -> Flag Verbosity) + -> (Flag Verbosity -> flags -> flags) + -> OptionField flags +optionVerbosity get set = + option "v" ["verbose"] + "Control verbosity (n is 0--3, default verbosity level is 1)" + get set + (optArg "n" (fmap Flag flagToVerbosity) + (Flag verbose) -- default Value if no n is given + (fmap (Just . showForCabal) . flagToList)) + +-- ------------------------------------------------------------ +-- * Other Utils +-- ------------------------------------------------------------ + +-- | Arguments to pass to a @configure@ script, e.g. generated by +-- @autoconf@. +configureArgs :: Bool -> ConfigFlags -> [String] +configureArgs bcHack flags + = hc_flag + ++ optFlag "with-hc-pkg" configHcPkg + ++ optFlag' "prefix" prefix + ++ optFlag' "bindir" bindir + ++ optFlag' "libdir" libdir + ++ optFlag' "libexecdir" libexecdir + ++ optFlag' "datadir" datadir + ++ configConfigureArgs flags + where + hc_flag = case (configHcFlavor flags, configHcPath flags) of + (_, Flag hc_path) -> [hc_flag_name ++ hc_path] + (Flag hc, NoFlag) -> [hc_flag_name ++ display hc] + (NoFlag,NoFlag) -> [] + hc_flag_name + --TODO kill off thic bc hack when defaultUserHooks is removed. + | bcHack = "--with-hc=" + | otherwise = "--with-compiler=" + optFlag name config_field = case config_field flags of + Flag p -> ["--" ++ name ++ "=" ++ p] + NoFlag -> [] + optFlag' name config_field = optFlag name (fmap fromPathTemplate + . config_field + . configInstallDirs) + +configureCCompiler :: Verbosity -> ProgramConfiguration -> IO (FilePath, [String]) +configureCCompiler verbosity lbi = configureProg verbosity lbi gccProgram + +configureLinker :: Verbosity -> ProgramConfiguration -> IO (FilePath, [String]) +configureLinker verbosity lbi = configureProg verbosity lbi ldProgram + +configureProg :: Verbosity -> ProgramConfiguration -> Program -> IO (FilePath, [String]) +configureProg verbosity programConfig prog = do + (p, _) <- requireProgram verbosity prog programConfig + let pInv = programInvocation p [] + return (progInvokePath pInv, progInvokeArgs pInv) + +-- | Helper function to split a string into a list of arguments. +-- It's supposed to handle quoted things sensibly, eg: +-- +-- > splitArgs "--foo=\"C:\Program Files\Bar\" --baz" +-- > = ["--foo=C:\Program Files\Bar", "--baz"] +-- +splitArgs :: String -> [String] +splitArgs = space [] + where + space :: String -> String -> [String] + space w [] = word w [] + space w ( c :s) + | isSpace c = word w (space [] s) + space w ('"':s) = string w s + space w s = nonstring w s + + string :: String -> String -> [String] + string w [] = word w [] + string w ('"':s) = space w s + string w ( c :s) = string (c:w) s + + nonstring :: String -> String -> [String] + nonstring w [] = word w [] + nonstring w ('"':s) = string w s + nonstring w ( c :s) = space (c:w) s + + word [] s = s + word w s = reverse w : s + +-- The test cases kinda have to be rewritten from the ground up... :/ +--hunitTests :: [Test] +--hunitTests = +-- let m = [("ghc", GHC), ("nhc98", NHC), ("hugs", Hugs)] +-- (flags, commands', unkFlags, ers) +-- = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc98", "--hugs", "--with-compiler=/comp", "--unknown1", "--unknown2", "--install-prefix=/foo", "--user", "--global"] +-- in [TestLabel "very basic option parsing" $ TestList [ +-- "getOpt flags" ~: "failed" ~: +-- [Prefix "/foo", GhcFlag, NhcFlag, HugsFlag, +-- WithCompiler "/comp", InstPrefix "/foo", UserFlag, GlobalFlag] +-- ~=? flags, +-- "getOpt commands" ~: "failed" ~: ["configure", "foobar"] ~=? commands', +-- "getOpt unknown opts" ~: "failed" ~: +-- ["--unknown1", "--unknown2"] ~=? unkFlags, +-- "getOpt errors" ~: "failed" ~: [] ~=? ers], +-- +-- TestLabel "test location of various compilers" $ TestList +-- ["configure parsing for prefix and compiler flag" ~: "failed" ~: +-- (Right (ConfigCmd (Just comp, Nothing, Just "/usr/local"), [])) +-- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, "configure"]) +-- | (name, comp) <- m], +-- +-- TestLabel "find the package tool" $ TestList +-- ["configure parsing for prefix comp flag, withcompiler" ~: "failed" ~: +-- (Right (ConfigCmd (Just comp, Just "/foo/comp", Just "/usr/local"), [])) +-- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, +-- "--with-compiler=/foo/comp", "configure"]) +-- | (name, comp) <- m], +-- +-- TestLabel "simpler commands" $ TestList +-- [flag ~: "failed" ~: (Right (flagCmd, [])) ~=? (parseArgs [flag]) +-- | (flag, flagCmd) <- [("build", BuildCmd), +-- ("install", InstallCmd Nothing False), +-- ("sdist", SDistCmd), +-- ("register", RegisterCmd False)] +-- ] +-- ] + +{- Testing ideas: + * IO to look for hugs and hugs-pkg (which hugs, etc) + * quickCheck to test permutations of arguments + * what other options can we over-ride with a command-line flag? +-} diff --git a/cabal/cabal/Distribution/Simple/SrcDist.hs b/cabal/cabal/Distribution/Simple/SrcDist.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/SrcDist.hs @@ -0,0 +1,418 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.SrcDist +-- Copyright : Simon Marlow 2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This handles the @sdist@ command. The module exports an 'sdist' action but +-- also some of the phases that make it up so that other tools can use just the +-- bits they need. In particular the preparation of the tree of files to go +-- into the source tarball is separated from actually building the source +-- tarball. +-- +-- The 'createArchive' action uses the external @tar@ program and assumes that +-- it accepts the @-z@ flag. Neither of these assumptions are valid on Windows. +-- The 'sdist' action now also does some distribution QA checks. + +{- 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 ( + -- * The top level action + sdist, + + -- ** Parts of 'sdist' + printPackageProblems, + prepareTree, + createArchive, + + -- ** Snaphots + prepareSnapshotTree, + snapshotPackage, + snapshotVersion, + dateToSnapshotNumber, + ) where + +import Distribution.PackageDescription + ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..) + , TestSuite(..), TestSuiteInterface(..) ) +import Distribution.PackageDescription.Check + ( PackageCheck(..), checkConfiguredPackage, checkPackageFiles ) +import Distribution.Package + ( PackageIdentifier(pkgVersion), Package(..), packageVersion ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Version + ( Version(versionBranch) ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File + , installOrdinaryFile, installOrdinaryFiles, setFileExecutable + , findFile, findFileWithExtension, matchFileGlob + , withTempDirectory, defaultPackageDesc + , die, warn, notice, setupMessage ) +import Distribution.Simple.Setup (SDistFlags(..), fromFlag, flagToMaybe) +import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessComponent) +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), withComponentsLBI ) +import Distribution.Simple.BuildPaths ( autogenModuleName ) +import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram, + rawSystemProgram, tarProgram ) +import Distribution.Text + ( display ) + +import Control.Monad(when, unless) +import Data.Char (toLower) +import Data.List (partition, isPrefixOf) +import Data.Maybe (isNothing, catMaybes) +import System.Time (getClockTime, toCalendarTime, CalendarTime(..)) +import System.Directory + ( doesFileExist, Permissions(executable), getPermissions ) +import Distribution.Verbosity (Verbosity) +import System.FilePath + ( (), (<.>), takeDirectory, dropExtension, isAbsolute ) + +-- |Create a source distribution. +sdist :: PackageDescription -- ^information from the tarball + -> Maybe LocalBuildInfo -- ^Information from configure + -> SDistFlags -- ^verbosity & snapshot + -> (FilePath -> FilePath) -- ^build prefix (temp dir) + -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) + -> IO () +sdist pkg mb_lbi flags mkTmpDir pps = do + + -- do some QA + printPackageProblems verbosity pkg + + when (isNothing mb_lbi) $ + warn verbosity "Cannot run preprocessors. Run 'configure' command first." + + date <- toCalendarTime =<< getClockTime + let pkg' | snapshot = snapshotPackage date pkg + | otherwise = pkg + + case flagToMaybe (sDistDirectory flags) of + Just targetDir -> do + generateSourceDir targetDir pkg' + notice verbosity $ "Source directory created: " ++ targetDir + + Nothing -> do + createDirectoryIfMissingVerbose verbosity True tmpTargetDir + withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do + let targetDir = tmpDir tarBallName pkg' + generateSourceDir targetDir pkg' + targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref + notice verbosity $ "Source tarball created: " ++ targzFile + + where + generateSourceDir targetDir pkg' = do + + setupMessage verbosity "Building source dist for" (packageId pkg') + prepareTree verbosity pkg' mb_lbi distPref targetDir pps + when snapshot $ + overwriteSnapshotPackageDesc verbosity pkg' targetDir + + verbosity = fromFlag (sDistVerbosity flags) + snapshot = fromFlag (sDistSnapshot flags) + + distPref = fromFlag $ sDistDistPref flags + targetPref = distPref + tmpTargetDir = mkTmpDir distPref + + +-- |Prepare a directory tree of source files. +prepareTree :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from the cabal file + -> Maybe LocalBuildInfo + -> FilePath -- ^dist dir + -> FilePath -- ^source tree to populate + -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) + -> IO () +prepareTree verbosity pkg_descr0 mb_lbi distPref targetDir pps = do + createDirectoryIfMissingVerbose verbosity True targetDir + + -- maybe move the library files into place + withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } -> + prepareDir verbosity pkg_descr distPref targetDir pps modules libBi + + -- move the executables into place + withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do + prepareDir verbosity pkg_descr distPref targetDir pps [] exeBi + srcMainFile <- do + ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi) (dropExtension mainPath) + case ppFile of + Nothing -> findFile (hsSourceDirs exeBi) mainPath + Just pp -> return pp + copyFileTo verbosity targetDir srcMainFile + + -- move the test suites into place + withTest $ \t -> do + let bi = testBuildInfo t + prep = prepareDir verbosity pkg_descr distPref targetDir pps + case testInterface t of + TestSuiteExeV10 _ mainPath -> do + prep [] bi + srcMainFile <- do + ppFile <- findFileWithExtension (ppSuffixes pps) + (hsSourceDirs bi) + (dropExtension mainPath) + case ppFile of + Nothing -> findFile (hsSourceDirs bi) mainPath + Just pp -> return pp + copyFileTo verbosity targetDir srcMainFile + TestSuiteLibV09 _ m -> do + prep [m] bi + TestSuiteUnsupported tp -> die $ "Unsupported test suite type: " ++ show tp + + flip mapM_ (dataFiles pkg_descr) $ \ filename -> do + files <- matchFileGlob (dataDir pkg_descr filename) + let dir = takeDirectory (dataDir pkg_descr filename) + createDirectoryIfMissingVerbose verbosity True (targetDir dir) + sequence_ [ installOrdinaryFile verbosity file (targetDir file) + | file <- files ] + + when (not (null (licenseFile pkg_descr))) $ + copyFileTo verbosity targetDir (licenseFile pkg_descr) + flip mapM_ (extraSrcFiles pkg_descr) $ \ fpath -> do + files <- matchFileGlob fpath + sequence_ + [ do copyFileTo verbosity targetDir file + -- preserve executable bit on extra-src-files like ./configure + perms <- getPermissions file + when (executable perms) --only checks user x bit + (setFileExecutable (targetDir file)) + | file <- files ] + + -- copy the install-include files + withLib $ \ l -> do + let lbi = libBuildInfo l + relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) + incs <- mapM (findInc relincdirs) (installIncludes lbi) + flip mapM_ incs $ \(_,fpath) -> + copyFileTo verbosity targetDir fpath + + -- if the package was configured then we can run platform independent + -- pre-processors and include those generated files + case mb_lbi of + Just lbi | not (null pps) -> do + let lbi' = lbi{ buildDir = targetDir buildDir lbi } + withComponentsLBI pkg_descr lbi' $ \c _ -> + preprocessComponent pkg_descr c lbi' True verbosity pps + _ -> return () + + -- setup isn't listed in the description file. + hsExists <- doesFileExist "Setup.hs" + lhsExists <- doesFileExist "Setup.lhs" + if hsExists then copyFileTo verbosity targetDir "Setup.hs" + else if lhsExists then copyFileTo verbosity targetDir "Setup.lhs" + else writeUTF8File (targetDir "Setup.hs") $ unlines [ + "import Distribution.Simple", + "main = defaultMain"] + -- the description file itself + descFile <- defaultPackageDesc verbosity + installOrdinaryFile verbosity descFile (targetDir descFile) + + where + pkg_descr = mapAllBuildInfo filterAutogenModule pkg_descr0 + filterAutogenModule bi = bi { + otherModules = filter (/=autogenModule) (otherModules bi) + } + autogenModule = autogenModuleName pkg_descr0 + + findInc [] f = die ("can't find include file " ++ f) + findInc (d:ds) f = do + let path = (d f) + b <- doesFileExist path + if b then return (f,path) else findInc ds f + + -- We have to deal with all libs and executables, so we have local + -- versions of these functions that ignore the 'buildable' attribute: + withLib action = maybe (return ()) action (library pkg_descr) + withExe action = mapM_ action (executables pkg_descr) + withTest action = mapM_ action (testSuites pkg_descr) + +-- | Prepare a directory tree of source files for a snapshot version. +-- It is expected that the appropriate snapshot version has already been set +-- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'. +-- +prepareSnapshotTree :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from the cabal file + -> Maybe LocalBuildInfo + -> FilePath -- ^dist dir + -> FilePath -- ^source tree to populate + -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) + -> IO () +prepareSnapshotTree verbosity pkg mb_lbi distPref targetDir pps = do + prepareTree verbosity pkg mb_lbi distPref targetDir pps + overwriteSnapshotPackageDesc verbosity pkg targetDir + +overwriteSnapshotPackageDesc :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from the cabal file + -> FilePath -- ^source tree + -> IO () +overwriteSnapshotPackageDesc verbosity pkg targetDir = do + -- We could just writePackageDescription targetDescFile pkg_descr, + -- but that would lose comments and formatting. + descFile <- defaultPackageDesc verbosity + withUTF8FileContents descFile $ + writeUTF8File (targetDir descFile) + . unlines . map (replaceVersion (packageVersion pkg)) . lines + + where + replaceVersion :: Version -> String -> String + replaceVersion version line + | "version:" `isPrefixOf` map toLower line + = "version: " ++ display version + | otherwise = line + +-- | Modifies a 'PackageDescription' by appending a snapshot number +-- corresponding to the given date. +-- +snapshotPackage :: CalendarTime -> PackageDescription -> PackageDescription +snapshotPackage date pkg = + pkg { + package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) } + } + where pkgid = packageId pkg + +-- | Modifies a 'Version' by appending a snapshot number corresponding +-- to the given date. +-- +snapshotVersion :: CalendarTime -> Version -> Version +snapshotVersion date version = version { + versionBranch = versionBranch version + ++ [dateToSnapshotNumber date] + } + +-- | Given a date produce a corresponding integer representation. +-- For example given a date @18/03/2008@ produce the number @20080318@. +-- +dateToSnapshotNumber :: CalendarTime -> Int +dateToSnapshotNumber date = year * 10000 + + month * 100 + + day + where + year = ctYear date + month = fromEnum (ctMonth date) + 1 + day = ctDay date + +-- |Create an archive from a tree of source files, and clean up the tree. +createArchive :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from cabal file + -> Maybe LocalBuildInfo -- ^info from configure + -> FilePath -- ^source tree to archive + -> FilePath -- ^name of archive to create + -> IO FilePath + +createArchive verbosity pkg_descr mb_lbi tmpDir targetPref = do + let tarBallFilePath = targetPref tarBallName pkg_descr <.> "tar.gz" + + (tarProg, _) <- requireProgram verbosity tarProgram + (maybe defaultProgramConfiguration withPrograms mb_lbi) + + -- Hmm: I could well be skating on thinner ice here by using the -C option (=> GNU tar-specific?) + -- [The prev. solution used pipes and sub-command sequences to set up the paths correctly, + -- which is problematic in a Windows setting.] + rawSystemProgram verbosity tarProg + ["-C", tmpDir, "-czf", tarBallFilePath, tarBallName pkg_descr] + return tarBallFilePath + +-- |Move the sources into place based on buildInfo +prepareDir :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from the cabal file + -> FilePath -- ^dist dir + -> FilePath -- ^TargetPrefix + -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) + -> [ModuleName] -- ^Exposed modules + -> BuildInfo + -> IO () +prepareDir verbosity _pkg _distPref inPref pps modules bi + = do let searchDirs = hsSourceDirs bi + sources <- sequence + [ let file = ModuleName.toFilePath module_ + in findFileWithExtension suffixes searchDirs file + >>= maybe (notFound module_) return + | module_ <- modules ++ otherModules bi ] + bootFiles <- sequence + [ let file = ModuleName.toFilePath module_ + fileExts = ["hs-boot", "lhs-boot"] + in findFileWithExtension fileExts (hsSourceDirs bi) file + | module_ <- modules ++ otherModules bi ] + + let allSources = sources ++ catMaybes bootFiles ++ cSources bi + installOrdinaryFiles verbosity inPref (zip (repeat []) allSources) + + where suffixes = ppSuffixes pps ++ ["hs", "lhs"] + notFound m = die $ "Error: Could not find module: " ++ display m + ++ " with any suffix: " ++ show suffixes + +copyFileTo :: Verbosity -> FilePath -> FilePath -> IO () +copyFileTo verbosity dir file = do + let targetFile = dir file + createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile) + installOrdinaryFile verbosity file targetFile + +printPackageProblems :: Verbosity -> PackageDescription -> IO () +printPackageProblems verbosity pkg_descr = do + ioChecks <- checkPackageFiles pkg_descr "." + let pureChecks = checkConfiguredPackage pkg_descr + isDistError (PackageDistSuspicious _) = False + isDistError _ = True + (errors, warnings) = partition isDistError (pureChecks ++ ioChecks) + unless (null errors) $ + notice verbosity $ "Distribution quality errors:\n" + ++ unlines (map explanation errors) + unless (null warnings) $ + notice verbosity $ "Distribution quality warnings:\n" + ++ unlines (map explanation warnings) + unless (null errors) $ + notice verbosity + "Note: the public hackage server would reject this package." + +------------------------------------------------------------ + +-- | The name of the tarball without extension +-- +tarBallName :: PackageDescription -> String +tarBallName = display . packageId + +mapAllBuildInfo :: (BuildInfo -> BuildInfo) + -> (PackageDescription -> PackageDescription) +mapAllBuildInfo f pkg = pkg { + library = fmap mapLibBi (library pkg), + executables = fmap mapExeBi (executables pkg) + } + where + mapLibBi lib = lib { libBuildInfo = f (libBuildInfo lib) } + mapExeBi exe = exe { buildInfo = f (buildInfo exe) } diff --git a/cabal/cabal/Distribution/Simple/Test.hs b/cabal/cabal/Distribution/Simple/Test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Test.hs @@ -0,0 +1,486 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Test +-- Copyright : Thomas Tuegel 2010 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point into testing a built package. It performs the +-- \"@.\/setup test@\" action. It runs test suites designated in the package +-- description and reports on the results. + +{- 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.Test + ( test + , runTests + , writeSimpleTestStub + , stubFilePath + , stubName + , PackageLog(..) + , TestSuiteLog(..) + , Case(..) + , suitePassed, suiteFailed, suiteError + ) where + +import Distribution.Compat.TempFile ( openTempFile ) +import Distribution.ModuleName ( ModuleName ) +import Distribution.Package + ( PackageId ) +import qualified Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(buildable) + , TestSuite(..) + , TestSuiteInterface(..), testType, hasTests ) +import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar ) +import Distribution.Simple.BuildPaths ( exeExtension ) +import Distribution.Simple.Compiler ( Compiler(..), CompilerId ) +import Distribution.Simple.Hpc ( doHpcMarkup, findTixFiles, tixDir ) +import Distribution.Simple.InstallDirs + ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..) + , substPathTemplate , toPathTemplate, PathTemplate ) +import qualified Distribution.Simple.LocalBuildInfo as LBI + ( LocalBuildInfo(..) ) +import Distribution.Simple.Setup ( TestFlags(..), TestShowDetails(..), fromFlag ) +import Distribution.Simple.Utils ( die, notice ) +import qualified Distribution.TestSuite as TestSuite + ( Test, Result(..), ImpureTestable(..), TestOptions(..), Options(..) ) +import Distribution.Text +import Distribution.Verbosity ( normal, Verbosity ) +import Distribution.System ( buildPlatform, Platform ) + +import Control.Exception ( bracket ) +import Control.Monad ( when, liftM, unless, filterM ) +import Data.Char ( toUpper ) +import Data.Monoid ( mempty ) +import System.Directory + ( createDirectoryIfMissing, doesFileExist, getCurrentDirectory + , removeFile, getDirectoryContents ) +import System.Environment ( getEnvironment ) +import System.Exit ( ExitCode(..), exitFailure, exitWith ) +import System.FilePath ( (), (<.>) ) +import System.IO ( hClose, IOMode(..), openFile ) +import System.Process ( runProcess, waitForProcess ) + +-- | Logs all test results for a package, broken down first by test suite and +-- then by test case. +data PackageLog = PackageLog + { package :: PackageId + , compiler :: CompilerId + , platform :: Platform + , testSuites :: [TestSuiteLog] + } + deriving (Read, Show, Eq) + +-- | A 'PackageLog' with package and platform information specified. +localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog +localPackageLog pkg_descr lbi = PackageLog + { package = PD.package pkg_descr + , compiler = compilerId $ LBI.compiler lbi + , platform = buildPlatform + , testSuites = [] + } + +-- | Logs test suite results, itemized by test case. +data TestSuiteLog = TestSuiteLog + { name :: String + , cases :: [Case] + , logFile :: FilePath -- path to human-readable log file + } + deriving (Read, Show, Eq) + +data Case = Case + { caseName :: String + , caseOptions :: TestSuite.Options + , caseResult :: TestSuite.Result + } + deriving (Read, Show, Eq) + +getTestOptions :: TestSuite.Test -> TestSuiteLog -> IO TestSuite.Options +getTestOptions t l = + case filter ((== TestSuite.name t) . caseName) (cases l) of + (x:_) -> return $ caseOptions x + _ -> TestSuite.defaultOptions t + +-- | From a 'TestSuiteLog', determine if the test suite passed. +suitePassed :: TestSuiteLog -> Bool +suitePassed = all (== TestSuite.Pass) . map caseResult . cases + +-- | From a 'TestSuiteLog', determine if the test suite failed. +suiteFailed :: TestSuiteLog -> Bool +suiteFailed = any isFail . map caseResult . cases + where isFail (TestSuite.Fail _) = True + isFail _ = False + +-- | From a 'TestSuiteLog', determine if the test suite encountered errors. +suiteError :: TestSuiteLog -> Bool +suiteError = any isError . map caseResult . cases + where isError (TestSuite.Error _) = True + isError _ = False + +-- | Run a test executable, logging the output and generating the appropriate +-- summary messages. +testController :: TestFlags + -- ^ flags Cabal was invoked with + -> PD.PackageDescription + -- ^ description of package the test suite belongs to + -> LBI.LocalBuildInfo + -- ^ information from the configure step + -> PD.TestSuite + -- ^ TestSuite being tested + -> (FilePath -> String) + -- ^ prepare standard input for test executable + -> FilePath -- ^ executable name + -> (ExitCode -> String -> TestSuiteLog) + -- ^ generator for the TestSuiteLog + -> (TestSuiteLog -> FilePath) + -- ^ generator for final human-readable log filename + -> IO TestSuiteLog +testController flags pkg_descr lbi suite preTest cmd postTest logNamer = do + let distPref = fromFlag $ testDistPref flags + verbosity = fromFlag $ testVerbosity flags + testLogDir = distPref "test" + optionTemplates = fromFlag $ testOptions flags + options = map (testOption pkg_descr lbi suite) optionTemplates + + pwd <- getCurrentDirectory + existingEnv <- getEnvironment + let dataDirPath = pwd PD.dataDir pkg_descr + shellEnv = Just $ (pkgPathEnvVar pkg_descr "datadir", dataDirPath) + : ("HPCTIXDIR", pwd tixDir distPref suite) + : existingEnv + + bracket (openCabalTemp testLogDir) deleteIfExists $ \tempLog -> + bracket (openCabalTemp testLogDir) deleteIfExists $ \tempInput -> do + + -- Create directory for HPC files. + createDirectoryIfMissing True $ tixDir distPref suite + + -- Remove old .tix files if appropriate. + tixFiles <- findTixFiles distPref suite + unless (fromFlag $ testKeepTix flags) + $ mapM_ deleteIfExists tixFiles + + -- Write summary notices indicating start of test suite + notice verbosity $ summarizeSuiteStart $ PD.testName suite + appendFile tempLog $ summarizeSuiteStart $ PD.testName suite + + -- Prepare standard input for test executable + appendFile tempInput $ preTest tempInput + + -- Run test executable + exit <- do + hLog <- openFile tempLog AppendMode + hIn <- openFile tempInput ReadMode + -- these handles get closed by runProcess + proc <- runProcess cmd options Nothing shellEnv + (Just hIn) (Just hLog) (Just hLog) + waitForProcess proc + + -- Generate TestSuiteLog from executable exit code and a machine- + -- readable test log + suiteLog <- readFile tempInput >>= return . postTest exit + + -- Generate final log file name + let finalLogName = testLogDir logNamer suiteLog + suiteLog' = suiteLog { logFile = finalLogName } + + -- Write summary notice to log file indicating end of test suite + appendFile tempLog $ summarizeSuiteFinish suiteLog' + + -- Append contents of temporary log file to the final human- + -- readable log file + readFile tempLog >>= appendFile (logFile suiteLog') + + -- Show the contents of the human-readable log file on the terminal + -- if there is a failure and/or detailed output is requested + let details = fromFlag $ testShowDetails flags + whenPrinting = when $ (details > Never) + && (not (suitePassed suiteLog) || details == Always) + && verbosity >= normal + whenPrinting $ readFile (logFile suiteLog') >>= + putStr . unlines . map (">>> " ++) . lines + + -- Write summary notice to terminal indicating end of test suite + notice verbosity $ summarizeSuiteFinish suiteLog' + + doHpcMarkup verbosity distPref (display $ PD.package pkg_descr) suite + + return suiteLog' + where + deleteIfExists file = do + exists <- doesFileExist file + when exists $ removeFile file + + openCabalTemp testLogDir = do + (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log" + hClose h >> return f + + +-- |Perform the \"@.\/setup test@\" action. +test :: PD.PackageDescription -- ^information from the .cabal file + -> LBI.LocalBuildInfo -- ^information from the configure step + -> TestFlags -- ^flags sent to test + -> IO () +test pkg_descr lbi flags = do + let verbosity = fromFlag $ testVerbosity flags + humanTemplate = fromFlag $ testHumanLog flags + machineTemplate = fromFlag $ testMachineLog flags + distPref = fromFlag $ testDistPref flags + testLogDir = distPref "test" + testNames = fromFlag $ testList flags + pkgTests = PD.testSuites pkg_descr + enabledTests = [ t | t <- pkgTests + , PD.testEnabled t + , PD.buildable (PD.testBuildInfo t) ] + + doTest :: (PD.TestSuite, Maybe TestSuiteLog) -> IO TestSuiteLog + doTest (suite, mLog) = do + let testLogPath = testSuiteLogPath humanTemplate pkg_descr lbi + go pre cmd post = testController flags pkg_descr lbi suite + pre cmd post testLogPath + case PD.testInterface suite of + PD.TestSuiteExeV10 _ _ -> do + let cmd = LBI.buildDir lbi PD.testName suite + PD.testName suite <.> exeExtension + preTest _ = "" + postTest exit _ = + let r = case exit of + ExitSuccess -> TestSuite.Pass + ExitFailure c -> TestSuite.Fail + $ "exit code: " ++ show c + in TestSuiteLog + { name = PD.testName suite + , cases = [Case (PD.testName suite) mempty r] + , logFile = "" + } + go preTest cmd postTest + + PD.TestSuiteLibV09 _ _ -> do + let cmd = LBI.buildDir lbi stubName suite + stubName suite <.> exeExtension + oldLog = case mLog of + Nothing -> TestSuiteLog + { name = PD.testName suite + , cases = [] + , logFile = [] + } + Just l -> l + preTest f = show $ oldLog { logFile = f } + postTest _ = read + go preTest cmd postTest + + _ -> return TestSuiteLog + { name = PD.testName suite + , cases = [Case (PD.testName suite) mempty + $ TestSuite.Error $ "No support for running " + ++ "test suite type: " + ++ show (disp $ PD.testType suite)] + , logFile = "" + } + + when (not $ PD.hasTests pkg_descr) $ do + notice verbosity "Package has no test suites." + exitWith ExitSuccess + + when (PD.hasTests pkg_descr && null enabledTests) $ + die $ "No test suites enabled. Did you remember to configure with " + ++ "\'--enable-tests\'?" + + testsToRun <- case testNames of + [] -> return $ zip enabledTests $ repeat Nothing + names -> flip mapM names $ \tName -> + let testMap = zip enabledNames enabledTests + enabledNames = map PD.testName enabledTests + allNames = map PD.testName pkgTests + in case lookup tName testMap of + Just t -> return (t, Nothing) + _ | tName `elem` allNames -> + die $ "Package configured with test suite " + ++ tName ++ " disabled." + | otherwise -> die $ "no such test: " ++ tName + + createDirectoryIfMissing True testLogDir + + -- Delete ordinary files from test log directory. + getDirectoryContents testLogDir + >>= filterM doesFileExist . map (testLogDir ) + >>= mapM_ removeFile + + let totalSuites = length testsToRun + notice verbosity $ "Running " ++ show totalSuites ++ " test suites..." + suites <- mapM doTest testsToRun + let packageLog = (localPackageLog pkg_descr lbi) { testSuites = suites } + packageLogFile = () testLogDir + $ packageLogPath machineTemplate pkg_descr lbi + allOk <- summarizePackage verbosity packageLog + writeFile packageLogFile $ show packageLog + unless allOk exitFailure + +-- | Print a summary to the console after all test suites have been run +-- indicating the number of successful test suites and cases. Returns 'True' if +-- all test suites passed and 'False' otherwise. +summarizePackage :: Verbosity -> PackageLog -> IO Bool +summarizePackage verbosity packageLog = do + let cases' = map caseResult $ concatMap cases $ testSuites packageLog + passedCases = length $ filter (== TestSuite.Pass) cases' + totalCases = length cases' + passedSuites = length $ filter suitePassed $ testSuites packageLog + totalSuites = length $ testSuites packageLog + notice verbosity $ show passedSuites ++ " of " ++ show totalSuites + ++ " test suites (" ++ show passedCases ++ " of " + ++ show totalCases ++ " test cases) passed." + return $! passedSuites == totalSuites + +-- | Print a summary of a single test case's result to the console, supressing +-- output for certain verbosity or test filter levels. +summarizeCase :: Verbosity -> TestShowDetails -> Case -> IO () +summarizeCase verbosity details t = + when shouldPrint $ notice verbosity $ "Test case " ++ caseName t + ++ ": " ++ show (caseResult t) + where shouldPrint = (details > Never) && (notPassed || details == Always) + notPassed = caseResult t /= TestSuite.Pass + +-- | Print a summary of the test suite's results on the console, suppressing +-- output for certain verbosity or test filter levels. +summarizeSuiteFinish :: TestSuiteLog -> String +summarizeSuiteFinish testLog = unlines + [ "Test suite " ++ name testLog ++ ": " ++ resStr + , "Test suite logged to: " ++ logFile testLog + ] + where resStr = map toUpper (resultString testLog) + +summarizeSuiteStart :: String -> String +summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n" + +resultString :: TestSuiteLog -> String +resultString l | suiteError l = "error" + | suiteFailed l = "fail" + | otherwise = "pass" + +testSuiteLogPath :: PathTemplate + -> PD.PackageDescription + -> LBI.LocalBuildInfo + -> TestSuiteLog + -> FilePath +testSuiteLogPath template pkg_descr lbi testLog = + fromPathTemplate $ substPathTemplate env template + where + env = initialPathTemplateEnv + (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) + ++ [ (TestSuiteNameVar, toPathTemplate $ name testLog) + , (TestSuiteResultVar, result) + ] + result = toPathTemplate $ resultString testLog + +-- TODO: This is abusing the notion of a 'PathTemplate'. The result +-- isn't neccesarily a path. +testOption :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.TestSuite + -> PathTemplate + -> String +testOption pkg_descr lbi suite template = + fromPathTemplate $ substPathTemplate env template + where + env = initialPathTemplateEnv + (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) ++ + [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)] + +packageLogPath :: PathTemplate + -> PD.PackageDescription + -> LBI.LocalBuildInfo + -> FilePath +packageLogPath template pkg_descr lbi = + fromPathTemplate $ substPathTemplate env template + where + env = initialPathTemplateEnv + (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) + +-- | The filename of the source file for the stub executable associated with a +-- library 'TestSuite'. +stubFilePath :: PD.TestSuite -> FilePath +stubFilePath t = stubName t <.> "hs" + +-- | The name of the stub executable associated with a library 'TestSuite'. +stubName :: PD.TestSuite -> FilePath +stubName t = PD.testName t ++ "Stub" + +-- | Write the source file for a library 'TestSuite' stub executable. +writeSimpleTestStub :: PD.TestSuite -- ^ library 'TestSuite' for which a stub + -- is being created + -> FilePath -- ^ path to directory where stub source + -- should be located + -> IO () +writeSimpleTestStub t dir = do + createDirectoryIfMissing True dir + let filename = dir stubFilePath t + PD.TestSuiteLibV09 _ m = PD.testInterface t + writeFile filename $ simpleTestStub m + +-- | Source code for library test suite stub executable +simpleTestStub :: ModuleName -> String +simpleTestStub m = unlines + [ "module Main ( main ) where" + , "import Control.Monad ( liftM )" + , "import Distribution.Simple.Test ( runTests )" + , "import " ++ show (disp m) ++ " ( tests )" + , "main :: IO ()" + , "main = runTests tests" + ] + +-- | The test runner used in library "TestSuite" stub executables. Runs a list +-- of 'Test's. An executable calling this function is meant to be invoked as +-- the child of a Cabal process during @.\/setup test@. A 'TestSuiteLog', +-- provided by Cabal, is read from the standard input; it supplies the name of +-- the test suite and the location of the machine-readable test suite log file. +-- Human-readable log information is written to the standard output for capture +-- by the calling Cabal process. +runTests :: [TestSuite.Test] -> IO () +runTests tests = do + testLogIn <- liftM read getContents + let go :: TestSuite.Test -> IO Case + go t = do + o <- getTestOptions t testLogIn + r <- TestSuite.runM t o + let ret = Case + { caseName = TestSuite.name t + , caseOptions = o + , caseResult = r + } + summarizeCase normal Always ret + return ret + cases' <- mapM go tests + let testLog = testLogIn { cases = cases'} + writeFile (logFile testLog) $ show testLog + when (suiteError testLog) $ exitWith $ ExitFailure 2 + when (suiteFailed testLog) $ exitWith $ ExitFailure 1 + exitWith ExitSuccess diff --git a/cabal/cabal/Distribution/Simple/UHC.hs b/cabal/cabal/Distribution/Simple/UHC.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/UHC.hs @@ -0,0 +1,300 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.UHC +-- Copyright : Andres Loeh 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains most of the UHC-specific code for configuring, building +-- and installing packages. +-- +-- Thanks to the authors of the other implementation-specific files, in +-- particular to Isaac Jones, Duncan Coutts and Henning Thielemann, for +-- inspiration on how to design this module. + +{- +Copyright (c) 2009, Andres Loeh +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.UHC ( + configure, getInstalledPackages, + buildLib, buildExe, installLib, registerPackage + ) where + +import Control.Monad +import Data.List +import Distribution.Compat.ReadP +import Distribution.InstalledPackageInfo +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler as C +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex +import Distribution.Simple.Program +import Distribution.Simple.Utils +import Distribution.Text +import Distribution.Verbosity +import Distribution.Version +import Language.Haskell.Extension +import System.Directory +import System.FilePath + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) +configure verbosity hcPath _hcPkgPath conf = do + + (_uhcProg, uhcVersion, conf') <- + requireProgramVersion verbosity uhcProgram + (orLaterVersion (Version [1,0,2] [])) + (userMaybeSpecifyPath "uhc" hcPath conf) + + let comp = Compiler { + compilerId = CompilerId UHC uhcVersion, + compilerLanguages = uhcLanguages, + compilerExtensions = uhcLanguageExtensions + } + return (comp, conf') + +uhcLanguages :: [(Language, C.Flag)] +uhcLanguages = [(Haskell98, "")] + +-- | The flags for the supported extensions. +uhcLanguageExtensions :: [(Extension, C.Flag)] +uhcLanguageExtensions = + let doFlag (f, (enable, disable)) = [(EnableExtension f, enable), + (DisableExtension f, disable)] + alwaysOn = ("", ""{- wrong -}) + in concatMap doFlag + [(CPP, ("--cpp", ""{- wrong -})), + (PolymorphicComponents, alwaysOn), + (ExistentialQuantification, alwaysOn), + (ForeignFunctionInterface, alwaysOn), + (UndecidableInstances, alwaysOn), + (MultiParamTypeClasses, alwaysOn), + (Rank2Types, alwaysOn), + (PatternSignatures, alwaysOn), + (EmptyDataDecls, alwaysOn), + (ImplicitPrelude, ("", "--no-prelude"{- wrong -})), + (TypeOperators, alwaysOn), + (OverlappingInstances, alwaysOn), + (FlexibleInstances, alwaysOn)] + +getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity comp packagedbs conf = do + let compilerid = compilerId comp + systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram conf ["--meta-pkgdir-system"] + userPkgDir <- getUserPackageDir + let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs) + -- putStrLn $ "pkgdirs: " ++ show pkgDirs + -- call to "lines" necessary, because pkgdir contains an extra newline at the end + pkgs <- liftM (map addBuiltinVersions . concat) . + mapM (\ d -> getDirectoryContents d >>= filterM (isPkgDir (display compilerid) d)) . + concatMap lines $ pkgDirs + -- putStrLn $ "pkgs: " ++ show pkgs + let iPkgs = + map mkInstalledPackageInfo $ + concatMap parsePackage $ + pkgs + -- putStrLn $ "installed pkgs: " ++ show iPkgs + return (fromList iPkgs) + +getUserPackageDir :: IO FilePath +getUserPackageDir = + do + homeDir <- getHomeDirectory + return $ homeDir ".cabal" "lib" -- TODO: determine in some other way + +packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] +packageDbPaths user system db = + case db of + GlobalPackageDB -> [ system ] + UserPackageDB -> [ user ] + SpecificPackageDB path -> [ path ] + +-- | Hack to add version numbers to UHC-builtin packages. This should sooner or +-- later be fixed on the UHC side. +addBuiltinVersions :: String -> String +{- +addBuiltinVersions "uhcbase" = "uhcbase-1.0" +addBuiltinVersions "base" = "base-3.0" +addBuiltinVersions "array" = "array-0.2" +-} +addBuiltinVersions xs = xs + +-- | Name of the installed package config file. +installedPkgConfig :: String +installedPkgConfig = "installed-pkg-config" + +-- | Check if a certain dir contains a valid package. Currently, we are +-- looking only for the presence of an installed package configuration. +-- TODO: Actually make use of the information provided in the file. +isPkgDir :: String -> String -> String -> IO Bool +isPkgDir _ _ ('.' : _) = return False -- ignore files starting with a . +isPkgDir c dir xs = do + let candidate = dir uhcPackageDir xs c + -- putStrLn $ "trying: " ++ candidate + doesFileExist (candidate installedPkgConfig) + +parsePackage :: String -> [PackageId] +parsePackage x = map fst (filter (\ (_,y) -> null y) (readP_to_S parse x)) + +-- | Create a trivial package info from a directory name. +mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo +mkInstalledPackageInfo p = emptyInstalledPackageInfo + { installedPackageId = InstalledPackageId (display p), + sourcePackageId = p } + + +-- ----------------------------------------------------------------------------- +-- Building + +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + + systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"] + userPkgDir <- getUserPackageDir + let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi) + let uhcArgs = -- set package name + ["--pkg-build=" ++ display (packageId pkg_descr)] + -- common flags lib/exe + ++ constructUHCCmdLine userPkgDir systemPkgDir + lbi (libBuildInfo lib) clbi + (buildDir lbi) verbosity + -- source files + -- suboptimal: UHC does not understand module names, so + -- we replace periods by path separators + ++ map (map (\ c -> if c == '.' then pathSeparator else c)) + (map display (libModules lib)) + + runUhcProg uhcArgs + + return () + +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity _pkg_descr lbi exe clbi = do + systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"] + userPkgDir <- getUserPackageDir + let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi) + let uhcArgs = -- common flags lib/exe + constructUHCCmdLine userPkgDir systemPkgDir + lbi (buildInfo exe) clbi + (buildDir lbi) verbosity + -- output file + ++ ["--output", buildDir lbi exeName exe] + -- main source module + ++ [modulePath exe] + runUhcProg uhcArgs + +constructUHCCmdLine :: FilePath -> FilePath + -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> Verbosity -> [String] +constructUHCCmdLine user system lbi bi clbi odir verbosity = + -- verbosity + (if verbosity >= deafening then ["-v4"] + else if verbosity >= normal then [] + else ["-v0"]) + ++ hcOptions UHC bi + -- flags for language extensions + ++ languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) + -- packages + ++ ["--hide-all-packages"] + ++ uhcPackageDbOptions user system (withPackageDB lbi) + ++ ["--package=uhcbase"] + ++ ["--package=" ++ display (pkgName pkgid) | (_, pkgid) <- componentPackageDeps clbi ] + -- search paths + ++ ["-i" ++ odir] + ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] + ++ ["-i" ++ autogenModulesDir lbi] + -- output path + ++ ["--odir=" ++ odir] + -- optimization + ++ (case withOptimization lbi of + NoOptimisation -> ["-O0"] + NormalOptimisation -> ["-O1"] + MaximumOptimisation -> ["-O2"]) + +uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String] +uhcPackageDbOptions user system db = map (\ x -> "--pkg-searchpath=" ++ x) + (concatMap (packageDbPaths user system) db) + +-- ----------------------------------------------------------------------------- +-- Installation + +installLib :: Verbosity -> LocalBuildInfo + -> FilePath -> FilePath -> FilePath + -> PackageDescription -> Library -> IO () +installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library = do + -- putStrLn $ "dest: " ++ targetDir + -- putStrLn $ "built: " ++ builtDir + installDirectoryContents verbosity (builtDir display (packageId pkg)) targetDir + +-- currently hardcoded UHC code generator and variant to use +uhcTarget, uhcTargetVariant :: String +uhcTarget = "bc" +uhcTargetVariant = "plain" + +-- root directory for a package in UHC +uhcPackageDir :: String -> String -> FilePath +uhcPackageSubDir :: String -> FilePath +uhcPackageDir pkgid compilerid = pkgid uhcPackageSubDir compilerid +uhcPackageSubDir compilerid = compilerid uhcTarget uhcTargetVariant + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage + :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do + let installDirs = absoluteInstallDirs pkg lbi NoCopyDest + pkgdir | inplace = buildDir lbi uhcPackageDir (display pkgid) (display compilerid) + | otherwise = libdir installDirs uhcPackageSubDir (display compilerid) + createDirectoryIfMissingVerbose verbosity True pkgdir + writeUTF8File (pkgdir installedPkgConfig) + (showInstalledPackageInfo installedPkgInfo) + where + pkgid = packageId pkg + compilerid = compilerId (compiler lbi) diff --git a/cabal/cabal/Distribution/Simple/UserHooks.hs b/cabal/cabal/Distribution/Simple/UserHooks.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/UserHooks.hs @@ -0,0 +1,220 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.UserHooks +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines the API that @Setup.hs@ scripts can use to customise the way +-- the build works. This module just defines the 'UserHooks' type. The +-- predefined sets of hooks that implement the @Simple@, @Make@ and @Configure@ +-- build systems are defined in "Distribution.Simple". The 'UserHooks' is a big +-- record of functions. There are 3 for each action, a pre, post and the action +-- itself. There are few other miscellaneous hooks, ones to extend the set of +-- programs and preprocessors and one to override the function used to read the +-- @.cabal@ file. +-- +-- This hooks type is widely agreed to not be the right solution. Partly this +-- is because changes to it usually break custom @Setup.hs@ files and yet many +-- internal code changes do require changes to the hooks. For example we cannot +-- pass any extra parameters to most of the functions that implement the +-- various phases because it would involve changing the types of the +-- corresponding hook. At some point it will have to be replaced. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.UserHooks ( + UserHooks(..), Args, + emptyUserHooks, + ) where + +import Distribution.PackageDescription + (PackageDescription, GenericPackageDescription, + HookedBuildInfo, emptyHookedBuildInfo) +import Distribution.Simple.Program (Program) +import Distribution.Simple.Command (noExtraFlags) +import Distribution.Simple.PreProcess (PPSuffixHandler) +import Distribution.Simple.Setup + (ConfigFlags, BuildFlags, CleanFlags, CopyFlags, + InstallFlags, SDistFlags, RegisterFlags, HscolourFlags, + HaddockFlags, TestFlags) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) + +type Args = [String] + +-- | Hooks allow authors to add specific functionality before and after a +-- command is run, and also to specify additional preprocessors. +-- +-- * WARNING: The hooks interface is under rather constant flux as we try to +-- understand users needs. Setup files that depend on this interface may +-- break in future releases. +data UserHooks = UserHooks { + + -- | Used for @.\/setup test@ + runTests :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO (), + -- | Read the description file + readDesc :: IO (Maybe GenericPackageDescription), + -- | Custom preprocessors in addition to and overriding 'knownSuffixHandlers'. + hookedPreProcessors :: [ PPSuffixHandler ], + -- | These programs are detected at configure time. Arguments for them are + -- added to the configure command. + hookedPrograms :: [Program], + + -- |Hook to run before configure command + preConf :: Args -> ConfigFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during configure. + confHook :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags -> IO LocalBuildInfo, + -- |Hook to run after configure command + postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before build command. Second arg indicates verbosity level. + preBuild :: Args -> BuildFlags -> IO HookedBuildInfo, + + -- |Over-ride this hook to gbet different behavior during build. + buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO (), + -- |Hook to run after build command. Second arg indicates verbosity level. + postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before clean command. Second arg indicates verbosity level. + preClean :: Args -> CleanFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during clean. + cleanHook :: PackageDescription -> () -> UserHooks -> CleanFlags -> IO (), + -- |Hook to run after clean command. Second arg indicates verbosity level. + postClean :: Args -> CleanFlags -> PackageDescription -> () -> IO (), + + -- |Hook to run before copy command + preCopy :: Args -> CopyFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during copy. + copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO (), + -- |Hook to run after copy command + postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before install command + preInst :: Args -> InstallFlags -> IO HookedBuildInfo, + + -- |Over-ride this hook to get different behavior during install. + instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO (), + -- |Hook to run after install command. postInst should be run + -- on the target, not on the build machine. + postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before sdist command. Second arg indicates verbosity level. + preSDist :: Args -> SDistFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during sdist. + sDistHook :: PackageDescription -> Maybe LocalBuildInfo -> UserHooks -> SDistFlags -> IO (), + -- |Hook to run after sdist command. Second arg indicates verbosity level. + postSDist :: Args -> SDistFlags -> PackageDescription -> Maybe LocalBuildInfo -> IO (), + + -- |Hook to run before register command + preReg :: Args -> RegisterFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during registration. + regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), + -- |Hook to run after register command + postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before unregister command + preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during registration. + unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), + -- |Hook to run after unregister command + postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before hscolour command. Second arg indicates verbosity level. + preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during hscolour. + hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO (), + -- |Hook to run after hscolour command. Second arg indicates verbosity level. + postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before haddock command. Second arg indicates verbosity level. + preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during haddock. + haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO (), + -- |Hook to run after haddock command. Second arg indicates verbosity level. + postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before test command. + preTest :: Args -> TestFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during test. + testHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (), + -- |Hook to run after test command. + postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO () + } + +{-# DEPRECATED runTests "Please use the new testing interface instead!" #-} + +-- |Empty 'UserHooks' which do nothing. +emptyUserHooks :: UserHooks +emptyUserHooks + = UserHooks { + runTests = ru, + readDesc = return Nothing, + hookedPreProcessors = [], + hookedPrograms = [], + preConf = rn, + confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")), + postConf = ru, + preBuild = rn, + buildHook = ru, + postBuild = ru, + preClean = rn, + cleanHook = ru, + postClean = ru, + preCopy = rn, + copyHook = ru, + postCopy = ru, + preInst = rn, + instHook = ru, + postInst = ru, + preSDist = rn, + sDistHook = ru, + postSDist = ru, + preReg = rn, + regHook = ru, + postReg = ru, + preUnreg = rn, + unregHook = ru, + postUnreg = ru, + preHscolour = rn, + hscolourHook = ru, + postHscolour = ru, + preHaddock = rn, + haddockHook = ru, + postHaddock = ru, + preTest = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without + -- noExtraFlags + testHook = ru, + postTest = ru + } + where rn args _ = noExtraFlags args >> return emptyHookedBuildInfo + ru _ _ _ _ = return () diff --git a/cabal/cabal/Distribution/Simple/Utils.hs b/cabal/cabal/Distribution/Simple/Utils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Simple/Utils.hs @@ -0,0 +1,1131 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp -fffi #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Utils +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- portions Copyright (c) 2007, Galois Inc. +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A large and somewhat miscellaneous collection of utility functions used +-- throughout the rest of the Cabal lib and in other tools that use the Cabal +-- lib like @cabal-install@. It has a very simple set of logging actions. It +-- has low level functions for running programs, a bunch of wrappers for +-- various directory and file functions that do extra logging. + +{- 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 ( + cabalVersion, + + -- * logging and errors + die, + dieWithLocation, + topHandler, + warn, notice, setupMessage, info, debug, + chattyTry, + + -- * running programs + rawSystemExit, + rawSystemExitWithEnv, + rawSystemStdout, + rawSystemStdInOut, + maybeExit, + xargs, + findProgramLocation, + findProgramVersion, + + -- * copying files + smartCopySources, + createDirectoryIfMissingVerbose, + copyFileVerbose, + copyDirectoryRecursiveVerbose, + copyFiles, + + -- * installing files + installOrdinaryFile, + installExecutableFile, + installOrdinaryFiles, + installDirectoryContents, + + -- * File permissions + setFileOrdinary, + setFileExecutable, + + -- * file names + currentDir, + + -- * finding files + findFile, + findFirstFile, + findFileWithExtension, + findFileWithExtension', + findModuleFile, + findModuleFiles, + getDirectoryContentsRecursive, + + -- * simple file globbing + matchFileGlob, + matchDirFileGlob, + parseFileGlob, + FileGlob(..), + + -- * temp files and dirs + withTempFile, + withTempDirectory, + + -- * .cabal and .buildinfo files + defaultPackageDesc, + findPackageDesc, + defaultHookedPackageDesc, + findHookedPackageDesc, + + -- * reading and writing files safely + withFileContents, + writeFileAtomic, + rewriteFile, + + -- * Unicode + fromUTF8, + toUTF8, + readUTF8File, + withUTF8FileContents, + writeUTF8File, + normaliseLineEndings, + + -- * generic utils + equating, + comparing, + isInfixOf, + intercalate, + lowercase, + wrapText, + wrapLine, + ) where + +import Control.Monad + ( when, unless, filterM ) +#ifdef __GLASGOW_HASKELL__ +import Control.Concurrent.MVar + ( newEmptyMVar, putMVar, takeMVar ) +#endif +import Data.List + ( nub, unfoldr, isPrefixOf, tails, intersperse ) +import Data.Char as Char + ( toLower, chr, ord ) +import Data.Bits + ( Bits((.|.), (.&.), shiftL, shiftR) ) + +import System.Directory + ( getDirectoryContents, doesDirectoryExist, doesFileExist, removeFile + , findExecutable ) +import System.Environment + ( getProgName ) +import System.Cmd + ( rawSystem ) +import System.Exit + ( exitWith, ExitCode(..) ) +import System.FilePath + ( normalise, (), (<.>), takeDirectory, splitFileName + , splitExtension, splitExtensions, splitDirectories ) +import System.Directory + ( createDirectory, renameFile, removeDirectoryRecursive ) +import System.IO + ( Handle, openFile, openBinaryFile, IOMode(ReadMode), hSetBinaryMode + , hGetContents, stderr, stdout, hPutStr, hFlush, hClose ) +import System.IO.Error as IO.Error + ( isDoesNotExistError, isAlreadyExistsError + , ioeSetFileName, ioeGetFileName, ioeGetErrorString ) +#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608)) +import System.IO.Error + ( ioeSetLocation, ioeGetLocation ) +#endif +import System.IO.Unsafe + ( unsafeInterleaveIO ) +import qualified Control.Exception as Exception + +import Distribution.Text + ( display, simpleParse ) +import Distribution.Package + ( PackageIdentifier ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Version + (Version(..)) + +import Control.Exception (evaluate) +import System.Process (runProcess) + +#ifdef __GLASGOW_HASKELL__ +import Control.Concurrent (forkIO) +import System.Process (runInteractiveProcess, waitForProcess) +#else +import System.Cmd (system) +import System.Directory (getTemporaryDirectory) +#endif + +import Distribution.Compat.CopyFile + ( copyFile, copyOrdinaryFile, copyExecutableFile + , setFileOrdinary, setFileExecutable, setDirOrdinary ) +import Distribution.Compat.TempFile + ( openTempFile, openNewBinaryFile, createTempDirectory ) +import Distribution.Compat.Exception + ( IOException, throwIOIO, tryIO, catchIO, catchExit, onException ) +import Distribution.Verbosity + +#ifdef VERSION_base +import qualified Paths_Cabal (version) +#endif + +-- We only get our own version number when we're building with ourselves +cabalVersion :: Version +#if defined(VERSION_base) +cabalVersion = Paths_Cabal.version +#elif defined(CABAL_VERSION) +cabalVersion = Version [CABAL_VERSION] [] +#else +cabalVersion = Version [1,9999] [] --used when bootstrapping +#endif + +-- ---------------------------------------------------------------------------- +-- Exception and logging utils + +dieWithLocation :: FilePath -> Maybe Int -> String -> IO a +dieWithLocation filename lineno msg = + ioError . setLocation lineno + . flip ioeSetFileName (normalise filename) + $ userError msg + where +#if defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608) + setLocation _ err = err +#else + setLocation Nothing err = err + setLocation (Just n) err = ioeSetLocation err (show n) +#endif + +die :: String -> IO a +die msg = ioError (userError msg) + +topHandler :: IO a -> IO a +topHandler prog = catchIO prog handle + where + handle ioe = do + hFlush stdout + pname <- getProgName + hPutStr stderr (mesage pname) + exitWith (ExitFailure 1) + where + mesage pname = wrapText (pname ++ ": " ++ file ++ detail) + file = case ioeGetFileName ioe of + Nothing -> "" + Just path -> path ++ location ++ ": " +#if defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608) + location = "" +#else + location = case ioeGetLocation ioe of + l@(n:_) | n >= '0' && n <= '9' -> ':' : l + _ -> "" +#endif + detail = ioeGetErrorString ioe + +-- | Non fatal conditions that may be indicative of an error or problem. +-- +-- We display these at the 'normal' verbosity level. +-- +warn :: Verbosity -> String -> IO () +warn verbosity msg = + when (verbosity >= normal) $ do + hFlush stdout + hPutStr stderr (wrapText ("Warning: " ++ msg)) + +-- | Useful status messages. +-- +-- We display these at the 'normal' verbosity level. +-- +-- This is for the ordinary helpful status messages that users see. Just +-- enough information to know that things are working but not floods of detail. +-- +notice :: Verbosity -> String -> IO () +notice verbosity msg = + when (verbosity >= normal) $ + putStr (wrapText msg) + +setupMessage :: Verbosity -> String -> PackageIdentifier -> IO () +setupMessage verbosity msg pkgid = + notice verbosity (msg ++ ' ': display pkgid ++ "...") + +-- | More detail on the operation of some action. +-- +-- We display these messages when the verbosity level is 'verbose' +-- +info :: Verbosity -> String -> IO () +info verbosity msg = + when (verbosity >= verbose) $ + putStr (wrapText msg) + +-- | Detailed internal debugging information +-- +-- We display these messages when the verbosity level is 'deafening' +-- +debug :: Verbosity -> String -> IO () +debug verbosity msg = + when (verbosity >= deafening) $ do + putStr (wrapText msg) + hFlush stdout + +-- | Perform an IO action, catching any IO exceptions and printing an error +-- if one occurs. +chattyTry :: String -- ^ a description of the action we were attempting + -> IO () -- ^ the action itself + -> IO () +chattyTry desc action = + catchIO action $ \exception -> + putStrLn $ "Error while " ++ desc ++ ": " ++ show exception + +-- ----------------------------------------------------------------------------- +-- Helper functions + +-- | Wraps text to the default line width. Existing newlines are preserved. +wrapText :: String -> String +wrapText = unlines + . concatMap (map unwords + . wrapLine 79 + . words) + . lines + +-- | Wraps a list of words to a list of lines of words of a particular width. +wrapLine :: Int -> [String] -> [[String]] +wrapLine width = wrap 0 [] + where wrap :: Int -> [String] -> [String] -> [[String]] + wrap 0 [] (w:ws) + | length w + 1 > width + = wrap (length w) [w] ws + wrap col line (w:ws) + | col + length w + 1 > width + = reverse line : wrap 0 [] (w:ws) + wrap col line (w:ws) + = let col' = col + length w + 1 + in wrap col' (w:line) ws + wrap _ [] [] = [] + wrap _ line [] = [reverse line] + +-- ----------------------------------------------------------------------------- +-- rawSystem variants +maybeExit :: IO ExitCode -> IO () +maybeExit cmd = do + res <- cmd + unless (res == ExitSuccess) $ exitWith res + +printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () +printRawCommandAndArgs verbosity path args + | verbosity >= deafening = print (path, args) + | verbosity >= verbose = putStrLn $ unwords (path : args) + | otherwise = return () + +printRawCommandAndArgsAndEnv :: Verbosity + -> FilePath + -> [String] + -> [(String, String)] + -> IO () +printRawCommandAndArgsAndEnv verbosity path args env + | verbosity >= deafening = do putStrLn ("Environment: " ++ show env) + print (path, args) + | verbosity >= verbose = putStrLn $ unwords (path : args) + | otherwise = return () + +-- Exit with the same exitcode if the subcommand fails +rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () +rawSystemExit verbosity path args = do + printRawCommandAndArgs verbosity path args + hFlush stdout + exitcode <- rawSystem path args + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + exitWith exitcode + +rawSystemExitWithEnv :: Verbosity + -> FilePath + -> [String] + -> [(String, String)] + -> IO () +rawSystemExitWithEnv verbosity path args env = do + printRawCommandAndArgsAndEnv verbosity path args env + hFlush stdout + ph <- runProcess path args Nothing (Just env) Nothing Nothing Nothing + exitcode <- waitForProcess ph + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + exitWith exitcode + +-- | Run a command and return its output. +-- +-- The output is assumed to be text in the locale encoding. +-- +rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String +rawSystemStdout verbosity path args = do + (output, errors, exitCode) <- rawSystemStdInOut verbosity path args + Nothing False + when (exitCode /= ExitSuccess) $ + die errors + return output + +-- | Run a command and return its output, errors and exit status. Optionally +-- also supply some input. Also provides control over whether the binary/text +-- mode of the input and output. +-- +rawSystemStdInOut :: Verbosity + -> FilePath -> [String] + -> Maybe (String, Bool) -- ^ input text and binary mode + -> Bool -- ^ output in binary mode + -> IO (String, String, ExitCode) -- ^ output, errors, exit +rawSystemStdInOut verbosity path args input outputBinary = do + printRawCommandAndArgs verbosity path args + +#ifdef __GLASGOW_HASKELL__ + Exception.bracket + (runInteractiveProcess path args Nothing Nothing) + (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh) + $ \(inh,outh,errh,pid) -> do + + -- output mode depends on what the caller wants + hSetBinaryMode outh outputBinary + -- but the errors are always assumed to be text (in the current locale) + hSetBinaryMode errh False + + -- fork off a couple threads to pull on the stderr and stdout + -- so if the process writes to stderr we do not block. + + err <- hGetContents errh + out <- hGetContents outh + + mv <- newEmptyMVar + let force str = (evaluate (length str) >> return ()) + `Exception.finally` putMVar mv () + --TODO: handle exceptions like text decoding. + _ <- forkIO $ force out + _ <- forkIO $ force err + + -- push all the input, if any + case input of + Nothing -> return () + Just (inputStr, inputBinary) -> do + -- input mode depends on what the caller wants + hSetBinaryMode inh inputBinary + hPutStr inh inputStr + hClose inh + --TODO: this probably fails if the process refuses to consume + -- or if it closes stdin (eg if it exits) + + -- wait for both to finish, in either order + takeMVar mv + takeMVar mv + + -- wait for the program to terminate + exitcode <- waitForProcess pid + unless (exitcode == ExitSuccess) $ + debug verbosity $ path ++ " returned " ++ show exitcode + ++ if null err then "" else + " with error message:\n" ++ err + + return (out, err, exitcode) +#else + tmpDir <- getTemporaryDirectory + withTempFile tmpDir ".cmd.stdout" $ \outName outHandle -> + withTempFile tmpDir ".cmd.stdin" $ \inName inHandle -> do + hClose outHandle + + case input of + Nothing -> return () + Just (inputStr, inputBinary) -> do + hSetBinaryMode inHandle inputBinary + hPutStr inHandle inputStr + hClose inHandle + + let quote name = "'" ++ name ++ "'" + cmd = unwords (map quote (path:args)) + ++ " <" ++ quote inName + ++ " >" ++ quote outName + exitcode <- system cmd + + unless (exitcode == ExitSuccess) $ + debug verbosity $ path ++ " returned " ++ show exitcode + + Exception.bracket (openFile outName ReadMode) hClose $ \hnd -> do + hSetBinaryMode hnd outputBinary + output <- hGetContents hnd + length output `seq` return (output, "", exitcode) +#endif + + +-- | Look for a program on the path. +findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath) +findProgramLocation verbosity prog = do + debug verbosity $ "searching for " ++ prog ++ " in path." + res <- findExecutable prog + case res of + Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") + Just path -> debug verbosity ("found " ++ prog ++ " at "++ path) + return res + + +-- | Look for a program and try to find it's version number. It can accept +-- either an absolute path or the name of a program binary, in which case we +-- will look for the program on the path. +-- +findProgramVersion :: String -- ^ version args + -> (String -> String) -- ^ function to select version + -- number from program output + -> Verbosity + -> FilePath -- ^ location + -> IO (Maybe Version) +findProgramVersion versionArg selectVersion verbosity path = do + str <- rawSystemStdout verbosity path [versionArg] + `catchIO` (\_ -> return "") + `catchExit` (\_ -> return "") + let version :: Maybe Version + version = simpleParse (selectVersion str) + case version of + Nothing -> warn verbosity $ "cannot determine version of " ++ path + ++ " :\n" ++ show str + Just v -> debug verbosity $ path ++ " is version " ++ display v + return version + + +-- | 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) (rawSystemExit verbosity) prog fixedArgs bigArgs +-- +xargs :: Int -> ([String] -> IO ()) + -> [String] -> [String] -> IO () +xargs maxSize rawSystemFun fixedArgs bigArgs = + let fixedArgSize = sum (map length fixedArgs) + length fixedArgs + chunkSize = maxSize - fixedArgSize + in mapM_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs) + + where chunks len = unfoldr $ \s -> + if null s then Nothing + else Just (chunk [] len s) + + chunk acc _ [] = (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 +-- ------------------------------------------------------------ + +---------------- +-- Finding files + +-- | Find a file by looking in a search path. The file path must match exactly. +-- +findFile :: [FilePath] -- ^search locations + -> FilePath -- ^File Name + -> IO FilePath +findFile searchPath fileName = + findFirstFile id + [ path fileName + | path <- nub searchPath] + >>= maybe (die $ fileName ++ " doesn't exist") return + +-- | Find a file by looking in a search path with one of a list of possible +-- file extensions. The file base name should be given and it will be tried +-- with each of the extensions in each element of the search path. +-- +findFileWithExtension :: [String] + -> [FilePath] + -> FilePath + -> IO (Maybe FilePath) +findFileWithExtension extensions searchPath baseName = + findFirstFile id + [ path baseName <.> ext + | path <- nub searchPath + , ext <- nub extensions ] + +-- | Like 'findFileWithExtension' but returns which element of the search path +-- the file was found in, and the file path relative to that base directory. +-- +findFileWithExtension' :: [String] + -> [FilePath] + -> FilePath + -> IO (Maybe (FilePath, FilePath)) +findFileWithExtension' extensions searchPath baseName = + findFirstFile (uncurry ()) + [ (path, baseName <.> ext) + | path <- nub searchPath + , ext <- nub extensions ] + +findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) +findFirstFile file = findFirst + where findFirst [] = return Nothing + findFirst (x:xs) = do exists <- doesFileExist (file x) + if exists + then return (Just x) + else findFirst xs + +-- | Finds the files corresponding to a list of Haskell module names. +-- +-- As 'findModuleFile' but for a list of module names. +-- +findModuleFiles :: [FilePath] -- ^ build prefix (location of objects) + -> [String] -- ^ search suffixes + -> [ModuleName] -- ^ modules + -> IO [(FilePath, FilePath)] +findModuleFiles searchPath extensions moduleNames = + mapM (findModuleFile searchPath extensions) moduleNames + +-- | Find the file corresponding to a Haskell module name. +-- +-- This is similar to 'findFileWithExtension'' but specialised to a module +-- name. The function fails if the file corresponding to the module is missing. +-- +findModuleFile :: [FilePath] -- ^ build prefix (location of objects) + -> [String] -- ^ search suffixes + -> ModuleName -- ^ module + -> IO (FilePath, FilePath) +findModuleFile searchPath extensions moduleName = + maybe notFound return + =<< findFileWithExtension' extensions searchPath + (ModuleName.toFilePath moduleName) + where + notFound = die $ "Error: Could not find module: " ++ display moduleName + ++ " with any suffix: " ++ show extensions + ++ " in the search path: " ++ show searchPath + +-- | List all the files in a directory and all subdirectories. +-- +-- The order places files in sub-directories after all the files in their +-- parent directories. The list is generated lazily so is not well defined if +-- the source directory structure changes before the list is used. +-- +getDirectoryContentsRecursive :: FilePath -> IO [FilePath] +getDirectoryContentsRecursive topdir = recurseDirectories [""] + where + recurseDirectories :: [FilePath] -> IO [FilePath] + recurseDirectories [] = return [] + recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do + (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) + files' <- recurseDirectories (dirs' ++ dirs) + return (files ++ files') + + where + collect files dirs' [] = return (reverse files, reverse dirs') + collect files dirs' (entry:entries) | ignore entry + = collect files dirs' entries + collect files dirs' (entry:entries) = do + let dirEntry = dir entry + isDirectory <- doesDirectoryExist (topdir dirEntry) + if isDirectory + then collect files (dirEntry:dirs') entries + else collect (dirEntry:files) dirs' entries + + ignore ['.'] = True + ignore ['.', '.'] = True + ignore _ = False + +---------------- +-- File globbing + +data FileGlob + -- | No glob at all, just an ordinary file + = NoGlob FilePath + + -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to + -- @FileGlob \"foo\/bar\" \".baz\"@ + | FileGlob FilePath String + +parseFileGlob :: FilePath -> Maybe FileGlob +parseFileGlob filepath = case splitExtensions filepath of + (filepath', ext) -> case splitFileName filepath' of + (dir, "*") | '*' `elem` dir + || '*' `elem` ext + || null ext -> Nothing + | null dir -> Just (FileGlob "." ext) + | otherwise -> Just (FileGlob dir ext) + _ | '*' `elem` filepath -> Nothing + | otherwise -> Just (NoGlob filepath) + +matchFileGlob :: FilePath -> IO [FilePath] +matchFileGlob = matchDirFileGlob "." + +matchDirFileGlob :: FilePath -> FilePath -> IO [FilePath] +matchDirFileGlob dir filepath = case parseFileGlob filepath of + Nothing -> die $ "invalid file glob '" ++ filepath + ++ "'. Wildcards '*' are only allowed in place of the file" + ++ " name, not in the directory name or file extension." + ++ " If a wildcard is used it must be with an file extension." + Just (NoGlob filepath') -> return [filepath'] + Just (FileGlob dir' ext) -> do + files <- getDirectoryContents (dir dir') + case [ dir' file + | file <- files + , let (name, ext') = splitExtensions file + , not (null name) && ext' == ext ] of + [] -> die $ "filepath wildcard '" ++ filepath + ++ "' does not match any files." + matches -> return matches + +---------------------------------------- +-- Copying and installing files and dirs + +-- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels. +-- +createDirectoryIfMissingVerbose :: Verbosity + -> Bool -- ^ Create its parents too? + -> FilePath + -> IO () +createDirectoryIfMissingVerbose verbosity create_parents path0 + | create_parents = createDirs (parents path0) + | otherwise = createDirs (take 1 (parents path0)) + where + parents = reverse . scanl1 () . splitDirectories . normalise + + createDirs [] = return () + createDirs (dir:[]) = createDir dir throwIOIO + createDirs (dir:dirs) = + createDir dir $ \_ -> do + createDirs dirs + createDir dir throwIOIO + + createDir :: FilePath -> (IOException -> IO ()) -> IO () + createDir dir notExistHandler = do + r <- tryIO $ createDirectoryVerbose verbosity dir + case (r :: Either IOException ()) of + Right () -> return () + Left e + | isDoesNotExistError e -> notExistHandler e + -- createDirectory (and indeed POSIX mkdir) does not distinguish + -- between a dir already existing and a file already existing. So we + -- check for it here. Unfortunately there is a slight race condition + -- here, but we think it is benign. It could report an exeption in + -- the case that the dir did exist but another process deletes the + -- directory and creates a file in its place before we can check + -- that the directory did indeed exist. + | isAlreadyExistsError e -> (do + isDir <- doesDirectoryExist dir + if isDir then return () + else throwIOIO e + ) `catchIO` ((\_ -> return ()) :: IOException -> IO ()) + | otherwise -> throwIOIO e + +createDirectoryVerbose :: Verbosity -> FilePath -> IO () +createDirectoryVerbose verbosity dir = do + info verbosity $ "creating " ++ dir + createDirectory dir + setDirOrdinary dir + +-- | Copies a file without copying file permissions. The target file is created +-- with default permissions. Any existing target file is replaced. +-- +-- At higher verbosity levels it logs an info message. +-- +copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO () +copyFileVerbose verbosity src dest = do + info verbosity ("copy " ++ src ++ " to " ++ dest) + copyFile src dest + +-- | Install an ordinary file. This is like a file copy but the permissions +-- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\" +-- while on Windows it uses the default permissions for the target directory. +-- +installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO () +installOrdinaryFile verbosity src dest = do + info verbosity ("Installing " ++ src ++ " to " ++ dest) + copyOrdinaryFile src dest + +-- | Install an executable file. This is like a file copy but the permissions +-- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\" +-- while on Windows it uses the default permissions for the target directory. +-- +installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () +installExecutableFile verbosity src dest = do + info verbosity ("Installing executable " ++ src ++ " to " ++ dest) + copyExecutableFile src dest + +-- | Copies a bunch of files to a target directory, preserving the directory +-- structure in the target location. The target directories are created if they +-- do not exist. +-- +-- The files are identified by a pair of base directory and a path relative to +-- that base. It is only the relative part that is preserved in the +-- destination. +-- +-- For example: +-- +-- > copyFiles normal "dist/src" +-- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")] +-- +-- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and +-- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\". +-- +-- This operation is not atomic. Any IO failure during the copy (including any +-- missing source files) leaves the target in an unknown state so it is best to +-- use it with a freshly created directory so that it can be simply deleted if +-- anything goes wrong. +-- +copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +copyFiles verbosity targetDir srcFiles = do + + -- Create parent directories for everything + let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles + mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs + + -- Copy all the files + sequence_ [ let src = srcBase srcFile + dest = targetDir srcFile + in copyFileVerbose verbosity src dest + | (srcBase, srcFile) <- srcFiles ] + +-- | This is like 'copyFiles' but uses 'installOrdinaryFile'. +-- +installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +installOrdinaryFiles verbosity targetDir srcFiles = do + + -- Create parent directories for everything + let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles + mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs + + -- Copy all the files + sequence_ [ let src = srcBase srcFile + dest = targetDir srcFile + in installOrdinaryFile verbosity src dest + | (srcBase, srcFile) <- srcFiles ] + +-- | This installs all the files in a directory to a target location, +-- preserving the directory layout. All the files are assumed to be ordinary +-- rather than executable files. +-- +installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO () +installDirectoryContents verbosity srcDir destDir = do + info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") + srcFiles <- getDirectoryContentsRecursive srcDir + installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] + +--------------------------------- +-- Deprecated file copy functions + +{-# DEPRECATED smartCopySources + "Use findModuleFiles and copyFiles or installOrdinaryFiles" #-} +smartCopySources :: Verbosity -> [FilePath] -> FilePath + -> [ModuleName] -> [String] -> IO () +smartCopySources verbosity searchPath targetDir moduleNames extensions = + findModuleFiles searchPath extensions moduleNames + >>= copyFiles verbosity targetDir + +{-# DEPRECATED copyDirectoryRecursiveVerbose + "You probably want installDirectoryContents instead" #-} +copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO () +copyDirectoryRecursiveVerbose verbosity srcDir destDir = do + info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") + srcFiles <- getDirectoryContentsRecursive srcDir + copyFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] + +--------------------------- +-- Temporary files and dirs + +-- | Use a temporary filename that doesn't already exist. +-- +withTempFile :: FilePath -- ^ Temp dir to create the file in + -> String -- ^ File name template. See 'openTempFile'. + -> (FilePath -> Handle -> IO a) -> IO a +withTempFile tmpDir template action = + Exception.bracket + (openTempFile tmpDir template) + (\(name, handle) -> hClose handle >> removeFile name) + (uncurry action) + +-- | Create and use a temporary directory. +-- +-- Creates a new temporary directory inside the given directory, making use +-- of the template. The temp directory is deleted after use. For example: +-- +-- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... +-- +-- The @tmpDir@ will be a new subdirectory of the given directory, e.g. +-- @src/sdist.342@. +-- +withTempDirectory :: Verbosity -> FilePath -> String -> (FilePath -> IO a) -> IO a +withTempDirectory _verbosity targetDir template = + Exception.bracket + (createTempDirectory targetDir template) + (removeDirectoryRecursive) + +----------------------------------- +-- Safely reading and writing files + +-- | Gets the contents of a file, but guarantee that it gets closed. +-- +-- The file is read lazily but if it is not fully consumed by the action then +-- the remaining input is truncated and the file is closed. +-- +withFileContents :: FilePath -> (String -> IO a) -> IO a +withFileContents name action = + Exception.bracket (openFile name ReadMode) hClose + (\hnd -> hGetContents hnd >>= action) + +-- | Writes a file atomically. +-- +-- The file is either written sucessfully or an IO exception is raised and +-- the original file is left unchanged. +-- +-- On windows it is not possible to delete a file that is open by a process. +-- This case will give an IO exception but the atomic property is not affected. +-- +writeFileAtomic :: FilePath -> String -> IO () +writeFileAtomic targetFile content = do + (tmpFile, tmpHandle) <- openNewBinaryFile targetDir template + do hPutStr tmpHandle content + hClose tmpHandle + renameFile tmpFile targetFile + `onException` do hClose tmpHandle + removeFile tmpFile + where + template = targetName <.> "tmp" + targetDir | null targetDir_ = currentDir + | otherwise = targetDir_ + --TODO: remove this when takeDirectory/splitFileName is fixed + -- to always return a valid dir + (targetDir_,targetName) = splitFileName targetFile + +-- | Write a file but only if it would have new content. If we would be writing +-- the same as the existing content then leave the file as is so that we do not +-- update the file's modification time. +-- +rewriteFile :: FilePath -> String -> IO () +rewriteFile path newContent = + flip catchIO mightNotExist $ do + existingContent <- readFile path + _ <- evaluate (length existingContent) + unless (existingContent == newContent) $ + writeFileAtomic path newContent + where + mightNotExist e | isDoesNotExistError e = writeFileAtomic path newContent + | otherwise = ioError e + +-- | 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 = "." + +-- ------------------------------------------------------------ +-- * Finding the description file +-- ------------------------------------------------------------ + +-- |Package description file (/pkgname/@.cabal@) +defaultPackageDesc :: Verbosity -> IO FilePath +defaultPackageDesc _verbosity = findPackageDesc currentDir + +-- |Find a package description file in the given directory. Looks for +-- @.cabal@ files. +findPackageDesc :: FilePath -- ^Where to look + -> IO FilePath -- ^.cabal +findPackageDesc dir + = do files <- getDirectoryContents dir + -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal + -- file we filter to exclude dirs and null base file names: + cabalFiles <- filterM doesFileExist + [ dir file + | file <- files + , let (name, ext) = splitExtension file + , not (null name) && ext == ".cabal" ] + case cabalFiles of + [] -> noDesc + [cabalFile] -> return cabalFile + multiple -> multiDesc multiple + + where + noDesc :: IO a + noDesc = die $ "No cabal file found.\n" + ++ "Please create a package description file .cabal" + + multiDesc :: [String] -> IO a + multiDesc l = die $ "Multiple cabal files found.\n" + ++ "Please use only one of: " + ++ show l + +-- |Optional auxiliary package information file (/pkgname/@.buildinfo@) +defaultHookedPackageDesc :: IO (Maybe FilePath) +defaultHookedPackageDesc = findHookedPackageDesc currentDir + +-- |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 + files <- getDirectoryContents dir + buildInfoFiles <- filterM doesFileExist + [ dir file + | file <- files + , let (name, ext) = splitExtension file + , not (null name) && ext == buildInfoExt ] + case buildInfoFiles of + [] -> return Nothing + [f] -> return (Just f) + _ -> die ("Multiple files with extension " ++ buildInfoExt) + +buildInfoExt :: String +buildInfoExt = ".buildinfo" + +-- ------------------------------------------------------------ +-- * Unicode stuff +-- ------------------------------------------------------------ + +-- This is a modification of the UTF8 code from gtk2hs and the +-- utf8-string package. + +fromUTF8 :: String -> String +fromUTF8 [] = [] +fromUTF8 (c:cs) + | c <= '\x7F' = c : fromUTF8 cs + | c <= '\xBF' = replacementChar : fromUTF8 cs + | c <= '\xDF' = twoBytes c cs + | c <= '\xEF' = moreBytes 3 0x800 cs (ord c .&. 0xF) + | c <= '\xF7' = moreBytes 4 0x10000 cs (ord c .&. 0x7) + | c <= '\xFB' = moreBytes 5 0x200000 cs (ord c .&. 0x3) + | c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1) + | otherwise = replacementChar : fromUTF8 cs + where + twoBytes c0 (c1:cs') + | ord c1 .&. 0xC0 == 0x80 + = let d = ((ord c0 .&. 0x1F) `shiftL` 6) + .|. (ord c1 .&. 0x3F) + in if d >= 0x80 + then chr d : fromUTF8 cs' + else replacementChar : fromUTF8 cs' + twoBytes _ cs' = replacementChar : fromUTF8 cs' + + moreBytes :: Int -> Int -> [Char] -> Int -> [Char] + moreBytes 1 overlong cs' acc + | overlong <= acc && acc <= 0x10FFFF + && (acc < 0xD800 || 0xDFFF < acc) + && (acc < 0xFFFE || 0xFFFF < acc) + = chr acc : fromUTF8 cs' + + | otherwise + = replacementChar : fromUTF8 cs' + + moreBytes byteCount overlong (cn:cs') acc + | ord cn .&. 0xC0 == 0x80 + = moreBytes (byteCount-1) overlong cs' + ((acc `shiftL` 6) .|. ord cn .&. 0x3F) + + moreBytes _ _ cs' _ + = replacementChar : fromUTF8 cs' + + replacementChar = '\xfffd' + +toUTF8 :: String -> String +toUTF8 [] = [] +toUTF8 (c:cs) + | c <= '\x07F' = c + : toUTF8 cs + | c <= '\x7FF' = chr (0xC0 .|. (w `shiftR` 6)) + : chr (0x80 .|. (w .&. 0x3F)) + : toUTF8 cs + | c <= '\xFFFF'= chr (0xE0 .|. (w `shiftR` 12)) + : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) + : chr (0x80 .|. (w .&. 0x3F)) + : toUTF8 cs + | otherwise = chr (0xf0 .|. (w `shiftR` 18)) + : chr (0x80 .|. ((w `shiftR` 12) .&. 0x3F)) + : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) + : chr (0x80 .|. (w .&. 0x3F)) + : toUTF8 cs + where w = ord c + +-- | Ignore a Unicode byte order mark (BOM) at the beginning of the input +-- +ignoreBOM :: String -> String +ignoreBOM ('\xFEFF':string) = string +ignoreBOM string = string + +-- | Reads a UTF8 encoded text file as a Unicode String +-- +-- Reads lazily using ordinary 'readFile'. +-- +readUTF8File :: FilePath -> IO String +readUTF8File f = fmap (ignoreBOM . fromUTF8) + . hGetContents =<< openBinaryFile f ReadMode + +-- | Reads a UTF8 encoded text file as a Unicode String +-- +-- Same behaviour as 'withFileContents'. +-- +withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a +withUTF8FileContents name action = + Exception.bracket + (openBinaryFile name ReadMode) + hClose + (\hnd -> hGetContents hnd >>= action . ignoreBOM . fromUTF8) + +-- | Writes a Unicode String as a UTF8 encoded text file. +-- +-- Uses 'writeFileAtomic', so provides the same guarantees. +-- +writeUTF8File :: FilePath -> String -> IO () +writeUTF8File path = writeFileAtomic path . toUTF8 + +-- | Fix different systems silly line ending conventions +normaliseLineEndings :: String -> String +normaliseLineEndings [] = [] +normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows +normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old osx +normaliseLineEndings ( c :s) = c : normaliseLineEndings s + +-- ------------------------------------------------------------ +-- * Common utils +-- ------------------------------------------------------------ + +equating :: Eq a => (b -> a) -> b -> b -> Bool +equating p x y = p x == p y + +comparing :: Ord a => (b -> a) -> b -> b -> Ordering +comparing p x y = p x `compare` p y + +isInfixOf :: String -> String -> Bool +isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) + +intercalate :: [a] -> [[a]] -> [a] +intercalate sep = concat . intersperse sep + +lowercase :: String -> String +lowercase = map Char.toLower diff --git a/cabal/cabal/Distribution/System.hs b/cabal/cabal/Distribution/System.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/System.hs @@ -0,0 +1,179 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.System +-- Copyright : Duncan Coutts 2007-2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Cabal often needs to do slightly different things on specific platforms. You +-- probably know about the 'System.Info.os' however using that is very +-- inconvenient because it is a string and different Haskell implementations +-- do not agree on using the same strings for the same platforms! (In +-- particular see the controversy over \"windows\" vs \"ming32\"). So to make it +-- more consistent and easy to use we have an 'OS' enumeration. +-- +module Distribution.System ( + -- * Operating System + OS(..), + buildOS, + + -- * Machine Architecture + Arch(..), + buildArch, + + -- * Platform is a pair of arch and OS + Platform(..), + buildPlatform, + ) where + +import qualified System.Info (os, arch) +import qualified Data.Char as Char (toLower, isAlphaNum) + +import Distribution.Text (Text(..), display) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>)) + +-- | How strict to be when classifying strings into the 'OS' and 'Arch' enums. +-- +-- The reason we have multiple ways to do the classification is because there +-- are two situations where we need to do it. +-- +-- For parsing os and arch names in .cabal files we really want everyone to be +-- referring to the same or or arch by the same name. Variety is not a virtue +-- in this case. We don't mind about case though. +-- +-- For the System.Info.os\/arch different Haskell implementations use different +-- names for the same or\/arch. Also they tend to distinguish versions of an +-- os\/arch which we just don't care about. +-- +-- The 'Compat' classification allows us to recognise aliases that are already +-- in common use but it allows us to distinguish them from the canonical name +-- which enables us to warn about such deprecated aliases. +-- +data ClassificationStrictness = Permissive | Compat | Strict + +-- ------------------------------------------------------------ +-- * Operating System +-- ------------------------------------------------------------ + +data OS = Linux | Windows | OSX -- teir 1 desktop OSs + | FreeBSD | OpenBSD | NetBSD -- other free unix OSs + | Solaris | AIX | HPUX | IRIX -- ageing Unix OSs + | HaLVM -- bare metal / VMs / hypervisors + | OtherOS String + deriving (Eq, Ord, Show, Read) + +--TODO: decide how to handle Android and iOS. +-- They are like Linux and OSX but with some differences. +-- Should they be separate from linux/osx, or a subtype? +-- e.g. should we have os(linux) && os(android) true simultaneously? + +knownOSs :: [OS] +knownOSs = [Linux, Windows, OSX + ,FreeBSD, OpenBSD, NetBSD + ,Solaris, AIX, HPUX, IRIX + ,HaLVM] + +osAliases :: ClassificationStrictness -> OS -> [String] +osAliases Permissive Windows = ["mingw32", "cygwin32"] +osAliases Compat Windows = ["mingw32", "win32"] +osAliases _ OSX = ["darwin"] +osAliases Permissive FreeBSD = ["kfreebsdgnu"] +osAliases Permissive Solaris = ["solaris2"] +osAliases _ _ = [] + +instance Text OS where + disp (OtherOS name) = Disp.text name + disp other = Disp.text (lowercase (show other)) + + parse = fmap (classifyOS Compat) ident + +classifyOS :: ClassificationStrictness -> String -> OS +classifyOS strictness s = + case lookup (lowercase s) osMap of + Just os -> os + Nothing -> OtherOS s + where + osMap = [ (name, os) + | os <- knownOSs + , name <- display os : osAliases strictness os ] + +buildOS :: OS +buildOS = classifyOS Permissive System.Info.os + +-- ------------------------------------------------------------ +-- * Machine Architecture +-- ------------------------------------------------------------ + +data Arch = I386 | X86_64 | PPC | PPC64 | Sparc + | Arm | Mips | SH + | IA64 | S390 + | Alpha | Hppa | Rs6000 + | M68k | Vax + | OtherArch String + deriving (Eq, Ord, Show, Read) + +knownArches :: [Arch] +knownArches = [I386, X86_64, PPC, PPC64, Sparc + ,Arm, Mips, SH + ,IA64, S390 + ,Alpha, Hppa, Rs6000 + ,M68k, Vax] + +archAliases :: ClassificationStrictness -> Arch -> [String] +archAliases Strict _ = [] +archAliases Compat _ = [] +archAliases _ PPC = ["powerpc"] +archAliases _ PPC64 = ["powerpc64"] +archAliases _ Sparc = ["sparc64", "sun4"] +archAliases _ Mips = ["mipsel", "mipseb"] +archAliases _ Arm = ["armeb", "armel"] +archAliases _ _ = [] + +instance Text Arch where + disp (OtherArch name) = Disp.text name + disp other = Disp.text (lowercase (show other)) + + parse = fmap (classifyArch Strict) ident + +classifyArch :: ClassificationStrictness -> String -> Arch +classifyArch strictness s = + case lookup (lowercase s) archMap of + Just arch -> arch + Nothing -> OtherArch s + where + archMap = [ (name, arch) + | arch <- knownArches + , name <- display arch : archAliases strictness arch ] + +buildArch :: Arch +buildArch = classifyArch Permissive System.Info.arch + +-- ------------------------------------------------------------ +-- * Platform +-- ------------------------------------------------------------ + +data Platform = Platform Arch OS + deriving (Eq, Ord, Show, Read) + +instance Text Platform where + disp (Platform arch os) = disp arch <> Disp.char '-' <> disp os + parse = do + arch <- parse + _ <- Parse.char '-' + os <- parse + return (Platform arch os) + +buildPlatform :: Platform +buildPlatform = Platform buildArch buildOS + +-- Utils: + +ident :: Parse.ReadP r String +ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') + --TODO: probably should disallow starting with a number + +lowercase :: String -> String +lowercase = map Char.toLower diff --git a/cabal/cabal/Distribution/TestSuite.hs b/cabal/cabal/Distribution/TestSuite.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/TestSuite.hs @@ -0,0 +1,310 @@ +{-# LANGUAGE CPP, ExistentialQuantification #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.TestSuite +-- Copyright : Thomas Tuegel 2010 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module defines the detailed test suite interface which makes it +-- possible to expose individual tests to Cabal or other test agents. + +{- 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. -} + +#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610)) +#define NEW_EXCEPTION +#endif + +module Distribution.TestSuite + ( -- * Example + -- $example + -- * Options + Options(..) + , lookupOption + , TestOptions(..) + -- * Tests + , Test + , pure, impure + , Result(..) + , ImpureTestable(..) + , PureTestable(..) + ) where + +#ifdef NEW_EXCEPTION +import Control.Exception ( evaluate, catch, throw, SomeException, fromException ) +#else +import Control.Exception ( evaluate, catch, throw, Exception(IOException) ) +#endif + +--TODO: it is totally unreasonable that we have to import things from GHC.* here. +-- see ghc ticket #3517 +#ifdef __GLASGOW_HASKELL__ +#if __GLASGOW_HASKELL__ >= 612 +import GHC.IO.Exception ( IOErrorType(Interrupted) ) +#else +import GHC.IOBase ( IOErrorType(Interrupted) ) +#endif +import System.IO.Error ( ioeGetErrorType ) +#endif + +import Data.List ( unionBy ) +import Data.Monoid ( Monoid(..) ) +import Data.Typeable ( TypeRep ) +import Prelude hiding ( catch ) + +-- | 'Options' are provided to pass options to test runners, making tests +-- reproducable. Each option is a @('String', 'String')@ of the form +-- @(Name, Value)@. Use 'mappend' to combine sets of 'Options'; if the same +-- option is given different values, the value from the left argument of +-- 'mappend' will be used. +newtype Options = Options [(String, String)] + deriving (Read, Show, Eq) + +instance Monoid Options where + mempty = Options [] + mappend (Options a) (Options b) = Options $ unionBy (equating fst) a b + where + equating p x y = p x == p y + + +class TestOptions t where + -- | The name of the test. + name :: t -> String + + -- | A list of the options a test recognizes. The name and 'TypeRep' are + -- provided so that test agents can ensure that user-specified options are + -- correctly typed. + options :: t -> [(String, TypeRep)] + + -- | The default options for a test. Test frameworks should provide a new + -- random seed, if appropriate. + defaultOptions :: t -> IO Options + + -- | Try to parse the provided options. Return the names of unparsable + -- options. This allows test agents to detect bad user-specified options. + check :: t -> Options -> [String] + +-- | Read an option from the specified set of 'Options'. It is an error to +-- lookup an option that has not been specified. For this reason, test agents +-- should 'mappend' any 'Options' against the 'defaultOptions' for a test, so +-- the default value specified by the test framework will be used for any +-- otherwise-unspecified options. +lookupOption :: Read r => String -> Options -> r +lookupOption n (Options opts) = + case lookup n opts of + Just str -> read str + Nothing -> error $ "test option not specified: " ++ n + +data Result + = Pass -- ^ indicates a successful test + | Fail String -- ^ indicates a test completed unsuccessfully; + -- the 'String' value should be a human-readable message + -- indicating how the test failed. + | Error String -- ^ indicates a test that could not be + -- completed due to some error; the test framework + -- should provide a message indicating the + -- nature of the error. + deriving (Read, Show, Eq) + +-- | Class abstracting impure tests. Test frameworks should implement this +-- class only as a last resort for test types which actually require 'IO'. +-- In particular, tests that simply require pseudo-random number generation can +-- be implemented as pure tests. +class TestOptions t => ImpureTestable t where + -- | Runs an impure test and returns the result. Test frameworks + -- implementing this class are responsible for converting any exceptions to + -- the correct 'Result' value. + runM :: t -> Options -> IO Result + +-- | Class abstracting pure tests. Test frameworks should prefer to implement +-- this class over 'ImpureTestable'. A default instance exists so that any pure +-- test can be lifted into an impure test; when lifted, any exceptions are +-- automatically caught. Test agents that lift pure tests themselves must +-- handle exceptions. +class TestOptions t => PureTestable t where + -- | The result of a pure test. + run :: t -> Options -> Result + +-- | 'Test' is a wrapper for pure and impure tests so that lists containing +-- arbitrary test types can be constructed. +data Test + = forall p. PureTestable p => PureTest p + | forall i. ImpureTestable i => ImpureTest i + +-- | A convenient function for wrapping pure tests into 'Test's. +pure :: PureTestable p => p -> Test +pure = PureTest + +-- | A convenient function for wrapping impure tests into 'Test's. +impure :: ImpureTestable i => i -> Test +impure = ImpureTest + +instance TestOptions Test where + name (PureTest p) = name p + name (ImpureTest i) = name i + + options (PureTest p) = options p + options (ImpureTest i) = options i + + defaultOptions (PureTest p) = defaultOptions p + defaultOptions (ImpureTest p) = defaultOptions p + + check (PureTest p) = check p + check (ImpureTest p) = check p + +instance ImpureTestable Test where + runM (PureTest p) o = catch (evaluate $ run p o) handler + + -- Because we have to handle old and new style exceptions, GHC and non-GHC + -- this code is totally horrible and really fragile. Has to be tested with + -- lots of ghc versions to check it is right, and with non-ghc too. :-( +#ifdef NEW_EXCEPTION + where + handler :: SomeException -> IO Result + handler e = case fromException e of + Just ioe | isInterruptedError ioe -> throw e + _ -> return (Error (show e)) +#else + where + handler :: Exception -> IO Result + handler e = case e of + IOException ioe | isInterruptedError ioe -> throw e + _ -> return (Error (show e)) +#endif + + -- We do not want to catch control-C here, but only GHC + -- defines the Interrupted exception type! (ticket #3517) + isInterruptedError ioe = +#ifdef __GLASGOW_HASKELL__ + ioeGetErrorType ioe == Interrupted +#else + False +#endif + + runM (ImpureTest i) o = runM i o + +-- $example +-- The following terms are used carefully throughout this file: +-- +-- [test interface] The interface provided by this module. +-- +-- [test agent] A program used by package users to coordinates the running +-- of tests and the reporting of their results. +-- +-- [test framework] A package used by software authors to specify tests, +-- such as QuickCheck or HUnit. +-- +-- Test frameworks are obligated to supply, at least, instances of the +-- 'TestOptions' and 'ImpureTestable' classes. It is preferred that test +-- frameworks implement 'PureTestable' whenever possible, so that test agents +-- have an assurance that tests can be safely run in parallel. +-- +-- Test agents that allow the user to specify options should avoid setting +-- options not listed by the 'options' method. Test agents should use 'check' +-- before running tests with non-default options. Test frameworks must +-- implement a 'check' function that attempts to parse the given options safely. +-- +-- The packages cabal-test-hunit, cabal-test-quickcheck1, and +-- cabal-test-quickcheck2 provide simple interfaces to these popular test +-- frameworks. An example from cabal-test-quickcheck2 is shown below. A +-- better implementation would eliminate the console output from QuickCheck\'s +-- built-in runner and provide an instance of 'PureTestable' instead of +-- 'ImpureTestable'. +-- +-- > import Control.Monad (liftM) +-- > import Data.Maybe (catMaybes, fromJust, maybe) +-- > import Data.Typeable (Typeable(..)) +-- > import qualified Distribution.TestSuite as Cabal +-- > import System.Random (newStdGen, next, StdGen) +-- > import qualified Test.QuickCheck as QC +-- > +-- > data QCTest = forall prop. QC.Testable prop => QCTest String prop +-- > +-- > test :: QC.Testable prop => String -> prop -> Cabal.Test +-- > test n p = Cabal.impure $ QCTest n p +-- > +-- > instance Cabal.TestOptions QCTest where +-- > name (QCTest n _) = n +-- > +-- > options _ = +-- > [ ("std-gen", typeOf (undefined :: String)) +-- > , ("max-success", typeOf (undefined :: Int)) +-- > , ("max-discard", typeOf (undefined :: Int)) +-- > , ("size", typeOf (undefined :: Int)) +-- > ] +-- > +-- > defaultOptions _ = do +-- > rng <- newStdGen +-- > return $ Cabal.Options $ +-- > [ ("std-gen", show rng) +-- > , ("max-success", show $ QC.maxSuccess QC.stdArgs) +-- > , ("max-discard", show $ QC.maxDiscard QC.stdArgs) +-- > , ("size", show $ QC.maxSize QC.stdArgs) +-- > ] +-- > +-- > check t (Cabal.Options opts) = catMaybes +-- > [ maybeNothing "max-success" ([] :: [(Int, String)]) +-- > , maybeNothing "max-discard" ([] :: [(Int, String)]) +-- > , maybeNothing "size" ([] :: [(Int, String)]) +-- > ] +-- > -- There is no need to check the parsability of "std-gen" +-- > -- because the Read instance for StdGen always succeeds. +-- > where +-- > maybeNothing n x = +-- > maybe Nothing (\str -> +-- > if reads str == x then Just n else Nothing) +-- > $ lookup n opts +-- > +-- > instance Cabal.ImpureTestable QCTest where +-- > runM (QCTest _ prop) o = +-- > catch go (return . Cabal.Error . show) +-- > where +-- > go = do +-- > result <- QC.quickCheckWithResult args prop +-- > return $ case result of +-- > QC.Success {} -> Cabal.Pass +-- > QC.GaveUp {}-> +-- > Cabal.Fail $ "gave up after " +-- > ++ show (QC.numTests result) +-- > ++ " tests" +-- > QC.Failure {} -> Cabal.Fail $ QC.reason result +-- > QC.NoExpectedFailure {} -> +-- > Cabal.Fail "passed (expected failure)" +-- > args = QC.Args +-- > { QC.replay = Just +-- > ( Cabal.lookupOption "std-gen" o +-- > , Cabal.lookupOption "size" o +-- > ) +-- > , QC.maxSuccess = Cabal.lookupOption "max-success" o +-- > , QC.maxDiscard = Cabal.lookupOption "max-discard" o +-- > , QC.maxSize = Cabal.lookupOption "size" o +-- > } diff --git a/cabal/cabal/Distribution/Text.hs b/cabal/cabal/Distribution/Text.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Text.hs @@ -0,0 +1,68 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Text +-- Copyright : Duncan Coutts 2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines a 'Text' class which is a bit like the 'Read' and 'Show' +-- classes. The difference is that is uses a modern pretty printer and parser +-- system and the format is not expected to be Haskell concrete syntax but +-- rather the external human readable representation used by Cabal. +-- +module Distribution.Text ( + Text(..), + display, + simpleParse, + ) where + +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp + +import Data.Version (Version(Version)) +import qualified Data.Char as Char (isDigit, isAlphaNum, isSpace) + +class Text a where + disp :: a -> Disp.Doc + parse :: Parse.ReadP r a + +display :: Text a => a -> String +display = Disp.renderStyle style . disp + where style = Disp.Style { + Disp.mode = Disp.PageMode, + Disp.lineLength = 79, + Disp.ribbonsPerLine = 1.0 + } + +simpleParse :: Text a => String -> Maybe a +simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str + , all Char.isSpace s ] of + [] -> Nothing + (p:_) -> Just p + +-- ----------------------------------------------------------------------------- +-- Instances for types from the base package + +instance Text Bool where + disp = Disp.text . show + parse = Parse.choice [ (Parse.string "True" Parse.+++ + Parse.string "true") >> return True + , (Parse.string "False" Parse.+++ + Parse.string "false") >> return False ] + +instance Text Version where + disp (Version branch _tags) -- Death to version tags!! + = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch)) + + parse = do + branch <- Parse.sepBy1 digits (Parse.char '.') + tags <- Parse.many (Parse.char '-' >> Parse.munch1 Char.isAlphaNum) + return (Version branch tags) --TODO: should we ignore the tags? + where + digits = do + first <- Parse.satisfy Char.isDigit + if first == '0' + then return 0 + else do rest <- Parse.munch Char.isDigit + return (read (first : rest)) diff --git a/cabal/cabal/Distribution/Verbosity.hs b/cabal/cabal/Distribution/Verbosity.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Verbosity.hs @@ -0,0 +1,113 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Verbosity +-- Copyright : Ian Lynagh 2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A simple 'Verbosity' type with associated utilities. There are 4 standard +-- verbosity levels from 'silent', 'normal', 'verbose' up to 'deafening'. This +-- is used for deciding what logging messages to print. + +-- Verbosity for Cabal functions + +{- Copyright (c) 2007, Ian Lynagh +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Verbosity ( + -- * Verbosity + Verbosity, + silent, normal, verbose, deafening, + moreVerbose, lessVerbose, + intToVerbosity, flagToVerbosity, + showForCabal, showForGHC + ) where + +import Data.List (elemIndex) +import Distribution.ReadE + +data Verbosity = Silent | Normal | Verbose | Deafening + deriving (Show, Read, Eq, Ord, Enum, Bounded) + +-- We shouldn't print /anything/ unless an error occurs in silent mode +silent :: Verbosity +silent = Silent + +-- Print stuff we want to see by default +normal :: Verbosity +normal = Normal + +-- Be more verbose about what's going on +verbose :: Verbosity +verbose = Verbose + +-- Not only are we verbose ourselves (perhaps even noisier than when +-- being "verbose"), but we tell everything we run to be verbose too +deafening :: Verbosity +deafening = Deafening + +moreVerbose :: Verbosity -> Verbosity +moreVerbose Silent = Silent --silent should stay silent +moreVerbose Normal = Verbose +moreVerbose Verbose = Deafening +moreVerbose Deafening = Deafening + +lessVerbose :: Verbosity -> Verbosity +lessVerbose Deafening = Deafening +lessVerbose Verbose = Normal +lessVerbose Normal = Silent +lessVerbose Silent = Silent + +intToVerbosity :: Int -> Maybe Verbosity +intToVerbosity 0 = Just Silent +intToVerbosity 1 = Just Normal +intToVerbosity 2 = Just Verbose +intToVerbosity 3 = Just Deafening +intToVerbosity _ = Nothing + +flagToVerbosity :: ReadE Verbosity +flagToVerbosity = ReadE $ \s -> + case reads s of + [(i, "")] -> + case intToVerbosity i of + Just v -> Right v + Nothing -> Left ("Bad verbosity: " ++ show i ++ + ". Valid values are 0..3") + _ -> Left ("Can't parse verbosity " ++ s) + +showForCabal, showForGHC :: Verbosity -> String + +showForCabal v = maybe (error "unknown verbosity") show $ + elemIndex v [silent,normal,verbose,deafening] +showForGHC v = maybe (error "unknown verbosity") show $ + elemIndex v [silent,normal,__,verbose,deafening] + where __ = silent -- this will be always ignored by elemIndex diff --git a/cabal/cabal/Distribution/Version.hs b/cabal/cabal/Distribution/Version.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Distribution/Version.hs @@ -0,0 +1,742 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Version +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Exports the 'Version' type along with a parser and pretty printer. A version +-- is something like @\"1.3.3\"@. It also defines the 'VersionRange' data +-- types. Version ranges are like @\">= 1.2 && < 2\"@. + +{- 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(..), + + -- * Version ranges + VersionRange(..), + + -- ** Constructing + anyVersion, noVersion, + thisVersion, notThisVersion, + laterVersion, earlierVersion, + orLaterVersion, orEarlierVersion, + unionVersionRanges, intersectVersionRanges, + withinVersion, + betweenVersionsInclusive, + + -- ** Inspection + withinRange, + isAnyVersion, + isNoVersion, + isSpecificVersion, + simplifyVersionRange, + foldVersionRange, + foldVersionRange', + + -- * Version intervals view + asVersionIntervals, + VersionInterval, + LowerBound(..), + UpperBound(..), + Bound(..), + + -- ** 'VersionIntervals' abstract type + -- | The 'VersionIntervals' type and the accompanying functions are exposed + -- primarily for completeness and testing purposes. In practice + -- 'asVersionIntervals' is the main function to use to + -- view a 'VersionRange' as a bunch of 'VersionInterval's. + -- + VersionIntervals, + toVersionIntervals, + fromVersionIntervals, + withinIntervals, + versionIntervals, + mkVersionIntervals, + unionVersionIntervals, + intersectVersionIntervals, + + ) where + +import Data.Version ( Version(..) ) + +import Distribution.Text ( Text(..) ) +import qualified Distribution.Compat.ReadP as Parse +import Distribution.Compat.ReadP ((+++)) +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>), (<+>)) +import qualified Data.Char as Char (isDigit) +import Control.Exception (assert) + +-- ----------------------------------------------------------------------------- +-- 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 + | WildcardVersion Version -- == ver.* (same as >= ver && < ver+1) + | UnionVersionRanges VersionRange VersionRange + | IntersectVersionRanges VersionRange VersionRange + | VersionRangeParens VersionRange -- just '(exp)' parentheses syntax + deriving (Show,Read,Eq) + +{-# DEPRECATED AnyVersion "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED ThisVersion "use 'thisVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED LaterVersion "use 'laterVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED EarlierVersion "use 'earlierVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED WildcardVersion "use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED UnionVersionRanges "use 'unionVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED IntersectVersionRanges "use 'intersectVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-} + +-- | The version range @-any@. That is, a version range containing all +-- versions. +-- +-- > withinRange v anyVersion = True +-- +anyVersion :: VersionRange +anyVersion = AnyVersion + +-- | The empty version range, that is a version range containing no versions. +-- +-- This can be constructed using any unsatisfiable version range expression, +-- for example @> 1 && < 1@. +-- +-- > withinRange v anyVersion = False +-- +noVersion :: VersionRange +noVersion = IntersectVersionRanges (LaterVersion v) (EarlierVersion v) + where v = Version [1] [] + +-- | The version range @== v@ +-- +-- > withinRange v' (thisVersion v) = v' == v +-- +thisVersion :: Version -> VersionRange +thisVersion = ThisVersion + +-- | The version range @< v || > v@ +-- +-- > withinRange v' (notThisVersion v) = v' /= v +-- +notThisVersion :: Version -> VersionRange +notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v) + +-- | The version range @> v@ +-- +-- > withinRange v' (laterVersion v) = v' > v +-- +laterVersion :: Version -> VersionRange +laterVersion = LaterVersion + +-- | The version range @>= v@ +-- +-- > withinRange v' (orLaterVersion v) = v' >= v +-- +orLaterVersion :: Version -> VersionRange +orLaterVersion v = UnionVersionRanges (ThisVersion v) (LaterVersion v) + +-- | The version range @< v@ +-- +-- > withinRange v' (earlierVersion v) = v' < v +-- +earlierVersion :: Version -> VersionRange +earlierVersion = EarlierVersion + +-- | The version range @<= v@ +-- +-- > withinRange v' (orEarlierVersion v) = v' <= v +-- +orEarlierVersion :: Version -> VersionRange +orEarlierVersion v = UnionVersionRanges (ThisVersion v) (EarlierVersion v) + +-- | The version range @vr1 || vr2@ +-- +-- > withinRange v' (unionVersionRanges vr1 vr2) +-- > = withinRange v' vr1 || withinRange v' vr2 +-- +unionVersionRanges :: VersionRange -> VersionRange -> VersionRange +unionVersionRanges = UnionVersionRanges + +-- | The version range @vr1 && vr2@ +-- +-- > withinRange v' (intersectVersionRanges vr1 vr2) +-- > = withinRange v' vr1 && withinRange v' vr2 +-- +intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange +intersectVersionRanges = IntersectVersionRanges + +-- | The version range @== v.*@. +-- +-- For example, for version @1.2@, the version range @== 1.2.*@ is the same as +-- @>= 1.2 && < 1.3@ +-- +-- > withinRange v' (laterVersion v) = v' >= v && v' < upper v +-- > where +-- > upper (Version lower t) = Version (init lower ++ [last lower + 1]) t +-- +withinVersion :: Version -> VersionRange +withinVersion = WildcardVersion + +-- | The version range @>= v1 && <= v2@. +-- +-- In practice this is not very useful because we normally use inclusive lower +-- bounds and exclusive upper bounds. +-- +-- > withinRange v' (laterVersion v) = v' > v +-- +betweenVersionsInclusive :: Version -> Version -> VersionRange +betweenVersionsInclusive v1 v2 = + IntersectVersionRanges (orLaterVersion v1) (orEarlierVersion v2) + +{-# DEPRECATED betweenVersionsInclusive + "In practice this is not very useful because we normally use inclusive lower bounds and exclusive upper bounds" + #-} + +-- | Fold over the basic syntactic structure of a 'VersionRange'. +-- +-- This provides a syntacic view of the expression defining the version range. +-- The syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented +-- in terms of the other basic syntax. +-- +-- For a semantic view use 'asVersionIntervals'. +-- +foldVersionRange :: a -- ^ @\"-any\"@ version + -> (Version -> a) -- ^ @\"== v\"@ + -> (Version -> a) -- ^ @\"> v\"@ + -> (Version -> a) -- ^ @\"< v\"@ + -> (a -> a -> a) -- ^ @\"_ || _\"@ union + -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection + -> VersionRange -> a +foldVersionRange anyv this later earlier union intersect = fold + where + fold AnyVersion = anyv + fold (ThisVersion v) = this v + fold (LaterVersion v) = later v + fold (EarlierVersion v) = earlier v + fold (WildcardVersion v) = fold (wildcard v) + fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) + fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) + fold (VersionRangeParens v) = fold v + + wildcard v = intersectVersionRanges + (orLaterVersion v) + (earlierVersion (wildcardUpperBound v)) + +-- | An extended variant of 'foldVersionRange' that also provides a view of +-- in which the syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented +-- explicitly rather than in terms of the other basic syntax. +-- +foldVersionRange' :: a -- ^ @\"-any\"@ version + -> (Version -> a) -- ^ @\"== v\"@ + -> (Version -> a) -- ^ @\"> v\"@ + -> (Version -> a) -- ^ @\"< v\"@ + -> (Version -> a) -- ^ @\">= v\"@ + -> (Version -> a) -- ^ @\"<= v\"@ + -> (Version -> Version -> a) -- ^ @\"== v.*\"@ wildcard. The + -- function is passed the + -- inclusive lower bound and the + -- exclusive upper bounds of the + -- range defined by the wildcard. + -> (a -> a -> a) -- ^ @\"_ || _\"@ union + -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection + -> (a -> a) -- ^ @\"(_)\"@ parentheses + -> VersionRange -> a +foldVersionRange' anyv this later earlier orLater orEarlier + wildcard union intersect parens = fold + where + fold AnyVersion = anyv + fold (ThisVersion v) = this v + fold (LaterVersion v) = later v + fold (EarlierVersion v) = earlier v + + fold (UnionVersionRanges (ThisVersion v) + (LaterVersion v')) | v==v' = orLater v + fold (UnionVersionRanges (LaterVersion v) + (ThisVersion v')) | v==v' = orLater v + fold (UnionVersionRanges (ThisVersion v) + (EarlierVersion v')) | v==v' = orEarlier v + fold (UnionVersionRanges (EarlierVersion v) + (ThisVersion v')) | v==v' = orEarlier v + + fold (WildcardVersion v) = wildcard v (wildcardUpperBound v) + fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) + fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) + fold (VersionRangeParens v) = parens (fold v) + + +-- | Does this version fall within the given range? +-- +-- This is the evaluation function for the 'VersionRange' type. +-- +withinRange :: Version -> VersionRange -> Bool +withinRange v = foldVersionRange + True + (\v' -> versionBranch v == versionBranch v') + (\v' -> versionBranch v > versionBranch v') + (\v' -> versionBranch v < versionBranch v') + (||) + (&&) + +-- | View a 'VersionRange' as a union of intervals. +-- +-- This provides a canonical view of the semantics of a 'VersionRange' as +-- opposed to the syntax of the expression used to define it. For the syntactic +-- view use 'foldVersionRange'. +-- +-- Each interval is non-empty. The sequence is in increasing order and no +-- intervals overlap or touch. Therefore only the first and last can be +-- unbounded. The sequence can be empty if the range is empty +-- (e.g. a range expression like @< 1 && > 2@). +-- +-- Other checks are trivial to implement using this view. For example: +-- +-- > isNoVersion vr | [] <- asVersionIntervals vr = True +-- > | otherwise = False +-- +-- > isSpecificVersion vr +-- > | [(LowerBound v InclusiveBound +-- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr +-- > , v == v' = Just v +-- > | otherwise = Nothing +-- +asVersionIntervals :: VersionRange -> [VersionInterval] +asVersionIntervals = versionIntervals . toVersionIntervals + +-- | Does this 'VersionRange' place any restriction on the 'Version' or is it +-- in fact equivalent to 'AnyVersion'. +-- +-- Note this is a semantic check, not simply a syntactic check. So for example +-- the following is @True@ (for all @v@). +-- +-- > isAnyVersion (EarlierVersion v `UnionVersionRanges` orLaterVersion v) +-- +isAnyVersion :: VersionRange -> Bool +isAnyVersion vr = case asVersionIntervals vr of + [(LowerBound v InclusiveBound, NoUpperBound)] | isVersion0 v -> True + _ -> False + +-- | This is the converse of 'isAnyVersion'. It check if the version range is +-- empty, if there is no possible version that satisfies the version range. +-- +-- For example this is @True@ (for all @v@): +-- +-- > isNoVersion (EarlierVersion v `IntersectVersionRanges` LaterVersion v) +-- +isNoVersion :: VersionRange -> Bool +isNoVersion vr = case asVersionIntervals vr of + [] -> True + _ -> False + +-- | Is this version range in fact just a specific version? +-- +-- For example the version range @\">= 3 && <= 3\"@ contains only the version +-- @3@. +-- +isSpecificVersion :: VersionRange -> Maybe Version +isSpecificVersion vr = case asVersionIntervals vr of + [(LowerBound v InclusiveBound + ,UpperBound v' InclusiveBound)] + | v == v' -> Just v + _ -> Nothing + +-- | Simplify a 'VersionRange' expression. For non-empty version ranges +-- this produces a canonical form. Empty or inconsistent version ranges +-- are left as-is because that provides more information. +-- +-- If you need a canonical form use +-- @fromVersionIntervals . toVersionIntervals@ +-- +-- It satisfies the following properties: +-- +-- > withinRange v (simplifyVersionRange r) = withinRange v r +-- +-- > withinRange v r = withinRange v r' +-- > ==> simplifyVersionRange r = simplifyVersionRange r' +-- > || isNoVersion r +-- > || isNoVersion r' +-- +simplifyVersionRange :: VersionRange -> VersionRange +simplifyVersionRange vr + -- If the version range is inconsistent then we just return the + -- original since that has more information than ">1 && < 1", which + -- is the canonical inconsistent version range. + | null (versionIntervals vi) = vr + | otherwise = fromVersionIntervals vi + where + vi = toVersionIntervals vr + +---------------------------- +-- Wildcard range utilities +-- + +wildcardUpperBound :: Version -> Version +wildcardUpperBound (Version lowerBound ts) = (Version upperBound ts) + where + upperBound = init lowerBound ++ [last lowerBound + 1] + +isWildcardRange :: Version -> Version -> Bool +isWildcardRange (Version branch1 _) (Version branch2 _) = check branch1 branch2 + where check (n:[]) (m:[]) | n+1 == m = True + check (n:ns) (m:ms) | n == m = check ns ms + check _ _ = False + +------------------ +-- Intervals view +-- + +-- | A complementary representation of a 'VersionRange'. Instead of a boolean +-- version predicate it uses an increasing sequence of non-overlapping, +-- non-empty intervals. +-- +-- The key point is that this representation gives a canonical representation +-- for the semantics of 'VersionRange's. This makes it easier to check things +-- like whether a version range is empty, covers all versions, or requires a +-- certain minimum or maximum version. It also makes it easy to check equality +-- or containment. It also makes it easier to identify \'simple\' version +-- predicates for translation into foreign packaging systems that do not +-- support complex version range expressions. +-- +newtype VersionIntervals = VersionIntervals [VersionInterval] + deriving (Eq, Show) + +-- | Inspect the list of version intervals. +-- +versionIntervals :: VersionIntervals -> [VersionInterval] +versionIntervals (VersionIntervals is) = is + +type VersionInterval = (LowerBound, UpperBound) +data LowerBound = LowerBound Version !Bound deriving (Eq, Show) +data UpperBound = NoUpperBound | UpperBound Version !Bound deriving (Eq, Show) +data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show) + +minLowerBound :: LowerBound +minLowerBound = LowerBound (Version [0] []) InclusiveBound + +isVersion0 :: Version -> Bool +isVersion0 (Version [0] _) = True +isVersion0 _ = False + +instance Ord LowerBound where + LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of + LT -> True + EQ -> not (bound == ExclusiveBound && bound' == InclusiveBound) + GT -> False + +instance Ord UpperBound where + _ <= NoUpperBound = True + NoUpperBound <= UpperBound _ _ = False + UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of + LT -> True + EQ -> not (bound == InclusiveBound && bound' == ExclusiveBound) + GT -> False + +invariant :: VersionIntervals -> Bool +invariant (VersionIntervals intervals) = all validInterval intervals + && all doesNotTouch' adjacentIntervals + where + doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool + doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l' + + adjacentIntervals :: [(VersionInterval, VersionInterval)] + adjacentIntervals + | null intervals = [] + | otherwise = zip intervals (tail intervals) + +checkInvariant :: VersionIntervals -> VersionIntervals +checkInvariant is = assert (invariant is) is + +-- | Directly construct a 'VersionIntervals' from a list of intervals. +-- +-- Each interval must be non-empty. The sequence must be in increasing order +-- and no invervals may overlap or touch. If any of these conditions are not +-- satisfied the function returns @Nothing@. +-- +mkVersionIntervals :: [VersionInterval] -> Maybe VersionIntervals +mkVersionIntervals intervals + | invariant (VersionIntervals intervals) = Just (VersionIntervals intervals) + | otherwise = Nothing + +validVersion :: Version -> Bool +validVersion (Version [] _) = False +validVersion (Version vs _) = all (>=0) vs + +validInterval :: (LowerBound, UpperBound) -> Bool +validInterval i@(l, u) = validLower l && validUpper u && nonEmpty i + where + validLower (LowerBound v _) = validVersion v + validUpper NoUpperBound = True + validUpper (UpperBound v _) = validVersion v + +-- Check an interval is non-empty +-- +nonEmpty :: VersionInterval -> Bool +nonEmpty (_, NoUpperBound ) = True +nonEmpty (LowerBound l lb, UpperBound u ub) = + (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound) + +-- Check an upper bound does not intersect, or even touch a lower bound: +-- +-- ---| or ---) but not ---] or ---) or ---] +-- |--- (--- (--- [--- [--- +-- +doesNotTouch :: UpperBound -> LowerBound -> Bool +doesNotTouch NoUpperBound _ = False +doesNotTouch (UpperBound u ub) (LowerBound l lb) = + u < l + || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) + +-- | Check an upper bound does not intersect a lower bound: +-- +-- ---| or ---) or ---] or ---) but not ---] +-- |--- (--- (--- [--- [--- +-- +doesNotIntersect :: UpperBound -> LowerBound -> Bool +doesNotIntersect NoUpperBound _ = False +doesNotIntersect (UpperBound u ub) (LowerBound l lb) = + u < l + || (u == l && not (ub == InclusiveBound && lb == InclusiveBound)) + +-- | Test if a version falls within the version intervals. +-- +-- It exists mostly for completeness and testing. It satisfies the following +-- properties: +-- +-- > withinIntervals v (toVersionIntervals vr) = withinRange v vr +-- > withinIntervals v ivs = withinRange v (fromVersionIntervals ivs) +-- +withinIntervals :: Version -> VersionIntervals -> Bool +withinIntervals v (VersionIntervals intervals) = any withinInterval intervals + where + withinInterval (lowerBound, upperBound) = withinLower lowerBound + && withinUpper upperBound + withinLower (LowerBound v' ExclusiveBound) = v' < v + withinLower (LowerBound v' InclusiveBound) = v' <= v + + withinUpper NoUpperBound = True + withinUpper (UpperBound v' ExclusiveBound) = v' > v + withinUpper (UpperBound v' InclusiveBound) = v' >= v + +-- | Convert a 'VersionRange' to a sequence of version intervals. +-- +toVersionIntervals :: VersionRange -> VersionIntervals +toVersionIntervals = foldVersionRange + ( chkIvl (minLowerBound, NoUpperBound)) + (\v -> chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound)) + (\v -> chkIvl (LowerBound v ExclusiveBound, NoUpperBound)) + (\v -> if isVersion0 v then VersionIntervals [] else + chkIvl (minLowerBound, UpperBound v ExclusiveBound)) + unionVersionIntervals + intersectVersionIntervals + where + chkIvl interval = checkInvariant (VersionIntervals [interval]) + +-- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression +-- representing the version intervals. +-- +fromVersionIntervals :: VersionIntervals -> VersionRange +fromVersionIntervals (VersionIntervals []) = noVersion +fromVersionIntervals (VersionIntervals intervals) = + foldr1 UnionVersionRanges [ interval l u | (l, u) <- intervals ] + + where + interval (LowerBound v InclusiveBound) + (UpperBound v' InclusiveBound) | v == v' + = ThisVersion v + interval (LowerBound v InclusiveBound) + (UpperBound v' ExclusiveBound) | isWildcardRange v v' + = WildcardVersion v + interval l u = lowerBound l `intersectVersionRanges'` upperBound u + + lowerBound (LowerBound v InclusiveBound) + | isVersion0 v = AnyVersion + | otherwise = orLaterVersion v + lowerBound (LowerBound v ExclusiveBound) = LaterVersion v + + upperBound NoUpperBound = AnyVersion + upperBound (UpperBound v InclusiveBound) = orEarlierVersion v + upperBound (UpperBound v ExclusiveBound) = EarlierVersion v + + intersectVersionRanges' vr AnyVersion = vr + intersectVersionRanges' AnyVersion vr = vr + intersectVersionRanges' vr vr' = IntersectVersionRanges vr vr' + +unionVersionIntervals :: VersionIntervals -> VersionIntervals + -> VersionIntervals +unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = + checkInvariant (VersionIntervals (union is0 is'0)) + where + union is [] = is + union [] is' = is' + union (i:is) (i':is') = case unionInterval i i' of + Left Nothing -> i : union is (i' :is') + Left (Just i'') -> union is (i'':is') + Right Nothing -> i' : union (i :is) is' + Right (Just i'') -> union (i'':is) is' + +unionInterval :: VersionInterval -> VersionInterval + -> Either (Maybe VersionInterval) (Maybe VersionInterval) +unionInterval (lower , upper ) (lower', upper') + + -- Non-intersecting intervals with the left interval ending first + | upper `doesNotTouch` lower' = Left Nothing + + -- Non-intersecting intervals with the right interval first + | upper' `doesNotTouch` lower = Right Nothing + + -- Complete or partial overlap, with the left interval ending first + | upper <= upper' = lowerBound `seq` + Left (Just (lowerBound, upper')) + + -- Complete or partial overlap, with the left interval ending first + | otherwise = lowerBound `seq` + Right (Just (lowerBound, upper)) + where + lowerBound = min lower lower' + +intersectVersionIntervals :: VersionIntervals -> VersionIntervals + -> VersionIntervals +intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = + checkInvariant (VersionIntervals (intersect is0 is'0)) + where + intersect _ [] = [] + intersect [] _ = [] + intersect (i:is) (i':is') = case intersectInterval i i' of + Left Nothing -> intersect is (i':is') + Left (Just i'') -> i'' : intersect is (i':is') + Right Nothing -> intersect (i:is) is' + Right (Just i'') -> i'' : intersect (i:is) is' + +intersectInterval :: VersionInterval -> VersionInterval + -> Either (Maybe VersionInterval) (Maybe VersionInterval) +intersectInterval (lower , upper ) (lower', upper') + + -- Non-intersecting intervals with the left interval ending first + | upper `doesNotIntersect` lower' = Left Nothing + + -- Non-intersecting intervals with the right interval first + | upper' `doesNotIntersect` lower = Right Nothing + + -- Complete or partial overlap, with the left interval ending first + | upper <= upper' = lowerBound `seq` + Left (Just (lowerBound, upper)) + + -- Complete or partial overlap, with the right interval ending first + | otherwise = lowerBound `seq` + Right (Just (lowerBound, upper')) + where + lowerBound = max lower lower' + +------------------------------- +-- Parsing and pretty printing +-- + +instance Text VersionRange where + disp = fst + . foldVersionRange' -- precedence: + ( Disp.text "-any" , 0 :: Int) + (\v -> (Disp.text "==" <> disp v , 0)) + (\v -> (Disp.char '>' <> disp v , 0)) + (\v -> (Disp.char '<' <> disp v , 0)) + (\v -> (Disp.text ">=" <> disp v , 0)) + (\v -> (Disp.text "<=" <> disp v , 0)) + (\v _ -> (Disp.text "==" <> dispWild v , 0)) + (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2)) + (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1)) + (\(r, p) -> (Disp.parens r, p)) + + where dispWild (Version b _) = + Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) + <> Disp.text ".*" + punct p p' | p < p' = Disp.parens + | otherwise = id + + parse = expr + where + expr = do Parse.skipSpaces + t <- term + Parse.skipSpaces + (do _ <- Parse.string "||" + Parse.skipSpaces + e <- expr + return (UnionVersionRanges t e) + +++ + return t) + term = do f <- factor + Parse.skipSpaces + (do _ <- Parse.string "&&" + Parse.skipSpaces + t <- term + return (IntersectVersionRanges f t) + +++ + return f) + factor = Parse.choice $ parens expr + : parseAnyVersion + : parseWildcardRange + : map parseRangeOp rangeOps + parseAnyVersion = Parse.string "-any" >> return AnyVersion + + parseWildcardRange = do + _ <- Parse.string "==" + Parse.skipSpaces + branch <- Parse.sepBy1 digits (Parse.char '.') + _ <- Parse.char '.' + _ <- Parse.char '*' + return (WildcardVersion (Version branch [])) + + parens p = Parse.between (Parse.char '(' >> Parse.skipSpaces) + (Parse.char ')' >> Parse.skipSpaces) + (do a <- p + Parse.skipSpaces + return (VersionRangeParens a)) + + digits = do + first <- Parse.satisfy Char.isDigit + if first == '0' + then return 0 + else do rest <- Parse.munch Char.isDigit + return (read (first : rest)) + + parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse + rangeOps = [ ("<", EarlierVersion), + ("<=", orEarlierVersion), + (">", LaterVersion), + (">=", orLaterVersion), + ("==", ThisVersion) ] diff --git a/cabal/cabal/LICENSE b/cabal/cabal/LICENSE new file mode 100644 --- /dev/null +++ b/cabal/cabal/LICENSE @@ -0,0 +1,33 @@ +Copyright (c) 2003-2008, Isaac Jones, Simon Marlow, Martin Sjögren, + Bjorn Bringert, Krasimir Angelov, + Malcolm Wallace, Ross Patterson, Ian Lynagh, + Duncan Coutts, Thomas Schilling +All rights reserved. + +Redistribution and use in source and binary forms, with or without +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/cabal/cabal/Language/Haskell/Extension.hs b/cabal/cabal/Language/Haskell/Extension.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Language/Haskell/Extension.hs @@ -0,0 +1,516 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.Extension +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- Haskell language dialects and 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 ( + Language(..), + knownLanguages, + + Extension(..), + KnownExtension(..), + knownExtensions, + deprecatedExtensions + ) where + +import Distribution.Text (Text(..)) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import qualified Data.Char as Char (isAlphaNum) +import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) + +-- ------------------------------------------------------------ +-- * Language +-- ------------------------------------------------------------ + +-- | This represents a Haskell language dialect. +-- +-- Language 'Extension's are interpreted relative to one of these base +-- languages. +-- +data Language = + + -- | The Haskell 98 language as defined by the Haskell 98 report. + -- + Haskell98 + + -- | The Haskell 2010 language as defined by the Haskell 2010 report. + -- + | Haskell2010 + + -- | An unknown language, identified by its name. + | UnknownLanguage String + deriving (Show, Read, Eq) + +knownLanguages :: [Language] +knownLanguages = [Haskell98, Haskell2010] + +instance Text Language where + disp (UnknownLanguage other) = Disp.text other + disp other = Disp.text (show other) + + parse = do + lang <- Parse.munch1 Char.isAlphaNum + return (classifyLanguage lang) + +classifyLanguage :: String -> Language +classifyLanguage = \str -> case lookup str langTable of + Just lang -> lang + Nothing -> UnknownLanguage str + where + langTable = [ (show lang, lang) + | lang <- knownLanguages ] + +-- ------------------------------------------------------------ +-- * Extension +-- ------------------------------------------------------------ + +-- Note: if you add a new 'KnownExtension': +-- +-- * also add it to the Distribution.Simple.X.languageExtensions lists +-- (where X is each compiler: GHC, JHC, Hugs, NHC) +-- +-- | This represents language extensions beyond a base 'Language' definition +-- (such as 'Haskell98') that are supported by some implementations, usually +-- in some special mode. +-- +-- Where applicable, references are given to an implementation's +-- official documentation, e.g. \"GHC § 7.2.1\" for an extension +-- documented in section 7.2.1 of the GHC User's Guide. + +data Extension = + -- | Enable a known extension + EnableExtension KnownExtension + + -- | Disable a known extension + | DisableExtension KnownExtension + + -- | An unknown extension, identified by the name of its @LANGUAGE@ + -- pragma. + | UnknownExtension String + + deriving (Show, Read, Eq) + +data KnownExtension = + + -- | [GHC § 7.6.3.4] Allow overlapping class instances, + -- provided there is a unique most specific instance for each use. + OverlappingInstances + + -- | [GHC § 7.6.3.3] Ignore structural rules guaranteeing the + -- termination of class instance resolution. Termination is + -- guaranteed by a fixed-depth recursion stack, and compilation + -- may fail if this depth is exceeded. + | UndecidableInstances + + -- | [GHC § 7.6.3.4] Implies 'OverlappingInstances'. Allow the + -- implementation to choose an instance even when it is possible + -- that further instantiation of types will lead to a more specific + -- instance being applicable. + | IncoherentInstances + + -- | [GHC § 7.3.8] Allows recursive bindings in @do@ blocks, + -- using the @rec@ keyword. + | DoRec + + -- | [GHC § 7.3.8.2] Deprecated in GHC. Allows recursive bindings + -- using @mdo@, a variant of @do@. @DoRec@ provides a different, + -- preferred syntax. + | RecursiveDo + + -- | [GHC § 7.3.9] Provide syntax for writing list + -- comprehensions which iterate over several lists together, like + -- the 'zipWith' family of functions. + | ParallelListComp + + -- | [GHC § 7.6.1.1] Allow multiple parameters in a type class. + | MultiParamTypeClasses + + -- | [GHC § 7.17] Enable the dreaded monomorphism restriction. + | MonomorphismRestriction + + -- | [GHC § 7.6.2] Allow a specification attached to a + -- multi-parameter type class which indicates that some parameters + -- are entirely determined by others. The implementation will check + -- that this property holds for the declared instances, and will use + -- this property to reduce ambiguity in instance resolution. + | FunctionalDependencies + + -- | [GHC § 7.8.5] Like 'RankNTypes' but does not allow a + -- higher-rank type to itself appear on the left of a function + -- arrow. + | Rank2Types + + -- | [GHC § 7.8.5] Allow a universally-quantified type to occur on + -- the left of a function arrow. + | RankNTypes + + -- | [GHC § 7.8.5] Allow data constructors to have polymorphic + -- arguments. Unlike 'RankNTypes', does not allow this for ordinary + -- functions. + | PolymorphicComponents + + -- | [GHC § 7.4.4] Allow existentially-quantified data constructors. + | ExistentialQuantification + + -- | [GHC § 7.8.7] Cause a type variable in a signature, which has an + -- explicit @forall@ quantifier, to scope over the definition of the + -- accompanying value declaration. + | ScopedTypeVariables + + -- | Deprecated, use 'ScopedTypeVariables' instead. + | PatternSignatures + + -- | [GHC § 7.8.3] Enable implicit function parameters with dynamic + -- scope. + | ImplicitParams + + -- | [GHC § 7.8.2] Relax some restrictions on the form of the context + -- of a type signature. + | FlexibleContexts + + -- | [GHC § 7.6.3.2] Relax some restrictions on the form of the + -- context of an instance declaration. + | FlexibleInstances + + -- | [GHC § 7.4.1] Allow data type declarations with no constructors. + | EmptyDataDecls + + -- | [GHC § 4.10.3] Run the C preprocessor on Haskell source code. + | CPP + + -- | [GHC § 7.8.4] Allow an explicit kind signature giving the kind of + -- types over which a type variable ranges. + | KindSignatures + + -- | [GHC § 7.11] Enable a form of pattern which forces evaluation + -- before an attempted match, and a form of strict @let@/@where@ + -- binding. + | BangPatterns + + -- | [GHC § 7.6.3.1] Allow type synonyms in instance heads. + | TypeSynonymInstances + + -- | [GHC § 7.9] Enable Template Haskell, a system for compile-time + -- metaprogramming. + | TemplateHaskell + + -- | [GHC § 8] Enable the Foreign Function Interface. In GHC, + -- implements the standard Haskell 98 Foreign Function Interface + -- Addendum, plus some GHC-specific extensions. + | ForeignFunctionInterface + + -- | [GHC § 7.10] Enable arrow notation. + | Arrows + + -- | [GHC § 7.16] Enable generic type classes, with default instances + -- defined in terms of the algebraic structure of a type. + | Generics + + -- | [GHC § 7.3.11] Enable the implicit importing of the module + -- @Prelude@. When disabled, when desugaring certain built-in syntax + -- into ordinary identifiers, use whatever is in scope rather than the + -- @Prelude@ -- version. + | ImplicitPrelude + + -- | [GHC § 7.3.15] Enable syntax for implicitly binding local names + -- corresponding to the field names of a record. Puns bind specific + -- names, unlike 'RecordWildCards'. + | NamedFieldPuns + + -- | [GHC § 7.3.5] Enable a form of guard which matches a pattern and + -- binds variables. + | PatternGuards + + -- | [GHC § 7.5.4] Allow a type declared with @newtype@ to use + -- @deriving@ for any class with an instance for the underlying type. + | GeneralizedNewtypeDeriving + + -- | [Hugs § 7.1] Enable the \"Trex\" extensible records system. + | ExtensibleRecords + + -- | [Hugs § 7.2] Enable type synonyms which are transparent in + -- some definitions and opaque elsewhere, as a way of implementing + -- abstract datatypes. + | RestrictedTypeSynonyms + + -- | [Hugs § 7.3] Enable an alternate syntax for string literals, + -- with string templating. + | HereDocuments + + -- | [GHC § 7.3.2] Allow the character @#@ as a postfix modifier on + -- identifiers. Also enables literal syntax for unboxed values. + | MagicHash + + -- | [GHC § 7.7] Allow data types and type synonyms which are + -- indexed by types, i.e. ad-hoc polymorphism for types. + | TypeFamilies + + -- | [GHC § 7.5.2] Allow a standalone declaration which invokes the + -- type class @deriving@ mechanism. + | StandaloneDeriving + + -- | [GHC § 7.3.1] Allow certain Unicode characters to stand for + -- certain ASCII character sequences, e.g. keywords and punctuation. + | UnicodeSyntax + + -- | [GHC § 8.1.1] Allow the use of unboxed types as foreign types, + -- e.g. in @foreign import@ and @foreign export@. + | UnliftedFFITypes + + -- | [GHC § 7.4.3] Defer validity checking of types until after + -- expanding type synonyms, relaxing the constraints on how synonyms + -- may be used. + | LiberalTypeSynonyms + + -- | [GHC § 7.4.2] Allow the name of a type constructor, type class, + -- or type variable to be an infix operator. + | TypeOperators + +--PArr -- not ready yet, and will probably be renamed to ParallelArrays + + -- | [GHC § 7.3.16] Enable syntax for implicitly binding local names + -- corresponding to the field names of a record. A wildcard binds + -- all unmentioned names, unlike 'NamedFieldPuns'. + | RecordWildCards + + -- | Deprecated, use 'NamedFieldPuns' instead. + | RecordPuns + + -- | [GHC § 7.3.14] Allow a record field name to be disambiguated + -- by the type of the record it's in. + | DisambiguateRecordFields + + -- | [GHC § 7.6.4] Enable overloading of string literals using a + -- type class, much like integer literals. + | OverloadedStrings + + -- | [GHC § 7.4.6] Enable generalized algebraic data types, in + -- which type variables may be instantiated on a per-constructor + -- basis. Implies GADTSyntax. + | GADTs + + -- | Enable GADT syntax for declaring ordinary algebraic datatypes. + | GADTSyntax + + -- | [GHC § 7.17.2] Make pattern bindings monomorphic. + | MonoPatBinds + + -- | [GHC § 7.8.8] Relax the requirements on mutually-recursive + -- polymorphic functions. + | RelaxedPolyRec + + -- | [GHC § 2.4.5] Allow default instantiation of polymorphic + -- types in more situations. + | ExtendedDefaultRules + + -- | [GHC § 7.2.2] Enable unboxed tuples. + | UnboxedTuples + + -- | [GHC § 7.5.3] Enable @deriving@ for classes + -- @Data.Typeable.Typeable@ and @Data.Generics.Data@. + | DeriveDataTypeable + + -- | [GHC § 7.6.1.3] Allow a class method's type to place + -- additional constraints on a class type variable. + | ConstrainedClassMethods + + -- | [GHC § 7.3.18] Allow imports to be qualified by the package + -- name the module is intended to be imported from, e.g. + -- + -- > import "network" Network.Socket + | PackageImports + + -- | [GHC § 7.8.6] Deprecated in GHC 6.12 and will be removed in + -- GHC 7. Allow a type variable to be instantiated at a + -- polymorphic type. + | ImpredicativeTypes + + -- | [GHC § 7.3.3] Change the syntax for qualified infix + -- operators. + | NewQualifiedOperators + + -- | [GHC § 7.3.12] Relax the interpretation of left operator + -- sections to allow unary postfix operators. + | PostfixOperators + + -- | [GHC § 7.9.5] Enable quasi-quotation, a mechanism for defining + -- new concrete syntax for expressions and patterns. + | QuasiQuotes + + -- | [GHC § 7.3.10] Enable generalized list comprehensions, + -- supporting operations such as sorting and grouping. + | TransformListComp + + -- | [GHC § 7.3.6] Enable view patterns, which match a value by + -- applying a function and matching on the result. + | ViewPatterns + + -- | Allow concrete XML syntax to be used in expressions and patterns, + -- as per the Haskell Server Pages extension language: + -- . The ideas behind it are + -- discussed in the paper \"Haskell Server Pages through Dynamic Loading\" + -- by Niklas Broberg, from Haskell Workshop '05. + | XmlSyntax + + -- | Allow regular pattern matching over lists, as discussed in the + -- paper \"Regular Expression Patterns\" by Niklas Broberg, Andreas Farre + -- and Josef Svenningsson, from ICFP '04. + | RegularPatterns + + -- | Enables the use of tuple sections, e.g. @(, True)@ desugars into + -- @\x -> (x, True)@. + | TupleSections + + -- | Allows GHC primops, written in C--, to be imported into a Haskell + -- file. + | GHCForeignImportPrim + + -- | Support for patterns of the form @n + k@, where @k@ is an + -- integer literal. + | NPlusKPatterns + + -- | Improve the layout rule when @if@ expressions are used in a @do@ + -- block. + | DoAndIfThenElse + + -- | Makes much of the Haskell sugar be desugared into calls to the + -- function with a particular name that is in scope. + | RebindableSyntax + + -- | Make @forall@ a keyword in types, which can be used to give the + -- generalisation explicitly. + | ExplicitForAll + + -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in + -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@. + | DatatypeContexts + + -- | Local (@let@ and @where@) bindings are monomorphic. + | MonoLocalBinds + + -- | Enable @deriving@ for the @Data.Functor.Functor@ class. + | DeriveFunctor + + -- | Enable @deriving@ for the @Data.Traversable.Traversable@ class. + | DeriveTraversable + + -- | Enable @deriving@ for the @Data.Foldable.Foldable@ class. + | DeriveFoldable + + -- | Enable non-decreasing indentation for 'do' blocks. + | NondecreasingIndentation + + deriving (Show, Read, Eq, Enum, Bounded) + +{-# DEPRECATED knownExtensions + "KnownExtension is an instance of Enum and Bounded, use those instead." #-} +knownExtensions :: [KnownExtension] +knownExtensions = [minBound..maxBound] + +-- | Extensions that have been deprecated, possibly paired with another +-- extension that replaces it. +-- +deprecatedExtensions :: [(Extension, Maybe Extension)] +deprecatedExtensions = + [ (EnableExtension RecordPuns, Just (EnableExtension NamedFieldPuns)) + , (EnableExtension PatternSignatures, Just (EnableExtension ScopedTypeVariables)) + ] +-- NOTE: when adding deprecated extensions that have new alternatives +-- we must be careful to make sure that the deprecation messages are +-- valid. We must not recomend aliases that cannot be used with older +-- compilers, perhaps by adding support in Cabal to translate the new +-- name to the old one for older compilers. Otherwise we are in danger +-- of the scenario in ticket #689. + +instance Text Extension where + disp (UnknownExtension other) = Disp.text other + disp (EnableExtension ke) = Disp.text (show ke) + disp (DisableExtension ke) = Disp.text ("No" ++ show ke) + + parse = do + extension <- Parse.munch1 Char.isAlphaNum + return (classifyExtension extension) + +instance Text KnownExtension where + disp ke = Disp.text (show ke) + + parse = do + extension <- Parse.munch1 Char.isAlphaNum + case classifyKnownExtension extension of + Just ke -> + return ke + Nothing -> + fail ("Can't parse " ++ show extension ++ " as KnownExtension") + +classifyExtension :: String -> Extension +classifyExtension string + = case classifyKnownExtension string of + Just ext -> EnableExtension ext + Nothing -> + case string of + 'N':'o':string' -> + case classifyKnownExtension string' of + Just ext -> DisableExtension ext + Nothing -> UnknownExtension string + _ -> UnknownExtension string + +-- | 'read' for 'KnownExtension's is really really slow so for the Text +-- instance +-- what we do is make a simple table indexed off the first letter in the +-- extension name. The extension names actually cover the range @'A'-'Z'@ +-- pretty densely and the biggest bucket is 7 so it's not too bad. We just do +-- a linear search within each bucket. +-- +-- This gives an order of magnitude improvement in parsing speed, and it'll +-- also allow us to do case insensitive matches in future if we prefer. +-- +classifyKnownExtension :: String -> Maybe KnownExtension +classifyKnownExtension "" = Nothing +classifyKnownExtension string@(c : _) + | inRange (bounds knownExtensionTable) c + = lookup string (knownExtensionTable ! c) + | otherwise = Nothing + +knownExtensionTable :: Array Char [(String, KnownExtension)] +knownExtensionTable = + accumArray (flip (:)) [] ('A', 'Z') + [ (head str, (str, extension)) + | extension <- [toEnum 0 ..] + , let str = show extension ] + diff --git a/cabal/cabal/Makefile b/cabal/cabal/Makefile new file mode 100644 --- /dev/null +++ b/cabal/cabal/Makefile @@ -0,0 +1,130 @@ + +VERSION=1.11.2 + +#KIND=devel +KIND=rc +#KIND=cabal-latest + +PREFIX=/usr/local +HC=ghc +GHCFLAGS=-Wall + +all: build + +# build the library itself + +SOURCES=Distribution/*.hs Distribution/Simple/*.hs Distribution/PackageDescription/*.hs Distribution/Simple/GHC/*.hs Distribution/Simple/Build/*.hs Distribution/Compat/*.hs Distribution/Simple/Program/*.hs +CONFIG_STAMP=dist/setup-config +BUILD_STAMP=dist/build/libHSCabal-$(VERSION).a +HADDOCK_STAMP=dist/doc/html/Cabal/index.html +USERGUIDE_STAMP=dist/doc/users-guide/index.html +SDIST_STAMP=dist/Cabal-$(VERSION).tar.gz +DISTLOC=dist/release +DIST_STAMP=$(DISTLOC)/Cabal-$(VERSION).tar.gz + +COMMA=, + +setup: $(SOURCES) Setup.hs + -mkdir -p dist/setup + $(HC) $(GHCFLAGS) --make -i. -odir dist/setup -hidir dist/setup Setup.hs -o setup + +Setup-nhc: + hmake -nhc98 -package base -prelude Setup + +$(CONFIG_STAMP): setup Cabal.cabal + ./setup configure --with-compiler=$(HC) --prefix=$(PREFIX) + +build: $(BUILD_STAMP) +$(BUILD_STAMP): $(CONFIG_STAMP) $(SOURCES) + ./setup build + +install: $(BUILD_STAMP) + ./setup install + +hugsbootstrap: + rm -rf dist/tmp dist/hugs + mkdir -p dist/tmp + mkdir dist/hugs + cp -r Distribution dist/tmp + hugs-package dist/tmp dist/hugs + cp Setup.lhs Cabal.cabal dist/hugs + +hugsinstall: hugsbootstrap + cd dist/hugs && ./Setup.lhs configure --hugs + cd dist/hugs && ./Setup.lhs build + cd dist/hugs && ./Setup.lhs install + +# documentation... + +haddock: $(HADDOCK_STAMP) +$(HADDOCK_STAMP) : $(CONFIG_STAMP) $(BUILD_STAMP) + ./setup haddock + +PANDOC=pandoc +PANDOC_OPTIONS= \ + --standalone \ + --smart \ + --css=$(PANDOC_HTML_CSS) +PANDOC_HTML_OUTDIR=dist/doc/users-guide +PANDOC_HTML_CSS=Cabal.css + +users-guide: $(USERGUIDE_STAMP) doc/*.markdown +$(USERGUIDE_STAMP): doc/*.markdown + mkdir -p $(PANDOC_HTML_OUTDIR) + for file in $^; do $(PANDOC) $(PANDOC_OPTIONS) --from=markdown --to=html --output $(PANDOC_HTML_OUTDIR)/$$(basename $${file} .markdown).html $${file}; done + cp doc/$(PANDOC_HTML_CSS) $(PANDOC_HTML_OUTDIR) + +docs: haddock users-guide + +clean: + rm -rf dist/ + rm -f setup + +# testing... + +moduleTest: tests/ModuleTest.hs tests/PackageDescriptionTests.hs + mkdir -p dist/test + $(HC) --make -Wall -DDEBUG -odir dist/test -hidir dist/test \ + -itests tests/ModuleTest.hs -o moduleTest + +#tests: moduleTest clean +# cd tests/A && $(MAKE) clean +# cd tests/HUnit-1.0 && $(MAKE) clean +# cd tests/A && $(MAKE) +# cd tests/HUnit-1.0 && $(MAKE) + +#check: +# rm -f moduleTest +# $(MAKE) moduleTest +# ./moduleTest + +# distribution... + +$(SDIST_STAMP) : $(BUILD_STAMP) + ./setup sdist + +dist: $(DIST_STAMP) +$(DIST_STAMP) : $(HADDOCK_STAMP) $(USERGUIDE_STAMP) $(SDIST_STAMP) + rm -rf $(DISTLOC) + mkdir $(DISTLOC) + tar -xzf $(SDIST_STAMP) -C $(DISTLOC)/ + mkdir $(DISTLOC)/Cabal-$(VERSION)/doc + cp -r dist/doc/html $(DISTLOC)/Cabal-$(VERSION)/doc/API + cp -r dist/doc/users-guide $(DISTLOC)/Cabal-$(VERSION)/doc/ + cp changelog $(DISTLOC)/Cabal-$(VERSION)/ + tar -C $(DISTLOC) -c Cabal-$(VERSION) -zf $(DISTLOC)/Cabal-$(VERSION).tar.gz + mv $(DISTLOC)/Cabal-$(VERSION)/doc $(DISTLOC)/ + mv $(DISTLOC)/Cabal-$(VERSION)/changelog $(DISTLOC)/ + rm -r $(DISTLOC)/Cabal-$(VERSION)/ + @echo "Cabal tarball built: $(DIST_STAMP)" + @echo "Release fileset prepared: $(DISTLOC)/" + +release: $(DIST_STAMP) + scp -r $(DISTLOC) haskell.org:/srv/web/haskell.org/cabal/release/cabal-$(VERSION) + ssh haskell.org 'cd /srv/web/haskell.org/cabal/release && rm -f $(KIND) && ln -s cabal-$(VERSION) $(KIND)' + +# tags... + +TAGSSRCDIRS = Distribution Language +tags TAGS: $(SOURCES) + find $(TAGSSRCDIRS) -name \*.\*hs | xargs hasktags diff --git a/cabal/cabal/Paths_Cabal.hs b/cabal/cabal/Paths_Cabal.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Paths_Cabal.hs @@ -0,0 +1,8 @@ +module Paths_Cabal ( + version, + ) where + +import Data.Version (Version(..)) + +version :: Version +version = Version {versionBranch = [1,12,0], versionTags = []} diff --git a/cabal/cabal/README b/cabal/cabal/README new file mode 100644 --- /dev/null +++ b/cabal/cabal/README @@ -0,0 +1,168 @@ +The Cabal library package +========================= + +[Cabal home page](http://www.haskell.org/cabal/) + +If you also want the `cabal` command line program then you need +the `cabal-install` package in addition to this library. + + +Installation instructions for the Cabal library +=============================================== + +Installing as a user (no root or administer access) +--------------------------------------------------- + + ghc --make Setup + ./Setup configure --user + ./Setup build + ./Setup install + +Note the use of the `--user` flag at the configure step. + +Compiling Setup rather than using `runghc Setup` is much faster and works on +Windows. For all packages other than Cabal itself it is fine to use `runghc`. + +This will install into `$HOME/.cabal/` on unix and into +`$Documents and Settings\$User\Application Data\cabal\` on Windows +If you want to install elsewhere use the `--prefix=` flag at the +configure step. + + +Installing as root / Administrator +---------------------------------- + + ghc --make Setup + ./Setup configure + ./Setup build + sudo ./Setup install + +Compiling Setup rather than using `runghc Setup` is much faster and works on +Windows. For all packages other than Cabal itself it is fine to use `runghc`. + +This will install into `/usr/local` on unix and on Windows it will +install into `$ProgramFiles/Haskell`. If you want to install +elsewhere use the `--prefix=` flag at the configure step. + + +Working with older versions of GHC and Cabal +============================================ + +It is recommended just to leave any pre-existing version of Cabal +installed. In particular it is *essential* to keep the version that +came with GHC itself since other installed packages need it (eg the +"ghc" api package). + +Prior to GHC 6.4.2 however, GHC didn't deal particularly well with +having multiple versions of packages installed at once. So if you +are using GHC 6.4.1 or older and you have an older version of Cabal +installed, you probably just want to remove it: + + ghc-pkg unregister Cabal + +or if you had Cabal installed just for your user account then: + + ghc-pkg unregister Cabal --user + + +The `filepath` dependency +========================= + +Cabal now uses the `filepath` package so that must be installed first. +GHC-6.6.1 and later come with `filepath` however earlier versions do not by +default. If you do not already have `filepath` then you need to install it. You +can use any existing version of Cabal to do that. If you have neither Cabal or +filepath then it is slightly harder but still possible. + +Unpack Cabal and filepath into separate directories. For example: + + tar -xzf filepath-1.1.0.0.tar.gz + tar -xzf Cabal-1.6.0.0.tar.gz + + # rename to make the following instructions simpler: + mv filepath-1.1.0.0/ filepath/ + mv Cabal-1.6.0.0/ Cabal/ + + cd Cabal + ghc -i../filepath -cpp --make Setup.hs -o ../filepath/setup + cd ../filepath/ + ./setup configure --user + ./setup build + ./setup install + +This installs filepath so you are then in a position to install Cabal by the +normal method. + + +More Information +================ + +Please see the web site for the [user guide] and API documentation. +There is some more information available on the [development wiki]. + +[user guide]: http://www.haskell.org/cabal/ +[development wiki]: http://hackage.haskell.org/trac/hackage/ + + +Bugs +======= + +Please report bugs and wish-list items in our [bug tracker]. + +[bug tracker]: http://hackage.haskell.org/trac/hackage/ + + +Your Help +--------- + +To help us in the next round of development work it would be +enormously helpful to know from our users what their most pressing +problems are with Cabal and Hackage. You probably have a favourite +Cabal bug or limitation. Take a look at our [bug tracker]. Make sure +the problem is reported there and properly described. Comment on the +ticket to tell us how much of a problem the bug is for you. Add +yourself to the ticket's cc list so we can discuss requirements and +keep you informed on progress. For feature requests it is very +helpful if there is a description of how you would expect to +interact with the new feature. + + +Code +======= + +You can get the code from the web page; the version control system we +use is very open and welcoming to new developers. + +You can get the main development branch: + +> darcs get --partial http://darcs.haskell.org/cabal + +and you can get the stable 1.6 branch: + +> darcs get --partial http://darcs.haskell.org/cabal-branches/cabal-1.6 + + +Credits +======= + +Cabal Coders (in alphabetical order): + +- Krasimir Angelov +- Bjorn Bringert +- Duncan Coutts +- Isaac Jones +- David Himmelstrup (Lemmih) +- Simon Marlow +- Ross Patterson +- Thomas Schilling +- Martin Sjögren +- Malcolm Wallace +- and nearly 30 other people have contributed occasional patches + +Cabal spec: + +- Isaac Jones +- Simon Marlow +- Ross Patterson +- Simon Peyton Jones +- Malcolm Wallace diff --git a/cabal/cabal/Setup.hs b/cabal/cabal/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/Setup.hs @@ -0,0 +1,10 @@ +import Distribution.Simple +main :: IO () +main = defaultMain + +-- Although this looks like the Simple build type, it is in fact vital that +-- we use this Setup.hs because it'll get compiled against the local copy +-- of the Cabal lib, thus enabling Cabal to bootstrap itself without relying +-- on any previous installation. This also means we can use any new features +-- immediately because we never have to worry about building Cabal with an +-- older version of itself. diff --git a/cabal/cabal/changelog b/cabal/cabal/changelog new file mode 100644 --- /dev/null +++ b/cabal/cabal/changelog @@ -0,0 +1,385 @@ +-*-change-log-*- + +1.11.x (current development version) + +1.10.0.x (next stable release version) + +1.10.2.0 Duncan Coutts June 2011 + * Include test suites in cabal sdist + * Fix for conditionals in test suite stanzas in .cabal files + * Fix permissions of directories created during install + * Fix for global builds when $HOME env var is not set + +1.10.1.0 Duncan Coutts February 2011 + * Improved error messages when test suites are not enabled + * Template parameters allowed in test --test-option(s) flag + * Improved documentation of the test feature + * Relaxed QA check on cabal-version when using test-suite sections + * haddock command now allows both --hoogle and --html at the same time + * Find ghc-version-specific instances of the hsc2hs program + * Preserve file executable permissions in sdist tarballs + * Pass gcc location and flags to ./configure scripts + * Get default gcc flags from ghc + +1.10.0.0 Duncan Coutts November 2010 + * New cabal test feature + * Initial support for UHC + * New default-language and other-languages fields (e.g. Haskell98/2010) + * New default-extensions and other-extensions fields + * Deprecated extensions field (for packages using cabal-version >=1.10) + * Cabal-version field must now only be of the form ">= x.y" + * Removed deprecated --copy-prefix= feature + * Auto-reconfigure when .cabal file changes + * Workaround for haddock overwriting .hi and .o files when using TH + * Extra cpp flags used with hsc2hs and c2hs (-D${os}_BUILD_OS etc) + * New cpp define VERSION_ gives string version of dependencies + * User guide source now in markdown format for easier editing + * Improved checks and error messages for C libraries and headers + * Removed BSD4 from the list of suggested licenses + * Updated list of known language extensions + * Fix for include paths to allow C code to import FFI stub.h files + * Fix for intra-package dependencies on OSX + * Stricter checks on various bits of .cabal file syntax + * Minor fixes for c2hs + +1.8.0.6 Duncan Coutts June 2010 + * Fix 'register --global/--user' + +1.8.0.4 Duncan Coutts March 2010 + * Set dylib-install-name for dynalic libs on OSX + * Stricter configure check that compiler supports a package's extensions + * More configure-time warnings + * Hugs can compile Cabal lib again + * Default datadir now follows prefix on Windows + * Support for finding installed packages for hugs + * Cabal version macros now have proper parenthesis + * Reverted change to filter out deps of non-buildable components + * Fix for registering implace when using a specific package db + * Fix mismatch between $os and $arch path template variables + * Fix for finding ar.exe on Windows, always pick ghc's version + * Fix for intra-package dependencies with ghc-6.12 + +1.8.0.2 Duncan Coutts December 2009 + * Support for GHC-6.12 + * New unique installed package IDs which use a package hash + * Allow executables to depend on the lib within the same package + * Dependencies for each component apply only to that component + (previously applied to all the other components too) + * Added new known license MIT and versioned GPL and LGPL + * More liberal package version range syntax + * Package registration files are now UTF8 + * Support for LHC and JHC-0.7.2 + * Deprecated RecordPuns extension in favour of NamedFieldPuns + * Deprecated PatternSignatures extension in favor of ScopedTypeVariables + * New VersionRange semantic view as a sequence of intervals + * Improved package quality checks + * Minor simplification in a couple Setup.hs hooks + * Beginnings of a unit level testsuite using QuickCheck + * Various bug fixes + * Various internal cleanups + +1.6.0.2 Duncan Coutts February 2009 + * New configure-time check for C headers and libraries + * Added language extensions present in ghc-6.10 + * Added support for NamedFieldPuns extension in ghc-6.8 + * Fix in configure step for ghc-6.6 on Windows + * Fix warnings in Path_pkgname.hs module on Windows + * Fix for exotic flags in ld-options field + * Fix for using pkg-config in a package with a lib and an executable + * Fix for building haddock docs for exes that use the Paths module + * Fix for installing header files in subdirectories + * Fix for the case of building profiling libs but not ordinary libs + * Fix read-only attribute of installed files on Windows + * Ignore ghc -threaded flag when profiling in ghc-6.8 and older + +1.6.0.1 Duncan Coutts October 2008 + * Export a compat function to help alex and happy + +1.6.0.0 Duncan Coutts October 2008 + * Support for ghc-6.10 + * Source control repositories can now be specified in .cabal files + * Bug report URLs can be now specified in .cabal files + * Wildcards now allowed in data-files and extra-source-files fields + * New syntactic sugar for dependencies "build-depends: foo ==1.2.*" + * New cabal_macros.h provides macros to test versions of dependencies + * Relocatable bindists now possible on unix via env vars + * New 'exposed' field allows packages to be not exposed by default + * Install dir flags can now use $os and $arch variables + * New --builddir flag allows multiple builds from a single sources dir + * cc-options now only apply to .c files, not for -fvia-C + * cc-options are not longer propagated to dependent packages + * The cpp/cc/ld-options fields no longer use ',' as a separator + * hsc2hs is now called using gcc instead of using ghc as gcc + * New api for manipulating sets and graphs of packages + * Internal api improvements and code cleanups + * Minor improvements to the user guide + * Miscellaneous minor bug fixes + +1.4.0.2 Duncan Coutts August 2008 + * Fix executable stripping default + * Fix striping exes on OSX that export dynamic symbols (like ghc) + * Correct the order of arguments given by --prog-options= + * Fix corner case with overlapping user and global packages + * Fix for modules that use pre-processing and .hs-boot files + * Clarify some points in the user guide and readme text + * Fix verbosity flags passed to sub-command like haddock + * Fix sdist --snapshot + * Allow meta-packages that contain no modules or C code + * Make the generated Paths module -Wall clean on Windows + +1.4.0.1 Duncan Coutts June 2008 + * Fix a bug which caused '.' to always be in the sources search path + * Haddock-2.2 and later do now support the --hoogle flag + +1.4.0.0 Duncan Coutts June 2008 + * Rewritten command line handling support + * Command line completion with bash + * Better support for Haddock 2 + * Improved support for nhc98 + * Removed support for ghc-6.2 + * Haddock markup in .lhs files now supported + * Default colour scheme for highlighted source code + * Default prefix for --user installs is now $HOME/.cabal + * All .cabal files are treaded as UTF-8 and must be valid + * Many checks added for common mistakes + * New --package-db= option for specific package databases + * Many internal changes to support cabal-install + * Stricter parsing for version strings, eg dissalows "1.05" + * Improved user guide introduction + * Programatica support removed + * New options --program-prefix/suffix allows eg versioned programs + * Support packages that use .hs-boot files + * Fix sdist for Main modules that require preprocessing + * New configure -O flag with optimisation level 0--2 + * Provide access to "x-" extension fields through the Cabal api + * Added check for broken installed packages + * Added warning about using inconsistent versions of dependencies + * Strip binary executable files by default with an option to disable + * New options to add site-specific include and library search paths + * Lift the restriction that libraries must have exposed-modules + * Many bugs fixed. + * Many internal structural improvements and code cleanups + +1.2.4.0 Duncan Coutts June 2008 + * Released with GHC 6.8.3 + * Backported several fixes and minor improvements from Cabal-1.4 + * Use a default colour scheme for sources with hscolour >=1.9 + * Support --hyperlink-source for Haddock >= 2.0 + * Fix for running in a non-writable directory + * Add OSX -framework arguments when linking executables + * Updates to the user guide + * Allow build-tools names to include + and _ + * Export autoconfUserHooks and simpleUserHooks + * Export ccLdOptionsBuildInfo for Setup.hs scripts + * Export unionBuildInfo and make BuildInfo an instance of Monoid + * Fix to allow the 'main-is' module to use a pre-processor + +1.2.3.0 Duncan Coutts Nov 2007 + * Released with GHC 6.8.2 + * Includes full list of GHC language extensions + * Fix infamous "dist/conftest.c" bug + * Fix configure --interfacedir= + * Find ld.exe on Windows correctly + * Export PreProcessor constructor and mkSimplePreProcessor + * Fix minor bug in unlit code + * Fix some markup in the haddock docs + +1.2.2.0 Duncan Coutts Nov 2007 + * Released with GHC 6.8.1 + * Support haddock-2.0 + * Support building DSOs with GHC + * Require reconfiguring if the .cabal file has changed + * Fix os(windows) configuration test + * Fix building documentation + * Fix building packages on Solaris + * Other minor bug fixes + +1.2.1 Duncan Coutts Oct 2007 + * To be included in GHC 6.8.1 + * New field "cpp-options" used when preprocessing Haskell modules + * Fixes for hsc2hs when using ghc + * C source code gets compiled with -O2 by default + * OS aliases, to allow os(windows) rather than requiring os(mingw32) + * Fix cleaning of 'stub' files + * Fix cabal-setup, command line ui that replaces "runhaskell Setup.hs" + * Build docs even when dependent packages docs are missing + * Allow the --html-dir to be specified at configure time + * Fix building with ghc-6.2 + * Other minor bug fixes and build fixes + +1.2.0 Duncan Coutts Sept 2007 + * To be included in GHC 6.8.x + * New configurations feature + * Can make haddock docs link to hilighted sources (with hscolour) + * New flag to allow linking to haddock docs on the web + * Supports pkg-config + * New field "build-tools" for tool dependencies + * Improved c2hs support + * Preprocessor output no longer clutters source dirs + * Seperate "includes" and "install-includes" fields + * Makefile command to generate makefiles for building libs with GHC + * New --docdir configure flag + * Generic --with-prog --prog-args configure flags + * Better default installation paths on Windows + * Install paths can be specified relative to each other + * License files now installed + * Initial support for NHC (incomplete) + * Consistent treatment of verbosity + * Reduced verbosity of configure step by default + * Improved helpfulness of output messages + * Help output now clearer and fits in 80 columns + * New setup register --gen-pkg-config flag for distros + * Major internal refactoring, hooks api has changed + * Dozens of bug fixes + +1.1.6.2 Duncan Coutts May 2007 + * Released with GHC 6.6.1 + * Handle windows text file encoding for .cabal files + * Fix compiling a executable for profiling that uses Template Haskell + * Other minor bug fixes and user guide clarifications + +1.1.6.1 Duncan Coutts Oct 2006 + * fix unlit code + * fix escaping in register.sh + +1.1.6 Duncan Coutts Oct 2006 + * Released with GHC 6.6 + * Added support for hoogle + * Allow profiling and normal builds of libs to be chosen indepentantly + * Default installation directories on Win32 changed + * Register haddock docs with ghc-pkg + * Get haddock to make hyperlinks to dependent package docs + * Added BangPatterns language extension + * Various bug fixes + +1.1.4 Duncan Coutts May 2006 + * Released with GHC 6.4.2 + * Better support for packages that need to install header files + * cabal-setup added, but not installed by default yet + * Implemented "setup register --inplace" + * Have packages exposed by default with ghc-6.2 + * It is no longer necessary to run 'configure' before 'clean' or 'sdist' + * Added support for ghc's -split-objs + * Initial support for JHC + * Ignore extension fields in .cabal files (fields begining with "x-") + * Some changes to command hooks API to improve consistency + * Hugs support improvements + * Added GeneralisedNewtypeDeriving language extension + * Added cabal-version field + * Support hidden modules with haddock + * Internal code refactoring + * More bug fixes + +1.1.3 Isaac Jones Sept 2005 + * WARNING: Interfaces not documented in the user's guide may + change in future releases. + * Move building of GHCi .o libs to the build phase rather than + register phase. (from Duncan Coutts) + * Use .tar.gz for source package extension + * Uses GHC instead of cpphs if the latter is not available + * Added experimental "command hooks" which completely override the + default behavior of a command. + * Some bugfixes + +1.1.1 Isaac Jones July 2005 + * WARNING: Interfaces not documented in the user's guide may + change in future releases. + * Handles recursive modules for GHC 6.2 and GHC 6.4. + * Added "setup test" command (Used with UserHook) + * implemented handling of _stub.{c,h,o} files + * Added support for profiling + * Changed install prefix of libraries (pref/pkgname-version + to prefix/pkgname-version/compname-version) + * Added pattern guards as a language extension + * Moved some functionality to Language.Haskell.Extension + * Register / unregister .bat files for windows + * Exposed more of the API + * Added support for the hide-all-packages flag in GHC > 6.4 + * Several bug fixes + +1.0 Isaac Jones March 11 2005 + * Released with GHC 6.4, Hugs March 2005, and nhc98 1.18 + * Some sanity checking + +0.5 Isaac Jones Wed Feb 19 2005 + * WARNING: this is a pre-release and the interfaces are still + likely to change until we reach a 1.0 release. + * Hooks interfaces changed + * Added preprocessors to user hooks + * No more executable-modules or hidden-modules. Use + "other-modules" instead. + * Certain fields moved into BuildInfo, much refactoring + * extra-libs -> extra-libraries + * Added --gen-script to configure and unconfigure. + * modules-ghc (etc) now ghc-modules (etc) + * added new fields including "synopsis" + * Lots of bug fixes + * spaces can sometimes be used instead of commas + * A user manual has appeared (Thanks, ross!) + * for ghc 6.4, configures versionsed depends properly + * more features to ./setup haddock + +0.4 Isaac Jones Sun Jan 16 2005 + + * Much thanks to all the awesome fptools hackers who have been + working hard to build the Haskell Cabal! + + * Interface Changes: + + ** WARNING: this is a pre-release and the interfaces are still + likely to change until we reach a 1.0 release. + + ** Instead of Package.description, you should name your + description files .cabal. In particular, we suggest + that you name it .cabal, but this is not enforced + (yet). Multiple .cabal files in the same directory is an error, + at least for now. + + ** ./setup install --install-prefix is gone. Use ./setup copy + --copy-prefix instead. + + ** The "Modules" field is gone. Use "hidden-modules", + "exposed-modules", and "executable-modules". + + ** Build-depends is now a package-only field, and can't go into + executable stanzas. Build-depends is a package-to-package + relationship. + + ** Some new fields. Use the Source. + + * New Features + + ** Cabal is now included as a package in the CVS version of + fptools. That means it'll be released as "-package Cabal" in + future versions of the compilers, and if you are a bleeding-edge + user, you can grab it from the CVS repository with the compilers. + + ** Hugs compatibility and NHC98 compatibility should both be + improved. + + ** Hooks Interface / Autoconf compatibility: Most of the hooks + interface is hidden for now, because it's not finalized. I have + exposed only "defaultMainWithHooks" and "defaultUserHooks". This + allows you to use a ./configure script to preprocess + "foo.buildinfo", which gets merged with "foo.cabal". In future + releases, we'll expose UserHooks, but we're definitely going to + change the interface to those. The interface to the two functions + I've exposed should stay the same, though. + + ** ./setup haddock is a baby feature which pre-processes the + source code with hscpp and runs haddock on it. This is brand new + and hardly tested, so you get to knock it around and see what you + think. + + ** Some commands now actually implement verbosity. + + ** The preprocessors have been tested a bit more, and seem to work + OK. Please give feedback if you use these. + +0.3 Isaac Jones Sun Jan 16 2005 + * Unstable snapshot release + * From now on, stable releases are even. + +0.2 Isaac Jones + + * Adds more HUGS support and preprocessor support. diff --git a/cabal/cabal/doc/Cabal.css b/cabal/cabal/doc/Cabal.css new file mode 100644 --- /dev/null +++ b/cabal/cabal/doc/Cabal.css @@ -0,0 +1,39 @@ +div { + font-family: sans-serif; + color: black; + background: white +} + +h1, h2, h3, h4, h5, h6, p.title { color: #005A9C } + +h1 { font: 170% sans-serif } +h2 { font: 140% sans-serif } +h3 { font: 120% sans-serif } +h4 { font: bold 100% sans-serif } +h5 { font: italic 100% sans-serif } +h6 { font: small-caps 100% sans-serif } + +pre { + font-family: monospace; + border-width: 1px; + border-style: solid; + padding: 0.3em +} + +pre.screen { color: #006400 } +pre.programlisting { color: maroon } + +div.example { + margin: 1ex 0em; + border: solid #412e25 1px; + padding: 0ex 0.4em +} + +div.example, div.example-contents { + background-color: #fffcf5 +} + +a:link { color: #0000C8 } +a:hover { background: #FFFFA8 } +a:active { color: #D00000 } +a:visited { color: #680098 } diff --git a/cabal/cabal/doc/developing-packages.markdown b/cabal/cabal/doc/developing-packages.markdown new file mode 100644 --- /dev/null +++ b/cabal/cabal/doc/developing-packages.markdown @@ -0,0 +1,1447 @@ +% Cabal User Guide + +# Developing packages # + +The Cabal package is the unit of distribution. When installed, its +purpose is to make available: + + * One or more Haskell programs. + + * At most one library, exposing a number of Haskell modules. + +However having both a library and executables in a package does not work +very well; if the executables depend on the library, they must +explicitly list all the modules they directly or indirectly import from +that library. Fortunately, starting with Cabal 1.8.0.4, executables can +also declare the package that they are in as a dependency, and Cabal +will treat them as if they were in another package that dependended on +the library. + +Internally, the package may consist of much more than a bunch of Haskell +modules: it may also have C source code and header files, source code +meant for preprocessing, documentation, test cases, auxiliary tools etc. + +A package is identified by a globally-unique _package name_, which +consists of one or more alphanumeric words separated by hyphens. To +avoid ambiguity, each of these words should contain at least one letter. +Chaos will result if two distinct packages with the same name are +installed on the same system. A particular version of the package is +distinguished by a _version number_, consisting of a sequence of one or +more integers separated by dots. These can be combined to form a single +text string called the _package ID_, using a hyphen to separate the name +from the version, e.g. "`HUnit-1.1`". + +Note: Packages are not part of the Haskell language; they simply +populate the hierarchical space of module names. In GHC 6.6 and later a +program may contain multiple modules with the same name if they come +from separate packages; in all other current Haskell systems packages +may not overlap in the modules they provide, including hidden modules. + +## Creating a package ## + +Suppose you have a directory hierarchy containing the source files that +make up your package. You will need to add two more files to the root +directory of the package: + +_package_`.cabal` + +: a Unicode UTF-8 text file containing a package description. + For details of the syntax of this file, see the [section on package + descriptions](#package-descriptions). + +`Setup.hs` + +: a single-module Haskell program to perform various setup tasks (with + the interface described in the section on [building and installing + packages](#building-and-installing-a-package)). This module should + import only modules that will be present in all Haskell + implementations, including modules of the Cabal library. In most + cases it will be trivial, calling on the Cabal library to do most of + the work. + +Once you have these, you can create a source bundle of this directory +for distribution. Building of the package is discussed in the section on +[building and installing packages](#building-and-installing-a-package). + +One of the purposes of Cabal is to make it easier to build a package +with different Haskell implementations. So it provides abstractions of +features present in different Haskell implementations and wherever +possible it is best to take advantage of these to increase portability. +Where necessary however it is possible to use specific features of +specific implementations. For example one of the pieces of information a +package author can put in the package's `.cabal` file is what language +extensions the code uses. This is far preferable to specifying flags for +a specific compiler as it allows Cabal to pick the right flags for the +Haskell implementation that the user picks. It also allows Cabal to +figure out if the language extension is even supported by the Haskell +implementation that the user picks. Where compiler-specific options are +needed however, there is an "escape hatch" available. The developer can +specify implementation-specific options and more generally there is a +configuration mechanism to customise many aspects of how a package is +built depending on the Haskell implementation, the Operating system, +computer architecture and user-specified configuration flags. + +~~~~~~~~~~~~~~~~ +name: Foo +version: 1.0 + +library + build-depends: base + exposed-modules: Foo + extensions: ForeignFunctionInterface + ghc-options: -Wall + nhc98-options: -K4m + if os(windows) + build-depends: Win32 +~~~~~~~~~~~~~~~~ + +#### Example: A package containing a simple library #### + +The HUnit package contains a file `HUnit.cabal` containing: + +~~~~~~~~~~~~~~~~ +name: HUnit +version: 1.1.1 +synopsis: A unit testing framework for Haskell +homepage: http://hunit.sourceforge.net/ +category: Testing +author: Dean Herington +license: BSD3 +license-file: LICENSE +cabal-version: >= 1.10 +build-type: Simple + +library + build-depends: base >= 2 && < 4 + exposed-modules: Test.HUnit.Base, Test.HUnit.Lang, + Test.HUnit.Terminal, Test.HUnit.Text, Test.HUnit + default-extensions: CPP +~~~~~~~~~~~~~~~~ + +and the following `Setup.hs`: + +~~~~~~~~~~~~~~~~ +import Distribution.Simple +main = defaultMain +~~~~~~~~~~~~~~~~ + +#### Example: A package containing executable programs #### + +~~~~~~~~~~~~~~~~ +name: TestPackage +version: 0.0 +synopsis: Small package with two programs +author: Angela Author +license: BSD3 +build-type: Simple +cabal-version: >= 1.2 + +executable program1 + build-depends: HUnit + main-is: Main.hs + hs-source-dirs: prog1 + +executable program2 + main-is: Main.hs + build-depends: HUnit + hs-source-dirs: prog2 + other-modules: Utils +~~~~~~~~~~~~~~~~ + +with `Setup.hs` the same as above. + +#### Example: A package containing a library and executable programs #### + +~~~~~~~~~~~~~~~~ +name: TestPackage +version: 0.0 +synopsis: Package with library and two programs +license: BSD3 +author: Angela Author +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: HUnit + exposed-modules: A, B, C + +executable program1 + main-is: Main.hs + hs-source-dirs: prog1 + other-modules: A, B + +executable program2 + main-is: Main.hs + hs-source-dirs: prog2 + other-modules: A, C, Utils +~~~~~~~~~~~~~~~~ + +with `Setup.hs` the same as above. Note that any library modules +required (directly or indirectly) by an executable must be listed again. + +The trivial setup script used in these examples uses the _simple build +infrastructure_ provided by the Cabal library (see +[Distribution.Simple][dist-simple]). The simplicity lies in its +interface rather that its implementation. It automatically handles +preprocessing with standard preprocessors, and builds packages for all +the Haskell implementations (except nhc98, for now). + +The simple build infrastructure can also handle packages where building +is governed by system-dependent parameters, if you specify a little more +(see the section on [system-dependent +parameters](#system-dependent-parameters)). A few packages require [more +elaborate solutions](#complex-packages). + +## Package descriptions ## + +The package description file must have a name ending in "`.cabal`". It +must be a Unicode text file encoded using valid UTF-8. There must be +exactly one such file in the directory. The first part of the name is +usually the package name, and some of the tools that operate on Cabal +packages require this. + +In the package description file, lines whose first non-whitespace characters +are "`--`" are treated as comments and ignored. + +This file should contain of a number global property descriptions and +several sections. + +* The [global properties](#package-properties) describe the package as a + whole, such as name, license, author, etc. + +* Optionally, a number of _configuration flags_ can be declared. These + can be used to enable or disable certain features of a package. (see + the section on [configurations](#configurations)). + +* The (optional) library section specifies the [library + properties](#library) and relevant [build + information](#build-information). + +* Following is an arbitrary number of executable sections + which describe an [executable program](#executable) and relevant + [build information](#build-information). + +Each section consists of a number of property descriptions +in the form of field/value pairs, with a syntax roughly like mail +message headers. + +* Case is not significant in field names, but is significant in field + values. + +* To continue a field value, indent the next line relative to the field + name. + +* Field names may be indented, but all field values in the same section + must use the same indentation. + +* Tabs are *not* allowed as indentation characters due to a missing + standard interpretation of tab width. + +* To get a blank line in a field value, use an indented "`.`" + +The syntax of the value depends on the field. Field types include: + +_token_, _filename_, _directory_ +: Either a sequence of one or more non-space non-comma characters, or + a quoted string in Haskell 98 lexical syntax. Unless otherwise + stated, relative filenames and directories are interpreted from the + package root directory. + +_freeform_, _URL_, _address_ +: An arbitrary, uninterpreted string. + +_identifier_ +: A letter followed by zero or more alphanumerics or underscores. + +_compiler_ +: A compiler flavor (one of: `GHC`, `NHC`, `YHC`, `Hugs`, `HBC`, + `Helium`, `JHC`, or `LHC`) followed by a version range. For + example, `GHC ==6.10.3`, or `LHC >=0.6 && <0.8`. + +### Modules and preprocessors ### + +Haskell module names listed in the `exposed-modules` and `other-modules` +fields may correspond to Haskell source files, i.e. with names ending in +"`.hs`" or "`.lhs`", or to inputs for various Haskell preprocessors. The +simple build infrastructure understands the extensions: + +* `.gc` ([greencard][]) +* `.chs` ([c2hs][]) +* `.hsc` (`hsc2hs`) +* `.y` and `.ly` ([happy][]) +* `.x` ([alex][]) +* `.cpphs` ([cpphs][]) + +When building, Cabal will automatically run the appropriate preprocessor +and compile the Haskell module it produces. + +Some fields take lists of values, which are optionally separated by commas, except for the +`build-depends` field, where the commas are mandatory. + +Some fields are marked as required. All others are optional, and unless +otherwise specified have empty default values. + +### Package properties ### + +These fields may occur in the first top-level properties section and +describe the package as a whole: + +`name:` _package-name_ (required) +: The unique name of the [package](#packages), without the version + number. + +`version:` _numbers_ (required) +: The package version number, usually consisting of a sequence of + natural numbers separated by dots. + +`cabal-version:` _>= x.y_ +: The version of the Cabal specification that this package description uses. + The Cabal specification does slowly evolve, intoducing new features and + occasionally changing the meaning of existing features. By specifying + which version of the spec you are using it enables programs which process + the package description to know what syntax to expect and what each part + means. + + For historical reasons this is always expressed using _>=_ version range + syntax. No other kinds of version range make sense, in particular upper + bounds do not make sense. In future this field will specify just a version + number, rather than a version range. + + The version number you specify will affect both compatability and + behaviour. Most tools (including the Cabal libray and cabal program) + understand a range of versions of the Cabal specification. Older tools + will of course only work with older versions of the Cabal specification. + Most of the time, tools that are too old will recognise this fact and + produce a suitable error message. + + As for behaviour, new versions of the Cabal spec can change the meaning + of existing syntax. This means if you want to take advantage of the new + meaning or behaviour then you must specify the newer Cabal version. + Tools are expected to use the meaning and behaviour appropriate to the + version given in the package description. + + In particular, the syntax of package descriptions changed significantly + with Cabal version 1.2 and the `cabal-version` field is now required. + Files written in the old syntax are still recognized, so if you require + compatability with very old Cabal versions then you may write your package + description file using the old syntax. Please consult the user's guide of + an older Cabal version for a description of that syntax. + +`build-type:` _identifier_ +: The type of build used by this package. Build types are the + constructors of the [BuildType][] type, defaulting to `Custom`. If + this field is given a value other than `Custom`, some tools such as + `cabal-install` will be able to build the package without using the + setup script. So if you are just using the default `Setup.hs` then + set the build type as `Simple`. + +`license:` _identifier_ (default: `AllRightsReserved`) +: The type of license under which this package is distributed. + License names are the constants of the [License][dist-license] type. + +`license-file:` _filename_ +: The name of a file containing the precise license for this package. + It will be installed with the package. + +`copyright:` _freeform_ +: The content of a copyright notice, typically the name of the holder + of the copyright on the package and the year(s) from which copyright + is claimed. For example: `Copyright: (c) 2006-2007 Joe Bloggs` + +`author:` _freeform_ +: The original author of the package. + + Remember that `.cabal` files are Unicode, using the UTF-8 encoding. + +`maintainer:` _address_ +: The current maintainer or maintainers of the package. This is an e-mail address to which users should send bug + reports, feature requests and patches. + +`stability:` _freeform_ +: The stability level of the package, e.g. `alpha`, `experimental`, `provisional`, + `stable`. + +`homepage:` _URL_ +: The package homepage. + +`bug-reports:` _URL_ +: The URL where users should direct bug reports. This would normally be either: + + * A `mailto:` URL, eg for a person or a mailing list. + + * An `http:` (or `https:`) URL for an online bug tracking system. + + For example Cabal itself uses a web-based bug tracking system + + ~~~~~~~~~~~~~~~~ + bug-reports: http://hackage.haskell.org/trac/hackage/ + ~~~~~~~~~~~~~~~~ + +`package-url:` _URL_ +: The location of a source bundle for the package. The distribution + should be a Cabal package. + +`synopsis:` _freeform_ +: A very short description of the package, for use in a table of + packages. This is your headline, so keep it short (one line) but as + informative as possible. Save space by not including the package + name or saying it's written in Haskell. + +`description:` _freeform_ +: Description of the package. This may be several paragraphs, and + should be aimed at a Haskell programmer who has never heard of your + package before. + + For library packages, this field is used as prologue text by [`setup + haddock`](#setup-haddock), and thus may contain the same markup as + [haddock][] documentation comments. + +`category:` _freeform_ +: A classification category for future use by the package catalogue [Hackage]. These + categories have not yet been specified, but the upper levels of the + module hierarchy make a good start. + +`tested-with:` _compiler list_ +: A list of compilers and versions against which the package has been + tested (or at least built). + +`data-files:` _filename list_ +: A list of files to be installed for run-time use by the package. + This is useful for packages that use a large amount of static data, + such as tables of values or code templates. Cabal provides a way to + [find these files at + run-time](#accessing-data-files-from-package-code). + + A limited form of `*` wildcards in file names, for example + `data-files: images/*.png` matches all the `.png` files in the + `images` directory. + + The limitation is that `*` wildcards are only allowed in place of + the file name, not in the directory name or file extension. In + particular, wildcards do not include directories contents + recursively. Furthermore, if a wildcard is used it must be used with + an extension, so `data-files: data/*` is not allowed. When matching + a wildcard plus extension, a file's full extension must match + exactly, so `*.gz` matches `foo.gz` but not `foo.tar.gz`. A wildcard + that does not match any files is an error. + + The reason for providing only a very limited form of wildcard is to + concisely express the common case of a large number of related files + of the same file type without making it too easy to accidentally + include unwanted files. + +`data-dir:` _directory_ +: The directory where Cabal looks for data files to install, relative + to the source directory. By default, Cabal will look in the source + directory itself. + +`extra-source-files:` _filename list_ +: A list of additional files to be included in source distributions + built with [`setup sdist`](#setup-sdist). As with `data-files` it + can use a limited form of `*` wildcards in file names. + +`extra-tmp-files:` _filename list_ +: A list of additional files or directories to be removed by [`setup + clean`](#setup-clean). These would typically be additional files + created by additional hooks, such as the scheme described in the + section on [system-dependent parameters](#system-dependent-parameters). + +### Library ### + +The library section should contain the following fields: + +`exposed-modules:` _identifier list_ (required if this package contains a library) +: A list of modules added by this package. + +`exposed:` _boolean_ (default: `True`) +: Some Haskell compilers (notably GHC) support the notion of packages + being "exposed" or "hidden" which means the modules they provide can + be easily imported without always having to specify which package + they come from. However this only works effectively if the modules + provided by all exposed packages do not overlap (otherwise a module + import would be ambiguous). + + Almost all new libraries use hierarchical module names that do not + clash, so it is very uncommon to have to use this field. However it + may be necessary to set `exposed: False` for some old libraries that + use a flat module namespace or where it is known that the exposed + modules would clash with other common modules. + +The library section may also contain build information fields (see the +section on [build information](#build-information)). + + +### Executables ### + +Executable sections (if present) describe executable programs contained +in the package and must have an argument after the section label, which +defines the name of the executable. This is a freeform argument but may +not contain spaces. + +The executable may be described using the following fields, as well as +build information fields (see the section on [build +information](#build-information)). + +`main-is:` _filename_ (required) +: The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the + `.hs` filename that must be listed, even if that file is generated + using a preprocessor. The source file must be relative to one of the + directories listed in `hs-source-dirs`. + +### Test suites ### + +Test suite sections (if present) describe package test suites and must have an +argument after the section label, which defines the name of the test suite. +This is a freeform argument, but may not contain spaces. It should be unique +among the names of the package's other test suites, the package's executables, +and the package itself. Using test suite sections requires at least Cabal +version 1.9.2. + +The test suite may be described using the following fields, as well as build +information fields (see the section on [build +information](#build-information)). + +`type:` _interface_ (required) +: The interface type and version of the test suite. Cabal supports two test + suite interfaces, called `exitcode-stdio-1.0` and `detailed-1.0`. Each of + these types may require or disallow other fields as described below. + +Test suites using the `exitcode-stdio-1.0` interface are executables +that indicate test failure with a non-zero exit code when run; they may provide +human-readable log information through the standard output and error channels. +This interface is provided primarily for compatibility with existing test +suites; it is preferred that new test suites be written for the `detailed-1.0` +interface. The `exitcode-stdio-1.0` type requires the `main-is` field. + +`main-is:` _filename_ (required: `exitcode-stdio-1.0`, disallowed: `detailed-1.0`) +: The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the + `.hs` filename that must be listed, even if that file is generated + using a preprocessor. The source file must be relative to one of the + directories listed in `hs-source-dirs`. This field is analogous to the + `main-is` field of an executable section. + +Test suites using the `detailed-1.0` interface are modules exporting the symbol +`tests :: [Test]`. The `Test` type is exported by the module +`Distribution.TestSuite` provided by Cabal. For more details, see the example below. + +The `detailed-1.0` interface allows Cabal and other test agents to inspect a +test suite's results case by case, producing detailed human- and +machine-readable log files. The `detailed-1.0` interface requires the +`test-module` field. + +`test-module:` _identifier_ (required: `detailed-1.0`, disallowed: `exitcode-stdio-1.0`) +: The module exporting the `tests` symbol. + +#### Example: Package using `exitcode-stdio-1.0` interface #### + +The example package description and executable source file below demonstrate +the use of the `exitcode-stdio-1.0` interface. For brevity, the example package +does not include a library or any normal executables, but a real package would +be required to have at least one library or executable. + +foo.cabal: + +~~~~~~~~~~~~~~~~ +Name: foo +Version: 1.0 +License: BSD3 +Cabal-Version: >= 1.9.2 +Build-Type: Simple + +Test-Suite test-foo + type: exitcode-stdio-1.0 + main-is: test-foo.hs + build-depends: base +~~~~~~~~~~~~~~~~ + +test-foo.hs: + +~~~~~~~~~~~~~~~~ +module Main where + +import System.Exit (exitFailure) + +main = do + putStrLn "This test always fails!" + exitFailure +~~~~~~~~~~~~~~~~ + +#### Example: Package using `detailed-1.0` interface #### + +The example package description and test module source file below demonstrate +the use of the `detailed-1.0` interface. For brevity, the example package does +note include a library or any normal executables, but a real package would be +required to have at least one library or executable. The test module below +also develops a simple implementation of the interface set by +`Distribution.TestSuite`, but in actual usage the implementation would be +provided by the library that provides the testing facility. + +bar.cabal: + +~~~~~~~~~~~~~~~~ +Name: bar +Version: 1.0 +License: BSD3 +Cabal-Version: >= 1.9.2 +Build-Type: Simple + +Test-Suite test-bar + type: detailed-1.0 + test-module: Test.Bar + build-depends: base, Cabal >= 1.9.2 +~~~~~~~~~~~~~~~~ + +Test/Bar.hs: + +~~~~~~~~~~~~~~~~ +{-# LANGUAGE FlexibleInstances #-} +module Test.Bar ( tests ) where + +import Distribution.TestSuite + +instance TestOptions (String, Bool) where + name = fst + options = const [] + defaultOptions _ = return (Options []) + check _ _ = [] + +instance PureTestable (String, Bool) where + run (name, result) _ | result == True = Pass + | result == False = Fail (name ++ " failed!") + +test :: (String, Bool) -> Test +test = pure + +-- In actual usage, the instances 'TestOptions (String, Bool)' and +-- 'PureTestable (String, Bool)', as well as the function 'test', would be +-- provided by the test framework. + +tests :: [Test] +tests = + [ test ("bar-1", True) + , test ("bar-2", False) + ] +~~~~~~~~~~~~~~~~ + +### Build information ### + +The following fields may be optionally present in a library or +executable section, and give information for the building of the +corresponding library or executable. See also the sections on +[system-dependent parameters](#system-dependent-parameters) and +[configurations](#configurations) for a way to supply system-dependent +values for these fields. + +`build-depends:` _package list_ +: A list of packages needed to build this one. Each package can be + annotated with a version constraint. + + Version constraints use the operators `==, >=, >, <, <=` and a + version number. Multiple constraints can be combined using `&&` or + `||`. If no version constraint is specified, any version is assumed + to be acceptable. For example: + + ~~~~~~~~~~~~~~~~ + library + build-depends: + base >= 2, + foo >= 1.2 && < 1.3, + bar + ~~~~~~~~~~~~~~~~ + + Dependencies like `foo >= 1.2 && < 1.3` turn out to be very common + because it is recommended practise for package versions to + correspond to API versions. As of Cabal 1.6, there is a special + syntax to support this use: + + ~~~~~~~~~~~~~~~~ + build-depends: foo ==1.2.* + ~~~~~~~~~~~~~~~~ + + It is only syntactic sugar. It is exactly equivalent to `foo >= 1.2 && < 1.3`. + + Note: Prior to Cabal 1.8, build-depends specified in each section + were global to all sections. This was unintentional, but some packages + were written to depend on it, so if you need your build-depends to + be local to each section, you must specify at least + `Cabal-Version: >= 1.8` in your `.cabal` file. + +`other-modules:` _identifier list_ +: A list of modules used by the component but not exposed to users. + For a library component, these would be hidden modules of the + library. For an executable, these would be auxiliary modules to be + linked with the file named in the `main-is` field. + + Note: Every module in the package *must* be listed in one of + `other-modules`, `exposed-modules` or `main-is` fields. + +`hs-source-dirs:` _directory list_ (default: "`.`") +: Root directories for the module hierarchy. + + For backwards compatibility, the old variant `hs-source-dir` is also + recognized. + +`extensions:` _identifier list_ +: A list of Haskell extensions used by every module. Extension names + are the constructors of the [Extension][extension] type. These + determine corresponding compiler options. In particular, `CPP` specifies that + Haskell source files are to be preprocessed with a C preprocessor. + + Extensions used only by one module may be specified by placing a + `LANGUAGE` pragma in the source file affected, e.g.: + + ~~~~~~~~~~~~~~~~ + {-# LANGUAGE CPP, MultiParamTypeClasses #-} + ~~~~~~~~~~~~~~~~ + + Note: GHC versions prior to 6.6 do not support the `LANGUAGE` pragma. + +`build-tools:` _program list_ +: A list of programs, possibly annotated with versions, needed to + build this package, e.g. `c2hs >= 0.15, cpphs`.If no version + constraint is specified, any version is assumed to be acceptable. + +`buildable:` _boolean_ (default: `True`) +: Is the component buildable? Like some of the other fields below, + this field is more useful with the slightly more elaborate form of + the simple build infrastructure described in the section on + [system-dependent parameters](#system-dependent-parameters). + +`ghc-options:` _token list_ +: Additional options for GHC. You can often achieve the same effect + using the `extensions` field, which is preferred. + + Options required only by one module may be specified by placing an + `OPTIONS_GHC` pragma in the source file affected. + +`ghc-prof-options:` _token list_ +: Additional options for GHC when the package is built with profiling + enabled. + +`ghc-shared-options:` _token list_ +: Additional options for GHC when the package is built as shared library. + +`hugs-options:` _token list_ +: Additional options for Hugs. You can often achieve the same effect + using the `extensions` field, which is preferred. + + Options required only by one module may be specified by placing an + `OPTIONS_HUGS` pragma in the source file affected. + +`nhc98-options:` _token list_ +: Additional options for nhc98. You can often achieve the same effect + using the `extensions` field, which is preferred. + + Options required only by one module may be specified by placing an + `OPTIONS_NHC98` pragma in the source file affected. + +`includes:` _filename list_ +: A list of header files to be included in any compilations via C. + This field applies to both header files that are already installed + on the system and to those coming with the package to be installed. + These files typically contain function prototypes for foreign + imports used by the package. + +`install-includes:` _filename list_ +: A list of header files from this package to be installed into + `$libdir/includes` when the package is installed. Files listed in + `install-includes:` should be found in relative to the top of the + source tree or relative to one of the directories listed in + `include-dirs`. + + `install-includes` is typically used to name header files that + contain prototypes for foreign imports used in Haskell code in this + package, for which the C implementations are also provided with the + package. Note that to include them when compiling the package + itself, they need to be listed in the `includes:` field as well. + +`include-dirs:` _directory list_ +: A list of directories to search for header files, when preprocessing + with `c2hs`, `hsc2hs`, `ffihugs`, `cpphs` or the C preprocessor, and + also when compiling via C. + +`c-sources:` _filename list_ +: A list of C source files to be compiled and linked with the Haskell files. + + If you use this field, you should also name the C files in `CFILES` + pragmas in the Haskell source files that use them, e.g.: `{-# CFILES + dir/file1.c dir/file2.c #-}` These are ignored by the compilers, but + needed by Hugs. + +`extra-libraries:` _token list_ +: A list of extra libraries to link with. + +`extra-lib-dirs:` _directory list_ +: A list of directories to search for libraries. + +`cc-options:` _token list_ +: Command-line arguments to be passed to the C compiler. Since the + arguments are compiler-dependent, this field is more useful with the + setup described in the section on [system-dependent + parameters](#system-dependent-parameters). + +`ld-options:` _token list_ +: Command-line arguments to be passed to the linker. Since the + arguments are compiler-dependent, this field is more useful with the + setup described in the section on [system-dependent + parameters](#system-dependent-parameters)>. + +`pkgconfig-depends:` _package list_ +: A list of [pkg-config][] packages, needed to build this package. + They can be annotated with versions, e.g. `gtk+-2.0 >= 2.10, cairo + >= 1.0`. If no version constraint is specified, any version is + assumed to be acceptable. Cabal uses `pkg-config` to find if the + packages are available on the system and to find the extra + compilation and linker options needed to use the packages. + + If you need to bind to a C library that supports `pkg-config` (use + `pkg-config --list-all` to find out if it is supported) then it is + much preferable to use this field rather than hard code options into + the other fields. + +`frameworks:` _token list_ +: On Darwin/MacOS X, a list of frameworks to link to. See Apple's + developer documentation for more details on frameworks. This entry + is ignored on all other platforms. + +### Configurations ### + +Library and executable sections may include conditional +blocks, which test for various system parameters and +configuration flags. The flags mechanism is rather generic, +but most of the time a flag represents certain feature, that +can be switched on or off by the package user. +Here is an example package description file using +configurations: + +#### Example: A package containing a library and executable programs #### + +~~~~~~~~~~~~~~~~ +Name: Test1 +Version: 0.0.1 +Cabal-Version: >= 1.2 +License: BSD3 +Author: Jane Doe +Synopsis: Test package to test configurations +Category: Example + +Flag Debug + Description: Enable debug support + Default: False + +Flag WebFrontend + Description: Include API for web frontend. + -- Cabal checks if the configuration is possible, first + -- with this flag set to True and if not it tries with False + +Library + Build-Depends: base + Exposed-Modules: Testing.Test1 + Extensions: CPP + + if flag(debug) + GHC-Options: -DDEBUG + if !os(windows) + CC-Options: "-DDEBUG" + else + CC-Options: "-DNDEBUG" + + if flag(webfrontend) + Build-Depends: cgi > 0.42 + Other-Modules: Testing.WebStuff + +Executable test1 + Main-is: T1.hs + Other-Modules: Testing.Test1 + Build-Depends: base + + if flag(debug) + CC-Options: "-DDEBUG" + GHC-Options: -DDEBUG +~~~~~~~~~~~~~~~~ + +#### Layout #### + +Flags, conditionals, library and executable sections use layout to +indicate structure. This is very similar to the Haskell layout rule. +Entries in a section have to all be indented to the same level which +must be more than the section header. Tabs are not allowed to be used +for indentation. + +As an alternative to using layout you can also use explicit braces `{}`. +In this case the indentation of entries in a section does not matter, +though different fields within a block must be on different lines. Here +is a bit of the above example again, using braces: + +#### Example: Using explicit braces rather than indentation for layout #### + +~~~~~~~~~~~~~~~~ +Name: Test1 +Version: 0.0.1 +Cabal-Version: >= 1.2 +License: BSD3 +Author: Jane Doe +Synopsis: Test package to test configurations +Category: Example + +Flag Debug { + Description: Enable debug support + Default: False +} + +Library { + Build-Depends: base + Exposed-Modules: Testing.Test1 + Extensions: CPP + if flag(debug) { + GHC-Options: -DDEBUG + if !os(windows) { + CC-Options: "-DDEBUG" + } else { + CC-Options: "-DNDEBUG" + } + } +} +~~~~~~~~~~~~~~~~ + +#### Configuration Flags #### + +A flag section takes the flag name as an argument and may contain the +following fields. + +`description:` _freeform_ +: The description of this flag. + +`default:` _boolean_ (default: `True`) +: The default value of this flag. + + Note that this value may be [overridden in several + ways](#controlling-flag-assignments"). The rationale for having + flags default to True is that users usually want new features as + soon as they are available. Flags representing features that are not + (yet) recommended for most users (such as experimental features or + debugging support) should therefore explicitly override the default + to False. + +`manual:` _boolean_ (default: `False`) +: By default, Cabal will first try to satisfy dependencies with the + default flag value and then, if that is not possible, with the + negated value. However, if the flag is manual, then the default + value (which can be overridden by commandline flags) will be used. + +#### Conditional Blocks #### + +Conditional blocks may appear anywhere inside a library or executable +section. They have to follow rather strict formatting rules. +Conditional blocks must always be of the shape + +~~~~~~~~~~~~~~~~ + `if `_condition_ + _property-descriptions-or-conditionals*_ +~~~~~~~~~~~~~~~~ + +or + +~~~~~~~~~~~~~~~~ + `if `_condition_ + _property-descriptions-or-conditionals*_ + `else` + _property-descriptions-or-conditionals*_ +~~~~~~~~~~~~~~~~ + +Note that the `if` and the condition have to be all on the same line. + +#### Conditions #### + +Conditions can be formed using boolean tests and the boolean operators +`||` (disjunction / logical "or"), `&&` (conjunction / logical "and"), +or `!` (negation / logical "not"). The unary `!` takes highest +precedence, `||` takes lowest. Precedence levels may be overridden +through the use of parentheses. For example, `os(darwin) && !arch(i386) +|| os(freebsd)` is equivalent to `(os(darwin) && !(arch(i386))) || +os(freebsd)`. + +The following tests are currently supported. + +`os(`_name_`)` +: Tests if the current operating system is _name_. The argument is + tested against `System.Info.os` on the target system. There is + unfortunately some disagreement between Haskell implementations + about the standard values of `System.Info.os`. Cabal canonicalises + it so that in particular `os(windows)` works on all implementations. + If the canonicalised os names match, this test evaluates to true, + otherwise false. The match is case-insensitive. + +`arch(`_name_`)` +: Tests if the current architecture is _name_. The argument is + matched against `System.Info.arch` on the target system. If the arch + names match, this test evaluates to true, otherwise false. The match + is case-insensitive. + +`impl(`_compiler_`)` +: Tests for the configured Haskell implementation. An optional version + constraint may be specified (for example `impl(ghc >= 6.6.1)`). If + the configured implementation is of the right type and matches the + version constraint, then this evaluates to true, otherwise false. + The match is case-insensitive. + +`flag(`_name_`)` +: Evaluates to the current assignment of the flag of the given name. + Flag names are case insensitive. Testing for flags that have not + been introduced with a flag section is an error. + +`true` +: Constant value true. + +`false` +: Constant value false. + +#### Resolution of Conditions and Flags #### + +If a package descriptions specifies configuration flags the package user +can [control these in several ways](#controlling-flag-assignments). If +the user does not fix the value of a flag, Cabal will try to find a flag +assignment in the following way. + + * For each flag specified, it will assign its default value, evaluate + all conditions with this flag assignment, and check if all + dependencies can be satisfied. If this check succeeded, the package + will be configured with those flag assignments. + + * If dependencies were missing, the last flag (as by the order in + which the flags were introduced in the package description) is tried + with its alternative value and so on. This continues until either + an assignment is found where all dependencies can be satisfied, or + all possible flag assignments have been tried. + +To put it another way, Cabal does a complete backtracking search to find +a satisfiable package configuration. It is only the dependencies +specified in the `build-depends` field in conditional blocks that +determine if a particular flag assignment is satisfiable (`build-tools` +are not considered). The order of the declaration and the default value +of the flags determines the search order. Flags overridden on the +command line fix the assignment of that flag, so no backtracking will be +tried for that flag. + +If no suitable flag assignment could be found, the configuration phase +will fail and a list of missing dependencies will be printed. Note that +this resolution process is exponential in the worst case (i.e., in the +case where dependencies cannot be satisfied). There are some +optimizations applied internally, but the overall complexity remains +unchanged. + +### Meaning of field values when using conditionals ### + +During the configuration phase, a flag assignment is chosen, all +conditionals are evaluated, and the package description is combined into +a flat package descriptions. If the same field both inside a conditional +and outside then they are combined using the following rules. + + + * Boolean fields are combined using conjunction (logical "and"). + + * List fields are combined by appending the inner items to the outer + items, for example + + ~~~~~~~~~~~~~~~~ + Extensions: CPP + if impl(ghc) || impl(hugs) + Extensions: MultiParamTypeClasses + ~~~~~~~~~~~~~~~~ + + when compiled using Hugs or GHC will be combined to + + ~~~~~~~~~~~~~~~~ + Extensions: CPP, MultiParamTypeClasses + ~~~~~~~~~~~~~~~~ + + Similarly, if two conditional sections appear at the same nesting + level, properties specified in the latter will come after properties + specified in the former. + + * All other fields must not be specified in ambiguous ways. For + example + + ~~~~~~~~~~~~~~~~ + Main-is: Main.hs + if flag(useothermain) + Main-is: OtherMain.hs + ~~~~~~~~~~~~~~~~ + + will lead to an error. Instead use + + ~~~~~~~~~~~~~~~~ + if flag(useothermain) + Main-is: OtherMain.hs + else + Main-is: Main.hs + ~~~~~~~~~~~~~~~~ + +### Source Repositories ### + +It is often useful to be able to specify a source revision control +repository for a package. Cabal lets you specifying this information in +a relatively structured form which enables other tools to interpret and +make effective use of the information. For example the information +should be sufficient for an automatic tool to checkout the sources. + +Cabal supports specifying different information for various common +source control systems. Obviously not all automated tools will support +all source control systems. + +Cabal supports specifying repositories for different use cases. By +declaring which case we mean automated tools can be more useful. There +are currently two kinds defined: + + * The `head` kind refers to the latest development branch of the + package. This may be used for example to track activity of a project + or as an indication to outside developers what sources to get for + making new contributions. + + * The `this` kind refers to the branch and tag of a repository that + contains the sources for this version or release of a package. For most + source control systems this involves specifying a tag, id or hash of + some form and perhaps a branch. The purpose is to be able to + reconstruct the sources corresponding to a particular package + version. This might be used to indicate what sources to get if + someone needs to fix a bug in an older branch that is no longer an + active head branch. + +You can specify one kind or the other or both. As an example here are +the repositories for the Cabal library. Note that the `this` kind of +repo specifies a tag. + +~~~~~~~~~~~~~~~~ +source-repository head + type: darcs + location: http://darcs.haskell.org/cabal/ + +source-repository this + type: darcs + location: http://darcs.haskell.org/cabal-branches/cabal-1.6/ + tag: 1.6.1 +~~~~~~~~~~~~~~~~ + +The exact fields are as follows: + +`type:` _token_ +: The name of the source control system used for this repository. The + currently recognised types are: + + * `darcs` + * `git` + * `svn` + * `cvs` + * `mercurial` (or alias `hg`) + * `bazaar` (or alias `bzr`) + * `arch` + * `monotone` + + This field is required. + +`location:` _URL_ +: The location of the repository. The exact form of this field depends + on the repository type. For example: + + * for darcs: `http://code.haskell.org/foo/` + * for git: `git://github.com/foo/bar.git` + * for CVS: `anoncvs@cvs.foo.org:/cvs` + + This field is required. + +`module:` _token_ +: CVS requires a named module, as each CVS server can host multiple + named repositories. + + This field is required for the CVS repo type and should not be used + otherwise. + +`branch:` _token_ +: Many source control systems support the notion of a branch, as a + distinct concept from having repositories in separate locations. For + example CVS, SVN and git use branches while for darcs uses different + locations for different branches. If you need to specify a branch to + identify a your repository then specify it in this field. + + This field is optional. + +`tag:` _token_ +: A tag identifies a particular state of a source repository. The tag + can be used with a `this` repo kind to identify the state of a repo + corresponding to a particular package version or release. The exact + form of the tag depends on the repository type. + + This field is required for the `this` repo kind. + +`subdir:` _directory_ +: Some projects put the sources for multiple packages under a single + source repository. This field lets you specify the relative path + from the root of the repository to the top directory for the + package, ie the directory containing the package's `.cabal` file. + + This field is optional. It default to empty which corresponds to the + root directory of the repository. + +## Accessing data files from package code ## + +The placement on the target system of files listed in the `data-files` +field varies between systems, and in some cases one can even move +packages around after installation (see [prefix +independence](#prefix-independence)). To enable packages to find these +files in a portable way, Cabal generates a module called +`Paths_`_pkgname_ (with any hyphens in _pkgname_ replaced by +underscores) during building, so that it may be imported by modules of +the package. This module defines a function + +~~~~~~~~~~~~~~~ +getDataFileName :: FilePath -> IO FilePath +~~~~~~~~~~~~~~~ + +If the argument is a filename listed in the `data-files` field, the +result is the name of the corresponding file on the system on which the +program is running. + +Note: If you decide to import the `Paths_`_pkgname_ module then it +*must* be listed in the `other-modules` field just like any other module +in your package. + +The `Paths_`_pkgname_ module is not platform independent so it does not +get included in the source tarballs generated by `sdist`. + +### Accessing the package version ### + +The aforementioned auto generated `Paths_`_pkgname_ module also +exports the constant `version ::` [Version][data-version] which is +defined as the version of your package as specified in the `version` +field. + +## System-dependent parameters ## + +For some packages, especially those interfacing with C libraries, +implementation details and the build procedure depend on the build +environment. A variant of the simple build infrastructure (the +`build-type` `Configure`) handles many such situations using a slightly +longer `Setup.hs`: + +~~~~~~~~~~~~~~~~ +import Distribution.Simple +main = defaultMainWithHooks autoconfUserHooks +~~~~~~~~~~~~~~~~ + +Most packages, however, would probably do better with +[configurations](#configurations). + +This program differs from `defaultMain` in two ways: + +* The package root directory must contain a shell script called + `configure`. The configure step will run the script. This `configure` + script may be produced by [autoconf][] or may be hand-written. The + `configure` script typically discovers information about the system + and records it for later steps, e.g. by generating system-dependent + header files for inclusion in C source files and preprocessed Haskell + source files. (Clearly this won't work for Windows without MSYS or + Cygwin: other ideas are needed.) + +* If the package root directory contains a file called + _package_`.buildinfo` after the configuration step, subsequent steps + will read it to obtain additional settings for [build + information](#build-information) fields,to be merged with the ones + given in the `.cabal` file. In particular, this file may be generated + by the `configure` script mentioned above, allowing these settings to + vary depending on the build environment. + + The build information file should have the following structure: + + > _buildinfo_ + > + > `executable:` _name_ + > _buildinfo_ + > + > `executable:` _name_ + > _buildinfo_ + > ... + + where each _buildinfo_ consists of settings of fields listed in the + section on [build information](#build-information). The first one (if + present) relates to the library, while each of the others relate to + the named executable. (The names must match the package description, + but you don't have to have entries for all of them.) + +Neither of these files is required. If they are absent, this setup +script is equivalent to `defaultMain`. + +#### Example: Using autoconf #### + +This example is for people familiar with the [autoconf][] tools. + +In the X11 package, the file `configure.ac` contains: + +~~~~~~~~~~~~~~~~ +AC_INIT([Haskell X11 package], [1.1], [libraries@haskell.org], [X11]) + +# Safety check: Ensure that we are in the correct source directory. +AC_CONFIG_SRCDIR([X11.cabal]) + +# Header file to place defines in +AC_CONFIG_HEADERS([include/HsX11Config.h]) + +# Check for X11 include paths and libraries +AC_PATH_XTRA +AC_TRY_CPP([#include ],,[no_x=yes]) + +# Build the package if we found X11 stuff +if test "$no_x" = yes +then BUILD_PACKAGE_BOOL=False +else BUILD_PACKAGE_BOOL=True +fi +AC_SUBST([BUILD_PACKAGE_BOOL]) + +AC_CONFIG_FILES([X11.buildinfo]) +AC_OUTPUT +~~~~~~~~~~~~~~~~ + +Then the setup script will run the `configure` script, which checks for +the presence of the X11 libraries and substitutes for variables in the +file `X11.buildinfo.in`: + +~~~~~~~~~~~~~~~~ +buildable: @BUILD_PACKAGE_BOOL@ +cc-options: @X_CFLAGS@ +ld-options: @X_LIBS@ +~~~~~~~~~~~~~~~~ + +This generates a file `X11.buildinfo` supplying the parameters needed by +later stages: + +~~~~~~~~~~~~~~~~ +buildable: True +cc-options: -I/usr/X11R6/include +ld-options: -L/usr/X11R6/lib +~~~~~~~~~~~~~~~~ + +The `configure` script also generates a header file +`include/HsX11Config.h` containing C preprocessor defines recording the +results of various tests. This file may be included by C source files +and preprocessed Haskell source files in the package. + +Note: Packages using these features will also need to list +additional files such as `configure`, +templates for `.buildinfo` files, files named +only in `.buildinfo` files, header files and +so on in the `extra-source-files` field, +to ensure that they are included in source distributions. +They should also list files and directories generated by +`configure` in the +`extra-tmp-files` field to ensure that they +are removed by `setup clean`. + +## Conditional compilation ## + +Sometimes you want to write code that works with more than one version +of a dependency. You can specify a range of versions for the depenency +in the `build-depends`, but how do you then write the code that can use +different versions of the API? + +Haskell lets you preprocess your code using the C preprocessor (either +the real C preprocessor, or `cpphs`). To enable this, add `extensions: +CPP` to your package description. When using CPP, Cabal provides some +pre-defined macros to let you test the version of dependent packages; +for example, suppose your package works with either version 3 or version +4 of the `base` package, you could select the available version in your +Haskell modules like this: + +~~~~~~~~~~~~~~~~ +#if MIN_VERSION_base(4,0,0) +... code that works with base-4 ... +#else +... code that works with base-3 ... +#endif +~~~~~~~~~~~~~~~~ + +In general, Cabal supplies a macro `MIN_VERSION_`_`package`_`_(A,B,C)` +for each package depended on via `build-depends`. This macro is true if +the actual version of the package in use is greater than or equal to +`A.B.C` (using the conventional ordering on version numbers, which is +lexicographic on the sequence, but numeric on each component, so for +example 1.2.0 is greater than 1.0.3). + +Cabal places the definitions of these macros into an +automatically-generated header file, which is included when +preprocessing Haskell source code by passing options to the C +preprocessor. + +## More complex packages ## + +For packages that don't fit the simple schemes described above, you have +a few options: + + * You can customize the simple build infrastructure using _hooks_. + These allow you to perform additional actions before and after each + command is run, and also to specify additional preprocessors. See + `UserHooks` in [Distribution.Simple][dist-simple] for the details, + but note that this interface is experimental, and likely to change + in future releases. + + * You could delegate all the work to `make`, though this is unlikely + to be very portable. Cabal supports this with the `build-type` + `Make` and a trivial setup library [Distribution.Make][dist-make], + which simply parses the command line arguments and invokes `make`. + Here `Setup.hs` looks like + + ~~~~~~~~~~~~~~~~ + import Distribution.Make + main = defaultMain + ~~~~~~~~~~~~~~~~ + + The root directory of the package should contain a `configure` + script, and, after that has run, a `Makefile` with a default target + that builds the package, plus targets `install`, `register`, + `unregister`, `clean`, `dist` and `docs`. Some options to commands + are passed through as follows: + + * The `--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`, + `--datadir` and `--libexecdir` options to the `configure` + command are passed on to the `configure` script. In addition the + value of the `--with-compiler` option is passed in a `--with-hc` + option and all options specified with `--configure-option=` are + passed on. + + * The `--destdir` option to the `copy` command becomes a setting + of a `destdir` variable on the invocation of `make copy`. The + supplied `Makefile` should provide a `copy` target, which will + probably look like this: + + ~~~~~~~~~~~~~~~~ + copy : + $(MAKE) install prefix=$(destdir)/$(prefix) \ + bindir=$(destdir)/$(bindir) \ + libdir=$(destdir)/$(libdir) \ + datadir=$(destdir)/$(datadir) \ + libexecdir=$(destdir)/$(libexecdir) + ~~~~~~~~~~~~~~~~ + + * You can write your own setup script conforming to the interface + described in the section on [building and installing + packages](#building-and-installing-a-package), possibly using the + Cabal library for part of the work. One option is to copy the + source of `Distribution.Simple`, and alter it for your needs. + Good luck. + + + +[dist-simple]: ../libraries/Cabal/Distribution-Simple.html +[dist-make]: ../libraries/Cabal/Distribution-Make.html +[dist-license]: ../libraries/Cabal/Distribution-License.html#t:License +[extension]: ../libraries/Cabal/Language-Haskell-Extension.html#t:Extension +[BuildType]: ../libraries/Cabal/Distribution-PackageDescription.html#t:BuildType +[data-version]: http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Version.html +[alex]: http://www.haskell.org/alex/ +[autoconf]: http://www.gnu.org/software/autoconf/ +[c2hs]: http://www.cse.unsw.edu.au/~chak/haskell/c2hs/ +[cpphs]: http://www.haskell.org/cpphs/ +[greencard]: http://www.haskell.org/greencard/ +[haddock]: http://www.haskell.org/haddock/ +[HsColour]: http://www.cs.york.ac.uk/fp/darcs/hscolour/ +[happy]: http://www.haskell.org/happy/ +[Hackage]: http://hackage.haskell.org/ +[pkg-config]: http://pkg-config.freedesktop.org/ diff --git a/cabal/cabal/doc/index.markdown b/cabal/cabal/doc/index.markdown new file mode 100644 --- /dev/null +++ b/cabal/cabal/doc/index.markdown @@ -0,0 +1,169 @@ +% Cabal User Guide + +Cabal is package system for [Haskell] software. + +Cabal specifies a standard way in which Haskell libraries and +applications can be packaged so that it is easy for consumers to use +them, or re-package them, regardless of the Haskell implementation or +installation platform. + +Cabal defines a common interface -- the _Cabal package_ -- between +package authors, builders and users. There is a library to help package +authors implement this interface, and a tool to enable developers, +builders and users to work with Cabal packages. + +# Contents # + + * [Introduction](#introduction) + - [What's in a package](#whats-in-a-package) + - [A tool for working with packages](#a-tool-for-working-with-packages) + * [Developing packages](developing-packages.html) + - [Package descriptions](developing-packages.html#package-descriptions) + + [Package properties](developing-packages.html#package-properties) + + [Library](developing-packages.html#library) + + [Executables](developing-packages.html#executables) + + [Test suites](developing-packages.html#test-suites) + + [Build information](developing-packages.html#build-information) + + [Configurations](developing-packages.html#configurations) + + [Source Repositories](developing-packages.html#source-repositories) + - [Accessing data files from package code](developing-packages.html#accessing-data-files-from-package-code) + + [Accessing the package version](developing-packages.html#accessing-the-package-version) + - [System-dependent parameters](developing-packages.html#system-dependent-parameters) + - [Conditional compilation](developing-packages.html#conditional-compilation) + - [More complex packages](developing-packages.html#more-complex-packages) + * [Building and installing packages](installing-packages.html) + - [Building and installing a system package](installing-packages.html#building-and-installing-a-system-package) + - [Building and installing a user package](installing-packages.html#building-and-installing-a-user-package) + - [Creating a binary package](installing-packages.html#creating-a-binary-package) + - [setup configure](installing-packages.html#setup-configure) + + [Programs used for building](installing-packages.html#programs-used-for-building) + + [Installation paths](installing-packages.html#installation-paths) + + [Controlling Flag Assignments](installing-packages.html#controlling-flag-assignments) + + [Building Test Suites](installing-packages.html#building-test-suites) + + [Miscellaneous options](installing-packages.html#miscellaneous-options) + - [setup build](installing-packages.html#setup-build) + - [setup haddock](installing-packages.html#setup-haddock) + - [setup hscolour](installing-packages.html#setup-hscolour) + - [setup install](installing-packages.html#setup-install) + - [setup copy](installing-packages.html#setup-copy) + - [setup register](installing-packages.html#setup-register) + - [setup unregister](installing-packages.html#setup-unregister) + - [setup clean](installing-packages.html#setup-clean) + - [setup test](installing-packages.html#setup-test) + - [setup sdist](installing-packages.html#setup-sdist) + * [Reporting bugs and deficiencies](misc.html#reporting-bugs-and-deficiencies) + * [Stability of Cabal interfaces](misc.html#stability-of-cabal-interfaces) + - [Cabal file format](misc.html#cabal-file-format) + - [Command-line interface](misc.html#command-line-interface) + + [Very Stable Command-line interfaces](misc.html#very-stable-command-line-interfaces) + + [Stable Command-line interfaces](misc.html#stable-command-line-interfaces) + + [Unstable command-line](misc.html#unstable-command-line) + - [Functions and Types](misc.html#functions-and-types) + + [Very Stable API](misc.html#very-stable-api) + + [Semi-stable API](misc.html#semi-stable-api) + + [Unstable API](#unstable-api) + - [Hackage](misc.html#hackage) + +# Introduction # + +Cabal is package system for Haskell software. The point of a packaging +system is to enable software developers and users to easily distribute, +use and reuse software. A good packaging system makes it easier for +developers to get their software into the hands of users, but equally +importantly it makes it easier for software developers to be able to +reuse software components written by other developers. + +Packaging systems deal with packages and with Cabal we call them _Cabal +packages_. The Cabal package is the unit of distribution. Every Cabal +package has a name and a version number which are used to identify the +package, e.g. `filepath-1.0`. + +Cabal packages are source based and are typically (but not necessarily) +portable to many platforms and Haskell implementations. The Cabal +package format is designed to make it possible to translate into other +formats, including binary packages for various systems. + +When distributed, Cabal packages use the standard compressed tarball +format, with the file extension `.tar.gz`, e.g. `filepath-1.0.tar.gz`. + +Note that packages are not part of the Haskell language, but most +Haskell implementations have some notion of package, and Cabal supports +most Haskell implementations. + + +## What's in a package ## + +A Cabal package consists of: + + * Haskell software, including libraries, executables and tests + * meta-data about the package in a standard human and machine + readable format (the "`.cabal`" file) + * a standard interface to build the package (the "`Setup.hs`" file) + +The `.cabal` file contains information about the package, supplied by +the package author. Some of this information is used for identifying and +managing the package when it comes to distribution. + +For the majority of packages it is possible to supply enough information +in the `.cabal` file so that it can be built without the package author +needing to write any extra build system scripts. For complex packages it +may be necessary to add code to the `Setup.hs` file. + +Here is an example `foo.cabal` for a very simple Haskell library that +exposes one Haskell module called `Data.Foo`: + +~~~~~~~~~~~~~~~~ +name: foo +version: 1.0 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: Data.Foo + build-depends: base >= 3 && < 5 +~~~~~~~~~~~~~~~~ + +For full details on what goes in the `.cabal` and `Setup.hs` files, and +for all the other features provided by the build system, see the section +on [developing packages](developing-packages.html). + + +## A tool for working with packages ## + +There is a command line tool, called `cabal`, that users and developers +can use to install Cabal packages. It can be used for both local +packages and for packages available remotely over the network. + +Developers can use the tool with packages in local directories, e.g. + +~~~~~~~~~~~~~~~~ +cd foo/ +cabal install +~~~~~~~~~~~~~~~~ + +Developers and users can use the tool to install packages from remote +Cabal package archives. By default, the `cabal` tool is configured to +use the centeralised Haskell community archive called [Hackage] but it +is possible to use it with any other suitable archive. + +~~~~~~~~~~~~~~~~ +cabal install xmonad +~~~~~~~~~~~~~~~~ + +This will install the `xmonad` package plus all of its dependencies. + +Cabal provides a number of ways for a user to customise how and where a +package is installed. They can decide where a package will be installed, +which Haskell implementation to use and whether to build optimised code +or build with the ability to profile code. It is not expected that users +will have to modify any of the information in the `.cabal` file. + +For full details, see the section on [building and installing +packages](installing-packages.html). + +Note that `cabal` is not the only tool for working with Cabal packages. +Due to the standardised format and a library for reading `.cabal` files, +there are several other special-purpose tools. + +[Haskell]: http://www.haskell.org/ +[Hackage]: http://hackage.haskell.org/ diff --git a/cabal/cabal/doc/installing-packages.markdown b/cabal/cabal/doc/installing-packages.markdown new file mode 100644 --- /dev/null +++ b/cabal/cabal/doc/installing-packages.markdown @@ -0,0 +1,809 @@ +% Cabal User Guide + + +# Building and installing packages # + +After you've unpacked a Cabal package, you can build it by moving into +the root directory of the package and using the `Setup.hs` or +`Setup.lhs` script there: + +> `_runhaskell_ Setup.hs` [_command_] [_option_...] + +The _command_ argument selects a particular step in the build/install +process. You can also get a summary of the command syntax with + +> `runhaskell Setup.hs --help` + +## Building and installing a system package ## + +~~~~~~~~~~~~~~~~ +runhaskell Setup.hs configure --ghc +runhaskell Setup.hs build +runhaskell Setup.hs install +~~~~~~~~~~~~~~~~ + +The first line readies the system to build the tool using GHC; for +example, it checks that GHC exists on the system. The second line +performs the actual building, while the last both copies the build +results to some permanent place and registers the package with GHC. + +## Building and installing a user package ## + +~~~~~~~~~~~~~~~~ +runhaskell Setup.hs configure --user +runhaskell Setup.hs build +runhaskell Setup.hs install +~~~~~~~~~~~~~~~~ + +The package is installed under the user's home directory and is +registered in the user's package database (`--user`). + +## Creating a binary package ## + +When creating binary packages (e.g. for RedHat or Debian) one needs to +create a tarball that can be sent to another system for unpacking in the +root directory: + +~~~~~~~~~~~~~~~~ +runhaskell Setup.hs configure --prefix=/usr +runhaskell Setup.hs build +runhaskell Setup.hs copy --destdir=/tmp/mypkg +tar -czf mypkg.tar.gz /tmp/mypkg/ +~~~~~~~~~~~~~~~~ + +If the package contains a library, you need two additional steps: + +~~~~~~~~~~~~~~~~ +runhaskell Setup.hs register --gen-script +runhaskell Setup.hs unregister --gen-script +~~~~~~~~~~~~~~~~ + +This creates shell scripts `register.sh` and `unregister.sh`, which must +also be sent to the target system. After unpacking there, the package +must be registered by running the `register.sh` script. The +`unregister.sh` script would be used in the uninstall procedure of the +package. Similar steps may be used for creating binary packages for +Windows. + + +The following options are understood by all commands: + +`--help`, `-h` or `-?` +: List the available options for the command. + +`--verbose=`_n_ or `-v`_n_ +: Set the verbosity level (0-3). The normal level is 1; a missing _n_ + defaults to 2. + +The various commands and the additional options they support are +described below. In the simple build infrastructure, any other options +will be reported as errors. + +## setup configure ## + +Prepare to build the package. Typically, this step checks that the +target platform is capable of building the package, and discovers +platform-specific features that are needed during the build. + +The user may also adjust the behaviour of later stages using the options +listed in the following subsections. In the simple build +infrastructure, the values supplied via these options are recorded in a +private file read by later stages. + +If a user-supplied `configure` script is run (see the section on +[system-dependent parameters](#system-dependent-parameters) or on +[complex packages](#complex-packages)), it is passed the +`--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`, `--datadir` and +`--libexecdir` options. In addition the value of the `--with-compiler` +option is passed in a `--with-hc` option and all options specified with +`--configure-option=` are passed on. + +### Programs used for building ### + +The following options govern the programs used to process the source +files of a package: + +`--ghc` or `-g`, `--nhc`, `--jhc`, `--hugs` +: Specify which Haskell implementation to use to build the package. + At most one of these flags may be given. If none is given, the + implementation under which the setup script was compiled or + interpreted is used. + +`--with-compiler=`_path_ or `-w`_path_ +: Specify the path to a particular compiler. If given, this must match + the implementation selected above. The default is to search for the + usual name of the selected implementation. + + This flag also sets the default value of the `--with-hc-pkg` option + to the package tool for this compiler. Check the output of `setup + configure -v` to ensure that it finds the right package tool (or use + `--with-hc-pkg` explicitly). + + +`--with-hc-pkg=`_path_ +: Specify the path to the package tool, e.g. `ghc-pkg`. The package + tool must be compatible with the compiler specified by + `--with-compiler`. If this option is omitted, the default value is + determined from the compiler selected. + +`--with-`_`prog`_`=`_path_ +: Specify the path to the program _prog_. Any program known to Cabal + can be used in place of _prog_. It can either be a fully path or the + name of a program that can be found on the program search path. For + example: `--with-ghc=ghc-6.6.1` or + `--with-cpphs=/usr/local/bin/cpphs`. + +`--`_`prog`_`-options=`_options_ +: Specify additional options to the program _prog_. Any program known + to Cabal can be used in place of _prog_. For example: + `--alex-options="--template=mytemplatedir/"`. The _options_ is split + into program options based on spaces. Any options containing embeded + spaced need to be quoted, for example + `--foo-options='--bar="C:\Program File\Bar"'`. As an alternative + that takes only one option at a time but avoids the need to quote, + use `--`_`prog`_`-option` instead. + +`--`_`prog`_`-option=`_option_ +: Specify a single additional option to the program _prog_. For + passing an option that contain embeded spaces, such as a file name + with embeded spaces, using this rather than `--`_`prog`_`-options` + means you do not need an additional level of quoting. Of course if + you are using a command shell you may still need to quote, for + example `--foo-options="--bar=C:\Program File\Bar"`. + +All of the options passed with either `--`_`prog`_`-options` or +`--`_`prog`_`-option` are passed in the order they were specified on the +configure command line. + +### Installation paths ### + +The following options govern the location of installed files from a +package: + +`--prefix=`_dir_ +: The root of the installation. For example for a global install you + might use `/usr/local` on a Unix system, or `C:\Program Files` on a + Windows system. The other installation paths are usually + subdirectories of _prefix_, but they don't have to be. + + In the simple build system, _dir_ may contain the following path + variables: `$pkgid`, `$pkg`, `$version`, `$compiler`, `$os`, + `$arch` + +`--bindir=`_dir_ +: Executables that the user might invoke are installed here. + + In the simple build system, _dir_ may contain the following path + variables: `$prefix`, `$pkgid`, `$pkg`, `$version`, `$compiler`, + `$os`, `$arch` + +`--libdir=`_dir_ +: Object-code libraries are installed here. + + In the simple build system, _dir_ may contain the following path + variables: `$prefix`, `$bindir`, `$pkgid`, `$pkg`, `$version`, + `$compiler`, `$os`, `$arch` + +`--libexecdir=`_dir_ +: Executables that are not expected to be invoked directly by the user + are installed here. + + In the simple build system, _dir_ may contain the following path + variables: `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`, + `$pkg`, `$version`, `$compiler`, `$os`, `$arch` + +`--datadir`=_dir_ +: Architecture-independent data files are installed here. + + In the simple build system, _dir_ may contain the following path + variables: `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`, `$pkg`, + `$version`, `$compiler`, `$os`, `$arch` + +In addition the simple build system supports the following installation path options: + +`--libsubdir=`_dir_ +: A subdirectory of _libdir_ in which libraries are actually + installed. For example, in the simple build system on Unix, the + default _libdir_ is `/usr/local/lib`, and _libsubdir_ contains the + package identifier and compiler, e.g. `mypkg-0.2/ghc-6.4`, so + libraries would be installed in `/usr/local/lib/mypkg-0.2/ghc-6.4`. + + _dir_ may contain the following path variables: `$pkgid`, `$pkg`, + `$version`, `$compiler`, `$os`, `$arch` + +`--datasubdir=`_dir_ +: A subdirectory of _datadir_ in which data files are actually + installed. + + _dir_ may contain the following path variables: `$pkgid`, `$pkg`, + `$version`, `$compiler`, `$os`, `$arch` + +`--docdir=`_dir_ +: Documentation files are installed relative to this directory. + + _dir_ may contain the following path variables: `$prefix`, `$bindir`, + `$libdir`, `$libsubdir`, `$datadir`, `$datasubdir`, `$pkgid`, `$pkg`, + `$version`, `$compiler`, `$os`, `$arch` + +`--htmldir=`_dir_ +: HTML documentation files are installed relative to this directory. + + _dir_ may contain the following path variables: `$prefix`, `$bindir`, + `$libdir`, `$libsubdir`, `$datadir`, `$datasubdir`, `$docdir`, `$pkgid`, + `$pkg`, `$version`, `$compiler`, `$os`, `$arch` + +`--program-prefix=`_prefix_ +: Prepend _prefix_ to installed program names. + + _prefix_ may contain the following path variables: `$pkgid`, `$pkg`, + `$version`, `$compiler`, `$os`, `$arch` + +`--program-suffix=`_suffix_ +: Append _suffix_ to installed program names. The most obvious use for + this is to append the program's version number to make it possible + to install several versions of a program at once: + `--program-suffix='$version'`. + + _suffix_ may contain the following path variables: `$pkgid`, `$pkg`, + `$version`, `$compiler`, `$os`, `$arch` + +#### Path variables in the simple build system #### + +For the simple build system, there are a number of variables that can be +used when specifying installation paths. The defaults are also specified +in terms of these variables. A number of the variables are actually for +other paths, like `$prefix`. This allows paths to be specified relative +to each other rather than as absolute paths, which is important for +building relocatable packages (see [prefix +independence](#prefix-independence)). + +`$prefix` +: The path variable that stands for the root of the installation. For + an installation to be relocatable, all other instllation paths must + be relative to the `$prefix` variable. + +`$bindir` +: The path variable that expands to the path given by the `--bindir` + configure option (or the default). + +`$libdir` +: As above but for `--libdir` + +`$libsubdir` +: As above but for `--libsubdir` + +`$datadir` +: As above but for `--datadir` + +`$datasubdir` +: As above but for `--datasubdir` + +`$docdir` +: As above but for `--docdir` + +`$pkgid` +: The name and version of the package, eg `mypkg-0.2` + +`$pkg` +: The name of the package, eg `mypkg` + +`$version` +: The version of the package, eg `0.2` + +`$compiler` +: The compiler being used to build the package, eg `ghc-6.6.1` + +`$os` +: The operating system of the computer being used to build the + package, eg `linux`, `windows`, `osx`, `freebsd` or `solaris` + +`$arch` +: The architecture of the computer being used to build the package, eg + `i386`, `x86_64`, `ppc` or `sparc` + +#### Paths in the simple build system #### + +For the simple build system, the following defaults apply: + +Option Windows Default Unix Default +------- ---------------- ------------- +`--prefix` (global) `C:\Program Files\Haskell` `/usr/local` +`--prefix` (per-user) `C:\Documents And Settings\user\Application Data\cabal` `$HOME/.cabal` +`--bindir` `$prefix\bin` `$prefix/bin` +`--libdir` `$prefix` `$prefix/lib` +`--libsubdir` (Hugs) `hugs\packages\$pkg` `hugs/packages/$pkg` +`--libsubdir` (others) `$pkgid\$compiler` `$pkgid/$compiler` +`--libexecdir` `$prefix\$pkgid` `$prefix/libexec` +`--datadir` (executable) `$prefix` `$prefix/share` +`--datadir` (library) `C:\Program Files\Haskell` `$prefix/share` +`--datasubdir` `$pkgid` `$pkgid` +`--docdir` `$prefix\doc\$pkgid` `$datadir/doc/$pkgid` +`--htmldir` `$docdir\html` `$docdir/html` +`--program-prefix` (empty) (empty) +`--program-suffix` (empty) (empty) + + +#### Prefix-independence #### + +On Windows, and when using Hugs on any system, it is possible to obtain +the pathname of the running program. This means that we can construct an +installable executable package that is independent of its absolute +install location. The executable can find its auxiliary files by finding +its own path and knowing the location of the other files relative to +`$bindir`. Prefix-independence is particularly +useful: it means the user can choose the install location (i.e. the +value of `$prefix`) at install-time, rather than +having to bake the path into the binary when it is built. + +In order to achieve this, we require that for an executable on Windows, +all of `$bindir`, `$libdir`, `$datadir` and `$libexecdir` begin with +`$prefix`. If this is not the case then the compiled executable will +have baked-in all absolute paths. + +The application need do nothing special to achieve prefix-independence. +If it finds any files using `getDataFileName` and the [other functions +provided for the purpose](#accessing-data-files-from-package-code), the +files will be accessed relative to the location of the current +executable. + +A library cannot (currently) be prefix-independent, because it will be +linked into an executable whose file system location bears no relation +to the library package. + +### Controlling Flag Assignments ### + +Flag assignments (see the [resolution of conditions and +flags](#resolution-of-conditions-and-flags)) can be controlled with the +followingcommand line options. + +`-f` _flagname_ or `-f` `-`_flagname_ +: Force the specified flag to `true` or `false` (if preceded with a `-`). Later + specifications for the same flags will override earlier, i.e., + specifying `-fdebug -f-debug` is equivalent to `-f-debug` + +`--flags=`_flagspecs_ +: Same as `-f`, but allows specifying multiple flag assignments at + once. The parameter is a space-separated list of flag names (to + force a flag to `true`), optionally preceded by a `-` (to force a + flag to `false`). For example, `--flags="debug -feature1 feature2"` is + equivalent to `-fdebug -f-feature1 -ffeature2`. + +### Building Test Suites ### + +`--enable-tests` +: Build the test suites defined in the package description file during the + `build` stage. Check for dependencies required by the test suites. If the + package is configured with this option, it will be possible to run the test + suites with the `test` command after the package is built. + +`--disable-tests` +: (default) Do not build any test suites during the `build` stage. + Do not check for dependencies required only by the test suites. It will not + be possible to invoke the `test` command without reconfiguring the package. + +### Miscellaneous options ## + +`--user` +: Does a per-user installation. This changes the [default installation + prefix](#paths-in-the-simple-build-system). It also allow + dependencies to be satisfied by the user's package database, in + addition to the global database. This also implies a default of + `--user` for any subsequent `install` command, as packages + registered in the global database should not depend on packages + registered in a user's database. + +`--global` +: (default) Does a global installation. In this case package + dependencies must be satisfied by the global package database. All + packages in the user's package database will be ignored. Typically + the final instllation step will require administrative privileges. + +`--package-db=`_db_ +: Allows package dependencies to be satisfied from this additional + package database _db_ in addition to the global package database. + All packages in the user's package database will be ignored. The + interpretation of _db_ is implementation-specific. Typically it will + be a file or directory. Not all implementations support arbitrary + package databases. + +`--enable-optimization`[=_n_] or `-O`[_n_] +: (default) Build with optimization flags (if available). This is + appropriate for production use, taking more time to build faster + libraries and programs. + + The optional _n_ value is the optimisation level. Some compilers + support multiple optimisation levels. The range is 0 to 2. Level 0 + is equivalent to `--disable-optimization`, level 1 is the default if + no _n_ parameter is given. Level 2 is higher optimisation if the + compiler supports it. Level 2 is likely to lead to longer compile + times and bigger generated code. + +`--disable-optimization` +: Build without optimization. This is suited for development: building + will be quicker, but the resulting library or programs will be slower. + +`--enable-library-profiling` or `-p` +: Request that an additional version of the library with profiling + features enabled be built and installed (only for implementations + that support profiling). + +`--disable-library-profiling` +: (default) Do not generate an additional profiling version of the + library. + +`--enable-executable-profiling` +: Any executables generated should have profiling enabled (only for + implementations that support profiling). For this to work, all + libraries used by these executables must also have been built with + profiling support. + +`--disable-executable-profiling` +: (default) Do not enable profiling in generated executables. + +`--enable-library-vanilla` +: (default) Build ordinary libraries (as opposed to profiling + libraries). This is independent of the `--enable-library-profiling` + option. If you enable both, you get both. + +`--disable-library-vanilla` +: Do not build ordinary libraries. This is useful in conjunction with + `--enable-library-profiling` to build only profiling libraries, + rather than profiling and ordinary libraries. + +`--enable-library-for-ghci` +: (default) Build libraries suitable for use with GHCi. + +`--disable-library-for-ghci` +: Not all platforms support GHCi and indeed on some platforms, trying + to build GHCi libs fails. In such cases this flag can be used as a + workaround. + +`--enable-split-objs` +: Use the GHC `-split-objs` feature when building the library. This + reduces the final size of the executables that use the library by + allowing them to link with only the bits that they use rather than + the entire library. The downside is that building the library takes + longer and uses considerably more memory. + +`--disable-split-objs` +: (default) Do not use the GHC `-split-objs` feature. This makes + building the library quicker but the final executables that use the + library will be larger. + +`--enable-executable-stripping` +: (default) When installing binary executable programs, run the + `strip` program on the binary. This can considerably reduce the size + of the executable binary file. It does this by removing debugging + information and symbols. While such extra information is useful for + debugging C programs with traditional debuggers it is rarely helpful + for debugging binaries produced by Haskell compilers. + + Not all Haskell implementations generate native binaries. For such + implementations this option has no effect. + +`--disable-executable-stripping` +: Do not strip binary executables during installation. You might want + to use this option if you need to debug a program using gdb, for + example if you want to debug the C parts of a program containing + both Haskell and C code. Another reason is if your are building a + package for a system which has a policy of managing the stripping + itself (such as some linux distributions). + +`--enable-shared` +: Build shared library. This implies a seperate compiler run to + generate position independent code as required on most platforms. + +`--disable-shared` +: (default) Do not build shared library. + +`--configure-option=`_str_ +: An extra option to an external `configure` script, if one is used + (see the section on [system-dependent + parameters](#system-dependent-parameters)). There can be several of + these options. + +`--extra-include-dirs`[=_dir_] +: An extra directory to search for C header files. You can use this + flag multiple times to get a list of directories. + + You might need to use this flag if you have standard system header + files in a non-standard location that is not mentioned in the + package's `.cabal` file. Using this option has the same affect as + appending the directory _dir_ to the `include-dirs` field in each + library and executable in the package's `.cabal` file. The advantage + of course is that you do not have to modify the package at all. + These extra directories will be used while building the package and + for libraries it is also saved in the package registration + information and used when compiling modules that use the library. + +`--extra-lib-dirs`[=_dir_] +: An extra directory to search for system libraries files. You can use + this flag multiple times to get a list of directories. + + You might need to use this flag if you have standard system + libraries in a non-standard location that is not mentioned in the + package's `.cabal` file. Using this option has the same affect as + appending the directory _dir_ to the `extra-lib-dirs` field in each + library and executable in the package's `.cabal` file. The advantage + of course is that you do not have to modify the package at all. + These extra directories will be used while building the package and + for libraries it is also saved in the package registration + information and used when compiling modules that use the library. + +In the simple build infrastructure, an additional option is recognized: + +`--scratchdir=`_dir_ +: Specify the directory into which the Hugs output will be placed + (default: `dist/scratch`). + +## setup build ## + +Perform any preprocessing or compilation needed to make this package ready for installation. + +This command takes the following options: + +--_prog_-options=_options_, --_prog_-option=_option_ +: These are mostly the same as the [options configure + step](#setup-configure). Unlike the options specified at the + configure step, any program options specified at the build step are + not persistent but are used for that invocation only. They options + specified at the build step are in addition not in replacement of + any options specified at the configure step. + +## setup haddock ## + +Build the documentation for the package using [haddock][]. By default, +only the documentation for the exposed modules is generated (but see the +`--executables` and `--internal` flags below). + +This command takes the following options: + +`--hoogle` +: Generate a file `dist/doc/html/`_pkgid_`.txt`, which can be + converted by [Hoogle](http://www.haskell.org/hoogle/) into a + database for searching. This is equivalent to running [haddock][] + with the `--hoogle` flag. + +`--html-location=`_url_ +: Specify a template for the location of HTML documentation for + prerequisite packages. The substitutions ([see + listing](#paths-in-the-simple-build-system)) are applied to the + template to obtain a location for each package, which will be used + by hyperlinks in the generated documentation. For example, the + following command generates links pointing at [Hackage] pages: + + > setup haddock --html-location='http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html' + + Here the argument is quoted to prevent substitution by the shell. If + this option is omitted, the location for each package is obtained + using the package tool (e.g. `ghc-pkg`). + +`--executables` +: Also run [haddock][] for the modules of all the executable programs. + By default [haddock][] is run only on the exported modules. + +`--internal` +: Run [haddock][] for the all modules, including unexposed ones, and + make [haddock][] generate documentation for unexported symbols as + well. + +`--css=`_path_ +: The argument _path_ denotes a CSS file, which is passed to + [haddock][] and used to set the style of the generated + documentation. This is only needed to override the default style + that [haddock][] uses. + +`--hyperlink-source` +: Generate [haddock][] documentation integrated with [HsColour][]. + First, [HsColour][] is run to generate colourised code. Then + [haddock][] is run to generate HTML documentation. Each entity + shown in the documentation is linked to its definition in the + colourised code. + +`--hscolour-css=`_path_ +: The argument _path_ denotes a CSS file, which is passed to [HsColour][] as in + + > runhaskell Setup.hs hscolour --css=_path_ + +## setup hscolour ## + +Produce colourised code in HTML format using [HsColour][]. Colourised +code for exported modules is put in `dist/doc/html/`_pkgid_`/src`. + +This command takes the following options: + +`--executables` +: Also run [HsColour][] on the sources of all executable programs. + Colourised code is put in `dist/doc/html/`_pkgid_/_executable_`/src`. + +`--css=`_path_ +: Use the given CSS file for the generated HTML files. The CSS file + defines the colours used to colourise code. Note that this copies + the given CSS file to the directory with the generated HTML files + (renamed to `hscolour.css`) rather than linking to it. + +## setup install ## + +Copy the files into the install locations and (for library packages) +register the package with the compiler, i.e. make the modules it +contains available to programs. + +The [install locations](#installation-paths) are determined by options +to `setup configure`. + +This command takes the following options: + +`--global` +: Register this package in the system-wide database. (This is the + default, unless the `--user` option was supplied to the `configure` + command.) + +`--user` +: Register this package in the user's local package database. (This is + the default if the `--user` option was supplied to the `configure` + command.) + +## setup copy ## + +Copy the files without registering them. This command is mainly of use +to those creating binary packages. + +This command takes the following option: + +`--destdir=`_path_ + +Specify the directory under which to place installed files. If this is +not given, then the root directory is assumed. + +## setup register ## + +Register this package with the compiler, i.e. make the modules it +contains available to programs. This only makes sense for library +packages. Note that the `install` command incorporates this action. The +main use of this separate command is in the post-installation step for a +binary package. + +This command takes the following options: + +`--global` +: Register this package in the system-wide database. (This is the default.) + + +`--user` +: Register this package in the user's local package database. + + +`--gen-script` +: Instead of registering the package, generate a script containing + commands to perform the registration. On Unix, this file is called + `register.sh`, on Windows, `register.bat`. This script might be + included in a binary bundle, to be run after the bundle is unpacked + on the target system. + +`--gen-pkg-config`[=_path_] +: Instead of registering the package, generate a package registration + file. This only applies to compilers that support package + registration files which at the moment is only GHC. The file should + be used with the compiler's mechanism for registering packages. This + option is mainly intended for packaging systems. If possible use the + `--gen-script` option instead since it is more portable across + Haskell implementations. The _path_ is + optional and can be used to specify a particular output file to + generate. Otherwise, by default the file is the package name and + version with a `.conf` extension. + +`--inplace` +: Registers the package for use directly from the build tree, without + needing to install it. This can be useful for testing: there's no + need to install the package after modifying it, just recompile and + test. + + This flag does not create a build-tree-local package database. It + still registers the package in one of the user or global databases. + + However, there are some caveats. It only works with GHC + (currently). It only works if your package doesn't depend on having + any supplemental files installed --- plain Haskell libraries should + be fine. + +## setup unregister ## + +Deregister this package with the compiler. + +This command takes the following options: + +`--global` +: Deregister this package in the system-wide database. (This is the default.) + +`--user` +: Deregister this package in the user's local package database. + +`--gen-script` +: Instead of deregistering the package, generate a script containing + commands to perform the deregistration. On Unix, this file is + called `unregister.sh`, on Windows, `unregister.bat`. This script + might be included in a binary bundle, to be run on the target + system. + +## setup clean ## + +Remove any local files created during the `configure`, `build`, +`haddock`, `register` or `unregister` steps, and also any files and +directories listed in the `extra-tmp-files` field. + +This command takes the following options: + +`--save-configure` or `-s` +: Keeps the configuration information so it is not necessary to run + the configure step again before building. + +## setup test ## + +Run the test suites specified in the package description file. Aside from +the following flags, Cabal accepts the name of one or more test suites on the +command line after `test`. When supplied, Cabal will run only the named test +suites, otherwise, Cabal will run all test suites in the package. + +`--builddir=`_dir_ +: The directory where Cabal puts generated build files (default: `dist`). + Test logs will be located in the `test` subdirectory. + +`--human-log=`_path_ +: The template used to name human-readable test logs; the path is relative + to `dist/test`. By default, logs are named according to the template + `$pkgid-$test-suite.log`, so that each test suite will be logged to its own + human-readable log file. Template variables allowed are: `$pkgid`, + `$compiler`, `$os`, `$arch`, `$test-suite`, and `$result`. + +`--machine-log=`_path_ +: The path to the machine-readable log, relative to `dist/test`. The default + template is `$pkgid.log`. Template variables allowed are: `$pkgid`, + `$compiler`, `$os`, `$arch`, and `$result`. + +`--show-details=`_filter_ +: Determines if the results of individual test cases are shown on the + terminal. May be `always` (always show), `never` (never show), or + `failures` (show only the test cases of failing test suites). + +`--test-options=`_options_ +: Give extra options to the test executables. + +`--test-option=`_option_ +: give an extra option to the test executables. There is no need to quote + options containing spaces because a single option is assumed, so options + will not be split on spaces. + +## setup sdist ## + +Create a system- and compiler-independent source distribution in a file +_package_-_version_`.tar.gz` in the `dist` subdirectory, for +distribution to package builders. When unpacked, the commands listed in +this section will be available. + +The files placed in this distribution are the package description file, +the setup script, the sources of the modules named in the package +description file, and files named in the `license-file`, `main-is`, +`c-sources`, `data-files` and `extra-source-files` fields. + +This command takes the following option: + +`--snapshot` +: Append today's date (in "YYYYMMDD" format) to the version number for + the generated source package. The original package is unaffected. + + +[dist-simple]: ../libraries/Cabal/Distribution-Simple.html +[dist-make]: ../libraries/Cabal/Distribution-Make.html +[dist-license]: ../libraries/Cabal/Distribution-License.html#t:License +[extension]: ../libraries/Cabal/Language-Haskell-Extension.html#t:Extension +[BuildType]: ../libraries/Cabal/Distribution-PackageDescription.html#t:BuildType +[alex]: http://www.haskell.org/alex/ +[autoconf]: http://www.gnu.org/software/autoconf/ +[c2hs]: http://www.cse.unsw.edu.au/~chak/haskell/c2hs/ +[cpphs]: http://www.haskell.org/cpphs/ +[greencard]: http://www.haskell.org/greencard/ +[haddock]: http://www.haskell.org/haddock/ +[HsColour]: http://www.cs.york.ac.uk/fp/darcs/hscolour/ +[happy]: http://www.haskell.org/happy/ +[Hackage]: http://hackage.haskell.org/ +[pkg-config]: http://pkg-config.freedesktop.org/ diff --git a/cabal/cabal/doc/misc.markdown b/cabal/cabal/doc/misc.markdown new file mode 100644 --- /dev/null +++ b/cabal/cabal/doc/misc.markdown @@ -0,0 +1,109 @@ +% Cabal User Guide + +# Reporting bugs and deficiencies # + +Please report any flaws or feature requests in the [bug tracker][]. + +For general discussion or queries email the libraries mailing list +. There is also a development mailing list +. + +[bug tracker]: http://hackage.haskell.org/trac/hackage/ + +# Stability of Cabal interfaces # + +The Cabal library and related infrastructure is still under active +development. New features are being added and limitations and bugs are +being fixed. This requires internal changes and often user visible +changes as well. We therefor cannot promise complete future-proof +stability, at least not without halting all development work. + +This section documents the aspects of the Cabal interface that we can +promise to keep stable and which bits are subject to change. + +## Cabal file format ## + +This is backwards compatible and mostly forwards compatible. New fields +can be added without breaking older versions of Cabal. Fields can be +deprecated without breaking older packages. + +## Command-line interface ## + +### Very Stable Command-line interfaces ### + +* `./setup configure` + * `--prefix` + * `--user` + * `--ghc`, `--hugs` + * `--verbose` + * `--prefix` + +* `./setup build` +* `./setup install` +* `./setup register` +* `./setup copy` + +### Stable Command-line interfaces ### + +### Unstable command-line ### + +## Functions and Types ## + +The Cabal library follows the [Package Versioning Policy][PVP]. This +means that within a stable major release, for example 1.2.x, there will +be no incompatible API changes. But minor versions increments, for +example 1.2.3, indicate compatible API additions. + +The Package Versioning Policy does not require any API guarantees +between major releases, for example between 1.2.x and 1.4.x. In practise +of course not everything changes between major releases. Some parts of +the API are more prone to change than others. The rest of this section +gives some informal advice on what level of API stability you can expect +between major releases. + +[PVP]: http://haskell.org/haskellwiki/Package_versioning_policy + +### Very Stable API ### + +* `defaultMain` + +* `defaultMainWithHooks defaultUserHooks` + + But regular `defaultMainWithHooks` isn't stable since `UserHooks` + changes. + +### Semi-stable API ### + +* `UserHooks` The hooks API will change in the future + +* `Distribution.*` is mostly declarative information about packages and + is somewhat stable. + +### Unstable API ### + +Everything under `Distribution.Simple.*` has no stability guarantee. + +## Hackage ## + +The index format is a partly stable interface. It consists of a tar.gz +file that contains directories with `.cabal` files in. In future it may +contain more kinds of files so do not assume every file is a `.cabal` +file. Incompatible revisions to the format would involve bumping the +name of the index file, i.e., `00-index.tar.gz`, `01-index.tar.gz` etc. + + +[dist-simple]: ../libraries/Cabal/Distribution-Simple.html +[dist-make]: ../libraries/Cabal/Distribution-Make.html +[dist-license]: ../libraries/Cabal/Distribution-License.html#t:License +[extension]: ../libraries/Cabal/Language-Haskell-Extension.html#t:Extension +[BuildType]: ../libraries/Cabal/Distribution-PackageDescription.html#t:BuildType +[alex]: http://www.haskell.org/alex/ +[autoconf]: http://www.gnu.org/software/autoconf/ +[c2hs]: http://www.cse.unsw.edu.au/~chak/haskell/c2hs/ +[cpphs]: http://www.haskell.org/cpphs/ +[greencard]: http://www.haskell.org/greencard/ +[haddock]: http://www.haskell.org/haddock/ +[HsColour]: http://www.cs.york.ac.uk/fp/darcs/hscolour/ +[happy]: http://www.haskell.org/happy/ +[HackageDB]: http://hackage.haskell.org/ +[pkg-config]: http://pkg-config.freedesktop.org/ diff --git a/cabal/cabal/prologue.txt b/cabal/cabal/prologue.txt new file mode 100644 --- /dev/null +++ b/cabal/cabal/prologue.txt @@ -0,0 +1,7 @@ +The Haskell Cabal is the Common Architecture for Building Applications +and Libraries. It is a framework which defines a common interface for +authors to more easily build their 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. For more information, please see: +. diff --git a/cabal/cabal/runTests.sh b/cabal/cabal/runTests.sh new file mode 100644 --- /dev/null +++ b/cabal/cabal/runTests.sh @@ -0,0 +1,21 @@ +#!/bin/sh + +HCBASE=/usr/bin/ +HC=$HCBASE/ghc +GHCFLAGS='--make -Wall -fno-warn-unused-matches -cpp' +ISPOSIX=-DHAVE_UNIX_PACKAGE + +rm -f moduleTest +mkdir -p dist/debug +echo Building... +$HC $GHCFLAGS $ISPOSIX -DDEBUG -odir dist/debug -hidir dist/debug -idist/debug/:.:tests/HUnit-1.0/src tests/ModuleTest.hs -o moduleTest 2> stderr +RES=$? +if [ $RES != 0 ] +then + cat stderr >&2 + exit $RES +fi +echo Running... +./moduleTest +echo Done + diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs @@ -0,0 +1,15 @@ +module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "GlobalBuildDepsNotAdditive1") [] + result <- cabal_build spec + assertEqual "cabal build should fail - see test-log.txt" False (successful result) + assertBool "cabal error should be \"Failed to load interface for `Prelude'\"" $ + "Failed to load interface for `Prelude'" `isInfixOf` outputText result diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal @@ -0,0 +1,20 @@ +name: GlobalBuildDepsNotAdditive1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + If you specify 'base' in the global build dependencies, then define + a library without base, it fails to find 'base' for the library. + +--------------------------------------- + +build-depends: base + +Library + exposed-modules: MyLibrary + build-depends: bytestring, old-time diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs @@ -0,0 +1,15 @@ +module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "GlobalBuildDepsNotAdditive2") [] + result <- cabal_build spec + assertEqual "cabal build should fail - see test-log.txt" False (successful result) + assertBool "cabal error should be \"Failed to load interface for `Prelude'\"" $ + "Failed to load interface for `Prelude'" `isInfixOf` outputText result diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal @@ -0,0 +1,20 @@ +name: GlobalBuildDepsNotAdditive1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + If you specify 'base' in the global build dependencies, then define + an executable without base, it fails to find 'base' for the executable + +--------------------------------------- + +build-depends: base + +Executable lemon + main-is: lemon.hs + build-depends: bytestring, old-time diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs @@ -0,0 +1,20 @@ +module PackageTests.BuildDeps.InternalLibrary0.Check where + +import Test.HUnit +import PackageTests.PackageTester +import Control.Monad +import System.FilePath +import Data.Version +import Data.List (isInfixOf, intercalate) + + +suite :: Version -> Test +suite cabalVersion = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary0") [] + result <- cabal_build spec + assertEqual "cabal build should fail" False (successful result) + when (cabalVersion >= Version [1, 7] []) $ do + -- In 1.7 it should tell you how to enable the desired behaviour. + assertEqual "error should say 'library which is defined within the same package.'" True $ + "library which is defined within the same package." `isInfixOf` (intercalate " " $ lines $ outputText result) + diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal @@ -0,0 +1,24 @@ +name: InternalLibrary0 +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check that with 'cabal-version:' containing versions less than 1.7, we do *not* + have the new behaviour to allow executables to refer to the library defined + in the same module. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary0 diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs @@ -0,0 +1,12 @@ +module PackageTests.BuildDeps.InternalLibrary1.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary1") [] + result <- cabal_build spec + assertEqual "cabal build should succeed - see test-log.txt" True (successful result) diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal @@ -0,0 +1,23 @@ +name: InternalLibrary1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check for the new (in >= 1.7.1) ability to allow executables to refer to + the library defined in the same module. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary1 diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs @@ -0,0 +1,24 @@ +module PackageTests.BuildDeps.InternalLibrary2.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import qualified Data.ByteString.Char8 as C + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary2") [] + let specTI = PackageSpec (directory spec "to-install") [] + + unregister "InternalLibrary2" + iResult <- cabal_install specTI + assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult) + bResult <- cabal_build spec + assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult) + unregister "InternalLibrary2" + + (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" [] + C.appendFile (directory spec "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output) + assertEqual "executable should have linked with the internal library" "myLibFunc internal" (concat $ lines output) + diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc internal" + C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal @@ -0,0 +1,23 @@ +name: InternalLibrary2 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name and version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary2 diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc installed" + C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal @@ -0,0 +1,18 @@ +name: InternalLibrary2 +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name and version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs @@ -0,0 +1,24 @@ +module PackageTests.BuildDeps.InternalLibrary3.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import qualified Data.ByteString.Char8 as C + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary3") [] + let specTI = PackageSpec (directory spec "to-install") [] + + unregister "InternalLibrary3" + iResult <- cabal_install specTI + assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult) + bResult <- cabal_build spec + assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult) + unregister "InternalLibrary3" + + (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" [] + C.appendFile (directory spec "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output) + assertEqual "executable should have linked with the internal library" "myLibFunc internal" (concat $ lines output) + diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc internal" + C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal @@ -0,0 +1,23 @@ +name: InternalLibrary3 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name, but a *newer* version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary3 diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc installed" + C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal @@ -0,0 +1,18 @@ +name: InternalLibrary3 +version: 0.2 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name but a *newer* version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs @@ -0,0 +1,24 @@ +module PackageTests.BuildDeps.InternalLibrary4.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import qualified Data.ByteString.Char8 as C + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary4") [] + let specTI = PackageSpec (directory spec "to-install") [] + + unregister "InternalLibrary4" + iResult <- cabal_install specTI + assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult) + bResult <- cabal_build spec + assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult) + unregister "InternalLibrary4" + + (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" [] + C.appendFile (directory spec "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output) + assertEqual "executable should have linked with the installed library" "myLibFunc installed" (concat $ lines output) + diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc internal" + C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal @@ -0,0 +1,23 @@ +name: InternalLibrary4 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that we can explicitly say we want InternalLibrary4-0.2 + and it will give us the *installed* version 0.2 instead of the internal 0.1. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary4 >= 0.2 diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc installed" + C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal @@ -0,0 +1,18 @@ +name: InternalLibrary4 +version: 0.2 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name but a *newer* version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs @@ -0,0 +1,12 @@ +module PackageTests.BuildDeps.SameDepsAllRound.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "SameDepsAllRound") [] + result <- cabal_build spec + assertEqual "cabal build should succeed - see test-log.txt" True (successful result) diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal @@ -0,0 +1,31 @@ +name: SameDepsAllRound +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +synopsis: Same dependencies all round +category: PackageTests +build-type: Simple + +description: + Check for the "old build-dep behaviour" namely that we get the same + package dependencies on all build targets, even if different ones + were specified for different targets + . + Here all .hs files use the three packages mentioned, so this shows + that build-depends is not target-specific. This is the behaviour + we want when cabal-version contains versions less than 1.7. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring + +Executable lemon + main-is: lemon.hs + build-depends: old-time + +Executable pineapple + main-is: pineapple.hs diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs b/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs b/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "pineapple" + C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs @@ -0,0 +1,18 @@ +module PackageTests.BuildDeps.TargetSpecificDeps1.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "TargetSpecificDeps1") [] + result <- cabal_build spec + assertEqual "cabal build should fail - see test-log.txt" False (successful result) + assertBool "error should be in MyLibrary.hs" $ + "MyLibrary.hs:" `isInfixOf` outputText result + assertBool "error should be \"Could not find module `System.Time\"" $ + "Could not find module `System.Time'" `isInfixOf` + (intercalate " " $ lines $ outputText result) diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal @@ -0,0 +1,22 @@ +name: TargetSpecificDeps1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check for the new build-dep behaviour, where build-depends are + handled specifically for each target + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring + +Executable lemon + main-is: lemon.hs + build-depends: base, bytestring, old-time diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs @@ -0,0 +1,13 @@ +module PackageTests.BuildDeps.TargetSpecificDeps2.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "TargetSpecificDeps2") [] + result <- cabal_build spec + assertEqual "cabal build should succeed - see test-log.txt" True (successful result) diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs @@ -0,0 +1,5 @@ +import qualified Data.ByteString.Char8 as C + +main = do + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal @@ -0,0 +1,24 @@ +name: TargetSpecificDeps1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check for the new build-dep behaviour, where build-depends are + handled specifically for each target + This one is a control against TargetSpecificDeps1 - it is correct and should + succeed. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + build-depends: base, bytestring diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs @@ -0,0 +1,17 @@ +module PackageTests.BuildDeps.TargetSpecificDeps3.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "TargetSpecificDeps3") [] + result <- cabal_build spec + assertEqual "cabal build should fail - see test-log.txt" False (successful result) + assertBool "error should be in lemon.hs" $ + "lemon.hs:" `isInfixOf` outputText result + assertBool "error should be \"Could not find module `System.Time\"" $ + "Could not find module `System.Time'" `isInfixOf` (intercalate " " $ lines $ outputText result) diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "lemon" + C.putStrLn $ C.pack text diff --git a/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal @@ -0,0 +1,22 @@ +name: test +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check for the new build-dep behaviour, where build-depends are + handled specifically for each target + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + build-depends: base, bytestring diff --git a/cabal/cabal/tests/PackageTests/PackageTester.hs b/cabal/cabal/tests/PackageTests/PackageTester.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/PackageTester.hs @@ -0,0 +1,192 @@ +module PackageTests.PackageTester ( + PackageSpec(..), + Success(..), + Result(..), + cabal_configure, + cabal_build, + cabal_test, + cabal_install, + unregister, + run + ) where + +import qualified Control.Exception.Extensible as E +import System.Directory +import System.FilePath +import System.IO +import System.Posix.IO +import System.Process +import System.Exit +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Concurrent +import Control.Monad +import Data.List +import Data.Maybe +import qualified Data.ByteString.Char8 as C + + +data PackageSpec = + PackageSpec { + directory :: FilePath, + configOpts :: [String] + } + +data Success = Failure | ConfigureSuccess | BuildSuccess | InstallSuccess | TestSuccess deriving (Eq, Show) + +data Result = Result { + successful :: Bool, + success :: Success, + outputText :: String + } + deriving Show + +nullResult :: Result +nullResult = Result True Failure "" + +recordRun :: (String, ExitCode, String) -> Success -> Result -> Result +recordRun (cmd, exitCode, exeOutput) thisSucc res = + res { + successful = successful res && exitCode == ExitSuccess, + success = if exitCode == ExitSuccess then thisSucc + else success res, + outputText = + (if null $ outputText res then "" else outputText res ++ "\n") ++ + cmd ++ "\n" ++ exeOutput + } + +cabal_configure :: PackageSpec -> IO Result +cabal_configure spec = do + res <- doCabalConfigure spec + record spec res + return res + +doCabalConfigure :: PackageSpec -> IO Result +doCabalConfigure spec = do + cleanResult@(_, _, cleanOutput) <- cabal spec ["clean"] + requireSuccess cleanResult + res <- cabal spec $ ["configure", "--user"] ++ configOpts spec + return $ recordRun res ConfigureSuccess nullResult + +doCabalBuild :: PackageSpec -> IO Result +doCabalBuild spec = do + configResult <- doCabalConfigure spec + if successful configResult + then do + res <- cabal spec ["build"] + return $ recordRun res BuildSuccess configResult + else + return configResult + +cabal_build :: PackageSpec -> IO Result +cabal_build spec = do + res <- doCabalBuild spec + record spec res + return res + +unregister :: String -> IO () +unregister libraryName = do + res@(_, _, output) <- run Nothing "ghc-pkg" ["unregister", "--user", libraryName] + if "cannot find package" `isInfixOf` output + then return () + else requireSuccess res + +-- | Install this library in the user area +cabal_install :: PackageSpec -> IO Result +cabal_install spec = do + buildResult <- doCabalBuild spec + res <- if successful buildResult + then do + res <- cabal spec ["install"] + return $ recordRun res InstallSuccess buildResult + else + return buildResult + record spec res + return res + +cabal_test :: PackageSpec -> IO Result +cabal_test spec = do + res <- cabal spec ["test"] + let r = recordRun res TestSuccess nullResult + record spec r + return r + +-- | Returns the command that was issued, the return code, and hte output text +cabal :: PackageSpec -> [String] -> IO (String, ExitCode, String) +cabal spec cabalArgs = do + wd <- getCurrentDirectory + r <- run (Just $ directory spec) "ghc" + [ "--make" + , "-fhpc" + , "-package-conf " ++ wd "../dist/package.conf.inplace" + , "Setup.hs" + ] + requireSuccess r + run (Just $ directory spec) (wd directory spec "Setup") cabalArgs + +-- | Returns the command that was issued, the return code, and hte output text +run :: Maybe FilePath -> String -> [String] -> IO (String, ExitCode, String) +run cwd cmd args = do + -- Posix-specific + (outf, outf0) <- createPipe + (errf, errf0) <- createPipe + outh <- fdToHandle outf + outh0 <- fdToHandle outf0 + errh <- fdToHandle errf + errh0 <- fdToHandle errf0 + pid <- runProcess cmd args cwd Nothing Nothing (Just outh0) (Just errh0) + + {- + -- ghc-6.10.1 specific + (Just inh, Just outh, Just errh, pid) <- + createProcess (proc cmd args){ std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe, + cwd = cwd } + hClose inh -- done with stdin + -} + + -- fork off a thread to start consuming the output + outChan <- newChan + forkIO $ suckH outChan outh + forkIO $ suckH outChan errh + + output <- suckChan outChan + + hClose outh + hClose errh + + -- wait on the process + ex <- waitForProcess pid + let fullCmd = intercalate " " $ cmd:args + return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd, + ex, output) + where + suckH chan h = do + eof <- hIsEOF h + if eof + then writeChan chan Nothing + else do + c <- hGetChar h + writeChan chan $ Just c + suckH chan h + suckChan chan = sc' chan 2 [] + where + sc' _ 0 acc = return $ reverse acc + sc' chan eofs acc = do + mC <- readChan chan + case mC of + Just c -> sc' chan eofs (c:acc) + Nothing -> sc' chan (eofs-1) acc + +requireSuccess :: (String, ExitCode, String) -> IO () +requireSuccess (cmd, exitCode, output) = do + case exitCode of + ExitSuccess -> return () + ExitFailure r -> do + ioError $ userError $ "Command " ++ cmd ++ " failed." + +record :: PackageSpec -> Result -> IO () +record spec res = do + C.writeFile (directory spec "test-log.txt") (C.pack $ outputText res) + diff --git a/cabal/cabal/tests/PackageTests/TestStanza/Check.hs b/cabal/cabal/tests/PackageTests/TestStanza/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/TestStanza/Check.hs @@ -0,0 +1,57 @@ +module PackageTests.TestStanza.Check where + +import Test.HUnit +import System.FilePath +import PackageTests.PackageTester +import Data.List (isInfixOf, intercalate) +import Distribution.Version +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Package + ( PackageIdentifier(..), PackageName(..), Dependency(..) ) +import Distribution.PackageDescription + ( PackageDescription(..), BuildInfo(..), TestSuite(..), Library(..) + , TestSuiteInterface(..) + , TestType(..), emptyPackageDescription, emptyBuildInfo, emptyLibrary + , emptyTestSuite, BuildType(..) ) +import Distribution.Verbosity (silent) +import Distribution.License (License(..)) +import Distribution.ModuleName (fromString) +import Distribution.System (buildPlatform) +import Distribution.Compiler + ( CompilerId(..), CompilerFlavor(..) ) +import Distribution.Text + +suite :: Version -> Test +suite cabalVersion = TestCase $ do + let directory = "PackageTests" "TestStanza" + pdFile = directory "my" <.> "cabal" + spec = PackageSpec directory [] + result <- cabal_configure spec + let message = "cabal configure should recognize test section" + test = "unknown section type" + `isInfixOf` + (intercalate " " $ lines $ outputText result) + assertEqual message False test + genPD <- readPackageDescription silent pdFile + let compiler = CompilerId GHC $ Version [6, 12, 2] [] + anyV = intersectVersionRanges anyVersion anyVersion + anticipatedTestSuite = emptyTestSuite + { testName = "dummy" + , testInterface = TestSuiteExeV10 (Version [1,0] []) "dummy.hs" + , testBuildInfo = emptyBuildInfo + { targetBuildDepends = + [ Dependency (PackageName "base") anyVersion ] + , hsSourceDirs = ["."] + } + , testEnabled = False + } + case finalizePackageDescription [] (const True) buildPlatform compiler [] genPD of + Left xs -> let depMessage = "should not have missing dependencies:\n" ++ + (unlines $ map (show . disp) xs) + in assertEqual depMessage True False + Right (f, _) -> let gotTest = head $ testSuites f + in assertEqual "parsed test-suite stanza does not match anticipated" + gotTest anticipatedTestSuite diff --git a/cabal/cabal/tests/PackageTests/TestStanza/Setup.hs b/cabal/cabal/tests/PackageTests/TestStanza/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/TestStanza/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/cabal/tests/PackageTests/TestStanza/my.cabal b/cabal/cabal/tests/PackageTests/TestStanza/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/TestStanza/my.cabal @@ -0,0 +1,19 @@ +name: TestStanza +version: 0.1 +license: BSD3 +author: Thomas Tuegel +stability: stable +category: PackageTests +build-type: Simple + +description: + Check that Cabal recognizes the Test stanza defined below. + +Library + exposed-modules: MyLibrary + build-depends: base + +test-suite dummy + main-is: dummy.hs + type: exitcode-stdio-1.0 + build-depends: base diff --git a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Check.hs b/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Check.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Check.hs @@ -0,0 +1,47 @@ +module PackageTests.TestSuiteExeV10.Check + ( checkTest + , checkTestWithHpc + ) where + +import Distribution.PackageDescription ( TestSuite(..), emptyTestSuite ) +import Distribution.Simple.Hpc +import Distribution.Version +import Test.HUnit +import System.Directory +import System.FilePath +import PackageTests.PackageTester + +dir :: FilePath +dir = "PackageTests" "TestSuiteExeV10" + +checkTest :: Version -> Test +checkTest cabalVersion = TestCase $ do + let spec = PackageSpec dir ["--enable-tests"] + buildResult <- cabal_build spec + let buildMessage = "\'setup build\' should succeed" + assertEqual buildMessage True $ successful buildResult + testResult <- cabal_test spec + let testMessage = "\'setup test\' should succeed" + assertEqual testMessage True $ successful testResult + +checkTestWithHpc :: Version -> Test +checkTestWithHpc cabalVersion = TestCase $ do + let spec = PackageSpec dir [ "--enable-tests" + , "--enable-library-coverage" + ] + buildResult <- cabal_build spec + let buildMessage = "\'setup build\' should succeed" + assertEqual buildMessage True $ successful buildResult + testResult <- cabal_test spec + let testMessage = "\'setup test\' should succeed" + assertEqual testMessage True $ successful testResult + let dummy = emptyTestSuite { testName = "test-Foo" } + tixFile = tixFilePath (dir "dist") dummy + tixFileMessage = ".tix file should exist" + markupDir = tixDir (dir "dist") dummy + markupFile = markupDir "hpc_index" <.> "html" + markupFileMessage = "HPC markup file should exist" + tixFileExists <- doesFileExist tixFile + assertEqual tixFileMessage True tixFileExists + markupFileExists <- doesFileExist markupFile + assertEqual markupFileMessage True markupFileExists diff --git a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs b/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs @@ -0,0 +1,4 @@ +module Foo where + +fooTest :: [String] -> Bool +fooTest _ = True diff --git a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs b/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/my.cabal b/cabal/cabal/tests/PackageTests/TestSuiteExeV10/my.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/TestSuiteExeV10/my.cabal @@ -0,0 +1,15 @@ +name: my +version: 0.1 +license: BSD3 +cabal-version: >= 1.9.2 +build-type: Simple + +library + exposed-modules: Foo + build-depends: base + +test-suite test-Foo + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: test-Foo.hs + build-depends: base, my diff --git a/cabal/cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs b/cabal/cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs @@ -0,0 +1,8 @@ +module Main where + +import Foo +import System.Exit + +main :: IO () +main | fooTest [] = exitSuccess + | otherwise = exitFailure diff --git a/cabal/cabal/tests/README b/cabal/cabal/tests/README new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/README @@ -0,0 +1,14 @@ +Building and running the test suite +=================================== + +You can build and run the test suite by running: + + cabal configure && cabal build + cd tests + cabal configure --package-db=../dist/package.conf.inplace \ + --constraint='Cabal == 1.9.1' + cabal build + ./dist/build/suite/suite + +Replace the Cabal constraint with whatever the current development +version of Cabal. diff --git a/cabal/cabal/tests/Setup.hs b/cabal/cabal/tests/Setup.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/cabal/cabal/tests/Test/Distribution/Version.hs b/cabal/cabal/tests/Test/Distribution/Version.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/Test/Distribution/Version.hs @@ -0,0 +1,644 @@ +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns #-} +module Test.Distribution.Version (properties) where + +import Distribution.Version +import Distribution.Text + +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>), (<+>)) + +import Test.QuickCheck +import Test.QuickCheck.Utils +import qualified Test.Laws as Laws + +import Control.Monad (liftM, liftM2) +import Data.Maybe (isJust, fromJust) +import Data.List (sort, sortBy, nub) +import Data.Ord (comparing) + +properties :: [Property] +properties = + -- properties to validate the test framework + [ property prop_nonNull + , property prop_gen_intervals1 + , property prop_gen_intervals2 + , property prop_equivalentVersionRange + , property prop_intermediateVersion + + -- the basic syntactic version range functions + , property prop_anyVersion + , property prop_noVersion + , property prop_thisVersion + , property prop_notThisVersion + , property prop_laterVersion + , property prop_orLaterVersion + , property prop_earlierVersion + , property prop_orEarlierVersion + , property prop_unionVersionRanges + , property prop_intersectVersionRanges + , property prop_withinVersion + , property prop_foldVersionRange + , property prop_foldVersionRange' + + -- the semantic query functions + , property prop_isAnyVersion1 + , property prop_isAnyVersion2 + , property prop_isNoVersion + , property prop_isSpecificVersion1 + , property prop_isSpecificVersion2 + , property prop_simplifyVersionRange1 + , property prop_simplifyVersionRange1' + , property prop_simplifyVersionRange2 + , property prop_simplifyVersionRange2' + , property prop_simplifyVersionRange2'' --FIXME + + -- converting between version ranges and version intervals + , property prop_to_intervals + , property prop_to_intervals_canonical + , property prop_to_intervals_canonical' + , property prop_from_intervals + , property prop_to_from_intervals + , property prop_from_to_intervals + , property prop_from_to_intervals' + + -- union and intersection of version intervals + , property prop_unionVersionIntervals + , property prop_unionVersionIntervals_idempotent + , property prop_unionVersionIntervals_commutative + , property prop_unionVersionIntervals_associative + , property prop_intersectVersionIntervals + , property prop_intersectVersionIntervals_idempotent + , property prop_intersectVersionIntervals_commutative + , property prop_intersectVersionIntervals_associative + , property prop_union_intersect_distributive + , property prop_intersect_union_distributive + + -- parsing an pretty printing + , property prop_parse_disp1 + , property prop_parse_disp2 + , property prop_parse_disp3 + ] + +instance Arbitrary Version where + arbitrary = do + branch <- smallListOf1 $ + frequency [(3, return 0) + ,(3, return 1) + ,(2, return 2) + ,(1, return 3)] + return (Version branch []) -- deliberate [] + where + smallListOf1 = adjustSize (\n -> min 5 (n `div` 3)) . listOf1 + + shrink (Version branch []) = + [ Version branch' [] | branch' <- shrink branch, not (null branch') ] + shrink (Version branch _tags) = + [ Version branch [] ] + +instance Arbitrary VersionRange where + arbitrary = sized verRangeExp + where + verRangeExp n = frequency $ + [ (2, return anyVersion) + , (1, liftM thisVersion arbitrary) + , (1, liftM laterVersion arbitrary) + , (1, liftM orLaterVersion arbitrary) + , (1, liftM orLaterVersion' arbitrary) + , (1, liftM earlierVersion arbitrary) + , (1, liftM orEarlierVersion arbitrary) + , (1, liftM orEarlierVersion' arbitrary) + , (1, liftM withinVersion arbitrary) + , (2, liftM VersionRangeParens arbitrary) + ] ++ if n == 0 then [] else + [ (2, liftM2 unionVersionRanges verRangeExp2 verRangeExp2) + , (2, liftM2 intersectVersionRanges verRangeExp2 verRangeExp2) + ] + where + verRangeExp2 = verRangeExp (n `div` 2) + + orLaterVersion' v = + UnionVersionRanges (LaterVersion v) (ThisVersion v) + orEarlierVersion' v = + UnionVersionRanges (EarlierVersion v) (ThisVersion v) + +--------------------------- +-- VersionRange properties +-- + +prop_nonNull :: Version -> Bool +prop_nonNull = not . null . versionBranch + +prop_anyVersion :: Version -> Bool +prop_anyVersion v' = + withinRange v' anyVersion == True + +prop_noVersion :: Version -> Bool +prop_noVersion v' = + withinRange v' noVersion == False + +prop_thisVersion :: Version -> Version -> Bool +prop_thisVersion v v' = + withinRange v' (thisVersion v) + == (v' == v) + +prop_notThisVersion :: Version -> Version -> Bool +prop_notThisVersion v v' = + withinRange v' (notThisVersion v) + == (v' /= v) + +prop_laterVersion :: Version -> Version -> Bool +prop_laterVersion v v' = + withinRange v' (laterVersion v) + == (v' > v) + +prop_orLaterVersion :: Version -> Version -> Bool +prop_orLaterVersion v v' = + withinRange v' (orLaterVersion v) + == (v' >= v) + +prop_earlierVersion :: Version -> Version -> Bool +prop_earlierVersion v v' = + withinRange v' (earlierVersion v) + == (v' < v) + +prop_orEarlierVersion :: Version -> Version -> Bool +prop_orEarlierVersion v v' = + withinRange v' (orEarlierVersion v) + == (v' <= v) + +prop_unionVersionRanges :: VersionRange -> VersionRange -> Version -> Bool +prop_unionVersionRanges vr1 vr2 v' = + withinRange v' (unionVersionRanges vr1 vr2) + == (withinRange v' vr1 || withinRange v' vr2) + +prop_intersectVersionRanges :: VersionRange -> VersionRange -> Version -> Bool +prop_intersectVersionRanges vr1 vr2 v' = + withinRange v' (intersectVersionRanges vr1 vr2) + == (withinRange v' vr1 && withinRange v' vr2) + +prop_withinVersion :: Version -> Version -> Bool +prop_withinVersion v v' = + withinRange v' (withinVersion v) + == (v' >= v && v' < upper v) + where + upper (Version lower t) = Version (init lower ++ [last lower + 1]) t + +prop_foldVersionRange :: VersionRange -> Bool +prop_foldVersionRange range = + expandWildcard range + == foldVersionRange anyVersion thisVersion + laterVersion earlierVersion + unionVersionRanges intersectVersionRanges + range + where + expandWildcard (WildcardVersion v) = + intersectVersionRanges (orLaterVersion v) (earlierVersion (upper v)) + where + upper (Version lower t) = Version (init lower ++ [last lower + 1]) t + + expandWildcard (UnionVersionRanges v1 v2) = + UnionVersionRanges (expandWildcard v1) (expandWildcard v2) + expandWildcard (IntersectVersionRanges v1 v2) = + IntersectVersionRanges (expandWildcard v1) (expandWildcard v2) + expandWildcard (VersionRangeParens v) = expandWildcard v + expandWildcard v = v + + +prop_foldVersionRange' :: VersionRange -> Bool +prop_foldVersionRange' range = + canonicalise range + == foldVersionRange' anyVersion thisVersion + laterVersion earlierVersion + orLaterVersion orEarlierVersion + (\v _ -> withinVersion v) + unionVersionRanges intersectVersionRanges id + range + where + canonicalise (UnionVersionRanges (LaterVersion v) + (ThisVersion v')) | v == v' + = UnionVersionRanges (ThisVersion v') + (LaterVersion v) + canonicalise (UnionVersionRanges (EarlierVersion v) + (ThisVersion v')) | v == v' + = UnionVersionRanges (ThisVersion v') + (EarlierVersion v) + canonicalise (UnionVersionRanges v1 v2) = + UnionVersionRanges (canonicalise v1) (canonicalise v2) + canonicalise (IntersectVersionRanges v1 v2) = + IntersectVersionRanges (canonicalise v1) (canonicalise v2) + canonicalise (VersionRangeParens v) = canonicalise v + canonicalise v = v + + +prop_isAnyVersion1 :: VersionRange -> Version -> Property +prop_isAnyVersion1 range version = + isAnyVersion range ==> withinRange version range + +prop_isAnyVersion2 :: VersionRange -> Property +prop_isAnyVersion2 range = + isAnyVersion range ==> + foldVersionRange True (\_ -> False) (\_ -> False) (\_ -> False) + (\_ _ -> False) (\_ _ -> False) + (simplifyVersionRange range) + +prop_isNoVersion :: VersionRange -> Version -> Property +prop_isNoVersion range version = + isNoVersion range ==> not (withinRange version range) + +prop_isSpecificVersion1 :: VersionRange -> NonEmptyList Version -> Property +prop_isSpecificVersion1 range (NonEmpty versions) = + isJust version && not (null versions') ==> + allEqual (fromJust version : versions') + where + version = isSpecificVersion range + versions' = filter (`withinRange` range) versions + allEqual xs = and (zipWith (==) xs (tail xs)) + +prop_isSpecificVersion2 :: VersionRange -> Property +prop_isSpecificVersion2 range = + isJust version ==> + foldVersionRange Nothing Just (\_ -> Nothing) (\_ -> Nothing) + (\_ _ -> Nothing) (\_ _ -> Nothing) + (simplifyVersionRange range) + == version + + where + version = isSpecificVersion range + +-- | 'simplifyVersionRange' is a semantic identity on 'VersionRange'. +-- +prop_simplifyVersionRange1 :: VersionRange -> Version -> Bool +prop_simplifyVersionRange1 range version = + withinRange version range == withinRange version (simplifyVersionRange range) + +prop_simplifyVersionRange1' :: VersionRange -> Bool +prop_simplifyVersionRange1' range = + range `equivalentVersionRange` (simplifyVersionRange range) + +-- | 'simplifyVersionRange' produces a canonical form for ranges with +-- equivalent semantics. +-- +prop_simplifyVersionRange2 :: VersionRange -> VersionRange -> Version -> Property +prop_simplifyVersionRange2 r r' v = + r /= r' && simplifyVersionRange r == simplifyVersionRange r' ==> + withinRange v r == withinRange v r' + +prop_simplifyVersionRange2' :: VersionRange -> VersionRange -> Property +prop_simplifyVersionRange2' r r' = + r /= r' && simplifyVersionRange r == simplifyVersionRange r' ==> + r `equivalentVersionRange` r' + +--FIXME: see equivalentVersionRange for details +prop_simplifyVersionRange2'' :: VersionRange -> VersionRange -> Property +prop_simplifyVersionRange2'' r r' = + r /= r' && r `equivalentVersionRange` r' ==> + simplifyVersionRange r == simplifyVersionRange r' + || isNoVersion r + || isNoVersion r' + +-------------------- +-- VersionIntervals +-- + +-- | Generating VersionIntervals +-- +-- This is a tad tricky as VersionIntervals is an abstract type, so we first +-- make a local type for generating the internal representation. Then we check +-- that this lets us construct valid 'VersionIntervals'. +-- +newtype VersionIntervals' = VersionIntervals' [VersionInterval] + deriving (Eq, Show) + +instance Arbitrary VersionIntervals' where + arbitrary = do + ubound <- arbitrary + bounds <- arbitrary + let intervals = mergeTouching + . map fixEmpty + . replaceUpper ubound + . pairs + . sortBy (comparing fst) + $ bounds + return (VersionIntervals' intervals) + + where + pairs ((l, lb):(u, ub):bs) = (LowerBound l lb, UpperBound u ub) + : pairs bs + pairs _ = [] + + replaceUpper NoUpperBound [(l,_)] = [(l, NoUpperBound)] + replaceUpper NoUpperBound (i:is) = i : replaceUpper NoUpperBound is + replaceUpper _ is = is + + -- merge adjacent intervals that touch + mergeTouching (i1@(l,u):i2@(l',u'):is) + | doesNotTouch u l' = i1 : mergeTouching (i2:is) + | otherwise = mergeTouching ((l,u'):is) + mergeTouching is = is + + doesNotTouch :: UpperBound -> LowerBound -> Bool + doesNotTouch NoUpperBound _ = False + doesNotTouch (UpperBound u ub) (LowerBound l lb) = + u < l + || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) + + fixEmpty (LowerBound l _, UpperBound u _) + | l == u = (LowerBound l InclusiveBound, UpperBound u InclusiveBound) + fixEmpty i = i + + shrink (VersionIntervals' intervals) = + [ VersionIntervals' intervals' | intervals' <- shrink intervals ] + +instance Arbitrary Bound where + arbitrary = elements [ExclusiveBound, InclusiveBound] + +instance Arbitrary LowerBound where + arbitrary = liftM2 LowerBound arbitrary arbitrary + +instance Arbitrary UpperBound where + arbitrary = oneof [return NoUpperBound + ,liftM2 UpperBound arbitrary arbitrary] + +-- | Check that our VersionIntervals' arbitrary instance generates intervals +-- that satisfies the invariant. +-- +prop_gen_intervals1 :: VersionIntervals' -> Bool +prop_gen_intervals1 (VersionIntervals' intervals) = + isJust (mkVersionIntervals intervals) + +instance Arbitrary VersionIntervals where + arbitrary = do + VersionIntervals' intervals <- arbitrary + case mkVersionIntervals intervals of + Just xs -> return xs + +-- | Check that constructing our intervals type and converting it to a +-- 'VersionRange' and then into the true intervals type gives us back +-- the exact same sequence of intervals. This tells us that our arbitrary +-- instance for 'VersionIntervals'' is ok. +-- +prop_gen_intervals2 :: VersionIntervals' -> Bool +prop_gen_intervals2 (VersionIntervals' intervals') = + asVersionIntervals (fromVersionIntervals intervals) == intervals' + where + Just intervals = mkVersionIntervals intervals' + +-- | Check that 'VersionIntervals' models 'VersionRange' via +-- 'toVersionIntervals'. +-- +prop_to_intervals :: VersionRange -> Version -> Bool +prop_to_intervals range version = + withinRange version range == withinIntervals version intervals + where + intervals = toVersionIntervals range + +-- | Check that semantic equality on 'VersionRange's is the same as converting +-- to 'VersionIntervals' and doing syntactic equality. +-- +prop_to_intervals_canonical :: VersionRange -> VersionRange -> Property +prop_to_intervals_canonical r r' = + r /= r' && r `equivalentVersionRange` r' ==> + toVersionIntervals r == toVersionIntervals r' + +prop_to_intervals_canonical' :: VersionRange -> VersionRange -> Property +prop_to_intervals_canonical' r r' = + r /= r' && toVersionIntervals r == toVersionIntervals r' ==> + r `equivalentVersionRange` r' + +-- | Check that 'VersionIntervals' models 'VersionRange' via +-- 'fromVersionIntervals'. +-- +prop_from_intervals :: VersionIntervals -> Version -> Bool +prop_from_intervals intervals version = + withinRange version range == withinIntervals version intervals + where + range = fromVersionIntervals intervals + +-- | @'toVersionIntervals' . 'fromVersionIntervals'@ is an exact identity on +-- 'VersionIntervals'. +-- +prop_to_from_intervals :: VersionIntervals -> Bool +prop_to_from_intervals intervals = + toVersionIntervals (fromVersionIntervals intervals) == intervals + +-- | @'fromVersionIntervals' . 'toVersionIntervals'@ is a semantic identity on +-- 'VersionRange', though not necessarily a syntactic identity. +-- +prop_from_to_intervals :: VersionRange -> Bool +prop_from_to_intervals range = + range' `equivalentVersionRange` range + where + range' = fromVersionIntervals (toVersionIntervals range) + +-- | Equivalent of 'prop_from_to_intervals' +-- +prop_from_to_intervals' :: VersionRange -> Version -> Bool +prop_from_to_intervals' range version = + withinRange version range' == withinRange version range + where + range' = fromVersionIntervals (toVersionIntervals range) + +-- | The semantics of 'unionVersionIntervals' is (||). +-- +prop_unionVersionIntervals :: VersionIntervals -> VersionIntervals + -> Version -> Bool +prop_unionVersionIntervals is1 is2 v = + withinIntervals v (unionVersionIntervals is1 is2) + == (withinIntervals v is1 || withinIntervals v is2) + +-- | 'unionVersionIntervals' is idempotent +-- +prop_unionVersionIntervals_idempotent :: VersionIntervals -> Bool +prop_unionVersionIntervals_idempotent = + Laws.idempotent_binary unionVersionIntervals + +-- | 'unionVersionIntervals' is commutative +-- +prop_unionVersionIntervals_commutative :: VersionIntervals + -> VersionIntervals -> Bool +prop_unionVersionIntervals_commutative = + Laws.commutative unionVersionIntervals + +-- | 'unionVersionIntervals' is associative +-- +prop_unionVersionIntervals_associative :: VersionIntervals + -> VersionIntervals + -> VersionIntervals -> Bool +prop_unionVersionIntervals_associative = + Laws.associative unionVersionIntervals + +-- | The semantics of 'intersectVersionIntervals' is (&&). +-- +prop_intersectVersionIntervals :: VersionIntervals -> VersionIntervals + -> Version -> Bool +prop_intersectVersionIntervals is1 is2 v = + withinIntervals v (intersectVersionIntervals is1 is2) + == (withinIntervals v is1 && withinIntervals v is2) + +-- | 'intersectVersionIntervals' is idempotent +-- +prop_intersectVersionIntervals_idempotent :: VersionIntervals -> Bool +prop_intersectVersionIntervals_idempotent = + Laws.idempotent_binary intersectVersionIntervals + +-- | 'intersectVersionIntervals' is commutative +-- +prop_intersectVersionIntervals_commutative :: VersionIntervals + -> VersionIntervals -> Bool +prop_intersectVersionIntervals_commutative = + Laws.commutative intersectVersionIntervals + +-- | 'intersectVersionIntervals' is associative +-- +prop_intersectVersionIntervals_associative :: VersionIntervals + -> VersionIntervals + -> VersionIntervals -> Bool +prop_intersectVersionIntervals_associative = + Laws.associative intersectVersionIntervals + +-- | 'unionVersionIntervals' distributes over 'intersectVersionIntervals' +-- +prop_union_intersect_distributive :: Property +prop_union_intersect_distributive = + Laws.distributive_left unionVersionIntervals intersectVersionIntervals + .&. Laws.distributive_right unionVersionIntervals intersectVersionIntervals + +-- | 'intersectVersionIntervals' distributes over 'unionVersionIntervals' +-- +prop_intersect_union_distributive :: Property +prop_intersect_union_distributive = + Laws.distributive_left intersectVersionIntervals unionVersionIntervals + .&. Laws.distributive_right intersectVersionIntervals unionVersionIntervals + +-------------------------------- +-- equivalentVersionRange helper + +prop_equivalentVersionRange :: VersionRange -> VersionRange + -> Version -> Property +prop_equivalentVersionRange range range' version = + equivalentVersionRange range range' && range /= range' ==> + withinRange version range == withinRange version range' + +--FIXME: this is wrong. consider version ranges "<=1" and "<1.0" +-- this algorithm cannot distinguish them because there is no version +-- that is included by one that is excluded by the other. +-- Alternatively we must reconsider the semantics of '<' and '<=' +-- in version ranges / version intervals. Perhaps the canonical +-- representation should use just < v and interpret "<= v" as "< v.0". +equivalentVersionRange :: VersionRange -> VersionRange -> Bool +equivalentVersionRange vr1 vr2 = + let allVersionsUsed = nub (sort (versionsUsed vr1 ++ versionsUsed vr2)) + minPoint = Version [0] [] + maxPoint | null allVersionsUsed = minPoint + | otherwise = case maximum allVersionsUsed of + Version vs _ -> Version (vs ++ [1]) [] + probeVersions = minPoint : maxPoint + : intermediateVersions allVersionsUsed + + in all (\v -> withinRange v vr1 == withinRange v vr2) probeVersions + + where + versionsUsed = foldVersionRange [] (\x->[x]) (\x->[x]) (\x->[x]) (++) (++) + intermediateVersions (v1:v2:vs) = v1 : intermediateVersion v1 v2 + : intermediateVersions (v2:vs) + intermediateVersions vs = vs + +intermediateVersion :: Version -> Version -> Version +intermediateVersion v1 v2 | v1 >= v2 = error "intermediateVersion: v1 >= v2" +intermediateVersion (Version v1 _) (Version v2 _) = + Version (intermediateList v1 v2) [] + where + intermediateList :: [Int] -> [Int] -> [Int] + intermediateList [] (_:_) = [0] + intermediateList (x:xs) (y:ys) + | x < y = x : xs ++ [0] + | otherwise = x : intermediateList xs ys + +prop_intermediateVersion :: Version -> Version -> Property +prop_intermediateVersion v1 v2 = + (v1 /= v2) && not (adjacentVersions v1 v2) ==> + if v1 < v2 + then let v = intermediateVersion v1 v2 + in (v1 < v && v < v2) + else let v = intermediateVersion v2 v1 + in v1 > v && v > v2 + +adjacentVersions :: Version -> Version -> Bool +adjacentVersions (Version v1 _) (Version v2 _) = v1 ++ [0] == v2 + || v2 ++ [0] == v1 + +-------------------------------- +-- Parsing and pretty printing +-- + +prop_parse_disp1 :: VersionRange -> Bool +prop_parse_disp1 vr = + fmap stripParens (simpleParse (display vr)) == Just (canonicalise vr) + + where + canonicalise = swizzle . swap + + swizzle (UnionVersionRanges (UnionVersionRanges v1 v2) v3) + | not (isOrLaterVersion v1 v2) && not (isOrEarlierVersion v1 v2) + = swizzle (UnionVersionRanges v1 (UnionVersionRanges v2 v3)) + + swizzle (IntersectVersionRanges (IntersectVersionRanges v1 v2) v3) + = swizzle (IntersectVersionRanges v1 (IntersectVersionRanges v2 v3)) + + swizzle (UnionVersionRanges v1 v2) = + UnionVersionRanges (swizzle v1) (swizzle v2) + swizzle (IntersectVersionRanges v1 v2) = + IntersectVersionRanges (swizzle v1) (swizzle v2) + swizzle (VersionRangeParens v) = swizzle v + swizzle v = v + + isOrLaterVersion (ThisVersion v) (LaterVersion v') = v == v' + isOrLaterVersion _ _ = False + + isOrEarlierVersion (ThisVersion v) (EarlierVersion v') = v == v' + isOrEarlierVersion _ _ = False + + swap = + foldVersionRange' anyVersion thisVersion + laterVersion earlierVersion + orLaterVersion orEarlierVersion + (\v _ -> withinVersion v) + unionVersionRanges intersectVersionRanges id + + stripParens :: VersionRange -> VersionRange + stripParens (VersionRangeParens v) = stripParens v + stripParens (UnionVersionRanges v1 v2) = + UnionVersionRanges (stripParens v1) (stripParens v2) + stripParens (IntersectVersionRanges v1 v2) = + IntersectVersionRanges (stripParens v1) (stripParens v2) + stripParens v = v + +prop_parse_disp2 :: VersionRange -> Bool +prop_parse_disp2 vr = + fmap (display :: VersionRange -> String) (simpleParse (display vr)) + == Just (display vr) + +prop_parse_disp3 :: VersionRange -> Bool +prop_parse_disp3 vr = + fmap displayRaw (simpleParse (display vr)) == Just (display vr) + +displayRaw :: VersionRange -> String +displayRaw = + Disp.render + . foldVersionRange' -- precedence: + -- All the same as the usual pretty printer, except for the parens + ( Disp.text "-any") + (\v -> Disp.text "==" <> disp v) + (\v -> Disp.char '>' <> disp v) + (\v -> Disp.char '<' <> disp v) + (\v -> Disp.text ">=" <> disp v) + (\v -> Disp.text "<=" <> disp v) + (\v _ -> Disp.text "==" <> dispWild v) + (\r1 r2 -> r1 <+> Disp.text "||" <+> r2) + (\r1 r2 -> r1 <+> Disp.text "&&" <+> r2) + (\r -> Disp.parens r) -- parens + + where + dispWild (Version b _) = + Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) + <> Disp.text ".*" diff --git a/cabal/cabal/tests/Test/Laws.hs b/cabal/cabal/tests/Test/Laws.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/Test/Laws.hs @@ -0,0 +1,79 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module Test.Laws where + +import Prelude hiding (Num((+), (*))) +import Data.Monoid (Monoid(..), Endo(..)) +import qualified Data.Foldable as Foldable + +idempotent_unary f x = f fx == fx where fx = f x + +-- Basic laws on binary operators + +idempotent_binary (+) x = x + x == x + +commutative (+) x y = x + y == y + x + +associative (+) x y z = (x + y) + z == x + (y + z) + +distributive_left (*) (+) x y z = x * (y + z) == (x * y) + (x * z) + +distributive_right (*) (+) x y z = (y + z) * x == (y * x) + (z * x) + + +-- | The first 'fmap' law +-- +-- > fmap id == id +-- +fmap_1 :: (Eq (f a), Functor f) => f a -> Bool +fmap_1 x = fmap id x == x + +-- | The second 'fmap' law +-- +-- > fmap (f . g) == fmap f . fmap g +-- +fmap_2 :: (Eq (f c), Functor f) => (b -> c) -> (a -> b) -> f a -> Bool +fmap_2 f g x = fmap (f . g) x == (fmap f . fmap g) x + + +-- | The monoid identity law, 'mempty' is a left and right identity of +-- 'mappend': +-- +-- > mempty `mappend` x = x +-- > x `mappend` mempty = x +-- +monoid_1 :: (Eq a, Data.Monoid.Monoid a) => a -> Bool +monoid_1 x = mempty `mappend` x == x + && x `mappend` mempty == x + +-- | The monoid associativity law, 'mappend' must be associative. +-- +-- > (x `mappend` y) `mappend` z = x `mappend` (y `mappend` z) +-- +monoid_2 :: (Eq a, Data.Monoid.Monoid a) => a -> a -> a -> Bool +monoid_2 x y z = (x `mappend` y) `mappend` z + == x `mappend` (y `mappend` z) + +-- | The 'mconcat' definition. It can be overidden for the sake of effeciency +-- but it must still satisfy the property given by the default definition: +-- +-- > mconcat = foldr mappend mempty +-- +monoid_3 :: (Eq a, Data.Monoid.Monoid a) => [a] -> Bool +monoid_3 xs = mconcat xs == foldr mappend mempty xs + + +-- | First 'Foldable' law +-- +-- > Foldable.fold = Foldable.foldr mappend mempty +-- +foldable_1 :: (Foldable.Foldable t, Monoid m, Eq m) => t m -> Bool +foldable_1 x = Foldable.fold x == Foldable.foldr mappend mempty x + +-- | Second 'Foldable' law +-- +-- > foldr f z t = appEndo (foldMap (Endo . f) t) z +-- +foldable_2 :: (Foldable.Foldable t, Eq b) + => (a -> b -> b) -> b -> t a -> Bool +foldable_2 f z t = Foldable.foldr f z t + == appEndo (Foldable.foldMap (Endo . f) t) z diff --git a/cabal/cabal/tests/Test/QuickCheck/Utils.hs b/cabal/cabal/tests/Test/QuickCheck/Utils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/Test/QuickCheck/Utils.hs @@ -0,0 +1,29 @@ +module Test.QuickCheck.Utils where + +import Test.QuickCheck.Gen + + +-- | Adjust the size of the generated value. +-- +-- In general the size gets bigger and bigger linearly. For some types +-- it is not appropriate to generate ever bigger values but instead +-- to generate lots of intermediate sized values. You could do that using: +-- +-- > adjustSize (\n -> min n 5) +-- +-- Similarly, for some types the linear size growth may mean getting too big +-- too quickly relative to other values. So you may want to adjust how +-- quickly the size grows. For example dividing by a constant, or even +-- something like the integer square root or log. +-- +-- > adjustSize (\n -> n `div` 2) +-- +-- Putting this together we can make for example a relatively short list: +-- +-- > adjustSize (\n -> min 5 (n `div` 3)) (listOf1 arbitrary) +-- +-- Not only do we put a limit on the length but we also scale the growth to +-- prevent it from hitting the maximum size quite so early. +-- +adjustSize :: (Int -> Int) -> Gen a -> Gen a +adjustSize adjust gen = sized (\n -> resize (adjust n) gen) diff --git a/cabal/cabal/tests/UnitTest.hs b/cabal/cabal/tests/UnitTest.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/UnitTest.hs @@ -0,0 +1,474 @@ +----------------------------------------------------------------------------- + +-- | +-- Module : UnitTest +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : GHC +-- +-- Explanation: Test this module and sub modules. + +{- 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 Main where +-- Import everything, since we want to test the compilation of them: + +import qualified UnitTest.Distribution.Version as D.V (hunitTests) +import qualified UnitTest.Distribution.PackageDescription as D.PD (hunitTests) + +import Distribution.Simple.Compiler (CompilerFlavor(..), compilerVersion) +import Distribution.Simple.Program (defaultProgramConfiguration) +import Distribution.Version (Version(..)) + +import System.FilePath( () ) + +import Distribution.Simple.Configure (configCompiler) +import Distribution.Verbosity ( silent ) +-- base +import Data.List (intersperse) +import Control.Monad (when) +import System.Directory (setCurrentDirectory, doesFileExist, + doesDirectoryExist, getCurrentDirectory, + getPermissions, Permissions(..), + removeDirectoryRecursive) +import System.Cmd (system) +import System.Exit(ExitCode(..)) +import System.Environment (getArgs) + +import Test.HUnit(runTestTT, Test(..), Counts(..), assertBool, + assertEqual, Assertion, showCounts) + + +-- ------------------------------------------------------------ +-- * Helpers +-- ------------------------------------------------------------ + +combineCounts :: Counts -> Counts -> Counts +combineCounts (Counts a b c d) (Counts a' b' c' d') + = Counts (a + a') (b + b') (c + c') (d + d') + +label :: String -> String +label t = "-= " ++ t ++ " =-" + +runTestTT' :: Test -> IO Counts +runTestTT' t@(TestList _) = runTestTT t +runTestTT' (TestLabel l t) + = putStrLn (label l) >> runTestTT t +runTestTT' t = runTestTT t + +checkTargetDir :: FilePath + -> [String] -- ^suffixes + -> IO () +checkTargetDir targetDir suffixes + = do doesDirectoryExist targetDir >>= + assertBool "target dir exists" + let mods = ["A", "B/A"] + allFilesE <- mapM anyExists [[(targetDir ++ t ++ y) + | y <- suffixes] + | t <- mods] + + sequence [assertBool ("target file missing: " ++ targetDir ++ f) e + | (e, f) <- zip allFilesE mods] + return () + + where anyExists :: [FilePath] -> IO Bool + anyExists l = do l' <- mapM doesFileExist l + return $ any (== True) l' + +-- |Run this command, and assert it returns a successful error code. +assertCmd :: String -- ^Command + -> String -- ^Comment + -> Assertion +assertCmd command comment + = system command >>= assertEqual (command ++ ":" ++ comment) ExitSuccess + +-- |like assertCmd, but separates command and args +assertCmd' :: String -- ^Command + -> String -- ^args + -> String -- ^Comment + -> Assertion +assertCmd' command args comment + = system (command ++ " "++ args ++ ">>out.build") + >>= assertEqual (command ++ ":" ++ comment) ExitSuccess + +-- |Run this command, and assert it returns an unsuccessful error code. +assertCmdFail :: String -- ^Command + -> String -- ^Comment + -> Assertion +assertCmdFail command comment + = do code <- system command + assertBool (command ++ ":" ++ comment) (code /= ExitSuccess) + + +-- ------------------------------------------------------------ +-- * Integration Tests +-- ------------------------------------------------------------ + +tests :: FilePath -- ^Currdir + -> CompilerFlavor -- ^build setup with compiler + -> CompilerFlavor -- ^configure with which compiler + -> Version -- ^version of the compiler to use + -> [Test] +tests currDir comp compConf compVersion = [ +-- executableWithC + TestLabel ("package exeWithC: " ++ compIdent) $ TestCase $ + do let targetDir = ",tmp" + setCurrentDirectory (testdir "exeWithC") + testPrelude + assertConfigure targetDir + assertClean + assertConfigure targetDir + assertBuild + assertCopy + assertCmd (targetDir "bin/tt" ++ " > " + ++ targetDir "out") + "exeWithC failed" +-- A + ,TestLabel ("package A: " ++ compIdent) $ TestCase $ + do let targetDir = ",tmp" + setCurrentDirectory (testdir "A") + testPrelude + assertConfigure targetDir + assertHaddock + assertBuild + when (comp == GHC) -- are these tests silly? + (do doesDirectoryExist "dist/build" >>= + assertBool "dist/build doesn't exist" + doesFileExist "dist/build/testA/testA" >>= + assertBool "build did not create the executable: testA" + doesFileExist "dist/build/testB/testB" >>= + assertBool "build did not create the executable: testB" + doesFileExist "dist/build/testA/testA-tmp/c_src/hello.o" >>= + assertBool "build did not build c source for testA" + doesFileExist "dist/build/hello.o" >>= + assertBool "build did not build c source for A library" + ) + assertCopy + libForA targetDir + doesFileExist ",tmp/bin/testA" >>= + assertBool "testA not produced" + doesFileExist ",tmp/bin/testB" >>= + assertBool "testB not produced" + assertCmd' compCmd "sdist -v0" "setup sdist returned error code" + doesFileExist "dist/test-1.0.tar.gz" >>= + assertBool "sdist did not put the expected file in place" + doesFileExist "dist/src" >>= + assertEqual "dist/src exists" False + assertCmd' compCmd "register -v0 --user" "pkg A, register failed" + assertCmd' compCmd "unregister -v0 --user" "pkg A, unregister failed" + -- tricky, script-based register + registerAndExecute "pkg A: register with script failed" + unregisterAndExecute "pkg A: unregister with script failed" + -- non-trick non-script based register + assertCmd' compCmd "register -v0 --user" "regular register returned error" + assertCmd' compCmd "unregister -v0 --user" "regular unregister returned error" + + ,TestLabel ("package A copy-prefix: " ++ compIdent) $ TestCase $ -- (uses above config) + do let targetDir = ",tmp2" + assertCmd' compCmd ("copy --copy-prefix=" ++ targetDir) "copy --copy-prefix failed" + doesFileExist ",tmp2/bin/testA" >>= + assertBool "testA not produced" + doesFileExist ",tmp2/bin/testB" >>= + assertBool "testB not produced" + libForA ",tmp2" + ,TestLabel ("package A and install w/ no prefix: " ++ compIdent) $ TestCase $ + do let targetDir = ",tmp" + removeDirectoryRecursive targetDir + when (comp == GHC) -- FIX: hugs can't do --user yet + (do assertCmd "make -s unregister-test" "unregister test" + assertCmd' compCmd "install -v0 --user" "install --user failed" + libForA targetDir + assertCmd' compCmd "unregister -v0 --user" "unregister failed") +-- HUnit + ,TestLabel ("testing the HUnit package" ++ compIdent) $ TestCase $ + do setCurrentDirectory $ (testdir "HUnit-1.0") + system "make -s clean" + system "make -s" + assertCmd' compCmd "configure -v0" "configure failed" + assertCmd' compCmd "unregister -v0 --user" "unregister failed" + + system $ "touch dist/setup-config" + system $ "touch dist/installed-pkg-config" + doesFileExist "dist/setup-config" >>= + assertBool ("touch dist/setup-config failed") + + -- Test clean: + assertBuild + doesDirectoryExist "dist/build" >>= + assertBool "HUnit build did not create build directory" + assertCmd' compCmd "clean -v0" "hunit clean" + doesDirectoryExist "dist/build" >>= + assertEqual "HUnit clean did not get rid of build directory" False + + doesFileExist "dist/setup-config" >>= + assertEqual ("clean dist/setup-config failed") False + doesFileExist "dist/installed-pkg-config" >>= + assertEqual ("clean dist/installed-pkg-config failed") False + + assertConfigure ",tmp" + assertHaddock + doesDirectoryExist "dist/doc" >>= assertEqual "create of dist/doc" True + assertBuild + when (comp == GHC) -- tests building w/ an installed -package + (do assertCmd' compCmd "install -v0 --user" "hunit install" + assertCmd ("ghc -package HUnitTest HUnitTester.hs -o ./hunitTest") + "compile w/ hunit" + assertCmd "./hunitTest" "hunit test" + assertCmd' compCmd "unregister --user" "unregister failed") + assertClean + doesDirectoryExist "dist/doc" >>= assertEqual "clean dist/doc" False + assertCmd "make -s clean" "make clean failed" + +-- twoMains + ,TestLabel ("package twoMains: building " ++ compIdent) $ TestCase $ + do setCurrentDirectory (testdir "twoMains") + testPrelude + assertConfigure ",tmp" + assertCmd' compCmd "haddock" "setup haddock returned error code." + assertBuild + assertCopy + doesFileExist ",tmp/bin/testA" >>= + assertBool "install did not create the executable: testA" + doesFileExist ",tmp/bin/testB" >>= + assertBool "install did not create the executable: testB" + assertCmd "./,tmp/bin/testA isA > out" "A is not A" + assertCmd "./,tmp/bin/testB isB >> out" "B is not B" + -- no register, since there's no library +-- buildinfo + ,TestLabel ("buildinfo with multiple executables " ++ compIdent) $ TestCase $ + do setCurrentDirectory (testdir "buildInfo") + testPrelude + assertConfigure ",tmp" + assertHaddock + assertBuild + assertCopy + doesFileExist ",tmp/bin/exe1" >>= + assertBool "install did not create the executable: exe1" + doesFileExist ",tmp/bin/exe2" >>= + assertBool "install did not create the executable: exe2" + -- no register, since there's no library +-- mutually recursive modules + ,TestLabel ("package recursive: building " ++ compIdent) $ TestCase $ + when (comp == GHC) (do + setCurrentDirectory (testdir "recursive") + testPrelude + assertConfigure ",tmp" + assertBuild + assertCopy + doesFileExist "dist/build/A.hi-boot" >>= + assertBool "build did not move A.hi-boot file into place lib" + doesFileExist (",tmp/lib/recursive-1.0/ghc-" ++ compVerStr + ++ "/libHSrecursive-1.0.a") >>= + assertBool "recursive build didn't create library" + doesFileExist "dist/build/testExe/testExe-tmp/A.hi" >>= + assertBool "build did not move A.hi-boot file into place exe" + doesFileExist "dist/build/testExe/testExe" >>= + assertBool "recursive build didn't create binary") +-- linking in ffi stubs + ,TestLabel ("package ffi: " ++ compIdent) $ TestCase $ + do setCurrentDirectory (testdir "ffi-package") + testPrelude + assertConfigure "/tmp" + assertBuild + -- install it so we can test building with it. + assertCmd' compCmd "install -v0 --user" "ffi-package install" + assertClean + doesFileExist "src/TestFFI_stub.c" >>= + assertEqual "FFI-generated stub not cleaned." False + -- now build something that depends on it + setCurrentDirectory (".." "ffi-bin") + testPrelude + assertConfigure ",tmp" + assertBuild + assertCopy +-- depOnLib + ,TestLabel ("package depOnLib: (executable depending on its lib)" ++ compIdent) $ TestCase $ + do setCurrentDirectory (testdir "depOnLib") + testPrelude + assertConfigure ",tmp" + assertHaddock + assertBuild + assertCopy + registerAndExecute "pkg depOnLib: register with script failed" + unregisterAndExecute "pkg DepOnLib: unregister with script failed" + when (comp == GHC) (do + doesFileExist "dist/build/mainForA/mainForA" >>= + assertBool "build did not create the executable: mainForA" + doesFileExist ("dist/build/" "libHStest-1.0.a") + >>= assertBool "library doesn't exist" + doesFileExist (",tmp/bin/mainForA") + >>= assertBool "installed bin doesn't exist" + doesFileExist (",tmp/lib/test-1.0/ghc-" ++ compVerStr ++ "/libHStest-1.0.a") + >>= assertBool "installed lib doesn't exist") +-- wash2hs + ,TestLabel ("testing the wash2hs package" ++ compIdent) $ TestCase $ + do setCurrentDirectory (testdir "wash2hs") + testPrelude + assertCmdFail (compCmd ++ " configure -v0 --someUnknownFlag 2> err") + "wash2hs configure with unknown flag" + assertConfigure ",tmp" + assertHaddock + assertBuild + assertCopy + -- no library to register + doesFileExist ",tmp/bin/wash2hs" + >>= assertBool "wash2hs didn't put executable into place." + perms <- getPermissions ",tmp/bin/wash2hs" + assertBool "wash2hs isn't +x" (executable perms) + assertClean + -- no unregister, because it has no libs! +-- withHooks + ,TestLabel ("package withHooks: " ++ compIdent) $ TestCase $ + do setCurrentDirectory (testdir "withHooks") + testPrelude + assertCmd' compCmd ("configure -v0 --prefix=,tmp --woohoo " ++ compFlag) + "configure returned error code" + assertCmdFail (compCmd ++ " test -v0 --asdf > out") "test was supposed to fail" + assertCmd' compCmd ("test -v0 --pass >> out") "test should not have failed" + + assertHaddock + assertBuild + assertCmd' compCmd "copy -v0 --copy-prefix=,tmp" "copy w/ prefix" + doesFileExist ",tmp/withHooks" >>= -- this file is added w/ the hook. + assertBool "hooked copy, redirecting prefix didn't work." + assertCmd' compCmd "register -v0 --user" "regular register returned error" + assertCmd' compCmd "unregister -v0 --user" "regular unregister returned error" + when (comp == GHC) -- FIX: come up with good test for Hugs + (do doesFileExist "dist/build/C.o" >>= + assertBool "C.testSuffix did not get compiled to C.o." + doesFileExist "dist/build/D.o" >>= + assertBool "D.gc did not get compiled to D.o this is an overriding test" + doesFileExist (",tmp/lib/withHooks-1.0/ghc-" ++ compVerStr + ++ "/" "libHSwithHooks-1.0.a") + >>= assertBool "library doesn't exist") + + doesFileExist ",tmp/bin/withHooks" >>= + assertBool "copy did not create the executable: withHooks" + assertClean + doesFileExist "C.hs" >>= + assertEqual "C.hs (a generated file) not cleaned." False +-- HSQL +{- ,TestLabel ("package HSQL (make-based): " ++ show compIdent) $ + TestCase $ unless (compFlag == "--hugs") $ -- FIX: won't compile w/ hugs + do setCurrentDirectory $ (testdir "HSQL") + system "make distclean" + system "rm -rf /tmp/lib/HSQL" + when (comp == GHC) + (system "ghc -cpp --make -i../.. Setup.lhs -o setup 2>out.build" >> return()) + assertConfigure "/tmp" + doesFileExist "config.mk" >>= + assertBool "config.mk not generated after configure" + assertBuild + assertCopy + when (comp == GHC) -- FIX: do something for hugs + (doesFileExist "/tmp/lib/HSQL/GHC/libHSsql.a" >>= + assertBool "libHSsql.a doesn't exist. copy failed.")-} + ] + where testdir = currDir "systemTests" + compStr = show comp + compVerStr = concat . intersperse "." . map show . versionBranch $ compVersion + compCmd = command comp + compFlag = case compConf of + GHC -> "--ghc" + Hugs -> "--hugs" + _ -> error ("Unhandled compiler: " ++ show compConf) + compIdent = compStr ++ "/" ++ compFlag + testPrelude = system "make clean >> out.build" >> system "make >> out.build" + assertConfigure pref + = assertCmd' compCmd ("configure -v0 --user --prefix=" ++ pref ++ " " ++ compFlag) + "configure returned error code" + -- XXX redirecting stderr is a hack. ar says + -- /usr/bin/ar: creating dist/build/libHStest-1.0.a + -- in the A test + assertBuild = assertCmd' compCmd "build -v0 2> err" "build returned error code" + assertCopy = assertCmd' compCmd "copy -v0" "copy returned error code" + assertClean = assertCmd' compCmd "clean -v0" "clean returned error code" + -- XXX Redirecting stderr is a hack - haddock needs to allow + -- us to tell it to be quiet + assertHaddock = assertCmd' compCmd "haddock -v0 2> err" "setup haddock returned error code." + command GHC = "./setup" + command Hugs = "runhugs -98 Setup.lhs" + command c = error ("Unhandled compiler: " ++ show c) + libForA pref -- checks to see if the lib exists, for tests/A + = let ghcTargetDir = pref ++ "/lib/test-1.0/ghc-" ++ compVerStr ++ "/" in + case compConf of + Hugs -> checkTargetDir (pref ++ "/lib/hugs/packages/test/") [".hs", ".lhs"] + GHC -> do checkTargetDir ghcTargetDir [".hi"] + doesFileExist (ghcTargetDir "libHStest-1.0.a") + >>= assertBool "library doesn't exist" + _ -> error ("Unhandled compiler: " ++ show compConf) + dumpScriptFlag = "--gen-script" + registerAndExecute comment = do + assertCmd' compCmd ("register -v0 --user "++dumpScriptFlag) comment + if comp == GHC + then assertCmd' "./register.sh" "" "reg script failed" + else do ex <- doesFileExist "register.sh" + assertBool "hugs should not produce register.sh" (not ex) + unregisterAndExecute comment = do + assertCmd' compCmd ("unregister -v0 --user "++dumpScriptFlag) comment + if comp == GHC + then assertCmd' "./unregister.sh" "" "reg script failed" + else do ex <- doesFileExist "unregister.sh" + assertBool "hugs should not produce unregister.sh" (not ex) + +main :: IO () +main = do putStrLn "compile successful" + putStrLn "-= Setup Tests =-" + setupCount <- runTestTT' $ TestList (D.V.hunitTests ++ D.PD.hunitTests) + dir <- getCurrentDirectory +-- count' <- runTestTT' $ TestList (tests dir Hugs GHC) + args <- getArgs + let testList :: CompilerFlavor -> Version -> [Test] + testList compiler version + | null args = tests dir compiler compiler version + | otherwise = + case reads (head args) of + [(n,_)] -> [ tests dir compiler compiler version !! n ] + _ -> error "usage: moduleTest [test_num]" + compilers = [GHC] --, Hugs] + globalTests <- + flip mapM compilers $ \compilerFlavour -> do + (compiler, _) <- configCompiler (Just compilerFlavour) + Nothing Nothing + defaultProgramConfiguration silent + let version = compilerVersion compiler + runTestTT' $ TestList (testList compilerFlavour version) + putStrLn "-------------" + putStrLn "Test Summary:" + putStrLn $ showCounts $ + foldl1 combineCounts (setupCount:globalTests) + return () + +-- Local Variables: +-- compile-command: "ghc -i../:/usr/local/src/HUnit-1.0 -Wall --make ModuleTest.hs -o moduleTest" +-- End: diff --git a/cabal/cabal/tests/UnitTest/Distribution/PackageDescription.hs b/cabal/cabal/tests/UnitTest/Distribution/PackageDescription.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/UnitTest/Distribution/PackageDescription.hs @@ -0,0 +1,416 @@ +----------------------------------------------------------------------------- +-- | +-- Module : PackageDescriptionTests +-- 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 UnitTest.Distribution.PackageDescription ( + -- * Debugging + hunitTests, + + ) where + + +import Distribution.ParseUtils +import Distribution.Package (PackageIdentifier(..), Dependency(..)) +import Distribution.Version (Version(..), VersionRange(..)) +import Distribution.Compiler (CompilerFlavor(..), CompilerId(..)) +import Distribution.System (OS(..), buildOS, Arch(..), buildArch) + +import Distribution.PackageDescription +import Distribution.PackageDescription.Configuration +import Distribution.PackageDescription.Parse +import Distribution.PackageDescription.Check +import qualified Distribution.Simple.PackageIndex as PackageIndex + +import Data.Maybe (catMaybes) +import Data.List (sortBy) +import Control.Monad (liftM) +import Test.HUnit (Test(..), assertBool, Assertion, assertEqual) +import Distribution.License +import Language.Haskell.Extension + + +-- ------------------------------------------------------------ +-- * Testing +-- ------------------------------------------------------------ + +compatTestPkgDesc :: String +compatTestPkgDesc = unlines [ + "-- Required", + "Name: Cabal", + "Version: 0.1.1.1.1-rain", + "License: LGPL", + "License-File: foo", + "Copyright: Free Text String", + "Cabal-version: >1.1.1", + "-- Optional - may be in source?", + "Author: Happy Haskell Hacker", + "Homepage: http://www.haskell.org/foo", + "Package-url: http://www.haskell.org/foo", + "Synopsis: a nice package!", + "Description: a really nice package!", + "Category: tools", + "buildable: True", + "CC-OPTIONS: -g -o", + "LD-OPTIONS: -BStatic -dn", + "Frameworks: foo", + "Tested-with: GHC", + "Stability: Free Text String", + "Build-Depends: haskell-src, HUnit>=1.0.0-rain", + "Other-Modules: Distribution.Package, Distribution.Version,", + " Distribution.Simple.GHCPackageConfig", + "Other-files: file1, file2", + "Extra-Tmp-Files: file1, file2", + "C-Sources: not/even/rain.c, such/small/hands", + "HS-Source-Dirs: src, src2", + "Exposed-Modules: Distribution.Void, Foo.Bar", + "Extensions: OverlappingInstances, TypeSynonymInstances", + "Extra-Libraries: libfoo, bar, bang", + "Extra-Lib-Dirs: \"/usr/local/libs\"", + "Include-Dirs: your/slightest, look/will", + "Includes: /easily/unclose, /me, \"funky, path\\\\name\"", + "Install-Includes: /easily/unclose, /me, \"funky, path\\\\name\"", + "GHC-Options: -fTH -fglasgow-exts", + "Hugs-Options: +TH", + "Nhc-Options: ", + "Jhc-Options: ", + "", + "-- Next is an executable", + "Executable: somescript", + "Main-is: SomeFile.hs", + "Other-Modules: Foo1, Util, Main", + "HS-Source-Dir: scripts", + "Extensions: OverlappingInstances", + "GHC-Options: ", + "Hugs-Options: ", + "Nhc-Options: ", + "Jhc-Options: " + ] + +compatTestPkgDescAnswer :: PackageDescription +compatTestPkgDescAnswer = + emptyPackageDescription + { package = PackageIdentifier + { pkgName = "Cabal", + pkgVersion = Version {versionBranch = [0,1,1,1,1], + versionTags = ["rain"]}}, + license = LGPL, + licenseFile = "foo", + copyright = "Free Text String", + author = "Happy Haskell Hacker", + homepage = "http://www.haskell.org/foo", + pkgUrl = "http://www.haskell.org/foo", + synopsis = "a nice package!", + description = "a really nice package!", + category = "tools", + descCabalVersion = LaterVersion (Version [1,1,1] []), + buildType = Just Custom, + buildDepends = [Dependency "haskell-src" AnyVersion, + Dependency "HUnit" + (UnionVersionRanges + (ThisVersion (Version [1,0,0] ["rain"])) + (LaterVersion (Version [1,0,0] ["rain"])))], + testedWith = [(GHC, AnyVersion)], + maintainer = "", + stability = "Free Text String", + extraTmpFiles = ["file1", "file2"], + extraSrcFiles = ["file1", "file2"], + dataFiles = [], + + library = Just $ Library { + exposedModules = ["Distribution.Void", "Foo.Bar"], + libBuildInfo = emptyBuildInfo { + buildable = True, + ccOptions = ["-g", "-o"], + ldOptions = ["-BStatic", "-dn"], + frameworks = ["foo"], + cSources = ["not/even/rain.c", "such/small/hands"], + hsSourceDirs = ["src", "src2"], + otherModules = ["Distribution.Package", + "Distribution.Version", + "Distribution.Simple.GHCPackageConfig"], + extensions = [OverlappingInstances, TypeSynonymInstances], + extraLibs = ["libfoo", "bar", "bang"], + extraLibDirs = ["/usr/local/libs"], + includeDirs = ["your/slightest", "look/will"], + includes = ["/easily/unclose", "/me", "funky, path\\name"], + installIncludes = ["/easily/unclose", "/me", "funky, path\\name"], + ghcProfOptions = [], + options = [(GHC,["-fTH","-fglasgow-exts"]) + ,(Hugs,["+TH"]),(NHC,[]),(JHC,[])] + }}, + + executables = [Executable "somescript" + "SomeFile.hs" (emptyBuildInfo { + otherModules=["Foo1","Util","Main"], + hsSourceDirs = ["scripts"], + extensions = [OverlappingInstances], + options = [(GHC,[]),(Hugs,[]),(NHC,[]),(JHC,[])] + })] + } + +-- Parse an old style package description. Assumes no flags etc. being used. +compatParseDescription :: String -> ParseResult PackageDescription +compatParseDescription descr = do + gpd <- parsePackageDescription descr + case finalizePackageDescription [] (Nothing :: Maybe (PackageIndex.PackageIndex PackageIdentifier)) + buildOS buildArch (CompilerId GHC (Version [] [])) [] gpd of + Left _ -> syntaxError (-1) "finalize failed" + Right (pd,_) -> return pd + +hunitTests :: [Test] +hunitTests = + [ TestLabel "license parsers" $ TestCase $ + sequence_ [ assertParseOk ("license " ++ show lVal) lVal + (runP 1 "license" parseLicenseQ (show lVal)) + | lVal <- [GPL,LGPL,BSD3,BSD4] ] + + , TestLabel "Required fields" $ TestCase $ + do assertParseOk "some fields" + emptyPackageDescription { + package = (PackageIdentifier "foo" + (Version [0,0] ["asdf"])) } + (compatParseDescription "Name: foo\nVersion: 0.0-asdf") + + assertParseOk "more fields foo" + emptyPackageDescription { + package = (PackageIdentifier "foo" + (Version [0,0] ["asdf"])), + license = GPL } + (compatParseDescription "Name: foo\nVersion:0.0-asdf\nLicense: GPL") + + assertParseOk "required fields for foo" + emptyPackageDescription { + package = (PackageIdentifier "foo" + (Version [0,0] ["asdf"])), + license = GPL, copyright="2004 isaac jones" } + (compatParseDescription $ "Name: foo\nVersion:0.0-asdf\n" + ++ "Copyright: 2004 isaac jones\nLicense: GPL") + + , TestCase $ assertParseOk "no library" Nothing + (library `liftM` (compatParseDescription $ + "Name: foo\nVersion: 1\nLicense: GPL\n" ++ + "Maintainer: someone\n\nExecutable: script\n" ++ + "Main-is: SomeFile.hs\n")) + + , TestCase $ assertParseOk "translate deprecated fields" + emptyPackageDescription { + extraSrcFiles = ["foo.c", "bar.ml"], + library = Just $ emptyLibrary { + libBuildInfo = emptyBuildInfo { hsSourceDirs = ["foo","bar"] }}} + (compatParseDescription $ + "hs-source-dir: foo bar\nother-files: foo.c bar.ml") + + , TestLabel "Package description" $ TestCase $ + assertParseOk "entire package description" + compatTestPkgDescAnswer + (compatParseDescription compatTestPkgDesc) + , TestLabel "Package description pretty" $ TestCase $ + case compatParseDescription compatTestPkgDesc of + ParseFailed _ -> assertBool "can't parse description" False + ParseOk _ d -> + case compatParseDescription $ showPackageDescription d of + ParseFailed _ -> + assertBool "can't parse description after pretty print!" False + ParseOk _ d' -> + assertBool ("parse . show . parse not identity." + ++" Incorrect fields:\n" + ++ (unlines $ comparePackageDescriptions d d')) + (d == d') + , TestLabel "Sanity checker" $ TestCase $ do + let checks = checkConfiguredPackage emptyPackageDescription + ers = [ s | PackageBuildImpossible s <- checks ] + warns = [ s | PackageBuildWarning s <- checks ] + assertEqual "Wrong number of errors" 2 (length ers) + assertEqual "Wrong number of warnings" 3 (length warns) + ] + +-- |Compare two package descriptions and see which fields aren't the same. +comparePackageDescriptions :: PackageDescription + -> PackageDescription + -> [String] -- ^Errors +comparePackageDescriptions p1 p2 + = catMaybes $ myCmp package "package" + : myCmp license "license" + : myCmp licenseFile "licenseFile" + : myCmp copyright "copyright" + : myCmp maintainer "maintainer" + : myCmp author "author" + : myCmp stability "stability" + : myCmp testedWith "testedWith" + : myCmp homepage "homepage" + : myCmp pkgUrl "pkgUrl" + : myCmp synopsis "synopsis" + : myCmp description "description" + : myCmp category "category" + : myCmp buildDepends "buildDepends" + : myCmp library "library" + : myCmp executables "executables" + : myCmp descCabalVersion "cabal-version" + : myCmp buildType "build-type" : [] + where canon_p1 = canonOptions p1 + canon_p2 = canonOptions p2 + + myCmp :: (Eq a, Show a) => (PackageDescription -> a) + -> String -- Error message + -> Maybe String -- + myCmp f er = let e1 = f canon_p1 + e2 = f canon_p2 + in if e1 /= e2 + then Just $ er ++ " Expected: " ++ show e1 + ++ " Got: " ++ show e2 + else Nothing + +canonOptions :: PackageDescription -> PackageDescription +canonOptions pd = + pd{ library = fmap canonLib (library pd), + executables = map canonExe (executables pd) } + where + canonLib l = l { libBuildInfo = canonBI (libBuildInfo l) } + canonExe e = e { buildInfo = canonBI (buildInfo e) } + + canonBI bi = bi { options = canonOptions (options bi) } + + canonOptions opts = sortBy (comparing fst) opts + + comparing f a b = f a `compare` f b + +-- |Assert that the 2nd value parses correctly and matches the first value +assertParseOk :: (Eq val) => String -> val -> ParseResult val -> Assertion +assertParseOk mes expected actual + = assertBool mes + (case actual of + ParseOk _ v -> v == expected + _ -> False) + +------------------------------------------------------------------------------ + +test_stanzas' = parsePackageDescription testFile +-- ParseOk _ x -> putStrLn $ show x +-- _ -> return () + +testFile = unlines $ + [ "Name: dwim" + , "Cabal-version: >= 1.7" + , "" + , "Description: This is a test file " + , " with a description longer than two lines. " + , "" + , "flag Debug {" + , " Description: Enable debug information" + , " Default: False" + , "}" + , "flag build_wibble {" + , "}" + , "" + , "library {" + , " build-depends: blub" + , " exposed-modules: DWIM.Main, DWIM" + , " if os(win32) && flag(debug) {" + , " build-depends: hunit" + , " ghc-options: -DDEBUG" + , " exposed-modules: DWIM.Internal" + , " if !flag(debug) {" + , " build-depends: impossible" + , " }" + , " }" + , "}" + , "" + , "executable foo-bar {" + , " Main-is: Foo.hs" + , " Build-depends: blab" + , "}" + , "executable wobble {" + , " Main-is: Wobble.hs" + , " if flag(debug) {" + , " Build-depends: hunit" + , " }" + , "}" + , "executable wibble {" + , " Main-is: Wibble.hs" + , " hs-source-dirs: wib-stuff" + , " if flag(build_wibble) {" + , " Build-depends: wiblib >= 0.42" + , " } else {" + , " buildable: False" + , " }" + , "}" + ] + +{- +test_compatParsing = + let ParseOk ws (p, pold) = do + fs <- readFields testPkgDesc + ppd <- parsePackageDescription' fs + let Right (pd,_) = finalizePackageDescription [] (Just pkgs) os arch ppd + pdold <- parsePackageDescription testPkgDesc + return (pd, pdold) + in do putStrLn $ unlines $ map show ws + putStrLn "===========" + putStrLn $ showPackageDescription p + putStrLn "===========" + putStrLn $ showPackageDescription testPkgDescAnswer + putStrLn "===========" + putStrLn $ showPackageDescription pold + putStrLn $ show (p == pold) + where + pkgs = [ PackageIdentifier "haskell-src" (Version [1,0] []) + , PackageIdentifier "HUnit" (Version [1,1] ["rain"]) + ] + os = (MkOSName "win32") + arch = (MkArchName "amd64") +-} +test_finalizePD = + case parsePackageDescription testFile of + ParseFailed err -> print err + ParseOk _ ppd -> do + case finalizePackageDescription [(FlagName "debug",True)] (Just pkgs) os arch impl [] ppd of + Right (pd,fs) -> do putStrLn $ showPackageDescription pd + print fs + Left missing -> putStrLn $ "missing: " ++ show missing + putStrLn $ showPackageDescription $ + flattenPackageDescription ppd + where + pkgs = PackageIndex.fromList[ PackageIdentifier "blub" (Version [1,0] []) + --, PackageIdentifier "hunit" (Version [1,1] []) + , PackageIdentifier "blab" (Version [0,1] []) + ] + os = Windows + arch = X86_64 + impl = CompilerId GHC (Version [6,6] []) diff --git a/cabal/cabal/tests/UnitTest/Distribution/PackageDescription/Configuration.hs b/cabal/cabal/tests/UnitTest/Distribution/PackageDescription/Configuration.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/UnitTest/Distribution/PackageDescription/Configuration.hs @@ -0,0 +1,135 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Configuration +-- Copyright : Thomas Schilling, 2007 +-- +-- Maintainer : Isaac Jones +-- Stability : alpha +-- Portability : portable +-- +-- Configurations + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module UnitTest.Distribution.PackageDescription.Configuration where + +import Distribution.PackageDescription.Configuration + +import Distribution.Package (Package) +import Distribution.PackageDescription + ( GenericPackageDescription(..), PackageDescription(..) + , Library(..), Executable(..), BuildInfo(..) + , Flag(..), CondTree(..), ConfVar(..), ConfFlag(..), Condition(..) ) +import Distribution.Simple.PackageIndex (PackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Version + ( Version(..), Dependency(..), VersionRange(..) + , withinRange, parseVersionRange ) +import Distribution.Compiler (CompilerFlavor, parseCompilerFlavor) +import Distribution.System + ( OS, readOS, Arch, readArch ) +import Distribution.Simple.Utils (currentDir) + +import Distribution.Compat.ReadP as ReadP hiding ( char ) +import qualified Distribution.Compat.ReadP as ReadP ( char ) + +import Data.Char ( isAlphaNum, toLower ) +import Data.Maybe ( catMaybes, maybeToList ) +import Data.List ( nub ) +import Data.Monoid + +import Data.List ( (\\) ) +import Distribution.ParseUtils + +------------------------------------------------------------------------------ +-- Testing + +tstTree :: CondTree ConfVar [Int] String +tstTree = CondNode "A" [0] + [ (CNot (Var (Flag (ConfFlag "a"))), + CondNode "B" [1] [], + Nothing) + , (CAnd (Var (Flag (ConfFlag "b"))) (Var (Flag (ConfFlag "c"))), + CondNode "C" [2] [], + Just $ CondNode "D" [3] + [ (Lit True, + CondNode "E" [4] [], + Just $ CondNode "F" [5] []) ]) + ] + + +test_simplify = simplifyWithSysParams i386 darwin ("ghc",Version [6,6] []) tstCond + where + tstCond = COr (CAnd (Var (Arch ppc)) (Var (OS darwin))) + (CAnd (Var (Flag (ConfFlag "debug"))) (Var (OS darwin))) + [ppc,i386] = ["ppc","i386"] + [darwin,windows] = ["darwin","windows"] + + + +test_parseCondition = map (runP 1 "test" parseCondition) testConditions + where + testConditions = [ "os(darwin)" + , "arch(i386)" + , "!os(linux)" + , "! arch(ppc)" + , "os(windows) && arch(i386)" + , "os(windows) && arch(i386) && flag(debug)" + , "true && false || false && true" -- should be same + , "(true && false) || (false && true)" -- as this + , "(os(darwin))" + , " ( os ( darwin ) ) " + , "true && !(false || os(plan9))" + , "flag( foo_bar )" + , "flag( foo_O_-_O_bar )" + , "impl ( ghc )" + , "impl( ghc >= 6.6.1 )" + ] + +test_ppCondTree = render $ ppCondTree tstTree (text . show) + + +test_simpCondTree = simplifyCondTree env tstTree + where + env x = maybe (Left x) Right (lookup x flags) + flags = [(mkFlag "a",False), (mkFlag "b",False), (mkFlag "c", True)] + mkFlag = Flag . ConfFlag + +test_resolveWithFlags = resolveWithFlags dom "os" "arch" ("ghc",Version [6,6] []) [tstTree] check + where + dom = [("a", [False,True]), ("b", [True,False]), ("c", [True,False])] + check ds = let missing = ds \\ avail in + case missing of + [] -> DepOk + _ -> MissingDeps missing + avail = [0,1,3,4] + +test_ignoreConditions = ignoreConditions tstTree diff --git a/cabal/cabal/tests/UnitTest/Distribution/ParseUtils.hs b/cabal/cabal/tests/UnitTest/Distribution/ParseUtils.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/UnitTest/Distribution/ParseUtils.hs @@ -0,0 +1,215 @@ +----------------------------------------------------------------------------- +-- | +-- 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. -} + +module UnitTest.Distribution.ParseUtils where + +import Distribution.ParseUtils +import Distribution.Compiler (CompilerFlavor, parseCompilerFlavorCompat) +import Distribution.License (License) +import Distribution.Version +import Distribution.Package ( parsePackageName ) +import Distribution.Compat.ReadP as ReadP hiding (get) +import Distribution.Simple.Utils (intercalate) +import Language.Haskell.Extension (Extension) + +import Text.PrettyPrint.HughesPJ hiding (braces) +import Data.Char (isSpace, isUpper, toLower, isAlphaNum, isSymbol, isDigit) +import Data.Maybe (fromMaybe) +import Data.Tree as Tree (Tree(..), flatten) + +import Test.HUnit (Test(..), assertBool, Assertion, runTestTT, Counts, assertEqual) +import IO +import System.Environment ( getArgs ) +import Control.Monad ( zipWithM_ ) + +------------------------------------------------------------------------------ +-- TESTING + +test_readFields = case + readFields testFile + of + ParseOk _ x -> x == expectedResult + _ -> False + where + testFile = unlines $ + [ "Cabal-version: 3" + , "" + , "Description: This is a test file " + , " with a description longer than two lines. " + , "if os(windows) {" + , " License: You may not use this software" + , " ." + , " If you do use this software you will be seeked and destroyed." + , "}" + , "if os(linux) {" + , " Main-is: foo1 " + , "}" + , "" + , "if os(vista) {" + , " executable RootKit {" + , " Main-is: DRMManager.hs" + , " }" + , "} else {" + , " executable VistaRemoteAccess {" + , " Main-is: VCtrl" + , "}}" + , "" + , "executable Foo-bar {" + , " Main-is: Foo.hs" + , "}" + ] + expectedResult = + [ F 1 "cabal-version" "3" + , F 3 "description" + "This is a test file\nwith a description longer than two lines." + , IfBlock 5 "os(windows) " + [ F 6 "license" + "You may not use this software\n\nIf you do use this software you will be seeked and destroyed." + ] + [] + , IfBlock 10 "os(linux) " + [ F 11 "main-is" "foo1" ] + [ ] + , IfBlock 14 "os(vista) " + [ Section 15 "executable" "RootKit " + [ F 16 "main-is" "DRMManager.hs"] + ] + [ Section 19 "executable" "VistaRemoteAccess " + [F 20 "main-is" "VCtrl"] + ] + , Section 23 "executable" "Foo-bar " + [F 24 "main-is" "Foo.hs"] + ] + +test_readFieldsCompat' = case test_readFieldsCompat of + ParseOk _ fs -> mapM_ (putStrLn . show) fs + x -> putStrLn $ "Failed: " ++ show x +test_readFieldsCompat = readFields testPkgDesc + where + testPkgDesc = unlines [ + "-- Required", + "Name: Cabal", + "Version: 0.1.1.1.1-rain", + "License: LGPL", + "License-File: foo", + "Copyright: Free Text String", + "Cabal-version: >1.1.1", + "-- Optional - may be in source?", + "Author: Happy Haskell Hacker", + "Homepage: http://www.haskell.org/foo", + "Package-url: http://www.haskell.org/foo", + "Synopsis: a nice package!", + "Description: a really nice package!", + "Category: tools", + "buildable: True", + "CC-OPTIONS: -g -o", + "LD-OPTIONS: -BStatic -dn", + "Frameworks: foo", + "Tested-with: GHC", + "Stability: Free Text String", + "Build-Depends: haskell-src, HUnit>=1.0.0-rain", + "Other-Modules: Distribution.Package, Distribution.Version,", + " Distribution.Simple.GHCPackageConfig", + "Other-files: file1, file2", + "Extra-Tmp-Files: file1, file2", + "C-Sources: not/even/rain.c, such/small/hands", + "HS-Source-Dirs: src, src2", + "Exposed-Modules: Distribution.Void, Foo.Bar", + "Extensions: OverlappingInstances, TypeSynonymInstances", + "Extra-Libraries: libfoo, bar, bang", + "Extra-Lib-Dirs: \"/usr/local/libs\"", + "Include-Dirs: your/slightest, look/will", + "Includes: /easily/unclose, /me, \"funky, path\\\\name\"", + "Install-Includes: /easily/unclose, /me, \"funky, path\\\\name\"", + "GHC-Options: -fTH -fglasgow-exts", + "Hugs-Options: +TH", + "Nhc-Options: ", + "Jhc-Options: ", + "", + "-- Next is an executable", + "Executable: somescript", + "Main-is: SomeFile.hs", + "Other-Modules: Foo1, Util, Main", + "HS-Source-Dir: scripts", + "Extensions: OverlappingInstances", + "GHC-Options: ", + "Hugs-Options: ", + "Nhc-Options: ", + "Jhc-Options: " + ] +{- +test' = do h <- openFile "../Cabal.cabal" ReadMode + s <- hGetContents h + let r = readFields s + case r of + ParseOk _ fs -> mapM_ (putStrLn . show) fs + x -> putStrLn $ "Failed: " ++ show x + putStrLn "===================" + mapM_ (putStrLn . show) $ + merge . zip [1..] . lines $ s + hClose h +-} + +-- ghc -DDEBUG --make Distribution/ParseUtils.hs -o test + +main :: IO () +main = do + inputFiles <- getArgs + ok <- mapM checkResult inputFiles + + zipWithM_ summary inputFiles ok + putStrLn $ show (length (filter not ok)) ++ " out of " ++ show (length ok) ++ " failed" + + where summary f True = return () + summary f False = putStrLn $ f ++ " failed :-(" + +checkResult :: FilePath -> IO Bool +checkResult inputFile = do + file <- readTextFile inputFile + case readFields file of + ParseOk _ result -> do + hPutStrLn stderr $ inputFile ++ " parses ok :-)" + return True + ParseFailed err -> do + hPutStrLn stderr $ inputFile ++ " parse failed:" + hPutStrLn stderr $ show err + return False diff --git a/cabal/cabal/tests/UnitTest/Distribution/Simple/PreProcess/UnlitTest.hs b/cabal/cabal/tests/UnitTest/Distribution/Simple/PreProcess/UnlitTest.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/UnitTest/Distribution/Simple/PreProcess/UnlitTest.hs @@ -0,0 +1,60 @@ + +module UnitTest.Distribution.Simple.PreProcess.Unlit where + +import Distribution.Simple.PreProcess.Unlit +import Control.Exception + +cases = + ( "", "" ) : + -- latex state + ( "\\begin{code}\n\\end{code}\na\n", "\n\n-- a\n") : -- latex -> comment + ( "\\begin{code}\nx=x\n\\end{code}\n", "\nx=x\n\n") : -- latex -> latex (code) + ( "\\begin{code}\n\\begin{code}\n", "\\begin{code} in code section") : -- latex -> error + -- blank state + ( "\\end{code}\n", "\\end{code} without \\begin{code}") : -- blank -> error + ( "\\begin{code}\n\\end{code}\n", "\n\n") : -- blank -> latex + ( " \n#pre\n \n", " \n#pre\n \n" ) : -- blank -> blank (CPP) + ( "\n \n#pre\n \n", "\n \n#pre\n \n" ) : -- blank -> blank (CPP) + ( "\n> x=x\n", "\n x=x\n" ) : -- blank -> bird (> ) + ( "\n>x=x\n", "\n x=x\n" ) : -- blank -> bird (>) + ( "\n", "\n" ) : -- blank -> blank + ( " \n", " \n" ) : -- blank -> blank + ( " \na\n", " \n-- a\n" ) : -- blank -> comment + -- bird state + ( "> x=x\n\\end{code}\n", "\\end{code} without \\begin{code}") : -- bird -> error + ( "> x=x\n\\begin{code}\ny=y\n", " x=x\n\ny=y\n" ) : -- bird -> latex + ( "> x=x\n#abc\n> y=y\n", " x=x\n#abc\n y=y\n" ) : -- bird -> bird (CPP) + ( "> x=x\n> y=y\n", " x=x\n y=y\n" ) : -- bird -> bird (> ) + ( ">x=x\n>y=y\n", " x=x\n y=y\n" ) : -- bird -> bird (>) + ( "> x=x\n \n", " x=x\n \n" ) : -- bird -> empty + ( "> x=x\na\n", "program line before comment line" ) : -- bird -> error + -- comment state + -- comment -> error + ( "a\n\\end{code}\n", "\\end{code} without \\begin{code}") : + -- comment -> latex + ( "a\n\\begin{code}\nx=x\n\\end{code}\nb\n", "-- a\n\nx=x\n\n-- b\n" ) : + ( "a\n#pre\nb\n", "-- a\n#pre\n-- b\n" ) : -- comment -> comment (CPP) + ( "a\n> x=x\n", "comment line before program line" ) : -- comment -> error + ( "abc\n", "-- abc\n" ) : + ( "a\nb\n", "-- a\n-- b\n") : + ( "a\n\n", "-- a\n\n") : -- comment -> blank + ( "a\n\nb\n", "-- a\n--\n-- b\n" ) : -- comment -> blank + ( "a\n \n\n", "-- a\n \n\n" ) : -- comment -> comment + ( "a\n \n> x=x\n", "-- a\n \n x=x\n" ) : -- comment -> blank (> ) + ( "a\n \n>x=x\n", "-- a\n \n x=x\n" ) : -- comment -> blank (>) + ( "a\n \nb\n", "-- a\n-- \n-- b\n" ) : -- comment -> comment + [] + + +assertEq :: Int -> String -> String -> IO () +assertEq n actual expect = + if actual /= expect + then putStrLn ("Test "++show n++" failed:\n expect: "++expect++"\n actual: "++(take 200 actual)++"\n") + else putStrLn ("Test "++show n++" passed.") + +runTest (n, (input, expect)) = do + let actual = either id stripErr $ unlit ("test"++show n) input + assertEq n actual (expect ++ "\n") + where stripErr = (++"\n") . drop 2 . dropWhile (/= ':') . tail . dropWhile (/= ':') + +runTests = mapM_ runTest (zip [1..] cases) diff --git a/cabal/cabal/tests/UnitTest/Distribution/Version.hs b/cabal/cabal/tests/UnitTest/Distribution/Version.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/UnitTest/Distribution/Version.hs @@ -0,0 +1,118 @@ +----------------------------------------------------------------------------- +-- | +-- 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 UnitTest.Distribution.Version (hunitTests) where + +import Distribution.Version +import Distribution.Text ( simpleParse ) + +import Data.Version ( Version(..), showVersion ) + +import Control.Monad ( liftM ) +import Data.Char ( isSpace, isDigit, isAlphaNum ) +import Data.Maybe ( listToMaybe ) + +import Distribution.Compat.ReadP + +import Test.HUnit + +-- ------------------------------------------------------------ +-- * Testing +-- ------------------------------------------------------------ + +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" + ~: (Just release1) ~=? simpleParse "1", + "released version 3" ~: "failed" + ~: (Just release3) ~=? simpleParse "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) + ] diff --git a/cabal/cabal/tests/hackage/check.sh b/cabal/cabal/tests/hackage/check.sh new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/hackage/check.sh @@ -0,0 +1,25 @@ +#!/bin/sh + +base_version=1.4.0.2 +test_version=1.5.6 + +for setup in archive/*/*/Setup.hs archive/*/*/Setup.lhs; do + + pkgname=$(basename ${setup}) + + if test $(wc -w < ${setup}) -gt 21; then + if ghc -package Cabal-${base_version} -S ${setup} -o /dev/null 2> /dev/null; then + + if ghc -package Cabal-${test_version} -S ${setup} -o /dev/null 2> /dev/null; then + echo "OK ${setup}" + else + echo "FAIL ${setup} does not compile with Cabal-${test_version}" + fi + else + echo "OK ${setup} (does not compile with Cabal-${base_version})" + fi + else + echo "trivial ${setup}" + fi + +done diff --git a/cabal/cabal/tests/hackage/download.sh b/cabal/cabal/tests/hackage/download.sh new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/hackage/download.sh @@ -0,0 +1,19 @@ +#!/bin/sh + +if test ! -f archive/archive.tar; then + + wget http://hackage.haskell.org/cgi-bin/hackage-scripts/archive.tar + mkdir -p archive + mv archive.tar archive/ + tar -C archive -xf archive/archive.tar + +fi + +if test ! -f archive/00-index.tar.gz; then + + wget http://hackage.haskell.org/packages/archive/00-index.tar.gz + mkdir -p archive + mv 00-index.tar.gz archive/ + tar -C archive -xzf archive/00-index.tar.gz + +fi diff --git a/cabal/cabal/tests/hackage/unpack.sh b/cabal/cabal/tests/hackage/unpack.sh new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/hackage/unpack.sh @@ -0,0 +1,16 @@ +#!/bin/sh + +for tarball in archive/*/*/*.tar.gz; do + + pkgdir=$(dirname ${tarball}) + pkgname=$(basename ${tarball} .tar.gz) + + if tar -tzf ${tarball} ${pkgname}/Setup.hs 2> /dev/null; then + tar -xzf ${tarball} ${pkgname}/Setup.hs -O > ${pkgdir}/Setup.hs + elif tar -tzf ${tarball} ${pkgname}/Setup.lhs 2> /dev/null; then + tar -xzf ${tarball} ${pkgname}/Setup.lhs -O > ${pkgdir}/Setup.lhs + else + echo "${pkgname} has no Setup.hs or .lhs at all!!?!" + fi + +done diff --git a/cabal/cabal/tests/misc/ghc-supported-languages.hs b/cabal/cabal/tests/misc/ghc-supported-languages.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/misc/ghc-supported-languages.hs @@ -0,0 +1,99 @@ +-- | A test program to check that ghc has got all of its extensions registered +-- +module Main where + +import Language.Haskell.Extension +import Distribution.Text +import Distribution.Simple.Utils +import Distribution.Verbosity + +import Data.List ((\\)) +import Data.Maybe +import Control.Applicative +import Control.Monad +import System.Environment +import System.Exit + +-- | A list of GHC extensions that are deliberately not registered, +-- e.g. due to being experimental and not ready for public consumption +-- +exceptions = map readExtension + [ "PArr" -- still classed as experimental, will be renamed and registered + ] + +checkProblems :: [Extension] -> [String] +checkProblems implemented = + + let unregistered = + [ ext | ext <- implemented -- extensions that ghc knows about + , not (registered ext) -- but that are not registered + , ext `notElem` exceptions ] -- except for the exceptions + + -- check if someone has forgotten to update the exceptions list... + + -- exceptions that are not implemented + badExceptions = exceptions \\ implemented + + -- exceptions that are now registered + badExceptions' = filter registered exceptions + + in catMaybes + [ check unregistered $ unlines + [ "The following extensions are known to GHC but are not in the " + , "extension registry in Language.Haskell.Extension." + , " " ++ intercalate "\n " (map display unregistered) + , "If these extensions are ready for public consumption then they " + , "should be registered. If they are still experimental and you " + , "think they are not ready to be registered then please add them " + , "to the exceptions list in this test program along with an " + , "explanation." + ] + , check badExceptions $ unlines + [ "Error in the extension exception list. The following extensions" + , "are listed as exceptions but are not even implemented by GHC:" + , " " ++ intercalate "\n " (map display badExceptions) + , "Please fix this test program by correcting the list of" + , "exceptions." + ] + , check badExceptions' $ unlines + [ "Error in the extension exception list. The following extensions" + , "are listed as exceptions to registration but they are in fact" + , "now registered in Language.Haskell.Extension:" + , " " ++ intercalate "\n " (map display badExceptions') + , "Please fix this test program by correcting the list of" + , "exceptions." + ] + ] + where + registered (UnknownExtension _) = False + registered _ = True + + check [] _ = Nothing + check _ i = Just i + + +main = topHandler $ do + [ghcPath] <- getArgs + exts <- getExtensions ghcPath + let problems = checkProblems exts + putStrLn (intercalate "\n" problems) + if null problems + then exitSuccess + else exitFailure + +getExtensions :: FilePath -> IO [Extension] +getExtensions ghcPath = + map readExtension . lines + <$> rawSystemStdout normal ghcPath ["--supported-languages"] + +readExtension :: String -> Extension +readExtension str = handleNoParse $ do + -- GHC defines extensions in a positive way, Cabal defines them + -- relative to H98 so we try parsing ("No" ++ extName) first + ext <- simpleParse ("No" ++ str) + case ext of + UnknownExtension _ -> simpleParse str + _ -> return ext + where + handleNoParse :: Maybe Extension -> Extension + handleNoParse = fromMaybe (error $ "unparsable extension " ++ show str) diff --git a/cabal/cabal/tests/suite.cabal b/cabal/cabal/tests/suite.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/suite.cabal @@ -0,0 +1,30 @@ +name: suite +version: 0.1 +license: BSD3 +author: Stephen Blackheath +stability: stable +synopsis: test suite for cabal +category: Distribution +build-type: Simple +cabal-version: >= 1.6 +description: + A test suite for cabal. Run it often, maintain it, add tests to it, + and it will work for you. + +Executable suite + main-is: suite.hs + build-depends: + base, + test-framework, + test-framework-quickcheck2, + test-framework-hunit, + HUnit, + QuickCheck >= 2.1.0.1, + Cabal, + filepath, + process, + directory, + extensible-exceptions, + bytestring, + unix + diff --git a/cabal/cabal/tests/suite.hs b/cabal/cabal/tests/suite.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/suite.hs @@ -0,0 +1,66 @@ +-- The intention is that this will be the new unit test framework. +-- Please add any working tests here. This file should do nothing +-- but import tests from other modules. +-- +-- Stephen Blackheath, 2009 + +module Main where + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import qualified Test.HUnit as HUnit +import PackageTests.BuildDeps.SameDepsAllRound.Check +import PackageTests.BuildDeps.TargetSpecificDeps1.Check +import PackageTests.BuildDeps.TargetSpecificDeps1.Check +import PackageTests.BuildDeps.TargetSpecificDeps2.Check +import PackageTests.BuildDeps.TargetSpecificDeps3.Check +import PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check +import PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check +import PackageTests.BuildDeps.InternalLibrary0.Check +import PackageTests.BuildDeps.InternalLibrary1.Check +import PackageTests.BuildDeps.InternalLibrary2.Check +import PackageTests.BuildDeps.InternalLibrary3.Check +import PackageTests.BuildDeps.InternalLibrary4.Check +import PackageTests.TestStanza.Check +import PackageTests.TestSuiteExeV10.Check +import Distribution.Text (display) +import Distribution.Simple.Utils (cabalVersion) +import Data.Version +import System.Directory + +hunit :: TestName -> HUnit.Test -> Test +hunit name test = testGroup name $ hUnitTestToTests test + +tests :: Version -> [Test] +tests cabalVersion = [ + hunit "PackageTests/BuildDeps/SameDepsAllRound/" PackageTests.BuildDeps.SameDepsAllRound.Check.suite, + hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check.suite, + hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check.suite, + hunit "PackageTests/BuildDeps/InternalLibrary0/" (PackageTests.BuildDeps.InternalLibrary0.Check.suite cabalVersion), + hunit "PackageTests/TestStanza/" (PackageTests.TestStanza.Check.suite cabalVersion), + -- ^ The Test stanza test will eventually be required + -- only for higher versions. + hunit "PackageTests/TestSuiteExeV10/Test" + (PackageTests.TestSuiteExeV10.Check.checkTest cabalVersion), + hunit "PackageTests/TestSuiteExeV10/TestWithHpc" + (PackageTests.TestSuiteExeV10.Check.checkTestWithHpc cabalVersion) + ] ++ + -- These tests are only required to pass on cabal version >= 1.7 + (if cabalVersion >= Version [1, 7] [] + then [ + hunit "PackageTests/BuildDeps/TargetSpecificDeps1/" PackageTests.BuildDeps.TargetSpecificDeps1.Check.suite, + hunit "PackageTests/BuildDeps/TargetSpecificDeps2/" PackageTests.BuildDeps.TargetSpecificDeps2.Check.suite, + hunit "PackageTests/BuildDeps/TargetSpecificDeps3/" PackageTests.BuildDeps.TargetSpecificDeps3.Check.suite, + hunit "PackageTests/BuildDeps/InternalLibrary1/" PackageTests.BuildDeps.InternalLibrary1.Check.suite, + hunit "PackageTests/BuildDeps/InternalLibrary2/" PackageTests.BuildDeps.InternalLibrary2.Check.suite, + hunit "PackageTests/BuildDeps/InternalLibrary3/" PackageTests.BuildDeps.InternalLibrary3.Check.suite, + hunit "PackageTests/BuildDeps/InternalLibrary4/" PackageTests.BuildDeps.InternalLibrary4.Check.suite + ] + else []) + +main = do + putStrLn $ "Cabal test suite - testing cabal version "++display cabalVersion + setCurrentDirectory "tests" + defaultMain (tests cabalVersion) + diff --git a/cabal/cabal/tests/systemTests/A/A.cabal b/cabal/cabal/tests/systemTests/A/A.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/A/A.cabal @@ -0,0 +1,23 @@ +Name: test +cabal-version: > 1.1 +Version: 1.0 +copyright: filler for test suite +maintainer: Isaac Jones +synopsis: this package is really awesome. +Build-Depends: base +Other-Modules: B.A +Exposed-Modules: A +C-Sources: hello.c, c_src/hello.c +Extensions: ForeignFunctionInterface +x-darcs-repo: http://darcs.haskell.org/tmp +unknown-field: Filler. + +Executable: testA +Other-Modules: A +Main-is: MainA.hs +C-Sources: c_src/hello.c +Extensions: OverlappingInstances + +Executable: testB +Other-Modules: B.A +Main-is: B/MainB.hs diff --git a/cabal/cabal/tests/systemTests/A/A.hs b/cabal/cabal/tests/systemTests/A/A.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/A/A.hs @@ -0,0 +1,4 @@ +module A where +a = 42 :: Int + +main2 = print a diff --git a/cabal/cabal/tests/systemTests/A/B/A.lhs b/cabal/cabal/tests/systemTests/A/B/A.lhs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/A/B/A.lhs @@ -0,0 +1,4 @@ +> module B.A where +> a = 42 :: Int + +> main = print a diff --git a/cabal/cabal/tests/systemTests/A/B/MainB.hs b/cabal/cabal/tests/systemTests/A/B/MainB.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/A/B/MainB.hs @@ -0,0 +1,5 @@ +module Main where + +import A + +main = print a diff --git a/cabal/cabal/tests/systemTests/A/MainA.hs b/cabal/cabal/tests/systemTests/A/MainA.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/A/MainA.hs @@ -0,0 +1,5 @@ +module Main where + +import A + +main = print a diff --git a/cabal/cabal/tests/systemTests/A/Makefile b/cabal/cabal/tests/systemTests/A/Makefile new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/A/Makefile @@ -0,0 +1,1 @@ +include ../Tests.mk diff --git a/cabal/cabal/tests/systemTests/A/Setup.lhs b/cabal/cabal/tests/systemTests/A/Setup.lhs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/A/Setup.lhs @@ -0,0 +1,8 @@ +#!/usr/bin/env runhaskell + +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/cabal/cabal/tests/systemTests/A/c_src/hello.c b/cabal/cabal/tests/systemTests/A/c_src/hello.c new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/A/c_src/hello.c @@ -0,0 +1,1 @@ +int foo () {return 9;} diff --git a/cabal/cabal/tests/systemTests/A/hello.c b/cabal/cabal/tests/systemTests/A/hello.c new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/A/hello.c @@ -0,0 +1,1 @@ +int main () {return 9;} diff --git a/cabal/cabal/tests/systemTests/buildInfo/Makefile b/cabal/cabal/tests/systemTests/buildInfo/Makefile new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/buildInfo/Makefile @@ -0,0 +1,1 @@ +include ../Tests.mk diff --git a/cabal/cabal/tests/systemTests/buildInfo/Setup.lhs b/cabal/cabal/tests/systemTests/buildInfo/Setup.lhs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/buildInfo/Setup.lhs @@ -0,0 +1,5 @@ +#!/usr/bin/runhaskell + +> import Distribution.Simple +> main = defaultMainWithHooks defaultUserHooks + diff --git a/cabal/cabal/tests/systemTests/buildInfo/buildinfo2.buildinfo b/cabal/cabal/tests/systemTests/buildInfo/buildinfo2.buildinfo new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/buildInfo/buildinfo2.buildinfo @@ -0,0 +1,5 @@ +Executable: exe1 +Buildable: True + +Executable: exe2 +Buildable: True diff --git a/cabal/cabal/tests/systemTests/buildInfo/buildinfo2.cabal b/cabal/cabal/tests/systemTests/buildInfo/buildinfo2.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/buildInfo/buildinfo2.cabal @@ -0,0 +1,19 @@ +Name: buildinfo2 +Version: 0.0 +License: GPL +License-file: COPYING +Build-Depends: base +Author: Evgeny Chukreev +Copyright: Evgeny Chukreev (C) 2005 +Maintainer: Evgeny Chukreev +Synopsis: Buildinfo testcase +Description: + Buildinfo testcase + +Executable: exe1 +Main-is: exe1.hs +HS-source-dirs: src + +Executable: exe2 +Main-is: exe2.hs +HS-source-dirs: src diff --git a/cabal/cabal/tests/systemTests/buildInfo/src/exe1.hs b/cabal/cabal/tests/systemTests/buildInfo/src/exe1.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/buildInfo/src/exe1.hs @@ -0,0 +1,4 @@ +module Main () where + +main :: IO () +main = return () diff --git a/cabal/cabal/tests/systemTests/buildInfo/src/exe2.hs b/cabal/cabal/tests/systemTests/buildInfo/src/exe2.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/buildInfo/src/exe2.hs @@ -0,0 +1,4 @@ +module Main () where + +main :: IO () +main = return () diff --git a/cabal/cabal/tests/systemTests/dataDir/Exe.hs b/cabal/cabal/tests/systemTests/dataDir/Exe.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/dataDir/Exe.hs @@ -0,0 +1,17 @@ +module Main where + +import Control.Monad (unless) +import Paths_test (getDataFileName) +import System.Directory (doesFileExist) +import System.Exit (exitFailure) +import System.IO (putStrLn) + +main :: IO () +main = do + fname <- getDataFileName "data-file" + exists <- doesFileExist fname + if exists + then return () + else do putStrLn "Failure." + print fname + exitFailure diff --git a/cabal/cabal/tests/systemTests/dataDir/data-file b/cabal/cabal/tests/systemTests/dataDir/data-file new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/dataDir/data-file diff --git a/cabal/cabal/tests/systemTests/dataDir/dataDir.cabal b/cabal/cabal/tests/systemTests/dataDir/dataDir.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/dataDir/dataDir.cabal @@ -0,0 +1,13 @@ +name: test +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 +data-files: data-file + +-- This test passes if running the below executeable doesn't return an +-- 'exitFailure' status code. + +executable exe + main-is: Exe.hs +-- other-modules: Paths_test + build-depends: base, directory diff --git a/cabal/cabal/tests/systemTests/depOnLib/Makefile b/cabal/cabal/tests/systemTests/depOnLib/Makefile new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/depOnLib/Makefile @@ -0,0 +1,1 @@ +include ../Tests.mk diff --git a/cabal/cabal/tests/systemTests/depOnLib/Setup.lhs b/cabal/cabal/tests/systemTests/depOnLib/Setup.lhs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/depOnLib/Setup.lhs @@ -0,0 +1,8 @@ +#!/usr/bin/runhugs + +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/cabal/cabal/tests/systemTests/depOnLib/libs/A.hs b/cabal/cabal/tests/systemTests/depOnLib/libs/A.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/depOnLib/libs/A.hs @@ -0,0 +1,4 @@ +module A where + +a :: Char +a = 'a' diff --git a/cabal/cabal/tests/systemTests/depOnLib/mains/Main.hs b/cabal/cabal/tests/systemTests/depOnLib/mains/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/depOnLib/mains/Main.hs @@ -0,0 +1,4 @@ +module Main where +import A + +main = putStrLn "Hello, cabal." diff --git a/cabal/cabal/tests/systemTests/depOnLib/test.cabal b/cabal/cabal/tests/systemTests/depOnLib/test.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/depOnLib/test.cabal @@ -0,0 +1,13 @@ +Name: test +Version: 1.0 +hs-source-dir: libs +copyright: filler for test suite +maintainer: filler for test suite +synopsis: filler for test suite +build-depends: base +exposed-modules: A + +Executable: mainForA +Other-Modules: Main, A +hs-source-dirs: mains, libs +Main-is: Main.hs diff --git a/cabal/cabal/tests/systemTests/exeWithC/Makefile b/cabal/cabal/tests/systemTests/exeWithC/Makefile new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/exeWithC/Makefile @@ -0,0 +1,1 @@ +include ../Tests.mk diff --git a/cabal/cabal/tests/systemTests/exeWithC/Setup.lhs b/cabal/cabal/tests/systemTests/exeWithC/Setup.lhs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/exeWithC/Setup.lhs @@ -0,0 +1,2 @@ +> import Distribution.Simple +> main = defaultMainWithHooks defaultUserHooks diff --git a/cabal/cabal/tests/systemTests/exeWithC/a.c b/cabal/cabal/tests/systemTests/exeWithC/a.c new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/exeWithC/a.c @@ -0,0 +1,1 @@ +int foo(int v) { return 2*v; } diff --git a/cabal/cabal/tests/systemTests/exeWithC/test.hs b/cabal/cabal/tests/systemTests/exeWithC/test.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/exeWithC/test.hs @@ -0,0 +1,4 @@ +{-# CFILES a.c #-} +foreign import ccall unsafe "foo" foo :: Int -> Int + +main = print $ foo 6 diff --git a/cabal/cabal/tests/systemTests/exeWithC/tt.cabal b/cabal/cabal/tests/systemTests/exeWithC/tt.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/exeWithC/tt.cabal @@ -0,0 +1,13 @@ +Name: tt +Version: 0.0 +Copyright: Einar Karttunen +Maintainer: Isaac Jones +Synopsis: Provided as a test. +License: BSD3 +Author: This Test Case Contributed by: Einar Karttunen Thanks! +Build-Depends: base + +Executable: tt +Main-Is: test.hs +C-Sources: a.c +Extensions: ForeignFunctionInterface diff --git a/cabal/cabal/tests/systemTests/ffi-bin/Main.hs b/cabal/cabal/tests/systemTests/ffi-bin/Main.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/ffi-bin/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import TestFFI + +main :: IO () +main = putStrLn "test" + diff --git a/cabal/cabal/tests/systemTests/ffi-bin/Makefile b/cabal/cabal/tests/systemTests/ffi-bin/Makefile new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/ffi-bin/Makefile @@ -0,0 +1,1 @@ +include ../Tests.mk diff --git a/cabal/cabal/tests/systemTests/ffi-bin/Setup.lhs b/cabal/cabal/tests/systemTests/ffi-bin/Setup.lhs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/ffi-bin/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/cabal/cabal/tests/systemTests/ffi-bin/main.cabal b/cabal/cabal/tests/systemTests/ffi-bin/main.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/ffi-bin/main.cabal @@ -0,0 +1,6 @@ +Name: test-bin +Build-Depends: base, testffi +Version: 0.0 + +Executable: test +Main-Is: Main.hs diff --git a/cabal/cabal/tests/systemTests/ffi-package/Makefile b/cabal/cabal/tests/systemTests/ffi-package/Makefile new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/ffi-package/Makefile @@ -0,0 +1,1 @@ +include ../Tests.mk diff --git a/cabal/cabal/tests/systemTests/ffi-package/Setup.lhs b/cabal/cabal/tests/systemTests/ffi-package/Setup.lhs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/ffi-package/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhugs + +> import Distribution.Simple +> main = defaultMain diff --git a/cabal/cabal/tests/systemTests/ffi-package/TestFFIExe.hs b/cabal/cabal/tests/systemTests/ffi-package/TestFFIExe.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/ffi-package/TestFFIExe.hs @@ -0,0 +1,11 @@ +module Main where + +import Foreign + +type Action = IO () + +foreign import ccall "wrapper" + mkAction :: Action -> IO (FunPtr Action) + +main :: IO () +main = return () diff --git a/cabal/cabal/tests/systemTests/ffi-package/src/TestFFI.hs b/cabal/cabal/tests/systemTests/ffi-package/src/TestFFI.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/ffi-package/src/TestFFI.hs @@ -0,0 +1,8 @@ +module TestFFI where + +import Foreign + +type Action = IO () + +foreign import ccall "wrapper" + mkAction :: Action -> IO (FunPtr Action) diff --git a/cabal/cabal/tests/systemTests/ffi-package/testffi.cabal b/cabal/cabal/tests/systemTests/ffi-package/testffi.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/ffi-package/testffi.cabal @@ -0,0 +1,10 @@ +Name: testffi +Version: 0.0 +Build-Depends: base +hs-source-dir: src +Exposed-modules: TestFFI +Extensions: ForeignFunctionInterface + +executable: foo +main-is: TestFFIExe.hs +Extensions: ForeignFunctionInterface diff --git a/cabal/cabal/tests/systemTests/preprocess/preprocess.cabal b/cabal/cabal/tests/systemTests/preprocess/preprocess.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/preprocess/preprocess.cabal @@ -0,0 +1,9 @@ +-- The point of this test is to check that the c2hs pre-processed .hs sources +-- end up in dist/build and that the happy one stays in the src dir. +-- Also, the happy one should be included into the sdist tarball. + +name: preprocess +version: 0.0 +build-depends: base +hs-source-dirs: src +exposed-modules: C2HsExample, HappyExample diff --git a/cabal/cabal/tests/systemTests/preprocess/src/C2HsExample.chs b/cabal/cabal/tests/systemTests/preprocess/src/C2HsExample.chs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/preprocess/src/C2HsExample.chs @@ -0,0 +1,3 @@ +module C2HsExample where + +-- we don't actually need anything diff --git a/cabal/cabal/tests/systemTests/preprocess/src/HappyExample.y b/cabal/cabal/tests/systemTests/preprocess/src/HappyExample.y new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/preprocess/src/HappyExample.y @@ -0,0 +1,92 @@ +{ +module HappyExample where +import Data.Char +} + +%name calc +%tokentype { Token } +%expect 0 + + +%token + let { TokenLet } + in { TokenIn } + int { TokenInt $$ } + var { TokenVar $$ } + '=' { TokenEq } + '+' { TokenPlus } + '-' { TokenMinus } + '*' { TokenTimes } + '/' { TokenDiv } + '(' { TokenOB } + ')' { TokenCB } + + +%% + +Exp :: { Exp } +Exp : let var '=' Exp in Exp { Let $2 $4 $6 } + | Exp1 { Exp1 $1 } + +Exp1 : Exp1 '+' Term { Plus $1 $3 } + | Exp1 '-' Term { Minus $1 $3 } + | Term { Term $1 } + +Term : Term '*' Factor { Times $1 $3 } + | Term '/' Factor { Div $1 $3 } + | Factor { Factor $1 } + +Factor : int { Int $1 } + | var { Var $1 } + | '(' Exp ')' { Brack $2 } + + +{ + +happyError :: [Token] -> a +happyError _ = error ("Parse error\n") + + +data Exp = Let String Exp Exp | Exp1 Exp1 +data Exp1 = Plus Exp1 Term | Minus Exp1 Term | Term Term +data Term = Times Term Factor | Div Term Factor | Factor Factor +data Factor = Int Int | Var String | Brack Exp + + +data Token + = TokenLet + | TokenIn + | TokenInt Int + | TokenVar String + | TokenEq + | TokenPlus + | TokenMinus + | TokenTimes + | TokenDiv + | TokenOB + | TokenCB + +lexer :: String -> [Token] +lexer [] = [] +lexer (c:cs) + | isSpace c = lexer cs + | isAlpha c = lexVar (c:cs) + | isDigit c = lexNum (c:cs) +lexer ('=':cs) = TokenEq : lexer cs +lexer ('+':cs) = TokenPlus : lexer cs +lexer ('-':cs) = TokenMinus : lexer cs +lexer ('*':cs) = TokenTimes : lexer cs +lexer ('/':cs) = TokenDiv : lexer cs +lexer ('(':cs) = TokenOB : lexer cs +lexer (')':cs) = TokenCB : lexer cs + +lexNum cs = TokenInt (read num) : lexer rest + where (num,rest) = span isDigit cs + +lexVar cs = + case span isAlpha cs of + ("let",rest) -> TokenLet : lexer rest + ("in",rest) -> TokenIn : lexer rest + (var,rest) -> TokenVar var : lexer rest + +} diff --git a/cabal/cabal/tests/systemTests/recursive/A.hi-boot b/cabal/cabal/tests/systemTests/recursive/A.hi-boot new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/recursive/A.hi-boot @@ -0,0 +1,2 @@ +module A where +newtype TA = MkTA GHC.Base.Int diff --git a/cabal/cabal/tests/systemTests/recursive/A.hs b/cabal/cabal/tests/systemTests/recursive/A.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/recursive/A.hs @@ -0,0 +1,8 @@ +module A where + +import B( TB(..) ) + +newtype TA = MkTA Int + +f :: TB -> TA +f (MkTB x) = MkTA x diff --git a/cabal/cabal/tests/systemTests/recursive/A.hs-boot b/cabal/cabal/tests/systemTests/recursive/A.hs-boot new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/recursive/A.hs-boot @@ -0,0 +1,2 @@ +module A where +newtype TA = MkTA Int diff --git a/cabal/cabal/tests/systemTests/recursive/B.hs b/cabal/cabal/tests/systemTests/recursive/B.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/recursive/B.hs @@ -0,0 +1,8 @@ +module B where +import {-# SOURCE #-} A( TA(..) ) + +data TB = MkTB !Int + +g :: TA -> TB +g (MkTA x) = MkTB x + diff --git a/cabal/cabal/tests/systemTests/recursive/C.hs b/cabal/cabal/tests/systemTests/recursive/C.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/recursive/C.hs @@ -0,0 +1,6 @@ +module Main where +import B +import A -- FIX: GHC doesn't seem to figure out this dependency?! + +main :: IO () +main = let f = g in putStrLn "C" diff --git a/cabal/cabal/tests/systemTests/recursive/Makefile b/cabal/cabal/tests/systemTests/recursive/Makefile new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/recursive/Makefile @@ -0,0 +1,1 @@ +include ../Tests.mk diff --git a/cabal/cabal/tests/systemTests/recursive/Setup.lhs b/cabal/cabal/tests/systemTests/recursive/Setup.lhs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/recursive/Setup.lhs @@ -0,0 +1,8 @@ +#!/usr/bin/env runhaskell + +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/cabal/cabal/tests/systemTests/recursive/recursive.cabal b/cabal/cabal/tests/systemTests/recursive/recursive.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/recursive/recursive.cabal @@ -0,0 +1,11 @@ +name: recursive +build-depends: base +version: 1.0 +copyright: filler for test suite +maintainer: Isaac Jones +synopsis: this package is really awesome. +Exposed-Modules: A, B + +Executable: testExe +Main-is: C.hs +other-modules: A, B diff --git a/cabal/cabal/tests/systemTests/sdist/Exe1.hs b/cabal/cabal/tests/systemTests/sdist/Exe1.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/sdist/Exe1.hs @@ -0,0 +1,1 @@ +main = print "exe1" diff --git a/cabal/cabal/tests/systemTests/sdist/Exe2.hs b/cabal/cabal/tests/systemTests/sdist/Exe2.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/sdist/Exe2.hs @@ -0,0 +1,1 @@ +main = print "exe2" diff --git a/cabal/cabal/tests/systemTests/sdist/sdist.cabal b/cabal/cabal/tests/systemTests/sdist/sdist.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/sdist/sdist.cabal @@ -0,0 +1,19 @@ +Name: test +Version: 0.1 +Build-Type: Simple +Cabal-Version: >=1.2 + +-- http://hackage.haskell.org/trac/hackage/ticket/257 +-- This is a test to make sure we're including all sections into the sdist +-- irrespective of the buildable status. +-- So the test passes if the tarball includes both Exe1.hs and Exe2.hs + +Executable exe1 + Main-Is: Exe1.hs + Build-Depends: base + +Executable exe2 + Main-Is: Exe2.hs + Build-Depends: base + if !os(linux) + Buildable: False diff --git a/cabal/cabal/tests/systemTests/twoMains/MainA.hs b/cabal/cabal/tests/systemTests/twoMains/MainA.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/twoMains/MainA.hs @@ -0,0 +1,9 @@ +module Main where + +import System.Environment (getArgs) +import Control.Monad (when) + +main = do print 'a' + args <- getArgs + let isB = head args + when (isB /= "isA") (error "A is not A!") diff --git a/cabal/cabal/tests/systemTests/twoMains/MainB.hs b/cabal/cabal/tests/systemTests/twoMains/MainB.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/twoMains/MainB.hs @@ -0,0 +1,9 @@ +module Main where + +import System.Environment (getArgs) +import Control.Monad (when) + +main = do print 'b' + args <- getArgs + let isB = head args + when (isB /= "isB") (error "B is not B!") diff --git a/cabal/cabal/tests/systemTests/twoMains/Makefile b/cabal/cabal/tests/systemTests/twoMains/Makefile new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/twoMains/Makefile @@ -0,0 +1,1 @@ +include ../Tests.mk diff --git a/cabal/cabal/tests/systemTests/twoMains/Setup.lhs b/cabal/cabal/tests/systemTests/twoMains/Setup.lhs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/twoMains/Setup.lhs @@ -0,0 +1,8 @@ +#!/usr/bin/runhugs + +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/cabal/cabal/tests/systemTests/twoMains/test.cabal b/cabal/cabal/tests/systemTests/twoMains/test.cabal new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/twoMains/test.cabal @@ -0,0 +1,14 @@ +Name: test +Version: 1.0 +copyright: filler for test suite +maintainer: filler for test suite +build-depends: base +synopsis: filler for test suite + +Executable: testA +Other-Modules: MainA +Main-is: MainA.hs + +Executable: testB +Other-Modules: MainB +Main-is: MainB.hs diff --git a/cabal/cabal/tests/systemTests/wash2hs/CHANGES b/cabal/cabal/tests/systemTests/wash2hs/CHANGES new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/wash2hs/CHANGES @@ -0,0 +1,5 @@ +* 20031112 + added JSP-style string escape: + <%= my nice haskell code %> + is mapped to + text (my nice haskell code) diff --git a/cabal/cabal/tests/systemTests/wash2hs/LICENSE b/cabal/cabal/tests/systemTests/wash2hs/LICENSE new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/wash2hs/LICENSE @@ -0,0 +1,27 @@ +Copyright (C) 2000-2003 Erik Meijer, Danny van Velzen, and Peter Thiemann + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. 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. +3. The names of the authors may not be used to endorse or promote + products derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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/cabal/cabal/tests/systemTests/wash2hs/Makefile b/cabal/cabal/tests/systemTests/wash2hs/Makefile new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/wash2hs/Makefile @@ -0,0 +1,1 @@ +include ../Tests.mk diff --git a/cabal/cabal/tests/systemTests/wash2hs/Setup.lhs b/cabal/cabal/tests/systemTests/wash2hs/Setup.lhs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/wash2hs/Setup.lhs @@ -0,0 +1,9 @@ +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain + +to compile: +ghc -package Cabal -package parsec Setup.lhs -o setup diff --git a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHClean.hs b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHClean.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHClean.hs @@ -0,0 +1,58 @@ +module WASHClean where + +import Data.Char + +import WASHData + +data CM a = CM ([String] -> a) +instance Monad CM where -- Reader monad + return x = CM (const x) + m >>= f = CM (\strs -> + case m of + CM mfun -> + case f (mfun strs) of + CM ffun -> + ffun strs) + +class Clean n where + clean :: n -> CM n + +cleanCodeFragList :: [CodeFrag] -> [CodeFrag] +cleanCodeFragList = map g + where g (EFrag el) = EFrag (cleanElement el) + g (CFrag cs) = CFrag (cleanContentList cs) + g cf = cf + +cleanElement :: Element -> Element +cleanElement e@Element{elemName = en, elemContent = ec} = + if en == "pre" + then e + else let ec' = cleanContentList ec in + e{elemContent = ec'} + +cleanContentList :: [Content] -> [Content] +cleanContentList = remove . map g . combine + where g c = case c of CElement{celem = el} -> CElement{celem = cleanElement el} + CText{ctext = et} -> CText{ctext = et { textString = cleanText (textString et) }} + CCode{ccode = ec} -> CCode{ccode = cleanCodeFragList ec} + _ -> c + combine (CText {ctext = t1} : CText {ctext = t2} : rest ) = + combine (CText {ctext = Text {textString = textString t1++ textString t2, textMode = textMode t1}} : rest) + combine (x : xs) = x : combine xs + combine [] = [] + remove (CText{ctext = tt} : rest) | textString tt == " " = remove rest + -- remove (CText{ctext = tt} : rest@(CElement{} : _)) = CText{ctext = dropRight tt} : remove rest + -- remove (e@CElement{} : (CText{ctext = tt} : rest)) = e : remove (CText{ctext = dropLeft tt} : rest) + remove (x : rest) = x : remove rest + remove [] = [] + +cleanText "" = "" +cleanText xs@[x] | isSpace x = " " + | otherwise = xs +cleanText (x : ys@(y : _)) | isSpace x = if isSpace y + then cleanText ys + else ' ' : cleanText ys + | otherwise = x : cleanText ys + +dropRight tt = tt { textString = reverse (dropWhile isSpace (reverse (textString tt))) } +dropLeft tt = tt { textString = dropWhile isSpace (textString tt) } diff --git a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHData.hs b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHData.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHData.hs @@ -0,0 +1,74 @@ +module WASHData -- derived from HSPData + ( File (..) + , Mode (..) + , Element (..) + , Text (..) + , Content (..) + , CodeFrag (..) + , Attribute (..) + , AttrValue (..) + ) +where { + + +-- Data type. + +data File = File { + fcode :: [CodeFrag], + topElem :: Element + } deriving Show; + +data Mode = V | S | F + deriving (Eq,Show); + +data Element = Element + { elemMode :: Mode + , elemName :: String + , elemAttrs :: [Attribute] + , elemContent :: [Content] + , elemEmptyTag :: Bool } + deriving Show; + +data Text = Text + { textMode :: Mode + , textString :: String + } + deriving Show; + +data Content + = CElement { celem :: Element } + | CText { ctext :: Text } + | CReference { creference :: Text } + | CPI { cpi :: String } + | CComment { ccomment :: String } + | CCode { ccode :: [CodeFrag] } + deriving Show; + +data CodeFrag + = HFrag String + | EFrag Element + | HSFrag String + | CFrag [Content] + | AFrag [Attribute] + | VFrag String + deriving Show; + +data Attribute + = Attribute + { attrMode :: Mode + , attrName :: String + , attrValue :: AttrValue } + | AttrPattern + { attrPattern :: String } + deriving Show; + +data AttrValue + = AText String + | ACode String + deriving Show; + +data Reference = Reference String deriving Show; + + + +} diff --git a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHExpression.hs b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHExpression.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHExpression.hs @@ -0,0 +1,158 @@ +module WASHExpression where + +import Control.Monad + +import WASHFlags +import qualified WASHUtil +import WASHData +import WASHOut + +code :: FLAGS -> [CodeFrag] -> ShowS +code flags [] = id +code flags (x:xs) = code' flags x . code flags xs + +code' :: FLAGS -> CodeFrag -> ShowS +code' flags (HFrag h) = + showString h +code' flags (EFrag e) = + runOut $ element flags e +code' flags (CFrag cnts) = + showChar '(' . + runOut (contents flags [] cnts) . + showChar ')' +code' flags (AFrag attrs) = + showChar '(' . + WASHUtil.itemList (attribute flags) "CGI.empty" " >> " attrs . + showChar ')' +code' flags (VFrag var) = + id +code' flags _ = error "Unknown type: code" + +outMode :: Mode -> Out () +outMode = outShowS . showMode + +showMode :: Mode -> ShowS +showMode V = id +showMode S = showString "_T" +showMode F = showString "_S" + +element :: FLAGS -> Element -> Out [String] +element flags (Element mode nm ats cnt et) = + do outChar '(' + outString "CGI." + outString nm + when (generateBT flags) $ outMode mode + outChar '(' + outShowS $ attributes flags ats + rvs <- contents flags [] cnt + outString "))" + return rvs + +outRVS :: [String] -> Out () +outRVS [] = outString "()" +outRVS (x:xs) = + do outChar '(' + outString x + mapM_ g xs + outChar ')' + where g x = do { outChar ','; outString x; } + +outRVSpat :: [String] -> Out () +outRVSpat [] = outString "(_)" +outRVSpat xs = outRVS xs + +contents :: FLAGS -> [String] -> [Content] -> Out [String] +contents flags inRVS cts = + case cts of + [] -> + do outString "return" + outRVS inRVS + return inRVS + ct:cts -> + do rvs <- content flags ct + case rvs of + [] -> + case (cts, inRVS) of + ([],[]) -> + return [] + _ -> + do outString " >> " + contents flags inRVS cts + _ -> + case (cts, inRVS) of + ([],[]) -> + return rvs + _ -> + do outString " >>= \\ " + outRVSpat rvs + outString " -> " + contents flags (rvs ++ inRVS) cts + +content :: FLAGS -> Content -> Out [String] +content flags (CElement elem) = + element flags elem +content flags (CText txt) = + do text flags txt + return [] +content flags (CCode (VFrag var:c)) = + do outShowS $ (showChar '(' . code flags c . showChar ')') + return [var] +content flags (CCode c) = + do outShowS $ (showChar '(' . code flags c . showChar ')') + return [] +content flags (CComment cc) = + do outShowS $ (showString "return (const () " . shows cc . showChar ')') + return [] +content flags (CReference txt) = + do text flags txt + return [] +content flags c = + error $ "Unknown type: content -- " ++ (show c) + +text :: FLAGS -> Text -> Out [String] +text flags txt = + do outString "CGI.rawtext" + when (generateBT flags) $ outMode (textMode txt) + outChar ' ' + outs (textString txt) + return [] + +attributes :: FLAGS -> [Attribute] -> ShowS +attributes flags atts = + f atts + where + f [] = id + f (att:atts) = + attribute flags att . + showString " >> " . + f atts + +attribute :: FLAGS -> Attribute -> ShowS +attribute flags (Attribute m n v) = + showString "(CGI.attr" . + (if generateBT flags then (attrvalueBT m v) else id) . + showChar ' ' . + shows n . + showString " " . + attrvalue v . + showString ")" +attribute flags (AttrPattern pat) = + showString "( " . + showString pat . + showString " )" +attribute flags a = error $ "Unknown type: attribute -- " ++ (show a) + +attrvalue :: AttrValue -> ShowS +attrvalue (AText t) = + shows t +attrvalue (ACode c) = + showString "( " . + showString c . + showString " )" +attrvalue a = error $ "Unknown type: attrvalue -- " ++ (show a) + +attrvalueBT :: Mode -> AttrValue -> ShowS +attrvalueBT V _ = id +attrvalueBT m (AText _) = showMode m . showChar 'S' +attrvalueBT m (ACode _) = showMode m . showChar 'D' +attrvalueBT m a = error $ "Unknown type: attrvalueBT -- " ++ (show a) diff --git a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHFlags.hs b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHFlags.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHFlags.hs @@ -0,0 +1,7 @@ +module WASHFlags where +-- +flags0 = FLAGS { generateBT = False } + +data FLAGS = FLAGS { generateBT :: Bool } + + diff --git a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHGenerator.hs b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHGenerator.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHGenerator.hs @@ -0,0 +1,57 @@ +module WASHGenerator (preprocess, preprocessPIPE) where { + +import Data.List; +import System.IO; + +import WASHData ; +import Parsec hiding (try) ; +import qualified WASHParser ; +import qualified WASHExpression ; +import qualified WASHClean ; +import WASHFlags ; + +-- import Trace; + +preprocess :: FLAGS -> String -> String -> String -> IO (); +preprocess flags srcName dstName globalDefs = + bracket (openFile srcName ReadMode) + (\ srcHandle -> hClose srcHandle) + (\ srcHandle -> + bracket (openFile dstName WriteMode) + (\ dstHandle -> hClose dstHandle) + (\ dstHandle -> + preprocessPIPE flags srcName srcHandle dstHandle globalDefs)); + + +preprocessPIPE :: FLAGS -> String -> Handle -> Handle -> String -> IO (); +preprocessPIPE flags srcName srcHandle dstHandle globalDefs = do { + input <- hGetContents srcHandle; + let { parsing = parse WASHParser.washfile srcName input }; + case parsing of { + Left error -> ioError $ userError $ show error; + Right washfile -> + hPutStrLn dstHandle (postprocess $ file flags globalDefs washfile ""); + }; +}; + +file :: FLAGS -> String -> [CodeFrag] -> ShowS ; +file flags globalDefs fcode = + WASHExpression.code flags (WASHClean.cleanCodeFragList fcode) . + showString globalDefs . + showString "\n" + ; + +imports :: [String] -> String ; +imports is = concat $ map (\m -> "import " ++ m ++ ";\n") is ; + +postprocess :: String -> String ; +postprocess = unlines . postprocess' . lines ; + +postprocess' :: [String] -> [String] ; +postprocess' [] = [] ; +postprocess' xs'@(x:xs) = + if "import" `isPrefixOf` x + then "import qualified CGI" : xs' + else x : postprocess' xs ; + +} diff --git a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHMain.hs b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHMain.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHMain.hs @@ -0,0 +1,36 @@ +module Main where + +-- ghc --make WASHMain -package text -o WASHMain + +import System.IO +import Data.List +import System +import WASHGenerator +import WASHFlags + +main = + do args <- getArgs + runPreprocessor flags0 args + +runPreprocessor flags [washfile] = + if ".wash" `isSuffixOf` washfile + then + preprocess flags washfile (take (length washfile - 5) washfile ++ ".hs") "" + else + preprocess flags + (washfile ++ ".wash") + (washfile ++ ".hs") + "" +runPreprocessor flags [washfile, hsfile] = + preprocess flags (washfile) (hsfile) "" +runPreprocessor flags [originalFile, washfile, hsfile] = + preprocess flags (washfile) (hsfile) "" +runPreprocessor flags [] = + preprocessPIPE flags "" stdin stdout "" +runPreprocessor flags args = + do progName <- getProgName + hPutStrLn stderr ("Usage: " ++ progName ++ " washfile [hsfile]") + hPutStrLn stderr (" or: " ++ progName ++ " originalFile infile outfile") + hPutStrLn stderr (" or: " ++ progName) + hPutStrLn stderr (" to run as pipe processor") + hPutStrLn stderr ("Actual arguments: " ++ show args) diff --git a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHOut.hs b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHOut.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHOut.hs @@ -0,0 +1,30 @@ +module WASHOut where + +-- output monad + +data Out a = Out a ShowS + +instance Monad Out where + return a = Out a id + m >>= f = case m of + Out x shw1 -> + case f x of + Out y shw2 -> + Out y (shw1 . shw2) + +runOut :: Out a -> ShowS +runOut (Out a shw) = shw + +wrapper = (Out () .) + +outString :: String -> Out () +outString = wrapper showString + +outChar :: Char -> Out () +outChar = wrapper showChar + +outs :: Show a => a -> Out () +outs = wrapper shows + +outShowS :: ShowS -> Out () +outShowS = Out () diff --git a/cabal/cabal/tests/systemTests/wash2hs/hs/WASHParser.hs b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHParser.hs new file mode 100644 --- /dev/null +++ b/cabal/cabal/tests/systemTests/wash2hs/hs/WASHParser.hs @@ -0,0 +1,541 @@ +module WASHParser ( xmlfile, washfile ) where { + +import Data.Char ; +import Parsec hiding (letter) ; +import WASHData; +import WASHUtil; + + +notImplemented = char '\xff' >> return undefined + "something that isn't implemented yet"; + +f <$> p = do { x <- p; return $ f x; }; + +testParser p s = + case parse (do { x <- p; eof; return x; }) "bla" s of { + Left x -> print x; + Right y -> print y; + }; + +washfile :: Parser [CodeFrag] ; +washfile = + do code <- hBody + eof + return $ code + ; + +setMode :: Bool -> Mode ; +setMode toplevel = if toplevel then S else F ; + +-- The numbers given for each parser identify the section and +-- grammar production within the XML 1.0 definition (W3C +-- REC-xml-19980210). + + +-- 2.1 / 1 +xmlfile :: Parser File; +xmlfile = do { + prolog; + code <- option [] (do { + hs <- haskell; + s0; + return hs + }); + elem <- element True; + many misc; + eof; + return $ File { fcode = code, topElem = elem }; +}; + + +-- 2.2 / 2 +char' = (char '\t' <|> char '\n' <|> char '\r' <|> + satisfy (>= ' ')) "character"; + + +-- 2.3 / 3 +s = (try $ many1 (char ' ' <|> char '\t' <|> + char '\r' <|> char '\n')) "whitespace"; +s0 = option "" s; +{- +s0 = (try $ many (char ' ' <|> char '\t' <|> + char '\r' <|> char '\n')) "optional whitespace"; +-} + +-- 2.3 / 4 +nameChar = letter <|> digit <|> char '.' <|> char '-' <|> + char '_' <|> char ':' <|> combiningChar <|> extender; + + +-- 2.3 / 5 +name :: Parser String; +name = do { + c <- letter <|> char '_' <|> char ':'; + cs <- many nameChar; + return $ c:cs; +} "name"; + + +-- 2.3 / 6 +names :: Parser [String]; +names = sepBy1 name s; + + +-- 2.3 / 7 +nmtoken :: Parser String; +nmtoken = many1 nameChar "nmtoken"; + + +-- 2.3 / 8 +nmtokens :: Parser [String]; +nmtokens = sepBy1 name s; + + +-- 2.3 / 10 +attValue :: Parser AttrValue; +attValue = (((AText . concat) <$> ( + between (char '\"') (char '\"') (many (p '\"')) + <|> between (char '\'') (char '\'') (many (p '\'')) )) + <|> ACode <$> haskellAttr) "attvalue" +where { + p end = (\x -> [x]) <$> satisfy (f end) <|> reference; + f end = \c -> c /= '<' && c /= '&' && c /= end; +}; + +-- 2.3 / 11 +systemLiteral = do{ + char '\''; + sl <- many (satisfy (\c -> c /= '\'')); + char '\''; + return sl; +} <|> do{ + char '\"'; + sl <- many (satisfy (\c -> c /= '\"')); + char '\"'; + return sl; +}; + +-- 2.3 / 12 +pubidLiteral = do { + char '\''; + sl <- many (pubidChar False); + char '\''; + return sl; +} <|> do{ + char '\"'; + sl <- many (pubidChar True); + char '\"'; + return sl; +}; + +-- 2.3 / 13 +pubidChar w = satisfy (\c -> c >= 'A' && c <= 'Z' + || c >= 'a' && c <= 'z' + || c >= '0' && c <= '9' + || c `elem` " \n\r-()+,./:=?;!*#@$_%" + || w && c == '\''); + +-- 2.4 / 14 +charData :: Bool -> Parser Text; +charData toplevel = + do { s <- many1 charData'; return $ Text (setMode toplevel) $ concat s; } + "#PCDATA"; + +charData' :: Parser String; +charData' = do { + c <- satisfy f; + return [c]; +} <|> do { + string "]]"; + c <- satisfy (\c -> f c && c /= '>'); + return $ ']':']':[c]; +} +where { + f c = c /= '<' && c /= '&' && c /= ']'; +}; + + +-- 2.5 / 15 +comment :: Parser String; +comment = do { + try $ string "