hackport 0.2.9 → 0.2.10
raw patch · 108 files changed
+14114/−12379 lines, 108 filesdep +xmldep ~Cabaldep ~basenew-component:exe:hackport-guess-ghc-version
Dependencies added: xml
Dependency ranges changed: Cabal, base
Files
- Cabal2Ebuild.hs +3/−10
- Error.hs +2/−1
- Main-GuessGHC.hs +27/−0
- Main.hs +12/−14
- MaybeRead.hs +0/−14
- Merge.hs +29/−32
- Merge/Dependencies.hs +45/−13
- P2.hs +0/−104
- Portage/Dependency.hs +3/−1
- Portage/EBuild.hs +16/−21
- Portage/GHCCore.hs +305/−0
- Portage/Host.hs +45/−52
- Portage/Metadata.hs +31/−0
- Portage/Overlay.hs +41/−29
- Portage/PackageId.hs +12/−3
- Status.hs +41/−28
- cabal-install-0.8.2/Distribution/Client/BuildReports/Anonymous.hs +0/−311
- cabal-install-0.8.2/Distribution/Client/BuildReports/Storage.hs +0/−129
- cabal-install-0.8.2/Distribution/Client/BuildReports/Types.hs +0/−44
- cabal-install-0.8.2/Distribution/Client/BuildReports/Upload.hs +0/−71
- cabal-install-0.8.2/Distribution/Client/Check.hs +0/−85
- cabal-install-0.8.2/Distribution/Client/Config.hs +0/−565
- cabal-install-0.8.2/Distribution/Client/Configure.hs +0/−205
- cabal-install-0.8.2/Distribution/Client/Dependency.hs +0/−233
- cabal-install-0.8.2/Distribution/Client/Dependency/Bogus.hs +0/−129
- cabal-install-0.8.2/Distribution/Client/Dependency/TopDown.hs +0/−776
- cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Constraints.hs +0/−316
- cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Types.hs +0/−93
- cabal-install-0.8.2/Distribution/Client/Dependency/Types.hs +0/−114
- cabal-install-0.8.2/Distribution/Client/Fetch.hs +0/−192
- cabal-install-0.8.2/Distribution/Client/Haddock.hs +0/−101
- cabal-install-0.8.2/Distribution/Client/HttpUtils.hs +0/−197
- cabal-install-0.8.2/Distribution/Client/IndexUtils.hs +0/−301
- cabal-install-0.8.2/Distribution/Client/Init.hs +0/−556
- cabal-install-0.8.2/Distribution/Client/Init/Heuristics.hs +0/−187
- cabal-install-0.8.2/Distribution/Client/Init/Licenses.hs +0/−1722
- cabal-install-0.8.2/Distribution/Client/Init/Types.hs +0/−152
- cabal-install-0.8.2/Distribution/Client/Install.hs +0/−786
- cabal-install-0.8.2/Distribution/Client/InstallPlan.hs +0/−495
- cabal-install-0.8.2/Distribution/Client/InstallSymlink.hs +0/−238
- cabal-install-0.8.2/Distribution/Client/List.hs +0/−368
- cabal-install-0.8.2/Distribution/Client/PackageIndex.hs +0/−479
- cabal-install-0.8.2/Distribution/Client/PackageUtils.hs +0/−34
- cabal-install-0.8.2/Distribution/Client/Setup.hs +0/−876
- cabal-install-0.8.2/Distribution/Client/SetupWrapper.hs +0/−321
- cabal-install-0.8.2/Distribution/Client/SrcDist.hs +0/−80
- cabal-install-0.8.2/Distribution/Client/Tar.hs +0/−870
- cabal-install-0.8.2/Distribution/Client/Types.hs +0/−148
- cabal-install-0.8.2/Distribution/Client/Unpack.hs +0/−116
- cabal-install-0.8.2/Distribution/Client/Update.hs +0/−82
- cabal-install-0.8.2/Distribution/Client/Upload.hs +0/−177
- cabal-install-0.8.2/Distribution/Client/Utils.hs +0/−60
- cabal-install-0.8.2/Distribution/Client/Win32SelfUpgrade.hs +0/−222
- cabal-install-0.8.2/Distribution/Compat/Exception.hs +0/−56
- cabal-install-0.8.2/LICENSE +0/−34
- cabal-install-0.8.2/Paths_cabal_install.hs +0/−8
- cabal-install-0.8.2/cabal-install.cabal +0/−122
- cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Anonymous.hs +311/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Storage.hs +129/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Types.hs +44/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Upload.hs +71/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Check.hs +85/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Config.hs +519/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Configure.hs +205/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency.hs +318/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown.hs +776/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Constraints.hs +316/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Types.hs +93/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/Types.hs +114/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Fetch.hs +259/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/GZipUtils.hs +44/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Haddock.hs +105/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/HttpUtils.hs +197/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/IndexUtils.hs +299/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Init.hs +556/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Heuristics.hs +191/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Licenses.hs +1722/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Types.hs +152/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Install.hs +940/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/InstallPlan.hs +495/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/InstallSymlink.hs +238/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/List.hs +368/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/PackageIndex.hs +479/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/PackageUtils.hs +34/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Setup.hs +952/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/SetupWrapper.hs +320/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/SrcDist.hs +80/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Tar.hs +871/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Types.hs +211/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Unpack.hs +138/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Update.hs +82/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Upload.hs +177/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Utils.hs +60/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/Win32SelfUpgrade.hs +222/−0
- cabal-install-0.9.5_rc20101226/Distribution/Client/World.hs +132/−0
- cabal-install-0.9.5_rc20101226/Distribution/Compat/Exception.hs +56/−0
- cabal-install-0.9.5_rc20101226/LICENSE +34/−0
- cabal-install-0.9.5_rc20101226/Main.hs +388/−0
- cabal-install-0.9.5_rc20101226/Paths_cabal_install.hs +8/−0
- cabal-install-0.9.5_rc20101226/README +153/−0
- cabal-install-0.9.5_rc20101226/Setup.hs +2/−0
- cabal-install-0.9.5_rc20101226/bash-completion/cabal +24/−0
- cabal-install-0.9.5_rc20101226/bootstrap.sh +241/−0
- cabal-install-0.9.5_rc20101226/cabal-install.cabal +117/−0
- cabal-install-0.9.5_rc20101226/changelog +100/−0
- cabal-install-0.9.5_rc20101226/tests/test-cabal-install +9/−0
- cabal-install-0.9.5_rc20101226/tests/test-cabal-install-user +8/−0
- hackport.cabal +57/−6
Cabal2Ebuild.hs view
@@ -24,8 +24,7 @@ module Cabal2Ebuild (cabal2ebuild ,convertDependencies- ,convertDependency- ,default_ghc_dependency) where+ ,convertDependency) where import qualified Distribution.PackageDescription as Cabal (PackageDescription(..))@@ -43,9 +42,6 @@ import qualified Portage.EBuild as E import Portage.Version -default_ghc_dependency :: Dependency-default_ghc_dependency = OrLaterVersionOf (Version [6,8,1] Nothing [] 0) (Portage.mkPackageName "dev-lang" "ghc")- cabal2ebuild :: Cabal.PackageDescription -> Portage.EBuild cabal2ebuild pkg = Portage.ebuildTemplate { E.name = map toLower cabalPkgName,@@ -53,7 +49,6 @@ E.description = if null (Cabal.synopsis pkg) then Cabal.description pkg else Cabal.synopsis pkg, E.homepage = thisHomepage,- E.src_uri = thisSRC_URI, E.license = Cabal.license pkg, E.my_pn = if any isUpper cabalPkgName then Just cabalPkgName else Nothing, E.features = E.features E.ebuildTemplate@@ -67,9 +62,6 @@ thisHomepage = if (null $ Cabal.homepage pkg) then E.homepage E.ebuildTemplate else Cabal.homepage pkg- thisSRC_URI = if (null $ Cabal.pkgUrl pkg)- then E.src_uri E.ebuildTemplate- else Cabal.pkgUrl pkg convertDependencies :: Portage.Category -> [Cabal.Dependency] -> [Dependency] convertDependencies category = concatMap (convertDependency category)@@ -93,7 +85,8 @@ )(\v -> [OrEarlierVersionOf (fromCabalVersion v) pn] -- ^ @\"<= v\"@ )(\v _ -> [ThisMajorOf (fromCabalVersion v) pn] -- ^ @\"== v.*\"@ wildcard. (incl lower, excl upper) )(\g1 g2 -> [DependEither (flatten g1 ++ flatten g2) ] -- ^ @\"_ || _\"@ union- )(\r1 r2 -> r1 ++ r2+ )(\r1 r2 -> r1 ++ r2 -- ^ @\"_ && _\"@ intersection+ )(\dp -> [AllOf dp ] -- ^ @\"(_)\"@ parentheses ) where flatten :: [Dependency] -> [[Dependency]]
Error.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE DeriveDataTypeable #-}+ module Error (HackPortError(..), throwEx, catchEx, hackPortShowError) where import Data.Typeable
+ Main-GuessGHC.hs view
@@ -0,0 +1,27 @@+module Main where++import System.Environment++import Distribution.PackageDescription+import Distribution.PackageDescription.Parse++import Distribution.Text+import Distribution.Verbosity++import Portage.GHCCore++main :: IO ()+main = do+ args <- getArgs+ gpds <- mapM (readPackageDescription silent) args+ mapM_ guess gpds++guess :: GenericPackageDescription -> IO ()+guess gpd = do+ let pkg = package . packageDescription $ gpd+ let mghc = minimumGHCVersionToBuildPackage gpd+ putStr (display pkg)+ putStr "\t\t"+ putStrLn $ case mghc of+ Nothing -> "Unknown"+ Just (compiler, _pkgs) -> display compiler
Main.hs view
@@ -14,15 +14,13 @@ , flagToList , optionVerbosity )-import Distribution.PackageDescription.Configuration- ( flattenPackageDescription ) import Distribution.ReadE ( succeedReadE ) import Distribution.Simple.Command -- commandsRun import Distribution.Simple.Utils ( die, cabalVersion, warn ) import qualified Distribution.PackageDescription.Parse as Cabal import qualified Distribution.Package as Cabal import Distribution.Verbosity (Verbosity, normal)-import Distribution.Text (display)+import Distribution.Text (display, simpleParse) import Distribution.Client.Types import Distribution.Client.Update@@ -40,9 +38,6 @@ import System.Exit ( exitFailure ) import System.FilePath ( (</>) ) -import qualified Cabal2Ebuild as C2E-import qualified Portage.EBuild as E- import Diff import Error import Status@@ -145,15 +140,18 @@ } makeEbuildAction :: MakeEbuildFlags -> [String] -> GlobalFlags -> IO ()-makeEbuildAction flags args _globalFlags = do- when (null args) $- die "make-ebuild needs at least one argument"- let _verbosity = fromFlag (makeEbuildVerbosity flags)- forM_ args $ \cabalFileName -> do+makeEbuildAction flags args globalFlags = do+ (catstr,cabals) <- case args of+ (category:cabal1:cabaln) -> return (category, cabal1:cabaln)+ _ -> throwEx (ArgumentError "make-ebuild needs at least two arguments. <category> <cabal-1> <cabal-n>")+ cat <- case simpleParse catstr of+ Just c -> return c+ Nothing -> throwEx (ArgumentError ("could not parse category: " ++ catstr))+ let verbosity = fromFlag (makeEbuildVerbosity flags)+ overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)+ forM_ cabals $ \cabalFileName -> do pkg <- Cabal.readPackageDescription normal cabalFileName- let ebuild = C2E.cabal2ebuild (flattenPackageDescription pkg)- let ebuildFileName = E.name ebuild ++ "-" ++ E.version ebuild ++ ".ebuild"- writeFile ebuildFileName (display ebuild)+ mergeGenericPackageDescription verbosity overlayPath cat pkg False makeEbuildCommand :: CommandUI MakeEbuildFlags makeEbuildCommand = CommandUI {
− MaybeRead.hs
@@ -1,14 +0,0 @@-module MaybeRead where--import Data.List(find)-import Text.Read-import Text.ParserCombinators.ReadP--readMaybe :: Read a => String -> Maybe a-readMaybe = readsMaybe reads--readsMaybe :: ReadS a -> String -> Maybe a-readsMaybe func str = maybe Nothing (\x->Just (fst x)) (find (null.snd) (func str))--readPMaybe :: ReadP a -> String -> Maybe a-readPMaybe = readsMaybe.readP_to_S
Merge.hs view
@@ -1,15 +1,18 @@ {-# OPTIONS -XPatternGuards #-} module Merge- ( merge ) where+ ( merge+ , mergeGenericPackageDescription+ ) where import Control.Monad.Error import Control.Exception import Data.Maybe import Data.List import Distribution.Package-import Distribution.Compiler (CompilerId(..), CompilerFlavor(GHC))+-- import Distribution.Compiler (CompilerId(..), CompilerFlavor(GHC)) import Distribution.PackageDescription ( PackageDescription(..) , FlagName(..)+ , GenericPackageDescription ) import Distribution.PackageDescription.Configuration ( finalizePackageDescription )@@ -46,6 +49,8 @@ import qualified Portage.Overlay as Overlay import qualified Portage.Resolve as Portage +import qualified Portage.GHCCore as GHCCore+ import qualified Merge.Dependencies as Merge import Debug.Trace ( trace )@@ -141,12 +146,13 @@ info verbosity $ match_text ++ (display . packageInfoId $ avail) let cabal_pkgId = packageInfoId selectedPkg- norm_pkgId = Portage.normalizeCabalPackageId cabal_pkgId- norm_pkgName = packageName norm_pkgId+ norm_pkgName = packageName (Portage.normalizeCabalPackageId cabal_pkgId) cat <- maybe (Portage.resolveCategory verbosity overlay norm_pkgName) return m_category+ mergeGenericPackageDescription verbosity overlayPath cat (packageDescription selectedPkg) True - let pkgGenericDesc = packageDescription selectedPkg- Right (pkgDesc0, flags) =+mergeGenericPackageDescription :: Verbosity -> FilePath -> Portage.Category -> GenericPackageDescription -> Bool -> IO ()+mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch = do+ let Right (pkgDesc0, flags) = finalizePackageDescription [ -- XXX: common things we should enable/disable? -- (FlagName "small_base", True) -- try to use small base@@ -155,29 +161,37 @@ (\dep -> trace ("accepting dep(?): " ++ display dep) True) -- (Nothing :: Maybe (Index.PackageIndex PackageIdentifier)) buildPlatform- (CompilerId GHC (Cabal.Version [6,10,4] []))+ (fst GHCCore.defaultGHC) [] pkgGenericDesc++ mminimumGHC = GHCCore.minimumGHCVersionToBuildPackage pkgGenericDesc+ (compilerId, excludePkgs) = maybe GHCCore.defaultGHC id mminimumGHC+ pkgDesc = let deps = [ Dependency pn (Cabal.simplifyVersionRange vr) | Dependency pn vr <- buildDepends pkgDesc0+ , pn `notElem` excludePkgs ] in pkgDesc0 { buildDepends = deps }- edeps = Merge.resolveDependencies pkgDesc+ edeps = Merge.resolveDependencies pkgDesc (Just compilerId) debug verbosity ("Selected flags: " ++ show flags)+ info verbosity ("Guessing GHC version: " ++ maybe "could not guess" (display.fst) mminimumGHC) - let ebuild = fixSrc serverURI (packageId pkgDesc)- . (\e -> e { E.depend = Merge.dep edeps } )+ let ebuild = (\e -> e { E.depend = Merge.dep edeps } ) . (\e -> e { E.depend_extra = Merge.dep_e edeps } ) . (\e -> e { E.rdepend = Merge.rdep edeps } ) . (\e -> e { E.rdepend_extra = Merge.rdep_e edeps } ) $ C2E.cabal2ebuild pkgDesc mergeEbuild verbosity overlayPath (Portage.unCategory cat) ebuild- fetchAndDigest- verbosity- (overlayPath </> display cat </> display norm_pkgName)- (display cabal_pkgId <.> "tar.gz")- (mkUri cabal_pkgId)+ when fetch $ do+ let cabal_pkgId = packageId pkgDesc+ norm_pkgName = packageName (Portage.normalizeCabalPackageId cabal_pkgId)+ fetchAndDigest+ verbosity+ (overlayPath </> display cat </> display norm_pkgName)+ (display cabal_pkgId <.> "tar.gz")+ (mkUri cabal_pkgId) mkUri :: Cabal.PackageIdentifier -> URI mkUri pid =@@ -224,20 +238,3 @@ createDirectoryIfMissing True edir info verbosity $ "Writing " ++ elocal writeFile epath (display ebuild)--fixSrc :: URI -> PackageIdentifier -> E.EBuild -> E.EBuild-fixSrc serverURI p ebuild =- ebuild {- E.src_uri = show $ serverURI {- uriPath =- uriPath serverURI- </> display (pkgName p) - </> display (pkgVersion p) - </> display (pkgName p) ++ "-" ++ display (pkgVersion p) - <.> "tar.gz"- },- E.homepage = case E.homepage ebuild of- "" -> "http://hackage.haskell.org/package/"- ++ display (pkgName p)- x -> x- }
Merge/Dependencies.hs view
@@ -53,16 +53,23 @@ , extraLibs , buildTools , pkgconfigDepends- , hasLibs )+ , hasLibs+ , specVersion+ ) import Data.Maybe ( isNothing ) import Data.List ( nub ) import qualified Distribution.Package as Cabal+import qualified Distribution.Version as Cabal+import Distribution.Compiler +import qualified Portage.Version as Portage import qualified Portage.PackageId as Portage import qualified Portage.Dependency as Portage import qualified Cabal2Ebuild as C2E +import qualified Portage.GHCCore as GHCCore+ import Debug.Trace ( trace ) -- | Dependencies of an ebuild@@ -83,8 +90,8 @@ dep_e = [] } -resolveDependencies :: PackageDescription -> EDep-resolveDependencies pkg =+resolveDependencies :: PackageDescription -> Maybe CompilerId -> EDep+resolveDependencies pkg mcompiler = edeps { dep = Portage.simplify_deps ( dep edeps),@@ -93,11 +100,13 @@ -- version as in dep } where+ compiler = maybe (fst GHCCore.defaultGHC) id mcompiler+ hasBuildableExes p = any (buildable . buildInfo) . executables $ p treatAsLibrary = (not . hasBuildableExes) pkg || hasLibs pkg haskell_deps = haskellDependencies pkg- cabal_dep = cabalDependency pkg- ghc_dep = ghcDependency pkg+ cabal_dep = cabalDependency pkg compiler+ ghc_dep = compilerIdToDependency compiler extra_libs = findCLibs pkg build_tools = buildToolsDependencies pkg pkg_config = pkgConfigDependencies pkg@@ -122,6 +131,7 @@ rdep = extra_libs ++ pkg_config } + --------------------------------------------------------------- -- Haskell packages ---------------------------------------------------------------@@ -135,19 +145,34 @@ -- Cabal Dependency --------------------------------------------------------------- -cabalDependency :: PackageDescription -> Portage.Dependency-cabalDependency pkg =+-- | Select the most restrictive dependency on Cabal, either the .cabal+-- file's descCabalVersion, or the Cabal GHC shipped with.+cabalDependency :: PackageDescription -> CompilerId -> Portage.Dependency+cabalDependency pkg (CompilerId GHC ghcVersion@(Cabal.Version versionNumbers _)) = head $ C2E.convertDependency (Portage.Category "dev-haskell") (Cabal.Dependency (Cabal.PackageName "Cabal")- (descCabalVersion pkg))+ finalCabalDep)+ where+ userCabalVersion = Cabal.orLaterVersion (specVersion pkg)+ shippedCabalVersion = GHCCore.cabalFromGHC versionNumbers+ shippedCabalDep = maybe Cabal.anyVersion+ (\shipped -> Cabal.intersectVersionRanges+ (Cabal.thisVersion shipped)+ (Cabal.laterVersion shipped))+ shippedCabalVersion+ finalCabalDep = Cabal.simplifyVersionRange+ (Cabal.intersectVersionRanges+ userCabalVersion+ shippedCabalDep) --------------------------------------------------------------- -- GHC Dependency --------------------------------------------------------------- -ghcDependency :: PackageDescription -> Portage.Dependency-ghcDependency _pkg = C2E.default_ghc_dependency- +compilerIdToDependency :: CompilerId -> Portage.Dependency+compilerIdToDependency (CompilerId GHC versionNumbers) =+ Portage.OrLaterVersionOf (Portage.fromCabalVersion versionNumbers) (Portage.mkPackageName "dev-lang" "ghc")+ --------------------------------------------------------------- -- C Libraries ---------------------------------------------------------------@@ -166,7 +191,6 @@ notFound = [ p | p <- allE, isNothing (staticTranslateExtraLib p) ] found = [ p | Just p <- map staticTranslateExtraLib allE ]- staticTranslateExtraLib :: String -> Maybe Portage.Dependency staticTranslateExtraLib lib = lookup lib m@@ -177,6 +201,7 @@ , ("pq", Portage.LaterVersionOf (Portage.Version [7] Nothing [] 0) (Portage.mkPackageName "virtual" "postgresql-base")) , ("ev", Portage.AnyVersionOf (Portage.mkPackageName "dev-libs" "libev")) , ("expat", Portage.AnyVersionOf (Portage.mkPackageName "dev-libs" "expat"))+ , ("curl", Portage.AnyVersionOf (Portage.mkPackageName "net-misc" "curl")) ] ---------------------------------------------------------------@@ -234,14 +259,20 @@ table :: [(String, (String, String))] table = [("gconf-2.0", ("gnome-base", "gconf"))+ ,("gthread-2.0", ("dev-libs", "glib")) -- should be slot 2+ ,("gio-2.0", ("dev-libs", "glib"))+ ,("glib-2.0", ("dev-libs", "glib"))+ ,("gobject-2.0", ("dev-libs", "glib"))+ ,("gtk+-2.0", ("x11-libs", "gtk+")) -- should be slot 2+ ,("cairo", ("x11-libs", "cairo")) ,("cairo-ps", ("x11-libs", "cairo")) ,("cairo-pdf", ("x11-libs", "cairo")) ,("cairo-svg", ("x11-libs", "cairo")) -- need [svg] for dev-haskell/cairo+ ,("pangocairo", ("x11-libs", "cairo")) ,("pango", ("x11-libs", "pango"))- ,("gio-2.0", ("dev-libs", "glib")) ,("libglade-2.0", ("gnome-base", "libglade")) ,("gnome-vfs-2.0", ("gnome-base", "gnome-vfs")) ,("gnome-vfs-module-2.0", ("gnome-base", "gnome-vfs"))@@ -257,4 +288,5 @@ ,("librsvg-2.0", ("gnome-base","librsvg")) ,("vte", ("x11-libs","vte")) ,("gtkglext-1.0", ("x11-libs","gtkglext"))+ ,("curl", ("net-misc", "curl")) ]
− P2.hs
@@ -1,104 +0,0 @@-module P2 where---- Module that respect categories.--- Possibly to replace Portage.hs when the rest of the project has been--- ported to this style.--import BlingBling--import Control.Arrow-import Control.Monad--import qualified Distribution.PackageDescription as Cabal--import Data.Map (Map)-import qualified Data.Map as Map-import qualified Data.List as List--import System.Directory-import System.FilePath--import Text.Regex--import qualified Portage.Version as Portage--import Distribution.Text--type Portage = PortageMap [Ebuild]-type PortageMap a = Map Package a--data Ebuild = Ebuild {- ePackage :: Package,- eVersion :: Portage.Version,- eFilePath :: FilePath,- ePkgDesc :: Maybe Cabal.GenericPackageDescription }- deriving (Show)--data Package = P { pCategory :: String, pPackage :: String }- deriving (Eq, Ord)--instance Show Package where- show (P c p) = c ++ '/':p--instance Eq Ebuild where- e1 == e2 = (ePackage e1, eVersion e1) == (ePackage e2, eVersion e2)--instance Ord Ebuild where- compare e1 e2 = compare (ePackage e1, eVersion e1)- (ePackage e2, eVersion e2)--lookupEbuildWith :: Portage -> Package -> (Ebuild -> Bool) -> Maybe Ebuild-lookupEbuildWith portage package comp = do- es <- Map.lookup package portage- List.find comp es--getPackageList :: FilePath -> IO [Package]-getPackageList portdir = do- categories <- getDirectories portdir- packages <- fmap concat $ forMbling categories $ \c -> do- pkg <- getDirectories (portdir </> c)- return (map (P c) pkg)- return packages--readPortagePackages :: FilePath -> [Package] -> IO Portage-readPortagePackages portdir packages0 = do- packages <- filterM (doesDirectoryExist . (portdir </>) . show) packages0- ebuild_map0 <- forM packages $ \package -> do- ebuilds <- getPackageVersions package- return (package, List.sort ebuilds)- let ebuild_map = filter (not . null . snd) ebuild_map0- return $ Map.fromList ebuild_map-- where- getPackageVersions :: Package -> IO [Ebuild]- getPackageVersions (P category package) = do- files <- getDirectoryContents (portdir </> category </> package)- let ebuilds = [ (v, portdir </> category </> package </> fn)- | (Just v, fn) <- map ((filterVersion package) &&& id) files ]- return (map (uncurry (\v f -> Ebuild (P category package) v f Nothing)) ebuilds)-- filterVersion :: String -> String -> Maybe Portage.Version- filterVersion p fn = do- [vstring] <- matchRegex (ebuildVersionRegex p) fn- simpleParse vstring-- ebuildVersionRegex name = mkRegex ("^"++name++"-(.*)\\.ebuild$")--readPortageTree :: FilePath -> IO Portage-readPortageTree portdir = do- packages <- getPackageList portdir- readPortagePackages portdir packages--getDirectories :: FilePath -> IO [String]-getDirectories fp = do- files <- fmap (filter (`notElem` [".", ".."])) $ getDirectoryContents fp- filterM (doesDirectoryExist . (fp </>)) files--printPortage :: Portage -> IO ()-printPortage port =- forM_ (Map.toAscList port) $ \(package, ebuilds) -> do- let (P c p) = package- putStr $ c ++ '/':p- putStr " "- forM_ ebuilds (\e -> putStr (show $ eVersion e) >> putChar ' ')- putStrLn ""
Portage/Dependency.hs view
@@ -9,7 +9,7 @@ import Portage.PackageId import qualified Text.PrettyPrint as Disp-import Text.PrettyPrint ( (<>) )+import Text.PrettyPrint ( (<>), hsep ) import Data.Maybe ( fromJust, catMaybes ) import Data.List ( nub, groupBy, partition, sortBy )@@ -26,6 +26,7 @@ | DependEither [[Dependency]] -- || ( depend_group1 ..depend_groupN ) | DependIfUse UseFlag Dependency -- use? ( depend ) | ThisMajorOf Version PackageName -- =package-version*+ | AllOf [Dependency] -- ( package-version* ) deriving (Eq,Show) instance Text Dependency where@@ -50,6 +51,7 @@ showDepend (DependIfUse useflag dep) = Disp.text useflag <> Disp.text "? " <> Disp.parens (disp dep) showDepend (ThisMajorOf v p) = Disp.char '=' <> disp p <-> disp v <> Disp.char '*'+showDepend (AllOf dp ) = Disp.text "( " <> hsep (map showDepend dp) <> Disp.text " )" {- Here goes code for dependencies simplification -}
Portage/EBuild.hs view
@@ -1,6 +1,7 @@ module Portage.EBuild ( EBuild(..) , ebuildTemplate+ , src_uri ) where import Distribution.Text ( Text(..), display )@@ -19,7 +20,6 @@ hackportVersion :: String, description :: String, homepage :: String,- src_uri :: String, license :: Cabal.License, slot :: String, keywords :: [String],@@ -29,7 +29,7 @@ rdepend :: [Dependency], rdepend_extra :: [String], features :: [String],- my_pn :: Maybe String --If the package's name contains upper-case+ my_pn :: Maybe String -- ^ Just 'myOldName' if the package name contains upper characters } getHackportVersion :: Version -> String@@ -43,7 +43,6 @@ hackportVersion = getHackportVersion Paths_hackport.version, description = "", homepage = "http://hackage.haskell.org/package/${PN}",- src_uri = "http://hackage.haskell.org/packages/archive/${PN}/${PV}/${P}.tar.gz", license = Cabal.UnknownLicense "xxx UNKNOWN xxx", slot = "0", keywords = ["~amd64","~x86"],@@ -59,6 +58,18 @@ instance Text EBuild where disp = Disp.text . showEBuild +-- | Given an EBuild, give the URI to the tarball of the source code.+-- Assumes that the server is always hackage.haskell.org.+src_uri :: EBuild -> String+src_uri e = + case my_pn e of+ -- use standard address given that the package name has no upper+ -- characters+ Nothing -> "http://hackage.haskell.org/packages/archive/${PN}/${PV}/${P}.tar.gz"+ -- use MY_X variables (defined in showEBuild) as we've renamed the+ -- package+ Just _ -> "http://hackage.haskell.org/packages/archive/${MY_PN}/${PV}/${MY_P}.tar.gz"+ showEBuild :: EBuild -> String showEBuild ebuild = ss "# Copyright 1999-2010 Gentoo Foundation". nl.@@ -76,7 +87,7 @@ ss "MY_P=". quote "${MY_PN}-${PV}". nl. nl). ss "DESCRIPTION=". quote (description ebuild). nl. ss "HOMEPAGE=". quote (expandVars (homepage ebuild)). nl.- ss "SRC_URI=". quote (replaceVars (src_uri ebuild)). nl.+ ss "SRC_URI=". quote (src_uri ebuild). nl. nl. ss "LICENSE=". quote (convertLicense . license $ ebuild). (if null (licenseComment . license $ ebuild) then id@@ -91,8 +102,7 @@ Nothing -> id Just _ -> nl. ss "S=". quote ("${WORKDIR}/${MY_P}"). nl) $ []- where replaceVars = replaceCommonVars (name ebuild) (my_pn ebuild) (version ebuild)- expandVars = replaceMultiVars [(name ebuild, "${PN}")]+ where expandVars = replaceMultiVars [(name ebuild, "${PN}")] ss :: String -> String -> String ss = showString@@ -147,21 +157,6 @@ replaceMultiVars whole@((pname,cont):rest) str = case subStr cont str of Nothing -> replaceMultiVars rest str Just (pre,post) -> (replaceMultiVars rest pre)++pname++(replaceMultiVars whole post)--replaceCommonVars ::- String -> -- ^ PN- Maybe String -> -- ^ MYPN- String -> -- ^ PV- String -> -- ^ the string to be replaced- String-replaceCommonVars pn mypn pv str- = replaceMultiVars- ([("${P}",pn++"-"++pv)]- ++ maybe [] (\x->[("${MY_P}",x++"-"++pv)]) mypn- ++[("${PN}",pn)]- ++ maybe [] (\x->[("${MY_PN}",x)]) mypn- ++[("${PV}",pv)]) str- -- map the cabal license type to the gentoo license string format convertLicense :: Cabal.License -> String
+ Portage/GHCCore.hs view
@@ -0,0 +1,305 @@++-- Guess GHC version from packages depended upon.+module Portage.GHCCore+ ( minimumGHCVersionToBuildPackage+ , cabalFromGHC+ , defaultGHC+ ) where++import Distribution.Package+import Distribution.Version+import Distribution.Simple.PackageIndex+import Distribution.InstalledPackageInfo++import Distribution.PackageDescription+import Distribution.PackageDescription.Configuration+import Distribution.Compiler (CompilerId(..), CompilerFlavor(GHC))+import Distribution.System++import Distribution.Text++import Data.Maybe+import Data.List ( nub )++import Text.PrettyPrint.HughesPJ++defaultGHC :: (CompilerId, [PackageName])+defaultGHC = let (g,pix) = ghc6123 in (g, packageNamesFromPackageIndex pix)++ghcs :: [(CompilerId, PackageIndex)]+ghcs = [ghc682, ghc6101, ghc6104, ghc6121, ghc6122, ghc6123, ghc701]++cabalFromGHC :: [Int] -> Maybe Version+cabalFromGHC ver = lookup ver table+ where+ table = [([6,6,0], Version [1,1,6] [])+ ,([6,6,1], Version [1,1,6,2] [])+ ,([6,8,1], Version [1,2,2,0] [])+ ,([6,8,2], Version [1,2,3,0] [])+ ,([6,8,3], Version [1,2,4,0] [])+ ,([6,10,1], Version [1,6,0,1] [])+ ,([6,10,2], Version [1,6,0,3] [])+ ,([6,10,3], Version [1,6,0,3] [])+ ,([6,10,4], Version [1,6,0,3] [])+ ,([6,12,1], Version [1,8,0,2] [])+ ,([6,12,2], Version [1,8,0,4] [])+ ,([6,12,3], Version [1,8,0,6] [])+ ,([7,0,1], Version [1,10,0,0] [])+ ]++platform :: Platform+platform = Platform X86_64 Linux++packageIsCore :: PackageIndex -> PackageName -> Bool+packageIsCore index pn = not . null $ lookupPackageName index pn++packageIsCoreInAnyGHC :: PackageName -> Bool+packageIsCoreInAnyGHC pn = any (flip packageIsCore pn) (map snd ghcs)++-- | Check if a dependency is satisfiable given a 'PackageIndex'+-- representing the core packages in a GHC version.+-- Packages that are not core will always be accepted, packages that are+-- core in any ghc must be satisfied by the 'PackageIndex'.+dependencySatisfiable :: PackageIndex -> Dependency -> Bool+dependencySatisfiable pi dep@(Dependency pn rang)+ | pn == PackageName "Win32" = False -- only exists on windows, not in linux+ | not . null $ lookupDependency pi dep = True -- the package index satisfies the dep+ | packageIsCoreInAnyGHC pn = False -- some other ghcs support the dependency+ | otherwise = True -- the dep is not related with core packages, accept the dep++packageBuildableWithGHCVersion+ :: GenericPackageDescription+ -> (CompilerId, PackageIndex)+ -> Either [Dependency] (PackageDescription, FlagAssignment)+packageBuildableWithGHCVersion pkg (compiler, pkgIndex) =+ finalizePackageDescription [] (dependencySatisfiable pkgIndex) platform compiler [] pkg++-- | Given a 'GenericPackageDescription' it returns the miminum GHC version+-- to build a package, and a list of core packages to that GHC version.+minimumGHCVersionToBuildPackage :: GenericPackageDescription -> Maybe (CompilerId, [PackageName])+minimumGHCVersionToBuildPackage gpd =+ listToMaybe [ (cid, packageNamesFromPackageIndex pix)+ | g@(cid, pix) <- ghcs+ , Right _ <- return (packageBuildableWithGHCVersion gpd g)]++mkIndex :: [PackageIdentifier] -> PackageIndex+mkIndex pids = fromList+ [ emptyInstalledPackageInfo+ { installedPackageId = InstalledPackageId $ display name ++ "-" ++ display version+ , sourcePackageId = pi+ , exposed = True+ }+ | pi@(PackageIdentifier name version) <- pids ]++packageNamesFromPackageIndex :: PackageIndex -> [PackageName]+packageNamesFromPackageIndex pix = nub $+ [ (pkgName . sourcePackageId) p | (p:_) <- allPackagesByName pix ]++ghc :: [Int] -> CompilerId+ghc nrs = CompilerId GHC (Version nrs [])++-- | Core packages in GHC 7.0.1 as a 'PackageIndex'.+ghc701 :: (CompilerId, PackageIndex)+ghc701 = (ghc [7,0,1], mkIndex ghc701_pkgs)++ghc6123 :: (CompilerId, PackageIndex)+ghc6123 = (ghc [6,12,3], mkIndex ghc6123_pkgs)++ghc6122 :: (CompilerId, PackageIndex)+ghc6122 = (ghc [6,12,2], mkIndex ghc6122_pkgs)++ghc6121 :: (CompilerId, PackageIndex)+ghc6121 = (ghc [6,12,1], mkIndex ghc6121_pkgs)++ghc6104 :: (CompilerId, PackageIndex)+ghc6104 = (ghc [6,10,4], mkIndex ghc6104_pkgs)++ghc6101 :: (CompilerId, PackageIndex)+ghc6101 = (ghc [6,10,1], mkIndex ghc6101_pkgs)++ghc682 :: (CompilerId, PackageIndex)+ghc682 = (ghc [6,8,2], mkIndex ghc682_pkgs)++-- | Non-upgradeable core packages+-- Source: http://haskell.org/haskellwiki/Libraries_released_with_GHC+ghc701_pkgs :: [PackageIdentifier]+ghc701_pkgs = + [ p "array" [0,3,0,2]+ , p "base" [4,3,0,0]+ , p "bytestring" [0,9,1,8]+-- , p "Cabal" [1,10,0,0] package is upgradeable+ , p "containers" [0,4,0,0]+ , p "directory" [1,1,0,0]+ , p "extensible-exceptions" [0,1,1,2]+ , p "filepath" [1,2,0,0]+ , p "haskell2010" [1,0,0,0]+ , p "haskell98" [1,1,0,0]+ , p "hpc" [0,5,0,6]+ , p "integer-gmp" [0,2,0,2]+ , p "integer-simple" [0,1,0,0]+ , p "old-locale" [1,0,0,2]+ , p "old-time" [1,0,0,6]+ , p "pretty" [1,0,1,2]+ , p "process" [1,0,1,4]+ , p "random" [1,0,0,3]+ , p "syb" [0,2,2] -- not distributed with ghc-7, but ghc-7 PDEPENDs on it+ , p "template-haskell" [2,5,0,0]+-- , p "time" [1,2,0,3] package is upgradeable+ , p "unix" [2,4,1,0]+-- , p "utf8-string" [0,3,4] package is upgradeable+ ]++ghc6123_pkgs :: [PackageIdentifier]+ghc6123_pkgs = + [ p "array" [0,3,0,1]+ , p "base" [3,0,3,2]+ , p "base" [4,2,0,2]+ , p "bytestring" [0,9,1,7]+-- , p "Cabal" [1,8,0,6] package is upgradeable+ , p "containers" [0,3,0,0]+ , p "directory" [1,0,1,1]+ , p "extensible-exceptions" [0,1,1,1]+ , p "filepath" [1,1,0,4]+ , p "haskell98" [1,0,1,1]+ , p "hpc" [0,5,0,5]+ , p "integer-gmp" [0,2,0,1]+ , p "integer-simple" [0,1,0,0]+ , p "old-locale" [1,0,0,2]+ , p "old-time" [1,0,0,5]+ , p "pretty" [1,0,1,1]+ , p "process" [1,0,1,3]+ , p "random" [1,0,0,2]+ , p "syb" [0,1,0,2]+ , p "template-haskell" [2,4,0,1]+-- , p "time" [1,1,4] package is upgradeable+ , p "unix" [2,4,0,2]+-- , p "utf8-string" [0,3,4] package is upgradeable+ ]++ghc6122_pkgs :: [PackageIdentifier]+ghc6122_pkgs = + [ p "array" [0,3,0,0]+ , p "base" [3,0,3,2]+ , p "base" [4,2,0,1]+ , p "bytestring" [0,9,1,6]+-- , p "Cabal" [1,8,0,4] package is upgradeable+ , p "containers" [0,3,0,0]+ , p "directory" [1,0,1,1]+ , p "extensible-exceptions" [0,1,1,1]+ , p "filepath" [1,1,0,4]+ , p "haskell98" [1,0,1,1]+ , p "hpc" [0,5,0,5]+ , p "integer-gmp" [0,2,0,1]+ , p "integer-simple" [0,1,0,0]+ , p "old-locale" [1,0,0,2]+ , p "old-time" [1,0,0,4]+ , p "pretty" [1,0,1,1]+ , p "process" [1,0,1,2]+ , p "random" [1,0,0,2]+ , p "syb" [0,1,0,2]+ , p "template-haskell" [2,4,0,1]+-- , p "time" [1,1,4] package is upgradeable+ , p "unix" [2,4,0,1]+-- , p "utf8-string" [0,3,4] package is upgradeable+ ]++ghc6121_pkgs :: [PackageIdentifier]+ghc6121_pkgs = + [ p "array" [0,3,0,0]+ , p "base" [3,0,3,2]+ , p "base" [4,2,0,0]+ , p "bytestring" [0,9,1,5]+-- , p "Cabal" [1,8,0,2] package is upgradeable+ , p "containers" [0,3,0,0]+ , p "directory" [1,0,1,0]+ , p "extensible-exceptions" [0,1,1,1]+ , p "filepath" [1,1,0,3]+ , p "haskell98" [1,0,1,1]+ , p "hpc" [0,5,0,4]+ , p "integer-gmp" [0,2,0,0]+ , p "integer-simple" [0,1,0,0]+ , p "old-locale" [1,0,0,2]+ , p "old-time" [1,0,0,3]+ , p "pretty" [1,0,1,1]+ , p "process" [1,0,1,2]+ , p "random" [1,0,0,2]+ , p "syb" [0,1,0,2]+ , p "template-haskell" [2,4,0,0]+-- , p "time" [1,1,4] package is upgradeable+ , p "unix" [2,4,0,0]+-- , p "utf8-string" [0,3,4] package is upgradeable+ ]++ghc6104_pkgs :: [PackageIdentifier]+ghc6104_pkgs =+ [ p "array" [0,2,0,0]+ , p "base" [3,0,3,1]+ , p "base" [4,1,0,0]+ , p "bytestring" [0,9,1,4]+-- , p "Cabal" [1,6,0,3] package is upgradeable+ , p "containers" [0,2,0,1 ]+ , p "directory" [1,0,0,3]+ , p "extensible-exceptions" [0,1,1,0]+ , p "filepath" [1,1,0,2]+ , p "haskell98" [1,0,1,0]+ , p "hpc" [0,5,0,3]+ , p "old-locale" [1,0,0,1]+ , p "old-time" [1,0,0,2]+ , p "packedstring" [0,1,0,1]+ , p "pretty" [1,0,1,0]+ , p "process" [1,0,1,1]+ , p "random" [1,0,0,1]+ , p "syb" [0,1,0,1]+ , p "template-haskell" [2,3,0,1]+-- , p "time" [1,1,4] package is upgradeable+ , p "unix" [2,3,2,0]+ ]++ghc6101_pkgs :: [PackageIdentifier]+ghc6101_pkgs =+ [ p "array" [0,2,0,0]+ , p "base" [3,0,3,0]+ , p "base" [4,0,0,0]+ , p "bytestring" [0,9,1,4]+-- , p "Cabal" [1,6,0,1] package is upgradeable+ , p "containers" [0,2,0,0]+ , p "directory" [1,0,0,2]+ , p "extensible-exceptions" [0,1,0,0]+ , p "filepath" [1,1,0,1]+ , p "haskell98" [1,0,1,0]+ , p "hpc" [0,5,0,2]+ , p "old-locale" [1,0,0,1]+ , p "old-time" [1,0,0,1]+ , p "packedstring" [0,1,0,1]+ , p "pretty" [1,0,1,0]+ , p "process" [1,0,1,0]+ , p "random" [1,0,0,1]+ , p "syb" [0,1,0,0]+ , p "template-haskell" [2,3,0,0]+ , p "unix" [2,3,1,0]+ ]++ghc682_pkgs :: [PackageIdentifier]+ghc682_pkgs =+ [ p "array" [0,1,0,0]+ , p "base" [3,0,1,0]+ , p "bytestring" [0,9,0,1]+-- , p "Cabal" [1,2,3,0] package is upgradeable+ , p "containers" [0,1,0,1]+ , p "dictionary" [1,0,0,0]+ , p "filepath" [1,1,0,0]+ , p "haskell98" [1,0,1,0]+ , p "hpc" [0,5,0,0]+ , p "old-locale" [1,0,0,0]+ , p "old-time" [1,0,0,0]+ , p "packedstring" [0,1,0,0]+ , p "pretty" [1,0,0,0]+ , p "process" [1,0,0,0]+ , p "random" [1,0,0,0]+-- , p "readline" [1,0,1,0]+ , p "template-haskell" [2,2,0,0]+ , p "unix" [2,3,0,0]+ ]++p :: String -> [Int] -> PackageIdentifier+p pn vs = PackageIdentifier (PackageName pn) (Version vs [])
Portage/Host.hs view
@@ -5,14 +5,14 @@ import Util (run_cmd) import Data.Char (isSpace)-import Data.Maybe (fromJust, isJust)-+import Data.Maybe (fromJust, isJust, catMaybes)+import Control.Applicative ( (<$>) ) data LocalInfo = LocalInfo { distfiles_dir :: String , overlay_list :: [FilePath] , portage_dir :: FilePath- }+ } deriving Show defaultInfo :: LocalInfo defaultInfo = LocalInfo { distfiles_dir = "/usr/portage/distfiles"@@ -23,8 +23,8 @@ -- query paludis and then emerge getInfo :: IO LocalInfo getInfo = fromJust `fmap`- performMaybes [ (fmap . fmap) parse_paludis_output (run_cmd "paludis --info")- , (fmap . fmap) parse_emerge_output (run_cmd "emerge --info")+ performMaybes [ getPaludisInfo+ , fmap parse_emerge_output <$> (run_cmd "emerge --info") , return (Just defaultInfo) ] where performMaybes [] = return Nothing@@ -34,58 +34,51 @@ then return r else performMaybes acts -data LocalPaludisOverlay =- LocalPaludisOverlay { repo_name :: String- , format :: String- , location :: FilePath- , distdir :: FilePath- }+----------+-- Paludis+---------- -bad_paludis_overlay :: LocalPaludisOverlay-bad_paludis_overlay =- LocalPaludisOverlay { repo_name = undefined- , format = undefined- , location = undefined- , distdir = undefined- }+getPaludisInfo :: IO (Maybe LocalInfo)+getPaludisInfo = fmap parsePaludisInfo <$> run_cmd "paludis --info" -parse_paludis_output :: String -> LocalInfo-parse_paludis_output raw_data =- foldl updateInfo defaultInfo $ parse_paludis_overlays raw_data- where updateInfo info po =- case (format po) of- "ebuild" | (repo_name po) /= "gentoo" -- hack, skip main repo- -> info{ distfiles_dir = distdir po -- we override last distdir here (FIXME?)- , overlay_list = (location po) : overlay_list info- }- "ebuild" -- hack, main repo -- (repo_name po) == "gentoo"- -> info{ portage_dir = location po }+parsePaludisInfo :: String -> LocalInfo+parsePaludisInfo text =+ let chunks = splitBy (=="") . lines $ text+ repositories = catMaybes (map parseRepository chunks)+ in fromJust (mkLocalInfo repositories)+ where+ parseRepository :: [String] -> Maybe (String, (String, String))+ parseRepository (firstLine:lns) = do+ name <- case words firstLine of+ ["Repository", nm] -> return (init nm)+ _ -> fail "not a repository chunk"+ let dict = [ (head ln, unwords (tail ln)) | ln <- map words lns ]+ location <- lookup "location:" dict+ distfiles <- lookup "distdir:" dict+ return (name, (location, distfiles)) - _ -> info+ knownRepos = ["installed-virtuals", "virtuals", "gentoo", "installed"] -parse_paludis_overlays :: String -> [LocalPaludisOverlay]-parse_paludis_overlays raw_data =- parse_paludis_overlays' (reverse $ lines raw_data) bad_paludis_overlay+ mkLocalInfo :: [(String, (String, String))] -> Maybe LocalInfo+ mkLocalInfo repos = do+ (gentooLocation, gentooDistfiles) <- lookup "gentoo" repos+ let overlays = [ loc | (name, (loc, _dist)) <- repos, name `notElem` knownRepos ]+ return (LocalInfo+ { distfiles_dir = gentooDistfiles+ , portage_dir = gentooLocation+ , overlay_list = overlays+ }) --- parse in reverse order :]-parse_paludis_overlays' :: [String] -> LocalPaludisOverlay -> [LocalPaludisOverlay]-parse_paludis_overlays' [] _ = []-parse_paludis_overlays' (l:ls) info =- case (words l) of- -- look for "Repository <repo-name>:"- ["Repository", r_name] -> info{repo_name = init r_name} :- go bad_paludis_overlay- -- else - parse attributes- _ -> case (break (== ':') (refine l)) of- ("location", ':':value)- -> go info{location = refine value}- ("distdir", ':':value)- -> go info{distdir = refine value}- ("format", ':':value)- -> go info{format = refine value}- _ -> go info- where go = parse_paludis_overlays' ls- refine = dropWhile isSpace+splitBy :: (a -> Bool) -> [a] -> [[a]]+splitBy c [] = []+splitBy c lst =+ let (x,xs) = break c lst+ (_,xs') = span c xs+ in x : splitBy c xs'++---------+-- Emerge+--------- parse_emerge_output :: String -> LocalInfo parse_emerge_output raw_data =
+ Portage/Metadata.hs view
@@ -0,0 +1,31 @@+module Portage.Metadata+ ( Metadata(..)+ , metadataFromFile+ ) where++import qualified Data.ByteString as B++import Control.Applicative++import Text.XML.Light++import Control.Monad++data Metadata = Metadata+ { metadataHerds :: [String]+ -- , metadataMaintainers :: [String],+ -- , metadataUseFlags :: [(String,String)]+ } deriving (Show)++metadataFromFile :: FilePath -> IO (Maybe Metadata)+metadataFromFile fp = do+ doc <- parseXMLDoc <$> B.readFile fp+ return (doc >>= parseMetadata)++parseMetadata :: Element -> Maybe Metadata+parseMetadata xml = do+ let herds = map strContent (findChildren (unqual "herd") xml)+ return Metadata+ {+ metadataHerds = herds+ }
Portage/Overlay.hs view
@@ -1,19 +1,22 @@ module Portage.Overlay ( ExistingEbuild(..) , Overlay(..)- , load, loadLazy- , readOverlayByPackage, getDirectoryTree, DirectoryTree+ , loadLazy+ , readOverlay, readOverlayByPackage+ , getDirectoryTree, DirectoryTree , reduceOverlay+ , filterByHerd , inOverlay ) where import qualified Portage.PackageId as Portage+import qualified Portage.Metadata as Portage import qualified Distribution.Package as Cabal -import Distribution.Text (simpleParse, display)+import Distribution.Text (simpleParse) import Distribution.Simple.Utils ( comparing, equating ) import Data.List as List@@ -23,14 +26,8 @@ import System.IO.Unsafe (unsafeInterleaveIO) import System.FilePath ((</>), splitExtension) ---main = do--- pkgs <- blingProgress . Progress.fromList . readOverlay--- =<< getDirectoryTree "."--- putStrLn $ unlines [ display pkg--- | pkg <- pkgs--- , isNothing (Portage.toCabalPackageId pkg) ]+import Data.Traversable ( traverse ) ---TODO: move this to another module: data ExistingEbuild = ExistingEbuild { ebuildId :: Portage.PackageId, ebuildCabalId :: Cabal.PackageIdentifier,@@ -41,7 +38,8 @@ data Overlay = Overlay { overlayPath :: FilePath,- overlayMap :: Map Portage.PackageName [ExistingEbuild]+ overlayMap :: Map Portage.PackageName [ExistingEbuild],+ overlayMetadata :: Map Portage.PackageName Portage.Metadata } deriving Show inOverlay :: Overlay -> Cabal.PackageId -> Bool@@ -58,41 +56,55 @@ in cabal_pn == overlay_pn && (not (null ebs))) om om = overlayMap overlay -load :: FilePath -> IO Overlay-load dir = fmap (mkOverlay . readOverlay) (getDirectoryTree dir)- where- mkOverlay _packages = Overlay {- overlayPath = dir--- TODO: ignore all ebuilds that have no Cabal version number--- , overlayIndex = PackageIndex.fromList packages- , overlayMap = undefined- }- loadLazy :: FilePath -> IO Overlay-loadLazy dir = fmap (mkOverlay . readOverlayByPackage) (getDirectoryTree dir)+loadLazy path = do+ dir <- getDirectoryTree path+ metadata <- unsafeInterleaveIO $ mkMetadataMap path dir+ return $ mkOverlay metadata $ readOverlayByPackage dir where allowed v = case v of (Portage.Version _ Nothing [] _) -> True _ -> False- a <-> b = a ++ '-':b- a <.> b = a ++ '.':b - mkOverlay :: [(Portage.PackageName, [Portage.Version])] -> Overlay- mkOverlay packages = Overlay {- overlayPath = dir,+ mkOverlay :: Map Portage.PackageName Portage.Metadata+ -> [(Portage.PackageName, [Portage.Version])]+ -> Overlay+ mkOverlay meta packages = Overlay {+ overlayPath = path,+ overlayMetadata = meta, overlayMap = Map.fromList [ (pkgName, [ ExistingEbuild portageId cabalId filepath | version <- allowedVersions , let portageId = Portage.PackageId pkgName version , Just cabalId <- [ Portage.toCabalPackageId portageId ]- , let filepath =- dir </> display pkgName <-> display version <.> "ebuild"+ , let filepath = path </> Portage.packageIdToFilePath portageId ]) | (pkgName, allVersions) <- packages , let allowedVersions = filter allowed allVersions ] }++mkMetadataMap :: FilePath -> DirectoryTree -> IO (Map Portage.PackageName Portage.Metadata)+mkMetadataMap root dir =+ fmap (Map.mapMaybe id) $+ traverse Portage.metadataFromFile $+ Map.fromList+ [ (Portage.mkPackageName category package, root </> category </> package </> "metadata.xml")+ | Directory category packages <- dir+ , Directory package files <- packages+ , File "metadata.xml" <- files+ ]++filterByHerd :: ([String] -> Bool) -> Overlay -> Overlay+filterByHerd p overlay = overlay+ { overlayMetadata = metadataMap'+ , overlayMap = pkgMap'+ }+ where+ metadataMap' = Map.filter (p . Portage.metadataHerds) (overlayMetadata overlay)+ pkgMap' = Map.intersection (overlayMap overlay) metadataMap'+ -- make sure there is only one ebuild for each version number (by selecting -- the highest ebuild version revision)
Portage/PackageId.hs view
@@ -10,7 +10,8 @@ toCabalPackageId, parseFriendlyPackage, normalizeCabalPackageName,- normalizeCabalPackageId+ normalizeCabalPackageId,+ packageIdToFilePath ) where import qualified Distribution.Package as Cabal@@ -23,9 +24,10 @@ import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>)) import qualified Data.Char as Char (isAlphaNum, isSpace, toLower)--- import qualified Data.Char as Char (isDigit)--- import Data.List (intersperse) +import Distribution.Text(display)+import System.FilePath ( (</>) )+ newtype Category = Category { unCategory :: String } deriving (Eq, Ord, Show, Read) @@ -48,6 +50,13 @@ -- each component must contain an alphabetic character, to avoid -- ambiguity in identifiers like foo-1 (the 1 is the version number). -}++packageIdToFilePath :: PackageId -> FilePath+packageIdToFilePath (PackageId (PackageName cat pn) version) =+ display cat </> display pn </> display pn <-> display version <.> "ebuild"+ where+ a <-> b = a ++ '-':b+ a <.> b = a ++ '.':b mkPackageName :: String -> String -> PackageName mkPackageName cat package = PackageName (Category cat) (Cabal.PackageName package)
Status.hs view
@@ -6,8 +6,10 @@ ) where import AnsiColor-import P2 +import Portage.Overlay+import Portage.PackageId+ import Control.Monad.State import qualified Data.List as List@@ -19,11 +21,13 @@ import Data.Map as Map (Map) import qualified Data.Traversable as T+import Control.Applicative -- cabal import Distribution.Verbosity import Distribution.Simple.Utils (equating, comparing)-import Distribution.Text(display)+import Distribution.Text ( display, simpleParse )+import Distribution.Simple.Utils ( die ) data FileStatus a = Same a@@ -51,20 +55,20 @@ OverlayOnly a -> a PortageOnly a -> a -status :: Verbosity -> FilePath -> FilePath -> IO (Map Package [FileStatus Ebuild])-status _verbosity portdir overlayPath = do- overlay <- readPortageTree overlayPath- portage <- readPortagePackages portdir (Map.keys overlay)- let (over, both, port) = portageDiff overlay portage+status :: Verbosity -> FilePath -> FilePath -> IO (Map PackageName [FileStatus ExistingEbuild])+status _verbosity portdir overlaydir = do+ overlay <- loadLazy overlaydir+ portage <- filterByHerd ("haskell" `elem`) <$> loadLazy portdir+ let (over, both, port) = portageDiff (overlayMap overlay) (overlayMap portage) both' <- T.forM both $ mapM $ \e -> liftIO $ do -- can't fail, we know the ebuild exists in both portagedirs -- also, one of them is already bound to 'e'- let (Just e1) = lookupEbuildWith portage (ePackage e) (equating eVersion e)- (Just e2) = lookupEbuildWith overlay (ePackage e) (equating eVersion e)- eq <- equals (eFilePath e1) (eFilePath e2)+ let (Just e1) = lookupEbuildWith (overlayMap portage) (ebuildId e)+ (Just e2) = lookupEbuildWith (overlayMap overlay) (ebuildId e)+ eq <- equals (ebuildPath e1) (ebuildPath e2) return $ if eq- then Same e+ then Same e1 else Differs e1 e2 let meld = Map.unionsWith (\a b -> List.sort (a++b))@@ -74,50 +78,59 @@ ] return meld +type EMap = Map PackageName [ExistingEbuild]++lookupEbuildWith :: EMap -> PackageId -> Maybe ExistingEbuild+lookupEbuildWith overlay pkgid = do+ ebuilds <- Map.lookup (packageId pkgid) overlay+ List.find (\e -> ebuildId e == pkgid) ebuilds+ runStatus :: Verbosity -> FilePath -> FilePath -> Bool -> [String] -> IO ()-runStatus verbosity portdir overlayPath toPortageFlag pkgs = do+runStatus verbosity portdir overlaydir toPortageFlag pkgs = do let pkgFilter | toPortageFlag = toPortageFilter | otherwise = id- tree0 <- status verbosity portdir overlayPath+ pkgs' <- forM pkgs $ \p ->+ case simpleParse p of+ Nothing -> die ("Could not parse package name: " ++ p ++ ". Format cat/pkg")+ Just pn -> return pn+ tree0 <- status verbosity portdir overlaydir let tree = pkgFilter tree0- if (null pkgs)+ if (null pkgs') then statusPrinter tree- else forM_ pkgs $ \pkg -> do- let filteredTree = Map.filterWithKey (\k _ -> pPackage k == pkg) tree- statusPrinter filteredTree+ else forM_ pkgs' $ \pkg -> statusPrinter (Map.filterWithKey (\k _ -> k == pkg) tree) -- |Only return packages that seems interesting to sync to portage; -- -- * Ebuild differs, or -- * Newer version in overlay than in portage-toPortageFilter :: Map Package [FileStatus Ebuild] -> Map Package [FileStatus Ebuild]+toPortageFilter :: Map PackageName [FileStatus ExistingEbuild] -> Map PackageName [FileStatus ExistingEbuild] toPortageFilter = Map.mapMaybe $ \ sts -> let inPortage = flip filter sts $ \st -> case st of OverlayOnly _ -> False _ -> True- latestPortageVersion = List.maximum $ map (eVersion . fromStatus) inPortage+ latestPortageVersion = List.maximum $ map (pkgVersion . ebuildId . fromStatus) inPortage interestingPackages = flip filter sts $ \st -> case st of Differs _ _ -> True- _ | eVersion (fromStatus st) > latestPortageVersion -> True+ _ | pkgVersion (ebuildId (fromStatus st)) > latestPortageVersion -> True | otherwise -> False in if not (null inPortage) && not (null interestingPackages) then Just sts else Nothing -statusPrinter :: Map Package [FileStatus Ebuild] -> IO ()+statusPrinter :: Map PackageName [FileStatus ExistingEbuild] -> IO () statusPrinter packages = do putStrLn $ toColor (Same "Green") ++ ": package in portage and overlay are the same" putStrLn $ toColor (Differs "Yellow" "") ++ ": package in portage and overlay differs" putStrLn $ toColor (OverlayOnly "Red") ++ ": package only exist in the overlay" putStrLn $ toColor (PortageOnly "Magenta") ++ ": package only exist in the portage tree" forM_ (Map.toAscList packages) $ \(pkg, ebuilds) -> do- let (P c p) = pkg- putStr $ c ++ '/' : bold p+ let (PackageName c p) = pkg+ putStr $ display c ++ '/' : bold (display p) putStr " " forM_ ebuilds $ \e -> do- putStr $ toColor (fmap (display . eVersion) e)+ putStr $ toColor (fmap (display . pkgVersion . ebuildId) e) putChar ' ' putStrLn "" @@ -130,15 +143,15 @@ (OverlayOnly _) -> Red (PortageOnly _) -> Magenta -portageDiff :: Portage -> Portage -> (Portage, Portage, Portage)++portageDiff :: EMap -> EMap -> (EMap, EMap, EMap) portageDiff p1 p2 = (in1, ins, in2)- where ins = Map.filter (not . null) $- Map.intersectionWith (List.intersectBy $ equating eVersion) p1 p2+ where ins = Map.filter (not . null) $ Map.intersectionWith (List.intersectBy $ equating ebuildId) p1 p2 in1 = difference p1 p2 in2 = difference p2 p1 difference x y = Map.filter (not . null) $ Map.differenceWith (\xs ys ->- let lst = foldr (List.deleteBy (equating eVersion)) xs ys in+ let lst = foldr (List.deleteBy (equating ebuildId)) xs ys in if null lst then Nothing else Just lst
− cabal-install-0.8.2/Distribution/Client/BuildReports/Anonymous.hs
@@ -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
− cabal-install-0.8.2/Distribution/Client/BuildReports/Storage.hs
@@ -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
− cabal-install-0.8.2/Distribution/Client/BuildReports/Types.hs
@@ -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
− cabal-install-0.8.2/Distribution/Client/BuildReports/Upload.hs
@@ -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 ()
− cabal-install-0.8.2/Distribution/Client/Check.hs
@@ -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 . ("* "++)
− cabal-install-0.8.2/Distribution/Client/Config.hs
@@ -1,565 +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- , Flag, toFlag, flagToMaybe, fromFlagOrDefault, flagToList )-import Distribution.Simple.InstallDirs- ( InstallDirs(..), defaultInstallDirs- , PathTemplate, toPathTemplate, fromPathTemplate )-import Distribution.ParseUtils- ( FieldDescr(..), liftField- , ParseResult(..), locatedErrorMsg, showPWarning- , readFields, warning, lineNo- , simpleField, listField, parseFilePathQ, showFilePath, parseTokenQ )-import qualified Distribution.ParseUtils as ParseUtils- ( Field(..) )-import qualified Distribution.Text as Text- ( Text(..) )-import Distribution.ReadE- ( readP_to_E )-import Distribution.Simple.Command- ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..)- , viewAsFieldDescr, OptionField, option, reqArg )-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- return mempty {- savedConfigureFlags = mempty {- configHcFlavor = toFlag defaultCompiler,- configUserInstall = toFlag defaultUserInstall,- configVerbosity = toFlag normal- },- savedUserInstallDirs = mempty {- prefix = toFlag (toPathTemplate userPrefix)- }- }---- | 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- return mempty {- savedGlobalFlags = mempty {- globalCacheDir = toFlag cacheDir,- globalRemoteRepos = [defaultRemoteRepo]- },- savedInstallFlags = mempty {- installSummaryFile = [toPathTemplate (logsDir </> "build.log")],- installBuildReports= toFlag AnonymousReports- }- }--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"--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----TODO: this is now exported in Cabal-1.5-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)-- reqArgFlag ad = reqArg ad (fmap toFlag (readP_to_E err parseFilePathQ))- (map (show . showFilePath) . flagToList)- where err _ = "paths with spaces must use Haskell String syntax"
− cabal-install-0.8.2/Distribution/Client/Configure.hs
@@ -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 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- -> Maybe (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) `fmap` installed- localPkg = AvailablePackage {- packageInfoId = packageId pkg,- Available.packageDescription = pkg,- packageSource = LocalUnpackedPackage- }- 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
− cabal-install-0.8.2/Distribution/Client/Dependency.hs
@@ -1,233 +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,-- dependencyConstraints,- dependencyTargets,-- PackagesPreference(..),- PackagesPreferenceDefault(..),- PackagePreference(..),-- upgradableDependencies,- ) where--import Distribution.Client.Dependency.Bogus (bogusResolver)-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(..), Package(..), PackageFixedDeps(..) )-import Distribution.Version- ( VersionRange, anyVersion, orLaterVersion, isAnyVersion )-import Distribution.Compiler- ( CompilerId(..) )-import Distribution.System- ( Platform )-import Distribution.Simple.Utils (comparing)-import Distribution.Client.Utils (mergeBy, MergeResult(..))--import Data.List (maximumBy)-import Data.Monoid (Monoid(mempty))-import Data.Maybe (fromMaybe)-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- -> Maybe (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- -> Maybe (PackageIndex InstalledPackage)- -> PackageIndex AvailablePackage- -> PackagesPreference- -> [PackageConstraint]- -> [PackageName]- -> Progress String String InstallPlan-resolveDependenciesWithProgress platform comp (Just installed) =- dependencyResolver defaultResolver platform comp installed--resolveDependenciesWithProgress platform comp Nothing =- dependencyResolver bogusResolver platform comp mempty--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--dependencyResolver- :: DependencyResolver- -> Platform -> CompilerId- -> PackageIndex InstalledPackage- -> PackageIndex AvailablePackage- -> PackagesPreference- -> [PackageConstraint]- -> [PackageName]- -> Progress String String InstallPlan-dependencyResolver resolver platform comp installed available- pref constraints targets =- 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- $ resolver 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---- | 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---- | 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 ]
− cabal-install-0.8.2/Distribution/Client/Dependency/Bogus.hs
@@ -1,129 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Distribution.Client.Dependency.Bogus--- Copyright : (c) David Himmelstrup 2005, Bjorn Bringert 2007--- Duncan Coutts 2008--- License : BSD-like------ Maintainer : cabal-devel@haskell.org--- Stability : provisional--- Portability : portable------ A dependency resolver for when we do not know what packages are installed.-------------------------------------------------------------------------------module Distribution.Client.Dependency.Bogus (- bogusResolver- ) where--import Distribution.Client.Types- ( AvailablePackage(..), ConfiguredPackage(..) )-import Distribution.Client.Dependency.Types- ( DependencyResolver, Progress(..)- , PackageConstraint(..), PackagePreferences(..) )-import qualified Distribution.Client.InstallPlan as InstallPlan--import Distribution.Package- ( PackageName, PackageIdentifier(..), Dependency(..)- , Package(..), packageVersion )-import Distribution.PackageDescription- ( GenericPackageDescription(..), CondTree(..), FlagAssignment )-import Distribution.PackageDescription.Configuration- ( finalizePackageDescription )-import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Client.PackageIndex (PackageIndex)-import Distribution.Version- ( VersionRange, anyVersion, intersectVersionRanges, withinRange )-import Distribution.Simple.Utils- ( comparing )-import Distribution.Text- ( display )--import Data.List- ( maximumBy )-import Data.Maybe- ( fromMaybe )-import qualified Data.Map as Map---- | This resolver thinks that every package is already installed.------ We need this for hugs and nhc98 which do not track installed packages.--- We just pretend that everything is installed and hope for the best.----bogusResolver :: DependencyResolver-bogusResolver platform comp _ available- preferences constraints targets =- resolveFromAvailable []- (combineConstraints preferences constraints targets)- where- resolveFromAvailable chosen [] = Done chosen- resolveFromAvailable chosen ((name, verConstraint, flags, verPref): deps) =- case latestAvailableSatisfying available name verConstraint verPref of- Nothing -> Fail ("Unresolved dependency: " ++ display dep)- Just apkg@(AvailablePackage _ pkg _) ->- case finalizePackageDescription flags none platform comp [] pkg of- Right (_, flags') -> Step msg (resolveFromAvailable chosen' deps)- where- msg = "selecting " ++ display (packageId pkg)- cpkg = fudgeChosenPackage apkg flags'- chosen' = InstallPlan.Configured cpkg : chosen- _ -> error "bogusResolver: impossible happened"- where- none :: Dependency -> Bool- none = const True- where- dep = Dependency name verConstraint--fudgeChosenPackage :: AvailablePackage -> FlagAssignment -> ConfiguredPackage-fudgeChosenPackage (AvailablePackage pkgid pkg source) flags =- ConfiguredPackage (AvailablePackage pkgid (stripDependencies pkg) source)- flags ([] :: [PackageIdentifier]) -- empty list of deps- where- -- | Pretend that a package has no dependencies. Go through the- -- 'GenericPackageDescription' and strip them all out.- --- stripDependencies :: GenericPackageDescription -> GenericPackageDescription- stripDependencies gpkg = gpkg {- condLibrary = fmap stripDeps (condLibrary gpkg),- condExecutables = [ (name, stripDeps tree)- | (name, tree) <- condExecutables gpkg ]- }- stripDeps :: CondTree v [Dependency] a -> CondTree v [Dependency] a- stripDeps = mapTreeConstrs (const [])-- mapTreeConstrs :: (c -> c) -> CondTree v c a -> CondTree v c a- mapTreeConstrs f (CondNode a c ifs) = CondNode a (f c) (map g ifs)- where- g (cnd, t, me) = (cnd, mapTreeConstrs f t, fmap (mapTreeConstrs f) me)--combineConstraints :: (PackageName -> PackagePreferences)- -> [PackageConstraint]- -> [PackageName]- -> [(PackageName, VersionRange, FlagAssignment, VersionRange)]-combineConstraints preferences constraints targets =- [ (name, ver, flags, pref)- | name <- targets- , let ver = fromMaybe anyVersion (Map.lookup name versionConstraints)- flags = fromMaybe [] (Map.lookup name flagsConstraints)- PackagePreferences pref _ = preferences name ]- where- versionConstraints = Map.fromListWith intersectVersionRanges- [ (name, versionRange)- | PackageVersionConstraint name versionRange <- constraints ]-- flagsConstraints = Map.fromListWith (++)- [ (name, flags)- | PackageFlagsConstraint name flags <- constraints ]---- | Gets the best available package satisfying a dependency.----latestAvailableSatisfying :: PackageIndex AvailablePackage- -> PackageName -> VersionRange -> VersionRange- -> Maybe AvailablePackage-latestAvailableSatisfying index name versionConstraint versionPreference =- case PackageIndex.lookupDependency index dep of- [] -> Nothing- pkgs -> Just (maximumBy best pkgs)- where- dep = Dependency name versionConstraint- best = comparing (\p -> (isPreferred p, packageVersion p))- isPreferred p = packageVersion p `withinRange` versionPreference
− cabal-install-0.8.2/Distribution/Client/Dependency/TopDown.hs
@@ -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'
− cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Constraints.hs
@@ -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 ]
− cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Types.hs
@@ -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
− cabal-install-0.8.2/Distribution/Client/Dependency/Types.hs
@@ -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
− cabal-install-0.8.2/Distribution/Client/Fetch.hs
@@ -1,192 +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(..) )-import Distribution.Client.Dependency- ( resolveDependenciesWithProgress- , 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.Package- ( PackageIdentifier, 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.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- 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- -> [UnresolvedDependency]- -> IO ()-fetch verbosity packageDBs repos comp conf deps = do- installed <- getInstalledPackages verbosity comp packageDBs conf- AvailablePackageDb available availablePrefs- <- getAvailablePackages verbosity repos- deps' <- IndexUtils.disambiguateDependencies available deps-- let -- 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).- installed' = fmap (hideGivenDeps deps') installed- hideGivenDeps pkgs index =- foldr PackageIndex.deletePackageName index- [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ]-- let progress = resolveDependenciesWithProgress- buildPlatform (compilerId comp)- installed' available- (PackagesPreference PreferLatestForSelected- [ PackageVersionPreference name ver- | (name, ver) <- Map.toList availablePrefs ])- (dependencyConstraints deps')- (dependencyTargets deps')- notice verbosity "Resolving dependencies..."- maybePlan <- foldProgress (\message rest -> info verbosity message >> rest)- (return . Left) (return . Right) progress- case maybePlan of- Left message -> die message- Right pkgs -> do- ps <- filterM (fmap not . isFetched)- [ pkg | (InstallPlan.Configured- (InstallPlan.ConfiguredPackage pkg _ _))- <- InstallPlan.toList pkgs ]- when (null ps) $- notice verbosity $ "No packages need to be fetched. "- ++ "All the requested packages are already cached."-- sequence_ - [ fetchPackage verbosity repo pkgid- | (AvailablePackage pkgid _ (RepoTarballPackage repo)) <- ps ]---- |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"]- }
− cabal-install-0.8.2/Distribution/Client/Haddock.hs
@@ -1,101 +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 "htemp" $ \tempDir -> do-- let flags = ["--gen-contents", "--gen-index", "--odir="++tempDir] - ++ map (\(i,h) -> "--read-interface=" ++ h ++ "," ++ i) 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 [Char])-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)
− cabal-install-0.8.2/Distribution/Client/HttpUtils.hs
@@ -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
− cabal-install-0.8.2/Distribution/Client/IndexUtils.hs
@@ -1,301 +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,- readRepoIndex,- 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 qualified Codec.Compression.GZip as GZip (decompress)-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 (Maybe (PackageIndex InstalledPackage))-getInstalledPackages verbosity comp packageDbs conf =- fmap (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 'cabal 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 "- ++ "'cabal 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- . GZip.decompress- =<< 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 'cabal 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 ]
− cabal-install-0.8.2/Distribution/Client/Init.hs
@@ -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
− cabal-install-0.8.2/Distribution/Client/Init/Heuristics.hs
@@ -1,187 +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 ]- 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) && entry /= "dist" =- scanForModulesIn projectRoot $ foldl (</>) srcRoot (entry : hierarchy)- | otherwise = return []---- 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
− cabal-install-0.8.2/Distribution/Client/Init/Licenses.hs
@@ -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."- , ""- , " <one line to give the program's name and a brief idea of what it does.>"- , " Copyright (C) <year> <name of author>"- , ""- , " 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."- , ""- , " <signature of Ty Coon>, 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. <http://fsf.org/>"- , " 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."- , ""- , " <one line to give the program's name and a brief idea of what it does.>"- , " Copyright (C) <year> <name of author>"- , ""- , " 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 <http://www.gnu.org/licenses/>."- , ""- , "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:"- , ""- , " <program> Copyright (C) <year> <name of author>"- , " 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"- , "<http://www.gnu.org/licenses/>."- , ""- , " 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"- , "<http://www.gnu.org/philosophy/why-not-lgpl.html>."- , ""- ]--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."- , ""- , " <one line to give the library's name and a brief idea of what it does.>"- , " Copyright (C) <year> <name of author>"- , ""- , " 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."- , ""- , " <signature of Ty Coon>, 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. <http://fsf.org/>"- , " 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."- ]-
− cabal-install-0.8.2/Distribution/Client/Init/Types.hs
@@ -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
− cabal-install-0.8.2/Distribution/Client/Install.hs
@@ -1,786 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Distribution.Client.Install--- Copyright : (c) David Himmelstrup 2005--- License : BSD-like------ Maintainer : lemmih@gmail.com--- 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 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(..)- , upgradableDependencies- , Progress(..), foldProgress, )-import Distribution.Client.Fetch (fetchPackage)-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- ( ConfigFlags(..), configureCommand, filterConfigureFlags- , ConfigExFlags(..), InstallFlags(..) )-import Distribution.Client.Config- ( defaultLogsDir, 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 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 )--data InstallMisc = InstallMisc {- rootCmd :: Maybe FilePath,- libVersion :: Maybe Version- }---- |Installs the packages needed to satisfy a list of dependencies.-install, upgrade- :: Verbosity- -> PackageDBStack- -> [Repo]- -> Compiler- -> ProgramConfiguration- -> ConfigFlags- -> ConfigExFlags- -> InstallFlags- -> [UnresolvedDependency]- -> IO ()-install verbosity packageDB repos comp conf- configFlags configExFlags installFlags deps =-- installWithPlanner planner- verbosity packageDB repos comp conf- configFlags configExFlags installFlags- where- planner :: Planner- planner | null deps = planLocalPackage verbosity- comp configFlags configExFlags- | otherwise = planRepoPackages PreferLatestForSelected- comp configFlags configExFlags installFlags deps--upgrade verbosity packageDB repos comp conf- configFlags configExFlags installFlags deps =-- installWithPlanner planner- verbosity packageDB repos comp conf- configFlags configExFlags installFlags- where- planner :: Planner- planner | null deps = planUpgradePackages- comp configFlags configExFlags- | otherwise = planRepoPackages PreferAllLatest- comp configFlags configExFlags installFlags deps--type Planner = Maybe (PackageIndex InstalledPackage)- -> AvailablePackageDb- -> IO (Progress String String InstallPlan)---- |Installs the packages generated by a planner.-installWithPlanner ::- Planner- -> Verbosity- -> PackageDBStack- -> [Repo]- -> Compiler- -> ProgramConfiguration- -> ConfigFlags- -> ConfigExFlags- -> InstallFlags- -> IO ()-installWithPlanner planner verbosity packageDBs repos comp conf- configFlags configExFlags installFlags = do-- installed <- getInstalledPackages verbosity comp packageDBs conf- available <- getAvailablePackages verbosity repos-- progress <- planner installed available-- notice verbosity "Resolving dependencies..."- maybePlan <- foldProgress (\message rest -> info verbosity message >> rest)- (return . Left) (return . Right) progress- case maybePlan of- Left message -> die message- Right installPlan -> do- let nothingToInstall = null (InstallPlan.ready installPlan)- 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-- unless dryRun $ do- logsDir <- defaultLogsDir- let platform = InstallPlan.planPlatform installPlan- compid = InstallPlan.planCompiler installPlan- installPlan' <-- 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 logsDir)-- -- build reporting, local and remote- 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- 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 index- else Nothing,- useProgramConfig = conf,- useDistPref = fromFlagOrDefault- (useDistPref defaultSetupScriptOptions)- (configDistPref configFlags),- useLoggingHandle = Nothing,- useWorkingDir = Nothing- }- reportingLevel = fromFlag (installBuildReports installFlags)- useLogFile :: FilePath -> Maybe (PackageIdentifier -> FilePath)- useLogFile logsDir = 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)- dryRun = fromFlag (installDryRun installFlags)- miscOptions = InstallMisc {- rootCmd = if fromFlag (configUserInstall configFlags)- then Nothing -- ignore --root-cmd if --user.- else flagToMaybe (installRootCmd installFlags),- libVersion = flagToMaybe (configCabalVersion configExFlags)- }--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- case installed of- Nothing -> return () -- warning ?- Just index -> Haddock.regenerateHaddockIndex verbosity index 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)----- | 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) `fmap` installed- localPkg = AvailablePackage {- packageInfoId = packageId pkg,- Available.packageDescription = pkg,- packageSource = LocalUnpackedPackage- }- 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- -> ConfigFlags -> ConfigExFlags -> InstallFlags- -> [UnresolvedDependency] -> Planner-planRepoPackages defaultPref comp configFlags configExFlags installFlags- deps installed (AvailablePackageDb available availablePrefs) = do-- deps' <- IndexUtils.disambiguateDependencies available deps- let installed'- | fromFlag (installReinstall installFlags)- = fmap (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 ]--planUpgradePackages :: Compiler -> ConfigFlags -> ConfigExFlags -> Planner-planUpgradePackages _comp _configFlags _configExFlags (Just installed)- (AvailablePackageDb available _availablePrefs) = die $- "the 'upgrade' command (when used without any package arguments) has "- ++ "been disabled in this release. It has been disabled because it has "- ++ "frequently led people to accidentally break their set of installed "- ++ "packages. It will be re-enabled when it is safer to use.\n"- ++ "Below is the list of packages that it would have tried to upgrade. You "- ++ "can use the 'install' command to install the ones you want. Note that "- ++ "it is generally not recommended to upgrade core packages.\n"- ++ unlines [ display pkgid | Dependency pkgid _ <- deps ]----TODO: improve upgrade so we can re-enable it--- return $--- resolveDependenciesWithProgress buildPlatform (compilerId comp)--- (Just installed) available preferences constraints targets- where- deps = upgradableDependencies installed available--- preferences = mergePackagePrefs PreferAllLatest availablePrefs configExFlags--- constraints = [ PackageVersionConstraint name ver--- | Dependency name ver <- deps ]--- ++ [ PackageVersionConstraint name ver--- | Dependency name ver <- configConstraints configFlags ]--- targets = [ name | Dependency name _ <- deps ]--planUpgradePackages comp _ _ _ _ =- die $ display (compilerId comp)- ++ " does not track installed packages so cabal cannot figure out what"- ++ " packages need to be upgraded."--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 ]--printDryRun :: Verbosity -> Maybe (PackageIndex InstalledPackage)- -> InstallPlan -> IO ()-printDryRun verbosity minstalled 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 minstalled of- Nothing -> ""- Just installed ->- 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--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--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 installPkg =- installPkg Nothing--installAvailablePackage verbosity pkgid (RepoTarballPackage repo) installPkg =- onFailure DownloadFailed $ do- pkgPath <- fetchPackage verbosity repo pkgid- onFailure UnpackFailed $ do- tmp <- getTemporaryDirectory- withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath -> do- info verbosity $ "Extracting " ++ pkgPath- ++ " to " ++ tmpDirPath ++ "..."- let relUnpackedPath = display pkgid- absUnpackedPath = tmpDirPath </> relUnpackedPath- descFilePath = absUnpackedPath- </> display (packageName pkgid) <.> "cabal"- extractTarGzFile tmpDirPath relUnpackedPath pkgPath- 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--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
− cabal-install-0.8.2/Distribution/Client/InstallPlan.hs
@@ -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"
− cabal-install-0.8.2/Distribution/Client/InstallSymlink.hs
@@ -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
− cabal-install-0.8.2/Distribution/Client/List.hs
@@ -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- Just 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- Just 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)
− cabal-install-0.8.2/Distribution/Client/PackageIndex.hs
@@ -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
− cabal-install-0.8.2/Distribution/Client/PackageUtils.hs
@@ -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
− cabal-install-0.8.2/Distribution/Client/Setup.hs
@@ -1,876 +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- , 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 )-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]- }--defaultGlobalFlags :: GlobalFlags-defaultGlobalFlags = GlobalFlags {- globalVersion = Flag False,- globalNumericVersion = Flag False,- globalConfigFile = mempty,- globalRemoteRepos = [],- globalCacheDir = mempty,- globalLocalRepos = 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)- ]- }--instance Monoid GlobalFlags where- mempty = GlobalFlags {- globalVersion = mempty,- globalNumericVersion = mempty,- globalConfigFile = mempty,- globalRemoteRepos = mempty,- globalCacheDir = mempty,- globalLocalRepos = mempty- }- mappend a b = GlobalFlags {- globalVersion = combine globalVersion,- globalNumericVersion = combine globalNumericVersion,- globalConfigFile = combine globalConfigFile,- globalRemoteRepos = combine globalRemoteRepos,- globalCacheDir = combine globalCacheDir,- globalLocalRepos = combine globalLocalRepos- }- 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---- --------------------------------------------------------------- * Other commands--- --------------------------------------------------------------fetchCommand :: CommandUI (Flag Verbosity)-fetchCommand = CommandUI {- commandName = "fetch",- commandSynopsis = "Downloads packages for later installation.",- commandDescription = Nothing,- commandUsage = usagePackages "fetch",- commandDefaultFlags = toFlag normal,- commandOptions = \_ -> [optionVerbosity id const]- }--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 = "Upgrades installed packages to the latest available version",- 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,- installOnly :: Flag Bool,- installRootCmd :: Flag String,- installSummaryFile :: [PathTemplate],- installLogFile :: Flag PathTemplate,- installBuildReports :: Flag ReportLevel,- installSymlinkBinDir:: Flag FilePath- }--defaultInstallFlags :: InstallFlags-defaultInstallFlags = InstallFlags {- installDocumentation= Flag False,- installHaddockIndex = Flag docIndexFile,- installDryRun = Flag False,- installReinstall = Flag False,- installOnly = Flag False,- installRootCmd = mempty,- installSummaryFile = mempty,- installLogFile = mempty,- installBuildReports = Flag NoReports,- installSymlinkBinDir= mempty- }- 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 [] ["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))-- ] ++ 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,- installOnly = mempty,- installRootCmd = mempty,- installSummaryFile = mempty,- installLogFile = mempty,- installBuildReports = mempty,- installSymlinkBinDir= mempty- }- mappend a b = InstallFlags {- installDocumentation= combine installDocumentation,- installHaddockIndex = combine installHaddockIndex,- installDryRun = combine installDryRun,- installReinstall = combine installReinstall,- installOnly = combine installOnly,- installRootCmd = combine installRootCmd,- installSummaryFile = combine installSummaryFile,- installLogFile = combine installLogFile,- installBuildReports = combine installBuildReports,- installSymlinkBinDir= combine installSymlinkBinDir- }- 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- }
− cabal-install-0.8.2/Distribution/Client/SetupWrapper.hs
@@ -1,321 +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- , withinRange )-import Distribution.Package- ( PackageIdentifier(..), PackageName(..), Package(..), packageName- , packageVersion, Dependency(..) )-import Distribution.PackageDescription- ( GenericPackageDescription(packageDescription)- , PackageDescription(..), 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.Monoid ( Monoid(mempty) )-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)- (descCabalVersion 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 -> fromMaybe mempty- `fmap` 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
− cabal-install-0.8.2/Distribution/Client/SrcDist.hs
@@ -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
− cabal-install-0.8.2/Distribution/Client/Tar.hs
@@ -1,870 +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 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 =- unpack dir . checkTarbomb expected . read . GZip.decompress =<< 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
− cabal-install-0.8.2/Distribution/Client/Types.hs
@@ -1,148 +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 )-import Distribution.Client.PackageIndex- ( PackageIndex )-import Distribution.Version- ( VersionRange )--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 =-- -- | The unpacked package in the current dir- LocalUnpackedPackage-- -- | 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:--- * generalise local package to any local unpacked package, not just in the--- current dir, ie add a FilePath param--- * 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)--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
− cabal-install-0.8.2/Distribution/Client/Unpack.hs
@@ -1,116 +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, packageId, Dependency(..) )-import Distribution.Client.PackageIndex as PackageIndex (lookupDependency)-import Distribution.Simple.Setup(fromFlag, fromFlagOrDefault)-import Distribution.Simple.Utils- ( notice, die )-import Distribution.Verbosity- ( Verbosity )-import Distribution.Text(display)-import Distribution.Version- ( anyVersion, intersectVersionRanges )--import Distribution.Client.Setup(UnpackFlags(unpackVerbosity,- unpackDestDir))-import Distribution.Client.Types(UnresolvedDependency(..),- Repo, AvailablePackageSource(..),- AvailablePackage(AvailablePackage),- AvailablePackageDb(AvailablePackageDb))-import Distribution.Client.Fetch(fetchPackage)-import qualified Distribution.Client.Tar as Tar (extractTarGzFile)-import Distribution.Client.IndexUtils as IndexUtils- (getAvailablePackages, disambiguateDependencies)--import System.Directory- ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist )-import Control.Monad- ( unless, when )-import Data.Ord (comparing)-import Data.List(maximumBy)-import System.FilePath- ( (</>), addTrailingPathSeparator )-import qualified Data.Map as Map--unpack :: UnpackFlags -> [Repo] -> [Dependency] -> IO ()-unpack flags repos deps - | null deps = notice verbosity- "No packages requested. Nothing to do."- | otherwise = do- db@(AvailablePackageDb available _)- <- getAvailablePackages verbosity repos- deps' <- fmap (map dependency) - . IndexUtils.disambiguateDependencies available - . map toUnresolved $ deps-- let pkgs = resolvePackages db deps'-- unless (null prefix) $- createDirectoryIfMissing True prefix-- flip mapM_ pkgs $ \pkg ->- case pkg of-- Left (Dependency name ver) -> - die $ "There is no available version of " ++ display name - ++ " that satisfies " ++ display ver-- Right (AvailablePackage pkgid _ (RepoTarballPackage repo)) -> do- pkgPath <- fetchPackage verbosity repo pkgid- unpackPackage verbosity prefix pkgid pkgPath-- Right (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- -> [Dependency]- -> [Either Dependency AvailablePackage]-resolvePackages (AvailablePackageDb available prefs) deps =- map (\d -> best d (candidates d)) deps- where- candidates dep@(Dependency name ver) =- let [x,y] = map (PackageIndex.lookupDependency available)- [ Dependency name- (maybe anyVersion id (Map.lookup name prefs)- `intersectVersionRanges` ver)- , dep ]- in if null x then y else x- best d [] = Left d- best _ xs = Right $ maximumBy (comparing packageId) xs-
− cabal-install-0.8.2/Distribution/Client/Update.hs
@@ -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 qualified Codec.Compression.GZip as GZip (decompress)-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- . GZip.decompress- =<< 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"-
− cabal-install-0.8.2/Distribution/Client/Upload.hs
@@ -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"
− cabal-install-0.8.2/Distribution/Client/Utils.hs
@@ -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
− cabal-install-0.8.2/Distribution/Client/Win32SelfUpgrade.hs
@@ -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
− cabal-install-0.8.2/Distribution/Compat/Exception.hs
@@ -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
− cabal-install-0.8.2/LICENSE
@@ -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.
− cabal-install-0.8.2/Paths_cabal_install.hs
@@ -1,8 +0,0 @@-module Paths_cabal_install (- version,- ) where--import Data.Version (Version(..))--version :: Version-version = Version {versionBranch = [0,8,2], versionTags = []}
− cabal-install-0.8.2/cabal-install.cabal
@@ -1,122 +0,0 @@-Name: cabal-install-Version: 0.8.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 <lemmih@gmail.com>- Paolo Martini <paolo@nemail.it>- Bjorn Bringert <bjorn@bringert.net>- Isaac Potoczny-Jones <ijones@syntaxpolice.org>- Duncan Coutts <duncan@haskell.org>-Maintainer: cabal-devel@haskell.org-Copyright: 2005 Lemmih <lemmih@gmail.com>- 2006 Paolo Martini <paolo@nemail.it>- 2007 Bjorn Bringert <bjorn@bringert.net>- 2007 Isaac Potoczny-Jones <ijones@syntaxpolice.org>- 2008-2009 Duncan Coutts <duncan@haskell.org>-Category: Distribution-Build-type: Simple-Extra-Source-Files: README bash-completion/cabal bootstrap.sh-Cabal-Version: >= 1.6-Tested-With: GHC==6.6.1, GHC==6.8.2, GHC==6.10.4, GHC==6.12.1--source-repository head- type: darcs- location: http://darcs.haskell.org/cabal-install/--source-repository this- type: darcs- location: http://darcs.haskell.org/cabal-branches/cabal-install-0.8/- tag: 0.8.2--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.Bogus- Distribution.Client.Dependency.TopDown- Distribution.Client.Dependency.TopDown.Constraints- Distribution.Client.Dependency.TopDown.Types- Distribution.Client.Dependency.Types- Distribution.Client.Fetch- 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.Win32SelfUpgrade- Distribution.Compat.Exception- Paths_cabal_install-- build-depends: base >= 2 && < 5,- Cabal >= 1.8 && < 1.9,- filepath >= 1.0,- network >= 1 && < 3,- HTTP >= 4000.0.2 && < 4001,- zlib >= 0.4 && < 0.6,- time >= 1.1 && < 1.2-- if flag(old-base)- build-depends: base < 3- else- build-depends: base >= 3,- process >= 1 && < 1.1,- directory >= 1 && < 1.1,- pretty >= 1 && < 1.1,- random >= 1 && < 1.1,- containers >= 0.1 && < 0.4,- 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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Anonymous.hs view
@@ -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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Storage.hs view
@@ -0,0 +1,129 @@+-----------------------------------------------------------------------------+-- |+-- 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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Types.hs view
@@ -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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Upload.hs view
@@ -0,0 +1,71 @@+{-# 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 ()
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Check.hs view
@@ -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 . ("* "++)
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Config.hs view
@@ -0,0 +1,519 @@+-----------------------------------------------------------------------------+-- |+-- 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+
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Configure.hs view
@@ -0,0 +1,205 @@+-----------------------------------------------------------------------------+-- |+-- 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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency.hs view
@@ -0,0 +1,318 @@+-----------------------------------------------------------------------------+-- |+-- 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 ]
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown.hs view
@@ -0,0 +1,776 @@+-----------------------------------------------------------------------------+-- |+-- 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'
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Constraints.hs view
@@ -0,0 +1,316 @@+-----------------------------------------------------------------------------+-- |+-- 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 ]
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Types.hs view
@@ -0,0 +1,93 @@+-----------------------------------------------------------------------------+-- |+-- 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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/Types.hs view
@@ -0,0 +1,114 @@+-----------------------------------------------------------------------------+-- |+-- 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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Fetch.hs view
@@ -0,0 +1,259 @@+-----------------------------------------------------------------------------+-- |+-- 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"]+ }
+ cabal-install-0.9.5_rc20101226/Distribution/Client/GZipUtils.hs view
@@ -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:+-- <http://hackage.haskell.org/trac/hackage/ticket/686>+--+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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Haddock.hs view
@@ -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)
+ cabal-install-0.9.5_rc20101226/Distribution/Client/HttpUtils.hs view
@@ -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.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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/IndexUtils.hs view
@@ -0,0 +1,299 @@+-----------------------------------------------------------------------------+-- |+-- 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 ]
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Init.hs view
@@ -0,0 +1,556 @@+{-# 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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Heuristics.hs view
@@ -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, 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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Licenses.hs view
@@ -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."+ , ""+ , " <one line to give the program's name and a brief idea of what it does.>"+ , " Copyright (C) <year> <name of author>"+ , ""+ , " 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."+ , ""+ , " <signature of Ty Coon>, 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. <http://fsf.org/>"+ , " 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."+ , ""+ , " <one line to give the program's name and a brief idea of what it does.>"+ , " Copyright (C) <year> <name of author>"+ , ""+ , " 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 <http://www.gnu.org/licenses/>."+ , ""+ , "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:"+ , ""+ , " <program> Copyright (C) <year> <name of author>"+ , " 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"+ , "<http://www.gnu.org/licenses/>."+ , ""+ , " 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"+ , "<http://www.gnu.org/philosophy/why-not-lgpl.html>."+ , ""+ ]++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."+ , ""+ , " <one line to give the library's name and a brief idea of what it does.>"+ , " Copyright (C) <year> <name of author>"+ , ""+ , " 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."+ , ""+ , " <signature of Ty Coon>, 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. <http://fsf.org/>"+ , " 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."+ ]+
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Types.hs view
@@ -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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Install.hs view
@@ -0,0 +1,940 @@+-----------------------------------------------------------------------------+-- |+-- 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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/InstallPlan.hs view
@@ -0,0 +1,495 @@+-----------------------------------------------------------------------------+-- |+-- 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"
+ cabal-install-0.9.5_rc20101226/Distribution/Client/InstallSymlink.hs view
@@ -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+ ( 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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/List.hs view
@@ -0,0 +1,368 @@+-----------------------------------------------------------------------------+-- |+-- 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)
+ cabal-install-0.9.5_rc20101226/Distribution/Client/PackageIndex.hs view
@@ -0,0 +1,479 @@+-----------------------------------------------------------------------------+-- |+-- 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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/PackageUtils.hs view
@@ -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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Setup.hs view
@@ -0,0 +1,952 @@+-----------------------------------------------------------------------------+-- |+-- 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+ }
+ cabal-install-0.9.5_rc20101226/Distribution/Client/SetupWrapper.hs view
@@ -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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/SrcDist.hs view
@@ -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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Tar.hs view
@@ -0,0 +1,871 @@+{-# 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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Types.hs view
@@ -0,0 +1,211 @@+-----------------------------------------------------------------------------+-- |+-- 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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Unpack.hs view
@@ -0,0 +1,138 @@+-----------------------------------------------------------------------------+-- |+-- 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 ]
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Update.hs view
@@ -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(..), 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"+
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Upload.hs view
@@ -0,0 +1,177 @@+-- 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"
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Utils.hs view
@@ -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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/Win32SelfUpgrade.hs view
@@ -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
+ cabal-install-0.9.5_rc20101226/Distribution/Client/World.hs view
@@ -0,0 +1,132 @@+-----------------------------------------------------------------------------+-- |+-- 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
+ cabal-install-0.9.5_rc20101226/Distribution/Compat/Exception.hs view
@@ -0,0 +1,56 @@+{-# 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
+ cabal-install-0.9.5_rc20101226/LICENSE view
@@ -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.
+ cabal-install-0.9.5_rc20101226/Main.hs view
@@ -0,0 +1,388 @@+-----------------------------------------------------------------------------+-- |+-- 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)
+ cabal-install-0.9.5_rc20101226/Paths_cabal_install.hs view
@@ -0,0 +1,8 @@+module Paths_cabal_install (+ version,+ ) where++import Data.Version (Version(..))++version :: Version+version = Version {versionBranch = [0,9,5], versionTags = []}
+ cabal-install-0.9.5_rc20101226/README view
@@ -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.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.
+ cabal-install-0.9.5_rc20101226/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal-install-0.9.5_rc20101226/bash-completion/cabal view
@@ -0,0 +1,24 @@+# cabal command line completion+# Copyright 2007-2008 "Lennart Kolmodin" <kolmodin@gentoo.org>+# "Duncan Coutts" <dcoutts@gentoo.org>+#++_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
+ cabal-install-0.9.5_rc20101226/bootstrap.sh view
@@ -0,0 +1,241 @@+#!/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
+ cabal-install-0.9.5_rc20101226/cabal-install.cabal view
@@ -0,0 +1,117 @@+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 <lemmih@gmail.com>+ Paolo Martini <paolo@nemail.it>+ Bjorn Bringert <bjorn@bringert.net>+ Isaac Potoczny-Jones <ijones@syntaxpolice.org>+ Duncan Coutts <duncan@haskell.org>+Maintainer: cabal-devel@haskell.org+Copyright: 2005 Lemmih <lemmih@gmail.com>+ 2006 Paolo Martini <paolo@nemail.it>+ 2007 Bjorn Bringert <bjorn@bringert.net>+ 2007 Isaac Potoczny-Jones <ijones@syntaxpolice.org>+ 2007-2010 Duncan Coutts <duncan@haskell.org>+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
+ cabal-install-0.9.5_rc20101226/changelog view
@@ -0,0 +1,100 @@+-*-change-log-*-++0.8.0 Duncan Coutts <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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
+ cabal-install-0.9.5_rc20101226/tests/test-cabal-install view
@@ -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
+ cabal-install-0.9.5_rc20101226/tests/test-cabal-install-user view
@@ -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
hackport.cabal view
@@ -1,5 +1,5 @@ Name: hackport-Version: 0.2.9+Version: 0.2.10 License: GPL License-file: LICENSE Author: Henning Günther, Duncan Coutts, Lennart Kolmodin@@ -9,7 +9,7 @@ Description: A command line tool to manage an overlay of Gentoo ebuilds that are generated from a hackage repo of Cabal packages. Build-Type: Simple-Cabal-Version: >=1.8+Cabal-Version: >=1.10 source-repository head type: darcs@@ -19,7 +19,8 @@ Executable hackport Main-Is: Main.hs- Hs-Source-Dirs: ., cabal-install-0.8.2+ Default-Language: Haskell98+ Hs-Source-Dirs: ., cabal-install-0.9.5_rc20101226 Build-Depends: base >= 2.0 && < 5, filepath,@@ -28,15 +29,27 @@ network, pretty, regex-compat,- Cabal == 1.8.*,+ Cabal == 1.10.*, HTTP >= 4000.0.3, zlib, tar,+ xml>1.3.5, array, -- array is inherited from cabal-install -- tar >= 0.3.0.0 && < 0.4 extensible-exceptions + -- extensions due to hackport+ other-extensions:+ DeriveDataTypeable,+ PatternGuards++ -- extensions due to bundled cabal-install+ other-extensions:+ CPP,+ ForeignFunctionInterface,+ PatternGuards+ if flag(split-base) Build-Depends: base >= 3 && < 5,@@ -58,12 +71,11 @@ Error Paths_hackport Main- MaybeRead Overlays- P2 Portage Portage.Version Portage.Dependency+ Portage.GHCCore Portage.PackageId Portage.Overlay Portage.Resolve@@ -73,3 +85,42 @@ Status Merge Util+++Executable hackport-guess-ghc-version+ Main-Is: Main-GuessGHC.hs+ Default-Language: Haskell98+ Buildable: False+ -- this was used as a test while developing the+ -- ghc-guessfeature. now we can disable building+ Build-Depends:+ base >= 2.0 && < 5,+ filepath,+ parsec,+ mtl,+ network,+ pretty,+ regex-compat,+ Cabal > 1.8 && < 1.11,+ HTTP >= 4000.0.3,+ zlib,+ tar,+ array,+ -- array is inherited from cabal-install + -- tar >= 0.3.0.0 && < 0.4+ extensible-exceptions++ if flag(split-base)+ Build-Depends:+ base >= 3 && < 5,+ directory,+ containers,+ process,+ old-time,+ bytestring+ else+ Build-Depends: base < 3++ ghc-options: -Wall+ other-modules:+ Portage.GHCCore