summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLennartKolmodin <>2010-05-23 21:07:04 (GMT)
committerLuite Stegeman <luite@luite.com>2010-05-23 21:07:04 (GMT)
commit1985899a588577277edfbf8ebf4168b2e3a0bb5a (patch)
treec428ab19e52212ae24c94997445f8c4329c756ea
parent798faf2f4fc74cddc57c6a010ab65448c4067da8 (diff)
version 0.2.60.2.6
-rw-r--r--Action.hs121
-rw-r--r--Bash.hs45
-rw-r--r--BlingBling.hs45
-rw-r--r--Cabal2Ebuild.hs269
-rw-r--r--Cache.hs93
-rw-r--r--Config.hs125
-rw-r--r--Diff.hs234
-rw-r--r--DistroMap.hs159
-rw-r--r--Error.hs19
-rw-r--r--GenerateEbuild.hs60
-rw-r--r--Index.hs45
-rw-r--r--LICENSE674
-rw-r--r--Main.hs687
-rw-r--r--Merge.hs378
-rw-r--r--Overlays.hs102
-rw-r--r--P2.hs14
-rw-r--r--Package.hs76
-rw-r--r--Portage/Cabal.hs15
-rw-r--r--Portage/Dependency.hs145
-rw-r--r--Portage/Host.hs102
-rw-r--r--Portage/Overlay.hs169
-rw-r--r--Portage/PackageId.hs113
-rw-r--r--Portage/Resolve.hs72
-rw-r--r--Portage/Version.hs86
-rw-r--r--Progress.hs62
-rw-r--r--README111
-rw-r--r--Status.hs66
-rw-r--r--TODO35
-rw-r--r--Util.hs31
-rw-r--r--Utils.hs7
-rw-r--r--Version.hs122
-rw-r--r--cabal-install-0.8.2/Distribution/Client/BuildReports/Anonymous.hs311
-rw-r--r--cabal-install-0.8.2/Distribution/Client/BuildReports/Storage.hs129
-rw-r--r--cabal-install-0.8.2/Distribution/Client/BuildReports/Types.hs44
-rw-r--r--cabal-install-0.8.2/Distribution/Client/BuildReports/Upload.hs71
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Check.hs85
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Config.hs565
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Configure.hs205
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Dependency.hs233
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Dependency/Bogus.hs129
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Dependency/TopDown.hs776
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Constraints.hs316
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Types.hs93
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Dependency/Types.hs114
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Fetch.hs192
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Haddock.hs101
-rw-r--r--cabal-install-0.8.2/Distribution/Client/HttpUtils.hs197
-rw-r--r--cabal-install-0.8.2/Distribution/Client/IndexUtils.hs301
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Init.hs556
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Init/Heuristics.hs187
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Init/Licenses.hs1722
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Init/Types.hs152
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Install.hs786
-rw-r--r--cabal-install-0.8.2/Distribution/Client/InstallPlan.hs495
-rw-r--r--cabal-install-0.8.2/Distribution/Client/InstallSymlink.hs238
-rw-r--r--cabal-install-0.8.2/Distribution/Client/List.hs368
-rw-r--r--cabal-install-0.8.2/Distribution/Client/PackageIndex.hs479
-rw-r--r--cabal-install-0.8.2/Distribution/Client/PackageUtils.hs34
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Setup.hs876
-rw-r--r--cabal-install-0.8.2/Distribution/Client/SetupWrapper.hs321
-rw-r--r--cabal-install-0.8.2/Distribution/Client/SrcDist.hs80
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Tar.hs870
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Types.hs148
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Unpack.hs116
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Update.hs82
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Upload.hs177
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Utils.hs60
-rw-r--r--cabal-install-0.8.2/Distribution/Client/Win32SelfUpgrade.hs222
-rw-r--r--cabal-install-0.8.2/Distribution/Compat/Exception.hs56
-rw-r--r--cabal-install-0.8.2/LICENSE34
-rw-r--r--cabal-install-0.8.2/Paths_cabal_install.hs8
-rw-r--r--cabal-install-0.8.2/cabal-install.cabal122
-rw-r--r--cabal2ebuild.hs17
-rw-r--r--hackport.cabal45
-rw-r--r--tests/resolveCat.hs21
-rw-r--r--unused/Fetch.hs (renamed from Fetch.hs)33
76 files changed, 15263 insertions, 1186 deletions
diff --git a/Action.hs b/Action.hs
deleted file mode 100644
index 0b18752..0000000
--- a/Action.hs
+++ /dev/null
@@ -1,121 +0,0 @@
-module Action where
-
-import Config
-import Error
-
-import Control.Monad.State
-import Control.Monad.Error
-import Network.URI (parseURI)
-import System.IO
-import System.Environment
-
-type HPAction = ErrorT HackPortError (StateT HPState IO)
-
-data HPState = HPState
- { config :: Config
- , indention :: Int
- }
-
-verbose :: HPAction a -> (String,a->String) -> HPAction a
-verbose action (premsg,postmsg) = do
- echoIndent
- echo premsg
- flush
- res <- indent action
- echoLn (postmsg res)
- return res
-
-sayNormal :: HPAction a -> (String,a->String) -> HPAction a
-sayNormal action strs = do
- cfg <- getCfg
- case verbosity cfg of
- Silent -> action
- _ -> action `verbose` strs
-
-sayDebug :: HPAction a -> (String,a->String) -> HPAction a
-sayDebug action strs = do
- cfg <- getCfg
- case verbosity cfg of
- Debug -> action `verbose` strs
- _ -> action
-
-info :: String -> HPAction ()
-info str = do
- cfg <- getCfg
- case verbosity cfg of
- Silent -> return ()
- _ -> echoLn str
-
--- | Prints a string iff in debug output mode
-whisper :: String -> HPAction ()
-whisper str = do
- cfg <- getCfg
- case verbosity cfg of
- Debug -> echoLn str
- _ -> return ()
-
-getCfg :: HPAction Config
-getCfg = gets config
-
-setOverlayPath :: Maybe String -> HPAction ()
-setOverlayPath mt = modify $ \hps ->
- hps { config = (config hps) { overlayPath = mt } }
-
-setPortagePath :: Maybe String -> HPAction ()
-setPortagePath mt = modify $ \hps ->
- hps { config = (config hps) { portagePath = mt } }
-
-lessIndent :: HPAction ()
-lessIndent = modify $ \s -> s { indention = indention s - 1 }
-
-moreIndent :: HPAction ()
-moreIndent = modify $ \s -> s { indention = indention s + 1 }
-
-echoIndent :: HPAction ()
-echoIndent = do
- ind <- gets indention
- echo (replicate ind '\t')
-
-indent :: HPAction a -> HPAction a
-indent action = do
- moreIndent
- res <- action
- lessIndent
- return res
-
-echo :: String -> HPAction ()
-echo str = liftIO $ hPutStr stderr str
-
-flush :: HPAction ()
-flush = liftIO (hFlush stderr)
-
-echoLn :: String -> HPAction ()
-echoLn str = echoIndent >> echo str >> liftIO (hPutChar stderr '\n')
-
-loadConfig :: HPAction OperationMode
-loadConfig = do
- args <- liftIO getArgs
- case parseConfig args of
- Left errmsg -> throwError (ArgumentError errmsg)
- Right (opts,opmode) -> do
- cfg <- foldM optionToConfig defaultConfig opts
- modify $ \s -> s { config = cfg }
- return opmode
-
-optionToConfig :: Config -> HackPortOptions -> HPAction Config
-optionToConfig cfg opt = case opt of
- OverlayPath str -> return cfg { overlayPath = Just str }
- PortagePath str -> return cfg { portagePath = Just str }
- Server str -> case parseURI str of
- Nothing -> throwError (InvalidServer str)
- Just uri -> return cfg { server = uri }
- TempDir str -> return cfg { tmp = str }
- Verbosity str -> case parseVerbosity str of
- Nothing -> throwError (UnknownVerbosityLevel str)
- Just verb -> return cfg { verbosity=verb }
- Help -> return cfg
- RefreshCache -> return cfg { refreshCache = True }
-
-performHPAction :: HPAction a -> IO (Either HackPortError a)
-performHPAction action =
- evalStateT (runErrorT action) (HPState defaultConfig 0)
diff --git a/Bash.hs b/Bash.hs
deleted file mode 100644
index 4fe703b..0000000
--- a/Bash.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-module Bash where
-
-import Control.Monad.Error
-import System.Process
-import System.Directory
-import System.IO
-import System.Exit
-
-import Action
-import Config
-import Error
-
-getSystemPortdir :: HPAction String
-getSystemPortdir = do
- dir <- runBash "source /etc/make.conf;echo -n $PORTDIR"
- case dir of
- "" -> return "/usr/portage"
- _ -> return dir
-
-getPortdir :: HPAction String
-getPortdir = do
- cfg <- getCfg
- case portagePath cfg of
- Just dir -> return dir
- Nothing -> do
- sys <- getSystemPortdir
- setPortagePath (Just sys)
- return sys
-
-runBash ::
- String -> -- ^ The command line
- HPAction String -- ^ The command-line's output
-runBash command = do
- mpath <- liftIO $ findExecutable "bash"
- bash <- maybe (throwError BashNotFound) return mpath
- (inp,outp,err,pid) <- liftIO $ runInteractiveProcess bash ["-c",command] Nothing Nothing
- liftIO $ hClose inp
- result <- liftIO $ hGetContents outp
- errors <- liftIO $ hGetContents err
- length result `seq` liftIO (hClose outp)
- length errors `seq` liftIO (hClose err)
- exitCode <- liftIO $ waitForProcess pid
- case exitCode of
- ExitFailure _ -> throwError $ BashError errors
- ExitSuccess -> return result
diff --git a/BlingBling.hs b/BlingBling.hs
index 14a75b1..23ad2ff 100644
--- a/BlingBling.hs
+++ b/BlingBling.hs
@@ -1,15 +1,52 @@
module BlingBling where
+import qualified Progress
+
import System.IO
+import Control.Exception as Exception (bracket)
-- what nobody needs but everyone wants...
-- FIXME: do something more fun here
forMbling :: [a] -> (a -> IO b) -> IO [b]
-forMbling lst f = do
- origBuffering <- hGetBuffering stdout
- hSetBuffering stdout NoBuffering
+forMbling lst f =
+ withBuffering stdout NoBuffering $ do
xs <- mapM (\x -> putStr "." >> f x) lst
putStrLn ""
- hSetBuffering stdout origBuffering
return xs
+
+blingProgress :: Progress.Progress s String a -> IO a
+blingProgress progress = do
+ isTerm <- hIsTerminalDevice stdout
+ if isTerm
+ then canIHasTehBling
+ else boring
+
+ where
+ boring = Progress.fold (flip const) fail return progress
+
+ canIHasTehBling =
+ withBuffering stdout NoBuffering $ do
+ putChar (fst (char 0))
+ result <- spin 0 progress
+ putStr "\b \b"
+ return result
+
+ spin _ (Progress.Fail e) = fail e
+ spin _ (Progress.Done r) = return r
+ spin n (Progress.Step _ p) = do
+ putStr ['\b', c]
+ spin n' p
+ where (c, n') = char n
+
+ char :: Int -> (Char, Int)
+ char 0 = ('/', 1)
+ char 1 = ('-', 2)
+ char 2 = ('\\', 3)
+ char _ = ('|', 0)
+
+withBuffering :: Handle -> BufferMode -> IO a -> IO a
+withBuffering hnd mode action =
+ Exception.bracket
+ (hGetBuffering hnd) (hSetBuffering hnd)
+ (\_ -> hSetBuffering hnd mode >> action)
diff --git a/Cabal2Ebuild.hs b/Cabal2Ebuild.hs
index 5511204..e8034de 100644
--- a/Cabal2Ebuild.hs
+++ b/Cabal2Ebuild.hs
@@ -23,21 +23,24 @@
--
module Cabal2Ebuild
(EBuild(..)
+ ,Dependency(..)
,cabal2ebuild
+ ,convertDependencies
,showEBuild) where
import qualified Distribution.PackageDescription as Cabal
(PackageDescription(..))
-import qualified Distribution.Package as Cabal (PackageIdentifier(..), Dependency(..))
-import qualified Distribution.Version as Cabal (VersionRange(..), versionBranch, Version)
+import qualified Distribution.Package as Cabal (PackageIdentifier(..)
+ , Dependency(..)
+ , PackageName(..))
+import qualified Distribution.Version as Cabal (VersionRange, foldVersionRange', versionBranch, Version)
import qualified Distribution.License as Cabal (License(..))
import qualified Distribution.Text as Cabal (display)
---import qualified Distribution.Compiler as Cabal (CompilerFlavor(..))
import Data.Char (toLower,isUpper)
-import Data.List (intercalate, groupBy, partition, nub, sortBy, init, last)
-import Data.Ord (comparing)
-import Data.Maybe (catMaybes, fromJust)
+
+import Portage.Dependency
+import Portage.Version
data EBuild = EBuild {
name :: String,
@@ -49,27 +52,19 @@ data EBuild = EBuild {
slot :: String,
keywords :: [String],
iuse :: [String],
- depend :: [Dependency],
+ haskell_deps :: [Dependency],
+ build_tools :: [Dependency],
+ extra_libs :: [Dependency],
+ cabal_dep :: Dependency,
+ ghc_dep :: Dependency,
+ depend :: [String],
+ rdepend :: [String],
features :: [String],
-- comments on various fields for communicating stuff to the user
licenseComments :: String,
my_pn :: Maybe String --If the package's name contains upper-case
}
-type Package = String
-newtype Version = Version [Int] deriving (Ord, Eq)
-type UseFlag = String
-data Dependency = AnyVersionOf Package
- | ThisVersionOf Version Package -- =package-version
- | LaterVersionOf Version Package -- >package-version
- | EarlierVersionOf Version Package -- <package-version
- | OrLaterVersionOf Version Package -- >=package-version
- | OrEarlierVersionOf Version Package -- <=package-version
- | DependEither Dependency Dependency -- depend || depend
- | DependIfUse UseFlag Dependency -- use? ( depend )
- | ThisMajorOf Version Package -- =package-version*
- deriving Eq
-
ebuildTemplate :: EBuild
ebuildTemplate = EBuild {
name = "foobar",
@@ -81,14 +76,18 @@ ebuildTemplate = EBuild {
slot = "0",
keywords = ["~amd64","~x86"],
iuse = [],
+ haskell_deps = [],
+ build_tools = [],
+ extra_libs = [],
+ cabal_dep = AnyVersionOf "dev-haskell/cabal",
+ ghc_dep = defaultDepGHC,
depend = [],
+ rdepend = [],
features = [],
licenseComments = "",
my_pn = Nothing
}
-
-
cabal2ebuild :: Cabal.PackageDescription -> EBuild
cabal2ebuild pkg = ebuildTemplate {
name = map toLower cabalPkgName,
@@ -99,29 +98,32 @@ cabal2ebuild pkg = ebuildTemplate {
src_uri = Cabal.pkgUrl pkg,
license = convertLicense (Cabal.license pkg),
licenseComments = licenseComment (Cabal.license pkg),
- depend = defaultDepGHC
- : (simplify_deps $
- convertDependency (Cabal.Dependency "Cabal"
- (Cabal.descCabalVersion pkg))
- ++ convertDependencies (Cabal.buildDepends pkg)),
+ haskell_deps = simplify_deps $ convertDependencies (Cabal.buildDepends pkg),
+ cabal_dep = head $ convertDependency (Cabal.Dependency (Cabal.PackageName "Cabal")
+ (Cabal.descCabalVersion pkg)),
my_pn = if any isUpper cabalPkgName then Just cabalPkgName else Nothing,
features = features ebuildTemplate
- ++ (if null (Cabal.executables pkg) then [] else ["bin"])
- ++ maybe [] (const ["lib","profile","haddock"]) (Cabal.library pkg)
+ ++ (if hasExe then ["bin"] else [])
+ ++ maybe [] (const (["lib","profile","haddock"]
+ ++ if cabalPkgName == "hscolour" then [] else ["hscolour"])
+ ) (Cabal.library pkg) -- hscolour can't colour its own sources
} where
- cabalPkgName = Cabal.pkgName (Cabal.package pkg)
+ cabalPkgName = Cabal.display $ Cabal.pkgName (Cabal.package pkg)
+ -- hasLib = isJust (Cabal.library pkg)
+ hasExe = (not . null) (Cabal.executables pkg)
defaultDepGHC :: Dependency
-defaultDepGHC = OrLaterVersionOf (Version [6,6,1]) "dev-lang/ghc"
+defaultDepGHC = OrLaterVersionOf (Version [6,8,1] Nothing [] 0) "dev-lang/ghc"
-- map the cabal license type to the gentoo license string format
convertLicense :: Cabal.License -> String
-convertLicense Cabal.GPL = "GPL-2" -- almost certainly version 2
-convertLicense Cabal.LGPL = "LGPL-2.1" -- probably version 2.1
-convertLicense Cabal.BSD3 = "BSD" -- do we really not
-convertLicense Cabal.BSD4 = "BSD" -- distinguish between these?
+convertLicense (Cabal.GPL mv) = "GPL-" ++ (maybe "2" Cabal.display mv) -- almost certainly version 2
+convertLicense (Cabal.LGPL mv) = "LGPL-" ++ (maybe "2.1" Cabal.display mv) -- probably version 2.1
+convertLicense Cabal.BSD3 = "BSD"
+convertLicense Cabal.BSD4 = "BSD-4"
convertLicense Cabal.PublicDomain = "public-domain"
convertLicense Cabal.AllRightsReserved = ""
+convertLicense Cabal.MIT = "MIT"
convertLicense _ = ""
licenseComment :: Cabal.License -> String
@@ -135,46 +137,48 @@ convertDependencies :: [Cabal.Dependency] -> [Dependency]
convertDependencies = concatMap convertDependency
convertDependency :: Cabal.Dependency -> [Dependency]
-convertDependency (Cabal.Dependency pname _)
+convertDependency (Cabal.Dependency pname@(Cabal.PackageName _name) _)
| pname `elem` coreLibs = [] -- no explicit dep on core libs
convertDependency (Cabal.Dependency pname versionRange)
- = case versionRange of
- (Cabal.IntersectVersionRanges v1 v2) -> [convert v1, convert v2]
- v -> [convert v]
-
+ = convert versionRange
where
- ebuildName = "dev-haskell/" ++ map toLower pname
-
- convert :: Cabal.VersionRange -> Dependency
- convert Cabal.AnyVersion = AnyVersionOf ebuildName
- convert (Cabal.ThisVersion v) = ThisVersionOf (cabalVtoHPv v) ebuildName
- convert (Cabal.LaterVersion v) = LaterVersionOf (cabalVtoHPv v) ebuildName
- convert (Cabal.EarlierVersion v) = EarlierVersionOf (cabalVtoHPv v) ebuildName
- convert (Cabal.UnionVersionRanges (Cabal.ThisVersion v1) (Cabal.LaterVersion v2))
- | v1 == v2 = OrLaterVersionOf (cabalVtoHPv v1) ebuildName
- convert (Cabal.UnionVersionRanges (Cabal.ThisVersion v1) (Cabal.EarlierVersion v2))
- | v1 == v2 = OrEarlierVersionOf (cabalVtoHPv v1) ebuildName
- convert (Cabal.UnionVersionRanges r1 r2)
- = DependEither (convert r1) (convert r2)
-
--- converts Cabal versiion type to hackopr version
+ -- XXX: not always true, we should look properly for deps in the overlay
+ -- to find the correct category
+ ebuildName = "dev-haskell/" ++ map toLower (Cabal.display pname)
+ convert :: Cabal.VersionRange -> [Dependency]
+ convert = Cabal.foldVersionRange'
+ ( [AnyVersionOf ebuildName] -- ^ @\"-any\"@ version
+ )(\v -> [ThisVersionOf (cabalVtoHPv v) ebuildName] -- ^ @\"== v\"@
+ )(\v -> [LaterVersionOf (cabalVtoHPv v) ebuildName] -- ^ @\"> v\"@
+ )(\v -> [EarlierVersionOf (cabalVtoHPv v) ebuildName] -- ^ @\"< v\"@
+ )(\v -> [OrLaterVersionOf (cabalVtoHPv v) ebuildName] -- ^ @\">= v\"@
+ )(\v -> [OrEarlierVersionOf (cabalVtoHPv v) ebuildName] -- ^ @\"<= v\"@
+{- FIXME -} )(\v1 _ -> [ThisMajorOf (cabalVtoHPv v1) ebuildName] -- ^ @\"== v.*\"@ wildcard. (incl lower, excl upper)
+ )(\r1 r2 -> case (r1,r2) of
+ ([r1'], [r2']) -> [DependEither r1' r2'] -- ^ @\"_ || _\"@ union
+ _ -> error "convertDependency: compound either"
+ )(\r1 r2 -> r1 ++ r2
+ )
+
+-- converts Cabal version type to hackport version
cabalVtoHPv :: Cabal.Version -> Version
-cabalVtoHPv = Version . Cabal.versionBranch
-
-instance Show Version where
- show (Version v) = intercalate "." $ map show v
+cabalVtoHPv = (\v -> Version v Nothing [] 0) . Cabal.versionBranch
-coreLibs :: [String]
-coreLibs =
+coreLibs :: [Cabal.PackageName]
+coreLibs = map Cabal.PackageName
["array"
,"base"
---,"bytestring" --already has ebuild
+ ,"bytestring" -- intentionally no ebuild. use ghc's version
+ -- to avoid dreaded 'diamond dependency' problem
,"containers"
,"directory"
---,"filepath" --already has ebuild
+ --,"editline"
+ ,"filepath" -- intentionally no ebuild. use ghc's version
,"ghc"
+ ,"ghc-prim"
,"haskell98"
,"hpc" --has ebuild, but only in the overlay
+ ,"integer"
,"old-locale"
,"old-time"
,"packedstring"
@@ -183,13 +187,14 @@ coreLibs =
,"random"
,"readline" --has ebuild, but only in the overlay
,"rts"
+ ,"syb" -- intentionally no ebuild. use ghc's version
,"template-haskell"
,"unix" --has ebuild, but only in the overlay
]
showEBuild :: EBuild -> String
showEBuild ebuild =
- ss "# Copyright 1999-2008 Gentoo Foundation". nl.
+ ss "# Copyright 1999-2010 Gentoo Foundation". nl.
ss "# Distributed under the terms of the GNU General Public License v2". nl.
ss "# $Header: $". nl.
nl.
@@ -213,27 +218,26 @@ showEBuild ebuild =
ss "KEYWORDS=". quote' (sepBy " " $ keywords ebuild).nl.
ss "IUSE=". quote' (sepBy ", " $ iuse ebuild). nl.
nl.
- ss "DEPEND=". quote' (sepBy "\n\t\t" $ map showDepend $ depend ebuild). nl.
+ ( if (not . null . build_tools $ ebuild)
+ then ss "BUILDTOOLS=". quote' (sepBy "\n\t\t" $ map showDepend $ build_tools ebuild). nl
+ else id
+ ).
+ ( if (not . null . extra_libs $ ebuild )
+ then ss "EXTRALIBS=". quote' (sepBy "\n\t\t" $ map showDepend $ extra_libs ebuild). nl
+ else id
+ ).
+ ( if (not . null . haskell_deps $ ebuild)
+ then ss "HASKELLDEPS=". quote' (sepBy "\n\t\t" $ map showDepend $ haskell_deps ebuild). nl
+ else id
+ ).
+ ss "RDEPEND=". quote' (sepBy "\n\t\t" $ rdepend ebuild). nl.
+ ss "DEPEND=". quote' (sepBy "\n\t\t" $ depend ebuild). nl.
(case my_pn ebuild of
Nothing -> id
Just _ -> nl. ss "S=". quote ("${WORKDIR}/${MY_P}"). nl)
$ []
where replaceVars = replaceCommonVars (name ebuild) (my_pn ebuild) (version ebuild)
-showDepend :: Dependency -> Package
-showDepend (AnyVersionOf p) = p
-showDepend (ThisVersionOf v p) = "~" ++ p ++ "-" ++ show v
-showDepend (LaterVersionOf v p) = ">" ++ p ++ "-" ++ show v
-showDepend (EarlierVersionOf v p) = "<" ++ p ++ "-" ++ show v
-showDepend (OrLaterVersionOf v p) = ">=" ++ p ++ "-" ++ show v
-showDepend (OrEarlierVersionOf v p) = "<=" ++ p ++ "-" ++ show v
-showDepend (DependEither dep1 dep2) = showDepend dep1
- ++ " || " ++ showDepend dep2
-showDepend (DependIfUse useflag dep@(DependEither _ _))
- = useflag ++ "? " ++ showDepend dep
-showDepend (DependIfUse useflag dep) = useflag ++ "? ( " ++ showDepend dep++ " )"
-showDepend (ThisMajorOf v p) = "=" ++ p ++ "-" ++ show v ++ "*"
-
ss :: String -> String -> String
ss = showString
@@ -294,108 +298,3 @@ replaceCommonVars pn mypn pv str
++[("${PN}",pn)]
++ maybe [] (\x->[("${MY_PN}",x)]) mypn
++[("${PV}",pv)]) str
-
-
-{- Here goes code for dependencies simplification -}
-
-simplify_group_table :: Package ->
- Maybe Version ->
- Maybe Version ->
- Maybe Version ->
- Maybe Version ->
- Maybe Version -> [Dependency]
-
--- simplify_group_table p ol l e oe exact
--- 1) trivial cases:
-simplify_group_table p Nothing Nothing Nothing Nothing Nothing = error $ p ++ ": unsolvable constraints"
-simplify_group_table p (Just v) Nothing Nothing Nothing Nothing = [OrLaterVersionOf v p]
-simplify_group_table p Nothing (Just v) Nothing Nothing Nothing = [LaterVersionOf v p]
-simplify_group_table p Nothing Nothing (Just v) Nothing Nothing = [EarlierVersionOf v p]
-simplify_group_table p Nothing Nothing Nothing (Just v) Nothing = [OrEarlierVersionOf v p]
-simplify_group_table p Nothing Nothing Nothing Nothing (Just v) = [ThisVersionOf v p]
-
--- 2) simplification passes
-simplify_group_table p (Just (Version v1)) Nothing (Just (Version v2)) Nothing Nothing
- -- specian case: >=a-v.N a<v.(N+1) => =a-v.N*
- | (init v1 == init v2) && (last v2 == last v1 + 1) = [ThisMajorOf (Version v1) p]
- | otherwise = [OrLaterVersionOf (Version v1) p, EarlierVersionOf (Version v2) p]
-
--- TODO: simplify constraints of type: >=a-v1; > a-v2 and such
-
--- o3) therwise sink:
-simplify_group_table p (Just v) l@(_) e@(_) oe@(_) exact@(_) = OrLaterVersionOf v p : simplify_group_table p Nothing l e oe exact
-simplify_group_table p ol@(Nothing) (Just v) e@(_) oe@(_) exact@(_) = LaterVersionOf v p : simplify_group_table p ol Nothing e oe exact
-simplify_group_table p ol@(Nothing) l@(Nothing) (Just v) oe@(_) exact@(_) = EarlierVersionOf v p : simplify_group_table p ol l Nothing oe exact
-simplify_group_table p ol@(Nothing) l@(Nothing) e@(Nothing) (Just v) exact@(_) = OrEarlierVersionOf v p : simplify_group_table p ol l e Nothing exact
--- already defined earlier
--- simplify_group_table p ol@(Nothing) l@(Nothing) e@(Nothing) oe@(Nothing) (Just v) = OrEarlierVersionOf v p : simplify_group_table p ol l e oe Nothing
-
--- >a-v1 >a-v2 => >a-(max v1 v2)
--- key idea: all constraints are enforcing constraints, so we can't get
--- more, than one interval.
-simplify_group :: [Dependency] -> [Dependency]
-simplify_group [dep@(AnyVersionOf _package)] = [dep]
-simplify_group deps = simplify_group_table package
- min_or_later_v -- >=
- min_later_v -- >
- max_earlier_v -- <
- max_or_earlier_v -- <=
- exact_this_v -- ==
- where
- package = fromJust.getPackage $ head deps
- max_earlier_v = safe_minimum $ map earlier_v deps
- max_or_earlier_v = safe_minimum $ map or_earlier_v deps
- min_later_v = safe_maximum $ map later_v deps
- min_or_later_v = safe_maximum $ map or_later_v deps
- exact_this_v = case catMaybes (map this_v deps) of
- [] -> Nothing
- [v] -> Just v
- xs -> error $ "too many exact versions:" ++ show xs
- --
- earlier_v (EarlierVersionOf v _p) = Just v
- earlier_v _ = Nothing
-
- or_earlier_v (OrEarlierVersionOf v _p) = Just v
- or_earlier_v _ = Nothing
-
- later_v (LaterVersionOf v _p) = Just v
- later_v _ = Nothing
-
- or_later_v (OrLaterVersionOf v _p) = Just v
- or_later_v _ = Nothing
-
- this_v (ThisVersionOf v _p) = Just v
- this_v _ = Nothing
- --
- safe_minimum xs = case catMaybes xs of
- [] -> Nothing
- xs' -> Just $ minimum xs'
- safe_maximum xs = case catMaybes xs of
- [] -> Nothing
- xs' -> Just $ maximum xs'
-
--- divide packages to groups (by package name), simplify groups, merge again
-simplify_deps :: [Dependency] -> [Dependency]
-simplify_deps deps = (concatMap (simplify_group.nub) $
- groupBy cmpPkgName $
- sortBy (comparing getPackageString) groupable)
- ++ ungroupable
- where (ungroupable, groupable) = partition ((==Nothing).getPackage) deps
- --
- cmpPkgName p1 p2 = cmpMaybe (getPackage p1) (getPackage p2)
- cmpMaybe (Just p1) (Just p2) = p1 == p2
- cmpMaybe _ _ = False
- --
-getPackage :: Dependency -> Maybe Package
-getPackage (AnyVersionOf package) = Just package
-getPackage (ThisVersionOf _version package) = Just package
-getPackage (LaterVersionOf _version package) = Just package
-getPackage (EarlierVersionOf _version package) = Just package
-getPackage (OrLaterVersionOf _version package) = Just package
-getPackage (OrEarlierVersionOf _version package) = Just package
-getPackage (DependEither _dependency _Dependency) = Nothing
-getPackage (DependIfUse _useFlag _Dependency) = Nothing
-getPackage (ThisMajorOf _version package) = Just package
---
-getPackageString :: Dependency -> Package
-getPackageString dep = maybe "" id $ getPackage dep
diff --git a/Cache.hs b/Cache.hs
deleted file mode 100644
index 3cc5051..0000000
--- a/Cache.hs
+++ /dev/null
@@ -1,93 +0,0 @@
-module Cache where
-
-import Action
-import CacheFile
-import Config
-import Error
-import Index
-import P2
-import Version
-import Overlays
-
-import Distribution.Text ( simpleParse )
-
-import Control.Arrow
-import Data.Char
-import Data.List
-import Network.URI (URI, uriPath)
-import Network.HTTP (Request(..), RequestMethod(GET), simpleHTTP, rspBody)
-import qualified Data.ByteString.Lazy as L
-import System.Time
-import System.FilePath
-import Control.Monad.Error(throwError)
-import Control.Monad.Writer
-import Control.Monad (unless)
-import System.Directory (doesFileExist,createDirectoryIfMissing)
-
-import qualified Data.Map as Map
-
--- | A long time. Used in checkCacheDate
-alarmingLongTime :: TimeDiff
-alarmingLongTime = TimeDiff
- { tdYear = 0
- , tdMonth = 0
- , tdDay = 7
- , tdHour = 0
- , tdMin = 0
- , tdSec = 0
- , tdPicosec = 0
- }
-
-cacheURI :: URI -> URI
-cacheURI uri = uri {uriPath = uriPath uri </> indexFile}
-
-updateCache :: HPAction ()
-updateCache = do
- path <- getOverlayPath
- cfg <- getCfg
- let cache = cacheURI $ server cfg
- res <- (liftIO $ simpleHTTP (Request cache GET [] "")) `sayNormal` ("Fetching cache from "++show cache++"...",const "done.")
- case res of
- Left err -> throwError (ConnectionFailed (show cache) (show err))
- Right resp -> liftIO $ do
- createDirectoryIfMissing False (path </> hackportDir)
- Prelude.writeFile (cacheFile path) (rspBody resp)
-
-readCache :: FilePath -> HPAction Index
-readCache portdir = do
- let cachePath = cacheFile portdir
- exists <- liftIO $ doesFileExist cachePath
- unless exists $ do
- info "No cache file present, attempting to update..."
- updateCache
- str <- liftIO $ L.readFile cachePath
- return $ readIndex str
-
-readDefaultCache :: HPAction Index
-readDefaultCache = do
- overlayPath <- getOverlayPath
- readCache overlayPath
-
-indexToPortage :: Index -> Portage -> (Portage, [String])
-indexToPortage index port = second nub . runWriter $ do
- pkgs <- forM index $ \(pkg_h_name, pkg_h_ver, pkg_desc) -> do
- let pkg_name = map toLower pkg_h_name
- pkg_cat <- lookupCat pkg_name
- Just ver <- return . simpleParse $ pkg_h_ver
- return $ Ebuild (P pkg_cat pkg_name)
- (fromCabalVersion ver)
- "<hackage>"
- (Just pkg_desc)
- return $ Map.map sort $ Map.fromListWith (++) [ (ePackage e, [e]) | e <- pkgs ]
- where
- catMap = Map.fromListWith (++) [ (p, [c]) | P c p <- Map.keys port ]
- lookupCat :: String -> Writer [String] String
- lookupCat p = do
- case Map.lookup p catMap of
- Nothing -> return "hackage"
- Just [x] -> return x
- Just xs -> do
- let c | elem "dev-haskell" xs = "dev-haskell"
- | otherwise = head xs
- tell ["WARNING: Category clash for package " ++ p ++ ", defaulting to " ++ c ++ ". Other categories: " ++ unwords (delete c xs)]
- return c
diff --git a/Config.hs b/Config.hs
deleted file mode 100644
index b6f122d..0000000
--- a/Config.hs
+++ /dev/null
@@ -1,125 +0,0 @@
-module Config where
-
-import Network.URI
-import System.Console.GetOpt
-import Text.Regex
-
-data HackPortOptions
- = OverlayPath String
- | PortagePath String
- | Server String
- | TempDir String
- | Verbosity String
- | Help
- | RefreshCache
-
-data OperationMode
- = List String
- | Merge String
- | DiffTree DiffMode
- | Update
- | ShowHelp
- | Status String
- | MakeEbuild String
-
-data DiffMode
- = ShowAll
- | ShowMissing
- | ShowAdditions
- | ShowNewer
- | ShowCommon
- deriving Eq
-
-data Config = Config
- { overlayPath ::Maybe String
- , portagePath ::Maybe String
- , server ::URI
- , tmp ::String
- , verbosity ::Verbosity
- , refreshCache ::Bool
- }
-
-data Verbosity
- = Debug
- | Normal
- | Silent
-
-packageRegex :: Regex
-packageRegex = mkRegex "^(.*?)-([0-9].*)$"
-
-defaultConfig :: Config
-defaultConfig = Config
- { overlayPath = Nothing
- , portagePath = Nothing
- , server = URI "http:" (Just $ URIAuth "" "hackage.haskell.org" "") "/packages/archive/" "" ""
- , tmp = "/tmp"
- , verbosity = Normal
- , refreshCache = False
- }
-
-hackageOptions :: [OptDescr HackPortOptions]
-hackageOptions =
- [Option ['o'] ["overlay-path"] (ReqArg OverlayPath "PATH") "The overlay tree to merge to"
- ,Option ['p'] ["portdir"] (ReqArg PortagePath "PATH") "The portage directory to use"
- ,Option ['s'] ["server"] (ReqArg Server "URL") "The Hackage server to query"
- ,Option ['t'] ["temp-dir"] (ReqArg TempDir "PATH") "A temp directory where tarballs can be stored"
- ,Option ['v'] ["verbosity"] (ReqArg Verbosity "debug|normal|silent") "Set verbosity level (default is 'normal')"
- ,Option ['h', '?'] ["help"] (NoArg Help) "Display this help message"
- ,Option ['r'] ["refresh-cache"] (NoArg RefreshCache) "Refresh the hackport cache before running the command"
- ]
-
-parseConfig :: [String] -> Either String ([HackPortOptions],OperationMode)
-parseConfig opts = let
- (popts,args,errs) = getOpt Permute hackageOptions opts
- mode | not (null errs) = Left $ "Error while parsing flags:\n"
- ++ concat errs
- | not (null [ () | Help <- popts ]) = Right ShowHelp
- | otherwise = case args of
- "merge":[] -> Left "Need a package's name and version to merge it.\n"
- "merge":package:[] -> Right (Merge package)
- "merge":_:rest -> Left ("'merge' takes 1 argument("++show ((length rest)+1)++" given).\n")
- "list":[] -> Right (List "")
- "list":package:[] -> Right (List package)
- "list":rest -> Left ("'list' takes at most one argument ("++show (length rest)++" given).\n")
- "diff":[] -> Right (DiffTree ShowAll)
- "diff":"all":[] -> Right (DiffTree ShowAll)
- "diff":"missing":[] -> Right (DiffTree ShowMissing)
- "diff":"additions":[] -> Right (DiffTree ShowAdditions)
- "diff":"newer":[] -> Right (DiffTree ShowNewer)
- "diff":"common":[] -> Right (DiffTree ShowCommon)
- "diff":arg:[] -> Left ("Unknown argument to diff: '" ++ arg ++ "'. Use all,missing,additions,newer or common.\n")
- "diff":_:xs -> Left ("'diff' takes one argument("++show ((length xs)+1)++" given).\n")
- "update":[] -> Right Update
- "update":rest -> Left ("'update' takes zero arguments("++show (length rest)++" given).\n")
- "status":[] -> Right (Status "")
- "status":"toportage":[] -> Right (Status "toportage")
- "status":xs-> Left ("invalid argument(s) to 'status': " ++ show xs)
- "make-ebuild":[] -> Left "Need .cabal file to make ebuild."
- "make-ebuild":package:[] -> Right (MakeEbuild package)
- "make-ebuild":_:rest -> Left ("'make-ebuild' takes 1 argument("++show ((length rest)+1)++" given).\n")
-
- [] -> Right ShowHelp
- _ -> Left "Unknown opertation mode\n"
- in case mode of
- Left err -> Left err
- Right m -> Right (popts,m)
-
-hackageUsage :: IO ()
-hackageUsage = putStr $ flip usageInfo hackageOptions $ unlines
- [ "Usage:"
- , "\t\"hackport [OPTION] MODE [MODETARGET]\""
- , "\t\"hackport [OPTION] list [PKG]\" lists all packages or packages matching search term"
- , "\t\"hackport [OPTION] merge PKG-VERSION\" merges a package into the portage tree"
- , "\t\"hackport [OPTION] diff\" prints the difference between the portage-tree and the server's packages"
- , "\t\"hackport [OPTION] update\" updates the local cache"
- , "\t\"hackport [OPTION] status\" compares the overlay with the portage tree"
- , "\t\"hackport [OPTION] make-ebuild\" creates standalone ebuild from given .cabal file"
- , "Options:"
- ]
-
-parseVerbosity :: String -> Maybe Verbosity
-parseVerbosity "debug" = Just Debug
-parseVerbosity "normal" = Just Normal
-parseVerbosity "silent" = Just Silent
-parseVerbosity _ = Nothing
-
diff --git a/Diff.hs b/Diff.hs
index fc355ea..ef2a597 100644
--- a/Diff.hs
+++ b/Diff.hs
@@ -1,70 +1,188 @@
module Diff
- ( diffAction
+ ( runDiff
+ , DiffMode(..)
) where
-import qualified Data.Map as Map
+import Control.Monad ( mplus )
+import Control.Exception ( assert )
+import Data.Maybe ( fromJust, listToMaybe )
+import Data.List ( sortBy, groupBy )
+import Data.Ord ( comparing )
-import Control.Monad.Trans
-import Data.Char
+import qualified Portage.Overlay as Portage
+import qualified Portage.Cabal as Portage
+import qualified Portage.PackageId as Portage
-import Action
-import Cache
-import Config (DiffMode(..))
-import P2
-import Version
-import Overlays
+import qualified Data.Version as Cabal
-data DiffState a
- = OnlyLeft a
- | OnlyRight a
- | Both a a
+-- cabal
+import Distribution.Verbosity
+import Distribution.Text(display)
+import qualified Distribution.Package as Cabal
+import qualified Distribution.Client.PackageIndex as Index
+import Distribution.Simple.Utils (equating)
+-- cabal-install
+import qualified Distribution.Client.IndexUtils as Index (getAvailablePackages )
+import qualified Distribution.Client.Types as Cabal
+import Distribution.Client.Utils (mergeBy, MergeResult(..))
+
+data DiffMode
+ = ShowAll
+ | ShowMissing
+ | ShowAdditions
+ | ShowNewer
+ | ShowCommon
+ | ShowPackages [String]
+ deriving Eq
+
+
+{-
+type DiffState a = MergeResult a a
tabs :: String -> String
tabs str = let len = length str in str++(if len < 3*8
then replicate (3*8-len) ' '
else "")
-showDiffState :: Package -> DiffState Version -> String
-showDiffState pkg st = (tabs (show pkg)) ++ " [" ++ (case st of
- Both x y -> showVersion x ++ (case compare x y of
- EQ -> "="
- GT -> ">"
- LT -> "<") ++ showVersion y
- OnlyLeft x -> showVersion x ++ ">none"
- OnlyRight y -> "none<"++showVersion y)++"]"
-
-
-diffAction :: DiffMode -> HPAction ()
-diffAction dm = do
- overlayPath <- getOverlayPath
- cache <- readCache overlayPath
- overlayTree <- liftIO $ readPortageTree overlayPath
- let (hackageTree, clashes) = indexToPortage cache overlayTree
- liftIO $ mapM_ putStrLn clashes
- diff hackageTree overlayTree dm
-
-diff :: Portage -> Portage -> DiffMode -> HPAction ()
-diff pt1 pt2 mode = do
- let pkgs1 = Map.map (OnlyLeft . eVersion . maximum) pt1
- let pkgs2 = Map.map (OnlyRight . eVersion . maximum) pt2
- let union = Map.unionWith (\(OnlyLeft x) (OnlyRight y) -> Both x y) pkgs1 pkgs2
- let showFilter st = case mode of
- ShowAll -> True
- ShowMissing -> case st of
- OnlyLeft _ -> True
- Both x y -> x > y
- OnlyRight _ -> False
- ShowAdditions -> case st of
- OnlyLeft _ -> False
- Both x y -> x < y
- OnlyRight _ -> True
- ShowNewer -> case st of
- OnlyLeft _ -> False
- Both x y -> x > y
- OnlyRight _ -> False
- ShowCommon -> case st of
- OnlyLeft _ -> False
- Both x y -> x == y
- OnlyRight _ -> False
- let packages = filter (showFilter . snd) (Map.assocs union)
- mapM_ (info . uncurry showDiffState) packages
+
+-- TODO: is the new showPackageCompareInfo showing the packages in the same
+-- way as showDiffState did?
+
+showDiffState :: Cabal.PackageName -> DiffState Portage.Version -> String
+showDiffState pkg st = (tabs (display pkg)) ++ " [" ++ (case st of
+ InBoth x y -> display x ++ (case compare x y of
+ EQ -> "="
+ GT -> ">"
+ LT -> "<") ++ display y
+ OnlyInLeft x -> display x ++ ">none"
+ OnlyInRight y -> "none<" ++ display y) ++ "]"
+-}
+
+runDiff :: Verbosity -> FilePath -> DiffMode -> Cabal.Repo -> IO ()
+runDiff verbosity overlayPath dm repo = do
+ -- get package list from hackage
+ pkgDB <- Index.getAvailablePackages verbosity [ repo ]
+ let (Cabal.AvailablePackageDb hackageIndex _) = pkgDB
+
+ -- get package list from the overlay
+ overlay0 <- (Portage.loadLazy overlayPath)
+ let overlayIndex = Portage.fromOverlay (Portage.reduceOverlay overlay0)
+
+ let (subHackage, subOverlay)
+ = case dm of
+ ShowPackages pkgs ->
+ (concatMap (Index.searchByNameSubstring hackageIndex) pkgs
+ ,concatMap (Index.searchByNameSubstring overlayIndex) pkgs)
+ _ ->
+ (Index.allPackages hackageIndex
+ ,Index.allPackages overlayIndex)
+ diff subHackage subOverlay dm
+
+data PackageCompareInfo = PackageCompareInfo {
+ name :: Cabal.PackageName,
+-- hackageVersions :: [ Cabal.Version ],
+-- overlayVersions :: [ Cabal.Version ]
+ hackageVersion :: Maybe Cabal.Version,
+ overlayVersion :: Maybe Cabal.Version
+ } deriving Show
+
+showPackageCompareInfo :: PackageCompareInfo -> String
+showPackageCompareInfo pkgCmpInfo =
+ display (name pkgCmpInfo) ++ " ["
+ ++ hackageS ++ sign ++ overlayS ++ "]"
+ where
+ overlay = overlayVersion pkgCmpInfo
+ hackage = hackageVersion pkgCmpInfo
+ hackageS = maybe "none" display hackage
+ overlayS = maybe "none" display overlay
+ sign = case compare hackage overlay of
+ EQ -> "="
+ GT -> ">"
+ LT -> "<"
+
+diff :: [Cabal.AvailablePackage]
+ -> [Portage.ExistingEbuild]
+ -> DiffMode
+ -> IO ()
+diff hackage overlay dm = do
+ mapM_ (putStrLn . showPackageCompareInfo) pkgCmpInfos
+ where
+ merged = mergePackages (map (Portage.normalizeCabalPackageId . Cabal.packageId) hackage)
+ (map Portage.ebuildCabalId overlay)
+ pkgCmpInfos = filter pkgFilter (map (uncurry mergePackageInfo) merged)
+ pkgFilter :: PackageCompareInfo -> Bool
+ pkgFilter pkgCmpInfo =
+ let om = overlayVersion pkgCmpInfo
+ hm = hackageVersion pkgCmpInfo
+ st = case (om,hm) of
+ (Just ov, Just hv) -> InBoth ov hv
+ (Nothing, Just hv) -> OnlyInRight hv
+ (Just ov, Nothing) -> OnlyInLeft ov
+ _ -> error "impossible"
+ in
+ case dm of
+ ShowAll -> True
+ ShowPackages _ -> True -- already filtered
+ ShowNewer -> case st of
+ InBoth o h -> h>o
+ _ -> False
+ ShowMissing -> case st of
+ OnlyInLeft _ -> False
+ InBoth x y -> x < y
+ OnlyInRight _ -> True
+ ShowAdditions -> case st of
+ OnlyInLeft _ -> True
+ InBoth x y -> x > y
+ OnlyInRight _ -> False
+ ShowCommon -> case st of
+ OnlyInLeft _ -> False
+ InBoth x y -> x == y
+ OnlyInRight _ -> False
+
+-- | We get the 'PackageCompareInfo' by combining the info for the overlay
+-- and hackage 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 :: [Cabal.PackageIdentifier]
+ -> [Cabal.PackageIdentifier]
+ -> PackageCompareInfo
+mergePackageInfo hackage overlay =
+ assert (length overlay + length hackage > 0) $
+ PackageCompareInfo {
+ name = combine Cabal.pkgName latestHackage
+ Cabal.pkgName latestOverlay,
+-- hackageVersions = map Cabal.pkgVersion hackage,
+-- overlayVersions = map Cabal.pkgVersion overlay
+ hackageVersion = fmap Cabal.pkgVersion latestHackage,
+ overlayVersion = fmap Cabal.pkgVersion latestOverlay
+ }
+ where
+ combine f x g y = fromJust (fmap f x `mplus` fmap g y)
+ latestHackage = latestOf hackage
+ latestOverlay = latestOf overlay
+ latestOf :: [Cabal.PackageIdentifier] -> Maybe Cabal.PackageIdentifier
+ latestOf = listToMaybe . reverse . sortBy (comparing Cabal.pkgVersion)
+
+-- | 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 :: [Cabal.PackageIdentifier] -> [Cabal.PackageIdentifier]
+ -> [([Cabal.PackageIdentifier], [Cabal.PackageIdentifier])]
+mergePackages hackage overlay =
+ map collect
+ $ mergeBy (\i a -> fst i `compare` fst a)
+ (groupOn Cabal.pkgName hackage)
+ (groupOn Cabal.pkgName overlay)
+ where
+ collect (OnlyInLeft (_,is) ) = (is, [])
+ collect ( InBoth (_,is) (_,as)) = (is, as)
+ collect (OnlyInRight (_,as)) = ([], as)
+
+groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])]
+groupOn key = map (\xs -> (key (head xs), xs))
+ . groupBy (equating key)
+ . sortBy (comparing key)
diff --git a/DistroMap.hs b/DistroMap.hs
new file mode 100644
index 0000000..47e69b5
--- /dev/null
+++ b/DistroMap.hs
@@ -0,0 +1,159 @@
+{-# OPTIONS -XPatternGuards #-}
+{-
+Generate a distromap, like these:
+http://hackage.haskell.org/packages/archive/00-distromap/
+Format:
+
+("xmobar","0.8",Just "http://packages.gentoo.org/package/x11-misc/xmobar")
+("xmobar","0.9",Just "http://packages.gentoo.org/package/x11-misc/xmobar")
+("xmobar","0.9.2",Just "http://packages.gentoo.org/package/x11-misc/xmobar")
+("xmonad","0.5",Just "http://packages.gentoo.org/package/x11-wm/xmonad")
+("xmonad","0.6",Just "http://packages.gentoo.org/package/x11-wm/xmonad")
+("xmonad","0.7",Just "http://packages.gentoo.org/package/x11-wm/xmonad")
+("xmonad","0.8",Just "http://packages.gentoo.org/package/x11-wm/xmonad")
+("xmonad","0.8.1",Just "http://packages.gentoo.org/package/x11-wm/xmonad")
+("xmonad","0.9",Just "http://packages.gentoo.org/package/x11-wm/xmonad")
+("xmonad","0.9.1",Just "http://en.gentoo-wiki.com/wiki/Haskell/overlay")
+
+Multiple entries for each package is allowed, given that there are different versions.
+
+
+Setup:
+ Join all packages from portage and the overlay into a big map;
+ From Portage.PackageId: PackageName = category/package
+ PVULine = (packagename, versionstring, url)
+ Create such a map: Map PackageName DistroLine
+ Only one PVULine per version, and prefer portage over the overlay.
+
+Algorithm;
+ 1. Take a package from hackage
+ 2. Look for it in the map
+ a. For each version:
+ find a match in the list of versions:
+ yield the PVULine
+-}
+
+module DistroMap
+ ( distroMap ) where
+
+import Control.Applicative
+import qualified Data.List as List ( nub )
+import qualified Data.Map as Map
+import Data.Map ( Map )
+import System.FilePath ( (</>) )
+import Debug.Trace ( trace )
+import Data.Maybe ( fromJust )
+
+import Distribution.Verbosity
+import Distribution.Text ( display )
+import Distribution.Client.Types ( Repo, AvailablePackageDb(..), AvailablePackage(..) )
+import Distribution.Simple.Utils ( warn, notice, info )
+
+import qualified Data.Version as Cabal
+import qualified Distribution.Package as Cabal
+import qualified Distribution.Client.PackageIndex as CabalInstall
+import qualified Distribution.Client.IndexUtils as CabalInstall
+
+import Portage.Overlay ( Overlay(..), readOverlayByPackage, getDirectoryTree, DirectoryTree )
+import qualified Portage.PackageId as Portage
+import qualified Portage.Version as Portage
+
+type PVU = (Cabal.PackageName, Cabal.Version, Maybe String)
+type PVU_Map = Map Portage.PackageName [(Cabal.Version, Maybe String)]
+type PVU_Item = (Portage.PackageName, [(Cabal.Version, Maybe String)])
+
+distroMap :: Verbosity -> Repo -> FilePath -> FilePath -> [String] -> IO ()
+distroMap verbosity repo portagePath overlayPath args = do
+ info verbosity "distro map called"
+ info verbosity ("verbosity: " ++ show verbosity)
+ info verbosity ("portage: " ++ portagePath)
+ info verbosity ("overlay: " ++ overlayPath)
+ info verbosity ("args: " ++ show args)
+
+ portage <- readOverlayByPackage <$> getDirectoryTree portagePath
+ overlay <- readOverlayByPackage <$> getDirectoryTree overlayPath
+
+ info verbosity ("portage packages: " ++ show (length portage))
+ info verbosity ("overlay packages: " ++ show (length overlay))
+
+ let portageMap = buildPortageMap portage
+ overlayMap = buildOverlayMap overlay
+ completeMap = unionMap portageMap overlayMap
+
+ info verbosity ("portage map: " ++ show (Map.size portageMap))
+ info verbosity ("overlay map: " ++ show (Map.size overlayMap))
+ info verbosity ("complete map: " ++ show (Map.size completeMap))
+
+ AvailablePackageDb { packageIndex = packageIndex } <-
+ CabalInstall.getAvailablePackages verbosity [repo]
+
+ let pkgs0 = map (map packageInfoId) (CabalInstall.allPackagesByName packageIndex)
+ hackagePkgs = [ (Cabal.pkgName (head p), map Cabal.pkgVersion p) | p <- pkgs0 ]
+
+ info verbosity ("cabal packages: " ++ show (length hackagePkgs))
+
+ let pvus = concat $ map (\(p,vs) -> lookupPVU completeMap p vs) hackagePkgs
+ info verbosity ("found pvus: " ++ show (length pvus))
+
+ mapM_ (putStrLn . showPVU) pvus
+ return ()
+
+
+showPVU :: PVU -> String
+showPVU (p,v,u) = show $ (display p, display v, u)
+
+-- building the PVU_Map
+
+reduceVersion :: Portage.Version -> Portage.Version
+reduceVersion (Portage.Version ns _ _ _) = Portage.Version ns Nothing [] 0
+
+reduceVersions :: [Portage.Version] -> [Portage.Version]
+reduceVersions = List.nub . map reduceVersion
+
+buildMap :: [(Portage.PackageName, [Portage.Version])]
+ -> (Portage.PackageName -> Portage.Version -> Maybe String)
+ -> PVU_Map
+buildMap pvs f = Map.mapWithKey (\p vs -> [ (fromJust $ Portage.toCabalVersion v, f p v)
+ | v <- reduceVersions vs ])
+ (Map.fromList pvs)
+
+buildPortageMap :: [(Portage.PackageName, [Portage.Version])] -> PVU_Map
+buildPortageMap lst = buildMap lst $ \ (Portage.PackageName c p) _v ->
+ Just $ "http://packages.gentoo.org/package" </> display c </> display p
+
+buildOverlayMap :: [(Portage.PackageName, [Portage.Version])] -> PVU_Map
+buildOverlayMap lst = buildMap lst $ \_ _ -> Just "http://en.gentoo-wiki.com/wiki/Haskell/overlay"
+
+unionMap :: PVU_Map -> PVU_Map -> PVU_Map
+unionMap = Map.unionWith f
+ where
+ f :: [(Cabal.Version, Maybe String)]
+ -> [(Cabal.Version, Maybe String)]
+ -> [(Cabal.Version, Maybe String)]
+ f vas vbs = Map.toList (Map.union (Map.fromList vas) (Map.fromList vbs))
+
+
+-- resolving Cabal.PackageName to Portage.PackageName
+
+lookupPVU :: PVU_Map -> Cabal.PackageName -> [Cabal.Version] -> [PVU]
+lookupPVU pvu_map pn cvs =
+ case findItems pvu_map (Portage.normalizeCabalPackageName pn) of
+ [] -> []
+ [item] -> ret item
+ items | [item] <- preferableItem items -> ret item
+ | otherwise -> trace (noDefaultText items) []
+ where
+ noDefaultText is = unlines $ ("no default for package: " ++ display pn)
+ : [ " * " ++ (display cat)
+ | (Portage.PackageName cat _, _) <- is]
+
+ ret (_, vs) = [ (pn, v, u) | (v, u) <- vs, v `elem` cvs ]
+ preferableItem items =
+ [ item
+ | item@(Portage.PackageName cat _pn, _vs) <- items
+ , cat == Portage.Category "dev-haskell"]
+ findItems pvu_map cpn = Map.toList $ Map.filterWithKey f pvu_map
+ where
+ f (Portage.PackageName _cat pn) _vs = cpn == pn
+
+
diff --git a/Error.hs b/Error.hs
index d7e3519..ae618e8 100644
--- a/Error.hs
+++ b/Error.hs
@@ -1,8 +1,9 @@
{-# OPTIONS -fglasgow-exts #-}
-module Error where
+module Error (HackPortError(..), throwEx, catchEx, hackPortShowError) where
import Data.Typeable
-import Control.Monad.Error (Error)
+import Control.Exception.Extensible as EE
+import Control.Monad.Error
data HackPortError
= ArgumentError String
@@ -25,17 +26,23 @@ data HackPortError
-- | WrongCacheVersion
-- | InvalidCache
| InvalidServer String
- deriving (Typeable)
+ deriving (Typeable, Show)
-instance Error HackPortError
+instance Error HackPortError where
-type HackPortResult a = Either
+instance Exception HackPortError where
+
+throwEx :: HackPortError -> IO a
+throwEx = EE.throw
+
+catchEx :: IO a -> (HackPortError -> IO a) -> IO a
+catchEx = EE.catch
hackPortShowError :: HackPortError -> String
hackPortShowError err = case err of
ArgumentError str -> "Argument error: "++str
ConnectionFailed server reason -> "Connection to hackage server '"++server++"' failed: "++reason
- PackageNotFound pkg -> "Package '"++ pkg ++"' not found on server."
+ PackageNotFound pkg -> "Package '"++ pkg ++"' not found on server. Try 'hackport update'?"
InvalidTarballURL url reason -> "Error while downloading tarball '"++url++"': "++reason
InvalidSignatureURL url reason -> "Error while downloading signature '"++url++"': "++reason
VerificationFailed file signature -> "Error while checking signature('"++signature++"') of '"++file++"'"
diff --git a/GenerateEbuild.hs b/GenerateEbuild.hs
deleted file mode 100644
index 65d35b0..0000000
--- a/GenerateEbuild.hs
+++ /dev/null
@@ -1,60 +0,0 @@
-module GenerateEbuild where
-
-import Action
-import Cabal2Ebuild
-import Config
-
-import Prelude hiding (catch)
-import Control.Monad.Error
-import Distribution.Package
-import Data.Version (showVersion)
-import Network.URI
-import System.Directory
-import System.FilePath
-
-mergeEbuild :: FilePath -> String -> EBuild -> IO ()
-mergeEbuild target category ebuild = do
- let edir = target </> category </> name ebuild
- let epath = edir </> name ebuild ++"-"++ version ebuild <.> "ebuild"
- createDirectoryIfMissing True edir
- writeFile epath (showEBuild ebuild)
-
-fixSrc :: PackageIdentifier -> EBuild -> HPAction EBuild
-fixSrc p ebuild = do
- cfg <- getCfg
- return $ ebuild {
- src_uri = show $ (server cfg) {
- uriPath = (uriPath (server cfg))
- </> pkgName p
- </> showVersion (pkgVersion p)
- </> pkgName p ++ "-" ++
- showVersion (pkgVersion p)
- <.> "tar.gz"
- }
- }
-
-{-hackage2ebuild ::
- (PackageIdentifier,String,String) -> -- ^ the package
- HPAction EBuild
-hackage2ebuild (pkg,tarball,sig) = do
- cfg <- getCfg
- tarballPath <- (if verify cfg then (do
- (tarPath,sigPath) <- downloadFileVerify (tmp cfg) tarball sig
- liftIO $ removeFile sigPath
- return tarPath) else (downloadTarball (tmp cfg) tarball))
- `sayNormal` ("Downloading tarball from '"++tarball++"' to '"++(tmp cfg)++"'... ",const "done.")
- tarType <- maybe (liftIO (removeFile tarballPath) >> throwError (UnknownCompression tarball)) return (tarballGetType tarballPath)
- `sayDebug` ("Guessing compression type of tarball... ",const "done.")
- filesInTarball <- tarballGetFiles (tarCommand cfg) tarballPath tarType
- `sayDebug` ("Getting list of files from tarball... ",const "done.")
- `catchError` (\x->liftIO (removeFile tarballPath) >> throwError x)
- (cabalDir,cabalName) <- maybe (throwError $ NoCabalFound tarball) return (findCabal filesInTarball)
- `sayDebug` ("Trying to find cabal file... ",\(dir,name)->"Found cabal file '"++name++"' in '"++dir++"'.")
- cabalFile <- tarballExtractFile tarballPath tarType (cabalDir++"/"++cabalName)
- `sayDebug` ("Extracting cabal file... ",const "done.")
- packageDescription <- case parseDescription cabalFile of
- ParseFailed err -> throwError $ CabalParseFailed cabalName (showError err)
- ParseOk descr -> return descr
- `sayDebug` ("Parsing '"++cabalName++"'... ",const "done.")
- let ebuild=cabal2ebuild (packageDescription{pkgUrl=tarball}) --we don't trust the cabal file as we just successfully downloaded the tarbal somewhere
- return ebuild {cabalPath=Just cabalDir}-}
diff --git a/Index.hs b/Index.hs
deleted file mode 100644
index 065f3c9..0000000
--- a/Index.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-module Index where
-
-import qualified Data.Set as Set
-import qualified Data.Map as Map
-import Data.Version (Version,parseVersion)
-import Codec.Compression.GZip(decompress)
-import Data.ByteString.Lazy.Char8(ByteString,unpack)
-import Codec.Archive.Tar
-import Distribution.PackageDescription
-import Distribution.Package
-import System.FilePath.Posix
-import MaybeRead (readPMaybe)
-
-type Index = [(String,String,GenericPackageDescription)]
-type IndexMap = Map.Map String (Set.Set Version)
-
-readIndex :: ByteString -> Index
-readIndex str = do
- let unziped = decompress str
- untared = readTarArchive unziped
- entr <- archiveEntries untared
- case splitDirectories (tarFileName (entryHeader entr)) of
- [".",pkgname,vers,file] -> do
- let descr = case parsePackageDescription (unpack (entryData entr)) of
- ParseOk _ pkg_desc -> pkg_desc
- _ -> error $ "Couldn't read cabal file "++show file
- return (pkgname,vers,descr)
- _ -> fail "doesn't look like the proper path"
-
-filterIndexByPV :: (String -> String -> Bool) -> Index -> Index
-filterIndexByPV cond index = [ x | x@(p,v,_d) <- index, cond p v]
-
-indexMapFromList :: [PackageIdentifier] -> IndexMap
-indexMapFromList pids = Map.unionsWith Set.union $
- [ Map.singleton name (Set.singleton vers)
- | (PackageIdentifier {pkgName = name,pkgVersion = vers}) <- pids ]
-
-indexToPackageIdentifier :: Index -> [PackageIdentifier]
-indexToPackageIdentifier index = do
- (name,vers_str,_) <- index
- Just vers <- return $ readPMaybe parseVersion vers_str
- return $ PackageIdentifier {pkgName = name,pkgVersion = vers}
-
-bestVersions :: IndexMap -> Map.Map String Version
-bestVersions = Map.map Set.findMax
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..94a9ed0
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,674 @@
+ 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>.
diff --git a/Main.hs b/Main.hs
index 19d7929..7064a92 100644
--- a/Main.hs
+++ b/Main.hs
@@ -1,136 +1,581 @@
module Main where
-import Control.Monad.Error
-import Data.Char
+import Control.Applicative
+import Control.Monad
import Data.Maybe
import Data.List
-import Data.Version
-import Distribution.Package
-import Distribution.Compiler (CompilerId(..), CompilerFlavor(GHC))
+import Data.Monoid
+ ( Monoid(..) )
+
+-- cabal
+import Distribution.Simple.Setup
+ ( Flag(..), fromFlag
+ , trueArg
+ , flagToMaybe, flagToList
+ , optionVerbosity
+ )
import Distribution.PackageDescription.Configuration
- ( finalizePackageDescription, flattenPackageDescription )
-import Distribution.Simple.PackageIndex (PackageIndex)
+ ( 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 System.IO
-import Distribution.System (buildOS, buildArch)
-import qualified Data.Map as Map
-import Text.ParserCombinators.Parsec
-import Action
+import Distribution.Client.Types
+import Distribution.Client.Update
+
+import qualified Distribution.Client.PackageIndex as Index
+import qualified Distribution.Client.IndexUtils as Index
+
+import Portage.Overlay as Overlay ( loadLazy, inOverlay )
+import Portage.Host as Host ( getInfo, portage_dir )
+import Portage.PackageId ( normalizeCabalPackageId )
+
+import Network.URI
+import System.Environment ( getArgs, getProgName )
+import System.Directory ( doesDirectoryExist )
+import System.Exit ( exitFailure )
+import System.FilePath ( (</>) )
+
import qualified Cabal2Ebuild as E
-import Cache
-import Config
+
import Diff
import Error
-import GenerateEbuild
-import Index
import Status
-import Package
import Overlays
-import P2
-
-import qualified Distribution.PackageDescription as Cabal
-import Distribution.Verbosity (normal)
-import Cabal2Ebuild
-
-list :: String -> HPAction ()
-list name = do
- index <- readCache =<< getOverlayPath
- let index' | null name = index
- | otherwise = filterIndexByPV matchSubstringCaseInsensitive index
- pkgs = [ pkg ++ "-" ++ ver | (pkg,ver,_) <- index']
- if null pkgs
- then throwError (PackageNotFound name)
- else liftIO . putStr . unlines . sort $ pkgs
- where
- matchSubstringCaseInsensitive pName _pVver =
- map toLower name `isInfixOf` map toLower pName
-
-merge :: String -> HPAction ()
-merge pstr = do
- (m_category, pname, m_version) <- case parsePVC of
- Right v -> return v
- Left err -> throwError (ArgumentError ("Could not parse [category/]package[-version]: " ++ show err))
- portdir <- getOverlayPath
- overlay <- liftIO $ readPortageTree portdir
- cache <- readCache portdir
- let (indexTree,clashes) = indexToPortage cache overlay
- mapM_ (liftIO . putStrLn) clashes
- whisper $ "Searching for: "++ pstr
- let pkgs =
- Map.elems
- . Map.filterWithKey (\(P _ pname') _ -> map toLower pname' == map toLower pname)
- $ indexTree
- return ()
- pkg <- case pkgs of
- [] -> throwError (PackageNotFound pname)
- [xs] -> case m_version of
- Nothing -> return (maximum xs) -- highest version
- Just v -> do
- let ebuilds = filter (\e -> eVersion e == v) xs
- case ebuilds of
- [] -> throwError (PackageNotFound (pname ++ '-':show v))
- [e] -> return e
- _ -> fail "the impossible happened"
- _ -> fail "the impossible happened"
- category <- do
- case m_category of
- Just cat -> return cat
- Nothing -> do
- case pCategory (ePackage pkg) of
- "hackage" -> return "dev-haskell"
- c -> return c
- let Just genericDesc = ePkgDesc pkg
- Right (desc, _) = finalizePackageDescription []
- (Nothing :: Maybe (PackageIndex PackageIdentifier))
- buildOS buildArch
- (CompilerId GHC (Version [6,8,2] []))
- [] genericDesc
- ebuild <- fixSrc (packageId desc) (E.cabal2ebuild desc)
- liftIO $ do
- putStrLn $ "Merging " ++ category ++ '/': pname ++ "-" ++ display (pkgVersion (packageId desc))
- putStrLn $ "Destination: " ++ portdir
- mergeEbuild portdir category ebuild
- where
- parsePVC = parse readPVC "" pstr
- readPVC = do
- mc <- option Nothing $ try $ do
- c <- readCat
- char '/'
- return (Just c)
- (p, mv) <- readPkgAndVer
- eof
- return (mc, p, mv)
-
-makeEbuild :: String -> HPAction ()
-makeEbuild cabalFileName = liftIO $ do
+import Merge
+import DistroMap ( distroMap )
+
+import qualified Paths_cabal_install
+import qualified Paths_hackport
+
+-----------------------------------------------------------------------
+-- List
+-----------------------------------------------------------------------
+
+data ListFlags = ListFlags {
+ listVerbosity :: Flag Verbosity
+ -- , listOverlayPath :: Flag FilePath
+ -- , listServerURI :: Flag String
+ }
+
+instance Monoid ListFlags where
+ mempty = ListFlags {
+ listVerbosity = mempty
+ -- , listOverlayPath = mempty
+ -- , listServerURI = mempty
+ }
+ mappend a b = ListFlags {
+ listVerbosity = combine listVerbosity
+ -- , listOverlayPath = combine listOverlayPath
+ -- , listServerURI = combine listServerURI
+ }
+ where combine field = field a `mappend` field b
+
+defaultListFlags :: ListFlags
+defaultListFlags = ListFlags {
+ listVerbosity = Flag normal
+ -- , listOverlayPath = NoFlag
+ -- , listServerURI = Flag defaultHackageServerURI
+ }
+
+listCommand :: CommandUI ListFlags
+listCommand = CommandUI {
+ commandName = "list",
+ commandSynopsis = "List packages",
+ commandDescription = Just $ \_pname ->
+ "TODO: this is the commandDescription for listCommand\n",
+ commandUsage = usagePackages "list",
+ commandDefaultFlags = defaultListFlags,
+ commandOptions = \_showOrParseArgs ->
+ [ optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })
+ {-
+ , option [] ["overlay"]
+ "Use cached packages list from specified overlay"
+ listOverlayPath (\v flags -> flags { listOverlayPath = v })
+ (reqArgFlag "PATH")
+ -}
+ ]
+ }
+
+listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()
+listAction flags extraArgs globalFlags = do
+ let verbosity = fromFlag (listVerbosity flags)
+ overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)
+ let repo = defaultRepo overlayPath
+ index <- fmap packageIndex (Index.getAvailablePackages verbosity [ repo ])
+ overlay <- Overlay.loadLazy overlayPath
+ let pkgs | null extraArgs = Index.allPackages index
+ | otherwise = concatMap (Index.searchByNameSubstring index) extraArgs
+ normalized = map (normalizeCabalPackageId . packageInfoId) pkgs
+ let decorated = map (\p -> (Overlay.inOverlay overlay p, p)) normalized
+ mapM_ (putStrLn . pretty) decorated
+ where
+ pretty :: (Bool, Cabal.PackageIdentifier) -> String
+ pretty (isInOverlay, pkgId) =
+ let dec | isInOverlay = " * "
+ | otherwise = " "
+ in dec ++ display pkgId
+
+
+-----------------------------------------------------------------------
+-- Make Ebuild
+-----------------------------------------------------------------------
+
+data MakeEbuildFlags = MakeEbuildFlags {
+ makeEbuildVerbosity :: Flag Verbosity
+ }
+
+instance Monoid MakeEbuildFlags where
+ mempty = MakeEbuildFlags {
+ makeEbuildVerbosity = mempty
+ }
+ mappend a b = MakeEbuildFlags {
+ makeEbuildVerbosity = combine makeEbuildVerbosity
+ }
+ where combine field = field a `mappend` field b
+
+defaultMakeEbuildFlags :: MakeEbuildFlags
+defaultMakeEbuildFlags = MakeEbuildFlags {
+ makeEbuildVerbosity = Flag normal
+ }
+
+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
pkg <- Cabal.readPackageDescription normal cabalFileName
- let ebuild = cabal2ebuild (flattenPackageDescription pkg)
- let ebuildFileName = name ebuild ++ "-" ++ version ebuild ++ ".ebuild"
- writeFile ebuildFileName (showEBuild ebuild)
-
-hpmain :: HPAction ()
-hpmain = do
- mode <- loadConfig
- requestedUpdate <- fmap refreshCache getCfg
- when requestedUpdate $
- case mode of
- Update -> return ()
- _ -> updateCache
- case mode of
- ShowHelp -> liftIO hackageUsage
- List pkg -> list pkg
- Merge pkg -> merge pkg
- DiffTree dtmode -> diffAction dtmode
- Update -> updateCache
- Status action -> statusAction action
- MakeEbuild cabalFileName -> makeEbuild cabalFileName
+ let ebuild = E.cabal2ebuild (flattenPackageDescription pkg)
+ let ebuildFileName = E.name ebuild ++ "-" ++ E.version ebuild ++ ".ebuild"
+ writeFile ebuildFileName (E.showEBuild ebuild)
+
+makeEbuildCommand :: CommandUI MakeEbuildFlags
+makeEbuildCommand = CommandUI {
+ commandName = "make-ebuild",
+ commandSynopsis = "Make an ebuild from a .cabal file",
+ commandDescription = Just $ \_pname ->
+ "TODO: this is the commandDescription for makeEbuildCommand\n",
+ commandUsage = \_ -> [],
+ commandDefaultFlags = defaultMakeEbuildFlags,
+ commandOptions = \_showOrParseArgs ->
+ [ optionVerbosity makeEbuildVerbosity (\v flags -> flags { makeEbuildVerbosity = v })
+ ]
+ }
+
+-----------------------------------------------------------------------
+-- Diff
+-----------------------------------------------------------------------
+
+data DiffFlags = DiffFlags {
+ -- diffMode :: Flag String, -- DiffMode,
+ diffVerbosity :: Flag Verbosity
+ -- , diffServerURI :: Flag String
+ }
+
+instance Monoid DiffFlags where
+ mempty = DiffFlags {
+ -- diffMode = mempty,
+ diffVerbosity = mempty
+ -- , diffServerURI = mempty
+ }
+ mappend a b = DiffFlags {
+ -- diffMode = combine diffMode,
+ diffVerbosity = combine diffVerbosity
+ -- , diffServerURI = combine diffServerURI
+ }
+ where combine field = field a `mappend` field b
+
+defaultDiffFlags :: DiffFlags
+defaultDiffFlags = DiffFlags {
+ -- diffMode = Flag "all",
+ diffVerbosity = Flag normal
+ -- , diffServerURI = Flag defaultHackageServerURI
+ }
+
+diffCommand :: CommandUI DiffFlags
+diffCommand = CommandUI {
+ commandName = "diff",
+ commandSynopsis = "Run diff",
+ commandDescription = Just $ \_pname ->
+ "TODO: this is the commandDescription for diffCommand\n",
+ commandUsage = usagePackages "diff",
+ commandDefaultFlags = defaultDiffFlags,
+ commandOptions = \_showOrParseArgs ->
+ [ optionVerbosity diffVerbosity (\v flags -> flags { diffVerbosity = v })
+ {-
+ , option [] ["mode"]
+ "Diff mode, one of: all, newer, missing, additions, common"
+ diffMode (\v flags -> flags { diffMode = v })
+ (reqArgFlag "MODE") -- I don't know how to map it strictly to DiffMode
+ -}
+ ]
+ }
+
+diffAction :: DiffFlags -> [String] -> GlobalFlags -> IO ()
+diffAction flags args globalFlags = do
+ let verbosity = fromFlag (diffVerbosity flags)
+ -- dm0 = fromFlag (diffMode flags)
+ dm <- case args of
+ [] -> return ShowAll
+ ["all"] -> return ShowAll
+ ["missing"] -> return ShowMissing
+ ["additions"] -> return ShowAdditions
+ ["newer"] -> return ShowNewer
+ ["common"] -> return ShowCommon
+ ("package": pkgs) -> return (ShowPackages pkgs)
+ -- TODO: ["package",packagePattern] ->
+ -- return ShowPackagePattern packagePattern
+ _ -> die $ "Unknown mode: " ++ unwords args
+ overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)
+ let repo = defaultRepo overlayPath
+ runDiff verbosity overlayPath dm repo
+
+-----------------------------------------------------------------------
+-- Update
+-----------------------------------------------------------------------
+
+data UpdateFlags = UpdateFlags {
+ updateVerbosity :: Flag Verbosity
+ -- , updateServerURI :: Flag String
+ }
+
+instance Monoid UpdateFlags where
+ mempty = UpdateFlags {
+ updateVerbosity = mempty
+ -- , updateServerURI = mempty
+ }
+ mappend a b = UpdateFlags {
+ updateVerbosity = combine updateVerbosity
+ -- , updateServerURI = combine updateServerURI
+ }
+ where combine field = field a `mappend` field b
+
+defaultUpdateFlags :: UpdateFlags
+defaultUpdateFlags = UpdateFlags {
+ updateVerbosity = Flag normal
+ -- , updateServerURI = Flag defaultHackageServerURI
+ }
+
+updateCommand :: CommandUI UpdateFlags
+updateCommand = CommandUI {
+ commandName = "update",
+ commandSynopsis = "Update the local cache",
+ commandDescription = Just $ \_pname ->
+ "TODO: this is the commandDescription for updateCommand\n",
+ commandUsage = usageFlags "update",
+ commandDefaultFlags = defaultUpdateFlags,
+ commandOptions = \_ ->
+ [ optionVerbosity updateVerbosity (\v flags -> flags { updateVerbosity = v })
+
+ {-
+ , option [] ["server"]
+ "Set the server you'd like to update the cache from"
+ updateServerURI (\v flags -> flags { updateServerURI = v} )
+ (reqArgFlag "SERVER")
+ -}
+ ]
+ }
+
+updateAction :: UpdateFlags -> [String] -> GlobalFlags -> IO ()
+updateAction flags extraArgs globalFlags = do
+ unless (null extraArgs) $
+ die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs
+ let verbosity = fromFlag (updateVerbosity flags)
+ overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)
+ update verbosity [ defaultRepo overlayPath ]
+
+
+-----------------------------------------------------------------------
+-- Status
+-----------------------------------------------------------------------
+
+data StatusFlags = StatusFlags {
+ statusVerbosity :: Flag Verbosity,
+ statusToPortage :: Flag Bool
+ }
+
+instance Monoid StatusFlags where
+ mempty = StatusFlags {
+ statusVerbosity = mempty,
+ statusToPortage = mempty
+ }
+ mappend a b = StatusFlags {
+ statusVerbosity = combine statusVerbosity,
+ statusToPortage = combine statusToPortage
+ }
+ where combine field = field a `mappend` field b
+
+defaultStatusFlags :: StatusFlags
+defaultStatusFlags = StatusFlags {
+ statusVerbosity = Flag normal,
+ statusToPortage = Flag False
+ }
+
+statusCommand :: CommandUI StatusFlags
+statusCommand = CommandUI {
+ commandName = "status",
+ commandSynopsis = "Show status(??)",
+ commandDescription = Just $ \_pname ->
+ "TODO: this is the commandDescription for statusCommand\n",
+ commandUsage = usagePackages "status",
+ commandDefaultFlags = defaultStatusFlags,
+ commandOptions = \_ ->
+ [ optionVerbosity statusVerbosity (\v flags -> flags { statusVerbosity = v })
+ , option [] ["to-portage"]
+ "Print only packages likely to be interesting to move to the portage tree."
+ statusToPortage (\v flags -> flags { statusToPortage = v })
+ trueArg
+ ]
+ }
+
+statusAction :: StatusFlags -> [String] -> GlobalFlags -> IO ()
+statusAction flags args globalFlags = do
+ let verbosity = fromFlag (statusVerbosity flags)
+ toPortdir = fromFlag (statusToPortage flags)
+ portagePath <- getPortageDir verbosity globalFlags
+ overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)
+ runStatus verbosity portagePath overlayPath toPortdir args
+
+-----------------------------------------------------------------------
+-- Merge
+-----------------------------------------------------------------------
+
+data MergeFlags = MergeFlags {
+ mergeVerbosity :: Flag Verbosity
+ -- , mergeServerURI :: Flag String
+ }
+
+instance Monoid MergeFlags where
+ mempty = MergeFlags {
+ mergeVerbosity = mempty
+ -- , mergeServerURI = mempty
+ }
+ mappend a b = MergeFlags {
+ mergeVerbosity = combine mergeVerbosity
+ -- , mergeServerURI = combine mergeServerURI
+ }
+ where combine field = field a `mappend` field b
+
+defaultMergeFlags :: MergeFlags
+defaultMergeFlags = MergeFlags {
+ mergeVerbosity = Flag normal
+ -- , mergeServerURI = Flag defaultHackageServerURI
+ }
+
+mergeCommand :: CommandUI MergeFlags
+mergeCommand = CommandUI {
+ commandName = "merge",
+ commandSynopsis = "Make an ebuild out of hackage package",
+ commandDescription = Just $ \_pname ->
+ "TODO: this is the commandDescription for mergeCommand\n",
+ commandUsage = usagePackages "merge",
+ commandDefaultFlags = defaultMergeFlags,
+ commandOptions = \_showOrParseArgs ->
+ [ optionVerbosity mergeVerbosity (\v flags -> flags { mergeVerbosity = v })
+
+ {-
+ , option [] ["server"]
+ "Set the server you'd like to update the cache from"
+ mergeServerURI (\v flags -> flags { mergeServerURI = v} )
+ (reqArgFlag "SERVER")
+ -}
+ ]
+ }
+
+mergeAction :: MergeFlags -> [String] -> GlobalFlags -> IO ()
+mergeAction flags extraArgs globalFlags = do
+ let verbosity = fromFlag (mergeVerbosity flags)
+ overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)
+ let repo = defaultRepo overlayPath
+ merge verbosity repo (defaultRepoURI overlayPath) extraArgs overlayPath
+
+-----------------------------------------------------------------------
+-- DistroMap
+-----------------------------------------------------------------------
+
+data DistroMapFlags = DistroMapFlags {
+ distroMapVerbosity :: Flag Verbosity
+ }
+
+instance Monoid DistroMapFlags where
+ mempty = DistroMapFlags {
+ distroMapVerbosity = mempty
+ -- , mergeServerURI = mempty
+ }
+ mappend a b = DistroMapFlags {
+ distroMapVerbosity = combine distroMapVerbosity
+ }
+ where combine field = field a `mappend` field b
+
+defaultDistroMapFlags :: DistroMapFlags
+defaultDistroMapFlags = DistroMapFlags {
+ distroMapVerbosity = Flag normal
+ }
+
+distroMapCommand :: CommandUI DistroMapFlags
+distroMapCommand = CommandUI {
+ commandName = "distromap",
+ commandSynopsis = "Build a distromap file",
+ commandDescription = Just $ \_pname ->
+ "TODO: this is the commandDescription for distroMapCommand\n",
+ commandUsage = usagePackages "distromap",
+ commandDefaultFlags = defaultDistroMapFlags,
+ commandOptions = \_showOrParseArgs ->
+ [ optionVerbosity distroMapVerbosity (\v flags -> flags { distroMapVerbosity = v })
+ ]
+ }
+
+distroMapAction :: DistroMapFlags-> [String] -> GlobalFlags -> IO ()
+distroMapAction flags extraArgs globalFlags = do
+ let verbosity = fromFlag (distroMapVerbosity flags)
+ overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)
+ let repo = defaultRepo overlayPath
+ portagePath <- getPortageDir verbosity globalFlags
+ distroMap verbosity repo portagePath overlayPath extraArgs
+
+-----------------------------------------------------------------------
+-- Utils
+-----------------------------------------------------------------------
+
+defaultRepo :: FilePath -> Repo
+defaultRepo overlayPath =
+ Repo {
+ repoKind = Left hackage,
+ repoLocalDir = overlayPath </> ".hackport"
+ }
+ where
+ hackage = RemoteRepo server_name uri
+ server_name = "hackage.haskell.org"
+ uri = URI "http:" (Just (URIAuth "" server_name "")) "/packages/archive" "" ""
+
+defaultRepoURI :: FilePath -> URI
+defaultRepoURI overlayPath =
+ case repoKind (defaultRepo overlayPath) of
+ Left (RemoteRepo { remoteRepoURI = uri }) -> uri
+ Right _ -> error $ "defaultRepoURI: unable to get URI for " ++ overlayPath
+
+getServerURI :: String -> IO URI
+getServerURI str =
+ case parseURI str of
+ Just uri -> return uri
+ Nothing -> throwEx (InvalidServer str)
+
+reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description ->
+ (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b
+reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList
+
+usagePackages :: String -> String -> String
+usagePackages op_name pname =
+ "Usage: " ++ pname ++ " " ++ op_name ++ " [FLAGS] [PACKAGE]\n\n"
+ ++ "Flags for " ++ op_name ++ ":"
+
+usageFlags :: String -> String -> String
+usageFlags flag_name pname =
+ "Usage: " ++ pname ++ " " ++ flag_name ++ " [FLAGS]\n\n"
+ ++ "Flags for " ++ flag_name ++ ":"
+
+getPortageDir :: Verbosity -> GlobalFlags -> IO FilePath
+getPortageDir verbosity globalFlags = do
+ let portagePathM = fromFlag (globalPathToPortage globalFlags)
+ portagePath <- case portagePathM of
+ Nothing -> Host.portage_dir <$> Host.getInfo
+ Just path -> return path
+ exists <- doesDirectoryExist $ portagePath </> "dev-haskell"
+ when (not exists) $
+ warn verbosity $ "Looks like an invalid portage directory: " ++ portagePath
+ return portagePath
+
+-----------------------------------------------------------------------
+-- Main
+-----------------------------------------------------------------------
+
+data GlobalFlags =
+ GlobalFlags { globalVersion :: Flag Bool
+ , globalNumericVersion :: Flag Bool
+ , globalPathToOverlay :: Flag (Maybe FilePath)
+ , globalPathToPortage :: Flag (Maybe FilePath)
+ }
+
+defaultGlobalFlags :: GlobalFlags
+defaultGlobalFlags =
+ GlobalFlags { globalVersion = Flag False
+ , globalNumericVersion = Flag False
+ , globalPathToOverlay = Flag Nothing
+ , globalPathToPortage = Flag Nothing
+ }
+
+globalCommand :: CommandUI GlobalFlags
+globalCommand = CommandUI {
+ commandName = "",
+ commandSynopsis = "",
+ commandDescription = Just $ \_pname ->
+ "TODO: this is the commandDescription for globalCommand\n",
+ commandUsage = \_ -> [],
+ commandDefaultFlags = defaultGlobalFlags,
+ commandOptions = \_showOrParseArgs ->
+ [ 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 ['p'] ["overlay-path"]
+ "Override search path list where .hackport/ lives (default list: ['.', paludis-ovls or emerge-ovls])"
+ globalPathToOverlay (\ovrl_path flags -> flags { globalPathToOverlay = ovrl_path })
+ (reqArg' "PATH" (Flag . Just) (\(Flag ms) -> catMaybes [ms]))
+ , option [] ["portage-path"]
+ "Override path to your portage tree"
+ globalPathToPortage (\port_path flags -> flags { globalPathToPortage = port_path })
+ (reqArg' "PATH" (Flag . Just) (\(Flag ms) -> catMaybes [ms]))
+ ]
+ }
+
+mainWorker :: [String] -> IO ()
+mainWorker args =
+ case commandsRun globalCommand commands args of
+ CommandHelp help -> printHelp help
+ CommandList opts -> printOptionsList opts
+ CommandErrors errs -> printErrors errs
+ CommandReadyToGo (globalflags, commandParse) -> do
+ case commandParse of
+ _ | fromFlag (globalVersion globalflags) -> printVersion
+ | fromFlag (globalNumericVersion globalflags) -> printNumericVersion
+ CommandHelp help -> printHelp help
+ CommandList opts -> printOptionsList opts
+ CommandErrors errs -> printErrors errs
+ CommandReadyToGo action -> catchEx (action globalflags) errorHandler
+ where
+ printHelp help = getProgName >>= putStr . help
+ printOptionsList = putStr . unlines
+ printErrors errs = do
+ putStr (concat (intersperse "\n" errs))
+ exitFailure
+ printNumericVersion = putStrLn $ display Paths_hackport.version
+ printVersion = putStrLn $ "hackport version "
+ ++ display Paths_hackport.version
+ ++ "\nusing cabal-install "
+ ++ display Paths_cabal_install.version
+ ++ " and the Cabal library version "
+ ++ display cabalVersion
+ errorHandler :: HackPortError -> IO ()
+ errorHandler e = do
+ putStrLn (hackPortShowError e)
+ commands =
+ [ listCommand `commandAddAction` listAction
+ , makeEbuildCommand `commandAddAction` makeEbuildAction
+ , statusCommand `commandAddAction` statusAction
+ , diffCommand `commandAddAction` diffAction
+ , updateCommand `commandAddAction` updateAction
+ , mergeCommand `commandAddAction` mergeAction
+ , distroMapCommand `commandAddAction` distroMapAction
+ ]
main :: IO ()
-main = do
- res <- performHPAction hpmain
- case res of
- Right _ -> return ()
- Left err -> do
- hPutStrLn stderr "An error occurred. To get more info run with --verbosity=debug"
- hPutStrLn stderr (hackPortShowError err)
+main = getArgs >>= mainWorker
diff --git a/Merge.hs b/Merge.hs
new file mode 100644
index 0000000..3448e16
--- /dev/null
+++ b/Merge.hs
@@ -0,0 +1,378 @@
+{-# OPTIONS -XPatternGuards #-}
+{- | Merge a package from hackage to an ebuild.
+
+Merging a library
+=================
+
+Compile time:
+ ghc
+ cabal
+ build tools
+ deps (haskell dependencies)
+ extra-libs (c-libs)
+
+Run time:
+ ghc
+ deps (haskell dependencies)
+ extra-libs (c-libs)
+
+RDEPEND="ghc ${DEPS} ${EXTRALIBS}"
+DEPEND="${RDEPEND} cabal ${BUILDTOOLS}"
+
+Merging an executable
+=====================
+Packages with both executable and library must be treated as libraries, as it will impose a stricter DEPEND.
+
+Compile time:
+ ghc
+ cabal
+ build tools
+ deps
+ extra-libs (c-libs)
+
+Run time:
+ extra-libs (c-libs)
+
+RDEPEND="${EXTRALIBS}"
+DEPEND="${RDEPEND} ghc cabal ${DEPS} ${BUILDTOOLS}"
+
+-}
+module Merge
+ ( merge ) 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.PackageDescription ( PackageDescription(..)
+ , FlagName(..)
+ , libBuildInfo
+ , buildInfo
+ , buildable
+ , extraLibs
+ , buildTools
+ , hasLibs )
+import Distribution.PackageDescription.Configuration
+ ( finalizePackageDescription )
+import Distribution.Text (display)
+
+import System.Directory ( getCurrentDirectory
+ , setCurrentDirectory
+ , createDirectoryIfMissing
+ )
+import System.Cmd (system)
+import System.FilePath ((</>))
+
+import qualified Cabal2Ebuild as E
+import Cabal2Ebuild
+import Error as E
+
+import qualified Distribution.Package as Cabal
+import qualified Distribution.Version as Cabal
+
+import Distribution.System (buildPlatform)
+import Distribution.Verbosity
+import Distribution.Simple.Utils
+
+import Network.URI
+
+import Distribution.Client.IndexUtils ( getAvailablePackages )
+import Distribution.Client.HttpUtils ( downloadURI )
+import qualified Distribution.Client.PackageIndex as Index
+import Distribution.Client.Types
+
+import qualified Portage.PackageId as Portage
+import qualified Portage.Version as Portage
+import qualified Portage.Dependency as Portage
+import qualified Portage.Host as Host
+import qualified Portage.Overlay as Overlay
+import qualified Portage.Resolve as Portage
+
+import Debug.Trace ( trace )
+
+(<->) :: String -> String -> String
+a <-> b = a ++ '-':b
+
+(<.>) :: String -> String -> String
+a <.> b = a ++ '.':b
+
+{-
+Requested features:
+ * Copy the old keywords and ~arch them
+ * Add files to darcs?
+ * Print diff with the next latest version?
+BUGS:
+ * Dependencies are always expected to be in dev-haskell
+-}
+
+readPackageString :: [String]
+ -> Either HackPortError ( Maybe Portage.Category
+ , Cabal.PackageName
+ , Maybe Portage.Version
+ )
+readPackageString args = do
+ packageString <-
+ case args of
+ [] -> Left (ArgumentError "Need an argument, [category/]package[-version]")
+ [pkg] -> return pkg
+ _ -> Left (ArgumentError ("Too many arguments: " ++ unwords args))
+ case Portage.parseFriendlyPackage packageString of
+ Just v@(_,_,Nothing) -> return v
+ -- we only allow versions we can convert into cabal versions
+ Just v@(_,_,Just (Portage.Version _ Nothing [] 0)) -> return v
+ _ -> Left (ArgumentError ("Could not parse [category/]package[-version]: " ++ packageString))
+
+
+
+-- | Given a list of available packages, and maybe a preferred version,
+-- return the available package with that version. Latest version is chosen
+-- if no preference.
+resolveVersion :: [AvailablePackage] -> Maybe Cabal.Version -> Maybe AvailablePackage
+resolveVersion avails Nothing = Just $ maximumBy (comparing packageInfoId) avails
+resolveVersion avails (Just ver) = listToMaybe (filter match avails)
+ where
+ match avail = ver == pkgVersion (packageInfoId avail)
+
+merge :: Verbosity -> Repo -> URI -> [String] -> FilePath -> IO ()
+merge verbosity repo serverURI args overlayPath = do
+ (m_category, user_pName, m_version) <-
+ case readPackageString args of
+ Left err -> throwEx err
+ Right (c,p,m_v) ->
+ case m_v of
+ Nothing -> return (c,p,Nothing)
+ Just v -> case Portage.toCabalVersion v of
+ Nothing -> throwEx (ArgumentError "illegal version")
+ Just ver -> return (c,p,Just ver)
+
+ debug verbosity $ "Category: " ++ show m_category
+ debug verbosity $ "Package: " ++ show user_pName
+ debug verbosity $ "Version: " ++ show m_version
+
+ let (Cabal.PackageName user_pname_str) = user_pName
+
+ overlay <- Overlay.loadLazy overlayPath
+ portage_path <- Host.portage_dir `fmap` Host.getInfo
+ portage <- Overlay.loadLazy portage_path
+ index <- fmap packageIndex $ getAvailablePackages verbosity [ repo ]
+
+ -- find all packages that maches the user specified package name
+ availablePkgs <-
+ case Index.searchByName index user_pname_str of
+ Index.None -> throwEx (PackageNotFound user_pname_str)
+ Index.Ambiguous pkgs -> throwEx (ArgumentError ("Ambiguous name: " ++ unwords (map show pkgs)))
+ Index.Unambiguous pkg -> return pkg
+
+ -- select a single package taking into account the user specified version
+ selectedPkg <-
+ case resolveVersion availablePkgs m_version of
+ Nothing -> do
+ putStrLn "No such version for that package, available versions:"
+ forM_ availablePkgs $ \ avail ->
+ putStrLn (display . packageInfoId $ avail)
+ throwEx (ArgumentError "no such version for that package")
+ Just avail -> return avail
+
+ -- print some info
+ info verbosity "Selecting package:"
+ forM_ availablePkgs $ \ avail -> do
+ let match_text | packageInfoId avail == packageInfoId selectedPkg = "* "
+ | otherwise = "- "
+ info verbosity $ match_text ++ (display . packageInfoId $ avail)
+
+ let cabal_pkgId = packageInfoId selectedPkg
+ norm_pkgId = Portage.normalizeCabalPackageId cabal_pkgId
+ norm_pkgName = packageName norm_pkgId
+ cat <- Portage.resolveCategory verbosity overlay norm_pkgName
+
+ let pkgGenericDesc = packageDescription selectedPkg
+ Right (pkgDesc0, flags) =
+ finalizePackageDescription
+ [ -- XXX: common things we should enable/disable?
+ -- (FlagName "small_base", True) -- try to use small base
+ (FlagName "cocoa", False)
+ ]
+ (\dep -> trace ("accepting dep(?): " ++ display dep) True)
+ -- (Nothing :: Maybe (Index.PackageIndex PackageIdentifier))
+ buildPlatform
+ (CompilerId GHC (Cabal.Version [6,10,4] []))
+ [] pkgGenericDesc
+ pkgDesc = let deps = [ Dependency pn (Cabal.simplifyVersionRange vr)
+ | Dependency pn vr <- buildDepends pkgDesc0
+ ]
+ in pkgDesc0 { buildDepends = deps }
+
+ hasBuildableExes p =
+ any (buildable . buildInfo)
+ . executables $ p
+ treatAsLibrary = (not . hasBuildableExes) pkgDesc && hasLibs pkgDesc
+
+ -- calculate build tools
+ bt = [ pkg' -- TODO: currently ignoring version range
+ | Cabal.Dependency (Cabal.PackageName pkg ) _range <- buildToolsDeps pkgDesc
+ , Just pkg' <- return (lookup pkg buildToolsTable)
+ ]
+
+ packageNameResolver s = do
+ (Portage.PackageName (Portage.Category p_cat) (Cabal.PackageName pn))
+ <- Portage.resolveFullPortageName portage (Cabal.PackageName s)
+ return $ E.AnyVersionOf (p_cat </> pn)
+
+ -- calculate extra-libs
+ extra <- findCLibs verbosity packageNameResolver pkgDesc
+
+ debug verbosity ("Selected flags: " ++ show flags)
+ debug verbosity ("extra-libs: ")
+ mapM_ (debug verbosity . show) extra
+
+ debug verbosity ("build-tools:")
+ mapM_ (debug verbosity . show) bt
+
+ -- debug verbosity ("Finalized package:\n" ++ showPackageDescription pkgDesc)
+
+ -- TODO: more fixes
+ -- * inherit keywords from previous ebuilds
+ let d e = if treatAsLibrary
+ then Portage.showDepend (cabal_dep e)
+ : "${RDEPEND}"
+ : [ "${BUILDTOOLS}" | not . null $ build_tools e ]
+ else Portage.showDepend (cabal_dep e)
+ : Portage.showDepend (ghc_dep e)
+ : "${RDEPEND}"
+ : [ "${BUILDTOOLS}" | not . null $ build_tools e ]
+ ++ [ "${HASKELLDEPS}" | not . null $ haskell_deps e ]
+ rd e = if treatAsLibrary
+ then Portage.showDepend (ghc_dep e)
+ : [ "${HASKELLDEPS}" | not . null $ haskell_deps e ]
+ ++ [ "${EXTRALIBS}" | not . null $ extra_libs e ]
+ else [ "${EXTRALIBS}" | not . null $ extra_libs e ]
+ let ebuild = fixSrc serverURI (packageId pkgDesc)
+ . (\e -> e { depend = d e } )
+ . (\e -> e { rdepend = rd e } )
+ . (\e -> e { extra_libs = extra_libs e ++ extra } )
+ . (\e -> e { build_tools = build_tools e ++ bt } )
+ $ E.cabal2ebuild pkgDesc
+
+ debug verbosity ("Treat as library: " ++ show treatAsLibrary)
+ mergeEbuild verbosity overlayPath (Portage.unCategory cat) ebuild
+ fetchAndDigest
+ verbosity
+ (overlayPath </> display cat </> display norm_pkgName)
+ (display cabal_pkgId <.> "tar.gz")
+ (mkUri cabal_pkgId)
+
+findCLibs :: Verbosity -> (String -> Maybe E.Dependency) -> PackageDescription -> IO [E.Dependency]
+findCLibs verbosity portageResolver (PackageDescription { library = lib, executables = exes }) = do
+ debug verbosity "Mapping extra-libraries into portage packages..."
+ -- for extra libs we don't find, maybe look into into installed packages?
+ when (not . null $ notFound) $
+ warn verbosity ("Could not find portage packages for extra-libraries: " ++ unwords notFound)
+ when (not . null $ found) $
+ debug verbosity ("Found c-libraries deps: " ++ show found)
+ return found
+ where
+ resolvers = [ staticTranslateExtraLib, portageResolver ]
+
+ resolved = [ chain p resolvers
+ | p <- libE ++ exeE
+ ] :: [Either String E.Dependency]
+
+ notFound = [ p | Left p <- resolved ]
+ found = [ p | Right p <- resolved ]
+
+ chain v [] = Left v
+ chain v (f:fs) = case f v of
+ Nothing -> chain v fs
+ Just x -> Right x
+
+ libE = maybe [] (extraLibs.libBuildInfo) lib
+ exeE = concatMap (extraLibs.buildInfo) exes
+
+staticTranslateExtraLib :: String -> Maybe E.Dependency
+staticTranslateExtraLib lib = lookup lib m
+ where
+ m = [ ("z", E.AnyVersionOf "sys-libs/zlib")
+ , ("bz2", E.AnyVersionOf "sys-libs/bzlib")
+ , ("mysqlclient", E.LaterVersionOf (Portage.Version [4,0] Nothing [] 0) "virtual/mysql")
+ , ("pq", E.LaterVersionOf (Portage.Version [7] Nothing [] 0) "virtual/postgresql-base")
+ , ("ev", E.AnyVersionOf "dev-libs/libev")
+ ]
+
+buildToolsDeps :: PackageDescription -> [Cabal.Dependency]
+buildToolsDeps (PackageDescription { library = lib, executables = exes }) = cabalDeps
+ where
+ cabalDeps = depL ++ depE
+ depL = maybe [] (buildTools.libBuildInfo) lib
+ depE = concatMap (buildTools.buildInfo) exes
+
+buildToolsTable :: [(String, E.Dependency)]
+buildToolsTable =
+ [ ("happy", E.AnyVersionOf "dev-haskell/happy")
+ , ("alex", E.AnyVersionOf "dev-haskell/alex")
+ , ("c2hs", E.AnyVersionOf "dev-haskell/c2hs")
+ ]
+
+mkUri :: Cabal.PackageIdentifier -> URI
+mkUri pid =
+ -- example:
+ -- http://hackage.haskell.org/packages/archive/Cabal/1.4.0.2/Cabal-1.4.0.2.tar.gz
+ fromJust $ parseURI $
+ "http://hackage.haskell.org/packages/archive/"
+ </> p_name </> p_ver </> p_name <-> p_ver <.> "tar.gz"
+ where
+ p_ver = display (packageVersion pid)
+ p_name = display (packageName pid)
+
+fetchAndDigest :: Verbosity
+ -> FilePath -- ^ directory of ebuild
+ -> String -- ^ tarball name
+ -> URI -- ^ tarball uri
+ -> IO ()
+fetchAndDigest verbosity ebuildDir tarballName tarballURI =
+ withWorkingDirectory ebuildDir $ do
+ repo_info <- Host.getInfo
+ let tarDestination = (Host.distfiles_dir repo_info) </> tarballName
+ downloadURI verbosity tarballURI tarDestination
+ -- Just err -> throwEx (E.DownloadFailed (show tarballURI) (show err))
+ -- TODO: downloadURI will throw a non-hackport exception if the
+ -- download fails
+ notice verbosity $ "Saved to " ++ tarDestination
+ notice verbosity "Recalculating digests..."
+ _ <- system "repoman manifest"
+ return ()
+
+withWorkingDirectory :: FilePath -> IO a -> IO a
+withWorkingDirectory newDir action = do
+ oldDir <- getCurrentDirectory
+ bracket
+ (setCurrentDirectory newDir)
+ (\_ -> setCurrentDirectory oldDir)
+ (\_ -> action)
+
+mergeEbuild :: Verbosity -> FilePath -> String -> EBuild -> IO ()
+mergeEbuild verbosity target cat ebuild = do
+ let edir = target </> cat </> name ebuild
+ elocal = name ebuild ++"-"++ version ebuild <.> "ebuild"
+ epath = edir </> elocal
+ createDirectoryIfMissing True edir
+ info verbosity $ "Writing " ++ elocal
+ writeFile epath (showEBuild ebuild)
+
+fixSrc :: URI -> PackageIdentifier -> EBuild -> EBuild
+fixSrc serverURI p ebuild =
+ ebuild {
+ 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/cgi-bin/hackage-scripts/package/"
+ ++ display (pkgName p)
+ x -> x
+ }
diff --git a/Overlays.hs b/Overlays.hs
index d18ab80..6a4614a 100644
--- a/Overlays.hs
+++ b/Overlays.hs
@@ -1,59 +1,71 @@
-module Overlays where
+module Overlays
+ ( getOverlayPath
+ ) where
-import Control.Monad.Error
+import Control.Monad
+import Data.List (nub, inits)
+import Data.Maybe (maybeToList, listToMaybe, isJust, fromJust)
import System.Directory
-import Data.Maybe
-import Data.List (nub)
+import System.FilePath ((</>), splitPath, joinPath)
-import Bash
-import Action
-import Config
import Error
import CacheFile
+import Portage.Host
-getOverlayPath :: HPAction String
-getOverlayPath = do
- cfg <- getCfg
- case overlayPath cfg of
- Nothing -> do
- tree <- getOverlay `sayDebug` ("Guessing overlay...\n",\tree->"Found '"++tree++"'")
- setOverlayPath $ Just tree
- return tree
- Just tree -> return tree
-
-getOverlay :: HPAction String
-getOverlay = do
- overlays <- getOverlays
- case overlays of
- [] -> throwError NoOverlay
- [x] -> return x
- mul -> search mul
+-- cabal
+import Distribution.Verbosity
+import Distribution.Simple.Utils ( info )
+
+getOverlayPath :: Verbosity -> Maybe FilePath -> IO String
+getOverlayPath verbosity override_overlay = do
+ overlays <- if isJust override_overlay
+ then do info verbosity $ "Forced " ++ fromJust override_overlay
+ return [fromJust override_overlay]
+ else getOverlays
+ case overlays of
+ [] -> throwEx NoOverlay
+ [x] -> return x
+ mul -> search mul
where
- search :: [String] -> HPAction String
+ search :: [String] -> IO String
search mul = do
- let loop [] = throwError $ MultipleOverlays mul
- loop (x:xs) = (do
- found <- liftIO (doesFileExist (cacheFile x))
- `sayDebug` ("Checking '"++x++"'...\n",\res->if res then "found.\n" else "not found.")
+ let loop [] = throwEx (MultipleOverlays mul)
+ loop (x:xs) = do
+ info verbosity $ "Checking '" ++ x ++ "'..."
+ found <- doesFileExist (cacheFile x)
if found
- then return x
- else loop xs)
- whisper "There are several overlays in your /etc/make.conf"
- mapM (\x-> whisper (" * " ++x)) mul
- whisper "Looking for one with a HackPort cache..."
+ then do
+ info verbosity "OK!"
+ return x
+ else do
+ info verbosity "Not ok."
+ loop xs
+ info verbosity "There are several overlays in your configuration."
+ mapM_ (info verbosity . (" * " ++)) mul
+ info verbosity "Looking for one with a HackPort cache..."
overlay <- loop mul
- whisper ("I choose " ++ overlay)
- whisper "Override my decision with hackport -p /my/overlay"
+ info verbosity $ "I choose " ++ overlay
+ info verbosity "Override my decision with hackport --overlay /my/overlay"
return overlay
-portageOverlays :: HPAction [String]
-portageOverlays = runBash "source /etc/make.conf;echo -n $PORTDIR_OVERLAY" >>= (return.words)
+getOverlays :: IO [String]
+getOverlays = do
+ local <- getLocalOverlay
+ overlays <- overlay_list `fmap` getInfo
+ return $ nub $ map clean $
+ maybeToList local
+ ++ overlays
+ where
+ clean path = case reverse path of
+ '/':p -> reverse p
+ _ -> path
+
+getLocalOverlay :: IO (Maybe FilePath)
+getLocalOverlay = do
+ curDir <- getCurrentDirectory
+ let lookIn = map joinPath . reverse . inits . splitPath $ curDir
+ fmap listToMaybe (filterM probe lookIn)
-paludisOverlays :: HPAction [String]
-paludisOverlays = return []
+ where
+ probe dir = doesDirectoryExist (dir </> "dev-haskell")
-getOverlays :: HPAction [String]
-getOverlays = do
- portage <- portageOverlays
- paludis <- paludisOverlays
- return (nub (portage ++ paludis))
diff --git a/P2.hs b/P2.hs
index 6df3902..3c32437 100644
--- a/P2.hs
+++ b/P2.hs
@@ -13,23 +13,23 @@ import qualified Distribution.PackageDescription as Cabal
import Data.Map (Map)
import qualified Data.Map as Map
-import Data.Maybe
import qualified Data.List as List
import System.Directory
-import System.IO
import System.FilePath
import Text.Regex
-import Version
+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 :: Version,
+ eVersion :: Portage.Version,
eFilePath :: FilePath,
ePkgDesc :: Maybe Cabal.GenericPackageDescription }
deriving (Show)
@@ -77,12 +77,10 @@ readPortagePackages portdir packages0 = do
| (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 Version
+ filterVersion :: String -> String -> Maybe Portage.Version
filterVersion p fn = do
[vstring] <- matchRegex (ebuildVersionRegex p) fn
- case (parseVersion vstring) of
- Left e -> fail (show e)
- Right v -> return v
+ simpleParse vstring
ebuildVersionRegex name = mkRegex ("^"++name++"-(.*)\\.ebuild$")
diff --git a/Package.hs b/Package.hs
deleted file mode 100644
index 5048cec..0000000
--- a/Package.hs
+++ /dev/null
@@ -1,76 +0,0 @@
-{-|
- Maintainer : Andres Loeh <kosmikus@gentoo.org>
- Stability : provisional
- Portability : haskell98
-
- Parser for categories and packages.
-
- Shamelessly borrowed from exi, somewhat modified
--}
-
-module Package
- where
-
-import Control.Monad
-import Text.ParserCombinators.Parsec
-
-import Version
-
-type Category = String
-type Package = String
-type Slot = String
-
-getPV :: String -> (Category, Package, Version)
-getPV xs = case parsePV xs of
- Left e ->
- error $ "getPV: cat/pkg-ver parse error '" ++ xs ++ "'\n" ++ show e
- Right x -> x
-
-getP :: String -> (Category, Package)
-getP xs = case parseP xs of
- Left e ->
- error $ "getCatPkg: cat/pkg parse error '" ++ xs ++ "'\n" ++ show e
- Right x -> x
-
-parsePV :: String -> Either ParseError (Category, Package, Version)
-parsePV = parse (readPV >>= \x -> eof >> return x) "<cat/pkg-ver>"
-
-readPV :: GenParser Char st (Category, Package, Version)
-readPV = do cat <- readCat
- char '/'
- (pkg,mver) <- readPkgAndVer
- case mver of
- Nothing -> fail "readPV: version expected"
- Just ver -> return (cat, pkg, ver)
-
-parseP :: String -> Either ParseError (Category, Package)
-parseP = parse (readP >>= \x -> eof >> return x) "<cat/pkg>"
-
-readP :: GenParser Char st (Category, Package)
-readP = do cat <- readCat
- char '/'
- (pkg,mver) <- readPkgAndVer
- case mver of
- Nothing -> return (cat, pkg)
- Just _ -> error "readCatPkg: unexpected version"
-
-readCat :: CharParser st Category
-readPkgAndVer :: CharParser st (Package,Maybe Version)
-
-readCat = many1 (letter <|> digit <|> oneOf "_-")
-readPkgAndVer = do pre <- many1 (letter <|> digit <|> oneOf "_+")
- (p,v) <- option ("",Nothing)
- (do char '-'
- liftM (\v -> ("",Just v)) readVerOrFail
- <|> liftM (\(p,v) -> ('-':p,v)) readPkgAndVer
- )
- return (pre ++ p,v)
-
-readVerOrFail :: CharParser st Version
-readVerOrFail = try $
- do ver <- many1 (letter <|> digit <|> oneOf "_+.-")
- case parseVersion ver of
- Left _ ->
- fail $ "version parse error"
- Right x -> return x
-
diff --git a/Portage/Cabal.hs b/Portage/Cabal.hs
new file mode 100644
index 0000000..a8a3c33
--- /dev/null
+++ b/Portage/Cabal.hs
@@ -0,0 +1,15 @@
+module Portage.Cabal
+ (fromOverlay) where
+
+import qualified Data.Map as Map
+
+import qualified Distribution.Client.PackageIndex as Cabal
+
+import qualified Portage.Overlay as Portage
+
+fromOverlay :: Portage.Overlay -> Cabal.PackageIndex Portage.ExistingEbuild
+fromOverlay overlay = Cabal.fromList $
+ [ ebuild
+ | (_pn, ebuilds) <- Map.toAscList (Portage.overlayMap overlay)
+ , ebuild <- ebuilds
+ ]
diff --git a/Portage/Dependency.hs b/Portage/Dependency.hs
new file mode 100644
index 0000000..f0ffd87
--- /dev/null
+++ b/Portage/Dependency.hs
@@ -0,0 +1,145 @@
+module Portage.Dependency (
+ Dependency(..),
+ showDepend,
+ simplify_deps
+ ) where
+
+import Portage.Version
+import Distribution.Text (display)
+
+import Data.Maybe ( fromJust, catMaybes )
+import Data.List ( nub, groupBy, partition, sortBy )
+import Data.Ord (comparing)
+
+type Package = String
+type UseFlag = String
+
+data Dependency = AnyVersionOf Package
+ | ThisVersionOf Version Package -- =package-version
+ | LaterVersionOf Version Package -- >package-version
+ | EarlierVersionOf Version Package -- <package-version
+ | OrLaterVersionOf Version Package -- >=package-version
+ | OrEarlierVersionOf Version Package -- <=package-version
+ | DependEither Dependency Dependency -- depend || depend
+ | DependIfUse UseFlag Dependency -- use? ( depend )
+ | ThisMajorOf Version Package -- =package-version*
+ deriving (Eq,Show)
+
+showDepend :: Dependency -> Package
+showDepend (AnyVersionOf p) = p
+showDepend (ThisVersionOf v p) = "~" ++ p ++ "-" ++ display v
+showDepend (LaterVersionOf v p) = ">" ++ p ++ "-" ++ display v
+showDepend (EarlierVersionOf v p) = "<" ++ p ++ "-" ++ display v
+showDepend (OrLaterVersionOf v p) = ">=" ++ p ++ "-" ++ display v
+showDepend (OrEarlierVersionOf v p) = "<=" ++ p ++ "-" ++ display v
+showDepend (DependEither dep1 dep2) = showDepend dep1
+ ++ " || " ++ showDepend dep2
+showDepend (DependIfUse useflag dep@(DependEither _ _))
+ = useflag ++ "? " ++ showDepend dep
+showDepend (DependIfUse useflag dep) = useflag ++ "? ( " ++ showDepend dep++ " )"
+showDepend (ThisMajorOf v p) = "=" ++ p ++ "-" ++ display v ++ "*"
+
+{- Here goes code for dependencies simplification -}
+
+simplify_group_table :: Package ->
+ Maybe Version ->
+ Maybe Version ->
+ Maybe Version ->
+ Maybe Version ->
+ Maybe Version -> [Dependency]
+
+-- simplify_group_table p ol l e oe exact
+-- 1) trivial cases:
+simplify_group_table p Nothing Nothing Nothing Nothing Nothing = error $ p ++ ": unsolvable constraints"
+simplify_group_table p (Just v) Nothing Nothing Nothing Nothing = [OrLaterVersionOf v p]
+simplify_group_table p Nothing (Just v) Nothing Nothing Nothing = [LaterVersionOf v p]
+simplify_group_table p Nothing Nothing (Just v) Nothing Nothing = [EarlierVersionOf v p]
+simplify_group_table p Nothing Nothing Nothing (Just v) Nothing = [OrEarlierVersionOf v p]
+simplify_group_table p Nothing Nothing Nothing Nothing (Just v) = [ThisVersionOf v p]
+
+-- 2) simplification passes
+simplify_group_table p (Just (Version v1 _ _ _)) Nothing (Just (Version v2 _ _ _)) Nothing Nothing
+ -- special case: >=a-v.N a<v.(N+1) => =a-v.N*
+ | (init v1 == init v2) && (last v2 == last v1 + 1) = [ThisMajorOf (Version v1 Nothing [] 0) p]
+ | otherwise = [OrLaterVersionOf (Version v1 Nothing [] 0) p, EarlierVersionOf (Version v2 Nothing [] 0) p]
+
+-- TODO: simplify constraints of type: >=a-v1; > a-v2 and such
+
+-- o3) therwise sink:
+simplify_group_table p (Just v) l@(_) e@(_) oe@(_) exact@(_) = OrLaterVersionOf v p : simplify_group_table p Nothing l e oe exact
+simplify_group_table p ol@(Nothing) (Just v) e@(_) oe@(_) exact@(_) = LaterVersionOf v p : simplify_group_table p ol Nothing e oe exact
+simplify_group_table p ol@(Nothing) l@(Nothing) (Just v) oe@(_) exact@(_) = EarlierVersionOf v p : simplify_group_table p ol l Nothing oe exact
+simplify_group_table p ol@(Nothing) l@(Nothing) e@(Nothing) (Just v) exact@(_) = OrEarlierVersionOf v p : simplify_group_table p ol l e Nothing exact
+-- already defined earlier
+-- simplify_group_table p ol@(Nothing) l@(Nothing) e@(Nothing) oe@(Nothing) (Just v) = OrEarlierVersionOf v p : simplify_group_table p ol l e oe Nothing
+
+-- >a-v1 >a-v2 => >a-(max v1 v2)
+-- key idea: all constraints are enforcing constraints, so we can't get
+-- more, than one interval.
+simplify_group :: [Dependency] -> [Dependency]
+simplify_group [dep@(AnyVersionOf _package)] = [dep]
+simplify_group [dep@(ThisMajorOf _v _p)] = [dep]
+simplify_group deps = simplify_group_table package
+ min_or_later_v -- >=
+ min_later_v -- >
+ max_earlier_v -- <
+ max_or_earlier_v -- <=
+ exact_this_v -- ==
+ where
+ package = fromJust.getPackage $ head deps
+ max_earlier_v = safe_minimum $ map earlier_v deps
+ max_or_earlier_v = safe_minimum $ map or_earlier_v deps
+ min_later_v = safe_maximum $ map later_v deps
+ min_or_later_v = safe_maximum $ map or_later_v deps
+ exact_this_v = case catMaybes (map this_v deps) of
+ [] -> Nothing
+ [v] -> Just v
+ xs -> error $ "too many exact versions:" ++ show xs
+ --
+ earlier_v (EarlierVersionOf v _p) = Just v
+ earlier_v _ = Nothing
+
+ or_earlier_v (OrEarlierVersionOf v _p) = Just v
+ or_earlier_v _ = Nothing
+
+ later_v (LaterVersionOf v _p) = Just v
+ later_v _ = Nothing
+
+ or_later_v (OrLaterVersionOf v _p) = Just v
+ or_later_v _ = Nothing
+
+ this_v (ThisVersionOf v _p) = Just v
+ this_v _ = Nothing
+ --
+ safe_minimum xs = case catMaybes xs of
+ [] -> Nothing
+ xs' -> Just $ minimum xs'
+ safe_maximum xs = case catMaybes xs of
+ [] -> Nothing
+ xs' -> Just $ maximum xs'
+
+-- divide packages to groups (by package name), simplify groups, merge again
+simplify_deps :: [Dependency] -> [Dependency]
+simplify_deps deps = (concatMap (simplify_group.nub) $
+ groupBy cmpPkgName $
+ sortBy (comparing getPackageString) groupable)
+ ++ ungroupable
+ where (ungroupable, groupable) = partition ((==Nothing).getPackage) deps
+ --
+ cmpPkgName p1 p2 = cmpMaybe (getPackage p1) (getPackage p2)
+ cmpMaybe (Just p1) (Just p2) = p1 == p2
+ cmpMaybe _ _ = False
+ --
+getPackage :: Dependency -> Maybe Package
+getPackage (AnyVersionOf package) = Just package
+getPackage (ThisVersionOf _version package) = Just package
+getPackage (LaterVersionOf _version package) = Just package
+getPackage (EarlierVersionOf _version package) = Just package
+getPackage (OrLaterVersionOf _version package) = Just package
+getPackage (OrEarlierVersionOf _version package) = Just package
+getPackage (DependEither _dependency _Dependency) = Nothing
+getPackage (DependIfUse _useFlag _Dependency) = Nothing
+getPackage (ThisMajorOf _version package) = Just package
+--
+getPackageString :: Dependency -> Package
+getPackageString dep = maybe "" id $ getPackage dep
diff --git a/Portage/Host.hs b/Portage/Host.hs
new file mode 100644
index 0000000..9664374
--- /dev/null
+++ b/Portage/Host.hs
@@ -0,0 +1,102 @@
+module Portage.Host
+ ( getInfo -- :: IO [(String, String)]
+ , LocalInfo(..)
+ ) where
+
+import Util (run_cmd)
+import Data.Char (isSpace)
+import Data.Maybe (fromJust, isJust)
+
+
+data LocalInfo =
+ LocalInfo { distfiles_dir :: String
+ , overlay_list :: [FilePath]
+ , portage_dir :: FilePath
+ }
+
+defaultInfo :: LocalInfo
+defaultInfo = LocalInfo { distfiles_dir = "/usr/portage/distfiles"
+ , overlay_list = []
+ , portage_dir = "/usr/portage"
+ }
+
+-- 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")
+ , return (Just defaultInfo)
+ ]
+ where performMaybes [] = return Nothing
+ performMaybes (act:acts) =
+ do r <- act
+ if isJust r
+ then return r
+ else performMaybes acts
+
+data LocalPaludisOverlay =
+ LocalPaludisOverlay { repo_name :: String
+ , format :: String
+ , location :: FilePath
+ , distdir :: FilePath
+ }
+
+bad_paludis_overlay :: LocalPaludisOverlay
+bad_paludis_overlay =
+ LocalPaludisOverlay { repo_name = undefined
+ , format = undefined
+ , location = undefined
+ , distdir = undefined
+ }
+
+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 }
+
+ _ -> info
+
+parse_paludis_overlays :: String -> [LocalPaludisOverlay]
+parse_paludis_overlays raw_data =
+ parse_paludis_overlays' (reverse $ lines raw_data) bad_paludis_overlay
+
+-- 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
+
+parse_emerge_output :: String -> LocalInfo
+parse_emerge_output raw_data =
+ foldl updateInfo defaultInfo $ lines raw_data
+ where updateInfo info str =
+ case (break (== '=') str) of
+ ("DISTDIR", '=':value)
+ -> info{distfiles_dir = unquote value}
+ ("PORTDIR", '=':value)
+ -> info{portage_dir = unquote value}
+ ("PORTDIR_OVERLAY", '=':value)
+ -> info{overlay_list = words $ unquote value}
+ _ -> info
+ unquote = init . tail
diff --git a/Portage/Overlay.hs b/Portage/Overlay.hs
new file mode 100644
index 0000000..3c1ca2b
--- /dev/null
+++ b/Portage/Overlay.hs
@@ -0,0 +1,169 @@
+module Portage.Overlay
+ ( ExistingEbuild(..)
+ , Overlay(..)
+ , load, loadLazy
+ , readOverlayByPackage, getDirectoryTree, DirectoryTree
+
+ , reduceOverlay
+ , inOverlay
+ )
+ where
+
+import qualified Portage.PackageId as Portage
+
+import qualified Distribution.Package as Cabal
+
+import Distribution.Text (simpleParse, display)
+import Distribution.Simple.Utils ( comparing, equating )
+
+import Data.List as List
+import qualified Data.Map as Map
+import Data.Map (Map)
+import System.Directory (getDirectoryContents, doesDirectoryExist)
+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) ]
+
+--TODO: move this to another module:
+data ExistingEbuild = ExistingEbuild {
+ ebuildId :: Portage.PackageId,
+ ebuildCabalId :: Cabal.PackageIdentifier,
+ ebuildPath :: FilePath
+ } deriving (Show,Ord,Eq)
+
+instance Cabal.Package ExistingEbuild where packageId = ebuildCabalId
+
+data Overlay = Overlay {
+ overlayPath :: FilePath,
+ overlayMap :: Map Portage.PackageName [ExistingEbuild]
+ } deriving Show
+
+inOverlay :: Overlay -> Cabal.PackageId -> Bool
+inOverlay overlay pkgId = not (Map.null packages)
+ where
+ packages = Map.filterWithKey
+ (\(Portage.PackageName _cat overlay_pn) ebuilds ->
+ let cabal_pn = Cabal.pkgName pkgId
+ ebs = [ ()
+ | e <- ebuilds
+ , let ebuild_cabal_id = ebuildCabalId e
+ , ebuild_cabal_id == pkgId
+ ]
+ 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)
+ 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,
+ 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"
+ ])
+ | (pkgName, allVersions) <- packages
+ , let allowedVersions = filter allowed allVersions
+ ]
+ }
+
+-- make sure there is only one ebuild for each version number (by selecting
+-- the highest ebuild version revision)
+reduceOverlay :: Overlay -> Overlay
+reduceOverlay overlay = overlay { overlayMap = Map.map reduceVersions (overlayMap overlay) }
+ where
+ versionNumbers (Portage.Version nums _ _ _) = nums
+ reduceVersions :: [ExistingEbuild] -> [ExistingEbuild]
+ reduceVersions ebuilds = -- gah!
+ map (maximumBy (comparing (Portage.pkgVersion . ebuildId)))
+ . groupBy (equating (versionNumbers . Portage.pkgVersion . ebuildId))
+ . sortBy (comparing (Portage.pkgVersion . ebuildId))
+ $ ebuilds
+
+readOverlayByPackage :: DirectoryTree -> [(Portage.PackageName, [Portage.Version])]
+readOverlayByPackage tree =
+ [ (name, versions name pkgTree)
+ | (category, catTree) <- categories tree
+ , (name, pkgTree) <- packages category catTree
+ ]
+
+ where
+ categories :: DirectoryTree -> [(Portage.Category, DirectoryTree)]
+ categories entries =
+ [ (category, entries')
+ | Directory dir entries' <- entries
+ , Just category <- [simpleParse dir] ]
+
+ packages :: Portage.Category -> DirectoryTree
+ -> [(Portage.PackageName, DirectoryTree)]
+ packages category entries =
+ [ (Portage.PackageName category name, entries')
+ | Directory dir entries' <- entries
+ , Just name <- [simpleParse dir] ]
+
+ versions :: Portage.PackageName -> DirectoryTree -> [Portage.Version]
+ versions name@(Portage.PackageName (Portage.Category category) _) entries =
+ [ version
+ | File fileName <- entries
+ , let (baseName, ext) = splitExtension fileName
+ , ext == ".ebuild"
+ , let fullName = category ++ '/' : baseName
+ , Just (Portage.PackageId name' version) <- [simpleParse fullName]
+ , name == name' ]
+
+readOverlay :: DirectoryTree -> [Portage.PackageId]
+readOverlay tree = [ Portage.PackageId pkgId version
+ | (pkgId, versions) <- readOverlayByPackage tree
+ , version <- versions
+ ]
+
+type DirectoryTree = [DirectoryEntry]
+data DirectoryEntry = File FilePath | Directory FilePath [DirectoryEntry]
+
+getDirectoryTree :: FilePath -> IO DirectoryTree
+getDirectoryTree = dirEntries
+
+ where
+ dirEntries :: FilePath -> IO [DirectoryEntry]
+ dirEntries dir = do
+ names <- getDirectoryContents dir
+ sequence
+ [ do isDirectory <- doesDirectoryExist path
+ if isDirectory
+ then do entries <- unsafeInterleaveIO (dirEntries path)
+ return (Directory name entries)
+ else return (File name)
+ | name <- names
+ , not (ignore name)
+ , let path = dir </> name ]
+
+ ignore ['.'] = True
+ ignore ['.', '.'] = True
+ ignore _ = False
diff --git a/Portage/PackageId.hs b/Portage/PackageId.hs
new file mode 100644
index 0000000..abc5569
--- /dev/null
+++ b/Portage/PackageId.hs
@@ -0,0 +1,113 @@
+-- | Portage package identifiers, which unlike Cabal ones include a category.
+--
+module Portage.PackageId (
+ Category(..),
+ PackageName(..),
+ PackageId(..),
+ Portage.Version(..),
+ fromCabalPackageId,
+ toCabalPackageId,
+ parseFriendlyPackage,
+ normalizeCabalPackageName,
+ normalizeCabalPackageId
+ ) where
+
+import qualified Distribution.Package as Cabal
+import Distribution.Text (Text(..))
+
+import qualified Distribution.Compat.ReadP as Parse
+
+import qualified Portage.Version as Portage
+
+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)
+
+newtype Category = Category { unCategory :: String }
+ deriving (Eq, Ord, Show, Read)
+
+data PackageName = PackageName Category Cabal.PackageName
+ deriving (Eq, Ord, Show, Read)
+
+data PackageId = PackageId { packageId :: PackageName, pkgVersion :: Portage.Version }
+ deriving (Eq, Ord, Show, Read)
+
+{-
+instance Text PN where
+ disp (PN n) = Disp.text n
+ parse = do
+ ns <- Parse.sepBy1 component (Parse.char '-')
+ return (PN (concat (intersperse "-" ns)))
+ where
+ component = do
+ cs <- Parse.munch1 Char.isAlphaNum
+ if all Char.isDigit cs then Parse.pfail else return cs
+ -- each component must contain an alphabetic character, to avoid
+ -- ambiguity in identifiers like foo-1 (the 1 is the version number).
+-}
+
+fromCabalPackageId :: Category -> Cabal.PackageIdentifier -> PackageId
+fromCabalPackageId category (Cabal.PackageIdentifier name version) =
+ PackageId (PackageName category (normalizeCabalPackageName name))
+ (Portage.fromCabalVersion version)
+
+normalizeCabalPackageName :: Cabal.PackageName -> Cabal.PackageName
+normalizeCabalPackageName (Cabal.PackageName name) =
+ Cabal.PackageName (map Char.toLower name)
+
+normalizeCabalPackageId :: Cabal.PackageIdentifier -> Cabal.PackageIdentifier
+normalizeCabalPackageId (Cabal.PackageIdentifier name version) =
+ Cabal.PackageIdentifier (normalizeCabalPackageName name) version
+
+toCabalPackageId :: PackageId -> Maybe Cabal.PackageIdentifier
+toCabalPackageId (PackageId (PackageName _cat name) version) =
+ fmap (Cabal.PackageIdentifier name)
+ (Portage.toCabalVersion version)
+
+instance Text Category where
+ disp (Category c) = Disp.text c
+ parse = fmap Category (Parse.munch1 categoryChar)
+ where
+ categoryChar c = Char.isAlphaNum c || c == '-'
+
+instance Text PackageName where
+ disp (PackageName category name) =
+ disp category <> Disp.char '/' <> disp name
+
+ parse = do
+ category <- parse
+ _ <- Parse.char '/'
+ name <- parse
+ return (PackageName category name)
+
+instance Text PackageId where
+ disp (PackageId name version) =
+ disp name <> Disp.char '-' <> disp version
+
+ parse = do
+ name <- parse
+ _ <- Parse.char '-'
+ version <- parse
+ return (PackageId name version)
+
+parseFriendlyPackage :: String -> Maybe (Maybe Category, Cabal.PackageName, Maybe Portage.Version)
+parseFriendlyPackage str =
+ case [ p | (p,s) <- Parse.readP_to_S parser str
+ , all Char.isSpace s ] of
+ [] -> Nothing
+ (x:_) -> Just x
+ where
+ parser = do
+ mc <- Parse.option Nothing $ do
+ c <- parse
+ _ <- Parse.char '/'
+ return (Just c)
+ p <- parse
+ mv <- Parse.option Nothing $ do
+ _ <- Parse.char '-'
+ v <- parse
+ return (Just v)
+ return (mc, p, mv)
+
diff --git a/Portage/Resolve.hs b/Portage/Resolve.hs
new file mode 100644
index 0000000..090629b
--- /dev/null
+++ b/Portage/Resolve.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE PatternGuards #-}
+
+module Portage.Resolve where
+
+import qualified Portage.Overlay as Overlay
+import qualified Portage.PackageId as Portage
+
+import Distribution.Verbosity
+import Distribution.Text (display)
+import qualified Distribution.Package as Cabal
+import Distribution.Simple.Utils
+
+import qualified Data.Map as Map
+
+import Error
+
+import Debug.Trace (trace)
+
+-- | If a package already exist in the overlay, find which category it has.
+-- If it does not exist, we default to \'dev-haskell\'.
+resolveCategory :: Verbosity -> Overlay.Overlay -> Cabal.PackageName -> IO Portage.Category
+resolveCategory verbosity overlay pn = do
+ info verbosity "Searching for which category to use..."
+ case resolveCategories overlay pn of
+ [] -> do
+ info verbosity "No previous version of this package, defaulting category to dev-haskell."
+ return devhaskell
+ [cat] -> do
+ info verbosity $ "Exact match of already existing package, using category: "
+ ++ display cat
+ return cat
+ cats -> do
+ warn verbosity $ "Multiple matches of categories: " ++ unwords (map display cats)
+ if devhaskell `elem` cats
+ then do notice verbosity "Defaulting to dev-haskell"
+ return devhaskell
+ else do warn verbosity "Multiple matches and no known default. Override by specifying "
+ warn verbosity "package category like so 'hackport merge categoryname/package[-version]."
+ throwEx (ArgumentError "Specify package category and try again.")
+ where
+ devhaskell = Portage.Category "dev-haskell"
+
+resolveCategories :: Overlay.Overlay -> Cabal.PackageName -> [Portage.Category]
+resolveCategories overlay pn =
+ [ cat
+ | (Portage.PackageName cat pn') <- Map.keys om
+ , pn == Portage.normalizeCabalPackageName pn'
+ ]
+ where
+ om = Overlay.overlayMap overlay
+
+resolveFullPortageName :: Overlay.Overlay -> Cabal.PackageName -> Maybe Portage.PackageName
+resolveFullPortageName overlay pn =
+ case resolveCategories overlay pn of
+ [] -> Nothing
+ [cat] -> ret cat
+ cats | (cat:_) <- (filter (`elem` cats) priority) -> ret cat
+ | otherwise -> trace ("Ambiguous package name: " ++ show pn ++ ", hits: " ++ show cats) Nothing
+ where
+ ret c = return (Portage.PackageName c pn)
+ mkC = Portage.Category
+ -- if any of these categories show up in the result list, the match isn't
+ -- ambiguous, pick the first match in the list
+ priority = [ mkC "dev-haskell"
+ , mkC "sys-libs"
+ , mkC "dev-libs"
+ , mkC "x11-libs"
+ , mkC "media-libs"
+ , mkC "net-libs"
+ , mkC "sci-libs"
+ ]
+
diff --git a/Portage/Version.hs b/Portage/Version.hs
new file mode 100644
index 0000000..eefce55
--- /dev/null
+++ b/Portage/Version.hs
@@ -0,0 +1,86 @@
+{-|
+ Author : Andres Loeh <kosmikus@gentoo.org>
+ Stability : provisional
+ Portability : haskell98
+
+ Version parser, according to Portage spec.
+
+ Shamelessly borrowed from exi, ported from Parsec to ReadP
+
+-}
+
+module Portage.Version (
+ Version(..),
+ Suffix(..),
+ fromCabalVersion,
+ toCabalVersion,
+ ) where
+
+import qualified Distribution.Version as Cabal
+
+import Distribution.Text (Text(..))
+
+import qualified Distribution.Compat.ReadP as Parse
+import qualified Text.PrettyPrint as Disp
+import Text.PrettyPrint ((<>))
+import qualified Data.Char as Char (isAlpha, isDigit)
+
+data Version = Version [Int] -- [1,42,3] ~= 1.42.3
+ (Maybe Char) -- optional letter
+ [Suffix]
+ Int -- revision, 0 means none
+ deriving (Eq, Ord, Show, Read)
+
+data Suffix = Alpha Int | Beta Int | Pre Int | RC Int | P Int
+ deriving (Eq, Ord, Show, Read)
+
+fromCabalVersion :: Cabal.Version -> Version
+fromCabalVersion (Cabal.Version nums _tags) = Version nums Nothing [] 0
+
+toCabalVersion :: Version -> Maybe Cabal.Version
+toCabalVersion (Version nums Nothing [] _) = Just (Cabal.Version nums [])
+toCabalVersion _ = Nothing
+
+instance Text Version where
+ disp (Version ver c suf rev) =
+ dispVer ver <> dispC c <> dispSuf suf <> dispRev rev
+ where
+ dispVer = Disp.hcat . Disp.punctuate (Disp.char '.') . map Disp.int
+ dispC = maybe Disp.empty Disp.char
+ dispSuf = Disp.hcat . map disp
+ dispRev 0 = Disp.empty
+ dispRev n = Disp.text "-r" <> Disp.int n
+
+ parse = do
+ ver <- Parse.sepBy1 digits (Parse.char '.')
+ c <- Parse.option Nothing (fmap Just (Parse.satisfy Char.isAlpha))
+ suf <- Parse.many parse
+ rev <- Parse.option 0 (Parse.string "-r" >> digits)
+ return (Version ver c suf rev)
+
+instance Text Suffix where
+ disp suf = case suf of
+ Alpha n -> Disp.text "_alpha" <> dispPos n
+ Beta n -> Disp.text "_beta" <> dispPos n
+ Pre n -> Disp.text "_pre" <> dispPos n
+ RC n -> Disp.text "_rc" <> dispPos n
+ P n -> Disp.text "_p" <> dispPos n
+
+ where
+ dispPos :: Int -> Disp.Doc
+ dispPos 0 = Disp.empty
+ dispPos n = Disp.int n
+
+ parse = Parse.char '_'
+ >> Parse.choice
+ [ Parse.string "alpha" >> fmap Alpha maybeDigits
+ , Parse.string "beta" >> fmap Beta maybeDigits
+ , Parse.string "pre" >> fmap Pre maybeDigits
+ , Parse.string "rc" >> fmap RC maybeDigits
+ , Parse.string "p" >> fmap P maybeDigits
+ ]
+ where
+ maybeDigits = Parse.option 0 digits
+
+digits :: Parse.ReadP r Int
+digits = fmap read (Parse.munch1 Char.isDigit)
diff --git a/Progress.hs b/Progress.hs
new file mode 100644
index 0000000..f318f57
--- /dev/null
+++ b/Progress.hs
@@ -0,0 +1,62 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Progress
+-- Copyright : (c) Duncan Coutts 2008
+-- License : BSD-like
+--
+-- Maintainer : duncan@haskell.org
+-- Portability : portable
+--
+-- Common types for dependency resolution.
+-----------------------------------------------------------------------------
+module Progress (
+ Progress(..),
+ fold, unfold, fromList,
+ ) where
+
+import Prelude hiding (fail)
+
+-- | 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 'Progress' 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
+--
+fold :: (step -> a -> a) -> (fail -> a) -> (done -> a)
+ -> Progress step fail done -> a
+fold step fail done = go
+ where
+ go (Step s p) = step s (go p)
+ go (Fail f) = fail f
+ go (Done r) = done r
+
+unfold :: (s -> Either (Either fail done) (step, s))
+ -> s -> Progress step fail done
+unfold f = go
+ where
+ go s = case f s of
+ Left (Left fail) -> Fail fail
+ Left (Right done) -> Done done
+ Right (step, s') -> Step step (go s')
+
+fromList :: [a] -> Progress () b [a]
+fromList xs0 = unfold next xs0
+ where
+ next [] = Left (Right xs0)
+ next (_:xs) = Right ((), xs)
+
+instance Functor (Progress step fail) where
+ fmap f = fold Step Fail (Done . f)
+
+instance Monad (Progress step fail) where
+ return a = Done a
+ p >>= f = fold Step Fail f p
diff --git a/README b/README
new file mode 100644
index 0000000..ebe91ab
--- /dev/null
+++ b/README
@@ -0,0 +1,111 @@
+Hackport
+========
+
+About
+-----
+
+Hackport is a utility application for Gentoo Linux to ease the tasks for the
+Haskell Project.
+
+The main purpose for Hackport is to interact with Hackage and create
+Ebuilds from Cabal packages. It also does handy functions to compare
+hackage, the overlay and the portage tree.
+
+Features
+--------
+
+ 'hackport update'
+ Update the local copy of hackage's package list. You should run this
+ every once in a while to get a more recent copy.
+
+ 'hackport list [FILTER]'
+ Print packages from hackage, with an optional substring matching.
+
+ 'hackport merge <package>'
+ Create a Gentoo Linux Ebuild for hackage package named <package>.
+ The category defaults to dev-haskell, but is overridden if an older
+ version has been merged previously to another category. The category
+ can also be overridden with the syntax category/package. Example:
+
+ $ hackport merge x11-wm/xmonad
+
+ Hackport will make an ebuild that uses the haskell-cabal eclass, and
+ set the following properties:
+
+ PN (package name)
+ Package name converted into lower case
+ PV (package version)
+ Package version with tags dropped.
+ KEYWORDS
+ Defaults to ~amd64 ~x86
+ CABAL_FEATURES
+ Set to "bin" for executables, and "lib haddock profile" for
+ libraries. Packages that contains both a binary and library will
+ get the union.
+ DEPEND
+ GHC dependency defaults to >=dev-lang/ghc-6.6.1.
+ Cabal dependency is fetched from Cabal field 'Cabal-Version'.
+ All other package dependencies are converted into gentoo syntax.
+ Range dependencies are flattened and usually needs manual
+ tweaking.
+ DESCRIPTION
+ From Synopsis if it is non-empty, otherwise Description.
+ HOMEPAGE
+ From Homepage
+ SRC_URI
+ From package url
+ LICENSE
+ From cabal license converted into gentoo licenses
+ SLOT
+ Defaults to "0"
+
+ 'hackport diff [missing|additions|newer|common]'
+ Prints a list showing a diff between hackage and the overlay.
+ For each package it shows the latest version in both hackage and the
+ overlay.
+
+
+ Optional parameters:
+ 'all', the default action
+ List all packages.
+ 'missing'
+ List packages that exist in hackage but not in the overlay,
+ or where the hackage version is more recent.
+ 'additions'
+ List packages only in the overlay, or where the overlay has
+ a more recent version.
+ 'newer'
+ List packages where hackage has a more recent version.
+ 'common'
+ List packages where hackage and the overlay has the same
+ version.
+
+ 'hackport status [toportage]'
+ Provides an overview comparing the overlay to the portage tree.
+ It will teel you, for each package and version, if the package exist
+
+ - only in the portage tree
+ - only in the overlay
+ - both in the portage tree and the overlay
+ - both in the portage tree and the overlay,
+ but the ebuilds are not identical
+
+ Optional parameters:
+ '--to-portage'
+ Only print packages that are likely to be interesting to
+ move to the portage tree.
+ It will print packages when they exist in both portage and
+ the overlay, and:
+ - the ebuilds differ, or
+ - the overlay has a more recent version
+
+ 'hackport make-ebuild <path/to/package.ebuild>'
+ Generates standalone .ebuild file from .cabal spec and stores result in same
+ directory.
+ Option is useful for packages not-on-hackage and for debug purposes.
+
+-------
+
+ Henning G√ľnther
+ Duncan Coutts
+ Lennart Kolmodin
diff --git a/Status.hs b/Status.hs
index aca18c4..a9328ba 100644
--- a/Status.hs
+++ b/Status.hs
@@ -2,15 +2,11 @@ module Status
( FileStatus(..)
, fromStatus
, status
- , statusAction
+ , runStatus
) where
-import Action
import AnsiColor
-import Bash
import P2
-import Utils
-import Overlays
import Control.Monad.State
@@ -24,6 +20,11 @@ import Data.Map as Map (Map)
import qualified Data.Traversable as T
+-- cabal
+import Distribution.Verbosity
+import Distribution.Simple.Utils (equating, comparing)
+import Distribution.Text(display)
+
data FileStatus a
= Same a
| Differs a a
@@ -32,7 +33,7 @@ data FileStatus a
deriving (Show,Eq)
instance Ord a => Ord (FileStatus a) where
- compare x y = compare (fromStatus x) (fromStatus y)
+ compare = comparing fromStatus
instance Functor FileStatus where
fmap f st =
@@ -50,19 +51,17 @@ fromStatus fs =
OverlayOnly a -> a
PortageOnly a -> a
-status :: HPAction (Map Package [FileStatus Ebuild])
-status = do
- portdir <- getPortdir
- overlayPath <- getOverlayPath
- overlay <- liftIO $ readPortageTree overlayPath
- portage <- liftIO $ readPortagePackages portdir (Map.keys overlay)
+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
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) (comparing eVersion e)
- (Just e2) = lookupEbuildWith overlay (ePackage e) (comparing eVersion 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)
return $ if eq
then Same e
@@ -75,14 +74,17 @@ status = do
]
return meld
-statusAction :: String -> HPAction ()
-statusAction action = do
- let pkgFilter =
- case action of
- "" -> id
- "toportage" -> toPortageFilter
- pkgs <- status
- statusPrinter (pkgFilter pkgs)
+runStatus :: Verbosity -> FilePath -> FilePath -> Bool -> [String] -> IO ()
+runStatus verbosity portdir overlayPath toPortageFlag pkgs = do
+ let pkgFilter | toPortageFlag = toPortageFilter
+ | otherwise = id
+ tree0 <- status verbosity portdir overlayPath
+ let tree = pkgFilter tree0
+ if (null pkgs)
+ then statusPrinter tree
+ else forM_ pkgs $ \pkg -> do
+ let filteredTree = Map.filterWithKey (\k _ -> pPackage k == pkg) tree
+ statusPrinter filteredTree
-- |Only return packages that seems interesting to sync to portage;
--
@@ -104,18 +106,18 @@ toPortageFilter = Map.mapMaybe $ \ sts ->
then Just sts
else Nothing
-statusPrinter :: Map Package [FileStatus Ebuild] -> HPAction ()
+statusPrinter :: Map Package [FileStatus Ebuild] -> IO ()
statusPrinter packages = do
- liftIO $ putStrLn $ toColor (Same "Green") ++ ": package in portage and overlay are the same"
- liftIO $ putStrLn $ toColor (Differs "Yellow" "") ++ ": package in portage and overlay differs"
- liftIO $ putStrLn $ toColor (OverlayOnly "Red") ++ ": package only exist in the overlay"
- liftIO $ putStrLn $ toColor (PortageOnly "Magenta") ++ ": package only exist in the portage tree"
- forM_ (Map.toAscList packages) $ \(pkg, ebuilds) -> liftIO $ 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
putStr " "
forM_ ebuilds $ \e -> do
- putStr $ toColor (fmap (show . eVersion) e)
+ putStr $ toColor (fmap (display . eVersion) e)
putChar ' '
putStrLn ""
@@ -131,12 +133,12 @@ toColor st = inColor c False Default (fromStatus st)
portageDiff :: Portage -> Portage -> (Portage, Portage, Portage)
portageDiff p1 p2 = (in1, ins, in2)
where ins = Map.filter (not . null) $
- Map.intersectionWith (List.intersectBy $ comparing eVersion) p1 p2
+ Map.intersectionWith (List.intersectBy $ equating eVersion) 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 (comparing eVersion)) xs ys in
+ let lst = foldr (List.deleteBy (equating eVersion)) xs ys in
if null lst
then Nothing
else Just lst
@@ -151,7 +153,7 @@ equals fp1 fp2 = do
return (equal' f1 f2)
equal' :: L.ByteString -> L.ByteString -> Bool
-equal' = comparing essence
+equal' = equating essence
where
essence = filter (not . isEmpty) . filter (not . isComment) . L.lines
isComment = L.isPrefixOf (L.pack "#") . L.dropWhile isSpace
diff --git a/TODO b/TODO
new file mode 100644
index 0000000..e8a3db8
--- /dev/null
+++ b/TODO
@@ -0,0 +1,35 @@
+
+Easier
+====
+
+* Document the commands in Main.hs with text from README.
+ commandDescription and commandSynopsis fields in the CommandUI records
+
+* continue on the CLI. see what additional flags the commands need, if there
+ still are any missing. set good default values, and make sure we don't
+ get any 'fromFlag' errors due to missing defaults for all commands
+
+* catch baseconstraints and upgrade ghc requirement
+ (like in vty-4.0.0.1: base >= 4 leads to ghc >= 6.10)
+
+Harder
+======
+
+* translate the dev-db/libpq dependency into virtual/postgresql-base
+ the cabal field to describe c libs should be translated if we know the
+ proper gentoo package name.
+
+* see if PackageIndex and IndexUtils from cabal install can be used instead of Index
+ see Distribution.Simple.PackageIndex
+ PackageIndex Ebuild?
+
+* make clear destinction of Hackage.Package and Portage.Package (notice the namespaces)
+ Look into Portage, P2 and whatever other hacks there might be and
+ properly separate them into the two categories.
+ See the already existing Portage.PackageId
+
+* look into Ebuild's field ePkgDesc and its uses
+
+* Merge the separate tool keyword-stat into hackport, and make it use the
+ hackport API.
+ See http://code.haskell.org/gentoo/keyword-stat/
diff --git a/Util.hs b/Util.hs
new file mode 100644
index 0000000..95f5d88
--- /dev/null
+++ b/Util.hs
@@ -0,0 +1,31 @@
+{-|
+ Author : Sergei Trofimovich <slyfox@inbox.ru>
+ Stability : experimental
+ Portability : haskell98
+
+ Ungrouped utilitary stuff lays here until someone finds better place for it :]
+-}
+
+module Util
+ ( run_cmd -- :: String -> IO (Maybe String)
+ ) where
+
+import System.IO
+import System.Process
+import System.Exit (ExitCode(..))
+
+-- 'run_cmd' executes command and returns it's standard output
+-- as 'String'.
+
+run_cmd :: String -> IO (Maybe String)
+run_cmd cmd = do (hI, hO, hE, hProcess) <- runInteractiveCommand cmd
+ hClose hI
+ output <- hGetContents hO
+ errors <- hGetContents hE -- TODO: propagate error to caller
+ length output `seq` hClose hO
+ length errors `seq` hClose hE
+
+ exitCode <- waitForProcess hProcess
+ return $ if (output == "" || exitCode /= ExitSuccess)
+ then Nothing
+ else Just output
diff --git a/Utils.hs b/Utils.hs
deleted file mode 100644
index bee72e2..0000000
--- a/Utils.hs
+++ /dev/null
@@ -1,7 +0,0 @@
-module Utils where
-
-comparing :: (Eq b) => (a -> b) -> a -> a -> Bool
-comparing f x y = f x == f y
-
-compareWith :: (Ord b) => (a -> b) -> a -> a -> Ordering
-compareWith f x y = compare (f x) (f y)
diff --git a/Version.hs b/Version.hs
deleted file mode 100644
index 4a7853a..0000000
--- a/Version.hs
+++ /dev/null
@@ -1,122 +0,0 @@
-{-|
- Maintainer : Andres Loeh <kosmikus@gentoo.org>
- Stability : provisional
- Portability : haskell98
-
- Version parser, according to Portage spec.
-
- Shamelessly borrowed from exi, somewhat modified
-
--}
-
-module Version
- (
- Version(),
- Suffix(..),
- fromCabalVersion,
- showVersion,
- showSuffix,
- readVersion,
- parseVersion,
- getVersion,
- showRevPR
- ) where
-
-import qualified Distribution.Version as Cabal
-import Control.Monad
-import Data.List
-import Data.Maybe
-import Text.ParserCombinators.Parsec
-
-data Version = Version [Int] -- [1,42,3] ~= 1.42.3
- (Maybe Char) -- optional letter
- [Suffix]
- Int -- revision, 0 means none
- deriving (Eq, Ord)
-
-data Suffix = Alpha Int | Beta Int | Pre Int | RC Int | P_ Int
- deriving (Eq,Ord)
-
-instance Show Version where
- show = showVersion
-
-instance Show Suffix where
- show = showSuffix
-
-showVersion :: Version -> String
-showVersion (Version ver c suf rev)
- = showver ++ showc ++ concatMap showSuffix suf ++ showRev rev
- where showver = concat . intersperse "." . map show $ ver
- showc = maybe "" (:[]) c
-
-showSuffix :: Suffix -> String
-showSuffix (Alpha n) = "_alpha" ++ showPos n
-showSuffix (Beta n) = "_beta" ++ showPos n
-showSuffix (Pre n) = "_pre" ++ showPos n
-showSuffix (RC n) = "_rc" ++ showPos n
-showSuffix (P_ n) = "_p" ++ showPos n
-
-showPos :: Int -> String
-showPos 0 = ""
-showPos n = show n
-
-showRev :: Int -> String
-showRev 0 = ""
-showRev n = "-r" ++ show n
-
-showRevPR :: Int -> String
-showRevPR n = "r" ++ show n
-
-fromCabalVersion :: Cabal.Version -> Version
-fromCabalVersion (Cabal.Version nums _tags) =
- Version nums Nothing [] 0
-
--- | Function to call if you want to parse a version number.
-getVersion :: String -> Version
-getVersion ver = case parseVersion ver of
- Left _ ->
- error $ "getVersion: version parse error '" ++ ver ++ "'"
- Right x -> x
-
-parseVersion :: String -> Either ParseError Version
-parseVersion = parse (readVersion >>= \x -> eof >> return x) "<version number>"
-
-readVersion :: CharParser st Version
-readVersion = do (ver, _verr) <- readVer
- (c, _cr ) <- readC
- (suf, _sufr) <- readSufs
- (rev, _revr) <- readRev
- return (Version ver c suf rev)
-
-readVer :: CharParser st ([Int], String)
-readNum :: CharParser st (Int, String)
-readC :: CharParser st (Maybe Char, String)
-readSuf :: CharParser st (Suffix, String)
-readSufType :: CharParser st (Int -> Suffix, String)
-readSufs :: CharParser st ([Suffix], String)
-readRev :: CharParser st (Int, String)
-
-readVer = liftM ((\(x,y) -> (x, concat . intersperse "." $ y)) . unzip) (sepBy1 readNum (char '.'))
-readNum = do ds <- many1 digit
- case read ds of
- n -> return (n,ds)
-readC = option (Nothing, "") (liftM (\x -> (Just x, [x])) letter)
-readSuf = do char '_'
- (f,sr) <- readSufType
- (n,nr) <- option (0, "") readNum
- return (f n,"_" ++ sr ++ nr)
-
-readSufType = choice [
- liftM (\x -> (Alpha, x)) (try $ string "alpha"),
- liftM (\x -> (Beta, x)) (try $ string "beta" ),
- liftM (\x -> (Pre, x)) (try $ string "pre" ),
- liftM (\x -> (RC, x)) (try $ string "rc" ),
- liftM (\x -> (P_, x)) (try $ string "p" )
- ]
-
-readSufs = fmap ( ( \ (x,y) -> (x, concat y) ) . unzip ) (many readSuf)
-
-readRev = option (0, "") ( do rr <- string "-r"
- (n,nr) <- readNum
- return (n,rr ++ nr)
- )
diff --git a/cabal-install-0.8.2/Distribution/Client/BuildReports/Anonymous.hs b/cabal-install-0.8.2/Distribution/Client/BuildReports/Anonymous.hs
new file mode 100644
index 0000000..53d1f45
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/BuildReports/Anonymous.hs
@@ -0,0 +1,311 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Client.Reporting
+-- Copyright : (c) David Waern 2008
+-- License : BSD-like
+--
+-- Maintainer : david.waern@gmail.com
+-- Stability : experimental
+-- Portability : portable
+--
+-- Anonymous build report data structure, printing and parsing
+--
+-----------------------------------------------------------------------------
+module Distribution.Client.BuildReports.Anonymous (
+ BuildReport(..),
+ InstallOutcome(..),
+ Outcome(..),
+
+ -- * Constructing and writing reports
+ new,
+
+ -- * parsing and pretty printing
+ parse,
+ parseList,
+ show,
+-- showList,
+ ) where
+
+import Distribution.Client.Types
+ ( ConfiguredPackage(..) )
+import qualified Distribution.Client.Types as BR
+ ( BuildResult, BuildFailure(..), BuildSuccess(..)
+ , DocsResult(..), TestsResult(..) )
+import Distribution.Client.Utils
+ ( mergeBy, MergeResult(..) )
+import qualified Paths_cabal_install (version)
+
+import Distribution.Package
+ ( PackageIdentifier(..), PackageName(..), Package(packageId) )
+import Distribution.PackageDescription
+ ( FlagName(..), FlagAssignment )
+--import Distribution.Version
+-- ( Version )
+import Distribution.System
+ ( OS, Arch )
+import Distribution.Compiler
+ ( CompilerId )
+import qualified Distribution.Text as Text
+ ( Text(disp, parse) )
+import Distribution.ParseUtils
+ ( FieldDescr(..), ParseResult(..), Field(..)
+ , simpleField, listField, ppFields, readFields
+ , syntaxError, locatedErrorMsg )
+import Distribution.Simple.Utils
+ ( comparing )
+
+import qualified Distribution.Compat.ReadP as Parse
+ ( ReadP, pfail, munch1, skipSpaces )
+import qualified Text.PrettyPrint.HughesPJ as Disp
+ ( Doc, render, char, text )
+import Text.PrettyPrint.HughesPJ
+ ( (<+>), (<>) )
+
+import Data.List
+ ( unfoldr, sortBy )
+import Data.Char as Char
+ ( isAlpha, isAlphaNum )
+
+import Prelude hiding (show)
+
+data BuildReport
+ = BuildReport {
+ -- | The package this build report is about
+ package :: PackageIdentifier,
+
+ -- | The OS and Arch the package was built on
+ os :: OS,
+ arch :: Arch,
+
+ -- | The Haskell compiler (and hopefully version) used
+ compiler :: CompilerId,
+
+ -- | The uploading client, ie cabal-install-x.y.z
+ client :: PackageIdentifier,
+
+ -- | Which configurations flags we used
+ flagAssignment :: FlagAssignment,
+
+ -- | Which dependent packages we were using exactly
+ dependencies :: [PackageIdentifier],
+
+ -- | Did installing work ok?
+ installOutcome :: InstallOutcome,
+
+ -- Which version of the Cabal library was used to compile the Setup.hs
+-- cabalVersion :: Version,
+
+ -- Which build tools we were using (with versions)
+-- tools :: [PackageIdentifier],
+
+ -- | Configure outcome, did configure work ok?
+ docsOutcome :: Outcome,
+
+ -- | Configure outcome, did configure work ok?
+ testsOutcome :: Outcome
+ }
+
+data InstallOutcome
+ = DependencyFailed PackageIdentifier
+ | DownloadFailed
+ | UnpackFailed
+ | SetupFailed
+ | ConfigureFailed
+ | BuildFailed
+ | InstallFailed
+ | InstallOk
+ deriving Eq
+
+data Outcome = NotTried | Failed | Ok
+ deriving Eq
+
+new :: OS -> Arch -> CompilerId -- -> Version
+ -> ConfiguredPackage -> BR.BuildResult
+ -> BuildReport
+new os' arch' comp (ConfiguredPackage pkg flags deps) result =
+ BuildReport {
+ package = packageId pkg,
+ os = os',
+ arch = arch',
+ compiler = comp,
+ client = cabalInstallID,
+ flagAssignment = flags,
+ dependencies = deps,
+ installOutcome = convertInstallOutcome,
+-- cabalVersion = undefined
+ docsOutcome = convertDocsOutcome,
+ testsOutcome = convertTestsOutcome
+ }
+ where
+ convertInstallOutcome = case result of
+ Left (BR.DependentFailed p) -> DependencyFailed p
+ Left (BR.DownloadFailed _) -> DownloadFailed
+ Left (BR.UnpackFailed _) -> UnpackFailed
+ Left (BR.ConfigureFailed _) -> ConfigureFailed
+ Left (BR.BuildFailed _) -> BuildFailed
+ Left (BR.InstallFailed _) -> InstallFailed
+ Right (BR.BuildOk _ _) -> InstallOk
+ convertDocsOutcome = case result of
+ Left _ -> NotTried
+ Right (BR.BuildOk BR.DocsNotTried _) -> NotTried
+ Right (BR.BuildOk BR.DocsFailed _) -> Failed
+ Right (BR.BuildOk BR.DocsOk _) -> Ok
+ convertTestsOutcome = case result of
+ Left _ -> NotTried
+ Right (BR.BuildOk _ BR.TestsNotTried) -> NotTried
+ Right (BR.BuildOk _ BR.TestsFailed) -> Failed
+ Right (BR.BuildOk _ BR.TestsOk) -> Ok
+
+cabalInstallID :: PackageIdentifier
+cabalInstallID =
+ PackageIdentifier (PackageName "cabal-install") Paths_cabal_install.version
+
+-- ------------------------------------------------------------
+-- * External format
+-- ------------------------------------------------------------
+
+initialBuildReport :: BuildReport
+initialBuildReport = BuildReport {
+ package = requiredField "package",
+ os = requiredField "os",
+ arch = requiredField "arch",
+ compiler = requiredField "compiler",
+ client = requiredField "client",
+ flagAssignment = [],
+ dependencies = [],
+ installOutcome = requiredField "install-outcome",
+-- cabalVersion = Nothing,
+-- tools = [],
+ docsOutcome = NotTried,
+ testsOutcome = NotTried
+ }
+ where
+ requiredField fname = error ("required field: " ++ fname)
+
+-- -----------------------------------------------------------------------------
+-- Parsing
+
+parse :: String -> Either String BuildReport
+parse s = case parseFields s of
+ ParseFailed perror -> Left msg where (_, msg) = locatedErrorMsg perror
+ ParseOk _ report -> Right report
+
+--FIXME: this does not allow for optional or repeated fields
+parseFields :: String -> ParseResult BuildReport
+parseFields input = do
+ fields <- mapM extractField =<< readFields input
+ let merged = mergeBy (\desc (_,name,_) -> compare (fieldName desc) name)
+ sortedFieldDescrs
+ (sortBy (comparing (\(_,name,_) -> name)) fields)
+ checkMerged initialBuildReport merged
+
+ where
+ extractField :: Field -> ParseResult (Int, String, String)
+ extractField (F line name value) = return (line, name, value)
+ extractField (Section line _ _ _) = syntaxError line "Unrecognized stanza"
+ extractField (IfBlock line _ _ _) = syntaxError line "Unrecognized stanza"
+
+ checkMerged report [] = return report
+ checkMerged report (merged:remaining) = case merged of
+ InBoth fieldDescr (line, _name, value) -> do
+ report' <- fieldSet fieldDescr line value report
+ checkMerged report' remaining
+ OnlyInRight (line, name, _) ->
+ syntaxError line ("Unrecognized field " ++ name)
+ OnlyInLeft fieldDescr ->
+ fail ("Missing field " ++ fieldName fieldDescr)
+
+parseList :: String -> [BuildReport]
+parseList str =
+ [ report | Right report <- map parse (split str) ]
+
+ where
+ split :: String -> [String]
+ split = filter (not . null) . unfoldr chunk . lines
+ chunk [] = Nothing
+ chunk ls = case break null ls of
+ (r, rs) -> Just (unlines r, dropWhile null rs)
+
+-- -----------------------------------------------------------------------------
+-- Pretty-printing
+
+show :: BuildReport -> String
+show = Disp.render . ppFields fieldDescrs
+
+-- -----------------------------------------------------------------------------
+-- Description of the fields, for parsing/printing
+
+fieldDescrs :: [FieldDescr BuildReport]
+fieldDescrs =
+ [ simpleField "package" Text.disp Text.parse
+ package (\v r -> r { package = v })
+ , simpleField "os" Text.disp Text.parse
+ os (\v r -> r { os = v })
+ , simpleField "arch" Text.disp Text.parse
+ arch (\v r -> r { arch = v })
+ , simpleField "compiler" Text.disp Text.parse
+ compiler (\v r -> r { compiler = v })
+ , simpleField "client" Text.disp Text.parse
+ client (\v r -> r { client = v })
+ , listField "flags" dispFlag parseFlag
+ flagAssignment (\v r -> r { flagAssignment = v })
+ , listField "dependencies" Text.disp Text.parse
+ dependencies (\v r -> r { dependencies = v })
+ , simpleField "install-outcome" Text.disp Text.parse
+ installOutcome (\v r -> r { installOutcome = v })
+ , simpleField "docs-outcome" Text.disp Text.parse
+ docsOutcome (\v r -> r { docsOutcome = v })
+ , simpleField "tests-outcome" Text.disp Text.parse
+ testsOutcome (\v r -> r { testsOutcome = v })
+ ]
+
+sortedFieldDescrs :: [FieldDescr BuildReport]
+sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs
+
+dispFlag :: (FlagName, Bool) -> Disp.Doc
+dispFlag (FlagName name, True) = Disp.text name
+dispFlag (FlagName name, False) = Disp.char '-' <> Disp.text name
+
+parseFlag :: Parse.ReadP r (FlagName, Bool)
+parseFlag = do
+ name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')
+ case name of
+ ('-':flag) -> return (FlagName flag, False)
+ flag -> return (FlagName flag, True)
+
+instance Text.Text InstallOutcome where
+ disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid
+ disp DownloadFailed = Disp.text "DownloadFailed"
+ disp UnpackFailed = Disp.text "UnpackFailed"
+ disp SetupFailed = Disp.text "SetupFailed"
+ disp ConfigureFailed = Disp.text "ConfigureFailed"
+ disp BuildFailed = Disp.text "BuildFailed"
+ disp InstallFailed = Disp.text "InstallFailed"
+ disp InstallOk = Disp.text "InstallOk"
+
+ parse = do
+ name <- Parse.munch1 Char.isAlphaNum
+ case name of
+ "DependencyFailed" -> do Parse.skipSpaces
+ pkgid <- Text.parse
+ return (DependencyFailed pkgid)
+ "DownloadFailed" -> return DownloadFailed
+ "UnpackFailed" -> return UnpackFailed
+ "SetupFailed" -> return SetupFailed
+ "ConfigureFailed" -> return ConfigureFailed
+ "BuildFailed" -> return BuildFailed
+ "InstallFailed" -> return InstallFailed
+ "InstallOk" -> return InstallOk
+ _ -> Parse.pfail
+
+instance Text.Text Outcome where
+ disp NotTried = Disp.text "NotTried"
+ disp Failed = Disp.text "Failed"
+ disp Ok = Disp.text "Ok"
+ parse = do
+ name <- Parse.munch1 Char.isAlpha
+ case name of
+ "NotTried" -> return NotTried
+ "Failed" -> return Failed
+ "Ok" -> return Ok
+ _ -> Parse.pfail
diff --git a/cabal-install-0.8.2/Distribution/Client/BuildReports/Storage.hs b/cabal-install-0.8.2/Distribution/Client/BuildReports/Storage.hs
new file mode 100644
index 0000000..a8e9150
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/BuildReports/Storage.hs
@@ -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
diff --git a/cabal-install-0.8.2/Distribution/Client/BuildReports/Types.hs b/cabal-install-0.8.2/Distribution/Client/BuildReports/Types.hs
new file mode 100644
index 0000000..ea28e71
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/BuildReports/Types.hs
@@ -0,0 +1,44 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Client.BuildReports.Types
+-- Copyright : (c) Duncan Coutts 2009
+-- License : BSD-like
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- Types related to build reporting
+--
+-----------------------------------------------------------------------------
+module Distribution.Client.BuildReports.Types (
+ ReportLevel(..),
+ ) where
+
+import qualified Distribution.Text as Text
+ ( Text(..) )
+
+import qualified Distribution.Compat.ReadP as Parse
+ ( pfail, munch1 )
+import qualified Text.PrettyPrint.HughesPJ as Disp
+ ( text )
+
+import Data.Char as Char
+ ( isAlpha, toLower )
+
+data ReportLevel = NoReports | AnonymousReports | DetailedReports
+ deriving (Eq, Ord, Show)
+
+instance Text.Text ReportLevel where
+ disp NoReports = Disp.text "none"
+ disp AnonymousReports = Disp.text "anonymous"
+ disp DetailedReports = Disp.text "detailed"
+ parse = do
+ name <- Parse.munch1 Char.isAlpha
+ case lowercase name of
+ "none" -> return NoReports
+ "anonymous" -> return AnonymousReports
+ "detailed" -> return DetailedReports
+ _ -> Parse.pfail
+
+lowercase :: String -> String
+lowercase = map Char.toLower
diff --git a/cabal-install-0.8.2/Distribution/Client/BuildReports/Upload.hs b/cabal-install-0.8.2/Distribution/Client/BuildReports/Upload.hs
new file mode 100644
index 0000000..dc35552
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/BuildReports/Upload.hs
@@ -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 ()
diff --git a/cabal-install-0.8.2/Distribution/Client/Check.hs b/cabal-install-0.8.2/Distribution/Client/Check.hs
new file mode 100644
index 0000000..8d5fe23
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/Check.hs
@@ -0,0 +1,85 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Client.Check
+-- Copyright : (c) Lennart Kolmodin 2008
+-- License : BSD-like
+--
+-- Maintainer : kolmodin@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- Check a package for common mistakes
+--
+-----------------------------------------------------------------------------
+module Distribution.Client.Check (
+ check
+ ) where
+
+import Control.Monad ( when, unless )
+
+import Distribution.PackageDescription.Parse
+ ( readPackageDescription )
+import Distribution.PackageDescription.Check
+import Distribution.PackageDescription.Configuration
+ ( flattenPackageDescription )
+import Distribution.Verbosity
+ ( Verbosity )
+import Distribution.Simple.Utils
+ ( defaultPackageDesc, toUTF8, wrapText )
+
+check :: Verbosity -> IO Bool
+check verbosity = do
+ pdfile <- defaultPackageDesc verbosity
+ ppd <- readPackageDescription verbosity pdfile
+ -- flatten the generic package description into a regular package
+ -- description
+ -- TODO: this may give more warnings than it should give;
+ -- consider two branches of a condition, one saying
+ -- ghc-options: -Wall
+ -- and the other
+ -- ghc-options: -Werror
+ -- joined into
+ -- ghc-options: -Wall -Werror
+ -- checkPackages will yield a warning on the last line, but it
+ -- would not on each individual branch.
+ -- Hovever, this is the same way hackage does it, so we will yield
+ -- the exact same errors as it will.
+ let pkg_desc = flattenPackageDescription ppd
+ ioChecks <- checkPackageFiles pkg_desc "."
+ let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc)
+ buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ]
+ buildWarning = [ x | x@PackageBuildWarning {} <- packageChecks ]
+ distSuspicious = [ x | x@PackageDistSuspicious {} <- packageChecks ]
+ distInexusable = [ x | x@PackageDistInexcusable {} <- packageChecks ]
+
+ unless (null buildImpossible) $ do
+ putStrLn "The package will not build sanely due to these errors:"
+ printCheckMessages buildImpossible
+
+ unless (null buildWarning) $ do
+ putStrLn "The following warnings are likely affect your build negatively:"
+ printCheckMessages buildWarning
+
+ unless (null distSuspicious) $ do
+ putStrLn "These warnings may cause trouble when distributing the package:"
+ printCheckMessages distSuspicious
+
+ unless (null distInexusable) $ do
+ putStrLn "The following errors will cause portability problems on other environments:"
+ printCheckMessages distInexusable
+
+ let isDistError (PackageDistSuspicious {}) = False
+ isDistError _ = True
+ errors = filter isDistError packageChecks
+
+ unless (null errors) $ do
+ putStrLn "Hackage would reject this package."
+
+ when (null packageChecks) $ do
+ putStrLn "No errors or warnings could be found in the package."
+
+ return (null packageChecks)
+
+ where
+ printCheckMessages = mapM_ (putStrLn . format . explanation)
+ format = toUTF8 . wrapText . ("* "++)
diff --git a/cabal-install-0.8.2/Distribution/Client/Config.hs b/cabal-install-0.8.2/Distribution/Client/Config.hs
new file mode 100644
index 0000000..8ddca49
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/Config.hs
@@ -0,0 +1,565 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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"
diff --git a/cabal-install-0.8.2/Distribution/Client/Configure.hs b/cabal-install-0.8.2/Distribution/Client/Configure.hs
new file mode 100644
index 0000000..a1cfe2c
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/Configure.hs
@@ -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 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
diff --git a/cabal-install-0.8.2/Distribution/Client/Dependency.hs b/cabal-install-0.8.2/Distribution/Client/Dependency.hs
new file mode 100644
index 0000000..8675efe
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/Dependency.hs
@@ -0,0 +1,233 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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 ]
diff --git a/cabal-install-0.8.2/Distribution/Client/Dependency/Bogus.hs b/cabal-install-0.8.2/Distribution/Client/Dependency/Bogus.hs
new file mode 100644
index 0000000..695956c
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/Dependency/Bogus.hs
@@ -0,0 +1,129 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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
diff --git a/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown.hs b/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown.hs
new file mode 100644
index 0000000..fbab018
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown.hs
@@ -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'
diff --git a/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Constraints.hs b/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Constraints.hs
new file mode 100644
index 0000000..07b6b1a
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Constraints.hs
@@ -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 ]
diff --git a/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Types.hs b/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Types.hs
new file mode 100644
index 0000000..39c9ed5
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/Dependency/TopDown/Types.hs
@@ -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
diff --git a/cabal-install-0.8.2/Distribution/Client/Dependency/Types.hs b/cabal-install-0.8.2/Distribution/Client/Dependency/Types.hs
new file mode 100644
index 0000000..e5da64e
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/Dependency/Types.hs
@@ -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
diff --git a/cabal-install-0.8.2/Distribution/Client/Fetch.hs b/cabal-install-0.8.2/Distribution/Client/Fetch.hs
new file mode 100644
index 0000000..9239aee
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/Fetch.hs
@@ -0,0 +1,192 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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"]
+ }
diff --git a/cabal-install-0.8.2/Distribution/Client/Haddock.hs b/cabal-install-0.8.2/Distribution/Client/Haddock.hs
new file mode 100644
index 0000000..8f1b992
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/Haddock.hs
@@ -0,0 +1,101 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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)
diff --git a/cabal-install-0.8.2/Distribution/Client/HttpUtils.hs b/cabal-install-0.8.2/Distribution/Client/HttpUtils.hs
new file mode 100644
index 0000000..81f6d12
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/HttpUtils.hs
@@ -0,0 +1,197 @@
+{-# OPTIONS -cpp #-}
+-----------------------------------------------------------------------------
+-- | Separate module for HTTP actions, using a proxy server if one exists
+-----------------------------------------------------------------------------
+module Distribution.Client.HttpUtils (
+ downloadURI,
+ getHTTP,
+ proxy,
+ isOldHackageURI
+ ) where
+
+import Network.HTTP
+ ( Request (..), Response (..), RequestMethod (..)
+ , Header(..), HeaderName(..) )
+import Network.URI
+ ( URI (..), URIAuth (..), parseAbsoluteURI )
+import Network.Stream
+ ( Result, ConnError(..) )
+import Network.Browser
+ ( Proxy (..), Authority (..), browse
+ , setOutHandler, setErrHandler, setProxy, request)
+import Control.Monad
+ ( mplus, join, liftM2 )
+import qualified Data.ByteString.Lazy.Char8 as ByteString
+import Data.ByteString.Lazy (ByteString)
+#ifdef WIN32
+import System.Win32.Types
+ ( DWORD, HKEY )
+import System.Win32.Registry
+ ( hKEY_CURRENT_USER, regOpenKey, regCloseKey
+ , regQueryValue, regQueryValueEx )
+import Control.Exception
+ ( bracket )
+import Distribution.Compat.Exception
+ ( handleIO )
+import Foreign
+ ( toBool, Storable(peek, sizeOf), castPtr, alloca )
+#endif
+import System.Environment (getEnvironment)
+
+import qualified Paths_cabal_install (version)
+import Distribution.Verbosity (Verbosity)
+import Distribution.Simple.Utils
+ ( die, info, warn, debug
+ , copyFileVerbose, writeFileAtomic )
+import Distribution.Text
+ ( display )
+import qualified System.FilePath.Posix as FilePath.Posix
+ ( splitDirectories )
+
+-- FIXME: all this proxy stuff is far too complicated, especially parsing
+-- the proxy strings. Network.Browser should have a way to pick up the
+-- proxy settings hiding all this system-dependent stuff below.
+
+-- try to read the system proxy settings on windows or unix
+proxyString, envProxyString, registryProxyString :: IO (Maybe String)
+#ifdef WIN32
+-- read proxy settings from the windows registry
+registryProxyString = handleIO (\_ -> return Nothing) $
+ bracket (regOpenKey hive path) regCloseKey $ \hkey -> do
+ enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable"
+ if enable
+ then fmap Just $ regQueryValue hkey (Just "ProxyServer")
+ else return Nothing
+ where
+ -- some sources say proxy settings should be at
+ -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows
+ -- \CurrentVersion\Internet Settings\ProxyServer
+ -- but if the user sets them with IE connection panel they seem to
+ -- end up in the following place:
+ hive = hKEY_CURRENT_USER
+ path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings"
+
+ regQueryValueDWORD :: HKEY -> String -> IO DWORD
+ regQueryValueDWORD hkey name = alloca $ \ptr -> do
+ regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD))
+ peek ptr
+#else
+registryProxyString = return Nothing
+#endif
+
+-- read proxy settings by looking for an env var
+envProxyString = do
+ env <- getEnvironment
+ return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env)
+
+proxyString = liftM2 mplus envProxyString registryProxyString
+
+
+-- |Get the local proxy settings
+proxy :: Verbosity -> IO Proxy
+proxy verbosity = do
+ mstr <- proxyString
+ case mstr of
+ Nothing -> return NoProxy
+ Just str -> case parseHttpProxy str of
+ Nothing -> do
+ warn verbosity $ "invalid http proxy uri: " ++ show str
+ warn verbosity $ "proxy uri must be http with a hostname"
+ warn verbosity $ "ignoring http proxy, trying a direct connection"
+ return NoProxy
+ Just p -> return p
+--TODO: print info message when we're using a proxy
+
+-- | We need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@
+-- which lack the @\"http://\"@ URI scheme. The problem is that
+-- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme
+-- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@.
+--
+-- So our strategy is to try parsing as normal uri first and if it lacks the
+-- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix.
+--
+parseHttpProxy :: String -> Maybe Proxy
+parseHttpProxy str = join
+ . fmap uri2proxy
+ $ parseHttpURI str
+ `mplus` parseHttpURI ("http://" ++ str)
+ where
+ parseHttpURI str' = case parseAbsoluteURI str' of
+ Just uri@URI { uriAuthority = Just _ }
+ -> Just (fixUserInfo uri)
+ _ -> Nothing
+
+fixUserInfo :: URI -> URI
+fixUserInfo uri = uri{ uriAuthority = f `fmap` uriAuthority uri }
+ where
+ f a@URIAuth{ uriUserInfo = s } =
+ a{ uriUserInfo = case reverse s of
+ '@':s' -> reverse s'
+ _ -> s
+ }
+uri2proxy :: URI -> Maybe Proxy
+uri2proxy uri@URI{ uriScheme = "http:"
+ , uriAuthority = Just (URIAuth auth' host port)
+ } = Just (Proxy (host ++ port) auth)
+ where auth = if null auth'
+ then Nothing
+ else Just (AuthBasic "" usr pwd uri)
+ (usr,pwd') = break (==':') auth'
+ pwd = case pwd' of
+ ':':cs -> cs
+ _ -> pwd'
+uri2proxy _ = Nothing
+
+mkRequest :: URI -> Request ByteString
+mkRequest uri = Request{ rqURI = uri
+ , rqMethod = GET
+ , rqHeaders = [Header HdrUserAgent userAgent]
+ , rqBody = ByteString.empty }
+ where userAgent = "cabal-install/" ++ display Paths_cabal_install.version
+
+-- |Carry out a GET request, using the local proxy settings
+getHTTP :: Verbosity -> URI -> IO (Result (Response ByteString))
+getHTTP verbosity uri = do
+ p <- proxy verbosity
+ let req = mkRequest uri
+ (_, resp) <- browse $ do
+ setErrHandler (warn verbosity . ("http error: "++))
+ setOutHandler (debug verbosity)
+ setProxy p
+ request req
+ return (Right resp)
+
+downloadURI :: Verbosity
+ -> URI -- ^ What to download
+ -> FilePath -- ^ Where to put it
+ -> IO ()
+downloadURI verbosity uri path | uriScheme uri == "file:" =
+ copyFileVerbose verbosity (uriPath uri) path
+downloadURI verbosity uri path = do
+ result <- getHTTP verbosity uri
+ let result' = case result of
+ Left err -> Left err
+ Right rsp -> case rspCode rsp of
+ (2,0,0) -> Right (rspBody rsp)
+ (a,b,c) -> Left err
+ where
+ err = ErrorMisc $ "Unsucessful HTTP code: "
+ ++ concatMap show [a,b,c]
+
+ case result' of
+ Left err -> die $ "Failed to download " ++ show uri ++ " : " ++ show err
+ Right body -> do
+ info verbosity ("Downloaded to " ++ path)
+ writeFileAtomic path (ByteString.unpack body)
+ --FIXME: check the content-length header matches the body length.
+ --TODO: stream the download into the file rather than buffering the whole
+ -- thing in memory.
+ -- remember the ETag so we can not re-download if nothing changed.
+
+-- Utility function for legacy support.
+isOldHackageURI :: URI -> Bool
+isOldHackageURI uri
+ = case uriAuthority uri of
+ Just (URIAuth {uriRegName = "hackage.haskell.org"}) ->
+ FilePath.Posix.splitDirectories (uriPath uri) == ["/","packages","archive"]
+ _ -> False
diff --git a/cabal-install-0.8.2/Distribution/Client/IndexUtils.hs b/cabal-install-0.8.2/Distribution/Client/IndexUtils.hs
new file mode 100644
index 0000000..065048d
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/IndexUtils.hs
@@ -0,0 +1,301 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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 ]
diff --git a/cabal-install-0.8.2/Distribution/Client/Init.hs b/cabal-install-0.8.2/Distribution/Client/Init.hs
new file mode 100644
index 0000000..429a484
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/Init.hs
@@ -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
diff --git a/cabal-install-0.8.2/Distribution/Client/Init/Heuristics.hs b/cabal-install-0.8.2/Distribution/Client/Init/Heuristics.hs
new file mode 100644
index 0000000..82f4745
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/Init/Heuristics.hs
@@ -0,0 +1,187 @@
+{-# 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
diff --git a/cabal-install-0.8.2/Distribution/Client/Init/Licenses.hs b/cabal-install-0.8.2/Distribution/Client/Init/Licenses.hs
new file mode 100644
index 0000000..73bba06
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/Init/Licenses.hs
@@ -0,0 +1,1722 @@
+module Distribution.Client.Init.Licenses
+ ( License
+ , bsd3
+ , gplv2
+ , gplv3
+ , lgpl2
+ , lgpl3
+
+ ) where
+
+type License = String
+
+bsd3 :: String -> String -> License
+bsd3 authors year = unlines
+ [ "Copyright (c)" ++ year ++ ", " ++ authors
+ , ""
+ , "All rights reserved."
+ , ""
+ , "Redistribution and use in source and binary forms, with or without"
+ , "modification, are permitted provided that the following conditions are met:"
+ , ""
+ , " * Redistributions of source code must retain the above copyright"
+ , " notice, this list of conditions and the following disclaimer."
+ , ""
+ , " * Redistributions in binary form must reproduce the above"
+ , " copyright notice, this list of conditions and the following"
+ , " disclaimer in the documentation and/or other materials provided"
+ , " with the distribution."
+ , ""
+ , " * Neither the name of " ++ authors ++ " nor the names of other"
+ , " contributors may be used to endorse or promote products derived"
+ , " from this software without specific prior written permission."
+ , ""
+ , "THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS"
+ , "\"AS IS\" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT"
+ , "LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR"
+ , "A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT"
+ , "OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,"
+ , "SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT"
+ , "LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,"
+ , "DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY"
+ , "THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT"
+ , "(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE"
+ , "OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE."
+ ]
+
+gplv2 :: License
+gplv2 = unlines
+ [ " GNU GENERAL PUBLIC LICENSE"
+ , " Version 2, June 1991"
+ , ""
+ , " Copyright (C) 1989, 1991 Free Software Foundation, Inc.,"
+ , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA"
+ , " Everyone is permitted to copy and distribute verbatim copies"
+ , " of this license document, but changing it is not allowed."
+ , ""
+ , " Preamble"
+ , ""
+ , " The licenses for most software are designed to take away your"
+ , "freedom to share and change it. By contrast, the GNU General Public"
+ , "License is intended to guarantee your freedom to share and change free"
+ , "software--to make sure the software is free for all its users. This"
+ , "General Public License applies to most of the Free Software"
+ , "Foundation's software and to any other program whose authors commit to"
+ , "using it. (Some other Free Software Foundation software is covered by"
+ , "the GNU Lesser General Public License instead.) You can apply it to"
+ , "your programs, too."
+ , ""
+ , " When we speak of free software, we are referring to freedom, not"
+ , "price. Our General Public Licenses are designed to make sure that you"
+ , "have the freedom to distribute copies of free software (and charge for"
+ , "this service if you wish), that you receive source code or can get it"
+ , "if you want it, that you can change the software or use pieces of it"
+ , "in new free programs; and that you know you can do these things."
+ , ""
+ , " To protect your rights, we need to make restrictions that forbid"
+ , "anyone to deny you these rights or to ask you to surrender the rights."
+ , "These restrictions translate to certain responsibilities for you if you"
+ , "distribute copies of the software, or if you modify it."
+ , ""
+ , " For example, if you distribute copies of such a program, whether"
+ , "gratis or for a fee, you must give the recipients all the rights that"
+ , "you have. You must make sure that they, too, receive or can get the"
+ , "source code. And you must show them these terms so they know their"
+ , "rights."
+ , ""
+ , " We protect your rights with two steps: (1) copyright the software, and"
+ , "(2) offer you this license which gives you legal permission to copy,"
+ , "distribute and/or modify the software."
+ , ""
+ , " Also, for each author's protection and ours, we want to make certain"
+ , "that everyone understands that there is no warranty for this free"
+ , "software. If the software is modified by someone else and passed on, we"
+ , "want its recipients to know that what they have is not the original, so"
+ , "that any problems introduced by others will not reflect on the original"
+ , "authors' reputations."
+ , ""
+ , " Finally, any free program is threatened constantly by software"
+ , "patents. We wish to avoid the danger that redistributors of a free"
+ , "program will individually obtain patent licenses, in effect making the"
+ , "program proprietary. To prevent this, we have made it clear that any"
+ , "patent must be licensed for everyone's free use or not licensed at all."
+ , ""
+ , " The precise terms and conditions for copying, distribution and"
+ , "modification follow."
+ , ""
+ , " GNU GENERAL PUBLIC LICENSE"
+ , " TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION"
+ , ""
+ , " 0. This License applies to any program or other work which contains"
+ , "a notice placed by the copyright holder saying it may be distributed"
+ , "under the terms of this General Public License. The \"Program\", below,"
+ , "refers to any such program or work, and a \"work based on the Program\""
+ , "means either the Program or any derivative work under copyright law:"
+ , "that is to say, a work containing the Program or a portion of it,"
+ , "either verbatim or with modifications and/or translated into another"
+ , "language. (Hereinafter, translation is included without limitation in"
+ , "the term \"modification\".) Each licensee is addressed as \"you\"."
+ , ""
+ , "Activities other than copying, distribution and modification are not"
+ , "covered by this License; they are outside its scope. The act of"
+ , "running the Program is not restricted, and the output from the Program"
+ , "is covered only if its contents constitute a work based on the"
+ , "Program (independent of having been made by running the Program)."
+ , "Whether that is true depends on what the Program does."
+ , ""
+ , " 1. You may copy and distribute verbatim copies of the Program's"
+ , "source code as you receive it, in any medium, provided that you"
+ , "conspicuously and appropriately publish on each copy an appropriate"
+ , "copyright notice and disclaimer of warranty; keep intact all the"
+ , "notices that refer to this License and to the absence of any warranty;"
+ , "and give any other recipients of the Program a copy of this License"
+ , "along with the Program."
+ , ""
+ , "You may charge a fee for the physical act of transferring a copy, and"
+ , "you may at your option offer warranty protection in exchange for a fee."
+ , ""
+ , " 2. You may modify your copy or copies of the Program or any portion"
+ , "of it, thus forming a work based on the Program, and copy and"
+ , "distribute such modifications or work under the terms of Section 1"
+ , "above, provided that you also meet all of these conditions:"
+ , ""
+ , " a) You must cause the modified files to carry prominent notices"
+ , " stating that you changed the files and the date of any change."
+ , ""
+ , " b) You must cause any work that you distribute or publish, that in"
+ , " whole or in part contains or is derived from the Program or any"
+ , " part thereof, to be licensed as a whole at no charge to all third"
+ , " parties under the terms of this License."
+ , ""
+ , " c) If the modified program normally reads commands interactively"
+ , " when run, you must cause it, when started running for such"
+ , " interactive use in the most ordinary way, to print or display an"
+ , " announcement including an appropriate copyright notice and a"
+ , " notice that there is no warranty (or else, saying that you provide"
+ , " a warranty) and that users may redistribute the program under"
+ , " these conditions, and telling the user how to view a copy of this"
+ , " License. (Exception: if the Program itself is interactive but"
+ , " does not normally print such an announcement, your work based on"
+ , " the Program is not required to print an announcement.)"
+ , ""
+ , "These requirements apply to the modified work as a whole. If"
+ , "identifiable sections of that work are not derived from the Program,"
+ , "and can be reasonably considered independent and separate works in"
+ , "themselves, then this License, and its terms, do not apply to those"
+ , "sections when you distribute them as separate works. But when you"
+ , "distribute the same sections as part of a whole which is a work based"
+ , "on the Program, the distribution of the whole must be on the terms of"
+ , "this License, whose permissions for other licensees extend to the"
+ , "entire whole, and thus to each and every part regardless of who wrote it."
+ , ""
+ , "Thus, it is not the intent of this section to claim rights or contest"
+ , "your rights to work written entirely by you; rather, the intent is to"
+ , "exercise the right to control the distribution of derivative or"
+ , "collective works based on the Program."
+ , ""
+ , "In addition, mere aggregation of another work not based on the Program"
+ , "with the Program (or with a work based on the Program) on a volume of"
+ , "a storage or distribution medium does not bring the other work under"
+ , "the scope of this License."
+ , ""
+ , " 3. You may copy and distribute the Program (or a work based on it,"
+ , "under Section 2) in object code or executable form under the terms of"
+ , "Sections 1 and 2 above provided that you also do one of the following:"
+ , ""
+ , " a) Accompany it with the complete corresponding machine-readable"
+ , " source code, which must be distributed under the terms of Sections"
+ , " 1 and 2 above on a medium customarily used for software interchange; or,"
+ , ""
+ , " b) Accompany it with a written offer, valid for at least three"
+ , " years, to give any third party, for a charge no more than your"
+ , " cost of physically performing source distribution, a complete"
+ , " machine-readable copy of the corresponding source code, to be"
+ , " distributed under the terms of Sections 1 and 2 above on a medium"
+ , " customarily used for software interchange; or,"
+ , ""
+ , " c) Accompany it with the information you received as to the offer"
+ , " to distribute corresponding source code. (This alternative is"
+ , " allowed only for noncommercial distribution and only if you"
+ , " received the program in object code or executable form with such"
+ , " an offer, in accord with Subsection b above.)"
+ , ""
+ , "The source code for a work means the preferred form of the work for"
+ , "making modifications to it. For an executable work, complete source"
+ , "code means all the source code for all modules it contains, plus any"
+ , "associated interface definition files, plus the scripts used to"
+ , "control compilation and installation of the executable. However, as a"
+ , "special exception, the source code distributed need not include"
+ , "anything that is normally distributed (in either source or binary"
+ , "form) with the major components (compiler, kernel, and so on) of the"
+ , "operating system on which the executable runs, unless that component"
+ , "itself accompanies the executable."
+ , ""
+ , "If distribution of executable or object code is made by offering"
+ , "access to copy from a designated place, then offering equivalent"
+ , "access to copy the source code from the same place counts as"
+ , "distribution of the source code, even though third parties are not"
+ , "compelled to copy the source along with the object code."
+ , ""
+ , " 4. You may not copy, modify, sublicense, or distribute the Program"
+ , "except as expressly provided under this License. Any attempt"
+ , "otherwise to copy, modify, sublicense or distribute the Program is"
+ , "void, and will automatically terminate your rights under this License."
+ , "However, parties who have received copies, or rights, from you under"
+ , "this License will not have their licenses terminated so long as such"
+ , "parties remain in full compliance."
+ , ""
+ , " 5. You are not required to accept this License, since you have not"
+ , "signed it. However, nothing else grants you permission to modify or"
+ , "distribute the Program or its derivative works. These actions are"
+ , "prohibited by law if you do not accept this License. Therefore, by"
+ , "modifying or distributing the Program (or any work based on the"
+ , "Program), you indicate your acceptance of this License to do so, and"
+ , "all its terms and conditions for copying, distributing or modifying"
+ , "the Program or works based on it."
+ , ""
+ , " 6. Each time you redistribute the Program (or any work based on the"
+ , "Program), the recipient automatically receives a license from the"
+ , "original licensor to copy, distribute or modify the Program subject to"
+ , "these terms and conditions. You may not impose any further"
+ , "restrictions on the recipients' exercise of the rights granted herein."
+ , "You are not responsible for enforcing compliance by third parties to"
+ , "this License."
+ , ""
+ , " 7. If, as a consequence of a court judgment or allegation of patent"
+ , "infringement or for any other reason (not limited to patent issues),"
+ , "conditions are imposed on you (whether by court order, agreement or"
+ , "otherwise) that contradict the conditions of this License, they do not"
+ , "excuse you from the conditions of this License. If you cannot"
+ , "distribute so as to satisfy simultaneously your obligations under this"
+ , "License and any other pertinent obligations, then as a consequence you"
+ , "may not distribute the Program at all. For example, if a patent"
+ , "license would not permit royalty-free redistribution of the Program by"
+ , "all those who receive copies directly or indirectly through you, then"
+ , "the only way you could satisfy both it and this License would be to"
+ , "refrain entirely from distribution of the Program."
+ , ""
+ , "If any portion of this section is held invalid or unenforceable under"
+ , "any particular circumstance, the balance of the section is intended to"
+ , "apply and the section as a whole is intended to apply in other"
+ , "circumstances."
+ , ""
+ , "It is not the purpose of this section to induce you to infringe any"
+ , "patents or other property right claims or to contest validity of any"
+ , "such claims; this section has the sole purpose of protecting the"
+ , "integrity of the free software distribution system, which is"
+ , "implemented by public license practices. Many people have made"
+ , "generous contributions to the wide range of software distributed"
+ , "through that system in reliance on consistent application of that"
+ , "system; it is up to the author/donor to decide if he or she is willing"
+ , "to distribute software through any other system and a licensee cannot"
+ , "impose that choice."
+ , ""
+ , "This section is intended to make thoroughly clear what is believed to"
+ , "be a consequence of the rest of this License."
+ , ""
+ , " 8. If the distribution and/or use of the Program is restricted in"
+ , "certain countries either by patents or by copyrighted interfaces, the"
+ , "original copyright holder who places the Program under this License"
+ , "may add an explicit geographical distribution limitation excluding"
+ , "those countries, so that distribution is permitted only in or among"
+ , "countries not thus excluded. In such case, this License incorporates"
+ , "the limitation as if written in the body of this License."
+ , ""
+ , " 9. The Free Software Foundation may publish revised and/or new versions"
+ , "of the General Public License from time to time. Such new versions will"
+ , "be similar in spirit to the present version, but may differ in detail to"
+ , "address new problems or concerns."
+ , ""
+ , "Each version is given a distinguishing version number. If the Program"
+ , "specifies a version number of this License which applies to it and \"any"
+ , "later version\", you have the option of following the terms and conditions"
+ , "either of that version or of any later version published by the Free"
+ , "Software Foundation. If the Program does not specify a version number of"
+ , "this License, you may choose any version ever published by the Free Software"
+ , "Foundation."
+ , ""
+ , " 10. If you wish to incorporate parts of the Program into other free"
+ , "programs whose distribution conditions are different, write to the author"
+ , "to ask for permission. For software which is copyrighted by the Free"
+ , "Software Foundation, write to the Free Software Foundation; we sometimes"
+ , "make exceptions for this. Our decision will be guided by the two goals"
+ , "of preserving the free status of all derivatives of our free software and"
+ , "of promoting the sharing and reuse of software generally."
+ , ""
+ , " NO WARRANTY"
+ , ""
+ , " 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY"
+ , "FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN"
+ , "OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES"
+ , "PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED"
+ , "OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF"
+ , "MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS"
+ , "TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE"
+ , "PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,"
+ , "REPAIR OR CORRECTION."
+ , ""
+ , " 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING"
+ , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR"
+ , "REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,"
+ , "INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING"
+ , "OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED"
+ , "TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY"
+ , "YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER"
+ , "PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE"
+ , "POSSIBILITY OF SUCH DAMAGES."
+ , ""
+ , " END OF TERMS AND CONDITIONS"
+ , ""
+ , " How to Apply These Terms to Your New Programs"
+ , ""
+ , " If you develop a new program, and you want it to be of the greatest"
+ , "possible use to the public, the best way to achieve this is to make it"
+ , "free software which everyone can redistribute and change under these terms."
+ , ""
+ , " To do so, attach the following notices to the program. It is safest"
+ , "to attach them to the start of each source file to most effectively"
+ , "convey the exclusion of warranty; and each file should have at least"
+ , "the \"copyright\" line and a pointer to where the full notice is found."
+ , ""
+ , " <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."
+ ]
+
diff --git a/cabal-install-0.8.2/Distribution/Client/Init/Types.hs b/cabal-install-0.8.2/Distribution/Client/Init/Types.hs
new file mode 100644
index 0000000..aace727
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/Init/Types.hs
@@ -0,0 +1,152 @@
+{-# LANGUAGE CPP #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Client.Init.Types
+-- Copyright : (c) Brent Yorgey, Benedikt Huber 2009
+-- License : BSD-like
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- Some types used by the 'cabal init' command.
+--
+-----------------------------------------------------------------------------
+module Distribution.Client.Init.Types where
+
+import Distribution.Simple.Setup
+ ( Flag(..) )
+
+import Distribution.Version
+import qualified Distribution.Package as P
+import Distribution.License
+import Distribution.ModuleName
+
+import qualified Text.PrettyPrint as Disp
+import qualified Distribution.Compat.ReadP as Parse
+import Distribution.Text
+
+import Data.Monoid
+
+-- | InitFlags is really just a simple type to represent certain
+-- portions of a .cabal file. Rather than have a flag for EVERY
+-- possible field, we just have one for each field that the user is
+-- likely to want and/or that we are likely to be able to
+-- intelligently guess.
+data InitFlags =
+ InitFlags { nonInteractive :: Flag Bool
+ , quiet :: Flag Bool
+ , packageDir :: Flag FilePath
+ , noComments :: Flag Bool
+ , minimal :: Flag Bool
+
+ , packageName :: Flag String
+ , version :: Flag Version
+ , cabalVersion :: Flag VersionRange
+ , license :: Flag License
+ , author :: Flag String
+ , email :: Flag String
+ , homepage :: Flag String
+
+ , synopsis :: Flag String
+ , category :: Flag (Either String Category)
+
+ , packageType :: Flag PackageType
+
+ , exposedModules :: Maybe [ModuleName]
+ , otherModules :: Maybe [ModuleName]
+
+ , dependencies :: Maybe [P.Dependency]
+ , sourceDirs :: Maybe [String]
+ , buildTools :: Maybe [String]
+ }
+ deriving (Show)
+
+data PackageType = Library | Executable
+ deriving (Show, Read, Eq)
+
+instance Text PackageType where
+ disp = Disp.text . show
+ parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable]
+
+instance Monoid InitFlags where
+ mempty = InitFlags
+ { nonInteractive = mempty
+ , quiet = mempty
+ , packageDir = mempty
+ , noComments = mempty
+ , minimal = mempty
+ , packageName = mempty
+ , version = mempty
+ , cabalVersion = mempty
+ , license = mempty
+ , author = mempty
+ , email = mempty
+ , homepage = mempty
+ , synopsis = mempty
+ , category = mempty
+ , packageType = mempty
+ , exposedModules = mempty
+ , otherModules = mempty
+ , dependencies = mempty
+ , sourceDirs = mempty
+ , buildTools = mempty
+ }
+ mappend a b = InitFlags
+ { nonInteractive = combine nonInteractive
+ , quiet = combine quiet
+ , packageDir = combine packageDir
+ , noComments = combine noComments
+ , minimal = combine minimal
+ , packageName = combine packageName
+ , version = combine version
+ , cabalVersion = combine cabalVersion
+ , license = combine license
+ , author = combine author
+ , email = combine email
+ , homepage = combine homepage
+ , synopsis = combine synopsis
+ , category = combine category
+ , packageType = combine packageType
+ , exposedModules = combine exposedModules
+ , otherModules = combine otherModules
+ , dependencies = combine dependencies
+ , sourceDirs = combine sourceDirs
+ , buildTools = combine buildTools
+ }
+ where combine field = field a `mappend` field b
+
+-- | Some common package categories.
+data Category
+ = Codec
+ | Concurrency
+ | Control
+ | Data
+ | Database
+ | Development
+ | Distribution
+ | Game
+ | Graphics
+ | Language
+ | Math
+ | Network
+ | Sound
+ | System
+ | Testing
+ | Text
+ | Web
+ deriving (Read, Show, Eq, Ord, Bounded, Enum)
+
+instance Text Category where
+ disp = Disp.text . show
+ parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ]
+
+#if MIN_VERSION_base(3,0,0)
+#else
+-- Compat instance for ghc-6.6 era
+instance Monoid a => Monoid (Maybe a) where
+ mempty = Nothing
+ Nothing `mappend` m = m
+ m `mappend` Nothing = m
+ Just m1 `mappend` Just m2 = Just (m1 `mappend` m2)
+#endif
diff --git a/cabal-install-0.8.2/Distribution/Client/Install.hs b/cabal-install-0.8.2/Distribution/Client/Install.hs
new file mode 100644
index 0000000..f8927f3
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/Install.hs
@@ -0,0 +1,786 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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
diff --git a/cabal-install-0.8.2/Distribution/Client/InstallPlan.hs b/cabal-install-0.8.2/Distribution/Client/InstallPlan.hs
new file mode 100644
index 0000000..71fa6a9
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/InstallPlan.hs
@@ -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"
diff --git a/cabal-install-0.8.2/Distribution/Client/InstallSymlink.hs b/cabal-install-0.8.2/Distribution/Client/InstallSymlink.hs
new file mode 100644
index 0000000..8b6a375
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/InstallSymlink.hs
@@ -0,0 +1,238 @@
+{-# OPTIONS -cpp #-}
+-- OPTIONS required for ghc-6.4.x compat, and must appear first
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -cpp #-}
+{-# OPTIONS_NHC98 -cpp #-}
+{-# OPTIONS_JHC -fcpp #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Client.InstallSymlink
+-- Copyright : (c) Duncan Coutts 2008
+-- License : BSD-like
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- Managing installing binaries with symlinks.
+-----------------------------------------------------------------------------
+module Distribution.Client.InstallSymlink (
+ symlinkBinaries,
+ symlinkBinary,
+ ) where
+
+#if mingw32_HOST_OS || mingw32_TARGET_OS
+
+import Distribution.Package (PackageIdentifier)
+import Distribution.Client.InstallPlan (InstallPlan)
+import Distribution.Client.Setup (InstallFlags)
+import Distribution.Simple.Setup (ConfigFlags)
+
+symlinkBinaries :: ConfigFlags
+ -> InstallFlags
+ -> InstallPlan
+ -> IO [(PackageIdentifier, String, FilePath)]
+symlinkBinaries _ _ _ = return []
+
+symlinkBinary :: FilePath -> FilePath -> String -> String -> IO Bool
+symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows"
+
+#else
+
+import Distribution.Client.Types
+ ( AvailablePackage(..), ConfiguredPackage(..) )
+import Distribution.Client.Setup
+ ( InstallFlags(installSymlinkBinDir) )
+import qualified Distribution.Client.InstallPlan as InstallPlan
+import Distribution.Client.InstallPlan (InstallPlan)
+
+import Distribution.Package
+ ( PackageIdentifier, Package(packageId) )
+import Distribution.Compiler
+ ( CompilerId(..) )
+import qualified Distribution.PackageDescription as PackageDescription
+import Distribution.PackageDescription
+ ( PackageDescription )
+import Distribution.PackageDescription.Configuration
+ ( finalizePackageDescription )
+import Distribution.Simple.Setup
+ ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe )
+import qualified Distribution.Simple.InstallDirs as InstallDirs
+
+import System.Posix.Files
+ ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink
+ , removeLink )
+import System.Directory
+ ( canonicalizePath )
+import System.FilePath
+ ( (</>), splitPath, joinPath, isAbsolute )
+
+import Prelude hiding (catch, ioError)
+import System.IO.Error
+ ( catch, isDoesNotExistError, ioError )
+import Control.Exception
+ ( assert )
+import Data.Maybe
+ ( catMaybes )
+
+-- | We would like by default to install binaries into some location that is on
+-- the user's PATH. For per-user installations on Unix systems that basically
+-- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@
+-- directory will be on the user's PATH. However some people are a bit nervous
+-- about letting a package manager install programs into @~/bin/@.
+--
+-- A comprimise solution is that instead of installing binaries directly into
+-- @~/bin/@, we could install them in a private location under @~/.cabal/bin@
+-- and then create symlinks in @~/bin/@. We can be careful when setting up the
+-- symlinks that we do not overwrite any binary that the user installed. We can
+-- check if it was a symlink we made because it would point to the private dir
+-- where we install our binaries. This means we can install normally without
+-- worrying and in a later phase set up symlinks, and if that fails then we
+-- report it to the user, but even in this case the package is still in an ok
+-- installed state.
+--
+-- This is an optional feature that users can choose to use or not. It is
+-- controlled from the config file. Of course it only works on posix systems
+-- with symlinks so is not available to Windows users.
+--
+symlinkBinaries :: ConfigFlags
+ -> InstallFlags
+ -> InstallPlan
+ -> IO [(PackageIdentifier, String, FilePath)]
+symlinkBinaries configFlags installFlags plan =
+ case flagToMaybe (installSymlinkBinDir installFlags) of
+ Nothing -> return []
+ Just symlinkBinDir
+ | null exes -> return []
+ | otherwise -> do
+ publicBinDir <- canonicalizePath symlinkBinDir
+-- TODO: do we want to do this here? :
+-- createDirectoryIfMissing True publicBinDir
+ fmap catMaybes $ sequence
+ [ do privateBinDir <- pkgBinDir pkg
+ ok <- symlinkBinary
+ publicBinDir privateBinDir
+ publicExeName privateExeName
+ if ok
+ then return Nothing
+ else return (Just (pkgid, publicExeName,
+ privateBinDir </> privateExeName))
+ | (pkg, exe) <- exes
+ , let publicExeName = PackageDescription.exeName exe
+ privateExeName = prefix ++ publicExeName ++ suffix
+ pkgid = packageId pkg
+ prefix = substTemplate pkgid prefixTemplate
+ suffix = substTemplate pkgid suffixTemplate ]
+ where
+ exes =
+ [ (pkg, exe)
+ | InstallPlan.Installed cpkg _ <- InstallPlan.toList plan
+ , let pkg = pkgDescription cpkg
+ , exe <- PackageDescription.executables pkg
+ , PackageDescription.buildable (PackageDescription.buildInfo exe) ]
+
+ pkgDescription :: ConfiguredPackage -> PackageDescription
+ pkgDescription (ConfiguredPackage (AvailablePackage _ pkg _) flags _) =
+ case finalizePackageDescription flags
+ (const True)
+ platform compilerId [] pkg of
+ Left _ -> error "finalizePackageDescription ConfiguredPackage failed"
+ Right (desc, _) -> desc
+
+ -- This is sadly rather complicated. We're kind of re-doing part of the
+ -- configuration for the package. :-(
+ pkgBinDir :: PackageDescription -> IO FilePath
+ pkgBinDir pkg = do
+ defaultDirs <- InstallDirs.defaultInstallDirs
+ compilerFlavor
+ (fromFlag (configUserInstall configFlags))
+ (PackageDescription.hasLibs pkg)
+ let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault
+ defaultDirs (configInstallDirs configFlags)
+ absoluteDirs = InstallDirs.absoluteInstallDirs
+ (packageId pkg) compilerId InstallDirs.NoCopyDest
+ templateDirs
+ canonicalizePath (InstallDirs.bindir absoluteDirs)
+
+ substTemplate pkgid = InstallDirs.fromPathTemplate
+ . InstallDirs.substPathTemplate env
+ where env = InstallDirs.initialPathTemplateEnv pkgid compilerId
+
+ fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")
+ prefixTemplate = fromFlagTemplate (configProgPrefix configFlags)
+ suffixTemplate = fromFlagTemplate (configProgSuffix configFlags)
+ platform = InstallPlan.planPlatform plan
+ compilerId@(CompilerId compilerFlavor _) = InstallPlan.planCompiler plan
+
+symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir
+ -- eg @/home/user/bin@
+ -> FilePath -- ^ The canonical path of the private bin dir
+ -- eg @/home/user/.cabal/bin@
+ -> String -- ^ The name of the executable to go in the public
+ -- bin dir, eg @foo@
+ -> String -- ^ The name of the executable to in the private bin
+ -- dir, eg @foo-1.0@
+ -> IO Bool -- ^ If creating the symlink was sucessful. @False@
+ -- if there was another file there already that we
+ -- did not own. Other errors like permission errors
+ -- just propagate as exceptions.
+symlinkBinary publicBindir privateBindir publicName privateName = do
+ ok <- targetOkToOverwrite (publicBindir </> publicName)
+ (privateBindir </> privateName)
+ case ok of
+ NotOurFile -> return False
+ NotExists -> mkLink >> return True
+ OkToOverwrite -> rmLink >> mkLink >> return True
+ where
+ relativeBindir = makeRelative publicBindir privateBindir
+ mkLink = createSymbolicLink (relativeBindir </> privateName)
+ (publicBindir </> publicName)
+ rmLink = removeLink (publicBindir </> publicName)
+
+-- | Check a filepath of a symlink that we would like to create to see if it
+-- is ok. For it to be ok to overwrite it must either not already exist yet or
+-- be a symlink to our target (in which case we can assume ownership).
+--
+targetOkToOverwrite :: FilePath -- ^ The filepath of the symlink to the private
+ -- binary that we would like to create
+ -> FilePath -- ^ The canonical path of the private binary.
+ -- Use 'canonicalizePath' to make this.
+ -> IO SymlinkStatus
+targetOkToOverwrite symlink target = handleNotExist $ do
+ status <- getSymbolicLinkStatus symlink
+ if not (isSymbolicLink status)
+ then return NotOurFile
+ else do target' <- canonicalizePath symlink
+ -- This relies on canonicalizePath handling symlinks
+ if target == target'
+ then return OkToOverwrite
+ else return NotOurFile
+
+ where
+ handleNotExist action = catch action $ \ioexception ->
+ -- If the target doesn't exist then there's no problem overwriting it!
+ if isDoesNotExistError ioexception
+ then return NotExists
+ else ioError ioexception
+
+data SymlinkStatus
+ = NotExists -- ^ The file doesn't exist so we can make a symlink.
+ | OkToOverwrite -- ^ A symlink already exists, though it is ours. We'll
+ -- have to delete it first bemore we make a new symlink.
+ | NotOurFile -- ^ A file already exists and it is not one of our existing
+ -- symlinks (either because it is not a symlink or because
+ -- it points somewhere other than our managed space).
+ deriving Show
+
+-- | Take two canonical paths and produce a relative path to get from the first
+-- to the second, even if it means adding @..@ path components.
+--
+makeRelative :: FilePath -> FilePath -> FilePath
+makeRelative a b = assert (isAbsolute a && isAbsolute b) $
+ let as = splitPath a
+ bs = splitPath b
+ commonLen = length $ takeWhile id $ zipWith (==) as bs
+ in joinPath $ [ ".." | _ <- drop commonLen as ]
+ ++ [ b' | b' <- drop commonLen bs ]
+
+#endif
diff --git a/cabal-install-0.8.2/Distribution/Client/List.hs b/cabal-install-0.8.2/Distribution/Client/List.hs
new file mode 100644
index 0000000..e97f256
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/List.hs
@@ -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
+ 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)
diff --git a/cabal-install-0.8.2/Distribution/Client/PackageIndex.hs b/cabal-install-0.8.2/Distribution/Client/PackageIndex.hs
new file mode 100644
index 0000000..2f336f5
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/PackageIndex.hs
@@ -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
diff --git a/cabal-install-0.8.2/Distribution/Client/PackageUtils.hs b/cabal-install-0.8.2/Distribution/Client/PackageUtils.hs
new file mode 100644
index 0000000..bd2b1df
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/PackageUtils.hs
@@ -0,0 +1,34 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Client.PackageUtils
+-- Copyright : (c) Duncan Coutts 2010
+-- License : BSD-like
+--
+-- Maintainer : cabal-devel@gmail.com
+-- Stability : provisional
+-- Portability : portable
+--
+-- Various package description utils that should be in the Cabal lib
+-----------------------------------------------------------------------------
+module Distribution.Client.PackageUtils (
+ externalBuildDepends,
+ ) where
+
+import Distribution.Package
+ ( packageVersion, packageName, Dependency(..) )
+import Distribution.PackageDescription
+ ( PackageDescription(..) )
+import Distribution.Version
+ ( withinRange )
+
+-- | The list of dependencies that refer to external packages
+-- rather than internal package components.
+--
+externalBuildDepends :: PackageDescription -> [Dependency]
+externalBuildDepends pkg = filter (not . internal) (buildDepends pkg)
+ where
+ -- True if this dependency is an internal one (depends on a library
+ -- defined in the same package).
+ internal (Dependency depName versionRange) =
+ depName == packageName pkg &&
+ packageVersion pkg `withinRange` versionRange
diff --git a/cabal-install-0.8.2/Distribution/Client/Setup.hs b/cabal-install-0.8.2/Distribution/Client/Setup.hs
new file mode 100644
index 0000000..4441a8f
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/Setup.hs
@@ -0,0 +1,876 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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
+ }
diff --git a/cabal-install-0.8.2/Distribution/Client/SetupWrapper.hs b/cabal-install-0.8.2/Distribution/Client/SetupWrapper.hs
new file mode 100644
index 0000000..b48a929
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/SetupWrapper.hs
@@ -0,0 +1,321 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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
diff --git a/cabal-install-0.8.2/Distribution/Client/SrcDist.hs b/cabal-install-0.8.2/Distribution/Client/SrcDist.hs
new file mode 100644
index 0000000..f17a5ce
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/SrcDist.hs
@@ -0,0 +1,80 @@
+-- Implements the \"@.\/cabal sdist@\" command, which creates a source
+-- distribution for this package. That is, packs up the source code
+-- into a tarball, making use of the corresponding Cabal module.
+module Distribution.Client.SrcDist (
+ sdist
+ ) where
+import Distribution.Simple.SrcDist
+ ( printPackageProblems, prepareTree
+ , prepareSnapshotTree, snapshotPackage )
+import Distribution.Client.Tar (createTarGzFile)
+
+import Distribution.Package
+ ( Package(..) )
+import Distribution.PackageDescription
+ ( PackageDescription )
+import Distribution.PackageDescription.Parse
+ ( readPackageDescription )
+import Distribution.Simple.Utils
+ ( defaultPackageDesc, warn, notice, setupMessage
+ , createDirectoryIfMissingVerbose, withTempDirectory )
+import Distribution.Simple.Setup (SDistFlags(..), fromFlag)
+import Distribution.Verbosity (Verbosity)
+import Distribution.Simple.PreProcess (knownSuffixHandlers)
+import Distribution.Simple.BuildPaths ( srcPref)
+import Distribution.Simple.Configure(maybeGetPersistBuildConfig)
+import Distribution.PackageDescription.Configuration ( flattenPackageDescription )
+import Distribution.Text
+ ( display )
+
+import System.Time (getClockTime, toCalendarTime)
+import System.FilePath ((</>), (<.>))
+import Control.Monad (when)
+import Data.Maybe (isNothing)
+
+-- |Create a source distribution.
+sdist :: SDistFlags -> IO ()
+sdist flags = do
+ pkg <- return . flattenPackageDescription
+ =<< readPackageDescription verbosity
+ =<< defaultPackageDesc verbosity
+ mb_lbi <- maybeGetPersistBuildConfig distPref
+ let tmpTargetDir = srcPref distPref
+
+ -- do some QA
+ printPackageProblems verbosity pkg
+
+ when (isNothing mb_lbi) $
+ warn verbosity "Cannot run preprocessors. Run 'configure' command first."
+
+ createDirectoryIfMissingVerbose verbosity True tmpTargetDir
+ withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do
+
+ date <- toCalendarTime =<< getClockTime
+ let pkg' | snapshot = snapshotPackage date pkg
+ | otherwise = pkg
+ setupMessage verbosity "Building source dist for" (packageId pkg')
+
+ _ <- if snapshot
+ then prepareSnapshotTree verbosity pkg' mb_lbi distPref tmpDir pps
+ else prepareTree verbosity pkg' mb_lbi distPref tmpDir pps
+ targzFile <- createArchive verbosity pkg' tmpDir distPref
+ notice verbosity $ "Source tarball created: " ++ targzFile
+
+ where
+ verbosity = fromFlag (sDistVerbosity flags)
+ snapshot = fromFlag (sDistSnapshot flags)
+ distPref = fromFlag (sDistDistPref flags)
+ pps = knownSuffixHandlers
+
+-- |Create an archive from a tree of source files, and clean up the tree.
+createArchive :: Verbosity
+ -> PackageDescription
+ -> FilePath
+ -> FilePath
+ -> IO FilePath
+createArchive _verbosity pkg tmpDir targetPref = do
+ let tarBallName = display (packageId pkg)
+ tarBallFilePath = targetPref </> tarBallName <.> "tar.gz"
+ createTarGzFile tarBallFilePath tmpDir tarBallName
+ return tarBallFilePath
diff --git a/cabal-install-0.8.2/Distribution/Client/Tar.hs b/cabal-install-0.8.2/Distribution/Client/Tar.hs
new file mode 100644
index 0000000..ff7f254
--- /dev/null
+++ b/cabal-install-0.8.2/Distribution/Client/Tar.hs
@@ -0,0 +1,870 @@
+{-# 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 \"@..@\"