Skip to content
Browse files

move 'cabal' repo out of this git repo (Nensha's idea and implementat…

…ion)

Bumped cabal up to 1.15-dev state and fixed build failure.

Patch-by: Nensha <NenGraphy@gmail.com>
Signed-off-by: Sergei Trofimovich <slyfox@gentoo.org>
  • Loading branch information...
1 parent 014b2f9 commit 8ff048b7c730119f314d355ce3f996b48aaa69c0 @trofi trofi committed Jul 2, 2012
Showing with 5 additions and 20,682 deletions.
  1. +3 −0 .gitmodules
  2. +1 −2 Portage/GHCCore.hs
  3. +1 −0 cabal
  4. +0 −6 cabal/.darcs-boring
  5. +0 −10 cabal/HACKING
  6. +0 −7 cabal/IMPORTED-FROM
  7. +0 −33 cabal/LICENSE
  8. +0 −8 cabal/README
  9. +0 −311 cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs
  10. +0 −127 cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs
  11. +0 −44 cabal/cabal-install/Distribution/Client/BuildReports/Types.hs
  12. +0 −74 cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs
  13. +0 −85 cabal/cabal-install/Distribution/Client/Check.hs
  14. +0 −536 cabal/cabal-install/Distribution/Client/Config.hs
  15. +0 −194 cabal/cabal-install/Distribution/Client/Configure.hs
  16. +0 −449 cabal/cabal-install/Distribution/Client/Dependency.hs
  17. +0 −928 cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs
  18. +0 −601 cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs
  19. +0 −89 cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs
  20. +0 −116 cabal/cabal-install/Distribution/Client/Dependency/Types.hs
  21. +0 −173 cabal/cabal-install/Distribution/Client/Fetch.hs
  22. +0 −193 cabal/cabal-install/Distribution/Client/FetchUtils.hs
  23. +0 −44 cabal/cabal-install/Distribution/Client/GZipUtils.hs
  24. +0 −105 cabal/cabal-install/Distribution/Client/Haddock.hs
  25. +0 −197 cabal/cabal-install/Distribution/Client/HttpUtils.hs
  26. +0 −270 cabal/cabal-install/Distribution/Client/IndexUtils.hs
  27. +0 −603 cabal/cabal-install/Distribution/Client/Init.hs
  28. +0 −191 cabal/cabal-install/Distribution/Client/Init/Heuristics.hs
  29. +0 −1,722 cabal/cabal-install/Distribution/Client/Init/Licenses.hs
  30. +0 −152 cabal/cabal-install/Distribution/Client/Init/Types.hs
  31. +0 −891 cabal/cabal-install/Distribution/Client/Install.hs
  32. +0 −511 cabal/cabal-install/Distribution/Client/InstallPlan.hs
  33. +0 −238 cabal/cabal-install/Distribution/Client/InstallSymlink.hs
  34. +0 −530 cabal/cabal-install/Distribution/Client/List.hs
  35. +0 −487 cabal/cabal-install/Distribution/Client/PackageIndex.hs
  36. +0 −34 cabal/cabal-install/Distribution/Client/PackageUtils.hs
  37. +0 −1,023 cabal/cabal-install/Distribution/Client/Setup.hs
  38. +0 −320 cabal/cabal-install/Distribution/Client/SetupWrapper.hs
  39. +0 −80 cabal/cabal-install/Distribution/Client/SrcDist.hs
  40. +0 −903 cabal/cabal-install/Distribution/Client/Tar.hs
  41. +0 −743 cabal/cabal-install/Distribution/Client/Targets.hs
  42. +0 −163 cabal/cabal-install/Distribution/Client/Types.hs
  43. +0 −123 cabal/cabal-install/Distribution/Client/Unpack.hs
  44. +0 −82 cabal/cabal-install/Distribution/Client/Update.hs
  45. +0 −190 cabal/cabal-install/Distribution/Client/Upload.hs
  46. +0 −60 cabal/cabal-install/Distribution/Client/Utils.hs
  47. +0 −222 cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs
  48. +0 −173 cabal/cabal-install/Distribution/Client/World.hs
  49. +0 −56 cabal/cabal-install/Distribution/Compat/ExceptionCI.hs
  50. +0 −40 cabal/cabal-install/Distribution/Compat/FilePerms.hs
  51. +0 −34 cabal/cabal-install/LICENSE
  52. +0 −403 cabal/cabal-install/Main.hs
  53. +0 −8 cabal/cabal-install/Paths_cabal_install.hs
  54. +0 −153 cabal/cabal-install/README
  55. +0 −2 cabal/cabal-install/Setup.hs
  56. +0 −24 cabal/cabal-install/bash-completion/cabal
  57. +0 −231 cabal/cabal-install/bootstrap.sh
  58. +0 −120 cabal/cabal-install/cabal-install.cabal
  59. +0 −121 cabal/cabal-install/changelog
  60. +0 −9 cabal/cabal-install/tests/test-cabal-install
  61. +0 −8 cabal/cabal-install/tests/test-cabal-install-user
  62. +0 −163 cabal/cabal/Cabal.cabal
  63. +0 −2 cabal/cabal/DefaultSetup.hs
  64. +0 −115 cabal/cabal/Distribution/Compat/CopyFile.hs
  65. +0 −61 cabal/cabal/Distribution/Compat/Exception.hs
  66. +0 −470 cabal/cabal/Distribution/Compat/ReadP.hs
  67. +0 −204 cabal/cabal/Distribution/Compat/TempFile.hs
  68. +0 −158 cabal/cabal/Distribution/Compiler.hs
  69. +0 −335 cabal/cabal/Distribution/GetOpt.hs
  70. +0 −294 cabal/cabal/Distribution/InstalledPackageInfo.hs
  71. +0 −138 cabal/cabal/Distribution/License.hs
  72. +0 −213 cabal/cabal/Distribution/Make.hs
  73. +0 −130 cabal/cabal/Distribution/ModuleName.hs
  74. +0 −193 cabal/cabal/Distribution/Package.hs
  75. +0 −895 cabal/cabal/Distribution/PackageDescription.hs
  76. +0 −1,441 cabal/cabal/Distribution/PackageDescription/Check.hs
  77. +0 −618 cabal/cabal/Distribution/PackageDescription/Configuration.hs
Sorry, we could not display the entire diff because too many files (311) changed.
View
3 .gitmodules
@@ -0,0 +1,3 @@
+[submodule "cabal"]
+ path = cabal
+ url = git://github.com/gentoo-haskell/cabal.git
View
3 Portage/GHCCore.hs
@@ -90,8 +90,7 @@ mkIndex pids = fromList
| pi@(PackageIdentifier name version) <- pids ]
packageNamesFromPackageIndex :: PackageIndex -> [PackageName]
-packageNamesFromPackageIndex pix = nub $
- [ (pkgName . sourcePackageId) p | (p:_) <- allPackagesByName pix ]
+packageNamesFromPackageIndex pix = nub $ map fst $ allPackagesByName pix
ghc :: [Int] -> CompilerId
ghc nrs = CompilerId GHC (Version nrs [])
1 cabal
@@ -0,0 +1 @@
+Subproject commit 815a6cd92846c8a80905a153283c4bbaad06581a
View
6 cabal/.darcs-boring
@@ -1,6 +0,0 @@
-^dist(/|$)
-^setup(/|$)
-^GNUmakefile$
-^Makefile.local$
-^.depend(.bak)?$
-^doc/.depend(.bak)?$
View
10 cabal/HACKING
@@ -1,10 +0,0 @@
-If you want to hack on Cabal, don't be intimidated!
-
-Read the guide to the source code:
- http://hackage.haskell.org/trac/hackage/wiki/SourceGuide
-
-There are other resources listed on the dev wiki:
- http://hackage.haskell.org/trac/hackage/
-
-In particular, the open tickets and the cabal-devel mailing list
-which is a good place to ask questions.
View
7 cabal/IMPORTED-FROM
@@ -1,7 +0,0 @@
-http://darcs.haskell.org/cabal-branches/cabal-1.12
-
-Fri Jul 15 15:04:46 EEST 2011 Ian Lynagh <igloo@earth.li>
- * Bump version number
- hunk ./cabal/Cabal.cabal 2
- -Version: 1.11.2
- +Version: 1.12.0
View
33 cabal/LICENSE
@@ -1,33 +0,0 @@
-Copyright (c) 2011, Duncan Coutts and Ian Lynagh.
-
-See */LICENSE for the copyright holders of the subcomponents.
-
-All rights reserved.
-
-Redistribution and use in source and binary forms, with or without
-modification, are permitted provided that the following conditions are
-met:
-
- * Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
-
- * Redistributions in binary form must reproduce the above
- copyright notice, this list of conditions and the following
- disclaimer in the documentation and/or other materials provided
- with the distribution.
-
- * Neither the name of Isaac Jones nor the names of other
- contributors may be used to endorse or promote products derived
- from this software without specific prior written permission.
-
-THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
View
8 cabal/README
@@ -1,8 +0,0 @@
-This Cabal darcs repository contains multiple packages:
-
- * cabal/ -- the Cabal library package
- * cabal-install/ -- the cabal-install package containing the 'cabal' tool.
-
-See the README in each subdir for more details.
-
-The canonical upstream repo lives at http://darcs.haskell.org/cabal/
View
311 cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs
@@ -1,311 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Client.Reporting
--- Copyright : (c) David Waern 2008
--- License : BSD-like
---
--- Maintainer : david.waern@gmail.com
--- Stability : experimental
--- Portability : portable
---
--- Anonymous build report data structure, printing and parsing
---
------------------------------------------------------------------------------
-module Distribution.Client.BuildReports.Anonymous (
- BuildReport(..),
- InstallOutcome(..),
- Outcome(..),
-
- -- * Constructing and writing reports
- new,
-
- -- * parsing and pretty printing
- parse,
- parseList,
- show,
--- showList,
- ) where
-
-import Distribution.Client.Types
- ( ConfiguredPackage(..) )
-import qualified Distribution.Client.Types as BR
- ( BuildResult, BuildFailure(..), BuildSuccess(..)
- , DocsResult(..), TestsResult(..) )
-import Distribution.Client.Utils
- ( mergeBy, MergeResult(..) )
-import qualified Paths_cabal_install (version)
-
-import Distribution.Package
- ( PackageIdentifier(..), PackageName(..), Package(packageId) )
-import Distribution.PackageDescription
- ( FlagName(..), FlagAssignment )
---import Distribution.Version
--- ( Version )
-import Distribution.System
- ( OS, Arch )
-import Distribution.Compiler
- ( CompilerId )
-import qualified Distribution.Text as Text
- ( Text(disp, parse) )
-import Distribution.ParseUtils
- ( FieldDescr(..), ParseResult(..), Field(..)
- , simpleField, listField, ppFields, readFields
- , syntaxError, locatedErrorMsg )
-import Distribution.Simple.Utils
- ( comparing )
-
-import qualified Distribution.Compat.ReadP as Parse
- ( ReadP, pfail, munch1, skipSpaces )
-import qualified Text.PrettyPrint.HughesPJ as Disp
- ( Doc, render, char, text )
-import Text.PrettyPrint.HughesPJ
- ( (<+>), (<>) )
-
-import Data.List
- ( unfoldr, sortBy )
-import Data.Char as Char
- ( isAlpha, isAlphaNum )
-
-import Prelude hiding (show)
-
-data BuildReport
- = BuildReport {
- -- | The package this build report is about
- package :: PackageIdentifier,
-
- -- | The OS and Arch the package was built on
- os :: OS,
- arch :: Arch,
-
- -- | The Haskell compiler (and hopefully version) used
- compiler :: CompilerId,
-
- -- | The uploading client, ie cabal-install-x.y.z
- client :: PackageIdentifier,
-
- -- | Which configurations flags we used
- flagAssignment :: FlagAssignment,
-
- -- | Which dependent packages we were using exactly
- dependencies :: [PackageIdentifier],
-
- -- | Did installing work ok?
- installOutcome :: InstallOutcome,
-
- -- Which version of the Cabal library was used to compile the Setup.hs
--- cabalVersion :: Version,
-
- -- Which build tools we were using (with versions)
--- tools :: [PackageIdentifier],
-
- -- | Configure outcome, did configure work ok?
- docsOutcome :: Outcome,
-
- -- | Configure outcome, did configure work ok?
- testsOutcome :: Outcome
- }
-
-data InstallOutcome
- = DependencyFailed PackageIdentifier
- | DownloadFailed
- | UnpackFailed
- | SetupFailed
- | ConfigureFailed
- | BuildFailed
- | InstallFailed
- | InstallOk
- deriving Eq
-
-data Outcome = NotTried | Failed | Ok
- deriving Eq
-
-new :: OS -> Arch -> CompilerId -- -> Version
- -> ConfiguredPackage -> BR.BuildResult
- -> BuildReport
-new os' arch' comp (ConfiguredPackage pkg flags deps) result =
- BuildReport {
- package = packageId pkg,
- os = os',
- arch = arch',
- compiler = comp,
- client = cabalInstallID,
- flagAssignment = flags,
- dependencies = deps,
- installOutcome = convertInstallOutcome,
--- cabalVersion = undefined
- docsOutcome = convertDocsOutcome,
- testsOutcome = convertTestsOutcome
- }
- where
- convertInstallOutcome = case result of
- Left (BR.DependentFailed p) -> DependencyFailed p
- Left (BR.DownloadFailed _) -> DownloadFailed
- Left (BR.UnpackFailed _) -> UnpackFailed
- Left (BR.ConfigureFailed _) -> ConfigureFailed
- Left (BR.BuildFailed _) -> BuildFailed
- Left (BR.InstallFailed _) -> InstallFailed
- Right (BR.BuildOk _ _) -> InstallOk
- convertDocsOutcome = case result of
- Left _ -> NotTried
- Right (BR.BuildOk BR.DocsNotTried _) -> NotTried
- Right (BR.BuildOk BR.DocsFailed _) -> Failed
- Right (BR.BuildOk BR.DocsOk _) -> Ok
- convertTestsOutcome = case result of
- Left _ -> NotTried
- Right (BR.BuildOk _ BR.TestsNotTried) -> NotTried
- Right (BR.BuildOk _ BR.TestsFailed) -> Failed
- Right (BR.BuildOk _ BR.TestsOk) -> Ok
-
-cabalInstallID :: PackageIdentifier
-cabalInstallID =
- PackageIdentifier (PackageName "cabal-install") Paths_cabal_install.version
-
--- ------------------------------------------------------------
--- * External format
--- ------------------------------------------------------------
-
-initialBuildReport :: BuildReport
-initialBuildReport = BuildReport {
- package = requiredField "package",
- os = requiredField "os",
- arch = requiredField "arch",
- compiler = requiredField "compiler",
- client = requiredField "client",
- flagAssignment = [],
- dependencies = [],
- installOutcome = requiredField "install-outcome",
--- cabalVersion = Nothing,
--- tools = [],
- docsOutcome = NotTried,
- testsOutcome = NotTried
- }
- where
- requiredField fname = error ("required field: " ++ fname)
-
--- -----------------------------------------------------------------------------
--- Parsing
-
-parse :: String -> Either String BuildReport
-parse s = case parseFields s of
- ParseFailed perror -> Left msg where (_, msg) = locatedErrorMsg perror
- ParseOk _ report -> Right report
-
---FIXME: this does not allow for optional or repeated fields
-parseFields :: String -> ParseResult BuildReport
-parseFields input = do
- fields <- mapM extractField =<< readFields input
- let merged = mergeBy (\desc (_,name,_) -> compare (fieldName desc) name)
- sortedFieldDescrs
- (sortBy (comparing (\(_,name,_) -> name)) fields)
- checkMerged initialBuildReport merged
-
- where
- extractField :: Field -> ParseResult (Int, String, String)
- extractField (F line name value) = return (line, name, value)
- extractField (Section line _ _ _) = syntaxError line "Unrecognized stanza"
- extractField (IfBlock line _ _ _) = syntaxError line "Unrecognized stanza"
-
- checkMerged report [] = return report
- checkMerged report (merged:remaining) = case merged of
- InBoth fieldDescr (line, _name, value) -> do
- report' <- fieldSet fieldDescr line value report
- checkMerged report' remaining
- OnlyInRight (line, name, _) ->
- syntaxError line ("Unrecognized field " ++ name)
- OnlyInLeft fieldDescr ->
- fail ("Missing field " ++ fieldName fieldDescr)
-
-parseList :: String -> [BuildReport]
-parseList str =
- [ report | Right report <- map parse (split str) ]
-
- where
- split :: String -> [String]
- split = filter (not . null) . unfoldr chunk . lines
- chunk [] = Nothing
- chunk ls = case break null ls of
- (r, rs) -> Just (unlines r, dropWhile null rs)
-
--- -----------------------------------------------------------------------------
--- Pretty-printing
-
-show :: BuildReport -> String
-show = Disp.render . ppFields fieldDescrs
-
--- -----------------------------------------------------------------------------
--- Description of the fields, for parsing/printing
-
-fieldDescrs :: [FieldDescr BuildReport]
-fieldDescrs =
- [ simpleField "package" Text.disp Text.parse
- package (\v r -> r { package = v })
- , simpleField "os" Text.disp Text.parse
- os (\v r -> r { os = v })
- , simpleField "arch" Text.disp Text.parse
- arch (\v r -> r { arch = v })
- , simpleField "compiler" Text.disp Text.parse
- compiler (\v r -> r { compiler = v })
- , simpleField "client" Text.disp Text.parse
- client (\v r -> r { client = v })
- , listField "flags" dispFlag parseFlag
- flagAssignment (\v r -> r { flagAssignment = v })
- , listField "dependencies" Text.disp Text.parse
- dependencies (\v r -> r { dependencies = v })
- , simpleField "install-outcome" Text.disp Text.parse
- installOutcome (\v r -> r { installOutcome = v })
- , simpleField "docs-outcome" Text.disp Text.parse
- docsOutcome (\v r -> r { docsOutcome = v })
- , simpleField "tests-outcome" Text.disp Text.parse
- testsOutcome (\v r -> r { testsOutcome = v })
- ]
-
-sortedFieldDescrs :: [FieldDescr BuildReport]
-sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs
-
-dispFlag :: (FlagName, Bool) -> Disp.Doc
-dispFlag (FlagName name, True) = Disp.text name
-dispFlag (FlagName name, False) = Disp.char '-' <> Disp.text name
-
-parseFlag :: Parse.ReadP r (FlagName, Bool)
-parseFlag = do
- name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')
- case name of
- ('-':flag) -> return (FlagName flag, False)
- flag -> return (FlagName flag, True)
-
-instance Text.Text InstallOutcome where
- disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid
- disp DownloadFailed = Disp.text "DownloadFailed"
- disp UnpackFailed = Disp.text "UnpackFailed"
- disp SetupFailed = Disp.text "SetupFailed"
- disp ConfigureFailed = Disp.text "ConfigureFailed"
- disp BuildFailed = Disp.text "BuildFailed"
- disp InstallFailed = Disp.text "InstallFailed"
- disp InstallOk = Disp.text "InstallOk"
-
- parse = do
- name <- Parse.munch1 Char.isAlphaNum
- case name of
- "DependencyFailed" -> do Parse.skipSpaces
- pkgid <- Text.parse
- return (DependencyFailed pkgid)
- "DownloadFailed" -> return DownloadFailed
- "UnpackFailed" -> return UnpackFailed
- "SetupFailed" -> return SetupFailed
- "ConfigureFailed" -> return ConfigureFailed
- "BuildFailed" -> return BuildFailed
- "InstallFailed" -> return InstallFailed
- "InstallOk" -> return InstallOk
- _ -> Parse.pfail
-
-instance Text.Text Outcome where
- disp NotTried = Disp.text "NotTried"
- disp Failed = Disp.text "Failed"
- disp Ok = Disp.text "Ok"
- parse = do
- name <- Parse.munch1 Char.isAlpha
- case name of
- "NotTried" -> return NotTried
- "Failed" -> return Failed
- "Ok" -> return Ok
- _ -> Parse.pfail
View
127 cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs
@@ -1,127 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Client.Reporting
--- Copyright : (c) David Waern 2008
--- License : BSD-like
---
--- Maintainer : david.waern@gmail.com
--- Stability : experimental
--- Portability : portable
---
--- Anonymous build report data structure, printing and parsing
---
------------------------------------------------------------------------------
-module Distribution.Client.BuildReports.Storage (
-
- -- * Storing and retrieving build reports
- storeAnonymous,
- storeLocal,
--- retrieve,
-
- -- * 'InstallPlan' support
- fromInstallPlan,
- ) where
-
-import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
-import Distribution.Client.BuildReports.Anonymous (BuildReport)
-
-import Distribution.Client.Types
-import qualified Distribution.Client.InstallPlan as InstallPlan
-import Distribution.Client.InstallPlan
- ( InstallPlan )
-
-import Distribution.Simple.InstallDirs
- ( PathTemplate, fromPathTemplate
- , initialPathTemplateEnv, substPathTemplate )
-import Distribution.System
- ( Platform(Platform) )
-import Distribution.Compiler
- ( CompilerId )
-import Distribution.Simple.Utils
- ( comparing, equating )
-
-import Data.List
- ( groupBy, sortBy )
-import Data.Maybe
- ( catMaybes )
-import System.FilePath
- ( (</>), takeDirectory )
-import System.Directory
- ( createDirectoryIfMissing )
-
-storeAnonymous :: [(BuildReport, Repo)] -> IO ()
-storeAnonymous reports = sequence_
- [ appendFile file (concatMap format reports')
- | (repo, reports') <- separate reports
- , let file = repoLocalDir repo </> "build-reports.log" ]
- --TODO: make this concurrency safe, either lock the report file or make sure
- -- the writes for each report are atomic (under 4k and flush at boundaries)
-
- where
- format r = '\n' : BuildReport.show r ++ "\n"
- separate :: [(BuildReport, Repo)]
- -> [(Repo, [BuildReport])]
- separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ]))
- . map concat
- . groupBy (equating (repoName . head))
- . sortBy (comparing (repoName . head))
- . groupBy (equating repoName)
- . onlyRemote
- repoName (_,_,rrepo) = remoteRepoName rrepo
-
- onlyRemote :: [(BuildReport, Repo)] -> [(BuildReport, Repo, RemoteRepo)]
- onlyRemote rs =
- [ (report, repo, remoteRepo)
- | (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ]
-
-storeLocal :: [PathTemplate] -> [(BuildReport, Repo)] -> IO ()
-storeLocal templates reports = sequence_
- [ do createDirectoryIfMissing True (takeDirectory file)
- appendFile file output
- --TODO: make this concurrency safe, either lock the report file or make
- -- sure the writes for each report are atomic
- | (file, reports') <- groupByFileName
- [ (reportFileName template report, report)
- | template <- templates
- , (report, _repo) <- reports ]
- , let output = concatMap format reports'
- ]
- where
- format r = '\n' : BuildReport.show r ++ "\n"
-
- reportFileName template report =
- fromPathTemplate (substPathTemplate env template)
- where env = initialPathTemplateEnv
- (BuildReport.package report)
- (BuildReport.compiler report)
-
- groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp))
- . groupBy (equating fst)
- . sortBy (comparing fst)
-
--- ------------------------------------------------------------
--- * InstallPlan support
--- ------------------------------------------------------------
-
-fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)]
-fromInstallPlan plan = catMaybes
- . map (fromPlanPackage platform comp)
- . InstallPlan.toList
- $ plan
- where platform = InstallPlan.planPlatform plan
- comp = InstallPlan.planCompiler plan
-
-fromPlanPackage :: Platform -> CompilerId
- -> InstallPlan.PlanPackage
- -> Maybe (BuildReport, Repo)
-fromPlanPackage (Platform arch os) comp planPackage = case planPackage of
-
- InstallPlan.Installed pkg@(ConfiguredPackage (SourcePackage {
- packageSource = RepoTarballPackage repo _ _ }) _ _) result
- -> Just $ (BuildReport.new os arch comp pkg (Right result), repo)
-
- InstallPlan.Failed pkg@(ConfiguredPackage (SourcePackage {
- packageSource = RepoTarballPackage repo _ _ }) _ _) result
- -> Just $ (BuildReport.new os arch comp pkg (Left result), repo)
-
- _ -> Nothing
View
44 cabal/cabal-install/Distribution/Client/BuildReports/Types.hs
@@ -1,44 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Client.BuildReports.Types
--- Copyright : (c) Duncan Coutts 2009
--- License : BSD-like
---
--- Maintainer : cabal-devel@haskell.org
--- Portability : portable
---
--- Types related to build reporting
---
------------------------------------------------------------------------------
-module Distribution.Client.BuildReports.Types (
- ReportLevel(..),
- ) where
-
-import qualified Distribution.Text as Text
- ( Text(..) )
-
-import qualified Distribution.Compat.ReadP as Parse
- ( pfail, munch1 )
-import qualified Text.PrettyPrint.HughesPJ as Disp
- ( text )
-
-import Data.Char as Char
- ( isAlpha, toLower )
-
-data ReportLevel = NoReports | AnonymousReports | DetailedReports
- deriving (Eq, Ord, Show)
-
-instance Text.Text ReportLevel where
- disp NoReports = Disp.text "none"
- disp AnonymousReports = Disp.text "anonymous"
- disp DetailedReports = Disp.text "detailed"
- parse = do
- name <- Parse.munch1 Char.isAlpha
- case lowercase name of
- "none" -> return NoReports
- "anonymous" -> return AnonymousReports
- "detailed" -> return DetailedReports
- _ -> Parse.pfail
-
-lowercase :: String -> String
-lowercase = map Char.toLower
View
74 cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs
@@ -1,74 +0,0 @@
-{-# LANGUAGE PatternGuards #-}
--- This is a quick hack for uploading build reports to Hackage.
-
-module Distribution.Client.BuildReports.Upload
- ( BuildLog
- , BuildReportId
- , uploadReports
- , postBuildReport
- , putBuildLog
- ) where
-
-import Network.Browser
- ( BrowserAction, request, setAllowRedirects )
-import Network.HTTP
- ( Header(..), HeaderName(..)
- , Request(..), RequestMethod(..), Response(..) )
-import Network.TCP (HandleStream)
-import Network.URI (URI, uriPath, parseRelativeReference, relativeTo)
-
-import Control.Monad
- ( forM_ )
-import System.FilePath.Posix
- ( (</>) )
-import qualified Distribution.Client.BuildReports.Anonymous as BuildReport
-import Distribution.Client.BuildReports.Anonymous (BuildReport)
-import Distribution.Text (display)
-
-type BuildReportId = URI
-type BuildLog = String
-
-uploadReports :: URI -> [(BuildReport, Maybe BuildLog)]
- -> BrowserAction (HandleStream String) ()
- -> BrowserAction (HandleStream BuildLog) ()
-uploadReports uri reports auth = do
- auth
- forM_ reports $ \(report, mbBuildLog) -> do
- buildId <- postBuildReport uri report
- case mbBuildLog of
- Just buildLog -> putBuildLog buildId buildLog
- Nothing -> return ()
-
-postBuildReport :: URI -> BuildReport
- -> BrowserAction (HandleStream BuildLog) BuildReportId
-postBuildReport uri buildReport = do
- setAllowRedirects False
- (_, response) <- request Request {
- rqURI = uri { uriPath = "/package" </> display (BuildReport.package buildReport) </> "reports" },
- rqMethod = POST,
- rqHeaders = [Header HdrContentType ("text/plain"),
- Header HdrContentLength (show (length body)),
- Header HdrAccept ("text/plain")],
- rqBody = body
- }
- case rspCode response of
- (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location
- relativeTo rel uri
- | Header HdrLocation location <- rspHeaders response ]
- -> return $ buildId
- _ -> error "Unrecognised response from server."
- where body = BuildReport.show buildReport
-
-putBuildLog :: BuildReportId -> BuildLog
- -> BrowserAction (HandleStream BuildLog) ()
-putBuildLog reportId buildLog = do
- --FIXME: do something if the request fails
- (_, response) <- request Request {
- rqURI = reportId{uriPath = uriPath reportId </> "log"},
- rqMethod = PUT,
- rqHeaders = [Header HdrContentType ("text/plain"),
- Header HdrContentLength (show (length buildLog)),
- Header HdrAccept ("text/plain")],
- rqBody = buildLog
- }
- return ()
View
85 cabal/cabal-install/Distribution/Client/Check.hs
@@ -1,85 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Client.Check
--- Copyright : (c) Lennart Kolmodin 2008
--- License : BSD-like
---
--- Maintainer : kolmodin@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Check a package for common mistakes
---
------------------------------------------------------------------------------
-module Distribution.Client.Check (
- check
- ) where
-
-import Control.Monad ( when, unless )
-
-import Distribution.PackageDescription.Parse
- ( readPackageDescription )
-import Distribution.PackageDescription.Check
-import Distribution.PackageDescription.Configuration
- ( flattenPackageDescription )
-import Distribution.Verbosity
- ( Verbosity )
-import Distribution.Simple.Utils
- ( defaultPackageDesc, toUTF8, wrapText )
-
-check :: Verbosity -> IO Bool
-check verbosity = do
- pdfile <- defaultPackageDesc verbosity
- ppd <- readPackageDescription verbosity pdfile
- -- flatten the generic package description into a regular package
- -- description
- -- TODO: this may give more warnings than it should give;
- -- consider two branches of a condition, one saying
- -- ghc-options: -Wall
- -- and the other
- -- ghc-options: -Werror
- -- joined into
- -- ghc-options: -Wall -Werror
- -- checkPackages will yield a warning on the last line, but it
- -- would not on each individual branch.
- -- Hovever, this is the same way hackage does it, so we will yield
- -- the exact same errors as it will.
- let pkg_desc = flattenPackageDescription ppd
- ioChecks <- checkPackageFiles pkg_desc "."
- let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc)
- buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ]
- buildWarning = [ x | x@PackageBuildWarning {} <- packageChecks ]
- distSuspicious = [ x | x@PackageDistSuspicious {} <- packageChecks ]
- distInexusable = [ x | x@PackageDistInexcusable {} <- packageChecks ]
-
- unless (null buildImpossible) $ do
- putStrLn "The package will not build sanely due to these errors:"
- printCheckMessages buildImpossible
-
- unless (null buildWarning) $ do
- putStrLn "The following warnings are likely affect your build negatively:"
- printCheckMessages buildWarning
-
- unless (null distSuspicious) $ do
- putStrLn "These warnings may cause trouble when distributing the package:"
- printCheckMessages distSuspicious
-
- unless (null distInexusable) $ do
- putStrLn "The following errors will cause portability problems on other environments:"
- printCheckMessages distInexusable
-
- let isDistError (PackageDistSuspicious {}) = False
- isDistError _ = True
- errors = filter isDistError packageChecks
-
- unless (null errors) $ do
- putStrLn "Hackage would reject this package."
-
- when (null packageChecks) $ do
- putStrLn "No errors or warnings could be found in the package."
-
- return (null packageChecks)
-
- where
- printCheckMessages = mapM_ (putStrLn . format . explanation)
- format = toUTF8 . wrapText . ("* "++)
View
536 cabal/cabal-install/Distribution/Client/Config.hs
@@ -1,536 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Client.Config
--- Copyright : (c) David Himmelstrup 2005
--- License : BSD-like
---
--- Maintainer : lemmih@gmail.com
--- Stability : provisional
--- Portability : portable
---
--- Utilities for handling saved state such as known packages, known servers and downloaded packages.
------------------------------------------------------------------------------
-module Distribution.Client.Config (
- SavedConfig(..),
- loadConfig,
-
- showConfig,
- showConfigWithComments,
- parseConfig,
-
- defaultCabalDir,
- defaultConfigFile,
- defaultCacheDir,
- defaultLogsDir,
- ) where
-
-
-import Distribution.Client.Types
- ( RemoteRepo(..), Username(..), Password(..) )
-import Distribution.Client.BuildReports.Types
- ( ReportLevel(..) )
-import Distribution.Client.Setup
- ( GlobalFlags(..), globalCommand
- , ConfigExFlags(..), configureExOptions, defaultConfigExFlags
- , InstallFlags(..), installOptions, defaultInstallFlags
- , UploadFlags(..), uploadCommand
- , ReportFlags(..), reportCommand
- , showRepo, parseRepo )
-
-import Distribution.Simple.Setup
- ( ConfigFlags(..), configureOptions, defaultConfigFlags
- , installDirsOptions
- , Flag, toFlag, flagToMaybe, fromFlagOrDefault )
-import Distribution.Simple.InstallDirs
- ( InstallDirs(..), defaultInstallDirs
- , PathTemplate, toPathTemplate )
-import Distribution.ParseUtils
- ( FieldDescr(..), liftField
- , ParseResult(..), locatedErrorMsg, showPWarning
- , readFields, warning, lineNo
- , simpleField, listField, parseFilePathQ, parseTokenQ )
-import qualified Distribution.ParseUtils as ParseUtils
- ( Field(..) )
-import qualified Distribution.Text as Text
- ( Text(..) )
-import Distribution.Simple.Command
- ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..)
- , viewAsFieldDescr )
-import Distribution.Simple.Program
- ( defaultProgramConfiguration )
-import Distribution.Simple.Utils
- ( notice, warn, lowercase )
-import Distribution.Compiler
- ( CompilerFlavor(..), defaultCompilerFlavor )
-import Distribution.Verbosity
- ( Verbosity, normal )
-
-import Data.List
- ( partition, find )
-import Data.Maybe
- ( fromMaybe )
-import Data.Monoid
- ( Monoid(..) )
-import Control.Monad
- ( when, foldM, liftM )
-import qualified Data.Map as Map
-import qualified Distribution.Compat.ReadP as Parse
- ( option )
-import qualified Text.PrettyPrint.HughesPJ as Disp
- ( Doc, render, text, colon, vcat, empty, isEmpty, nest )
-import Text.PrettyPrint.HughesPJ
- ( (<>), (<+>), ($$), ($+$) )
-import System.Directory
- ( createDirectoryIfMissing, getAppUserDataDirectory )
-import Network.URI
- ( URI(..), URIAuth(..) )
-import System.FilePath
- ( (</>), takeDirectory )
-import System.Environment
- ( getEnvironment )
-import System.IO.Error
- ( isDoesNotExistError )
-
---
--- * Configuration saved in the config file
---
-
-data SavedConfig = SavedConfig {
- savedGlobalFlags :: GlobalFlags,
- savedInstallFlags :: InstallFlags,
- savedConfigureFlags :: ConfigFlags,
- savedConfigureExFlags :: ConfigExFlags,
- savedUserInstallDirs :: InstallDirs (Flag PathTemplate),
- savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate),
- savedUploadFlags :: UploadFlags,
- savedReportFlags :: ReportFlags
- }
-
-instance Monoid SavedConfig where
- mempty = SavedConfig {
- savedGlobalFlags = mempty,
- savedInstallFlags = mempty,
- savedConfigureFlags = mempty,
- savedConfigureExFlags = mempty,
- savedUserInstallDirs = mempty,
- savedGlobalInstallDirs = mempty,
- savedUploadFlags = mempty,
- savedReportFlags = mempty
- }
- mappend a b = SavedConfig {
- savedGlobalFlags = combine savedGlobalFlags,
- savedInstallFlags = combine savedInstallFlags,
- savedConfigureFlags = combine savedConfigureFlags,
- savedConfigureExFlags = combine savedConfigureExFlags,
- savedUserInstallDirs = combine savedUserInstallDirs,
- savedGlobalInstallDirs = combine savedGlobalInstallDirs,
- savedUploadFlags = combine savedUploadFlags,
- savedReportFlags = combine savedReportFlags
- }
- where combine field = field a `mappend` field b
-
-updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig
-updateInstallDirs userInstallFlag
- savedConfig@SavedConfig {
- savedConfigureFlags = configureFlags,
- savedUserInstallDirs = userInstallDirs,
- savedGlobalInstallDirs = globalInstallDirs
- } =
- savedConfig {
- savedConfigureFlags = configureFlags {
- configInstallDirs = installDirs
- }
- }
- where
- installDirs | userInstall = userInstallDirs
- | otherwise = globalInstallDirs
- userInstall = fromFlagOrDefault defaultUserInstall $
- configUserInstall configureFlags `mappend` userInstallFlag
-
---
--- * Default config
---
-
--- | These are the absolute basic defaults. The fields that must be
--- initialised. When we load the config from the file we layer the loaded
--- values over these ones, so any missing fields in the file take their values
--- from here.
---
-baseSavedConfig :: IO SavedConfig
-baseSavedConfig = do
- userPrefix <- defaultCabalDir
- logsDir <- defaultLogsDir
- worldFile <- defaultWorldFile
- return mempty {
- savedConfigureFlags = mempty {
- configHcFlavor = toFlag defaultCompiler,
- configUserInstall = toFlag defaultUserInstall,
- configVerbosity = toFlag normal
- },
- savedUserInstallDirs = mempty {
- prefix = toFlag (toPathTemplate userPrefix)
- },
- savedGlobalFlags = mempty {
- globalLogsDir = toFlag logsDir,
- globalWorldFile = toFlag worldFile
- }
- }
-
--- | This is the initial configuration that we write out to to the config file
--- if the file does not exist (or the config we use if the file cannot be read
--- for some other reason). When the config gets loaded it gets layered on top
--- of 'baseSavedConfig' so we do not need to include it into the initial
--- values we save into the config file.
---
-initialSavedConfig :: IO SavedConfig
-initialSavedConfig = do
- cacheDir <- defaultCacheDir
- logsDir <- defaultLogsDir
- worldFile <- defaultWorldFile
- return mempty {
- savedGlobalFlags = mempty {
- globalCacheDir = toFlag cacheDir,
- globalRemoteRepos = [defaultRemoteRepo],
- globalWorldFile = toFlag worldFile
- },
- savedInstallFlags = mempty {
- installSummaryFile = [toPathTemplate (logsDir </> "build.log")],
- installBuildReports= toFlag AnonymousReports
- }
- }
-
---TODO: misleading, there's no way to override this default
--- either make it possible or rename to simply getCabalDir.
-defaultCabalDir :: IO FilePath
-defaultCabalDir = getAppUserDataDirectory "cabal"
-
-defaultConfigFile :: IO FilePath
-defaultConfigFile = do
- dir <- defaultCabalDir
- return $ dir </> "config"
-
-defaultCacheDir :: IO FilePath
-defaultCacheDir = do
- dir <- defaultCabalDir
- return $ dir </> "packages"
-
-defaultLogsDir :: IO FilePath
-defaultLogsDir = do
- dir <- defaultCabalDir
- return $ dir </> "logs"
-
--- | Default position of the world file
-defaultWorldFile :: IO FilePath
-defaultWorldFile = do
- dir <- defaultCabalDir
- return $ dir </> "world"
-
-defaultCompiler :: CompilerFlavor
-defaultCompiler = fromMaybe GHC defaultCompilerFlavor
-
-defaultUserInstall :: Bool
-defaultUserInstall = True
--- We do per-user installs by default on all platforms. We used to default to
--- global installs on Windows but that no longer works on Windows Vista or 7.
-
-defaultRemoteRepo :: RemoteRepo
-defaultRemoteRepo = RemoteRepo name uri
- where
- name = "hackage.haskell.org"
- uri = URI "http:" (Just (URIAuth "" name "")) "/packages/archive" "" ""
-
---
--- * Config file reading
---
-
-loadConfig :: Verbosity -> Flag FilePath -> Flag Bool -> IO SavedConfig
-loadConfig verbosity configFileFlag userInstallFlag = addBaseConf $ do
- let sources = [
- ("commandline option", return . flagToMaybe $ configFileFlag),
- ("env var CABAL_CONFIG", lookup "CABAL_CONFIG" `liftM` getEnvironment),
- ("default config file", Just `liftM` defaultConfigFile) ]
-
- getSource [] = error "no config file path candidate found."
- getSource ((msg,action): xs) =
- action >>= maybe (getSource xs) (return . (,) msg)
-
- (source, configFile) <- getSource sources
- minp <- readConfigFile mempty configFile
- case minp of
- Nothing -> do
- notice verbosity $ "Config file path source is " ++ source ++ "."
- notice verbosity $ "Config file " ++ configFile ++ " not found."
- notice verbosity $ "Writing default configuration to " ++ configFile
- commentConf <- commentSavedConfig
- initialConf <- initialSavedConfig
- writeConfigFile configFile commentConf initialConf
- return initialConf
- Just (ParseOk ws conf) -> do
- when (not $ null ws) $ warn verbosity $
- unlines (map (showPWarning configFile) ws)
- return conf
- Just (ParseFailed err) -> do
- let (line, msg) = locatedErrorMsg err
- warn verbosity $
- "Error parsing config file " ++ configFile
- ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg
- warn verbosity $ "Using default configuration."
- initialSavedConfig
-
- where
- addBaseConf body = do
- base <- baseSavedConfig
- extra <- body
- return (updateInstallDirs userInstallFlag (base `mappend` extra))
-
-readConfigFile :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig))
-readConfigFile initial file = handleNotExists $
- fmap (Just . parseConfig initial) (readFile file)
-
- where
- handleNotExists action = catch action $ \ioe ->
- if isDoesNotExistError ioe
- then return Nothing
- else ioError ioe
-
-writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO ()
-writeConfigFile file comments vals = do
- createDirectoryIfMissing True (takeDirectory file)
- writeFile file $ explanation ++ showConfigWithComments comments vals ++ "\n"
- where
- explanation = unlines
- ["-- This is the configuration file for the 'cabal' command line tool."
- ,""
- ,"-- The available configuration options are listed below."
- ,"-- Some of them have default values listed."
- ,""
- ,"-- Lines (like this one) beginning with '--' are comments."
- ,"-- Be careful with spaces and indentation because they are"
- ,"-- used to indicate layout for nested sections."
- ,"",""
- ]
-
--- | These are the default values that get used in Cabal if a no value is
--- given. We use these here to include in comments when we write out the
--- initial config file so that the user can see what default value they are
--- overriding.
---
-commentSavedConfig :: IO SavedConfig
-commentSavedConfig = do
- userInstallDirs <- defaultInstallDirs defaultCompiler True True
- globalInstallDirs <- defaultInstallDirs defaultCompiler False True
- return SavedConfig {
- savedGlobalFlags = commandDefaultFlags globalCommand,
- savedInstallFlags = defaultInstallFlags,
- savedConfigureExFlags = defaultConfigExFlags,
- savedConfigureFlags = (defaultConfigFlags defaultProgramConfiguration) {
- configUserInstall = toFlag defaultUserInstall
- },
- savedUserInstallDirs = fmap toFlag userInstallDirs,
- savedGlobalInstallDirs = fmap toFlag globalInstallDirs,
- savedUploadFlags = commandDefaultFlags uploadCommand,
- savedReportFlags = commandDefaultFlags reportCommand
- }
-
--- | All config file fields.
---
-configFieldDescriptions :: [FieldDescr SavedConfig]
-configFieldDescriptions =
-
- toSavedConfig liftGlobalFlag
- (commandOptions globalCommand ParseArgs)
- ["version", "numeric-version", "config-file"] []
-
- ++ toSavedConfig liftConfigFlag
- (configureOptions ParseArgs)
- (["builddir", "configure-option"] ++ map fieldName installDirsFields)
-
- --FIXME: this is only here because viewAsFieldDescr gives us a parser
- -- that only recognises 'ghc' etc, the case-sensitive flag names, not
- -- what the normal case-insensitive parser gives us.
- [simpleField "compiler"
- (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse)
- configHcFlavor (\v flags -> flags { configHcFlavor = v })
- ]
-
- ++ toSavedConfig liftConfigExFlag
- (configureExOptions ParseArgs)
- [] []
-
- ++ toSavedConfig liftInstallFlag
- (installOptions ParseArgs)
- ["dry-run", "reinstall", "only"] []
-
- ++ toSavedConfig liftUploadFlag
- (commandOptions uploadCommand ParseArgs)
- ["verbose", "check"] []
-
- ++ toSavedConfig liftReportFlag
- (commandOptions reportCommand ParseArgs)
- ["verbose", "username", "password"] []
- --FIXME: this is a hack, hiding the username and password.
- -- But otherwise it masks the upload ones. Either need to
- -- share the options or make then distinct. In any case
- -- they should probably be per-server.
-
- where
- toSavedConfig lift options exclusions replacements =
- [ lift (fromMaybe field replacement)
- | opt <- options
- , let field = viewAsFieldDescr opt
- name = fieldName field
- replacement = find ((== name) . fieldName) replacements
- , name `notElem` exclusions ]
- optional = Parse.option mempty . fmap toFlag
-
--- TODO: next step, make the deprecated fields elicit a warning.
---
-deprecatedFieldDescriptions :: [FieldDescr SavedConfig]
-deprecatedFieldDescriptions =
- [ liftGlobalFlag $
- listField "repos"
- (Disp.text . showRepo) parseRepo
- globalRemoteRepos (\rs cfg -> cfg { globalRemoteRepos = rs })
- , liftGlobalFlag $
- simpleField "cachedir"
- (Disp.text . fromFlagOrDefault "") (optional parseFilePathQ)
- globalCacheDir (\d cfg -> cfg { globalCacheDir = d })
- , liftUploadFlag $
- simpleField "hackage-username"
- (Disp.text . fromFlagOrDefault "" . fmap unUsername)
- (optional (fmap Username parseTokenQ))
- uploadUsername (\d cfg -> cfg { uploadUsername = d })
- , liftUploadFlag $
- simpleField "hackage-password"
- (Disp.text . fromFlagOrDefault "" . fmap unPassword)
- (optional (fmap Password parseTokenQ))
- uploadPassword (\d cfg -> cfg { uploadPassword = d })
- ]
- ++ map (modifyFieldName ("user-"++) . liftUserInstallDirs) installDirsFields
- ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) installDirsFields
- where
- optional = Parse.option mempty . fmap toFlag
- modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a
- modifyFieldName f d = d { fieldName = f (fieldName d) }
-
-liftUserInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate))
- -> FieldDescr SavedConfig
-liftUserInstallDirs = liftField
- savedUserInstallDirs (\flags conf -> conf { savedUserInstallDirs = flags })
-
-liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate))
- -> FieldDescr SavedConfig
-liftGlobalInstallDirs = liftField
- savedGlobalInstallDirs (\flags conf -> conf { savedGlobalInstallDirs = flags })
-
-liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig
-liftGlobalFlag = liftField
- savedGlobalFlags (\flags conf -> conf { savedGlobalFlags = flags })
-
-liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig
-liftConfigFlag = liftField
- savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags })
-
-liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig
-liftConfigExFlag = liftField
- savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = flags })
-
-liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig
-liftInstallFlag = liftField
- savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags })
-
-liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig
-liftUploadFlag = liftField
- savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags })
-
-liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig
-liftReportFlag = liftField
- savedReportFlags (\flags conf -> conf { savedReportFlags = flags })
-
-parseConfig :: SavedConfig -> String -> ParseResult SavedConfig
-parseConfig initial = \str -> do
- fields <- readFields str
- let (knownSections, others) = partition isKnownSection fields
- config <- parse others
- let user0 = savedUserInstallDirs config
- global0 = savedGlobalInstallDirs config
- (user, global) <- foldM parseSections (user0, global0) knownSections
- return config {
- savedUserInstallDirs = user,
- savedGlobalInstallDirs = global
- }
-
- where
- isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True
- isKnownSection _ = False
-
- parse = parseFields (configFieldDescriptions
- ++ deprecatedFieldDescriptions) initial
-
- parseSections accum@(u,g) (ParseUtils.Section _ "install-dirs" name fs)
- | name' == "user" = do u' <- parseFields installDirsFields u fs
- return (u', g)
- | name' == "global" = do g' <- parseFields installDirsFields g fs
- return (u, g')
- | otherwise = do
- warning "The install-paths section should be for 'user' or 'global'"
- return accum
- where name' = lowercase name
- parseSections accum f = do
- warning $ "Unrecognized stanza on line " ++ show (lineNo f)
- return accum
-
-showConfig :: SavedConfig -> String
-showConfig = showConfigWithComments mempty
-
-showConfigWithComments :: SavedConfig -> SavedConfig -> String
-showConfigWithComments comment vals = Disp.render $
- ppFields configFieldDescriptions comment vals
- $+$ Disp.text ""
- $+$ installDirsSection "user" savedUserInstallDirs
- $+$ Disp.text ""
- $+$ installDirsSection "global" savedGlobalInstallDirs
- where
- installDirsSection name field =
- ppSection "install-dirs" name installDirsFields
- (field comment) (field vals)
-
-------------------------
--- * Parsing utils
---
-
---FIXME: replace this with something better in Cabal-1.5
-parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a
-parseFields fields initial = foldM setField initial
- where
- fieldMap = Map.fromList
- [ (name, f) | f@(FieldDescr name _ _) <- fields ]
- setField accum (ParseUtils.F line name value) = case Map.lookup name fieldMap of
- Just (FieldDescr _ _ set) -> set line value accum
- Nothing -> do
- warning $ "Unrecognized field " ++ name ++ " on line " ++ show line
- return accum
- setField accum f = do
- warning $ "Unrecognized stanza on line " ++ show (lineNo f)
- return accum
-
--- | This is a customised version of the function from Cabal that also prints
--- default values for empty fields as comments.
---
-ppFields :: [FieldDescr a] -> a -> a -> Disp.Doc
-ppFields fields def cur = Disp.vcat [ ppField name (getter def) (getter cur)
- | FieldDescr name getter _ <- fields]
-
-ppField :: String -> Disp.Doc -> Disp.Doc -> Disp.Doc
-ppField name def cur
- | Disp.isEmpty cur = Disp.text "--" <+> Disp.text name <> Disp.colon <+> def
- | otherwise = Disp.text name <> Disp.colon <+> cur
-
-ppSection :: String -> String -> [FieldDescr a] -> a -> a -> Disp.Doc
-ppSection name arg fields def cur =
- Disp.text name <+> Disp.text arg
- $$ Disp.nest 2 (ppFields fields def cur)
-
-installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))]
-installDirsFields = map viewAsFieldDescr installDirsOptions
-
View
194 cabal/cabal-install/Distribution/Client/Configure.hs
@@ -1,194 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Client.Configure
--- Copyright : (c) David Himmelstrup 2005,
--- Duncan Coutts 2005
--- License : BSD-like
---
--- Maintainer : cabal-devel@haskell.org
--- Portability : portable
---
--- High level interface to configuring a package.
------------------------------------------------------------------------------
-module Distribution.Client.Configure (
- configure,
- ) where
-
-import Distribution.Client.Dependency
-import qualified Distribution.Client.InstallPlan as InstallPlan
-import Distribution.Client.InstallPlan (InstallPlan)
-import Distribution.Client.IndexUtils as IndexUtils
- ( getSourcePackages, getInstalledPackages )
-import Distribution.Client.Setup
- ( ConfigExFlags(..), configureCommand, filterConfigureFlags )
-import Distribution.Client.Types as Source
-import Distribution.Client.SetupWrapper
- ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )
-import Distribution.Client.Targets
- ( userToPackageConstraint )
-
-import Distribution.Simple.Compiler
- ( CompilerId(..), Compiler(compilerId)
- , PackageDB(..), PackageDBStack )
-import Distribution.Simple.Program (ProgramConfiguration )
-import Distribution.Simple.Setup
- ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault )
-import Distribution.Client.PackageIndex (PackageIndex)
-import Distribution.Simple.Utils
- ( defaultPackageDesc )
-import Distribution.Package
- ( Package(..), packageName, Dependency(..), thisPackageVersion )
-import Distribution.PackageDescription.Parse
- ( readPackageDescription )
-import Distribution.PackageDescription.Configuration
- ( finalizePackageDescription )
-import Distribution.Version
- ( anyVersion, thisVersion )
-import Distribution.Simple.Utils as Utils
- ( notice, info, debug, die )
-import Distribution.System
- ( Platform, buildPlatform )
-import Distribution.Verbosity as Verbosity
- ( Verbosity )
-
-import Data.Monoid (Monoid(..))
-
--- | Configure the package found in the local directory
-configure :: Verbosity
- -> PackageDBStack
- -> [Repo]
- -> Compiler
- -> ProgramConfiguration
- -> ConfigFlags
- -> ConfigExFlags
- -> [String]
- -> IO ()
-configure verbosity packageDBs repos comp conf
- configFlags configExFlags extraArgs = do
-
- installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
- sourcePkgDb <- getSourcePackages verbosity repos
-
- progress <- planLocalPackage verbosity comp configFlags configExFlags
- installedPkgIndex sourcePkgDb
-
- notice verbosity "Resolving dependencies..."
- maybePlan <- foldProgress logMsg (return . Left) (return . Right)
- progress
- case maybePlan of
- Left message -> do
- info verbosity message
- setupWrapper verbosity (setupScriptOptions installedPkgIndex) Nothing
- configureCommand (const configFlags) extraArgs
-
- Right installPlan -> case InstallPlan.ready installPlan of
- [pkg@(ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _)) _ _)] ->
- configurePackage verbosity
- (InstallPlan.planPlatform installPlan)
- (InstallPlan.planCompiler installPlan)
- (setupScriptOptions installedPkgIndex)
- configFlags pkg extraArgs
-
- _ -> die $ "internal error: configure install plan should have exactly "
- ++ "one local ready package."
-
- where
- setupScriptOptions index = SetupScriptOptions {
- useCabalVersion = maybe anyVersion thisVersion
- (flagToMaybe (configCabalVersion configExFlags)),
- useCompiler = Just comp,
- -- Hack: we typically want to allow the UserPackageDB for finding the
- -- Cabal lib when compiling any Setup.hs even if we're doing a global
- -- install. However we also allow looking in a specific package db.
- usePackageDB = if UserPackageDB `elem` packageDBs
- then packageDBs
- else packageDBs ++ [UserPackageDB],
- usePackageIndex = if UserPackageDB `elem` packageDBs
- then Just index
- else Nothing,
- useProgramConfig = conf,
- useDistPref = fromFlagOrDefault
- (useDistPref defaultSetupScriptOptions)
- (configDistPref configFlags),
- useLoggingHandle = Nothing,
- useWorkingDir = Nothing
- }
-
- logMsg message rest = debug verbosity message >> rest
-
--- | Make an 'InstallPlan' for the unpacked package in the current directory,
--- and all its dependencies.
---
-planLocalPackage :: Verbosity -> Compiler
- -> ConfigFlags -> ConfigExFlags
- -> PackageIndex InstalledPackage
- -> SourcePackageDb
- -> IO (Progress String String InstallPlan)
-planLocalPackage verbosity comp configFlags configExFlags installedPkgIndex
- (SourcePackageDb _ packagePrefs) = do
- pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity
-
- let -- We create a local package and ask to resolve a dependency on it
- localPkg = SourcePackage {
- packageInfoId = packageId pkg,
- Source.packageDescription = pkg,
- packageSource = LocalUnpackedPackage "."
- }
-
- resolverParams =
-
- addPreferences
- -- preferences from the config file or command line
- [ PackageVersionPreference name ver
- | Dependency name ver <- configPreferences configExFlags ]
-
- . addConstraints
- -- version constraints from the config file or command line
- -- TODO: should warn or error on constraints that are not on direct deps
- -- or flag constraints not on the package in question.
- (map userToPackageConstraint (configExConstraints configExFlags))
-
- . addConstraints
- -- package flags from the config file or command line
- [ PackageConstraintFlags (packageName pkg)
- (configConfigurationsFlags configFlags) ]
-
- $ standardInstallPolicy
- installedPkgIndex
- (SourcePackageDb mempty packagePrefs)
- [SpecificSourcePackage localPkg]
-
- return (resolveDependencies buildPlatform (compilerId comp) resolverParams)
-
-
--- | Call an installer for an 'SourcePackage' but override the configure
--- flags with the ones given by the 'ConfiguredPackage'. In particular the
--- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly
--- versioned package dependencies. So we ignore any previous partial flag
--- assignment or dependency constraints and use the new ones.
---
-configurePackage :: Verbosity
- -> Platform -> CompilerId
- -> SetupScriptOptions
- -> ConfigFlags
- -> ConfiguredPackage
- -> [String]
- -> IO ()
-configurePackage verbosity platform comp scriptOptions configFlags
- (ConfiguredPackage (SourcePackage _ gpkg _) flags deps) extraArgs =
-
- setupWrapper verbosity
- scriptOptions (Just pkg) configureCommand configureFlags extraArgs
-
- where
- configureFlags = filterConfigureFlags configFlags {
- configConfigurationsFlags = flags,
- configConstraints = map thisPackageVersion deps,
- configVerbosity = toFlag verbosity
- }
-
- pkg = case finalizePackageDescription flags
- (const True)
- platform comp [] gpkg of
- Left _ -> error "finalizePackageDescription ConfiguredPackage failed"
- Right (desc, _) -> desc
View
449 cabal/cabal-install/Distribution/Client/Dependency.hs
@@ -1,449 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Client.Dependency
--- Copyright : (c) David Himmelstrup 2005,
--- Bjorn Bringert 2007
--- Duncan Coutts 2008
--- License : BSD-like
---
--- Maintainer : cabal-devel@gmail.com
--- Stability : provisional
--- Portability : portable
---
--- Top level interface to dependency resolution.
------------------------------------------------------------------------------
-module Distribution.Client.Dependency (
- -- * The main package dependency resolver
- resolveDependencies,
- Progress(..),
- foldProgress,
-
- -- * Alternate, simple resolver that does not do dependencies recursively
- resolveWithoutDependencies,
-
- -- * Constructing resolver policies
- DepResolverParams(..),
- PackageConstraint(..),
- PackagesPreferenceDefault(..),
- PackagePreference(..),
- InstalledPreference(..),
-
- -- ** Standard policy
- standardInstallPolicy,
- PackageSpecifier(..),
-
- -- ** Extra policy options
- dontUpgradeBasePackage,
- hideBrokenInstalledPackages,
- upgradeDependencies,
- reinstallTargets,
-
- -- ** Policy utils
- addConstraints,
- addPreferences,
- setPreferenceDefault,
- addSourcePackages,
- hideInstalledPackagesSpecific,
- hideInstalledPackagesAllVersions,
- ) where
-
-import Distribution.Client.Dependency.TopDown (topDownResolver)
-import qualified Distribution.Client.PackageIndex as PackageIndex
-import Distribution.Client.PackageIndex (PackageIndex)
-import qualified Distribution.Client.InstallPlan as InstallPlan
-import Distribution.Client.InstallPlan (InstallPlan)
-import Distribution.Client.Types
- ( SourcePackageDb(SourcePackageDb)
- , SourcePackage(..), InstalledPackage )
-import Distribution.Client.Dependency.Types
- ( DependencyResolver, PackageConstraint(..)
- , PackagePreferences(..), InstalledPreference(..)
- , Progress(..), foldProgress )
-import Distribution.Client.Targets
-import Distribution.Package
- ( PackageName(..), PackageId, Package(..), packageVersion
- , Dependency(Dependency))
-import Distribution.Version
- ( VersionRange, anyVersion, withinRange, simplifyVersionRange )
-import Distribution.Compiler
- ( CompilerId(..) )
-import Distribution.System
- ( Platform )
-import Distribution.Simple.Utils (comparing)
-import Distribution.Text
- ( display )
-
-import Data.List (maximumBy, foldl')
-import Data.Maybe (fromMaybe, isJust)
-import qualified Data.Map as Map
-import qualified Data.Set as Set
-import Data.Set (Set)
-
-
--- ------------------------------------------------------------
--- * High level planner policy
--- ------------------------------------------------------------
-
--- | The set of parameters to the dependency resolver. These parameters are
--- relatively low level but many kinds of high level policies can be
--- implemented in terms of adjustments to the parameters.
---
-data DepResolverParams = DepResolverParams {
- depResolverTargets :: [PackageName],
- depResolverConstraints :: [PackageConstraint],
- depResolverPreferences :: [PackagePreference],
- depResolverPreferenceDefault :: PackagesPreferenceDefault,
- depResolverInstalledPkgIndex :: PackageIndex InstalledPackage,
- depResolverSourcePkgIndex :: PackageIndex SourcePackage
- }
-
-
--- | Global policy for all packages to say if we prefer package versions that
--- are already installed locally or if we just prefer the latest available.
---
-data PackagesPreferenceDefault =
-
- -- | Always prefer the latest version irrespective of any existing
- -- installed version.
- --
- -- * This is the standard policy for upgrade.
- --
- PreferAllLatest
-
- -- | Always prefer the installed versions over ones that would need to be
- -- installed. Secondarily, prefer latest versions (eg the latest installed
- -- version or if there are none then the latest source version).
- | PreferAllInstalled
-
- -- | Prefer the latest version for packages that are explicitly requested
- -- but prefers the installed version for any other packages.
- --
- -- * This is the standard policy for install.
- --
- | PreferLatestForSelected
-
-
--- | A package selection preference for a particular package.
---
--- Preferences are soft constraints that the dependency resolver should try to
--- respect where possible. It is not specified if preferences on some packages
--- are more important than others.
---
-data PackagePreference =
-
- -- | A suggested constraint on the version number.
- PackageVersionPreference PackageName VersionRange
-
- -- | If we prefer versions of packages that are already installed.
- | PackageInstalledPreference PackageName InstalledPreference
-
-basicDepResolverParams :: PackageIndex InstalledPackage
- -> PackageIndex SourcePackage
- -> DepResolverParams
-basicDepResolverParams installedPkgIndex sourcePkgIndex =
- DepResolverParams {
- depResolverTargets = [],
- depResolverConstraints = [],
- depResolverPreferences = [],
- depResolverPreferenceDefault = PreferLatestForSelected,
- depResolverInstalledPkgIndex = installedPkgIndex,
- depResolverSourcePkgIndex = sourcePkgIndex
- }
-
-addTargets :: [PackageName]
- -> DepResolverParams -> DepResolverParams
-addTargets extraTargets params =
- params {
- depResolverTargets = extraTargets ++ depResolverTargets params
- }
-
-addConstraints :: [PackageConstraint]
- -> DepResolverParams -> DepResolverParams
-addConstraints extraConstraints params =
- params {
- depResolverConstraints = extraConstraints
- ++ depResolverConstraints params
- }
-
-addPreferences :: [PackagePreference]
- -> DepResolverParams -> DepResolverParams
-addPreferences extraPreferences params =
- params {
- depResolverPreferences = extraPreferences
- ++ depResolverPreferences params
- }
-
-setPreferenceDefault :: PackagesPreferenceDefault
- -> DepResolverParams -> DepResolverParams
-setPreferenceDefault preferenceDefault params =
- params {
- depResolverPreferenceDefault = preferenceDefault
- }
-
-dontUpgradeBasePackage :: DepResolverParams -> DepResolverParams
-dontUpgradeBasePackage params =
- addConstraints extraConstraints params
- where
- extraConstraints =
- [ PackageConstraintInstalled pkgname
- | all (/=PackageName "base") (depResolverTargets params)
- , pkgname <- [ PackageName "base", PackageName "ghc-prim" ]
- , isInstalled pkgname ]
- -- TODO: the top down resolver chokes on the base constraints
- -- below when there are no targets and thus no dep on base.
- -- Need to refactor contraints separate from needing packages.
- isInstalled = not . null
- . PackageIndex.lookupPackageName
- (depResolverInstalledPkgIndex params)
-
-addSourcePackages :: [SourcePackage]
- -> DepResolverParams -> DepResolverParams
-addSourcePackages pkgs params =
- params {
- depResolverSourcePkgIndex =
- foldl (flip PackageIndex.insert)
- (depResolverSourcePkgIndex params) pkgs
- }
-
-hideInstalledPackagesSpecific :: [PackageId]
- -> DepResolverParams -> DepResolverParams
-hideInstalledPackagesSpecific pkgids params =
- --TODO: this should work using exclude constraints instead
- params {
- depResolverInstalledPkgIndex =
- foldl' (flip PackageIndex.deletePackageId)
- (depResolverInstalledPkgIndex params) pkgids
- }
-
-hideInstalledPackagesAllVersions :: [PackageName]
- -> DepResolverParams -> DepResolverParams
-hideInstalledPackagesAllVersions pkgnames params =
- --TODO: this should work using exclude constraints instead
- params {
- depResolverInstalledPkgIndex =
- foldl' (flip PackageIndex.deletePackageName)
- (depResolverInstalledPkgIndex params) pkgnames
- }
-
-
-hideBrokenInstalledPackages :: DepResolverParams -> DepResolverParams
-hideBrokenInstalledPackages params =
- hideInstalledPackagesSpecific pkgids params
- where
- pkgids = map packageId
- . PackageIndex.reverseDependencyClosure
- (depResolverInstalledPkgIndex params)
- . map (packageId . fst)
- . PackageIndex.brokenPackages
- $ depResolverInstalledPkgIndex params
-
-
-upgradeDependencies :: DepResolverParams -> DepResolverParams
-upgradeDependencies = setPreferenceDefault PreferAllLatest
-
-
-reinstallTargets :: DepResolverParams -> DepResolverParams
-reinstallTargets params =
- hideInstalledPackagesAllVersions (depResolverTargets params) params
-
-
-standardInstallPolicy :: PackageIndex InstalledPackage
- -> SourcePackageDb
- -> [PackageSpecifier SourcePackage]
- -> DepResolverParams
-standardInstallPolicy
- installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs)
- pkgSpecifiers
-
- = addPreferences
- [ PackageVersionPreference name ver
- | (name, ver) <- Map.toList sourcePkgPrefs ]
-
- . addConstraints
- (concatMap pkgSpecifierConstraints pkgSpecifiers)
-
- . addTargets
- (map pkgSpecifierTarget pkgSpecifiers)
-
- . hideInstalledPackagesSpecific
- [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]
-
- . addSourcePackages
- [ pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]
-
- $ basicDepResolverParams
- installedPkgIndex sourcePkgIndex
-
-
--- ------------------------------------------------------------
--- * Interface to the standard resolver
--- ------------------------------------------------------------
-
-defaultResolver :: DependencyResolver
-defaultResolver = topDownResolver
-
--- | Run the dependency solver.
---
--- Since this is potentially an expensive operation, the result is wrapped in a
--- a 'Progress' structure that can be unfolded to provide progress information,
--- logging messages and the final result or an error.
---
-resolveDependencies :: Platform
- -> CompilerId
- -> DepResolverParams
- -> Progress String String InstallPlan
-
- --TODO: is this needed here? see dontUpgradeBasePackage
-resolveDependencies platform comp params
- | null (depResolverTargets params)
- = return (mkInstallPlan platform comp [])
-
-resolveDependencies platform comp params =
-
- fmap (mkInstallPlan platform comp)
- $ defaultResolver platform comp installedPkgIndex sourcePkgIndex
- preferences constraints targets
- where
- DepResolverParams
- targets constraints
- prefs defpref
- installedPkgIndex
- sourcePkgIndex = dontUpgradeBasePackage
- . hideBrokenInstalledPackages
- $ params
-
- preferences = interpretPackagesPreference
- (Set.fromList targets) defpref prefs
-
-
--- | Make an install plan from the output of the dep resolver.
--- It checks that the plan is valid, or it's an error in the dep resolver.
---
-mkInstallPlan :: Platform
- -> CompilerId
- -> [InstallPlan.PlanPackage] -> InstallPlan
-mkInstallPlan platform comp pkgIndex =
- case InstallPlan.new platform comp (PackageIndex.fromList pkgIndex) of
- Right plan -> plan
- Left problems -> error $ unlines $
- "internal error: could not construct a valid install plan."
- : "The proposed (invalid) plan contained the following problems:"
- : map InstallPlan.showPlanProblem problems
-
-
--- | Give an interpretation to the global 'PackagesPreference' as
--- specific per-package 'PackageVersionPreference'.
---
-interpretPackagesPreference :: Set PackageName
- -> PackagesPreferenceDefault
- -> [PackagePreference]
- -> (PackageName -> PackagePreferences)
-interpretPackagesPreference selected defaultPref prefs =
- \pkgname -> PackagePreferences (versionPref pkgname) (installPref pkgname)
-
- where
- versionPref pkgname =
- fromMaybe anyVersion (Map.lookup pkgname versionPrefs)
- versionPrefs = Map.fromList
- [ (pkgname, pref)
- | PackageVersionPreference pkgname pref <- prefs ]
-
- installPref pkgname =
- fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs)
- installPrefs = Map.fromList
- [ (pkgname, pref)
- | PackageInstalledPreference pkgname pref <- prefs ]
- installPrefDefault = case defaultPref of
- PreferAllLatest -> \_ -> PreferLatest
- PreferAllInstalled -> \_ -> PreferInstalled
- PreferLatestForSelected -> \pkgname ->
- -- When you say cabal install foo, what you really mean is, prefer the
- -- latest version of foo, but the installed version of everything else
- if pkgname `Set.member` selected then PreferLatest
- else PreferInstalled
-
--- ------------------------------------------------------------
--- * Simple resolver that ignores dependencies
--- ------------------------------------------------------------
-
--- | A simplistic method of resolving a list of target package names to
--- available packages.
---
--- Specifically, it does not consider package dependencies at all. Unlike
--- 'resolveDependencies', no attempt is made to ensure that the selected
--- packages have dependencies that are satisfiable or consistent with
--- each other.
---
--- It is suitable for tasks such as selecting packages to download for user
--- inspection. It is not suitable for selecting packages to install.
---
--- Note: if no installed package index is available, it is ok to pass 'mempty'.
--- It simply means preferences for installed packages will be ignored.
---
-resolveWithoutDependencies :: DepResolverParams
- -> Either [ResolveNoDepsError] [SourcePackage]
-resolveWithoutDependencies (DepResolverParams targets constraints
- prefs defpref installedPkgIndex sourcePkgIndex) =
- collectEithers (map selectPackage targets)
- where
- selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage
- selectPackage pkgname
- | null choices = Left $! ResolveUnsatisfiable pkgname requiredVersions
- | otherwise = Right $! maximumBy bestByPrefs choices
-
- where
- -- Constraints
- requiredVersions = packageConstraints pkgname
- pkgDependency = Dependency pkgname requiredVersions
- choices = PackageIndex.lookupDependency sourcePkgIndex
- pkgDependency
-
- -- Preferences
- PackagePreferences preferredVersions preferInstalled
- = packagePreferences pkgname
-
- bestByPrefs = comparing $ \pkg ->
- (installPref pkg, versionPref pkg, packageVersion pkg)
- installPref = case preferInstalled of
- PreferLatest -> const False
- PreferInstalled -> isJust . PackageIndex.lookupPackageId
- installedPkgIndex
- . packageId
- versionPref pkg = packageVersion pkg `withinRange` preferredVersions
-
- packageConstraints :: PackageName -> VersionRange
- packageConstraints pkgname =
- Map.findWithDefault anyVersion pkgname packageVersionConstraintMap
- packageVersionConstraintMap =
- Map.fromList [ (name, range)
- | PackageConstraintVersion name range <- constraints ]
-
- packagePreferences :: PackageName -> PackagePreferences
- packagePreferences = interpretPackagesPreference
- (Set.fromList targets) defpref prefs
-
-
-collectEithers :: [Either a b] -> Either [a] [b]
-collectEithers = collect . partitionEithers
- where
- collect ([], xs) = Right xs
- collect (errs,_) = Left errs
- partitionEithers :: [Either a b] -> ([a],[b])
- partitionEithers = foldr (either left right) ([],[])
- where
- left a (l, r) = (a:l, r)
- right a (l, r) = (l, a:r)
-
--- | Errors for 'resolveWithoutDependencies'.
---
-data ResolveNoDepsError =
-
- -- | A package name which cannot be resolved to a specific package.
- -- Also gives the constraint on the version and whether there was
- -- a constraint on the package being installed.
- ResolveUnsatisfiable PackageName VersionRange
-
-instance Show ResolveNoDepsError where
- show (ResolveUnsatisfiable name ver) =
- "There is no available version of " ++ display name
- ++ " that satisfies " ++ display (simplifyVersionRange ver)
View
928 cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs
@@ -1,928 +0,0 @@
------------------------------------------------------------------------------
--- |
--- Module : Distribution.Client.Dependency.Types
--- Copyright : (c) Duncan Coutts 2008
--- License : BSD-like
---
--- Maintainer : cabal-devel@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Common types for dependency resolution.
------------------------------------------------------------------------------
-module Distribution.Client.Dependency.TopDown (
- topDownResolver
- ) where
-
-import Distribution.Client.Dependency.TopDown.Types
-import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints
-import Distribution.Client.Dependency.TopDown.Constraints
- ( Satisfiable(..) )
-import qualified Distribution.Client.InstallPlan as InstallPlan
-import Distribution.Client.InstallPlan
- ( PlanPackage(..) )
-import Distribution.Client.Types
- ( SourcePackage(..), ConfiguredPackage(..), InstalledPackage(..) )
-import Distribution.Client.Dependency.Types
- ( DependencyResolver, PackageConstraint(..)
- , PackagePreferences(..), InstalledPreference(..)
- , Progress(..), foldProgress )
-
-import qualified Distribution.Client.PackageIndex as PackageIndex
-import Distribution.Client.PackageIndex (PackageIndex)
-import Distribution.Package
- ( PackageName(..), PackageId, Package(..), packageVersion, packageName
- , Dependency(Dependency), thisPackageVersion
- , simplifyDependency, PackageFixedDeps(depends) )
-import Distribution.PackageDescription
- ( PackageDescription(buildDepends) )
-import Distribution.Client.PackageUtils
- ( externalBuildDepends )
-import Distribution.PackageDescription.Configuration
- ( finalizePackageDescription, flattenPackageDescription )
-import Distribution.Version
- ( VersionRange, withinRange, simplifyVersionRange
- , UpperBound(..), asVersionIntervals )
-import Distribution.Compiler
- ( CompilerId )
-import Distribution.System
- ( Platform )
-import Distribution.Simple.Utils
- ( equating, comparing )
-import Distribution.Text
- ( display )
-
-import Data.List
- ( foldl', maximumBy, minimumBy, nub, sort, sortBy, groupBy )
-import Data.Maybe
- ( fromJust, fromMaybe, catMaybes )
-import Data.Monoid
- ( Monoid(mempty) )
-import Control.Monad
- ( guard )
-import qualified Data.Set as Set
-import Data.Set (Set)
-import qualified Data.Map as Map
-import qualified Data.Graph as Graph
-import qualified Data.Array as Array
-import Control.Exception
- ( assert )
-
--- ------------------------------------------------------------
--- * Search state types
--- ------------------------------------------------------------
-
-type Constraints = Constraints.Constraints
- InstalledPackageEx UnconfiguredPackage ExclusionReason
-type SelectedPackages = PackageIndex SelectedPackage
-
--- ------------------------------------------------------------
--- * The search tree type
--- ------------------------------------------------------------
-
-data SearchSpace inherited pkg
- = ChoiceNode inherited [[(pkg, SearchSpace inherited pkg)]]
- | Failure Failure
-
--- ------------------------------------------------------------
--- * Traverse a search tree
--- ------------------------------------------------------------
-
-explore :: (PackageName -> PackagePreferences)
- -> SearchSpace (SelectedPackages, Constraints, SelectionChanges)
- SelectablePackage
- -> Progress Log Failure (SelectedPackages, Constraints)
-
-explore _ (Failure failure) = Fail failure
-explore _ (ChoiceNode (s,c,_) []) = Done (s,c)
-explore pref (ChoiceNode _ choices) =
- case [ choice | [choice] <- choices ] of
- ((_, node'):_) -> Step (logInfo node') (explore pref node')
- [] -> Step (logInfo node') (explore pref node')
- where
- choice = minimumBy (comparing topSortNumber) choices
- pkgname = packageName . fst . head $ choice
- (_, node') = maximumBy (bestByPref pkgname) choice
- where
- topSortNumber choice = case fst (head choice) of
- InstalledOnly (InstalledPackageEx _ i _) -> i
- SourceOnly (UnconfiguredPackage _ i _) -> i
- InstalledAndSource _ (UnconfiguredPackage _ i _) -> i
-
- bestByPref pkgname = case packageInstalledPreference of
- PreferLatest ->
- comparing (\(p,_) -> ( isPreferred p, packageId p))
- PreferInstalled ->
- comparing (\(p,_) -> (isInstalled p, isPreferred p, packageId p))
- where
- isInstalled (SourceOnly _) = False
- isInstalled _ = True
- isPreferred p = packageVersion p `withinRange` preferredVersions
- (PackagePreferences preferredVersions packageInstalledPreference)
- = pref pkgname
-
- logInfo node = Select selected discarded
- where (selected, discarded) = case node of
- Failure _ -> ([], [])
- ChoiceNode (_,_,changes) _ -> changes
-
--- ------------------------------------------------------------
--- * Generate a search tree
--- ------------------------------------------------------------
-
-type ConfigurePackage = PackageIndex SelectablePackage
- -> SelectablePackage
- -> Either [Dependency] SelectedPackage
-
--- | (packages selected, packages discarded)
-type SelectionChanges = ([SelectedPackage], [PackageId])
-
-searchSpace :: ConfigurePackage
- -> Constraints
- -> SelectedPackages
- -> SelectionChanges
- -> Set PackageName
- -> SearchSpace (SelectedPackages, Constraints, SelectionChanges)
- SelectablePackage
-searchSpace configure constraints selected changes next =
- assert (Set.null (selectedSet `Set.intersection` next)) $
- assert (selectedSet `Set.isSubsetOf` Constraints.packages constraints) $
- assert (next `Set.isSubsetOf` Constraints.packages constraints) $
-
- ChoiceNode (selected, constraints, changes)
- [ [ (pkg, select name pkg)
- | pkg <- PackageIndex.lookupPackageName available name ]
- | name <- Set.elems next ]
- where
- available = Constraints.choices constraints
-
- selectedSet = Set.fromList (map packageName (PackageIndex.allPackages selected))
-
- select name pkg = case configure available pkg of
- Left missing -> Failure $ ConfigureFailed pkg
- [ (dep, Constraints.conflicting constraints dep)
- | dep <- missing ]
- Right pkg' ->
- case constrainDeps pkg' newDeps (addDeps constraints newPkgs) [] of
- Left failure -> Failure failure
- Right (constraints', newDiscarded) ->
- searchSpace configure
- constraints' selected' (newSelected, newDiscarded) next'
- where
- selected' = foldl' (flip PackageIndex.insert) selected newSelected
- newSelected =
- case Constraints.isPaired constraints (packageId pkg) of
- Nothing -> [pkg']
- Just pkgid' -> [pkg', pkg'']
- where
- Just pkg'' = fmap (\(InstalledOnly p) -> InstalledOnly p)
- (PackageIndex.lookupPackageId available pkgid')
-
- newPkgs = [ name'
- | (Dependency name' _, _) <- newDeps
- , null (PackageIndex.lookupPackageName selected' name') ]
- newDeps = concatMap packageConstraints newSelected
- next' = Set.delete name
- $ foldl' (flip Set.insert) next newPkgs
-
-packageConstraints :: SelectedPackage -> [(Dependency, Bool)]
-packageConstraints = either installedConstraints availableConstraints
- . preferSource
- where
- preferSource (InstalledOnly pkg) = Left pkg
- preferSource (SourceOnly pkg) = Right pkg
- preferSource (InstalledAndSource _ pkg) = Right pkg
- installedConstraints (InstalledPackageEx _ _ deps) =
- [ (thisPackageVersion dep, True)
- | dep <- deps ]
- availableConstraints (SemiConfiguredPackage _ _ deps) =
- [ (dep, False) | dep <- deps ]
-
-addDeps :: Constraints -> [PackageName] -> Constraints
-addDeps =
- foldr $ \pkgname cs ->
- case Constraints.addTarget pkgname cs of
- Satisfiable cs' () -> cs'
- _ -> impossible "addDeps unsatisfiable"
-
-constrainDeps :: SelectedPackage -> [(Dependency, Bool)] -> Constraints
- -> [PackageId]
- -> Either Failure (Constraints, [PackageId])
-constrainDeps pkg [] cs discard =
- case addPackageSelectConstraint (packageId pkg) cs of
- Satisfiable cs' discard' -> Right (cs', discard' ++ discard)
- _ -> impossible "constrainDeps unsatisfiable(1)"
-constrainDeps pkg ((dep, installedConstraint):deps) cs discard =
- case addPackageDependencyConstraint (packageId pkg) dep installedConstraint cs of
- Satisfiable cs' discard' -> constrainDeps pkg deps cs' (discard' ++ discard)
- Unsatisfiable -> impossible "constrainDeps unsatisfiable(2)"
- ConflictsWith conflicts ->
- Left (DependencyConflict pkg dep installedConstraint conflicts)
-
--- ------------------------------------------------------------
--- * The main algorithm
--- ------------------------------------------------------------
-
-search :: ConfigurePackage
- -> (PackageName -> PackagePreferences)
- -> Constraints
- -> Set PackageName
- -> Progress Log Failure (SelectedPackages, Constraints)
-search configure pref constraints =
- explore pref . searchSpace configure constraints mempty ([], [])
-
--- ------------------------------------------------------------
--- * The top level resolver
--- ------------------------------------------------------------
-
--- | The main exported resolver, with string logging and failure types to fit
--- the standard 'DependencyResolver' interface.
---
-topDownResolver :: DependencyResolver
-topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver'
- where
- mapMessages :: Progress Log Failure a -> Progress String String a
- mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done
-
--- | The native resolver with detailed structured logging and failure types.
---
-topDownResolver' :: Platform -> CompilerId
- -> PackageIndex InstalledPackage
- -> PackageIndex SourcePackage
- -> (PackageName -> PackagePreferences)
- -> [PackageConstraint]
- -> [PackageName]
- -> Progress Log Failure [PlanPackage]
-topDownResolver' platform comp installedPkgIndex sourcePkgIndex
- preferences constraints targets =
- fmap (uncurry finalise)
- . (\cs -> search configure preferences cs initialPkgNames)
- =<< pruneBottomUp platform comp
- =<< addTopLevelConstraints constraints
- =<< addTopLevelTargets targets emptyConstraintSet
-
- where
- configure = configurePackage platform comp
- emptyConstraintSet :: Constraints
- emptyConstraintSet = Constraints.empty
- (annotateInstalledPackages topSortNumber installedPkgIndex')
- (annotateSourcePackages constraints topSortNumber sourcePkgIndex')
- (installedPkgIndex', sourcePkgIndex') =
- selectNeededSubset installedPkgIndex sourcePkgIndex initialPkgNames
- topSortNumber = topologicalSortNumbering installedPkgIndex' sourcePkgIndex'
-
- initialPkgNames = Set.fromList targets
-
- finalise selected' constraints' =
- PackageIndex.allPackages
- . fst . improvePlan installedPkgIndex' constraints'
- . PackageIndex.fromList
- $ finaliseSelectedPackages preferences selected' constraints'
-
-
-addTopLevelTargets :: [PackageName]
- -> Constraints
- -> Progress a Failure Constraints
-addTopLevelTargets [] cs = Done cs
-addTopLevelTargets (pkg:pkgs) cs =
- case Constraints.addTarget pkg cs of
- Satisfiable cs' () -> addTopLevelTargets pkgs cs'
- Unsatisfiable -> Fail (NoSuchPackage pkg)