summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergeiTrofimovich <>2013-11-27 22:24:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2013-11-27 22:24:00 (GMT)
commitba7011e86691e488773552a8d6b17cb5b168683d (patch)
tree6884e734d6101a5be506932eb6de554101466ccb
parente0e48a6868e174487c70907bbb905aec2c8ce687 (diff)
version 0.3.50.3.5
-rw-r--r--.gitignore1
-rw-r--r--AnsiColor.hs63
-rw-r--r--BlingBling.hs52
-rw-r--r--Cabal2Ebuild.hs107
-rw-r--r--CacheFile.hs12
-rw-r--r--Diff.hs188
-rw-r--r--DistroMap.hs158
-rw-r--r--Error.hs63
-rw-r--r--Hackage.hs32
-rw-r--r--LICENSE674
-rw-r--r--Main-GuessGHC.hs27
-rw-r--r--Main.hs558
-rw-r--r--Merge.hs490
-rw-r--r--Merge/Dependencies.hs476
-rw-r--r--Overlays.hs71
-rw-r--r--Portage/Cabal.hs36
-rw-r--r--Portage/Dependency.hs119
-rw-r--r--Portage/Dependency/Builder.hs25
-rw-r--r--Portage/Dependency/Normalize.hs261
-rw-r--r--Portage/Dependency/Print.hs87
-rw-r--r--Portage/Dependency/Types.hs96
-rw-r--r--Portage/EBuild.hs214
-rw-r--r--Portage/GHCCore.hs425
-rw-r--r--Portage/Host.hs124
-rw-r--r--Portage/Metadata.hs55
-rw-r--r--Portage/Overlay.hs186
-rw-r--r--Portage/PackageId.hs126
-rw-r--r--Portage/Resolve.hs75
-rw-r--r--Portage/Use.hs59
-rw-r--r--Portage/Version.hs101
-rw-r--r--Progress.hs62
-rw-r--r--README.rst133
-rw-r--r--Setup.hs7
-rw-r--r--Status.hs243
-rw-r--r--TODO28
-rw-r--r--Util.hs31
-rw-r--r--cabal/Cabal/Cabal.cabal193
-rw-r--r--cabal/Cabal/DefaultSetup.hs2
-rw-r--r--cabal/Cabal/Distribution/Compat/CopyFile.hs115
-rw-r--r--cabal/Cabal/Distribution/Compat/Exception.hs61
-rw-r--r--cabal/Cabal/Distribution/Compat/ReadP.hs381
-rw-r--r--cabal/Cabal/Distribution/Compat/TempFile.hs204
-rw-r--r--cabal/Cabal/Distribution/Compiler.hs158
-rw-r--r--cabal/Cabal/Distribution/GetOpt.hs335
-rw-r--r--cabal/Cabal/Distribution/InstalledPackageInfo.hs294
-rw-r--r--cabal/Cabal/Distribution/License.hs146
-rw-r--r--cabal/Cabal/Distribution/Make.hs213
-rw-r--r--cabal/Cabal/Distribution/ModuleName.hs130
-rw-r--r--cabal/Cabal/Distribution/Package.hs202
-rw-r--r--cabal/Cabal/Distribution/PackageDescription.hs1034
-rw-r--r--cabal/Cabal/Distribution/PackageDescription/Check.hs1495
-rw-r--r--cabal/Cabal/Distribution/PackageDescription/Configuration.hs652
-rw-r--r--cabal/Cabal/Distribution/PackageDescription/Parse.hs1205
-rw-r--r--cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs238
-rw-r--r--cabal/Cabal/Distribution/ParseUtils.hs715
-rw-r--r--cabal/Cabal/Distribution/ReadE.hs81
-rw-r--r--cabal/Cabal/Distribution/Simple.hs703
-rw-r--r--cabal/Cabal/Distribution/Simple/Bench.hs156
-rw-r--r--cabal/Cabal/Distribution/Simple/Build.hs349
-rw-r--r--cabal/Cabal/Distribution/Simple/Build/Macros.hs57
-rw-r--r--cabal/Cabal/Distribution/Simple/Build/PathsModule.hs262
-rw-r--r--cabal/Cabal/Distribution/Simple/BuildPaths.hs150
-rw-r--r--cabal/Cabal/Distribution/Simple/Command.hs555
-rw-r--r--cabal/Cabal/Distribution/Simple/Compiler.hs194
-rw-r--r--cabal/Cabal/Distribution/Simple/Configure.hs1083
-rw-r--r--cabal/Cabal/Distribution/Simple/GHC.hs1127
-rw-r--r--cabal/Cabal/Distribution/Simple/GHC/IPI641.hs129
-rw-r--r--cabal/Cabal/Distribution/Simple/GHC/IPI642.hs164
-rw-r--r--cabal/Cabal/Distribution/Simple/Haddock.hs653
-rw-r--r--cabal/Cabal/Distribution/Simple/Hpc.hs170
-rw-r--r--cabal/Cabal/Distribution/Simple/Hugs.hs634
-rw-r--r--cabal/Cabal/Distribution/Simple/Install.hs214
-rw-r--r--cabal/Cabal/Distribution/Simple/InstallDirs.hs604
-rw-r--r--cabal/Cabal/Distribution/Simple/JHC.hs222
-rw-r--r--cabal/Cabal/Distribution/Simple/LHC.hs820
-rw-r--r--cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs337
-rw-r--r--cabal/Cabal/Distribution/Simple/NHC.hs424
-rw-r--r--cabal/Cabal/Distribution/Simple/PackageIndex.hs574
-rw-r--r--cabal/Cabal/Distribution/Simple/PreProcess.hs608
-rw-r--r--cabal/Cabal/Distribution/Simple/PreProcess/Unlit.hs165
-rw-r--r--cabal/Cabal/Distribution/Simple/Program.hs218
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Ar.hs70
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Builtin.hs269
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Db.hs409
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/GHC.hs458
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/HcPkg.hs365
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Hpc.hs73
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Ld.hs62
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Run.hs218
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Script.hs105
-rw-r--r--cabal/Cabal/Distribution/Simple/Program/Types.hs130
-rw-r--r--cabal/Cabal/Distribution/Simple/Register.hs404
-rw-r--r--cabal/Cabal/Distribution/Simple/Setup.hs1680
-rw-r--r--cabal/Cabal/Distribution/Simple/SrcDist.hs441
-rw-r--r--cabal/Cabal/Distribution/Simple/Test.hs544
-rw-r--r--cabal/Cabal/Distribution/Simple/UHC.hs300
-rw-r--r--cabal/Cabal/Distribution/Simple/UserHooks.hs231
-rw-r--r--cabal/Cabal/Distribution/Simple/Utils.hs1140
-rw-r--r--cabal/Cabal/Distribution/System.hs179
-rw-r--r--cabal/Cabal/Distribution/TestSuite.hs125
-rw-r--r--cabal/Cabal/Distribution/Text.hs68
-rw-r--r--cabal/Cabal/Distribution/Verbosity.hs113
-rw-r--r--cabal/Cabal/Distribution/Version.hs744
-rw-r--r--cabal/Cabal/LICENSE33
-rw-r--r--cabal/Cabal/Language/Haskell/Extension.hs540
-rw-r--r--cabal/Cabal/Makefile130
-rw-r--r--cabal/Cabal/README179
-rw-r--r--cabal/Cabal/Setup.hs10
-rw-r--r--cabal/Cabal/changelog385
-rw-r--r--cabal/Cabal/doc/Cabal.css39
-rw-r--r--cabal/Cabal/doc/developing-packages.markdown1537
-rw-r--r--cabal/Cabal/doc/index.markdown169
-rw-r--r--cabal/Cabal/doc/installing-packages.markdown809
-rw-r--r--cabal/Cabal/doc/misc.markdown109
-rw-r--r--cabal/Cabal/prologue.txt7
-rw-r--r--cabal/Cabal/runTests.sh21
-rw-r--r--cabal/HACKING10
-rw-r--r--cabal/LICENSE33
-rw-r--r--cabal/Paths_Cabal.hs8
-rw-r--r--cabal/Paths_cabal_install.hs8
-rw-r--r--cabal/README8
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs315
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs127
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Types.hs44
-rw-r--r--cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs72
-rw-r--r--cabal/cabal-install/Distribution/Client/Check.hs85
-rw-r--r--cabal/cabal-install/Distribution/Client/Config.hs543
-rw-r--r--cabal/cabal-install/Distribution/Client/Configure.hs215
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency.hs514
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular.hs58
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Assignment.hs154
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs143
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Configured.hs10
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/ConfiguredConversion.hs40
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs194
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs148
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Flag.hs71
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Index.hs33
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs184
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Log.hs108
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Message.hs98
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs102
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Package.hs113
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs275
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs54
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs147
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs232
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Modular/Version.hs43
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs942
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs600
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs91
-rw-r--r--cabal/cabal-install/Distribution/Client/Dependency/Types.hs205
-rw-r--r--cabal/cabal-install/Distribution/Client/Fetch.hs189
-rw-r--r--cabal/cabal-install/Distribution/Client/FetchUtils.hs193
-rw-r--r--cabal/cabal-install/Distribution/Client/GZipUtils.hs44
-rw-r--r--cabal/cabal-install/Distribution/Client/Haddock.hs101
-rw-r--r--cabal/cabal-install/Distribution/Client/HttpUtils.hs205
-rw-r--r--cabal/cabal-install/Distribution/Client/Index.hs218
-rw-r--r--cabal/cabal-install/Distribution/Client/IndexUtils.hs514
-rw-r--r--cabal/cabal-install/Distribution/Client/Init.hs779
-rw-r--r--cabal/cabal-install/Distribution/Client/Init/Heuristics.hs229
-rw-r--r--cabal/cabal-install/Distribution/Client/Init/Licenses.hs1928
-rw-r--r--cabal/cabal-install/Distribution/Client/Init/Types.hs164
-rw-r--r--cabal/cabal-install/Distribution/Client/Install.hs1212
-rw-r--r--cabal/cabal-install/Distribution/Client/InstallPlan.hs536
-rw-r--r--cabal/cabal-install/Distribution/Client/InstallSymlink.hs239
-rw-r--r--cabal/cabal-install/Distribution/Client/JobControl.hs89
-rw-r--r--cabal/cabal-install/Distribution/Client/List.hs533
-rw-r--r--cabal/cabal-install/Distribution/Client/PackageEnvironment.hs380
-rw-r--r--cabal/cabal-install/Distribution/Client/PackageIndex.hs487
-rw-r--r--cabal/cabal-install/Distribution/Client/PackageUtils.hs34
-rw-r--r--cabal/cabal-install/Distribution/Client/ParseUtils.hs55
-rw-r--r--cabal/cabal-install/Distribution/Client/Sandbox.hs215
-rw-r--r--cabal/cabal-install/Distribution/Client/Setup.hs1492
-rw-r--r--cabal/cabal-install/Distribution/Client/SetupWrapper.hs389
-rw-r--r--cabal/cabal-install/Distribution/Client/SrcDist.hs160
-rw-r--r--cabal/cabal-install/Distribution/Client/Tar.hs926
-rw-r--r--cabal/cabal-install/Distribution/Client/Targets.hs760
-rw-r--r--cabal/cabal-install/Distribution/Client/Types.hs187
-rw-r--r--cabal/cabal-install/Distribution/Client/Unpack.hs123
-rw-r--r--cabal/cabal-install/Distribution/Client/Update.hs80
-rw-r--r--cabal/cabal-install/Distribution/Client/Upload.hs185
-rw-r--r--cabal/cabal-install/Distribution/Client/Utils.hs127
-rw-r--r--cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs222
-rw-r--r--cabal/cabal-install/Distribution/Client/World.hs174
-rw-r--r--cabal/cabal-install/Distribution/Compat/ExceptionCI.hs56
-rw-r--r--cabal/cabal-install/Distribution/Compat/FilePerms.hs40
-rw-r--r--cabal/cabal-install/Distribution/Compat/Time.hs37
-rw-r--r--cabal/cabal-install/LICENSE34
-rw-r--r--cabal/cabal-install/Main.hs644
-rw-r--r--cabal/cabal-install/README143
-rw-r--r--cabal/cabal-install/Setup.hs2
-rw-r--r--cabal/cabal-install/bash-completion/cabal24
-rw-r--r--cabal/cabal-install/bootstrap.sh241
-rw-r--r--cabal/cabal-install/cabal-install.cabal146
-rw-r--r--cabal/cabal-install/cbits/getnumcores.c46
-rw-r--r--cabal/cabal-install/changelog135
-rw-r--r--cabal/ghc-packages2
-rw-r--r--hackport.cabal190
-rw-r--r--tests/RunTests.hs15
-rw-r--r--tests/normalize_deps.hs134
-rw-r--r--tests/print_deps.hs138
-rw-r--r--tests/resolveCat.hs29
203 files changed, 57238 insertions, 1 deletions
diff --git a/.gitignore b/.gitignore
deleted file mode 100644
index 7773828..0000000
--- a/.gitignore
+++ /dev/null
@@ -1 +0,0 @@
-dist/ \ No newline at end of file
diff --git a/AnsiColor.hs b/AnsiColor.hs
new file mode 100644
index 0000000..7a6edf7
--- /dev/null
+++ b/AnsiColor.hs
@@ -0,0 +1,63 @@
+{-|
+ Maintainer : Andres Loeh <kosmikus@gentoo.org>
+ Stability : provisional
+ Portability : haskell98
+
+ Simplistic ANSI color support.
+-}
+
+module AnsiColor
+ where
+
+import Data.List
+
+data Color = Black
+ | Red
+ | Green
+ | Yellow
+ | Blue
+ | Magenta
+ | Cyan
+ | White
+ | Default
+ deriving Enum
+
+esc :: [String] -> String
+esc [] = ""
+esc xs = "\ESC[" ++ (concat . intersperse ";" $ xs) ++ "m"
+
+col :: Color -> Bool -> Color -> [String]
+col fg bf bg = show (fromEnum fg + 30) : bf' [show (fromEnum bg + 40)]
+ where bf' | bf = ("01" :)
+ | otherwise = id
+
+inColor :: Color -> Bool -> Color -> String -> String
+inColor c bf bg txt = esc (col c bf bg) ++ txt ++ esc ["00"]
+
+bold, italic, underline, inverse :: String -> String
+bold = ansi "1" "22"
+italic = ansi "3" "23"
+underline = ansi "4" "24"
+inverse = ansi "7" "27"
+
+ansi :: String -> String -> String -> String
+ansi on off txt = esc [on] ++ txt ++ esc [off]
+
+{-
+data Doc = Doc (Bool -> String -> String)
+
+char chr = Doc (\_ c -> chr:c)
+
+text str = Doc (\_ c -> str ++ c)
+
+(Doc t) <> (Doc u) = Doc (\b c -> t b (u b c))
+
+t <+> u = t <> char ' ' <> u
+
+showDoc (Doc d) b = d b ""
+
+color (Doc d) color = Doc (\ b c ->
+ if not b
+ then d b c
+ else inColor color False Default (d b ""))
+-}
diff --git a/BlingBling.hs b/BlingBling.hs
new file mode 100644
index 0000000..23ad2ff
--- /dev/null
+++ b/BlingBling.hs
@@ -0,0 +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 =
+ withBuffering stdout NoBuffering $ do
+ xs <- mapM (\x -> putStr "." >> f x) lst
+ putStrLn ""
+ 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
new file mode 100644
index 0000000..c0f2721
--- /dev/null
+++ b/Cabal2Ebuild.hs
@@ -0,0 +1,107 @@
+-- A program for generating a Gentoo ebuild from a .cabal file
+--
+-- Author : Duncan Coutts <dcoutts@gentoo.org>
+--
+-- Created: 21 July 2005
+--
+-- Copyright (C) 2005 Duncan Coutts
+--
+-- This library 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 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
+-- General Public License for more details.
+--
+-- |
+-- Maintainer : haskell@gentoo.org
+--
+-- cabal2ebuild - a program for generating a Gentoo ebuild from a .cabal file
+--
+module Cabal2Ebuild
+ (cabal2ebuild
+ ,convertDependencies
+ ,convertDependency) where
+
+import qualified Distribution.PackageDescription as Cabal
+ (PackageDescription(..))
+import qualified Distribution.Package as Cabal (PackageIdentifier(..)
+ , Dependency(..)
+ , PackageName(..))
+import qualified Distribution.Version as Cabal (VersionRange, foldVersionRange')
+import Distribution.Text (display)
+
+import Data.Char (toLower,isUpper)
+
+import Portage.Dependency
+import qualified Portage.Cabal as Portage
+import qualified Portage.PackageId as Portage
+import qualified Portage.EBuild as Portage
+import qualified Portage.GHCCore as Portage
+import qualified Portage.Resolve as Portage
+import qualified Portage.EBuild as E
+import qualified Portage.Overlay as O
+import Portage.Version
+
+cabal2ebuild :: Cabal.PackageDescription -> Portage.EBuild
+cabal2ebuild pkg = Portage.ebuildTemplate {
+ E.name = map toLower cabalPkgName,
+ E.hackage_name= cabalPkgName,
+ E.version = display (Cabal.pkgVersion (Cabal.package pkg)),
+ E.description = if null (Cabal.synopsis pkg) then Cabal.description pkg
+ else Cabal.synopsis pkg,
+ E.long_desc = if null (Cabal.description pkg) then Cabal.synopsis pkg
+ else Cabal.description pkg,
+ E.homepage = thisHomepage,
+ E.license = Portage.convertLicense $ Cabal.license pkg,
+ E.slot = (E.slot E.ebuildTemplate) ++ maybe [] (const "/${PV}") (Cabal.library pkg),
+ E.my_pn = if any isUpper cabalPkgName then Just cabalPkgName else Nothing,
+ E.features = E.features E.ebuildTemplate
+ ++ (if hasExe then ["bin"] else [])
+ ++ maybe [] (const (["lib","profile","haddock","hoogle"]
+ ++ if cabalPkgName == "hscolour" then [] else ["hscolour"])
+ ) (Cabal.library pkg) -- hscolour can't colour its own sources
+ ++ (if hasTests then ["test-suite"] else [])
+ } where
+ cabalPkgName = display $ Cabal.pkgName (Cabal.package pkg)
+ hasExe = (not . null) (Cabal.executables pkg)
+ hasTests = (not . null) (Cabal.testSuites pkg)
+ thisHomepage = if (null $ Cabal.homepage pkg)
+ then E.homepage E.ebuildTemplate
+ else Cabal.homepage pkg
+
+convertDependencies :: O.Overlay -> Portage.Category -> [Cabal.Dependency] -> [Dependency]
+convertDependencies overlay category = map (convertDependency overlay category)
+
+convertDependency :: O.Overlay -> Portage.Category -> Cabal.Dependency -> Dependency
+convertDependency _overlay _category (Cabal.Dependency pname@(Cabal.PackageName _name) _)
+ -- no explicit dep on core libs.
+ -- TODO: the same is done when filtering in
+ -- merge phase in a more robust way. Do we need it?
+ | pname `elem` Portage.coreLibs = empty_dependency
+convertDependency overlay category (Cabal.Dependency pname versionRange)
+ = convert versionRange
+ where
+ pn = case Portage.resolveFullPortageName overlay pname of
+ Just r -> r
+ Nothing -> Portage.PackageName category (Portage.normalizeCabalPackageName pname)
+ mk_p :: DRange -> Dependency
+ mk_p dr = Atom pn dr (DAttr AnySlot [])
+ p_v v = fromCabalVersion v
+
+ convert :: Cabal.VersionRange -> Dependency
+ convert = Cabal.foldVersionRange'
+ ( mk_p (DRange ZeroB InfinityB) -- ^ @\"-any\"@ version
+ )(\v -> mk_p (DExact (p_v v)) -- ^ @\"== v\"@
+ )(\v -> mk_p (DRange (StrictLB (p_v v)) InfinityB) -- ^ @\"> v\"@
+ )(\v -> mk_p (DRange ZeroB (StrictUB (p_v v))) -- ^ @\"< v\"@
+ )(\v -> mk_p (DRange (NonstrictLB (p_v v)) InfinityB) -- ^ @\">= v\"@
+ )(\v -> mk_p (DRange ZeroB (NonstrictUB (p_v v))) -- ^ @\"<= v\"@
+ )(\v1 v2 -> mk_p (DRange (NonstrictLB (p_v v1)) (StrictUB (p_v v2))) -- ^ @\"== v.*\"@ wildcard. (incl lower, excl upper)
+ )(\g1 g2 -> DependAnyOf [g1, g2] -- ^ @\"_ || _\"@ union
+ )(\r1 r2 -> DependAllOf [r1, r2] -- ^ @\"_ && _\"@ intersection
+ )(\dp -> dp -- ^ @\"(_)\"@ parentheses
+ )
diff --git a/CacheFile.hs b/CacheFile.hs
new file mode 100644
index 0000000..4569ca3
--- /dev/null
+++ b/CacheFile.hs
@@ -0,0 +1,12 @@
+module CacheFile where
+
+import System.FilePath
+
+indexFile :: String
+indexFile = "00-index.tar.gz"
+
+hackportDir :: String
+hackportDir = ".hackport"
+
+cacheFile :: FilePath -> FilePath
+cacheFile tree = tree </> hackportDir </> indexFile
diff --git a/Diff.hs b/Diff.hs
new file mode 100644
index 0000000..9f1559e
--- /dev/null
+++ b/Diff.hs
@@ -0,0 +1,188 @@
+module Diff
+ ( runDiff
+ , DiffMode(..)
+ ) where
+
+import Control.Monad ( mplus )
+import Control.Exception ( assert )
+import Data.Maybe ( fromJust, listToMaybe )
+import Data.List ( sortBy, groupBy )
+import Data.Ord ( comparing )
+
+import qualified Portage.Overlay as Portage
+import qualified Portage.Cabal as Portage
+import qualified Portage.PackageId as Portage
+
+import qualified Data.Version as Cabal
+
+-- 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 (getSourcePackages)
+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 "")
+
+
+-- 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.getSourcePackages verbosity [ repo ]
+ let (Cabal.SourcePackageDb 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 (concatMap snd . Index.searchByNameSubstring hackageIndex) pkgs
+ ,concatMap (concatMap snd . 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.SourcePackage]
+ -> [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..52b16d5
--- /dev/null
+++ b/DistroMap.hs
@@ -0,0 +1,158 @@
+{-# 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, SourcePackageDb(..), SourcePackage(..) )
+import Distribution.Simple.Utils ( 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 ( readOverlayByPackage, getDirectoryTree )
+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)]
+
+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))
+
+ SourcePackageDb { packageIndex = packageIndex } <-
+ CabalInstall.getSourcePackages verbosity [repo]
+
+ let pkgs0 = map (map packageInfoId) (CabalInstall.allPackagesByName packageIndex)
+ hackagePkgs = [ (Cabal.pkgName (head p), map Cabal.pkgVersion p) | p <- pkgs0 ]
+
+ 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 (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 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
new file mode 100644
index 0000000..c0ff2d1
--- /dev/null
+++ b/Error.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Error (HackPortError(..), throwEx, catchEx, hackPortShowError) where
+
+import Data.Typeable
+import Control.Exception.Extensible as EE
+import Control.Monad.Error
+
+data HackPortError
+ = ArgumentError String
+ | ConnectionFailed String String
+ | PackageNotFound String
+ | InvalidTarballURL String String
+ | InvalidSignatureURL String String
+ | VerificationFailed String String
+ | DownloadFailed String String
+ | UnknownCompression String
+ | UnpackingFailed String Int
+ | NoCabalFound String
+ | ExtractionFailed String String Int
+ | CabalParseFailed String String
+ | BashNotFound
+ | BashError String
+ | NoOverlay
+ | MultipleOverlays [String]
+ | UnknownVerbosityLevel String
+ -- | WrongCacheVersion
+ -- | InvalidCache
+ | InvalidServer String
+ deriving (Typeable, Show)
+
+instance Error HackPortError where
+
+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. 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++"'"
+ DownloadFailed url reason -> "Error while downloading '"++url++"': "++reason
+ UnknownCompression tarball -> "Couldn't guess compression type of '"++tarball++"'"
+ UnpackingFailed tarball code -> "Unpacking '"++tarball++"' failed with exit code '"++show code++"'"
+ NoCabalFound tarball -> "Tarball '"++tarball++"' doesn't contain a cabal file"
+ ExtractionFailed tarball file code -> "Extracting '"++file++"' from '"++tarball++"' failed with '"++show code++"'"
+ CabalParseFailed file reason -> "Error while parsing cabal file '"++file++"': "++reason
+ BashNotFound -> "The 'bash' executable was not found. It is required to figure out your portage-overlay. If you don't want to install bash, use '-p path-to-overlay'"
+ BashError str -> "Error while guessing your portage-overlay. Either set PORTDIR_OVERLAY in /etc/make.conf or use '-p path-to-overlay'.\nThe error was: \""++str++"\""
+ MultipleOverlays overlays -> "You have the following overlays available: '"++unwords overlays++"'. Please choose one by using 'hackport -p path-to-overlay' <command>"
+ NoOverlay -> "You don't have PORTDIR_OVERLAY set in '/etc/make.conf'. Please set it or use '-p path-to-overlay'"
+ UnknownVerbosityLevel str -> "The verbosity level '"++str++"' is invalid. Please use debug,normal or silent"
+ InvalidServer srv -> "Invalid server address, could not parse: " ++ srv
+ --WrongCacheVersion -> "The version of the cache is too old. Please update the cache using 'hackport update'"
+ --InvalidCache -> "Could not read the cache. Please ensure that it's up to date using 'hackport update'"
diff --git a/Hackage.hs b/Hackage.hs
new file mode 100644
index 0000000..57a5db2
--- /dev/null
+++ b/Hackage.hs
@@ -0,0 +1,32 @@
+{-|
+ Author : Sergei Trofimovich <slyfox@gentoo.org>
+ Stability : experimental
+ Portability : haskell98
+
+ Utilities to work with hackage-alike repositories
+-}
+module Hackage
+ ( defaultRepo
+ , defaultRepoURI
+ ) where
+
+import Distribution.Client.Types (Repo(..), RemoteRepo(..))
+import Network.URI (URI(..), URIAuth(..))
+import System.FilePath
+
+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
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-GuessGHC.hs b/Main-GuessGHC.hs
new file mode 100644
index 0000000..3eaf317
--- /dev/null
+++ b/Main-GuessGHC.hs
@@ -0,0 +1,27 @@
+module Main where
+
+import System.Environment
+
+import Distribution.PackageDescription
+import Distribution.PackageDescription.Parse
+
+import Distribution.Text
+import Distribution.Verbosity
+
+import Portage.GHCCore
+
+main :: IO ()
+main = do
+ args <- getArgs
+ gpds <- mapM (readPackageDescription silent) args
+ mapM_ guess gpds
+
+guess :: GenericPackageDescription -> IO ()
+guess gpd = do
+ let pkg = package . packageDescription $ gpd
+ let mghc = minimumGHCVersionToBuildPackage gpd
+ putStr (display pkg)
+ putStr "\t\t"
+ putStrLn $ case mghc of
+ Nothing -> "Unknown"
+ Just (compiler, _pkgs) -> display compiler
diff --git a/Main.hs b/Main.hs
new file mode 100644
index 0000000..e6160a6
--- /dev/null
+++ b/Main.hs
@@ -0,0 +1,558 @@
+module Main where
+
+import Control.Applicative
+import Control.Monad
+import Data.Maybe
+import Data.List
+import Data.Monoid
+ ( Monoid(..) )
+
+-- cabal
+import Distribution.Simple.Setup
+ ( Flag(..), fromFlag
+ , trueArg
+ , flagToList
+ , optionVerbosity
+ )
+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, simpleParse)
+
+import Distribution.Client.Types
+import Distribution.Client.Update
+
+import qualified Distribution.Client.PackageIndex as Index
+import qualified Distribution.Client.IndexUtils as Index
+
+import Hackage (defaultRepo, defaultRepoURI)
+
+import Portage.Overlay as Overlay ( loadLazy, inOverlay )
+import Portage.Host as Host ( getInfo, portage_dir )
+import Portage.PackageId ( normalizeCabalPackageId )
+
+import Network.URI ( URI(..), parseURI )
+import System.Environment ( getArgs, getProgName )
+import System.Directory ( doesDirectoryExist )
+import System.Exit ( exitFailure )
+import System.FilePath ( (</>) )
+
+import Diff
+import Error
+import Status
+import Overlays
+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.getSourcePackages verbosity [ repo ])
+ overlay <- Overlay.loadLazy overlayPath
+ let pkgs | null extraArgs = Index.allPackages index
+ | otherwise = concatMap (concatMap snd . Index.searchByNameSubstring index) extraArgs
+ normalized = map (normalizeCabalPackageId . packageInfoId) pkgs
+ let decorated = map (\p -> (Overlay.inOverlay overlay p, p)) normalized
+ mapM_ (putStrLn . pretty) decorated
+ 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
+ (catstr,cabals) <- case args of
+ (category:cabal1:cabaln) -> return (category, cabal1:cabaln)
+ _ -> throwEx (ArgumentError "make-ebuild needs at least two arguments. <category> <cabal-1> <cabal-n>")
+ cat <- case simpleParse catstr of
+ Just c -> return c
+ Nothing -> throwEx (ArgumentError ("could not parse category: " ++ catstr))
+ let verbosity = fromFlag (makeEbuildVerbosity flags)
+ overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)
+ forM_ cabals $ \cabalFileName -> do
+ pkg <- Cabal.readPackageDescription normal cabalFileName
+ mergeGenericPackageDescription verbosity overlayPath cat pkg False
+
+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,
+ statusDirection :: Flag StatusDirection
+ }
+
+defaultStatusFlags :: StatusFlags
+defaultStatusFlags = StatusFlags {
+ statusVerbosity = Flag normal,
+ statusDirection = Flag PortagePlusOverlay
+ }
+
+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."
+ statusDirection (\v flags -> flags { statusDirection = v })
+ (noArg (Flag OverlayToPortage))
+ , option [] ["from-hackage"]
+ "Print only packages likely to be interesting to move from hackage tree."
+ statusDirection (\v flags -> flags { statusDirection = v })
+ (noArg (Flag HackageToOverlay))
+ ]
+ }
+
+statusAction :: StatusFlags -> [String] -> GlobalFlags -> IO ()
+statusAction flags args globalFlags = do
+ let verbosity = fromFlag (statusVerbosity flags)
+ direction = fromFlag (statusDirection flags)
+ portagePath <- getPortageDir verbosity globalFlags
+ overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)
+ runStatus verbosity portagePath overlayPath direction 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
+-----------------------------------------------------------------------
+
+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 = getArgs >>= mainWorker
diff --git a/Merge.hs b/Merge.hs
new file mode 100644
index 0000000..3230876
--- /dev/null
+++ b/Merge.hs
@@ -0,0 +1,490 @@
+{-# LANGUAGE PatternGuards, BangPatterns #-}
+module Merge
+ ( merge
+ , mergeGenericPackageDescription
+ ) where
+
+import Control.Arrow (first, second)
+import Control.Monad.Error
+import Control.Exception
+import qualified Data.ByteString.Lazy.Char8 as BL
+import Data.Char (isSpace)
+import Data.Function (on)
+import Data.Maybe
+import Data.Monoid
+import Data.List as L
+import Data.Version
+
+-- cabal
+import qualified Distribution.Package as Cabal
+import qualified Distribution.Version as Cabal
+import qualified Distribution.PackageDescription as Cabal ( PackageDescription(..)
+ , Flag(..)
+ , FlagAssignment
+ , FlagName(..)
+ , GenericPackageDescription(..)
+ )
+import qualified Distribution.PackageDescription.Parse as Cabal (showPackageDescription)
+
+import Distribution.Text (display)
+import Distribution.Verbosity
+import Distribution.Simple.Utils
+
+-- cabal-install
+import Distribution.Client.IndexUtils ( getSourcePackages )
+import qualified Distribution.Client.PackageIndex as Index
+import Distribution.Client.Types
+
+-- others
+import System.Directory ( getCurrentDirectory
+ , getDirectoryContents
+ , setCurrentDirectory
+ , createDirectoryIfMissing
+ , doesFileExist
+ )
+import System.Cmd (system)
+import System.FilePath ((</>))
+import System.Exit
+import Text.Printf
+
+import qualified Cabal2Ebuild as C2E
+import qualified Portage.EBuild as E
+import Error as E
+
+import Network.URI
+
+
+import qualified Portage.PackageId as Portage
+import qualified Portage.Version as Portage
+import qualified Portage.Metadata as Portage
+import qualified Portage.Overlay as Overlay
+import qualified Portage.Resolve as Portage
+import qualified Portage.Dependency as Portage
+
+import qualified Portage.GHCCore as GHCCore
+
+import qualified Merge.Dependencies as Merge
+
+(<.>) :: String -> String -> String
+a <.> b = a ++ '.':b
+
+{-
+Requested features:
+ * Add files to git?
+ * Print diff with the next latest version?
+-}
+
+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 :: [SourcePackage] -> Maybe Cabal.Version -> Maybe SourcePackage
+resolveVersion avails Nothing = Just $ maximumBy (comparing packageInfoId) avails
+resolveVersion avails (Just ver) = listToMaybe (filter match avails)
+ where
+ match avail = ver == Cabal.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 $ getSourcePackages verbosity [ repo ]
+
+ -- find all packages that maches the user specified package name
+ availablePkgs <-
+ case map snd (Index.searchByName index user_pname_str) of
+ [] -> throwEx (PackageNotFound user_pname_str)
+ [pkg] -> return pkg
+ pkgs -> do let cabal_pkg_to_pn pkg =
+ case Cabal.pkgName (packageInfoId pkg) of
+ Cabal.PackageName pn -> pn
+ names = map (cabal_pkg_to_pn . L.head) pkgs
+ notice verbosity $ "Ambiguous names: " ++ L.intercalate ", " names
+ forM_ pkgs $ \ps ->
+ do let p_name = (cabal_pkg_to_pn . L.head) ps
+ notice verbosity $ p_name ++ ": " ++ (L.intercalate ", " $ map (showVersion . Cabal.pkgVersion . packageInfoId) ps)
+ return $ concat pkgs
+
+ -- 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_pkgName = Cabal.packageName (Portage.normalizeCabalPackageId cabal_pkgId)
+ cat <- maybe (Portage.resolveCategory verbosity overlay norm_pkgName) return m_category
+ mergeGenericPackageDescription verbosity overlayPath cat (packageDescription selectedPkg) True
+
+mergeGenericPackageDescription :: Verbosity -> FilePath -> Portage.Category -> Cabal.GenericPackageDescription -> Bool -> IO ()
+mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch = do
+ overlay <- Overlay.loadLazy overlayPath
+ let merged_cabal_pkg_name = Cabal.pkgName (Cabal.package (Cabal.packageDescription pkgGenericDesc))
+
+ (compilerId, ghc_packages, pkgDesc0, _flags, pix) <- case GHCCore.minimumGHCVersionToBuildPackage pkgGenericDesc of
+ Just v -> return v
+ Nothing -> let cpn = display merged_cabal_pkg_name
+ in error $ unlines [ "mergeGenericPackageDescription: failed to find suitable GHC for " ++ cpn
+ , " You can try to merge the package manually:"
+ , " $ cabal unpack " ++ cpn
+ , " $ cd " ++ cpn ++ "*/"
+ , " # fix " ++ cpn ++ ".cabal"
+ , " $ hackport make-ebuild dev-haskell " ++ cpn ++ ".cabal"
+ ]
+
+ -- , Right (pkg_desc, picked_flags) <- return (packageBuildableWithGHCVersion gpd g)]
+ let (accepted_deps, skipped_deps, dropped_deps) = genSimple (Cabal.buildDepends pkgDesc0)
+ pkgDesc = pkgDesc0 { Cabal.buildDepends = accepted_deps }
+ aflags = map Cabal.flagName (Cabal.genPackageFlags pkgGenericDesc)
+ lflags :: [Cabal.Flag] -> [Cabal.FlagAssignment]
+ lflags [] = [[]]
+ lflags (x:xs) = let tp = lflags xs
+ in (map ((Cabal.flagName x,False) :) tp)
+ ++ (map ((Cabal.flagName x,True):) tp)
+ -- key idea is to generate all possible list of flags
+ deps1 :: [(Cabal.FlagAssignment, Merge.EDep)]
+ deps1 = [ (f `updateFa` fr, genDeps pkgDesc_filtered_bdeps)
+ | f <- lflags (Cabal.genPackageFlags pkgGenericDesc)
+ , Right (pkgDesc1,fr) <- [GHCCore.finalizePackageDescription f
+ (GHCCore.dependencySatisfiable pix)
+ (GHCCore.platform)
+ compilerId
+ []
+ pkgGenericDesc]
+ -- drop circular deps and shipped deps
+ , let (ad, _sd, _rd) = genSimple (Cabal.buildDepends pkgDesc1)
+ , let pkgDesc_filtered_bdeps = pkgDesc1 { Cabal.buildDepends = ad }
+ ]
+ where
+ updateFa :: Cabal.FlagAssignment -> Cabal.FlagAssignment -> Cabal.FlagAssignment
+ updateFa [] _ = []
+ updateFa (x:xs) y = case lookup (fst x) y of
+ Nothing -> x:(updateFa xs y)
+ Just y' -> (fst x,y'):(updateFa xs y)
+ -- then remove all flags that can't be changed
+ commonFlags = foldl1 intersect $ map fst deps1
+ aflags' | null commonFlags = aflags
+ | otherwise = filter (\a -> all (a/=) $ map fst commonFlags) aflags
+ aflags'' = filter (\x -> Cabal.flagName x `elem` aflags') $ Cabal.genPackageFlags pkgGenericDesc
+ -- flags that are faild to build
+ deadFlags = filter (\x -> all (x/=) $ map fst deps1) (lflags (Cabal.genPackageFlags pkgGenericDesc))
+ -- and finaly prettify all deps:
+ tdeps = (foldl (\x y -> x `mappend` (snd y)) mempty deps1){
+ Merge.dep = Portage.sortDeps . simplify $ map (\x -> (x,[])) $ map (first (filter (\x -> all (x/=) commonFlags))) $ map (second Merge.dep) deps1
+ , Merge.rdep = Portage.sortDeps . simplify $ map (\x -> (x,[])) $ map (first (filter (\x -> all (x/=) commonFlags))) $ map (second Merge.rdep) deps1
+ }
+
+ common :: [FlagDepH] -> FlagDepH
+ common xs =
+ let n = go xs
+ k m = case m of
+ [] -> error "impossible"
+ [x] -> x
+ _ -> k (go m)
+ in k n
+ where
+ go [] = []
+ go [y] = [y]
+ go (y1:y2:ys) = y1 `merge1` y2 : go ys
+
+ merge1 :: FlagDepH -> FlagDepH -> FlagDepH
+ merge1 ((f1, d1),x1) ((f2, d2),x2) = ((f1 `intersect` f2, Portage.simplify_deps $ d1 `intersect` d2)
+ , (f1, filter (`notElem` d2) d1)
+ : (f2, filter (`notElem` d1) d2)
+ : x1
+ ++ x2
+ )
+
+ simplify :: [FlagDepH] -> [Portage.Dependency]
+ simplify xs =
+ let -- extract common part of the depends
+ -- filtering out empty groups
+ ((fl,c), zs) = second (filter (not.null.snd)) $ common xs
+ -- Regroup flags according to packages, i.e.
+ -- if 2 groups of flagged deps containg same package, then
+ -- extract common flags, but if common flags will be empty
+ -- then remove repacked package from the result list.
+ -- This is simplify packages but will not break if depend
+ -- is required but non intersecting groups.
+ mergeD :: (Cabal.FlagAssignment, Portage.Dependency)
+ -> [(Cabal.FlagAssignment, Portage.Dependency)]
+ -> [(Cabal.FlagAssignment, Portage.Dependency)]
+ mergeD x [] = [x]
+ mergeD x@(f1,d1) (t@(f2,d2):ts) =
+ let is = f1 `intersect` f2
+ in if d1 == d2
+ then if null is
+ then ts
+ else (is,d1):ts
+ else t:mergeD x ts
+ sd :: [(Cabal.FlagAssignment, [Portage.Dependency])]
+ sd = foldl (\o (f,d) -> case lookup f o of
+ Just ds -> (f,d:ds):filter ((f/=).fst) o
+ Nothing -> (f,[d]):o
+ ) [] $ foldl (\o n -> n `mergeD` o)
+ []
+ (concatMap (\(f,d) -> map ((,) f) d) zs)
+ -- filter out splitted packages from common cgroup
+ ys = filter (not.null.snd) $ map (second (filter (\d -> all (d/=)
+ (concatMap snd sd))
+ )) zs
+ -- Now we need to find noniteracting use flags if they are then we
+ -- don't need to simplify them more, and output as-is
+ simplifyMore :: [(Cabal.FlagAssignment,[Portage.Dependency])] -> [Portage.Dependency]
+ simplifyMore [] = []
+ simplifyMore ws =
+ let us = getMultiFlags ws
+ (u,_) = maximumBy (compare `on` snd) $ getMultiFlags ws
+ (xs', ls) = (hasFlag u) `partition` ws
+ in if null us
+ then concatMap (\(a, b) -> liftFlags a b) ws
+ else liftFlags [u] (simplify $ map (\x -> (x,[])) $ dropFlag u xs')++simplifyMore ls
+ in (liftFlags fl c) ++ simplifyMore (sd ++ ys)
+
+ -- drop selected use flag from a list
+ getMultiFlags :: [FlagDep] -> [((Cabal.FlagName,Bool),Int)]
+ getMultiFlags ys = go [] (concatMap fst ys)
+ where go a [] = a
+ go a (x:xs) = case lookup x a of
+ Nothing -> go ((x,1):a) xs
+ Just n -> go ((x,n+1):filter ((x/=).fst) a) xs
+ dropFlag :: (Cabal.FlagName,Bool) -> [FlagDep] -> [FlagDep]
+ dropFlag f = map (first (filter (f /=)))
+ hasFlag :: (Cabal.FlagName,Bool) -> FlagDep -> Bool
+ hasFlag u = any ((u ==)) . fst
+
+ liftFlags :: Cabal.FlagAssignment -> [Portage.Dependency] -> [Portage.Dependency]
+ liftFlags fs e = let k = foldr (\(y,b) x -> Portage.DependIfUse (Portage.DUse (b, unFlagName y)) . x)
+ (id::Portage.Dependency->Portage.Dependency) fs
+ in Portage.simplify_deps [k $! Portage.DependAllOf e]
+
+
+ genSimple =
+ foldl (\(ad, sd, rd) (Cabal.Dependency pn vr) ->
+ let dep = (Cabal.Dependency pn (Cabal.simplifyVersionRange vr))
+ in case () of
+ _ | pn `elem` ghc_packages -> ( ad, dep:sd, rd)
+ _ | pn == merged_cabal_pkg_name -> ( ad, sd, dep:rd)
+ _ -> (dep:ad, sd, rd)
+ )
+ ([],[],[])
+ genDeps pkg = Merge.resolveDependencies overlay pkg (Just compilerId)
+
+ debug verbosity $ "buildDepends pkgDesc0 raw: " ++ Cabal.showPackageDescription pkgDesc0
+ debug verbosity $ "buildDepends pkgDesc0: " ++ show (map display (Cabal.buildDepends pkgDesc0))
+ debug verbosity $ "buildDepends pkgDesc: " ++ show (map display (Cabal.buildDepends pkgDesc))
+
+ notice verbosity $ "Accepted depends: " ++ show (map display accepted_deps)
+ notice verbosity $ "Skipped depends: " ++ show (map display skipped_deps)
+ notice verbosity $ "Dropped depends: " ++ show (map display dropped_deps)
+ notice verbosity $ "Dead flags: " ++ show deadFlags
+ notice verbosity $ "Dropped flags: " ++ show (map (unFlagName.fst) commonFlags)
+ -- mapM_ print tdeps
+
+ forM_ ghc_packages $
+ \(Cabal.PackageName name) -> info verbosity $ "Excluded packages (comes with ghc): " ++ name
+
+ let -- p_flag (Cabal.FlagName fn, True) = fn
+ -- p_flag (Cabal.FlagName fn, False) = '-':fn
+
+
+ -- appends 's' to each line except the last one
+ -- handy to build multiline shell expressions
+ icalate _s [] = []
+ icalate _s [x] = [x]
+ icalate s (x:xs) = (x ++ s) : icalate s xs
+
+ selected_flags :: [String] -> [String]
+ selected_flags [] = []
+ selected_flags fs = icalate " \\" $ "haskell-cabal_src_configure"
+ : map (\p -> "\t$(cabal_flag "++ p ++" "++ p ++")") fs
+ to_iuse x = let fn = unFlagName $ Cabal.flagName x
+ p = if Cabal.flagDefault x then "+" else ""
+ in p++fn
+
+ ebuild = (\e -> e { E.depend = Merge.dep tdeps} )
+ . (\e -> e { E.depend_extra = Merge.dep_e tdeps } )
+ . (\e -> e { E.rdepend = Merge.rdep tdeps} )
+ . (\e -> e { E.rdepend_extra = Merge.rdep_e tdeps } )
+ . (\e -> e { E.src_configure = selected_flags $ sort $ map unFlagName aflags' } )
+ . (\e -> e { E.iuse = E.iuse e ++ map to_iuse aflags'' })
+ $ C2E.cabal2ebuild pkgDesc
+
+ mergeEbuild verbosity overlayPath (Portage.unCategory cat) ebuild
+ when fetch $ do
+ let cabal_pkgId = Cabal.packageId pkgDesc
+ norm_pkgName = Cabal.packageName (Portage.normalizeCabalPackageId cabal_pkgId)
+ fetchDigestAndCheck
+ verbosity
+ (overlayPath </> display cat </> display norm_pkgName)
+
+fetchDigestAndCheck :: Verbosity
+ -> FilePath -- ^ directory of ebuild
+ -> IO ()
+fetchDigestAndCheck verbosity ebuildDir =
+ withWorkingDirectory ebuildDir $ do
+ notice verbosity "Recalculating digests (repoman manifest)..."
+ rm <- system "repoman manifest"
+ when (rm /= ExitSuccess) $
+ notice verbosity "repoman manifest failed horribly. Do something about it!"
+ rf <- system "repoman full --include-dev"
+ when (rf /= ExitSuccess) $
+ notice verbosity "repoman full --include-dev found an error. Do something about it!"
+ return ()
+
+withWorkingDirectory :: FilePath -> IO a -> IO a
+withWorkingDirectory newDir action = do
+ oldDir <- getCurrentDirectory
+ bracket
+ (setCurrentDirectory newDir)
+ (\_ -> setCurrentDirectory oldDir)
+ (\_ -> action)
+
+-- tries to extract value of variable in var="val" format
+-- There should be exactly one variable assignment in ebuild
+-- It's a bit artificial limitation, but it's common for 'if / else' blocks
+extract_quoted_string :: FilePath -> String -> String -> Maybe String
+extract_quoted_string ebuild_path s_ebuild var_name =
+ case filter (isPrefixOf var_prefix . ltrim) $ lines s_ebuild of
+ [] -> Nothing
+ [kw_line] -> up_to_quote $ skip_prefix $ ltrim kw_line
+ other -> bail_out $ printf "strange '%s' assignmets:\n%s" var_name (unlines other)
+
+ where ltrim :: String -> String
+ ltrim = dropWhile isSpace
+ var_prefix = var_name ++ "=\""
+ skip_prefix = drop (length var_prefix)
+ up_to_quote l = case break (== '"') l of
+ ("", _) -> Nothing -- empty line
+ (_, "") -> bail_out $ printf "failed to find closing quote for '%s'" l
+ (val, _) -> Just val
+ bail_out :: String -> e
+ bail_out msg = error $ printf "%s:extract_quoted_string %s" ebuild_path msg
+
+extractKeywords :: FilePath -> String -> Maybe [String]
+extractKeywords ebuild_path s_ebuild =
+ words `fmap ` extract_quoted_string ebuild_path s_ebuild "KEYWORDS"
+
+extractLicense :: FilePath -> String -> Maybe String
+extractLicense ebuild_path s_ebuild =
+ extract_quoted_string ebuild_path s_ebuild "LICENSE"
+
+-- aggregated (best inferred) metadata for a new ebuild of package
+data EMeta = EMeta { keywords :: Maybe [String]
+ , license :: Maybe String
+ }
+
+findExistingMeta :: FilePath -> IO EMeta
+findExistingMeta edir =
+ do ebuilds <- filter (isPrefixOf (reverse ".ebuild") . reverse) `fmap` getDirectoryContents edir
+ -- TODO: version sort
+ e_metas <- forM ebuilds $ \e ->
+ do let e_path = edir </> e
+ e_conts <- readFile e_path
+ return EMeta { keywords = extractKeywords e e_conts
+ , license = extractLicense e e_conts
+ }
+ let get_latest candidates = last (Nothing : filter (/= Nothing) candidates)
+ aggregated_meta = EMeta { keywords = get_latest $ map keywords e_metas
+ , license = get_latest $ map license e_metas
+ }
+ return $ aggregated_meta
+
+-- "amd64" -> "~amd64"
+to_unstable :: String -> String
+to_unstable kw =
+ case kw of
+ '~':_ -> kw
+ '-':_ -> kw
+ _ -> '~':kw
+
+mergeEbuild :: Verbosity -> FilePath -> String -> E.EBuild -> IO ()
+mergeEbuild verbosity target cat ebuild = do
+ let edir = target </> cat </> E.name ebuild
+ elocal = E.name ebuild ++"-"++ E.version ebuild <.> "ebuild"
+ epath = edir </> elocal
+ emeta = "metadata.xml"
+ mpath = edir </> emeta
+ default_meta = BL.pack $ Portage.makeDefaultMetadata (E.long_desc ebuild)
+ createDirectoryIfMissing True edir
+ existing_meta <- findExistingMeta edir
+
+ let (existing_keywords, existing_license) = (keywords existing_meta, license existing_meta)
+ new_keywords = maybe (E.keywords ebuild) (map to_unstable) existing_keywords
+ new_license = either (\err -> maybe (Left err)
+ Right
+ existing_license)
+ Right
+ (E.license ebuild)
+ ebuild' = ebuild { E.keywords = new_keywords
+ , E.license = new_license
+ }
+ s_ebuild' = display ebuild'
+
+ notice verbosity $ "Current keywords: " ++ show existing_keywords ++ " -> " ++ show new_keywords
+ notice verbosity $ "Current license: " ++ show existing_license ++ " -> " ++ show new_license
+
+ notice verbosity $ "Writing " ++ elocal
+ (length s_ebuild') `seq` BL.writeFile epath (BL.pack s_ebuild')
+
+ yet_meta <- doesFileExist mpath
+ if (not yet_meta) -- TODO: add --force-meta-rewrite to opts
+ then do notice verbosity $ "Writing " ++ emeta
+ BL.writeFile mpath default_meta
+ else do current_meta <- BL.readFile mpath
+ when (current_meta /= default_meta) $
+ notice verbosity $ "Default and current " ++ emeta ++ " differ."
+
+unFlagName :: Cabal.FlagName -> String
+unFlagName f =
+ let Cabal.FlagName y = f
+ in y
+
+type FlagDep = (Cabal.FlagAssignment,[Portage.Dependency])
+type FlagDepH = (FlagDep,[FlagDep])
diff --git a/Merge/Dependencies.hs b/Merge/Dependencies.hs
new file mode 100644
index 0000000..031c4f2
--- /dev/null
+++ b/Merge/Dependencies.hs
@@ -0,0 +1,476 @@
+{- | Merge a package from hackage to an ebuild.
+
+Merging a library
+=================
+
+Compile time:
+ ghc
+ cabal
+ build tools
+ deps (haskell dependencies)
+ extra-libs (c-libs)
+ pkg-config (c-libs)
+
+Run time:
+ ghc
+ deps (haskell dependencies)
+ extra-libs (c-libs)
+ pkg-config (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 (haskell dependencies)
+ extra-libs (c-libs)
+ pkg-config (c-libs)
+
+Run time:
+ extra-libs (c-libs)
+ pkg-config (c-libs)
+
+RDEPEND="${EXTRALIBS}"
+DEPEND="${RDEPEND} ghc cabal ${DEPS} ${BUILDTOOLS}"
+
+-}
+module Merge.Dependencies
+ ( EDep(..)
+ , resolveDependencies
+ , intersection
+ , difference
+ , null
+ ) where
+
+import Distribution.PackageDescription ( PackageDescription(..)
+ , libBuildInfo
+ , buildInfo
+ , buildable
+ , extraLibs
+ , buildTools
+ , pkgconfigDepends
+ , specVersion
+ , TestSuite(..)
+ , targetBuildDepends
+ )
+import Prelude hiding (null)
+import Data.Maybe ( isJust, isNothing )
+import Data.Monoid ( Monoid, mempty, mappend)
+import Data.List ( nub )
+import qualified Data.List as L
+import qualified Data.Set as S
+
+import qualified Distribution.Package as Cabal
+import qualified Distribution.PackageDescription as Cabal
+import qualified Distribution.Version as Cabal
+
+import Distribution.Compiler
+
+import qualified Portage.Dependency as Portage
+import qualified Portage.Overlay as Portage
+import qualified Portage.PackageId as Portage
+import qualified Portage.Use as Portage
+import qualified Cabal2Ebuild as C2E
+
+import qualified Portage.GHCCore as GHCCore
+
+import Debug.Trace ( trace )
+
+-- | Dependencies of an ebuild
+data EDep = EDep
+ {
+ rdep :: [Portage.Dependency],
+ rdep_e :: [String],
+ dep :: [Portage.Dependency],
+ dep_e :: [String]
+ }
+ deriving (Show, Eq)
+
+instance Monoid EDep where
+ mempty = EDep
+ {
+ rdep = [],
+ rdep_e = [],
+ dep = [],
+ dep_e = []
+ }
+ (EDep rdepA rdep_eA depA dep_eA) `mappend` (EDep rdepB rdep_eB depB dep_eB) = EDep
+ { rdep = Portage.simplify_deps $ rdepA ++ rdepB
+ , rdep_e = S.toList $ (S.fromList rdep_eA) `S.union` (S.fromList rdep_eB)
+ , dep = Portage.simplify_deps $ depA ++ depB
+ , dep_e = S.toList $ (S.fromList dep_eA) `S.union` (S.fromList dep_eB)
+ }
+
+
+intersection :: EDep -> EDep -> EDep
+intersection (EDep a1 a2 a3 a4) (EDep b1 b2 b3 b4) = EDep (L.intersect a1 b1)
+ (L.intersect a2 b2)
+ (L.intersect a3 b3)
+ (L.intersect a4 b4)
+
+difference :: EDep -> EDep -> EDep
+difference (EDep a1 a2 a3 a4) (EDep b1 b2 b3 b4) = EDep (f a1 b1)
+ (f a2 b2)
+ (f a3 b3)
+ (f a4 b4)
+ where f a b = L.filter (`L.notElem` b) a
+
+null :: EDep -> Bool
+null e = e == mempty
+
+resolveDependencies :: Portage.Overlay -> PackageDescription -> Maybe CompilerId -> EDep
+resolveDependencies overlay pkg mcompiler =
+ edeps
+ {
+ dep = dep2,
+ rdep = rdep2
+ -- todo: if rdep includes cabal or ghc, make sure it's the same
+ -- version as in dep
+ }
+ where
+ dep1 = Portage.simplify_deps ( dep edeps)
+ dep2 = Portage.simplifyUseDeps dep1 (dep1++rdep2)
+ rdep1 = Portage.simplify_deps (rdep edeps)
+ rdep2 = Portage.simplifyUseDeps rdep1 rdep1
+ compiler = maybe (fst GHCCore.defaultGHC) id mcompiler
+
+ -- hasBuildableExes p = any (buildable . buildInfo) . executables $ p
+ treatAsLibrary = isJust (Cabal.library pkg)
+ haskell_deps
+ | treatAsLibrary = map set_build_slot $ map add_profile $ haskellDependencies overlay (buildDepends pkg)
+ | otherwise = haskellDependencies overlay (buildDepends pkg)
+ test_deps
+ | (not . L.null) (testSuites pkg) = testDependencies overlay pkg
+ | otherwise = [] -- tests not enabled
+ cabal_dep = cabalDependency overlay pkg compiler
+ ghc_dep = compilerIdToDependency compiler
+ extra_libs = findCLibs pkg
+ pkg_config_libs = pkgConfigDependencies overlay pkg
+ pkg_config_tools = if L.null pkg_config_libs
+ then []
+ else [any_c_p "virtual" "pkgconfig"]
+ build_tools = buildToolsDependencies pkg ++ pkg_config_tools
+ edeps
+ | treatAsLibrary = mempty
+ {
+ dep = cabal_dep
+ : build_tools
+ ++ test_deps,
+ dep_e = [ "${RDEPEND}" ],
+ rdep = set_build_slot ghc_dep
+ : haskell_deps
+ ++ extra_libs
+ ++ pkg_config_libs
+ }
+ | otherwise = mempty
+ {
+ dep = ghc_dep
+ : cabal_dep
+ : build_tools
+ ++ haskell_deps
+ ++ test_deps,
+ dep_e = [ "${RDEPEND}" ],
+ rdep = extra_libs ++ pkg_config_libs
+ }
+ add_profile = Portage.addDepUseFlag (Portage.mkQUse "profile")
+ set_build_slot = Portage.setSlotDep Portage.AnyBuildTimeSlot
+
+---------------------------------------------------------------
+-- Test-suite dependencies
+---------------------------------------------------------------
+
+testDependencies :: Portage.Overlay -> PackageDescription -> [Portage.Dependency]
+testDependencies overlay pkg@(PackageDescription { package = Cabal.PackageIdentifier { Cabal.pkgName = Cabal.PackageName name}}) =
+ [Portage.DependIfUse (Portage.DUse (True, "test")) (Portage.DependAllOf $ Portage.simplify_deps deps)]
+ where cabalDeps = concat $ map targetBuildDepends $ map testBuildInfo (testSuites pkg)
+ cabalDeps' = filter (\(Cabal.Dependency (Cabal.PackageName pname) _) -> pname /= name) cabalDeps
+ deps = C2E.convertDependencies overlay (Portage.Category "dev-haskell") cabalDeps'
+
+---------------------------------------------------------------
+-- Haskell packages
+---------------------------------------------------------------
+
+haskellDependencies :: Portage.Overlay -> [Cabal.Dependency] {- PackageDescription -} -> [Portage.Dependency]
+haskellDependencies overlay deps =
+ Portage.simplify_deps
+ $ C2E.convertDependencies overlay (Portage.Category "dev-haskell") deps
+
+---------------------------------------------------------------
+-- Cabal Dependency
+---------------------------------------------------------------
+
+-- | Select the most restrictive dependency on Cabal, either the .cabal
+-- file's descCabalVersion, or the Cabal GHC shipped with.
+cabalDependency :: Portage.Overlay -> PackageDescription -> CompilerId -> Portage.Dependency
+cabalDependency overlay pkg (CompilerId GHC _ghcVersion@(Cabal.Version versionNumbers _)) =
+ C2E.convertDependency overlay
+ (Portage.Category "dev-haskell")
+ (Cabal.Dependency (Cabal.PackageName "Cabal")
+ finalCabalDep)
+ where
+ userCabalVersion = Cabal.orLaterVersion (specVersion pkg)
+ shippedCabalVersion = GHCCore.cabalFromGHC versionNumbers
+ shippedCabalDep = maybe Cabal.anyVersion Cabal.orLaterVersion shippedCabalVersion
+ finalCabalDep = Cabal.simplifyVersionRange
+ (Cabal.intersectVersionRanges
+ userCabalVersion
+ shippedCabalDep)
+
+---------------------------------------------------------------
+-- GHC Dependency
+---------------------------------------------------------------
+
+compilerIdToDependency :: CompilerId -> Portage.Dependency
+compilerIdToDependency (CompilerId GHC versionNumbers) =
+ at_least_c_p_v "dev-lang" "ghc" (Cabal.versionBranch versionNumbers)
+
+---------------------------------------------------------------
+-- C Libraries
+---------------------------------------------------------------
+
+findCLibs :: PackageDescription -> [Portage.Dependency]
+findCLibs (PackageDescription { library = lib, executables = exes }) =
+ [ trace ("WARNING: This package depends on a C library we don't know the portage name for: " ++ p ++ ". Check the generated ebuild.")
+ (any_c_p "unknown-c-lib" p)
+ | p <- notFound
+ ] ++
+ found
+ where
+ libE = maybe [] (extraLibs.libBuildInfo) lib
+ exeE = concatMap extraLibs (filter buildable (map buildInfo exes))
+ allE = libE ++ exeE
+
+ notFound = [ p | p <- allE, isNothing (staticTranslateExtraLib p) ]
+ found = [ p | Just p <- map staticTranslateExtraLib allE ]
+
+any_c_p_s_u :: String -> String -> Portage.SlotDepend -> [Portage.UseFlag] -> Portage.Dependency
+any_c_p_s_u cat pn slot uses = Portage.Atom (Portage.mkPackageName cat pn)
+ (Portage.DRange Portage.ZeroB Portage.InfinityB)
+ (Portage.DAttr slot uses)
+
+any_c_p :: String -> String -> Portage.Dependency
+any_c_p cat pn = any_c_p_s_u cat pn Portage.AnySlot []
+
+at_least_c_p_v :: String -> String -> [Int] -> Portage.Dependency
+at_least_c_p_v cat pn v = Portage.Atom (Portage.mkPackageName cat pn)
+ (Portage.DRange (Portage.NonstrictLB (Portage.Version v Nothing [] 0)) Portage.InfinityB)
+ (Portage.DAttr Portage.AnySlot [])
+
+staticTranslateExtraLib :: String -> Maybe Portage.Dependency
+staticTranslateExtraLib lib = lookup lib m
+ where
+ m = [ ("z", any_c_p "sys-libs" "zlib")
+ , ("bz2", any_c_p "app-arch" "bzip2")
+ , ("mysqlclient", at_least_c_p_v "virtual" "mysql" [4,0])
+ , ("pq", at_least_c_p_v "dev-db" "postgresql-base" [7])
+ , ("ev", any_c_p "dev-libs" "libev")
+ , ("expat", any_c_p "dev-libs" "expat")
+ , ("curl", any_c_p "net-misc" "curl")
+ , ("xml2", any_c_p "dev-libs" "libxml2")
+ , ("mecab", any_c_p "app-text" "mecab")
+ , ("zmq", any_c_p "net-libs" "zeromq")
+ , ("SDL", any_c_p "media-libs" "libsdl")
+ , ("adns", any_c_p "net-libs" "adns")
+ , ("pcre", any_c_p "dev-libs" "libpcre")
+ , ("GL", any_c_p "virtual" "opengl")
+ , ("GLU", any_c_p "virtual" "glu")
+ , ("glut", any_c_p "media-libs" "freeglut")
+ , ("X11", any_c_p "x11-libs" "libX11")
+ , ("libzip", any_c_p "dev-libs" "libzip")
+ , ("ssl", any_c_p "dev-libs" "openssl")
+ , ("Judy", any_c_p "dev-libs" "judy")
+ , ("fcgi", any_c_p "dev-libs" "fcgi")
+ , ("gnutls", any_c_p "net-libs" "gnutls")
+ , ("idn", any_c_p "net-dns" "libidn")
+ , ("tre", any_c_p "dev-libs" "tre")
+ , ("m", any_c_p "virtual" "libc")
+ , ("asound", any_c_p "media-libs" "alsa-lib")
+ , ("sqlite3", at_least_c_p_v "dev-db" "sqlite" [3,0])
+ , ("stdc++", any_c_p_s_u "sys-devel" "gcc" Portage.AnySlot [Portage.mkUse "cxx"])
+ , ("crack", any_c_p "sys-libs" "cracklib")
+ , ("exif", any_c_p "media-libs" "libexif")
+ , ("IL", any_c_p "media-libs" "devil")
+ , ("Imlib2", any_c_p "media-libs" "imlib2")
+ , ("pcap", any_c_p "net-libs" "libpcap")
+ , ("lber", any_c_p "net-nds" "openldap")
+ , ("ldap", any_c_p "net-nds" "openldap")
+ , ("expect", any_c_p "dev-tcltk" "expect")
+ , ("tcl", any_c_p "dev-lang" "tcl")
+ , ("Xext", any_c_p "x11-libs" "libXext")
+ , ("Xrandr", any_c_p "x11-libs" "libXrandr")
+ , ("crypto", any_c_p "dev-libs" "openssl")
+ , ("gmp", any_c_p "dev-libs" "gmp")
+ , ("fuse", any_c_p "sys-fs" "fuse")
+ , ("zip", any_c_p "dev-libs" "libzip")
+ , ("QtCore", any_c_p "dev-qt" "qtcore")
+ , ("QtDeclarative", any_c_p "dev-qt" "qtdeclarative")
+ , ("QtGui", any_c_p "dev-qt" "qtgui")
+ , ("QtOpenGL", any_c_p "dev-qt" "qtopengl")
+ , ("QtScript", any_c_p "dev-qt" "qtscript")
+ , ("gsl", any_c_p "sci-libs" "gsl")
+ , ("gslcblas", any_c_p "sci-libs" "gsl")
+ , ("mkl_core", any_c_p "sci-libs" "mkl")
+ , ("mkl_intel_lp64", any_c_p "sci-libs" "mkl")
+ , ("mkl_lapack", any_c_p "sci-libs" "mkl")
+ , ("mkl_sequential", any_c_p "sci-libs" "mkl")
+ , ("Xi", any_c_p "x11-libs" "libXi")
+ , ("Xxf86vm", any_c_p "x11-libs" "libXxf86vm")
+ , ("pthread", any_c_p "virtual" "libc")
+ , ("panelw", any_c_p "sys-libs" "ncurses")
+ , ("ncursesw", any_c_p "sys-libs" "ncurses")
+ , ("ftgl", any_c_p "media-libs" "ftgl")
+ , ("glpk", any_c_p "sci-mathematics" "glpk")
+ , ("sndfile", any_c_p "media-libs" "libsndfile")
+ , ("portaudio", any_c_p "media-libs" "portaudio")
+ , ("icudata", any_c_p "dev-libs" "icu")
+ , ("icui18n", any_c_p "dev-libs" "icu")
+ , ("icuuc", any_c_p "dev-libs" "icu")
+ , ("chipmunk", any_c_p "sci-physics" "chipmunk")
+ ]
+
+---------------------------------------------------------------
+-- Build Tools
+---------------------------------------------------------------
+
+buildToolsDependencies :: PackageDescription -> [Portage.Dependency]
+buildToolsDependencies (PackageDescription { library = lib, executables = exes }) = nub $
+ [ case pkg of
+ Just p -> p
+ Nothing -> trace ("WARNING: Unknown build tool '" ++ pn ++ "'. Check the generated ebuild.")
+ (any_c_p "unknown-build-tool" pn)
+ | Cabal.Dependency (Cabal.PackageName pn) _range <- cabalDeps
+ , pkg <- return (lookup pn buildToolsTable)
+ ]
+ where
+ cabalDeps = filter notProvided $ depL ++ depE
+ depL = maybe [] (buildTools.libBuildInfo) lib
+ depE = concatMap buildTools (filter buildable (map buildInfo exes))
+ notProvided (Cabal.Dependency (Cabal.PackageName pn) _range) = pn `notElem` buildToolsProvided
+
+buildToolsTable :: [(String, Portage.Dependency)]
+buildToolsTable =
+ [ ("happy", any_c_p "dev-haskell" "happy")
+ , ("alex", any_c_p "dev-haskell" "alex")
+ , ("c2hs", any_c_p "dev-haskell" "c2hs")
+ , ("cabal-install", any_c_p "dev-haskell" "cabal-install")
+ , ("gtk2hsTypeGen", any_c_p "dev-haskell" "gtk2hs-buildtools")
+ , ("gtk2hsHookGenerator", any_c_p "dev-haskell" "gtk2hs-buildtools")
+ , ("gtk2hsC2hs", any_c_p "dev-haskell" "gtk2hs-buildtools")
+ , ("cabal", any_c_p "dev-haskell" "cabal-install")
+ , ("llvm-config", any_c_p "sys-devel" "llvm")
+ , ("cpphs", any_c_p "dev-haskell" "cpphs")
+ ]
+
+-- tools that are provided by ghc or some other existing program
+-- so we do not need dependencies on them
+buildToolsProvided :: [String]
+buildToolsProvided = ["hsc2hs"]
+
+
+---------------------------------------------------------------
+-- pkg-config
+---------------------------------------------------------------
+
+pkgConfigDependencies :: Portage.Overlay -> PackageDescription -> [Portage.Dependency]
+pkgConfigDependencies overlay (PackageDescription { library = lib, executables = exes }) = nub $ resolvePkgConfigs overlay cabalDeps
+ where
+ cabalDeps = depL ++ depE
+ depL = maybe [] (pkgconfigDepends.libBuildInfo) lib
+ depE = concatMap pkgconfigDepends (filter buildable (map buildInfo exes))
+
+resolvePkgConfigs :: Portage.Overlay -> [Cabal.Dependency] -> [Portage.Dependency]
+resolvePkgConfigs overlay cdeps =
+ [ case resolvePkgConfig overlay pkg of
+ Just d -> d
+ Nothing -> trace ("WARNING: Could not resolve pkg-config: " ++ pn ++ ". Check generated ebuild.")
+ (any_c_p "unknown-pkg-config" pn)
+ | pkg@(Cabal.Dependency (Cabal.PackageName pn) _range) <- cdeps ]
+
+resolvePkgConfig :: Portage.Overlay -> Cabal.Dependency -> Maybe Portage.Dependency
+resolvePkgConfig _overlay (Cabal.Dependency (Cabal.PackageName pn) _cabalVersion) = do
+ (cat,portname, slot) <- lookup pn pkgconfig_table
+ return $ any_c_p_s_u cat portname slot []
+
+pkgconfig_table :: [(String, (String, String, Portage.SlotDepend))]
+pkgconfig_table =
+ [
+ ("alsa", ("media-libs", "alsa-lib", Portage.AnySlot))
+ ,("gconf-2.0", ("gnome-base", "gconf", Portage.AnySlot))
+
+ ,("gio-2.0", ("dev-libs", "glib", Portage.GivenSlot "2"))
+ ,("gio-unix-2.0", ("dev-libs", "glib", Portage.GivenSlot "2"))
+ ,("glib-2.0", ("dev-libs", "glib", Portage.GivenSlot "2"))
+ ,("gmodule-2.0", ("dev-libs", "glib", Portage.GivenSlot "2"))
+ ,("gmodule-export-2.0", ("dev-libs", "glib", Portage.GivenSlot "2"))
+ ,("gmodule-no-export-2.0", ("dev-libs", "glib", Portage.GivenSlot "2"))
+ ,("gobject-2.0", ("dev-libs", "glib", Portage.GivenSlot "2"))
+ ,("gthread-2.0", ("dev-libs", "glib", Portage.GivenSlot "2"))
+
+ ,("gtk+-2.0", ("x11-libs", "gtk+", Portage.GivenSlot "2"))
+ ,("gdk-2.0", ("x11-libs", "gtk+", Portage.GivenSlot "2"))
+ ,("gdk-pixbuf-2.0", ("x11-libs", "gtk+", Portage.GivenSlot "2"))
+ ,("gdk-pixbuf-xlib-2.0", ("x11-libs", "gtk+", Portage.GivenSlot "2"))
+ ,("gdk-x11-2.0", ("x11-libs", "gtk+", Portage.GivenSlot "2"))
+ ,("gtk+-unix-print-2.0", ("x11-libs", "gtk+", Portage.GivenSlot "2"))
+ ,("gtk+-x11-2.0", ("x11-libs", "gtk+", Portage.GivenSlot "2"))
+
+ ,("cairo", ("x11-libs", "cairo", Portage.AnySlot)) -- need [svg] for dev-haskell/cairo
+ ,("cairo-ft", ("x11-libs", "cairo", Portage.AnySlot))
+ ,("cairo-ps", ("x11-libs", "cairo", Portage.AnySlot))
+ ,("cairo-png", ("x11-libs", "cairo", Portage.AnySlot))
+ ,("cairo-pdf", ("x11-libs", "cairo", Portage.AnySlot))
+ ,("cairo-svg", ("x11-libs", "cairo", Portage.AnySlot))
+ ,("cairo-xlib", ("x11-libs", "cairo", Portage.AnySlot))
+ ,("cairo-xlib-xrender", ("x11-libs", "cairo", Portage.AnySlot))
+
+ ,("pangocairo", ("x11-libs", "pango", Portage.AnySlot))
+ ,("pangoft2", ("x11-libs", "pango", Portage.AnySlot))
+ ,("pango", ("x11-libs", "pango", Portage.AnySlot))
+ ,("pangoxft", ("x11-libs", "pango", Portage.AnySlot))
+ ,("pangox", ("x11-libs", "pango", Portage.AnySlot))
+
+ ,("libglade-2.0", ("gnome-base", "libglade", Portage.AnySlot))
+ ,("gnome-vfs-2.0", ("gnome-base", "gnome-vfs", Portage.AnySlot))
+ ,("gnome-vfs-module-2.0", ("gnome-base", "gnome-vfs", Portage.AnySlot))
+ ,("webkit-1.0", ("net-libs","webkit-gtk", Portage.GivenSlot "2"))
+
+ ,("gstreamer-0.10", ("media-libs", "gstreamer", Portage.AnySlot))
+ ,("gstreamer-base-0.10", ("media-libs", "gstreamer", Portage.AnySlot))
+ ,("gstreamer-check-0.10", ("media-libs", "gstreamer", Portage.AnySlot))
+ ,("gstreamer-controller-0.10", ("media-libs", "gstreamer", Portage.AnySlot))
+ ,("gstreamer-dataprotocol-0.10", ("media-libs", "gstreamer", Portage.AnySlot))
+ ,("gstreamer-net-0.10", ("media-libs", "gstreamer", Portage.AnySlot))
+
+ ,("gstreamer-app-0.10", ("media-libs", "gst-plugins-base", Portage.AnySlot))
+ ,("gstreamer-audio-0.10", ("media-libs", "gst-plugins-base", Portage.AnySlot))
+ ,("gstreamer-video-0.10", ("media-libs", "gst-plugins-base", Portage.AnySlot))
+ ,("gstreamer-plugins-base-0.10", ("media-libs", "gst-plugins-base", Portage.AnySlot))
+
+ ,("gtksourceview-2.0", ("x11-libs", "gtksourceview", Portage.GivenSlot "2.0"))
+ ,("librsvg-2.0", ("gnome-base","librsvg", Portage.AnySlot))
+ ,("vte", ("x11-libs","vte", Portage.GivenSlot "0"))
+ ,("gtkglext-1.0", ("x11-libs","gtkglext", Portage.AnySlot))
+
+ ,("curl", ("net-misc", "curl", Portage.AnySlot))
+ ,("libxml2", ("dev-libs", "libxml2", Portage.AnySlot))
+ ,("libgsasl", ("virtual", "gsasl", Portage.AnySlot))
+ ,("libzip", ("dev-libs", "libzip", Portage.AnySlot))
+ ,("gnutls", ("net-libs", "gnutls", Portage.AnySlot))
+ ,("libidn", ("net-dns", "libidn", Portage.AnySlot))
+ ,("libxml-2.0", ("dev-libs", "libxml2", Portage.AnySlot))
+ ,("yaml-0.1", ("dev-libs", "libyaml", Portage.AnySlot))
+ ,("QtCore", ("dev-qt", "qtcore", Portage.AnySlot))
+ ,("lua", ("dev-lang", "lua", Portage.AnySlot))
+ ,("QtDeclarative", ("dev-qt", "qtdeclarative", Portage.AnySlot))
+ ,("QtGui", ("dev-qt", "qtgui", Portage.AnySlot))
+ ,("QtOpenGL", ("dev-qt", "qtopengl", Portage.AnySlot))
+ ,("QtScript", ("dev-qt", "qtscript", Portage.AnySlot))
+ ,("ImageMagick", ("media-gfx", "imagemagick", Portage.AnySlot))
+ ,("MagickWand", ("media-gfx", "imagemagick", Portage.AnySlot))
+ ]
diff --git a/Overlays.hs b/Overlays.hs
new file mode 100644
index 0000000..6a4614a
--- /dev/null
+++ b/Overlays.hs
@@ -0,0 +1,71 @@
+module Overlays
+ ( getOverlayPath
+ ) where
+
+import Control.Monad
+import Data.List (nub, inits)
+import Data.Maybe (maybeToList, listToMaybe, isJust, fromJust)
+import System.Directory
+import System.FilePath ((</>), splitPath, joinPath)
+
+import Error
+import CacheFile
+import Portage.Host
+
+-- 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] -> IO String
+ search mul = do
+ let loop [] = throwEx (MultipleOverlays mul)
+ loop (x:xs) = do
+ info verbosity $ "Checking '" ++ x ++ "'..."
+ found <- doesFileExist (cacheFile x)
+ if found
+ 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
+ info verbosity $ "I choose " ++ overlay
+ info verbosity "Override my decision with hackport --overlay /my/overlay"
+ return overlay
+
+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)
+
+ where
+ probe dir = doesDirectoryExist (dir </> "dev-haskell")
+
diff --git a/Portage/Cabal.hs b/Portage/Cabal.hs
new file mode 100644
index 0000000..e23e2c7
--- /dev/null
+++ b/Portage/Cabal.hs
@@ -0,0 +1,36 @@
+module Portage.Cabal
+ ( fromOverlay
+ , convertLicense
+ ) where
+
+import qualified Data.Map as Map
+
+import qualified Distribution.Client.PackageIndex as Cabal
+import qualified Distribution.License as Cabal
+import qualified Distribution.Text 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
+ ]
+
+-- map the cabal license type to the gentoo license string format
+convertLicense :: Cabal.License -> Either String String
+convertLicense l =
+ case l of
+ -- good ones
+ Cabal.GPL mv -> Right $ "GPL-" ++ (maybe "2" Cabal.display mv) -- almost certainly version 2
+ Cabal.LGPL mv -> Right $ "LGPL-" ++ (maybe "2.1" Cabal.display mv) -- probably version 2.1
+ Cabal.BSD3 -> Right "BSD"
+ Cabal.BSD4 -> Right "BSD-4"
+ Cabal.PublicDomain -> Right "public-domain"
+ Cabal.MIT -> Right "MIT"
+ Cabal.Apache mv -> Right $ "Apache-" ++ (maybe "1.1" Cabal.display mv) -- probably version 1.1
+ -- bad ones
+ Cabal.AllRightsReserved -> Left "EULA-style licence. Please pick it manually."
+ Cabal.UnknownLicense _ -> Left "license unknown to cabal. Please pick it manually."
+ Cabal.OtherLicense -> Left "Please look at license file of package and pick it manually."
diff --git a/Portage/Dependency.hs b/Portage/Dependency.hs
new file mode 100644
index 0000000..6df98bc
--- /dev/null
+++ b/Portage/Dependency.hs
@@ -0,0 +1,119 @@
+module Portage.Dependency
+ (
+ simplify_deps
+ , simplifyUseDeps
+ , sortDeps
+
+ -- reexports
+ , module Portage.Dependency.Builder
+ , module Portage.Dependency.Print
+ , module Portage.Dependency.Types
+ ) where
+
+import Data.Function ( on )
+import Data.List ( nub, groupBy, partition, sortBy )
+import Data.Maybe ( fromJust, mapMaybe )
+import Data.Ord ( comparing )
+
+import Portage.PackageId
+
+import Portage.Dependency.Builder
+import Portage.Dependency.Print
+import Portage.Dependency.Types
+
+mergeDRanges :: DRange -> DRange -> DRange
+mergeDRanges _ r@(DExact _) = r
+mergeDRanges l@(DExact _) _ = l
+mergeDRanges (DRange ll lu) (DRange rl ru) = DRange (max ll rl) (min lu ru)
+
+merge_pair :: Dependency -> Dependency -> Dependency
+merge_pair (Atom lp ld la) (Atom rp rd ra)
+ | lp /= rp = error "merge_pair got different 'PackageName's"
+ | la /= ra = error "merge_pair got different 'DAttr's"
+ | otherwise = Atom lp (mergeDRanges ld rd) la
+merge_pair l r = error $ unwords ["merge_pair can't merge non-atoms:", show l, show r]
+
+-- TODO: remove it in favour of more robust 'normalize_depend'
+simplify_group :: [Dependency] -> Dependency
+simplify_group [x] = x
+simplify_group xs = foldl1 merge_pair xs
+
+-- TODO: remove it in favour of more robust 'normalize_depend'
+-- divide packages to groups (by package name), simplify groups, merge again
+simplify_deps :: [Dependency] -> [Dependency]
+simplify_deps deps = flattenDep $
+ (map (simplify_group.nub) $
+ groupBy cmpPkgName $
+ sortBy (comparing getPackagePart) 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
+ --
+ flattenDep :: [Dependency] -> [Dependency]
+ flattenDep [] = []
+ flattenDep (DependAllOf ds:xs) = (concatMap (\x -> flattenDep [x]) ds) ++ flattenDep xs
+ flattenDep (x:xs) = x:flattenDep xs
+ -- TODO concat 2 dep either in the same group
+
+getPackage :: Dependency -> Maybe PackageName
+getPackage (DependAllOf _dependency) = Nothing
+getPackage (Atom pn _dr _attrs) = Just pn
+getPackage (DependAnyOf _dependency ) = Nothing
+getPackage (DependIfUse _useFlag _Dependency) = Nothing
+
+getPackagePart :: Dependency -> PackageName
+getPackagePart dep = fromJust (getPackage dep)
+
+-- | remove all Use dependencies that overlap with normal dependencies
+simplifyUseDeps :: [Dependency] -- list where use deps is taken
+ -> [Dependency] -- list where common deps is taken
+ -> [Dependency] -- result deps
+simplifyUseDeps ds cs =
+ let (u,o) = partition isUseDep ds
+ c = mapMaybe getPackage cs
+ in (mapMaybe (intersectD c) u)++o
+
+intersectD :: [PackageName] -> Dependency -> Maybe Dependency
+intersectD fs (DependIfUse u d) = intersectD fs d >>= Just . DependIfUse u
+intersectD fs (DependAnyOf ds) =
+ let ds' = mapMaybe (intersectD fs) ds
+ in if null ds' then Nothing else Just (DependAnyOf ds')
+intersectD fs (DependAllOf ds) =
+ let ds' = mapMaybe (intersectD fs) ds
+ in if null ds' then Nothing else Just (DependAllOf ds')
+intersectD fs x =
+ let pkg = fromJust $ getPackage x -- this is unsafe but will save from error later
+ in if any (==pkg) fs then Nothing else Just x
+
+isUseDep :: Dependency -> Bool
+isUseDep (DependIfUse _ _) = True
+isUseDep _ = False
+
+
+sortDeps :: [Dependency] -> [Dependency]
+sortDeps = sortBy dsort . map deeper
+ where
+ deeper :: Dependency -> Dependency
+ deeper (DependIfUse u1 d) = DependIfUse u1 $ deeper d
+ deeper (DependAllOf ds) = DependAllOf $ sortDeps ds
+ deeper (DependAnyOf ds) = DependAnyOf $ sortDeps ds
+ deeper x = x
+ dsort :: Dependency -> Dependency -> Ordering
+ dsort (DependIfUse u1 _) (DependIfUse u2 _) = u1 `compare` u2
+ dsort (DependIfUse _ _) (DependAnyOf _) = LT
+ dsort (DependIfUse _ _) (DependAllOf _) = LT
+ dsort (DependIfUse _ _) _ = GT
+ dsort (DependAnyOf _) (DependAnyOf _) = EQ
+ dsort (DependAnyOf _) (DependIfUse _ _) = GT
+ dsort (DependAnyOf _) (DependAllOf _) = LT
+ dsort (DependAnyOf _) _ = GT
+ dsort (DependAllOf _) (DependAllOf _) = EQ
+ dsort (DependAllOf _) (DependIfUse _ _) = LT
+ dsort (DependAllOf _) (DependAnyOf _) = GT
+ dsort _ (DependIfUse _ _) = LT
+ dsort _ (DependAllOf _) = LT
+ dsort _ (DependAnyOf _) = LT
+ dsort a b = (compare `on` getPackage) a b
diff --git a/Portage/Dependency/Builder.hs b/Portage/Dependency/Builder.hs
new file mode 100644
index 0000000..db2f3d1
--- /dev/null
+++ b/Portage/Dependency/Builder.hs
@@ -0,0 +1,25 @@
+{- | Basic helpers to build depend structures -}
+module Portage.Dependency.Builder
+ (
+ empty_dependency
+ , addDepUseFlag
+ , setSlotDep
+ ) where
+
+import Portage.Dependency.Types
+import Portage.Use
+
+empty_dependency :: Dependency
+empty_dependency = DependAllOf []
+
+addDepUseFlag :: UseFlag -> Dependency -> Dependency
+addDepUseFlag n (DependAllOf d) = DependAllOf $ map (addDepUseFlag n) d
+addDepUseFlag n (Atom pn dr (DAttr s u)) = Atom pn dr (DAttr s (n:u))
+addDepUseFlag n (DependAnyOf d) = DependAnyOf $ map (addDepUseFlag n) d
+addDepUseFlag n (DependIfUse u d) = DependIfUse u (addDepUseFlag n d)
+
+setSlotDep :: SlotDepend -> Dependency -> Dependency
+setSlotDep n (DependAllOf d) = DependAllOf $ map (setSlotDep n) d
+setSlotDep n (Atom pn dr (DAttr _s u)) = Atom pn dr (DAttr n u)
+setSlotDep n (DependAnyOf d) = DependAnyOf $ map (setSlotDep n) d
+setSlotDep n (DependIfUse u d) = DependIfUse u (setSlotDep n d)
diff --git a/Portage/Dependency/Normalize.hs b/Portage/Dependency/Normalize.hs
new file mode 100644
index 0000000..401292d
--- /dev/null
+++ b/Portage/Dependency/Normalize.hs
@@ -0,0 +1,261 @@
+module Portage.Dependency.Normalize
+ (
+ normalize_depend
+ ) where
+
+import qualified Data.List as L
+
+import Portage.Dependency.Types
+
+mergeDRanges :: DRange -> DRange -> DRange
+mergeDRanges _ r@(DExact _) = r
+mergeDRanges l@(DExact _) _ = l
+mergeDRanges (DRange ll lu) (DRange rl ru) = DRange (max ll rl) (min lu ru)
+
+-- TODO: remove it and switch to 'SatisfiedDepend' instead
+empty_dependency :: Dependency
+empty_dependency = DependAllOf []
+
+is_empty_dependency :: Dependency -> Bool
+is_empty_dependency (DependIfUse _use dep) = is_empty_dependency dep
+is_empty_dependency (DependAnyOf []) = True -- because any (const True) == False
+is_empty_dependency (DependAnyOf deps) = any is_empty_dependency deps
+is_empty_dependency (DependAllOf deps) = all is_empty_dependency deps
+is_empty_dependency (Atom _pn _dr _dattr) = False
+
+-- remove one layer of redundancy
+normalization_step :: Dependency -> Dependency
+normalization_step = combine_atoms
+ . propagate_context
+ . flatten
+ . lift_context
+ . remove_duplicates
+ . remove_empty
+ . sort_deps
+ . combine_use_guards
+ . combine_use_counterguards
+
+remove_empty :: Dependency -> Dependency
+remove_empty d =
+ case d of
+ -- drop full empty nodes
+ _ | is_empty_dependency d -> empty_dependency
+ -- drop partial empty nodes
+ (DependIfUse use dep) -> DependIfUse use $ remove_empty dep
+ (DependAllOf deps) -> DependAllOf $ filter (not . is_empty_dependency) $ map remove_empty deps
+ (DependAnyOf deps) -> DependAnyOf $ map remove_empty deps
+ -- no change
+ (Atom _pn _dr _dattr) -> d
+
+-- Ideally 'combine_atoms' should handle those as well
+remove_duplicates :: Dependency -> Dependency
+remove_duplicates d =
+ case d of
+ (DependIfUse use dep) -> (DependIfUse use $ remove_duplicates dep)
+ (DependAnyOf deps) -> DependAnyOf $ L.nub $ map remove_duplicates deps
+ (DependAllOf deps) -> DependAllOf $ L.nub $ map remove_duplicates deps
+ (Atom _pn _dr _dattr) -> d
+
+-- TODO: implement flattening (if not done yet in other phases)
+-- DependAnyOf [DependAnyOf [something], rest] -> DependAnyOf $ something ++ rest
+-- DependAllOf [DependAllOf [something], rest] -> DependAllOf $ something ++ rest
+flatten :: Dependency -> Dependency
+flatten d =
+ case d of
+ (DependIfUse use dep) -> DependIfUse use (flatten dep)
+ (DependAnyOf [dep]) -> flatten dep
+ (DependAllOf [dep]) -> flatten dep
+ (DependAnyOf deps) -> DependAnyOf $ map flatten deps
+ (DependAllOf deps) -> DependAllOf $ map flatten deps
+ (Atom _pn _dr _dattr) -> d
+
+-- TODO: join atoms with different version constraints
+-- DependAllOf [ DRange ">=foo-1" Inf, Drange Zero "<foo-2" ] -> DRange ">=foo-1" "<foo-2"
+combine_atoms :: Dependency -> Dependency
+combine_atoms d =
+ case d of
+ (DependIfUse use dep) -> DependIfUse use (combine_atoms dep)
+ (DependAllOf deps) -> DependAllOf $ map combine_atoms $ find_intersections deps
+ (DependAnyOf deps) -> DependAnyOf $ map combine_atoms $ find_concatenations deps
+ (Atom _pn _dr _dattr) -> d
+
+find_intersections :: [Dependency] -> [Dependency]
+find_intersections = map merge_depends . L.groupBy is_mergeable
+ where is_mergeable :: Dependency -> Dependency -> Bool
+ is_mergeable (Atom lpn _ldrange lattr) (Atom rpn _rdrange rattr) = (lpn, lattr) == (rpn, rattr)
+ is_mergeable _ _ = False
+
+ merge_depends :: [Dependency] -> Dependency
+ merge_depends [x] = x
+ merge_depends xs = foldl1 merge_pair xs
+
+ merge_pair :: Dependency -> Dependency -> Dependency
+ merge_pair (Atom lp ld la) (Atom rp rd ra)
+ | lp /= rp = error "merge_pair got different 'PackageName's"
+ | la /= ra = error "merge_pair got different 'DAttr's"
+ | otherwise = Atom lp (mergeDRanges ld rd) la
+ merge_pair l r = error $ unwords ["merge_pair can't merge non-atoms:", show l, show r]
+
+-- TODO
+find_concatenations :: [Dependency] -> [Dependency]
+find_concatenations = id
+
+-- Eliminate use guarded redundancy:
+-- a? ( foo )
+-- a? ( bar )
+-- gets translated to
+-- a? ( foo bar )
+combine_use_guards :: Dependency -> Dependency
+combine_use_guards d =
+ case d of
+ (DependIfUse use dep) -> DependIfUse use (combine_use_guards dep)
+ (DependAllOf deps) -> DependAllOf $ map combine_use_guards $ find_use_intersections deps
+ (DependAnyOf deps) -> DependAnyOf $ map combine_use_guards $ find_use_concatenations deps
+ (Atom _pn _dr _dattr) -> d
+ where -- TODO
+ find_use_concatenations :: [Dependency] -> [Dependency]
+ find_use_concatenations = id
+ find_use_intersections :: [Dependency] -> [Dependency]
+ find_use_intersections = map merge_use_intersections . L.groupBy is_use_mergeable
+ where
+ is_use_mergeable :: Dependency -> Dependency -> Bool
+ is_use_mergeable (DependIfUse lu _ld) (DependIfUse ru _rd)
+ | lu == ru = True
+ is_use_mergeable _ _ = False
+ merge_use_intersections :: [Dependency] -> Dependency
+ merge_use_intersections [x] = x
+ merge_use_intersections ~(DependIfUse u dep : ds) = DependIfUse u $ DependAllOf (dep : [d' | (DependIfUse _u d') <- ds])
+
+-- Eliminate use guarded redundancy:
+-- a? ( foo bar )
+-- !a? ( foo baz )
+-- gets translated to
+-- foo
+-- a? ( bar )
+-- !a? ( baz )
+combine_use_counterguards :: Dependency -> Dependency
+combine_use_counterguards d =
+ case d of
+ (DependIfUse use dep) -> DependIfUse use (combine_use_counterguards dep)
+ (DependAllOf deps) -> DependAllOf $ map combine_use_counterguards $ find_use_intersections deps
+ (DependAnyOf deps) -> DependAnyOf $ map combine_use_counterguards $ find_use_concatenations deps
+ (Atom _pn _dr _dattr) -> d
+ where -- TODO
+ find_use_concatenations :: [Dependency] -> [Dependency]
+ find_use_concatenations = id
+ find_use_intersections :: [Dependency] -> [Dependency]
+ find_use_intersections = concatMap merge_use_intersections . L.groupBy is_counteruse_mergeable
+ where
+ is_counteruse_mergeable :: Dependency -> Dependency -> Bool
+ is_counteruse_mergeable (DependIfUse (DUse (lb,lu)) _ld) (DependIfUse (DUse (rb, ru)) _rd)
+ -- lookup 'a?' and '!a?'
+ | lu == ru && lb == not rb = True
+ is_counteruse_mergeable _ _ = False
+ merge_use_intersections :: [Dependency] -> [Dependency]
+ merge_use_intersections [(DependIfUse _lu ld), (DependIfUse _ru rd)]
+ -- very simple special case,
+ -- as we can't look through nested use guards
+ | ld == rd = [ld]
+ merge_use_intersections deps@[(DependIfUse _lu ld), (DependIfUse _ru rd)] =
+ case common_ctx of
+ [] -> deps
+ _ -> [propagate_context $ DependAllOf $ common_ctx ++ deps ]
+ where ld_ctx = lift_context' ld
+ rd_ctx = lift_context' rd
+ common_ctx = ld_ctx `L.intersect` rd_ctx
+ merge_use_intersections x = x
+
+-- Eliminate top-down redundancy:
+-- foo/bar
+-- u? ( foo/bar
+-- bar/baz )
+-- gets translated to
+-- foo/bar
+-- u? ( bar/baz )
+propagate_context :: Dependency -> Dependency
+propagate_context = propagate_context' []
+
+-- very simple model: pick all sibling-atom deps and add them to context
+-- for downward proparation and remove from 'all_of' part
+-- TODO: any-of part can benefit from it by removing unsatisfiable or satisfied alternative
+-- TODO: remove use-guarded redundancy
+-- a? ( x y z )
+-- test? ( a? ( y z t ) )
+-- can be reduced to
+-- a? ( x y z )
+-- test? ( a? ( t ) )
+propagate_context' :: [Dependency] -> Dependency -> Dependency
+propagate_context' ctx d =
+ case d of
+ (DependIfUse use dep) -> DependIfUse use (go ctx dep)
+ (DependAllOf deps) -> DependAllOf $ [ go ctx' dep
+ | dep <- deps
+ , let atom_deps = [ a
+ | a@(Atom _pn _dp _dattr) <- deps
+ , a /= dep ]
+ , let ctx' = ctx ++ atom_deps
+ ]
+ (DependAnyOf deps) -> DependAnyOf $ map (go ctx) deps
+ -- 'd' is already satisfied by 'ctx' constraint
+ (Atom _pn _dr _dattr) -> case any (\ctx_e -> ctx_e `dep_is_case_of` d) ctx of
+ True -> empty_dependency
+ False -> d
+ where go c = propagate_context' c
+
+-- Eliminate bottom-up redundancy:
+-- || ( ( foo/bar bar/baz )
+-- ( foo/bar bar/quux ) )
+-- gets translated to
+-- foo/bar
+-- || ( ( foo/bar bar/baz )
+-- ( foo/bar bar/quux ) )
+-- It looks like became more gross,
+-- but 'propagate_context' phase
+-- cleanups it to the following state:
+-- foo/bar
+-- || ( bar/baz
+-- bar/quux )
+
+lift_context :: Dependency -> Dependency
+lift_context d =
+ case d of
+ (DependIfUse _use _dep) -> d
+ (DependAllOf deps) -> DependAllOf $ deps ++ (new_ctx L.\\ deps)
+ -- the lift itself
+ (DependAnyOf _deps) -> case L.null new_ctx of
+ True -> d -- nothing is shared downwards
+ False -> propagate_context $ DependAllOf $ new_ctx ++ [d]
+ (Atom _pn _dr _dattr) -> d
+ where new_ctx = lift_context' d
+
+-- very simple model: pick all sibling-atom deps and add them to context
+-- for upward proparation and intersect with 'all_of' parts
+lift_context' :: Dependency -> [Dependency]
+lift_context' d =
+ case d of
+ (DependIfUse _use _dep) -> []
+ (DependAllOf deps) -> [dep | dep@(Atom _pn _dr _dattr) <- deps]
+ (DependAnyOf deps) -> case map lift_context' deps of
+ [] -> []
+ ctxes -> foldl1 L.intersect ctxes
+ (Atom _pn _dr _dattr) -> [d]
+
+-- reorders depends to make them more attractive
+-- for other normalization algorithms
+-- TODO: add all logic from 'sortDeps' here
+sort_deps :: Dependency -> Dependency
+sort_deps d =
+ case d of
+ (DependIfUse lhs (DependIfUse rhs dep))
+ | rhs < lhs -> DependIfUse rhs $ sort_deps $ DependIfUse lhs dep
+ (DependIfUse use dep) -> DependIfUse use $ sort_deps dep
+ (DependAnyOf deps) -> DependAnyOf $ map sort_deps deps
+ (DependAllOf deps) -> DependAllOf $ map sort_deps deps
+ (Atom _pn _dr _dattr) -> d
+
+-- remove various types of redundancy
+normalize_depend :: Dependency -> Dependency
+normalize_depend d = next_step next_d
+ where next_d = normalization_step d
+ next_step | d == next_d = id
+ | otherwise = normalize_depend
diff --git a/Portage/Dependency/Print.hs b/Portage/Dependency/Print.hs
new file mode 100644
index 0000000..189a1c8
--- /dev/null
+++ b/Portage/Dependency/Print.hs
@@ -0,0 +1,87 @@
+module Portage.Dependency.Print
+ (
+ dep2str
+ , dep2str_denorm -- for debugging
+ ) where
+
+import Portage.Version
+import Portage.Use
+
+import Portage.PackageId
+
+import Distribution.Text ( Text(..) )
+import qualified Text.PrettyPrint as Disp
+import Text.PrettyPrint ( (<>), vcat, nest, render )
+
+import Portage.Dependency.Normalize
+import Portage.Dependency.Types
+
+dispSlot :: SlotDepend -> Disp.Doc
+dispSlot AnySlot = Disp.empty
+dispSlot AnyBuildTimeSlot = Disp.text ":="
+dispSlot (GivenSlot slot) = Disp.text (':' : slot)
+
+dispLBound :: PackageName -> LBound -> Disp.Doc
+dispLBound pn (StrictLB v) = Disp.char '>' <> disp pn <-> disp v
+dispLBound pn (NonstrictLB v) = Disp.text ">=" <> disp pn <-> disp v
+dispLBound _pn ZeroB = error "unhandled 'dispLBound ZeroB'"
+
+dispUBound :: PackageName -> UBound -> Disp.Doc
+dispUBound pn (StrictUB v) = Disp.char '<' <> disp pn <-> disp v
+dispUBound pn (NonstrictUB v) = Disp.text "<=" <> disp pn <-> disp v
+dispUBound _pn InfinityB = error "unhandled 'dispUBound Infinity'"
+
+dispDAttr :: DAttr -> Disp.Doc
+dispDAttr (DAttr s u) = dispSlot s <> dispUses u
+
+dispDUse :: DUse -> Disp.Doc
+dispDUse (DUse (is_enabled, name)) = prefix is_enabled <> Disp.text name <> Disp.char '?'
+ where prefix True = Disp.empty
+ prefix False = Disp.char '!'
+
+dep2str :: Int -> Dependency -> String
+dep2str start_indent = render . nest start_indent . showDepend . normalize_depend
+
+dep2str_denorm :: Dependency -> String
+dep2str_denorm = render . showDepend
+
+(<->) :: Disp.Doc -> Disp.Doc -> Disp.Doc
+a <-> b = a <> Disp.char '-' <> b
+
+sp :: Disp.Doc
+sp = Disp.char ' '
+
+sparens :: Disp.Doc -> Disp.Doc
+sparens doc = Disp.parens (sp <> valign doc <> sp)
+
+valign :: Disp.Doc -> Disp.Doc
+valign d = nest 0 d
+
+showDepend :: Dependency -> Disp.Doc
+showDepend (Atom pn range dattr)
+ = case range of
+ -- any version
+ DRange ZeroB InfinityB -> disp pn <> dispDAttr dattr
+ DRange ZeroB ub -> dispUBound pn ub <> dispDAttr dattr
+ DRange lb InfinityB -> dispLBound pn lb <> dispDAttr dattr
+ -- TODO: handle >=foo-0 special case
+ -- TODO: handle =foo-x.y.* special case
+ DRange lb ub -> showDepend (Atom pn (DRange lb InfinityB) dattr)
+ <> Disp.char ' '
+ <> showDepend (Atom pn (DRange ZeroB ub) dattr)
+ DExact v -> Disp.char '~' <> disp pn <-> disp v { versionRevision = 0 } <> dispDAttr dattr
+
+showDepend (DependIfUse u dep) = dispDUse u <> sp <> sparens (showDepend dep)
+showDepend (DependAnyOf deps) = Disp.text "||" <> sp <> sparens (vcat $ map showDependInAnyOf deps)
+showDepend (DependAllOf deps) = valign $ vcat $ map showDepend deps
+
+-- needs special grouping
+showDependInAnyOf :: Dependency -> Disp.Doc
+showDependInAnyOf d@(DependAllOf _deps) = sparens (showDepend d)
+-- both lower and upper bounds are present thus needs 2 atoms
+-- TODO: '=foo-x.y.*' will take only one atom, not two
+showDependInAnyOf d@(Atom _pn (DRange lb ub) _dattr)
+ | lb /= ZeroB && ub /= InfinityB
+ = sparens (showDepend d)
+-- rest are fine
+showDependInAnyOf d = showDepend d
diff --git a/Portage/Dependency/Types.hs b/Portage/Dependency/Types.hs
new file mode 100644
index 0000000..4ac1b8b
--- /dev/null
+++ b/Portage/Dependency/Types.hs
@@ -0,0 +1,96 @@
+module Portage.Dependency.Types
+ (
+ SlotDepend(..)
+ , LBound(..)
+ , UBound(..)
+ , DRange(..)
+ , DAttr(..)
+ , DUse(..)
+ , Dependency(..)
+ , dep_is_case_of
+ ) where
+
+import Portage.PackageId
+import Portage.Use
+
+data SlotDepend = AnySlot -- nothing special
+ | AnyBuildTimeSlot -- ':='
+ | GivenSlot String -- ':slotno'
+ deriving (Eq, Show)
+
+data LBound = StrictLB Version
+ | NonstrictLB Version
+ | ZeroB
+ deriving (Eq, Show)
+
+instance Ord LBound where
+ compare ZeroB ZeroB = EQ
+ compare ZeroB _ = LT
+ compare _ ZeroB = GT
+ compare (StrictLB lv) (StrictLB rv) = compare lv rv
+ compare (NonstrictLB lv) (NonstrictLB rv) = compare lv rv
+ compare l r = error $ unlines ["i am too lazy to implement LBound: compare"
+ , show l
+ , show r]
+
+data UBound = StrictUB Version -- <
+ | NonstrictUB Version -- <=
+ | InfinityB
+ deriving (Eq, Show)
+
+instance Ord UBound where
+ compare InfinityB InfinityB = EQ
+ compare InfinityB _ = GT
+ compare _ InfinityB = LT
+ compare (NonstrictUB lv) (NonstrictUB rv) = compare lv rv
+ compare (StrictUB lv) (StrictUB rv) = compare lv rv
+ compare l r = error $ unlines ["i am too lazy to implement UBound: compare"
+ , show l
+ , show r]
+
+data DRange = DRange LBound UBound
+ | DExact Version
+ deriving (Eq, Show)
+
+-- True if 'left' "interval" is a nonstrict subset of 'right' "interval"
+range_is_case_of :: DRange -> DRange -> Bool
+range_is_case_of (DRange llow lup) (DRange rlow rup)
+ | llow >= rlow && lup <= rup = True
+range_is_case_of _ _ = False
+
+data DAttr = DAttr SlotDepend [UseFlag]
+ deriving (Eq, Show)
+
+-- Simplified version of 'UseFlag'
+-- used as a guarding depend:
+-- foo? ( ... )
+-- !foo? ( ... )
+data DUse = DUse (Bool, Use)
+ deriving (Eq, Show)
+
+-- sort order:
+-- a? < b?
+-- a? < !a?
+-- but 'test?' is special
+instance Ord DUse where
+ compare (DUse (lb, lname)) (DUse (rb, rname)) =
+ case (lname, rname, compare lname rname) of
+ (_, _, EQ) -> compare rb lb
+ ("test", _, _) -> LT
+ (_, "test", _) -> GT
+ (_, _, v) -> v
+
+data Dependency = Atom PackageName DRange DAttr
+ | DependIfUse DUse Dependency
+ | DependAnyOf [Dependency]
+ | DependAllOf [Dependency]
+ deriving (Eq, Show)
+
+dep_is_case_of :: Dependency -> Dependency -> Bool
+dep_is_case_of l r
+ -- very broad (not only on atoms) special case
+ | l == r = True
+-- only on atoms
+dep_is_case_of (Atom lpn lr lda) (Atom rpn rr rda)
+ | lpn == rpn && lda == rda = lr `range_is_case_of` rr
+dep_is_case_of _ _ = False
diff --git a/Portage/EBuild.hs b/Portage/EBuild.hs
new file mode 100644
index 0000000..8168eac
--- /dev/null
+++ b/Portage/EBuild.hs
@@ -0,0 +1,214 @@
+module Portage.EBuild
+ ( EBuild(..)
+ , ebuildTemplate
+ , src_uri
+ ) where
+
+import Distribution.Text ( Text(..) )
+import qualified Text.PrettyPrint as Disp
+
+import Portage.Dependency
+
+import Data.String.Utils
+import qualified Data.Function as F
+import qualified Data.List as L
+import Data.Version(Version(..))
+import qualified Paths_hackport(version)
+
+data EBuild = EBuild {
+ name :: String,
+ hackage_name :: String, -- might differ a bit (we mangle case)
+ version :: String,
+ hackportVersion :: String,
+ description :: String,
+ long_desc :: String,
+ homepage :: String,
+ license :: Either String String,
+ slot :: String,
+ keywords :: [String],
+ iuse :: [String],
+ depend :: [Dependency],
+ depend_extra :: [String],
+ rdepend :: [Dependency],
+ rdepend_extra :: [String],
+ features :: [String],
+ my_pn :: Maybe String -- ^ Just 'myOldName' if the package name contains upper characters
+ , src_prepare :: [String] -- ^ raw block for src_prepare() contents
+ , src_configure :: [String] -- ^ raw block for src_configure() contents
+ }
+
+getHackportVersion :: Version -> String
+getHackportVersion Version {versionBranch=(x:s)} = foldl (\y z -> y ++ "." ++ (show z)) (show x) s
+getHackportVersion Version {versionBranch=[]} = ""
+
+ebuildTemplate :: EBuild
+ebuildTemplate = EBuild {
+ name = "foobar",
+ hackage_name = "FooBar",
+ version = "0.1",
+ hackportVersion = getHackportVersion Paths_hackport.version,
+ description = "",
+ long_desc = "",
+ homepage = "http://hackage.haskell.org/package/${HACKAGE_N}",
+ license = Left "unassigned license?",
+ slot = "0",
+ keywords = ["~amd64","~x86"],
+ iuse = [],
+ depend = [],
+ depend_extra = [],
+ rdepend = [],
+ rdepend_extra = [],
+ features = [],
+ my_pn = Nothing
+ , src_prepare = []
+ , src_configure = []
+ }
+
+instance Text EBuild where
+ disp = Disp.text . showEBuild
+
+-- | Given an EBuild, give the URI to the tarball of the source code.
+-- Assumes that the server is always hackage.haskell.org.
+src_uri :: EBuild -> String
+src_uri e =
+ case my_pn e of
+ -- use standard address given that the package name has no upper
+ -- characters
+ Nothing -> "http://hackage.haskell.org/packages/archive/${PN}/${PV}/${P}.tar.gz"
+ -- use MY_X variables (defined in showEBuild) as we've renamed the
+ -- package
+ Just _ -> "http://hackage.haskell.org/packages/archive/${MY_PN}/${PV}/${MY_P}.tar.gz"
+
+showEBuild :: EBuild -> String
+showEBuild ebuild =
+ ss "# Copyright 1999-2013 Gentoo Foundation". nl.
+ ss "# Distributed under the terms of the GNU General Public License v2". nl.
+ ss "# $Header: $". nl.
+ nl.
+ ss "EAPI=5". nl.
+ nl.
+ ss ("# ebuild generated by hackport " ++ hackportVersion ebuild). nl.
+ nl.
+ ss "CABAL_FEATURES=". quote' (sepBy " " $ features ebuild). nl.
+ ss "inherit haskell-cabal". nl.
+ nl.
+ (case my_pn ebuild of
+ Nothing -> id
+ Just pn -> ss "MY_PN=". quote pn. nl.
+ ss "MY_P=". quote "${MY_PN}-${PV}". nl. nl).
+ ss "DESCRIPTION=". quote (description ebuild). nl.
+ ss "HOMEPAGE=". quote (expandVars (homepage ebuild)). nl.
+ ss "SRC_URI=". quote (toMirror $ src_uri ebuild). nl.
+ nl.
+ ss "LICENSE=". (either (\err -> quote "" . ss ("\t# FIXME: " ++ err))
+ quote
+ (license ebuild)). nl.
+ ss "SLOT=". quote (slot ebuild). nl.
+ ss "KEYWORDS=". quote' (sepBy " " $ keywords ebuild).nl.
+ ss "IUSE=". quote' (sepBy " " . sort_iuse $ iuse ebuild). nl.
+ nl.
+ dep_str "RDEPEND" (rdepend_extra ebuild) (rdepend ebuild).
+ dep_str "DEPEND" ( depend_extra ebuild) ( depend ebuild).
+ (case my_pn ebuild of
+ Nothing -> id
+ Just _ -> nl. ss "S=". quote ("${WORKDIR}/${MY_P}"). nl).
+ verbatim (nl. ss "src_prepare() {" . nl)
+ (src_prepare ebuild)
+ (ss "}" . nl).
+ verbatim (nl. ss "src_configure() {" . nl)
+ (src_configure ebuild)
+ (ss "}" . nl).
+ id $ []
+ where
+ expandVars = replaceMultiVars [ ( name ebuild, "${PN}")
+ , (hackage_name ebuild, "${HACKAGE_N}")
+ ]
+ toMirror = replace "http://hackage.haskell.org/" "mirror://hackage/"
+
+-- "+a" -> "a"
+-- "b" -> "b"
+sort_iuse :: [String] -> [String]
+sort_iuse = L.sortBy (compare `F.on` dropWhile ( `elem` "+"))
+
+type DString = String -> String
+
+ss :: String -> DString
+ss = showString
+
+sc :: Char -> DString
+sc = showChar
+
+nl :: DString
+nl = sc '\n'
+
+verbatim :: DString -> [String] -> DString -> DString
+verbatim pre s post =
+ if null s
+ then id
+ else pre .
+ (foldl (\acc v -> acc . ss "\t" . ss v . nl) id s) .
+ post
+
+-- takes string and substitutes tabs to spaces
+-- ebuild's convention is 4 spaces for one tab,
+-- BUT! nested USE flags get moved too much to
+-- right. Thus 8 :]
+tab_size :: Int
+tab_size = 8
+
+tabify_line :: String -> String
+tabify_line l = replicate need_tabs '\t' ++ nonsp
+ where (sp, nonsp) = break (/= ' ') l
+ (full_tabs, t) = length sp `divMod` tab_size
+ need_tabs = full_tabs + if t > 0 then 1 else 0
+
+tabify :: String -> String
+tabify = unlines . map tabify_line . lines
+
+dep_str :: String -> [String] -> [Dependency] -> DString
+dep_str var extra deps = ss var. sc '='. quote' (ss $ drop_leadings $ unlines extra ++ deps_s). nl
+ where indent = 1 * tab_size
+ deps_s = tabify (dep2str indent (DependAllOf deps))
+ drop_leadings = dropWhile (== '\t')
+
+quote :: String -> DString
+quote str = sc '"'. ss (esc str). sc '"'
+ where
+ esc = concatMap esc'
+ esc' '"' = "\""
+ esc' c = [c]
+
+quote' :: DString -> DString
+quote' str = sc '"'. str. sc '"'
+
+sepBy :: String -> [String] -> ShowS
+sepBy _ [] = id
+sepBy _ [x] = ss x
+sepBy s (x:xs) = ss x. ss s. sepBy s xs
+
+getRestIfPrefix ::
+ String -> -- ^ the prefix
+ String -> -- ^ the string
+ Maybe String
+getRestIfPrefix (p:ps) (x:xs) = if p==x then getRestIfPrefix ps xs else Nothing
+getRestIfPrefix [] rest = Just rest
+getRestIfPrefix _ [] = Nothing
+
+subStr ::
+ String -> -- ^ the search string
+ String -> -- ^ the string to be searched
+ Maybe (String,String) -- ^ Just (pre,post) if string is found
+subStr sstr str = case getRestIfPrefix sstr str of
+ Nothing -> if null str then Nothing else case subStr sstr (tail str) of
+ Nothing -> Nothing
+ Just (pre,post) -> Just (head str:pre,post)
+ Just rest -> Just ([],rest)
+
+replaceMultiVars ::
+ [(String,String)] -> -- ^ pairs of variable name and content
+ String -> -- ^ string to be searched
+ String -- ^ the result
+replaceMultiVars [] str = str
+replaceMultiVars whole@((pname,cont):rest) str = case subStr cont str of
+ Nothing -> replaceMultiVars rest str
+ Just (pre,post) -> (replaceMultiVars rest pre)++pname++(replaceMultiVars whole post)
diff --git a/Portage/GHCCore.hs b/Portage/GHCCore.hs
new file mode 100644
index 0000000..aee1dfc
--- /dev/null
+++ b/Portage/GHCCore.hs
@@ -0,0 +1,425 @@
+
+-- Guess GHC version from packages depended upon.
+module Portage.GHCCore
+ ( coreLibs
+ , minimumGHCVersionToBuildPackage
+ , cabalFromGHC
+ , defaultGHC
+ , finalizePackageDescription
+ , platform
+ , dependencySatisfiable
+ ) where
+
+import Distribution.Package
+import Distribution.Version
+import Distribution.Simple.PackageIndex
+import Distribution.InstalledPackageInfo
+
+import Distribution.PackageDescription
+import Distribution.PackageDescription.Configuration
+import Distribution.Compiler (CompilerId(..), CompilerFlavor(GHC))
+import Distribution.System
+
+import Distribution.Text
+
+import Data.Maybe
+import Data.List ( nub )
+import Data.Version
+
+import Debug.Trace
+
+defaultGHC :: (CompilerId, [PackageName])
+defaultGHC = let (g,pix) = ghc6123 in (g, packageNamesFromPackageIndex pix)
+
+ghcs :: [(CompilerId, PackageIndex)]
+ghcs = [ghc6104, ghc6121, ghc6122, ghc6123, ghc704, ghc741, ghc742, ghc761, ghc762]
+
+cabalFromGHC :: [Int] -> Maybe Version
+cabalFromGHC ver = lookup ver table
+ where
+ table = [([6,6,0], Version [1,1,6] [])
+ ,([6,6,1], Version [1,1,6,2] [])
+ ,([6,8,1], Version [1,2,2,0] [])
+ ,([6,8,2], Version [1,2,3,0] [])
+ ,([6,8,3], Version [1,2,4,0] [])
+ ,([6,10,1], Version [1,6,0,1] [])
+ ,([6,10,2], Version [1,6,0,3] [])
+ ,([6,10,3], Version [1,6,0,3] [])
+ ,([6,10,4], Version [1,6,0,3] [])
+ ,([6,12,1], Version [1,8,0,2] [])
+ ,([6,12,2], Version [1,8,0,4] [])
+ ,([6,12,3], Version [1,8,0,6] [])
+ ,([7,0,1], Version [1,10,0,0] [])
+ ,([7,4,2], Version [1,14,0] [])
+ ,([7,6,1], Version [1,16,0] [])
+ ,([7,6,2], Version [1,16,0] [])
+ ]
+
+platform :: Platform
+platform = Platform X86_64 Linux
+
+packageIsCore :: PackageIndex -> PackageName -> Bool
+packageIsCore index pn = not . null $ lookupPackageName index pn
+
+packageIsCoreInAnyGHC :: PackageName -> Bool
+packageIsCoreInAnyGHC pn = any (flip packageIsCore pn) (map snd ghcs)
+
+-- | Check if a dependency is satisfiable given a 'PackageIndex'
+-- representing the core packages in a GHC version.
+-- Packages that are not core will always be accepted, packages that are
+-- core in any ghc must be satisfied by the 'PackageIndex'.
+dependencySatisfiable :: PackageIndex -> Dependency -> Bool
+dependencySatisfiable pindex dep@(Dependency pn _rang)
+ | pn == PackageName "Win32" = False -- only exists on windows, not in linux
+ | not . null $ lookupDependency pindex dep = True -- the package index satisfies the dep
+ | packageIsCoreInAnyGHC pn = False -- some other ghcs support the dependency
+ | otherwise = True -- the dep is not related with core packages, accept the dep
+
+packageBuildableWithGHCVersion
+ :: GenericPackageDescription
+ -> (CompilerId, PackageIndex)
+ -> Either [Dependency] (PackageDescription, FlagAssignment)
+packageBuildableWithGHCVersion pkg (compiler, pkgIndex) = trace_failure $
+ finalizePackageDescription [] (dependencySatisfiable pkgIndex) platform compiler [] pkg
+ where trace_failure v = case v of
+ (Left deps) -> trace (unwords ["rejecting dep:" , show_compiler compiler
+ , "as", show_deps deps
+ , "were not found."
+ ]
+ ) v
+ _ -> trace (unwords ["accepting dep:" , show_compiler compiler
+ ]
+ ) v
+ show_deps = show . map display
+ show_compiler (CompilerId GHC v) = "ghc-" ++ showVersion v
+ show_compiler c = show c
+
+-- | Given a 'GenericPackageDescription' it returns the miminum GHC version
+-- to build a package, and a list of core packages to that GHC version.
+minimumGHCVersionToBuildPackage :: GenericPackageDescription -> Maybe (CompilerId, [PackageName], PackageDescription, FlagAssignment, PackageIndex)
+minimumGHCVersionToBuildPackage gpd =
+ listToMaybe [ (cid, packageNamesFromPackageIndex pix, pkg_desc, picked_flags, pix)
+ | g@(cid, pix) <- ghcs
+ , Right (pkg_desc, picked_flags) <- return (packageBuildableWithGHCVersion gpd g)]
+
+mkIndex :: [PackageIdentifier] -> PackageIndex
+mkIndex pids = fromList
+ [ emptyInstalledPackageInfo
+ { installedPackageId = InstalledPackageId $ display name ++ "-" ++ display version
+ , sourcePackageId = pindex
+ , exposed = True
+ }
+ | pindex@(PackageIdentifier name version) <- pids ]
+
+packageNamesFromPackageIndex :: PackageIndex -> [PackageName]
+packageNamesFromPackageIndex pix = nub $ map fst $ allPackagesByName pix
+
+ghc :: [Int] -> CompilerId
+ghc nrs = CompilerId GHC (Version nrs [])
+
+ghc762 :: (CompilerId, PackageIndex)
+ghc762 = (ghc [7,6,2], mkIndex ghc762_pkgs)
+
+ghc761 :: (CompilerId, PackageIndex)
+ghc761 = (ghc [7,6,1], mkIndex ghc761_pkgs)
+
+ghc742 :: (CompilerId, PackageIndex)
+ghc742 = (ghc [7,4,2], mkIndex ghc742_pkgs)
+
+ghc741 :: (CompilerId, PackageIndex)
+ghc741 = (ghc [7,4,1], mkIndex ghc741_pkgs)
+
+ghc704 :: (CompilerId, PackageIndex)
+ghc704 = (ghc [7,0,1], mkIndex ghc704_pkgs)
+
+ghc6123 :: (CompilerId, PackageIndex)
+ghc6123 = (ghc [6,12,3], mkIndex ghc6123_pkgs)
+
+ghc6122 :: (CompilerId, PackageIndex)
+ghc6122 = (ghc [6,12,2], mkIndex ghc6122_pkgs)
+
+ghc6121 :: (CompilerId, PackageIndex)
+ghc6121 = (ghc [6,12,1], mkIndex ghc6121_pkgs)
+
+ghc6104 :: (CompilerId, PackageIndex)
+ghc6104 = (ghc [6,10,4], mkIndex ghc6104_pkgs)
+
+-- | Non-upgradeable core packages
+-- Source: http://haskell.org/haskellwiki/Libraries_released_with_GHC
+
+ghc762_pkgs :: [PackageIdentifier]
+ghc762_pkgs =
+ [ p "array" [0,4,0,1]
+ , p "base" [4,6,0,1]
+-- , p "binary" [0,5,1,1] package is upgradeable
+ , p "bytestring" [0,10,0,2]
+-- , p "Cabal" [1,16,0] package is upgradeable
+ , p "containers" [0,5,0,0]
+ , p "deepseq" [1,3,0,1] -- used by time, haskell98
+ , p "directory" [1,2,0,1]
+ , p "filepath" [1,3,0,1]
+ , p "ghc-prim" [0,3,0,0]
+ , p "haskell2010" [1,1,1,0]
+ , p "haskell98" [2,0,0,2]
+ , p "hoopl" [3,9,0,0] -- used by libghc
+ , p "hpc" [0,6,0,0] -- used by libghc
+ , p "integer-gmp" [0,5,0,0]
+ , p "old-locale" [1,0,0,5]
+ , p "old-time" [1,1,0,1]
+ , p "pretty" [1,1,1,0]
+ , p "process" [1,1,0,2]
+ , p "template-haskell" [2,8,0,0] -- used by libghc
+ , p "time" [1,4,0,1] -- used by haskell98, unix, directory, hpc, ghc. unsafe to upgrade
+ , p "unix" [2,6,0,1]
+ ]
+
+ghc761_pkgs :: [PackageIdentifier]
+ghc761_pkgs =
+ [ p "array" [0,4,0,1]
+ , p "base" [4,6,0,0]
+-- , p "binary" [0,5,1,1] package is upgradeable
+ , p "bytestring" [0,10,0,0]
+-- , p "Cabal" [1,16,0] package is upgradeable
+ , p "containers" [0,5,0,0]
+ , p "deepseq" [1,3,0,1] -- used by time, haskell98
+ , p "directory" [1,2,0,0]
+ , p "filepath" [1,3,0,1]
+ , p "ghc-prim" [0,3,0,0]
+ , p "haskell2010" [1,1,1,0]
+ , p "haskell98" [2,0,0,2]
+ , p "hoopl" [3,9,0,0] -- used by libghc
+ , p "hpc" [0,6,0,0] -- used by libghc
+ , p "integer-gmp" [0,5,0,0]
+ , p "old-locale" [1,0,0,5]
+ , p "old-time" [1,1,0,1]
+ , p "pretty" [1,1,1,0]
+ , p "process" [1,1,0,2]
+ , p "template-haskell" [2,8,0,0] -- used by libghc
+ , p "time" [1,4,0,1] -- used by haskell98, unix, directory, hpc, ghc. unsafe to upgrade
+ , p "unix" [2,6,0,0]
+ ]
+
+ghc742_pkgs :: [PackageIdentifier]
+ghc742_pkgs =
+ [ p "array" [0,4,0,0]
+ , p "base" [4,5,1,0]
+-- , p "binary" [0,5,1,0] package is upgradeable
+ , p "bytestring" [0,9,2,1]
+-- , p "Cabal" [1,14,0] package is upgradeable
+ , p "containers" [0,4,2,1]
+ , p "deepseq" [1,3,0,0] -- used by time, haskell98
+ , p "directory" [1,1,0,2]
+-- , p "extensible-exceptions" [0,1,1,4] -- package is upgradeable, stopped shipping in 7.6
+ , p "filepath" [1,3,0,0]
+ , p "ghc-prim" [0,2,0,0]
+ , p "haskell2010" [1,1,0,1]
+ , p "haskell98" [2,0,0,1]
+ , p "hoopl" [3,8,7,3] -- used by libghc
+ , p "hpc" [0,5,1,1] -- used by libghc
+ , p "integer-gmp" [0,4,0,0]
+ , p "old-locale" [1,0,0,4]
+ , p "old-time" [1,1,0,0]
+ , p "pretty" [1,1,1,0]
+ , p "process" [1,1,0,1]
+ , p "template-haskell" [2,7,0,0] -- used by libghc
+ , p "time" [1,4]
+ , p "unix" [2,5,1,1]
+ ]
+
+ghc741_pkgs :: [PackageIdentifier]
+ghc741_pkgs =
+ [ p "array" [0,4,0,0]
+ , p "base" [4,5,0,0]
+-- , p "binary" [0,5,1,0] package is upgradeable
+ , p "bytestring" [0,9,2,1]
+-- , p "Cabal" [1,14,0] package is upgradeable
+ , p "containers" [0,4,2,1]
+ , p "deepseq" [1,3,0,0] -- used by time, haskell98
+ , p "directory" [1,1,0,2]
+-- , p "extensible-exceptions" [0,1,1,4] -- package is upgradeable, stopped shipping in 7.6
+ , p "filepath" [1,3,0,0]
+ , p "ghc-prim" [0,2,0,0]
+ , p "haskell2010" [1,1,0,1]
+ , p "haskell98" [2,0,0,1]
+ , p "hoopl" [3,8,7,3] -- used by libghc
+ , p "hpc" [0,5,1,1] -- used by libghc
+ , p "integer-gmp" [0,4,0,0]
+ , p "old-locale" [1,0,0,4]
+ , p "old-time" [1,1,0,0]
+ , p "pretty" [1,1,1,0]
+ , p "process" [1,1,0,1]
+ , p "template-haskell" [2,7,0,0] -- used by libghc
+ , p "time" [1,4]
+ , p "unix" [2,5,1,0]
+ ]
+
+ghc704_pkgs :: [PackageIdentifier]
+ghc704_pkgs =
+ [ p "array" [0,3,0,2]
+ , p "base" [4,3,1,0]
+ , p "bytestring" [0,9,1,10]
+-- , p "Cabal" [1,10,2,0] package is upgradeable
+ , p "containers" [0,4,0,0]
+ , p "directory" [1,1,0,0]
+-- , p "extensible-exceptions" [0,1,1,2] -- package is upgradeable, stopped shipping in 7.6
+ , p "filepath" [1,2,0,0]
+ , p "ghc-binary" [0,5,0,2]
+ , p "ghc-prim" [0,2,0,0]
+ , p "haskell2010" [1,0,0,0]
+ , p "haskell98" [1,1,0,1]
+ , p "hpc" [0,5,0,6]
+ , p "integer-gmp" [0,2,0,2]
+ , p "old-locale" [1,0,0,2]
+ , p "old-time" [1,0,0,6]
+ , p "pretty" [1,0,1,2]
+ , p "process" [1,0,1,5]
+-- , p "random" [1,0,0,3] -- will not be shipped starting from ghc-7.2
+ , p "template-haskell" [2,5,0,0]
+ , p "time" [1,2,0,3]
+ , p "unix" [2,4,2,0]
+ ]
+
+ghc6123_pkgs :: [PackageIdentifier]
+ghc6123_pkgs =
+ [ p "array" [0,3,0,1]
+ , p "base" [3,0,3,2]
+ , p "base" [4,2,0,2]
+ , p "bytestring" [0,9,1,7]
+-- , p "Cabal" [1,8,0,6] package is upgradeable
+ , p "containers" [0,3,0,0]
+ , p "directory" [1,0,1,1]
+-- , p "extensible-exceptions" [0,1,1,1] -- package is upgradeable, stopped shipping in 7.6
+ , p "filepath" [1,1,0,4]
+ , p "ghc-binary" [0,5,0,2]
+ , p "ghc-prim" [0,2,0,0]
+ , p "haskell98" [1,0,1,1]
+ , p "hpc" [0,5,0,5]
+ , p "integer-gmp" [0,2,0,1]
+ , p "integer-simple" [0,1,0,0]
+ , p "old-locale" [1,0,0,2]
+ , p "old-time" [1,0,0,5]
+ , p "pretty" [1,0,1,1]
+ , p "process" [1,0,1,3]
+-- , p "random" [1,0,0,2] -- will not be shipped starting from ghc-7.2
+-- , p "syb" [0,1,0,2] -- not distributed with ghc-7
+ , p "template-haskell" [2,4,0,1]
+ , p "time" [1,1,4]
+ , p "unix" [2,4,0,2]
+-- , p "utf8-string" [0,3,4] package is upgradeable
+ ]
+
+ghc6122_pkgs :: [PackageIdentifier]
+ghc6122_pkgs =
+ [ p "array" [0,3,0,0]
+ , p "base" [3,0,3,2]
+ , p "base" [4,2,0,1]
+ , p "bytestring" [0,9,1,6]
+-- , p "Cabal" [1,8,0,4] package is upgradeable
+ , p "containers" [0,3,0,0]
+ , p "directory" [1,0,1,1]
+-- , p "extensible-exceptions" [0,1,1,1] -- package is upgradeable, stopped shipping in 7.6
+ , p "filepath" [1,1,0,4]
+ , p "ghc-binary" [0,5,0,2]
+ , p "ghc-prim" [0,2,0,0]
+ , p "haskell98" [1,0,1,1]
+ , p "hpc" [0,5,0,5]
+ , p "integer-gmp" [0,2,0,1]
+ , p "old-locale" [1,0,0,2]
+ , p "old-time" [1,0,0,4]
+ , p "pretty" [1,0,1,1]
+ , p "process" [1,0,1,2]
+-- , p "random" [1,0,0,2] -- will not be shipped starting from ghc-7.2
+-- , p "syb" [0,1,0,2] -- not distributed with ghc-7
+ , p "template-haskell" [2,4,0,1]
+ , p "time" [1,1,4]
+ , p "unix" [2,4,0,1]
+-- , p "utf8-string" [0,3,4] package is upgradeable
+ ]
+
+ghc6121_pkgs :: [PackageIdentifier]
+ghc6121_pkgs =
+ [ p "array" [0,3,0,0]
+ , p "base" [3,0,3,2]
+ , p "base" [4,2,0,0]
+ , p "bytestring" [0,9,1,5]
+-- , p "Cabal" [1,8,0,2] package is upgradeable
+ , p "containers" [0,3,0,0]
+ , p "directory" [1,0,1,0]
+-- , p "extensible-exceptions" [0,1,1,1] -- package is upgradeable, stopped shipping in 7.6
+ , p "filepath" [1,1,0,3]
+ , p "ghc-binary" [0,5,0,2]
+ , p "ghc-prim" [0,2,0,0]
+ , p "haskell98" [1,0,1,1]
+ , p "hpc" [0,5,0,4]
+ , p "integer-gmp" [0,2,0,0]
+ , p "old-locale" [1,0,0,2]
+ , p "old-time" [1,0,0,3]
+ , p "pretty" [1,0,1,1]
+ , p "process" [1,0,1,2]
+-- , p "random" [1,0,0,2] -- will not be shipped starting from ghc-7.2
+-- , p "syb" [0,1,0,2] -- not distributed with ghc-7
+ , p "template-haskell" [2,4,0,0]
+ , p "time" [1,1,4]
+ , p "unix" [2,4,0,0]
+-- , p "utf8-string" [0,3,4] package is upgradeable
+ ]
+
+ghc6104_pkgs :: [PackageIdentifier]
+ghc6104_pkgs =
+ [ p "array" [0,2,0,0]
+ , p "base" [3,0,3,1]
+ , p "base" [4,1,0,0]
+ , p "bytestring" [0,9,1,4]
+-- , p "Cabal" [1,6,0,3] package is upgradeable
+ , p "containers" [0,2,0,1]
+ , p "directory" [1,0,0,3]
+-- , p "extensible-exceptions" [0,1,1,0] -- package is upgradeable, stopped shipping in 7.6
+ , p "filepath" [1,1,0,2]
+ , p "ghc-prim" [0,1,0,0]
+ , p "haskell98" [1,0,1,0]
+ , p "hpc" [0,5,0,3]
+ , p "integer" [0,1,0,1]
+ , p "old-locale" [1,0,0,1]
+ , p "old-time" [1,0,0,2]
+ , p "packedstring" [0,1,0,1]
+ , p "pretty" [1,0,1,0]
+ , p "process" [1,0,1,1]
+-- , p "random" [1,0,0,1] -- will not be shipped starting from ghc-7.2
+-- , p "syb" [0,1,0,1] -- not distributed with ghc-7
+ , p "template-haskell" [2,3,0,1]
+ , p "unix" [2,3,2,0]
+ ]
+
+p :: String -> [Int] -> PackageIdentifier
+p pn vs = PackageIdentifier (PackageName pn) (Version vs [])
+
+coreLibs :: [PackageName]
+coreLibs = map PackageName
+ ["array"
+ ,"base"
+ ,"bytestring" -- intentionally no ebuild. use ghc's version
+ -- to avoid dreaded 'diamond dependency' problem
+ ,"containers"
+ ,"directory"
+ --,"editline"
+ ,"filepath" -- intentionally no ebuild. use ghc's version
+ ,"ghc"
+ ,"ghc-prim"
+ ,"haskell98"
+ ,"hpc" --has ebuild, but only in the overlay
+ ,"integer" -- up to ghc-6.10
+ ,"integer-gmp" -- ghc-6.12+
+ ,"old-locale"
+ ,"old-time"
+ ,"packedstring"
+ ,"pretty"
+ ,"process"
+ -- ,"random" -- not a core package since ghc-7.2
+ ,"rts"
+ -- ,"syb" -- was splitted off from ghc again
+ ,"template-haskell"
+ ,"time" -- ghc-6.12+. startig from ghc-7.6.1 it is very
+ -- unsafe to upgrade as most others (like directory)
+ -- depend on it
+ ,"unix" -- unsafe to upgrade
+ ]
diff --git a/Portage/Host.hs b/Portage/Host.hs
new file mode 100644
index 0000000..e1fb598
--- /dev/null
+++ b/Portage/Host.hs
@@ -0,0 +1,124 @@
+module Portage.Host
+ ( getInfo -- :: IO [(String, String)]
+ , LocalInfo(..)
+ ) where
+
+import Util (run_cmd)
+import Data.Maybe (fromJust, isJust, catMaybes)
+import Control.Applicative ( (<$>) )
+
+import qualified System.Directory as D
+import System.FilePath ((</>))
+
+import System.IO
+
+data LocalInfo =
+ LocalInfo { distfiles_dir :: String
+ , overlay_list :: [FilePath]
+ , portage_dir :: FilePath
+ } deriving (Read, Show)
+
+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 [ readConfig
+ , performMaybes [ getPaludisInfo
+ , fmap parse_emerge_output <$> (run_cmd "emerge --info")
+ , return (Just defaultInfo)
+ ] >>= showAnnoyingWarning
+ ]
+ where performMaybes [] = return Nothing
+ performMaybes (act:acts) =
+ do r <- act
+ if isJust r
+ then return r
+ else performMaybes acts
+
+showAnnoyingWarning :: Maybe LocalInfo -> IO (Maybe LocalInfo)
+showAnnoyingWarning info = do
+ hPutStr stderr $ unlines [ "-- Consider creating ~/" ++ hackport_config ++ " file with contents:"
+ , show info
+ , "-- It will speed hackport startup time a bit."
+ ]
+ return info
+
+-- relative to home dir
+hackport_config :: FilePath
+hackport_config = ".hackport" </> "repositories"
+
+--------------------------
+-- fastest: config reading
+--------------------------
+readConfig :: IO (Maybe LocalInfo)
+readConfig =
+ do home_dir <- D.getHomeDirectory
+ let config_path = home_dir </> hackport_config
+ exists <- D.doesFileExist config_path
+ case exists of
+ True -> read <$> readFile config_path
+ False -> return Nothing
+
+----------
+-- Paludis
+----------
+
+getPaludisInfo :: IO (Maybe LocalInfo)
+getPaludisInfo = fmap parsePaludisInfo <$> run_cmd "cave info"
+
+parsePaludisInfo :: String -> LocalInfo
+parsePaludisInfo text =
+ let chunks = splitBy (=="") . lines $ text
+ repositories = catMaybes (map parseRepository chunks)
+ in fromJust (mkLocalInfo repositories)
+ where
+ parseRepository :: [String] -> Maybe (String, (String, String))
+ parseRepository [] = Nothing
+ parseRepository (firstLine:lns) = do
+ name <- case words firstLine of
+ ["Repository", nm] -> return (init nm)
+ _ -> fail "not a repository chunk"
+ let dict = [ (head ln, unwords (tail ln)) | ln <- map words lns ]
+ location <- lookup "location" dict
+ distfiles <- lookup "distdir" dict
+ return (name, (location, distfiles))
+
+ mkLocalInfo :: [(String, (String, String))] -> Maybe LocalInfo
+ mkLocalInfo repos = do
+ (gentooLocation, gentooDistfiles) <- lookup "gentoo" repos
+ let overlays = [ loc | (_, (loc, _dist)) <- repos ]
+ return (LocalInfo
+ { distfiles_dir = gentooDistfiles
+ , portage_dir = gentooLocation
+ , overlay_list = overlays
+ })
+
+splitBy :: (a -> Bool) -> [a] -> [[a]]
+splitBy _ [] = []
+splitBy c lst =
+ let (x,xs) = break c lst
+ (_,xs') = span c xs
+ in x : splitBy c xs'
+
+---------
+-- Emerge
+---------
+
+parse_emerge_output :: String -> LocalInfo
+parse_emerge_output raw_data =
+ 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/Metadata.hs b/Portage/Metadata.hs
new file mode 100644
index 0000000..1190209
--- /dev/null
+++ b/Portage/Metadata.hs
@@ -0,0 +1,55 @@
+module Portage.Metadata
+ ( Metadata(..)
+ , metadataFromFile
+ , makeDefaultMetadata
+ ) where
+
+import qualified Data.ByteString as B
+
+import Control.Applicative
+
+import Text.XML.Light
+
+data Metadata = Metadata
+ { metadataHerds :: [String]
+ -- , metadataMaintainers :: [String],
+ -- , metadataUseFlags :: [(String,String)]
+ } deriving (Show)
+
+metadataFromFile :: FilePath -> IO (Maybe Metadata)
+metadataFromFile fp = do
+ doc <- parseXMLDoc <$> B.readFile fp
+ return (doc >>= parseMetadata)
+
+parseMetadata :: Element -> Maybe Metadata
+parseMetadata xml = do
+ let herds = map strContent (findChildren (unqual "herd") xml)
+ return Metadata
+ {
+ metadataHerds = herds
+ }
+
+-- don't use Text.XML.Light as we like our own pretty printer
+makeDefaultMetadata :: String -> String
+makeDefaultMetadata long_description =
+ unlines [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
+ , "<!DOCTYPE pkgmetadata SYSTEM \"http://www.gentoo.org/dtd/metadata.dtd\">"
+ , "<pkgmetadata>"
+ , "\t<herd>haskell</herd>"
+ , "\t<maintainer>"
+ , "\t\t<email>haskell@gentoo.org</email>"
+ , "\t</maintainer>"
+ , (init {- strip trailing newline-}
+ . unlines
+ . map (\l -> if l `elem` ["<longdescription>", "</longdescription>"]
+ then "\t" ++ l -- leading/trailing lines
+ else "\t\t" ++ l -- description itself
+ )
+ . lines
+ . showElement
+ . unode "longdescription"
+ . ("\n" ++) -- prepend newline to separate form <longdescription>
+ . (++ "\n") -- append newline
+ ) long_description
+ , "</pkgmetadata>"
+ ]
diff --git a/Portage/Overlay.hs b/Portage/Overlay.hs
new file mode 100644
index 0000000..3602139
--- /dev/null
+++ b/Portage/Overlay.hs
@@ -0,0 +1,186 @@
+module Portage.Overlay
+ ( ExistingEbuild(..)
+ , Overlay(..)
+ , loadLazy
+ , readOverlay, readOverlayByPackage
+ , getDirectoryTree, DirectoryTree
+
+ , reduceOverlay
+ , filterByHerd
+ , inOverlay
+ )
+ where
+
+import qualified Portage.PackageId as Portage
+import qualified Portage.Metadata as Portage
+
+import qualified Distribution.Package as Cabal
+
+import Distribution.Text (simpleParse)
+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)
+
+import Data.Traversable ( traverse )
+
+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],
+ overlayMetadata :: Map Portage.PackageName Portage.Metadata
+ } 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
+
+loadLazy :: FilePath -> IO Overlay
+loadLazy path = do
+ dir <- getDirectoryTree path
+ metadata <- unsafeInterleaveIO $ mkMetadataMap path dir
+ return $ mkOverlay metadata $ readOverlayByPackage dir
+ where
+ allowed v = case v of
+ (Portage.Version _ Nothing [] _) -> True
+ _ -> False
+
+ mkOverlay :: Map Portage.PackageName Portage.Metadata
+ -> [(Portage.PackageName, [Portage.Version])]
+ -> Overlay
+ mkOverlay meta packages = Overlay {
+ overlayPath = path,
+ overlayMetadata = meta,
+ overlayMap =
+ Map.fromList
+ [ (pkgName, [ ExistingEbuild portageId cabalId filepath
+ | version <- allowedVersions
+ , let portageId = Portage.PackageId pkgName version
+ , Just cabalId <- [ Portage.toCabalPackageId portageId ]
+ , let filepath = path </> Portage.packageIdToFilePath portageId
+ ])
+ | (pkgName, allVersions) <- packages
+ , let allowedVersions = filter allowed allVersions
+ ]
+ }
+
+mkMetadataMap :: FilePath -> DirectoryTree -> IO (Map Portage.PackageName Portage.Metadata)
+mkMetadataMap root dir =
+ fmap (Map.mapMaybe id) $
+ traverse Portage.metadataFromFile $
+ Map.fromList
+ [ (Portage.mkPackageName category package, root </> category </> package </> "metadata.xml")
+ | Directory category packages <- dir
+ , Directory package files <- packages
+ , File "metadata.xml" <- files
+ ]
+
+filterByHerd :: ([String] -> Bool) -> Overlay -> Overlay
+filterByHerd p overlay = overlay
+ { overlayMetadata = metadataMap'
+ , overlayMap = pkgMap'
+ }
+ where
+ metadataMap' = Map.filter (p . Portage.metadataHerds) (overlayMetadata overlay)
+ pkgMap' = Map.intersection (overlayMap overlay) metadataMap'
+
+
+-- make sure there is only one ebuild for each version number (by selecting
+-- the highest ebuild version revision)
+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 path = path `elem` [ "."
+ , ".."
+ -- those speed things up a bit
+ -- and reduse memory consumption
+ -- (as we store it in RAM for the whole run)
+ , ".git"
+ , "CVS"
+ ]
diff --git a/Portage/PackageId.hs b/Portage/PackageId.hs
new file mode 100644
index 0000000..ec81733
--- /dev/null
+++ b/Portage/PackageId.hs
@@ -0,0 +1,126 @@
+-- | Portage package identifiers, which unlike Cabal ones include a category.
+--
+module Portage.PackageId (
+ Category(..),
+ PackageName(..),
+ PackageId(..),
+ Portage.Version(..),
+ mkPackageName,
+ fromCabalPackageId,
+ toCabalPackageId,
+ parseFriendlyPackage,
+ normalizeCabalPackageName,
+ normalizeCabalPackageId,
+ packageIdToFilePath
+ ) 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 Distribution.Text(display)
+import System.FilePath ( (</>) )
+
+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).
+-}
+
+packageIdToFilePath :: PackageId -> FilePath
+packageIdToFilePath (PackageId (PackageName cat pn) version) =
+ display cat </> display pn </> display pn <-> display version <.> "ebuild"
+ where
+ a <-> b = a ++ '-':b
+ a <.> b = a ++ '.':b
+
+mkPackageName :: String -> String -> PackageName
+mkPackageName cat package = PackageName (Category cat) (Cabal.PackageName package)
+
+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..0696d41
--- /dev/null
+++ b/Portage/Resolve.hs
@@ -0,0 +1,75 @@
+{-# LANGUAGE PatternGuards #-}
+
+module Portage.Resolve
+ ( resolveCategory
+ , resolveCategories
+ , resolveFullPortageName
+ ) 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
+ , Portage.normalizeCabalPackageName pn == 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 (Portage.normalizeCabalPackageName 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/Use.hs b/Portage/Use.hs
new file mode 100644
index 0000000..dcab0e0
--- /dev/null
+++ b/Portage/Use.hs
@@ -0,0 +1,59 @@
+module Portage.Use (
+ -- * main structures
+ UseFlag(..),
+ Use,
+ dispUses,
+ -- * helpers
+ mkUse,
+ mkNotUse,
+ mkQUse
+ ) where
+
+import qualified Text.PrettyPrint as Disp
+import Text.PrettyPrint ((<>))
+import Distribution.Text ( Text(..) )
+
+-- | Use variable modificator
+data UseFlag = UseFlag Use -- ^ no modificator
+ | E UseFlag -- ^ = modificator (Equiv mark)
+ | Q UseFlag -- ^ ? modificator (Question mark)
+ | X UseFlag -- ^ ! modificator (eXclamation mark)
+ | N UseFlag -- ^ - modificator
+ deriving (Eq,Show,Ord,Read)
+
+
+{-
+instance IsString UseFlag where
+ fromString ('!':str) = X (fromString str)
+ fromString ('-':str) = N (fromString str)
+ fromString str = case last str of
+ '?' -> Q (fromString (init str))
+ '=' -> E (fromString (init str))
+ s -> UseFlag s
+-}
+mkUse :: Use -> UseFlag
+mkUse = UseFlag
+
+mkNotUse :: Use -> UseFlag
+mkNotUse = N . UseFlag
+
+mkQUse :: Use -> UseFlag
+mkQUse = Q . UseFlag
+
+
+instance Text UseFlag where
+ disp = showModificator
+
+showModificator :: UseFlag -> Disp.Doc
+showModificator (UseFlag u) = Disp.text u
+showModificator (X u) = Disp.char '!' <> disp u
+showModificator (Q u) = disp u <> Disp.char '?'
+showModificator (E u) = disp u <> Disp.char '='
+showModificator (N u) = Disp.char '-' <> disp u
+
+dispUses :: [UseFlag] -> Disp.Doc
+dispUses [] = Disp.empty
+dispUses us = Disp.brackets $ Disp.hcat $ (Disp.punctuate (Disp.text ", ")) $ map disp us
+
+type Use = String
+
diff --git a/Portage/Version.hs b/Portage/Version.hs
new file mode 100644
index 0000000..fec60c1
--- /dev/null
+++ b/Portage/Version.hs
@@ -0,0 +1,101 @@
+{-|
+ 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,
+ is_live
+ ) 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 { versionNumber :: [Int] -- [1,42,3] ~= 1.42.3
+ , versionChar :: (Maybe Char) -- optional letter
+ , versionSuffix :: [Suffix]
+ , versionRevision :: Int -- revision, 0 means none
+ }
+ deriving (Eq, Ord, Show, Read)
+
+-- foo-9999* is treated as live ebuild
+-- Cabal-1.17.9999* as well
+is_live :: Version -> Bool
+is_live v =
+ case vs of
+ -- nonempty
+ (_:_) | many_nines (last vs) -> True
+ _ -> False
+ where vs = versionNumber v
+ many_nines n = is_big n && all_nines n
+ is_big n = n >= 9999
+ all_nines n = (all (== '9') . show) n
+
+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.rst b/README.rst
new file mode 100644
index 0000000..28898aa
--- /dev/null
+++ b/README.rst
@@ -0,0 +1,133 @@
+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.
+
+Quick start
+-----------
+
+1. Build hackport binary by hand (or install it from haskell overlay).
+2. Setup hackport database into overlay you plan to merge new ebuilds:
+
+::
+
+ $ mkdir ~/overlays
+ $ cd ~/overlays
+ $ git clone git://github.com/gentoo-haskell/gentoo-haskell.git
+ $ cd gentoo-haskell
+ $ hackport update
+ $ ls -1 .hackport/
+ 00-index.tar
+ 00-index.tar.gz
+
+3. Add your ~/overlays/gentoo-haskell to PORTDIR_OVERLAY in /etc/make.conf.
+
+Done! Now you can `hackport merge <package-name>` to get an ebuild merged to
+your overlay!
+
+Features
+--------
+
+ 'hackport update'
+ Update the local copy of hackage's package list. You should run this
+ every once in a while to get a more recent copy.
+
+ 'hackport list [FILTER]'
+ Print packages from hackage, with an optional substring matching.
+
+ '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 <category> <path/to/package.cabal>'
+ Generates standalone .ebuild file from .cabal spec and stores result
+ to the overlay into <category>/<package>
+ Option is useful for not-on-hackage packages and for debug purposes.
+
+-------
+
+ Henning Günther
+ Duncan Coutts
+ Lennart Kolmodin
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..36c3aa9
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,7 @@
+#!/usr/bin/runhaskell
+module Main where
+
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain
diff --git a/Status.hs b/Status.hs
new file mode 100644
index 0000000..c7ae5a9
--- /dev/null
+++ b/Status.hs
@@ -0,0 +1,243 @@
+module Status
+ ( FileStatus(..)
+ , StatusDirection(..)
+ , fromStatus
+ , status
+ , runStatus
+ ) where
+
+import AnsiColor
+
+import qualified Portage.Version as V (is_live)
+
+import Portage.Overlay
+import Portage.PackageId
+import Portage.Resolve
+
+import Control.Monad.State
+
+import qualified Data.List as List
+
+import qualified Data.ByteString.Char8 as BS
+
+import Data.Char
+import Data.Function (on)
+import qualified Data.Map as Map
+import Data.Map as Map (Map)
+
+import qualified Data.Traversable as T
+import Control.Applicative
+
+-- cabal
+import Distribution.Client.Types ( Repo, SourcePackageDb(..), SourcePackage(..) )
+import Distribution.Verbosity
+import Distribution.Package (pkgName)
+import Distribution.Simple.Utils (comparing, die, equating)
+import Distribution.Text ( display, simpleParse )
+
+import qualified Distribution.Client.PackageIndex as CabalInstall
+import qualified Distribution.Client.IndexUtils as CabalInstall
+
+import Hackage (defaultRepo)
+
+data StatusDirection
+ = PortagePlusOverlay
+ | OverlayToPortage
+ | HackageToOverlay
+ deriving Eq
+
+data FileStatus a
+ = Same a
+ | Differs a a
+ | OverlayOnly a
+ | PortageOnly a
+ | HackageOnly a
+ deriving (Show,Eq)
+
+instance Ord a => Ord (FileStatus a) where
+ compare = comparing fromStatus
+
+instance Functor FileStatus where
+ fmap f st =
+ case st of
+ Same a -> Same (f a)
+ Differs a b -> Differs (f a) (f b)
+ OverlayOnly a -> OverlayOnly (f a)
+ PortageOnly a -> PortageOnly (f a)
+ HackageOnly a -> HackageOnly (f a)
+
+fromStatus :: FileStatus a -> a
+fromStatus fs =
+ case fs of
+ Same a -> a
+ Differs a _ -> a -- second status is lost
+ OverlayOnly a -> a
+ PortageOnly a -> a
+ HackageOnly a -> a
+
+
+
+loadHackage :: Verbosity -> Distribution.Client.Types.Repo -> Overlay -> IO [[PackageId]]
+loadHackage verbosity repo overlay = do
+ SourcePackageDb { packageIndex = pindex } <- CabalInstall.getSourcePackages verbosity [repo]
+ let get_cat cabal_pkg = case resolveCategories overlay (pkgName cabal_pkg) of
+ [] -> Category "dev-haskell"
+ [cat] -> cat
+ _ -> {- ambig -} Category "dev-haskell"
+ pkg_infos = map ( reverse . take 3 . reverse -- hackage usually has a ton of older versions
+ . map ((\p -> fromCabalPackageId (get_cat p) p)
+ . packageInfoId))
+ (CabalInstall.allPackagesByName pindex)
+ return pkg_infos
+
+status :: Verbosity -> FilePath -> FilePath -> IO (Map PackageName [FileStatus ExistingEbuild])
+status verbosity portdir overlaydir = do
+ let repo = defaultRepo overlaydir
+ overlay <- loadLazy overlaydir
+ hackage <- loadHackage verbosity repo overlay
+ portage <- filterByHerd ("haskell" `elem`) <$> loadLazy portdir
+ let (over, both, port) = portageDiff (overlayMap overlay) (overlayMap portage)
+
+ both' <- T.forM both $ mapM $ \e -> liftIO $ do
+ -- can't fail, we know the ebuild exists in both portagedirs
+ -- also, one of them is already bound to 'e'
+ let (Just e1) = lookupEbuildWith (overlayMap portage) (ebuildId e)
+ (Just e2) = lookupEbuildWith (overlayMap overlay) (ebuildId e)
+ eq <- equals (ebuildPath e1) (ebuildPath e2)
+ return $ if eq
+ then Same e1
+ else Differs e1 e2
+
+ let p_to_ee :: PackageId -> ExistingEbuild
+ p_to_ee p = ExistingEbuild p cabal_p ebuild_path
+ where Just cabal_p = toCabalPackageId p -- lame doubleconv
+ ebuild_path = packageIdToFilePath p
+ mk_fake_ee :: [PackageId] -> (PackageName, [ExistingEbuild])
+ mk_fake_ee ~pkgs@(p:_) = (packageId p, map p_to_ee pkgs)
+
+ map_diff = Map.differenceWith (\le re -> Just $ foldr (List.deleteBy (equating ebuildId)) le re)
+ hack = ((Map.fromList $ map mk_fake_ee hackage) `map_diff` overlayMap overlay) `map_diff` overlayMap portage
+
+ meld = Map.unionsWith (\a b -> List.sort (a++b))
+ [ Map.map (map PortageOnly) port
+ , both'
+ , Map.map (map OverlayOnly) over
+ , Map.map (map HackageOnly) hack
+ ]
+ return meld
+
+type EMap = Map PackageName [ExistingEbuild]
+
+lookupEbuildWith :: EMap -> PackageId -> Maybe ExistingEbuild
+lookupEbuildWith overlay pkgid = do
+ ebuilds <- Map.lookup (packageId pkgid) overlay
+ List.find (\e -> ebuildId e == pkgid) ebuilds
+
+runStatus :: Verbosity -> FilePath -> FilePath -> StatusDirection -> [String] -> IO ()
+runStatus verbosity portdir overlaydir direction pkgs = do
+ let pkgFilter = case direction of
+ OverlayToPortage -> toPortageFilter
+ PortagePlusOverlay -> id
+ HackageToOverlay -> fromHackageFilter
+ pkgs' <- forM pkgs $ \p ->
+ case simpleParse p of
+ Nothing -> die ("Could not parse package name: " ++ p ++ ". Format cat/pkg")
+ Just pn -> return pn
+ tree0 <- status verbosity portdir overlaydir
+ let tree = pkgFilter tree0
+ if (null pkgs')
+ then statusPrinter tree
+ else forM_ pkgs' $ \pkg -> statusPrinter (Map.filterWithKey (\k _ -> k == pkg) tree)
+
+-- |Only return packages that seems interesting to sync to portage;
+--
+-- * Ebuild differs, or
+-- * Newer version in overlay than in portage
+toPortageFilter :: Map PackageName [FileStatus ExistingEbuild] -> Map PackageName [FileStatus ExistingEbuild]
+toPortageFilter = Map.mapMaybe $ \ sts ->
+ let filter_out_lives = filter (not . V.is_live . pkgVersion . ebuildId . fromStatus)
+ inPortage = flip filter sts $ \st ->
+ case st of
+ OverlayOnly _ -> False
+ HackageOnly _ -> False
+ _ -> True
+ latestPortageVersion = List.maximum $ map (pkgVersion . ebuildId . fromStatus) inPortage
+ interestingPackages = flip filter sts $ \st ->
+ case st of
+ Differs _ _ -> True
+ _ | pkgVersion (ebuildId (fromStatus st)) > latestPortageVersion -> True
+ | otherwise -> False
+ in if not (null inPortage) && not (null $ filter_out_lives interestingPackages)
+ then Just sts
+ else Nothing
+
+-- |Only return packages that exist in overlay or portage but look outdated
+fromHackageFilter :: Map PackageName [FileStatus ExistingEbuild] -> Map PackageName [FileStatus ExistingEbuild]
+fromHackageFilter = Map.mapMaybe $ \ sts ->
+ let inEbuilds = flip filter sts $ \st ->
+ case st of
+ HackageOnly _ -> False
+ _ -> True
+ -- treat live as oldest version not avoid masking hackage releases
+ mangle_live_versions v
+ | V.is_live v = v {versionNumber=[-1]}
+ | otherwise = v
+ latestVersion = List.maximumBy (compare `on` mangle_live_versions . pkgVersion . ebuildId . fromStatus) sts
+ in case latestVersion of
+ HackageOnly _ | not (null inEbuilds) -> Just sts
+ _ -> Nothing
+
+statusPrinter :: Map PackageName [FileStatus ExistingEbuild] -> IO ()
+statusPrinter packages = do
+ putStrLn $ toColor (Same "Green") ++ ": package in portage and overlay are the same"
+ putStrLn $ toColor (Differs "Yellow" "") ++ ": package in portage and overlay differs"
+ putStrLn $ toColor (OverlayOnly "Red") ++ ": package only exist in the overlay"
+ putStrLn $ toColor (PortageOnly "Magenta") ++ ": package only exist in the portage tree"
+ putStrLn $ toColor (HackageOnly "Cyan") ++ ": package only exist on hackage"
+ forM_ (Map.toAscList packages) $ \(pkg, ebuilds) -> do
+ let (PackageName c p) = pkg
+ putStr $ display c ++ '/' : bold (display p)
+ putStr " "
+ forM_ ebuilds $ \e -> do
+ putStr $ toColor (fmap (display . pkgVersion . ebuildId) e)
+ putChar ' '
+ putStrLn ""
+
+toColor :: FileStatus String -> String
+toColor st = inColor c False Default (fromStatus st)
+ where
+ c = case st of
+ (Same _) -> Green
+ (Differs _ _) -> Yellow
+ (OverlayOnly _) -> Red
+ (PortageOnly _) -> Magenta
+ (HackageOnly _) -> Cyan
+
+portageDiff :: EMap -> EMap -> (EMap, EMap, EMap)
+portageDiff p1 p2 = (in1, ins, in2)
+ where ins = Map.filter (not . null) $ Map.intersectionWith (List.intersectBy $ equating ebuildId) p1 p2
+ in1 = difference p1 p2
+ in2 = difference p2 p1
+ difference x y = Map.filter (not . null) $
+ Map.differenceWith (\xs ys ->
+ let lst = foldr (List.deleteBy (equating ebuildId)) xs ys in
+ if null lst
+ then Nothing
+ else Just lst
+ ) x y
+
+-- | Compares two ebuilds, returns True if they are equal.
+-- Disregards comments.
+equals :: FilePath -> FilePath -> IO Bool
+equals fp1 fp2 = do
+ -- don't leave halfopenfiles
+ f1 <- BS.readFile fp1
+ f2 <- BS.readFile fp2
+ return (equal' f1 f2)
+
+equal' :: BS.ByteString -> BS.ByteString -> Bool
+equal' = equating essence
+ where
+ essence = filter (not . isEmpty) . filter (not . isComment) . BS.lines
+ isComment = BS.isPrefixOf (BS.pack "#") . BS.dropWhile isSpace
+ isEmpty = BS.null . BS.dropWhile isSpace
diff --git a/TODO b/TODO
new file mode 100644
index 0000000..41e08f0
--- /dev/null
+++ b/TODO
@@ -0,0 +1,28 @@
+
+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
+
+Harder
+======
+
+* see if PackageIndex and IndexUtils from cabal install can be used instead of Index
+ see Distribution.Simple.PackageIndex
+ PackageIndex Ebuild?
+
+* make clear distinction 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
+
+* Merge the separate tool keyword-stat into hackport, and make it use the
+ hackport API.
+ See http://code.haskell.org/gentoo/keyword-stat/
+
+* Pick keywords from latest available ebuild
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/cabal/Cabal/Cabal.cabal b/cabal/Cabal/Cabal.cabal
new file mode 100644
index 0000000..a80e13b
--- /dev/null
+++ b/cabal/Cabal/Cabal.cabal
@@ -0,0 +1,193 @@
+Name: Cabal
+Version: 1.17.0
+Copyright: 2003-2006, Isaac Jones
+ 2005-2011, Duncan Coutts
+License: BSD3
+License-File: LICENSE
+Author: Isaac Jones <ijones@syntaxpolice.org>
+ Duncan Coutts <duncan@community.haskell.org>
+Maintainer: cabal-devel@haskell.org
+Homepage: http://www.haskell.org/cabal/
+bug-reports: https://github.com/haskell/cabal/issues
+Synopsis: A framework for packaging Haskell software
+Description:
+ The Haskell Common Architecture for Building Applications and
+ Libraries: a framework defining a common interface for authors to more
+ easily build their Haskell applications in a portable way.
+ .
+ The Haskell Cabal is part of a larger infrastructure for distributing,
+ organizing, and cataloging Haskell libraries and tools.
+Category: Distribution
+cabal-version: >=1.10
+Build-Type: Custom
+-- Even though we do use the default Setup.lhs it's vital to bootstrapping
+-- that we build Setup.lhs using our own local Cabal source code.
+
+Extra-Source-Files:
+ README changelog
+
+source-repository head
+ type: git
+ location: https://github.com/haskell/cabal/
+ subdir: Cabal
+
+Flag base4
+ Description: Choose the even newer, even smaller, split-up base package.
+
+Flag base3
+ Description: Choose the new smaller, split-up base package.
+
+Flag bytestring-in-base
+
+Library
+ build-depends: base >= 2 && < 5,
+ deepseq >= 1.3 && < 1.4,
+ filepath >= 1 && < 1.4
+ if flag(base4) { build-depends: base >= 4 } else { build-depends: base < 4 }
+ if flag(base3) { build-depends: base >= 3 } else { build-depends: base < 3 }
+ if flag(base3)
+ Build-Depends: directory >= 1 && < 1.3,
+ process >= 1 && < 1.2,
+ old-time >= 1 && < 1.2,
+ containers >= 0.1 && < 0.6,
+ array >= 0.1 && < 0.5,
+ pretty >= 1 && < 1.2
+ if flag(bytestring-in-base)
+ Build-Depends: base >= 2.0 && < 2.2
+ else
+ Build-Depends: base < 2.0 || >= 3.0, bytestring >= 0.9
+
+ if !os(windows)
+ Build-Depends: unix >= 2.0 && < 2.7
+
+ ghc-options: -Wall -fno-ignore-asserts
+ if impl(ghc >= 6.8)
+ ghc-options: -fwarn-tabs
+ nhc98-Options: -K4M
+
+ Exposed-Modules:
+ Distribution.Compiler,
+ Distribution.InstalledPackageInfo,
+ Distribution.License,
+ Distribution.Make,
+ Distribution.ModuleName,
+ Distribution.Package,
+ Distribution.PackageDescription,
+ Distribution.PackageDescription.Configuration,
+ Distribution.PackageDescription.Parse,
+ Distribution.PackageDescription.Check,
+ Distribution.PackageDescription.PrettyPrint,
+ Distribution.ParseUtils,
+ Distribution.ReadE,
+ Distribution.Simple,
+ Distribution.Simple.Build,
+ Distribution.Simple.Build.Macros,
+ Distribution.Simple.Build.PathsModule,
+ Distribution.Simple.BuildPaths,
+ Distribution.Simple.Bench,
+ Distribution.Simple.Command,
+ Distribution.Simple.Compiler,
+ Distribution.Simple.Configure,
+ Distribution.Simple.GHC,
+ Distribution.Simple.LHC,
+ Distribution.Simple.Haddock,
+ Distribution.Simple.Hpc,
+ Distribution.Simple.Hugs,
+ Distribution.Simple.Install,
+ Distribution.Simple.InstallDirs,
+ Distribution.Simple.JHC,
+ Distribution.Simple.LocalBuildInfo,
+ Distribution.Simple.NHC,
+ Distribution.Simple.PackageIndex,
+ Distribution.Simple.PreProcess,
+ Distribution.Simple.PreProcess.Unlit,
+ Distribution.Simple.Program,
+ Distribution.Simple.Program.Ar,
+ Distribution.Simple.Program.Builtin,
+ Distribution.Simple.Program.Db,
+ Distribution.Simple.Program.GHC,
+ Distribution.Simple.Program.HcPkg,
+ Distribution.Simple.Program.Hpc,
+ Distribution.Simple.Program.Ld,
+ Distribution.Simple.Program.Run,
+ Distribution.Simple.Program.Script,
+ Distribution.Simple.Program.Types,
+ Distribution.Simple.Register,
+ Distribution.Simple.Setup,
+ Distribution.Simple.SrcDist,
+ Distribution.Simple.Test,
+ Distribution.Simple.UHC,
+ Distribution.Simple.UserHooks,
+ Distribution.Simple.Utils,
+ Distribution.System,
+ Distribution.TestSuite,
+ Distribution.Text,
+ Distribution.Verbosity,
+ Distribution.Version,
+ Distribution.Compat.ReadP,
+ Language.Haskell.Extension
+
+ Other-Modules:
+ Distribution.GetOpt,
+ Distribution.Compat.Exception,
+ Distribution.Compat.CopyFile,
+ Distribution.Compat.TempFile,
+ Distribution.Simple.GHC.IPI641,
+ Distribution.Simple.GHC.IPI642,
+ Paths_Cabal
+
+ Default-Language: Haskell98
+ Default-Extensions: CPP
+
+-- Small, fast running tests.
+test-suite unit-tests
+ type: exitcode-stdio-1.0
+ main-is: UnitTests.hs
+ hs-source-dirs: tests
+ build-depends:
+ base,
+ test-framework,
+ test-framework-hunit,
+ test-framework-quickcheck2,
+ HUnit,
+ QuickCheck,
+ Cabal
+ Default-Language: Haskell98
+
+-- Large, system tests that build packages.
+test-suite package-tests
+ type: exitcode-stdio-1.0
+ main-is: PackageTests.hs
+ other-modules: PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check,
+ PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check,
+ PackageTests.BuildDeps.InternalLibrary0.Check,
+ PackageTests.BuildDeps.InternalLibrary1.Check,
+ PackageTests.BuildDeps.InternalLibrary2.Check,
+ PackageTests.BuildDeps.InternalLibrary3.Check,
+ PackageTests.BuildDeps.InternalLibrary4.Check,
+ PackageTests.BuildDeps.TargetSpecificDeps1.Check,
+ PackageTests.BuildDeps.TargetSpecificDeps2.Check,
+ PackageTests.BuildDeps.TargetSpecificDeps3.Check,
+ PackageTests.BuildDeps.SameDepsAllRound.Check,
+ PackageTests.TestOptions.Check,
+ PackageTests.TestStanza.Check,
+ PackageTests.TestSuiteExeV10.Check,
+ PackageTests.BenchmarkStanza.Check,
+ PackageTests.TemplateHaskell.Check,
+ PackageTests.PackageTester
+ hs-source-dirs: tests
+ build-depends:
+ base,
+ test-framework,
+ test-framework-quickcheck2 >= 0.2.12,
+ test-framework-hunit,
+ HUnit,
+ QuickCheck >= 2.1.0.1,
+ Cabal,
+ process,
+ directory,
+ filepath,
+ extensible-exceptions,
+ bytestring,
+ unix
+ Default-Language: Haskell98
diff --git a/cabal/Cabal/DefaultSetup.hs b/cabal/Cabal/DefaultSetup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/cabal/Cabal/DefaultSetup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/cabal/Cabal/Distribution/Compat/CopyFile.hs b/cabal/Cabal/Distribution/Compat/CopyFile.hs
new file mode 100644
index 0000000..3d96d72
--- /dev/null
+++ b/cabal/Cabal/Distribution/Compat/CopyFile.hs
@@ -0,0 +1,115 @@
+{-# OPTIONS -cpp #-}
+-- OPTIONS required for ghc-6.4.x compat, and must appear first
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -cpp #-}
+{-# OPTIONS_NHC98 -cpp #-}
+{-# OPTIONS_JHC -fcpp #-}
+-- #hide
+module Distribution.Compat.CopyFile (
+ copyFile,
+ copyOrdinaryFile,
+ copyExecutableFile,
+ setFileOrdinary,
+ setFileExecutable,
+ setDirOrdinary,
+ ) where
+
+#ifdef __GLASGOW_HASKELL__
+
+import Control.Monad
+ ( when )
+import Control.Exception
+ ( bracket, bracketOnError )
+import Distribution.Compat.Exception
+ ( catchIO )
+#if __GLASGOW_HASKELL__ >= 608
+import Distribution.Compat.Exception
+ ( throwIOIO )
+import System.IO.Error
+ ( ioeSetLocation )
+#endif
+import System.Directory
+ ( renameFile, removeFile )
+import Distribution.Compat.TempFile
+ ( openBinaryTempFile )
+import System.FilePath
+ ( takeDirectory )
+import System.IO
+ ( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf )
+import Foreign
+ ( allocaBytes )
+#endif /* __GLASGOW_HASKELL__ */
+
+#ifndef mingw32_HOST_OS
+#if __GLASGOW_HASKELL__ >= 611
+import System.Posix.Internals (withFilePath)
+#else
+import Foreign.C (withCString)
+#endif
+import System.Posix.Types
+ ( FileMode )
+import System.Posix.Internals
+ ( c_chmod )
+#if __GLASGOW_HASKELL__ >= 608
+import Foreign.C
+ ( throwErrnoPathIfMinus1_ )
+#else
+import Foreign.C
+ ( throwErrnoIfMinus1_ )
+#endif
+#endif /* mingw32_HOST_OS */
+
+copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO ()
+copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest
+copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest
+
+setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO ()
+#ifndef mingw32_HOST_OS
+setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r--
+setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x
+
+setFileMode :: FilePath -> FileMode -> IO ()
+setFileMode name m =
+#if __GLASGOW_HASKELL__ >= 611
+ withFilePath name $ \s -> do
+#else
+ withCString name $ \s -> do
+#endif
+#if __GLASGOW_HASKELL__ >= 608
+ throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)
+#else
+ throwErrnoIfMinus1_ name (c_chmod s m)
+#endif
+#else
+setFileOrdinary _ = return ()
+setFileExecutable _ = return ()
+#endif
+-- This happens to be true on Unix and currently on Windows too:
+setDirOrdinary = setFileExecutable
+
+copyFile :: FilePath -> FilePath -> IO ()
+#ifdef __GLASGOW_HASKELL__
+copyFile fromFPath toFPath =
+ copy
+#if __GLASGOW_HASKELL__ >= 608
+ `catchIO` (\ioe -> throwIOIO (ioeSetLocation ioe "copyFile"))
+#endif
+ where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
+ bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) ->
+ do allocaBytes bufferSize $ copyContents hFrom hTmp
+ hClose hTmp
+ renameFile tmpFPath toFPath
+ openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp"
+ cleanTmp (tmpFPath, hTmp) = do
+ hClose hTmp `catchIO` \_ -> return ()
+ removeFile tmpFPath `catchIO` \_ -> return ()
+ bufferSize = 4096
+
+ copyContents hFrom hTo buffer = do
+ count <- hGetBuf hFrom buffer bufferSize
+ when (count > 0) $ do
+ hPutBuf hTo buffer count
+ copyContents hFrom hTo buffer
+#else
+copyFile fromFPath toFPath = readFile fromFPath >>= writeFile toFPath
+#endif
diff --git a/cabal/Cabal/Distribution/Compat/Exception.hs b/cabal/Cabal/Distribution/Compat/Exception.hs
new file mode 100644
index 0000000..ae8d9d5
--- /dev/null
+++ b/cabal/Cabal/Distribution/Compat/Exception.hs
@@ -0,0 +1,61 @@
+{-# OPTIONS -cpp #-}
+-- OPTIONS required for ghc-6.4.x compat, and must appear first
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -cpp #-}
+{-# OPTIONS_NHC98 -cpp #-}
+{-# OPTIONS_JHC -fcpp #-}
+
+#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610))
+#define NEW_EXCEPTION
+#endif
+
+module Distribution.Compat.Exception (
+ Exception.IOException,
+ onException,
+ catchIO,
+ catchExit,
+ throwIOIO,
+ tryIO,
+ ) where
+
+import System.Exit
+import qualified Control.Exception as Exception
+
+onException :: IO a -> IO b -> IO a
+#ifdef NEW_EXCEPTION
+onException = Exception.onException
+#else
+onException io what = io `Exception.catch` \e -> do what
+ Exception.throw e
+#endif
+
+throwIOIO :: Exception.IOException -> IO a
+#ifdef NEW_EXCEPTION
+throwIOIO = Exception.throwIO
+#else
+throwIOIO = Exception.throwIO . Exception.IOException
+#endif
+
+tryIO :: IO a -> IO (Either Exception.IOException a)
+#ifdef NEW_EXCEPTION
+tryIO = Exception.try
+#else
+tryIO = Exception.tryJust Exception.ioErrors
+#endif
+
+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
+#ifdef NEW_EXCEPTION
+catchIO = Exception.catch
+#else
+catchIO = Exception.catchJust Exception.ioErrors
+#endif
+
+catchExit :: IO a -> (ExitCode -> IO a) -> IO a
+#ifdef NEW_EXCEPTION
+catchExit = Exception.catch
+#else
+catchExit = Exception.catchJust exitExceptions
+ where exitExceptions (Exception.ExitException ee) = Just ee
+ exitExceptions _ = Nothing
+#endif
+
diff --git a/cabal/Cabal/Distribution/Compat/ReadP.hs b/cabal/Cabal/Distribution/Compat/ReadP.hs
new file mode 100644
index 0000000..e087ed2
--- /dev/null
+++ b/cabal/Cabal/Distribution/Compat/ReadP.hs
@@ -0,0 +1,381 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Compat.ReadP
+-- Copyright : (c) The University of Glasgow 2002
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Portability : portable
+--
+-- This is a library of parser combinators, originally written by Koen Claessen.
+-- It parses all alternatives in parallel, so it never keeps hold of
+-- the beginning of the input string, a common source of space leaks with
+-- other parsers. The '(+++)' choice combinator is genuinely commutative;
+-- it makes no difference which branch is \"shorter\".
+--
+-- See also Koen's paper /Parallel Parsing Processes/
+-- (<http://www.cs.chalmers.se/~koen/publications.html>).
+--
+-- This version of ReadP has been locally hacked to make it H98, by
+-- Martin Sj&#xF6;gren <mailto:msjogren@gmail.com>
+--
+-- The unit tests have been moved to UnitTest.Distribution.Compat.ReadP, by
+-- Mark Lentczner <mailto:mark@glyphic.com>
+-----------------------------------------------------------------------------
+
+module Distribution.Compat.ReadP
+ (
+ -- * The 'ReadP' type
+ ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus
+
+ -- * Primitive operations
+ get, -- :: ReadP Char
+ look, -- :: ReadP String
+ (+++), -- :: ReadP a -> ReadP a -> ReadP a
+ (<++), -- :: ReadP a -> ReadP a -> ReadP a
+ gather, -- :: ReadP a -> ReadP (String, a)
+
+ -- * Other operations
+ pfail, -- :: ReadP a
+ satisfy, -- :: (Char -> Bool) -> ReadP Char
+ char, -- :: Char -> ReadP Char
+ string, -- :: String -> ReadP String
+ munch, -- :: (Char -> Bool) -> ReadP String
+ munch1, -- :: (Char -> Bool) -> ReadP String
+ skipSpaces, -- :: ReadP ()
+ choice, -- :: [ReadP a] -> ReadP a
+ count, -- :: Int -> ReadP a -> ReadP [a]
+ between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a
+ option, -- :: a -> ReadP a -> ReadP a
+ optional, -- :: ReadP a -> ReadP ()
+ many, -- :: ReadP a -> ReadP [a]
+ many1, -- :: ReadP a -> ReadP [a]
+ skipMany, -- :: ReadP a -> ReadP ()
+ skipMany1, -- :: ReadP a -> ReadP ()
+ sepBy, -- :: ReadP a -> ReadP sep -> ReadP [a]
+ sepBy1, -- :: ReadP a -> ReadP sep -> ReadP [a]
+ endBy, -- :: ReadP a -> ReadP sep -> ReadP [a]
+ endBy1, -- :: ReadP a -> ReadP sep -> ReadP [a]
+ chainr, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
+ chainl, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a
+ chainl1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
+ chainr1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a
+ manyTill, -- :: ReadP a -> ReadP end -> ReadP [a]
+
+ -- * Running a parser
+ ReadS, -- :: *; = String -> [(a,String)]
+ readP_to_S, -- :: ReadP a -> ReadS a
+ readS_to_P -- :: ReadS a -> ReadP a
+ )
+ where
+
+import Control.Monad( MonadPlus(..), liftM2 )
+import Data.Char (isSpace)
+
+infixr 5 +++, <++
+
+-- ---------------------------------------------------------------------------
+-- The P type
+-- is representation type -- should be kept abstract
+
+data P s a
+ = Get (s -> P s a)
+ | Look ([s] -> P s a)
+ | Fail
+ | Result a (P s a)
+ | Final [(a,[s])] -- invariant: list is non-empty!
+
+-- Monad, MonadPlus
+
+instance Monad (P s) where
+ return x = Result x Fail
+
+ (Get f) >>= k = Get (\c -> f c >>= k)
+ (Look f) >>= k = Look (\s -> f s >>= k)
+ Fail >>= _ = Fail
+ (Result x p) >>= k = k x `mplus` (p >>= k)
+ (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s]
+
+ fail _ = Fail
+
+instance MonadPlus (P s) where
+ mzero = Fail
+
+ -- most common case: two gets are combined
+ Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c)
+
+ -- results are delivered as soon as possible
+ Result x p `mplus` q = Result x (p `mplus` q)
+ p `mplus` Result x q = Result x (p `mplus` q)
+
+ -- fail disappears
+ Fail `mplus` p = p
+ p `mplus` Fail = p
+
+ -- two finals are combined
+ -- final + look becomes one look and one final (=optimization)
+ -- final + sthg else becomes one look and one final
+ Final r `mplus` Final t = Final (r ++ t)
+ Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s))
+ Final r `mplus` p = Look (\s -> Final (r ++ run p s))
+ Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r))
+ p `mplus` Final r = Look (\s -> Final (run p s ++ r))
+
+ -- two looks are combined (=optimization)
+ -- look + sthg else floats upwards
+ Look f `mplus` Look g = Look (\s -> f s `mplus` g s)
+ Look f `mplus` p = Look (\s -> f s `mplus` p)
+ p `mplus` Look f = Look (\s -> p `mplus` f s)
+
+-- ---------------------------------------------------------------------------
+-- The ReadP type
+
+newtype Parser r s a = R ((a -> P s r) -> P s r)
+type ReadP r a = Parser r Char a
+
+-- Functor, Monad, MonadPlus
+
+instance Functor (Parser r s) where
+ fmap h (R f) = R (\k -> f (k . h))
+
+instance Monad (Parser r s) where
+ return x = R (\k -> k x)
+ fail _ = R (\_ -> Fail)
+ R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k))
+
+--instance MonadPlus (Parser r s) where
+-- mzero = pfail
+-- mplus = (+++)
+
+-- ---------------------------------------------------------------------------
+-- Operations over P
+
+final :: [(a,[s])] -> P s a
+-- Maintains invariant for Final constructor
+final [] = Fail
+final r = Final r
+
+run :: P c a -> ([c] -> [(a, [c])])
+run (Get f) (c:s) = run (f c) s
+run (Look f) s = run (f s) s
+run (Result x p) s = (x,s) : run p s
+run (Final r) _ = r
+run _ _ = []
+
+-- ---------------------------------------------------------------------------
+-- Operations over ReadP
+
+get :: ReadP r Char
+-- ^ Consumes and returns the next character.
+-- Fails if there is no input left.
+get = R Get
+
+look :: ReadP r String
+-- ^ Look-ahead: returns the part of the input that is left, without
+-- consuming it.
+look = R Look
+
+pfail :: ReadP r a
+-- ^ Always fails.
+pfail = R (\_ -> Fail)
+
+(+++) :: ReadP r a -> ReadP r a -> ReadP r a
+-- ^ Symmetric choice.
+R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k)
+
+(<++) :: ReadP a a -> ReadP r a -> ReadP r a
+-- ^ Local, exclusive, left-biased choice: If left parser
+-- locally produces any result at all, then right parser is
+-- not used.
+R f <++ q =
+ do s <- look
+ probe (f return) s 0
+ where
+ probe (Get f') (c:s) n = probe (f' c) s (n+1 :: Int)
+ probe (Look f') s n = probe (f' s) s n
+ probe p@(Result _ _) _ n = discard n >> R (p >>=)
+ probe (Final r) _ _ = R (Final r >>=)
+ probe _ _ _ = q
+
+ discard 0 = return ()
+ discard n = get >> discard (n-1 :: Int)
+
+gather :: ReadP (String -> P Char r) a -> ReadP r (String, a)
+-- ^ Transforms a parser into one that does the same, but
+-- in addition returns the exact characters read.
+-- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument
+-- is built using any occurrences of readS_to_P.
+gather (R m) =
+ R (\k -> gath id (m (\a -> return (\s -> k (s,a)))))
+ where
+ gath l (Get f) = Get (\c -> gath (l.(c:)) (f c))
+ gath _ Fail = Fail
+ gath l (Look f) = Look (\s -> gath l (f s))
+ gath l (Result k p) = k (l []) `mplus` gath l p
+ gath _ (Final _) = error "do not use readS_to_P in gather!"
+
+-- ---------------------------------------------------------------------------
+-- Derived operations
+
+satisfy :: (Char -> Bool) -> ReadP r Char
+-- ^ Consumes and returns the next character, if it satisfies the
+-- specified predicate.
+satisfy p = do c <- get; if p c then return c else pfail
+
+char :: Char -> ReadP r Char
+-- ^ Parses and returns the specified character.
+char c = satisfy (c ==)
+
+string :: String -> ReadP r String
+-- ^ Parses and returns the specified string.
+string this = do s <- look; scan this s
+ where
+ scan [] _ = do return this
+ scan (x:xs) (y:ys) | x == y = do get >> scan xs ys
+ scan _ _ = do pfail
+
+munch :: (Char -> Bool) -> ReadP r String
+-- ^ Parses the first zero or more characters satisfying the predicate.
+munch p =
+ do s <- look
+ scan s
+ where
+ scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s)
+ scan _ = do return ""
+
+munch1 :: (Char -> Bool) -> ReadP r String
+-- ^ Parses the first one or more characters satisfying the predicate.
+munch1 p =
+ do c <- get
+ if p c then do s <- munch p; return (c:s)
+ else pfail
+
+choice :: [ReadP r a] -> ReadP r a
+-- ^ Combines all parsers in the specified list.
+choice [] = pfail
+choice [p] = p
+choice (p:ps) = p +++ choice ps
+
+skipSpaces :: ReadP r ()
+-- ^ Skips all whitespace.
+skipSpaces =
+ do s <- look
+ skip s
+ where
+ skip (c:s) | isSpace c = do _ <- get; skip s
+ skip _ = do return ()
+
+count :: Int -> ReadP r a -> ReadP r [a]
+-- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of
+-- results is returned.
+count n p = sequence (replicate n p)
+
+between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a
+-- ^ @ between open close p @ parses @open@, followed by @p@ and finally
+-- @close@. Only the value of @p@ is returned.
+between open close p = do _ <- open
+ x <- p
+ _ <- close
+ return x
+
+option :: a -> ReadP r a -> ReadP r a
+-- ^ @option x p@ will either parse @p@ or return @x@ without consuming
+-- any input.
+option x p = p +++ return x
+
+optional :: ReadP r a -> ReadP r ()
+-- ^ @optional p@ optionally parses @p@ and always returns @()@.
+optional p = (p >> return ()) +++ return ()
+
+many :: ReadP r a -> ReadP r [a]
+-- ^ Parses zero or more occurrences of the given parser.
+many p = return [] +++ many1 p
+
+many1 :: ReadP r a -> ReadP r [a]
+-- ^ Parses one or more occurrences of the given parser.
+many1 p = liftM2 (:) p (many p)
+
+skipMany :: ReadP r a -> ReadP r ()
+-- ^ Like 'many', but discards the result.
+skipMany p = many p >> return ()
+
+skipMany1 :: ReadP r a -> ReadP r ()
+-- ^ Like 'many1', but discards the result.
+skipMany1 p = p >> skipMany p
+
+sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a]
+-- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@.
+-- Returns a list of values returned by @p@.
+sepBy p sep = sepBy1 p sep +++ return []
+
+sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a]
+-- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@.
+-- Returns a list of values returned by @p@.
+sepBy1 p sep = liftM2 (:) p (many (sep >> p))
+
+endBy :: ReadP r a -> ReadP r sep -> ReadP r [a]
+-- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended
+-- by @sep@.
+endBy p sep = many (do x <- p ; _ <- sep ; return x)
+
+endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a]
+-- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended
+-- by @sep@.
+endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x)
+
+chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a
+-- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@.
+-- Returns a value produced by a /right/ associative application of all
+-- functions returned by @op@. If there are no occurrences of @p@, @x@ is
+-- returned.
+chainr p op x = chainr1 p op +++ return x
+
+chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a
+-- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@.
+-- Returns a value produced by a /left/ associative application of all
+-- functions returned by @op@. If there are no occurrences of @p@, @x@ is
+-- returned.
+chainl p op x = chainl1 p op +++ return x
+
+chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a
+-- ^ Like 'chainr', but parses one or more occurrences of @p@.
+chainr1 p op = scan
+ where scan = p >>= rest
+ rest x = do f <- op
+ y <- scan
+ return (f x y)
+ +++ return x
+
+chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a
+-- ^ Like 'chainl', but parses one or more occurrences of @p@.
+chainl1 p op = p >>= rest
+ where rest x = do f <- op
+ y <- p
+ rest (f x y)
+ +++ return x
+
+manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a]
+-- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@
+-- succeeds. Returns a list of values returned by @p@.
+manyTill p end = scan
+ where scan = (end >> return []) <++ (liftM2 (:) p scan)
+
+-- ---------------------------------------------------------------------------
+-- Converting between ReadP and Read
+
+readP_to_S :: ReadP a a -> ReadS a
+-- ^ Converts a parser into a Haskell ReadS-style function.
+-- This is the main way in which you can \"run\" a 'ReadP' parser:
+-- the expanded type is
+-- @ readP_to_S :: ReadP a -> String -> [(a,String)] @
+readP_to_S (R f) = run (f return)
+
+readS_to_P :: ReadS a -> ReadP r a
+-- ^ Converts a Haskell ReadS-style function into a parser.
+-- Warning: This introduces local backtracking in the resulting
+-- parser, and therefore a possible inefficiency.
+readS_to_P r =
+ R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))
+
+
+
diff --git a/cabal/Cabal/Distribution/Compat/TempFile.hs b/cabal/Cabal/Distribution/Compat/TempFile.hs
new file mode 100644
index 0000000..9feddeb
--- /dev/null
+++ b/cabal/Cabal/Distribution/Compat/TempFile.hs
@@ -0,0 +1,204 @@
+{-# OPTIONS -cpp #-}
+-- OPTIONS required for ghc-6.4.x compat, and must appear first
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -cpp #-}
+{-# OPTIONS_NHC98 -cpp #-}
+{-# OPTIONS_JHC -fcpp #-}
+-- #hide
+module Distribution.Compat.TempFile (
+ openTempFile,
+ openBinaryTempFile,
+ openNewBinaryFile,
+ createTempDirectory,
+ ) where
+
+
+import System.FilePath ((</>))
+import Foreign.C (eEXIST)
+
+#if __NHC__ || __HUGS__
+import System.IO (openFile, openBinaryFile,
+ Handle, IOMode(ReadWriteMode))
+import System.Directory (doesFileExist)
+import System.FilePath ((<.>), splitExtension)
+import System.IO.Error (try, isAlreadyExistsError)
+#else
+import System.IO (Handle, openTempFile, openBinaryTempFile)
+import Data.Bits ((.|.))
+import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR,
+ o_BINARY, o_NONBLOCK, o_NOCTTY)
+import System.IO.Error (isAlreadyExistsError)
+#if __GLASGOW_HASKELL__ >= 611
+import System.Posix.Internals (withFilePath)
+#else
+import Foreign.C (withCString)
+#endif
+import Foreign.C (CInt)
+#if __GLASGOW_HASKELL__ >= 611
+import GHC.IO.Handle.FD (fdToHandle)
+#else
+import GHC.Handle (fdToHandle)
+#endif
+import Distribution.Compat.Exception (onException, tryIO)
+#endif
+import Foreign.C (getErrno, errnoToIOError)
+
+#if __NHC__
+import System.Posix.Types (CPid(..))
+foreign import ccall unsafe "getpid" c_getpid :: IO CPid
+#else
+import System.Posix.Internals (c_getpid)
+#endif
+
+#ifdef mingw32_HOST_OS
+import System.Directory ( createDirectory )
+#else
+import qualified System.Posix
+#endif
+
+-- ------------------------------------------------------------
+-- * temporary files
+-- ------------------------------------------------------------
+
+-- This is here for Haskell implementations that do not come with
+-- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9.
+-- TODO: Not sure about jhc
+
+#if __NHC__ || __HUGS__
+-- use a temporary filename that doesn't already exist.
+-- NB. *not* secure (we don't atomically lock the tmp file we get)
+openTempFile :: FilePath -> String -> IO (FilePath, Handle)
+openTempFile tmp_dir template
+ = do x <- getProcessID
+ findTempName x
+ where
+ (templateBase, templateExt) = splitExtension template
+ findTempName :: Int -> IO (FilePath, Handle)
+ findTempName x
+ = do let path = tmp_dir </> (templateBase ++ "-" ++ show x) <.> templateExt
+ b <- doesFileExist path
+ if b then findTempName (x+1)
+ else do hnd <- openFile path ReadWriteMode
+ return (path, hnd)
+
+openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
+openBinaryTempFile tmp_dir template
+ = do x <- getProcessID
+ findTempName x
+ where
+ (templateBase, templateExt) = splitExtension template
+ findTempName :: Int -> IO (FilePath, Handle)
+ findTempName x
+ = do let path = tmp_dir </> (templateBase ++ "-" ++ show x) <.> templateExt
+ b <- doesFileExist path
+ if b then findTempName (x+1)
+ else do hnd <- openBinaryFile path ReadWriteMode
+ return (path, hnd)
+
+openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
+openNewBinaryFile = openBinaryTempFile
+
+getProcessID :: IO Int
+getProcessID = fmap fromIntegral c_getpid
+#else
+-- This is a copy/paste of the openBinaryTempFile definition, but
+-- if uses 666 rather than 600 for the permissions. The base library
+-- needs to be changed to make this better.
+openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
+openNewBinaryFile dir template = do
+ pid <- c_getpid
+ findTempName pid
+ where
+ -- We split off the last extension, so we can use .foo.ext files
+ -- for temporary files (hidden on Unix OSes). Unfortunately we're
+ -- below filepath in the hierarchy here.
+ (prefix,suffix) =
+ case break (== '.') $ reverse template of
+ -- First case: template contains no '.'s. Just re-reverse it.
+ (rev_suffix, "") -> (reverse rev_suffix, "")
+ -- Second case: template contains at least one '.'. Strip the
+ -- dot from the prefix and prepend it to the suffix (if we don't
+ -- do this, the unique number will get added after the '.' and
+ -- thus be part of the extension, which is wrong.)
+ (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
+ -- Otherwise, something is wrong, because (break (== '.')) should
+ -- always return a pair with either the empty string or a string
+ -- beginning with '.' as the second component.
+ _ -> error "bug in System.IO.openTempFile"
+
+ oflags = rw_flags .|. o_EXCL .|. o_BINARY
+
+#if __GLASGOW_HASKELL__ < 611
+ withFilePath = withCString
+#endif
+
+ findTempName x = do
+ fd <- withFilePath filepath $ \ f ->
+ c_open f oflags 0o666
+ if fd < 0
+ then do
+ errno <- getErrno
+ if errno == eEXIST
+ then findTempName (x+1)
+ else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir))
+ else do
+ -- TODO: We want to tell fdToHandle what the filepath is,
+ -- as any exceptions etc will only be able to report the
+ -- fd currently
+ h <-
+#if __GLASGOW_HASKELL__ >= 609
+ fdToHandle fd
+#elif __GLASGOW_HASKELL__ <= 606 && defined(mingw32_HOST_OS)
+ -- fdToHandle is borked on Windows with ghc-6.6.x
+ openFd (fromIntegral fd) Nothing False filepath
+ ReadWriteMode True
+#else
+ fdToHandle (fromIntegral fd)
+#endif
+ `onException` c_close fd
+ return (filepath, h)
+ where
+ filename = prefix ++ show x ++ suffix
+ filepath = dir `combine` filename
+
+ -- FIXME: bits copied from System.FilePath
+ combine a b
+ | null b = a
+ | null a = b
+ | last a == pathSeparator = a ++ b
+ | otherwise = a ++ [pathSeparator] ++ b
+
+-- FIXME: Should use filepath library
+pathSeparator :: Char
+#ifdef mingw32_HOST_OS
+pathSeparator = '\\'
+#else
+pathSeparator = '/'
+#endif
+
+-- FIXME: Copied from GHC.Handle
+std_flags, output_flags, rw_flags :: CInt
+std_flags = o_NONBLOCK .|. o_NOCTTY
+output_flags = std_flags .|. o_CREAT
+rw_flags = output_flags .|. o_RDWR
+#endif
+
+createTempDirectory :: FilePath -> String -> IO FilePath
+createTempDirectory dir template = do
+ pid <- c_getpid
+ findTempName pid
+ where
+ findTempName x = do
+ let dirpath = dir </> template ++ "-" ++ show x
+ r <- tryIO $ mkPrivateDir dirpath
+ case r of
+ Right _ -> return dirpath
+ Left e | isAlreadyExistsError e -> findTempName (x+1)
+ | otherwise -> ioError e
+
+mkPrivateDir :: String -> IO ()
+#ifdef mingw32_HOST_OS
+mkPrivateDir s = createDirectory s
+#else
+mkPrivateDir s = System.Posix.createDirectory s 0o700
+#endif
diff --git a/cabal/Cabal/Distribution/Compiler.hs b/cabal/Cabal/Distribution/Compiler.hs
new file mode 100644
index 0000000..82abd46
--- /dev/null
+++ b/cabal/Cabal/Distribution/Compiler.hs
@@ -0,0 +1,158 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Compiler
+-- Copyright : Isaac Jones 2003-2004
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This has an enumeration of the various compilers that Cabal knows about. It
+-- also specifies the default compiler. Sadly you'll often see code that does
+-- case analysis on this compiler flavour enumeration like:
+--
+-- > case compilerFlavor comp of
+-- > GHC -> GHC.getInstalledPackages verbosity packageDb progconf
+-- > JHC -> JHC.getInstalledPackages verbosity packageDb progconf
+--
+-- Obviously it would be better to use the proper 'Compiler' abstraction
+-- because that would keep all the compiler-specific code together.
+-- Unfortunately we cannot make this change yet without breaking the
+-- 'UserHooks' api, which would break all custom @Setup.hs@ files, so for the
+-- moment we just have to live with this deficiency. If you're interested, see
+-- ticket #50.
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.Compiler (
+ -- * Compiler flavor
+ CompilerFlavor(..),
+ buildCompilerFlavor,
+ defaultCompilerFlavor,
+ parseCompilerFlavorCompat,
+
+ -- * Compiler id
+ CompilerId(..),
+ ) where
+
+import Distribution.Version (Version(..))
+
+import qualified System.Info (compilerName)
+import Distribution.Text (Text(..), display)
+import qualified Distribution.Compat.ReadP as Parse
+import qualified Text.PrettyPrint as Disp
+import Text.PrettyPrint ((<>))
+
+import qualified Data.Char as Char (toLower, isDigit, isAlphaNum)
+import Control.Monad (when)
+
+data CompilerFlavor = GHC | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC
+ | OtherCompiler String
+ deriving (Show, Read, Eq, Ord)
+
+knownCompilerFlavors :: [CompilerFlavor]
+knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]
+
+instance Text CompilerFlavor where
+ disp (OtherCompiler name) = Disp.text name
+ disp NHC = Disp.text "nhc98"
+ disp other = Disp.text (lowercase (show other))
+
+ parse = do
+ comp <- Parse.munch1 Char.isAlphaNum
+ when (all Char.isDigit comp) Parse.pfail
+ return (classifyCompilerFlavor comp)
+
+classifyCompilerFlavor :: String -> CompilerFlavor
+classifyCompilerFlavor s =
+ case lookup (lowercase s) compilerMap of
+ Just compiler -> compiler
+ Nothing -> OtherCompiler s
+ where
+ compilerMap = [ (display compiler, compiler)
+ | compiler <- knownCompilerFlavors ]
+
+
+--TODO: In some future release, remove 'parseCompilerFlavorCompat' and use
+-- ordinary 'parse'. Also add ("nhc", NHC) to the above 'compilerMap'.
+
+-- | Like 'classifyCompilerFlavor' but compatible with the old ReadS parser.
+--
+-- It is compatible in the sense that it accepts only the same strings,
+-- eg "GHC" but not "ghc". However other strings get mapped to 'OtherCompiler'.
+-- The point of this is that we do not allow extra valid values that would
+-- upset older Cabal versions that had a stricter parser however we cope with
+-- new values more gracefully so that we'll be able to introduce new value in
+-- future without breaking things so much.
+--
+parseCompilerFlavorCompat :: Parse.ReadP r CompilerFlavor
+parseCompilerFlavorCompat = do
+ comp <- Parse.munch1 Char.isAlphaNum
+ when (all Char.isDigit comp) Parse.pfail
+ case lookup comp compilerMap of
+ Just compiler -> return compiler
+ Nothing -> return (OtherCompiler comp)
+ where
+ compilerMap = [ (show compiler, compiler)
+ | compiler <- knownCompilerFlavors
+ , compiler /= YHC ]
+
+buildCompilerFlavor :: CompilerFlavor
+buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName
+
+-- | The default compiler flavour to pick when compiling stuff. This defaults
+-- to the compiler used to build the Cabal lib.
+--
+-- However if it's not a recognised compiler then it's 'Nothing' and the user
+-- will have to specify which compiler they want.
+--
+defaultCompilerFlavor :: Maybe CompilerFlavor
+defaultCompilerFlavor = case buildCompilerFlavor of
+ OtherCompiler _ -> Nothing
+ _ -> Just buildCompilerFlavor
+
+-- ------------------------------------------------------------
+-- * Compiler Id
+-- ------------------------------------------------------------
+
+data CompilerId = CompilerId CompilerFlavor Version
+ deriving (Eq, Ord, Read, Show)
+
+instance Text CompilerId where
+ disp (CompilerId f (Version [] _)) = disp f
+ disp (CompilerId f v) = disp f <> Disp.char '-' <> disp v
+
+ parse = do
+ flavour <- parse
+ version <- (Parse.char '-' >> parse) Parse.<++ return (Version [] [])
+ return (CompilerId flavour version)
+
+lowercase :: String -> String
+lowercase = map Char.toLower
diff --git a/cabal/Cabal/Distribution/GetOpt.hs b/cabal/Cabal/Distribution/GetOpt.hs
new file mode 100644
index 0000000..14725d3
--- /dev/null
+++ b/cabal/Cabal/Distribution/GetOpt.hs
@@ -0,0 +1,335 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.GetOpt
+-- Copyright : (c) Sven Panne 2002-2005
+-- License : BSD-style (see the file libraries/base/LICENSE)
+--
+-- Maintainer : libraries@haskell.org
+-- Portability : portable
+--
+-- This library provides facilities for parsing the command-line options
+-- in a standalone program. It is essentially a Haskell port of the GNU
+-- @getopt@ library.
+--
+-----------------------------------------------------------------------------
+
+{-
+Sven Panne <Sven.Panne@informatik.uni-muenchen.de> Oct. 1996 (small
+changes Dec. 1997)
+
+Two rather obscure features are missing: The Bash 2.0 non-option hack
+(if you don't already know it, you probably don't want to hear about
+it...) and the recognition of long options with a single dash
+(e.g. '-help' is recognised as '--help', as long as there is no short
+option 'h').
+
+Other differences between GNU's getopt and this implementation:
+
+* To enforce a coherent description of options and arguments, there
+ are explanation fields in the option/argument descriptor.
+
+* Error messages are now more informative, but no longer POSIX
+ compliant... :-(
+
+And a final Haskell advertisement: The GNU C implementation uses well
+over 1100 lines, we need only 195 here, including a 46 line example!
+:-)
+-}
+
+-- #hide
+module Distribution.GetOpt (
+ -- * GetOpt
+ getOpt, getOpt',
+ usageInfo,
+ ArgOrder(..),
+ OptDescr(..),
+ ArgDescr(..),
+
+ -- * Example
+
+ -- $example
+) where
+
+import Data.List ( isPrefixOf, intersperse, find )
+
+-- |What to do with options following non-options
+data ArgOrder a
+ = RequireOrder -- ^ no option processing after first non-option
+ | Permute -- ^ freely intersperse options and non-options
+ | ReturnInOrder (String -> a) -- ^ wrap non-options into options
+
+{-|
+Each 'OptDescr' describes a single option.
+
+The arguments to 'Option' are:
+
+* list of short option characters
+
+* list of long option strings (without \"--\")
+
+* argument descriptor
+
+* explanation of option for user
+-}
+data OptDescr a = -- description of a single options:
+ Option [Char] -- list of short option characters
+ [String] -- list of long option strings (without "--")
+ (ArgDescr a) -- argument descriptor
+ String -- explanation of option for user
+
+-- |Describes whether an option takes an argument or not, and if so
+-- how the argument is injected into a value of type @a@.
+data ArgDescr a
+ = NoArg a -- ^ no argument expected
+ | ReqArg (String -> a) String -- ^ option requires argument
+ | OptArg (Maybe String -> a) String -- ^ optional argument
+
+data OptKind a -- kind of cmd line arg (internal use only):
+ = Opt a -- an option
+ | UnreqOpt String -- an un-recognized option
+ | NonOpt String -- a non-option
+ | EndOfOpts -- end-of-options marker (i.e. "--")
+ | OptErr String -- something went wrong...
+
+-- | Return a string describing the usage of a command, derived from
+-- the header (first argument) and the options described by the
+-- second argument.
+usageInfo :: String -- header
+ -> [OptDescr a] -- option descriptors
+ -> String -- nicely formatted decription of options
+usageInfo header optDescr = unlines (header:table)
+ where (ss,ls,ds) = unzip3 [ (sepBy ", " (map (fmtShort ad) sos)
+ ,concatMap (fmtLong ad) (take 1 los)
+ ,d)
+ | Option sos los ad d <- optDescr ]
+ ssWidth = (maximum . map length) ss
+ lsWidth = (maximum . map length) ls
+ dsWidth = 30 `max` (80 - (ssWidth + lsWidth + 3))
+ table = [ " " ++ padTo ssWidth so' ++
+ " " ++ padTo lsWidth lo' ++
+ " " ++ d'
+ | (so,lo,d) <- zip3 ss ls ds
+ , (so',lo',d') <- fmtOpt dsWidth so lo d ]
+ padTo n x = take n (x ++ repeat ' ')
+ sepBy s = concat . intersperse s
+
+fmtOpt :: Int -> String -> String -> String -> [(String, String, String)]
+fmtOpt descrWidth so lo descr =
+ case wrapText descrWidth descr of
+ [] -> [(so,lo,"")]
+ (d:ds) -> (so,lo,d) : [ ("","",d') | d' <- ds ]
+
+fmtShort :: ArgDescr a -> Char -> String
+fmtShort (NoArg _ ) so = "-" ++ [so]
+fmtShort (ReqArg _ _) so = "-" ++ [so]
+fmtShort (OptArg _ _) so = "-" ++ [so]
+
+fmtLong :: ArgDescr a -> String -> String
+fmtLong (NoArg _ ) lo = "--" ++ lo
+fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad
+fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"
+
+wrapText :: Int -> String -> [String]
+wrapText width = map unwords . wrap 0 [] . words
+ where wrap :: Int -> [String] -> [String] -> [[String]]
+ wrap 0 [] (w:ws)
+ | length w + 1 > width
+ = wrap (length w) [w] ws
+ wrap col line (w:ws)
+ | col + length w + 1 > width
+ = reverse line : wrap 0 [] (w:ws)
+ wrap col line (w:ws)
+ = let col' = col + length w + 1
+ in wrap col' (w:line) ws
+ wrap _ [] [] = []
+ wrap _ line [] = [reverse line]
+
+{-|
+Process the command-line, and return the list of values that matched
+(and those that didn\'t). The arguments are:
+
+* The order requirements (see 'ArgOrder')
+
+* The option descriptions (see 'OptDescr')
+
+* The actual command line arguments (presumably got from
+ 'System.Environment.getArgs').
+
+'getOpt' returns a triple consisting of the option arguments, a list
+of non-options, and a list of error messages.
+-}
+getOpt :: ArgOrder a -- non-option handling
+ -> [OptDescr a] -- option descriptors
+ -> [String] -- the command-line arguments
+ -> ([a],[String],[String]) -- (options,non-options,error messages)
+getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us)
+ where (os,xs,us,es) = getOpt' ordering optDescr args
+
+{-|
+This is almost the same as 'getOpt', but returns a quadruple
+consisting of the option arguments, a list of non-options, a list of
+unrecognized options, and a list of error messages.
+-}
+getOpt' :: ArgOrder a -- non-option handling
+ -> [OptDescr a] -- option descriptors
+ -> [String] -- the command-line arguments
+ -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages)
+getOpt' _ _ [] = ([],[],[],[])
+getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering
+ where procNextOpt (Opt o) _ = (o:os,xs,us,es)
+ procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es)
+ procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[])
+ procNextOpt (NonOpt x) Permute = (os,x:xs,us,es)
+ procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es)
+ procNextOpt EndOfOpts RequireOrder = ([],rest,[],[])
+ procNextOpt EndOfOpts Permute = ([],rest,[],[])
+ procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[])
+ procNextOpt (OptErr e) _ = (os,xs,us,e:es)
+
+ (opt,rest) = getNext arg args optDescr
+ (os,xs,us,es) = getOpt' ordering optDescr rest
+
+-- take a look at the next cmd line arg and decide what to do with it
+getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
+getNext ('-':'-':[]) rest _ = (EndOfOpts,rest)
+getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr
+getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr
+getNext a rest _ = (NonOpt a,rest)
+
+-- handle long option
+longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String])
+longOpt ls rs optDescr = long ads arg rs
+ where (opt,arg) = break (=='=') ls
+ getWith p = [ o | o@(Option _ xs _ _) <- optDescr
+ , find (p opt) xs /= Nothing]
+ exact = getWith (==)
+ options = if null exact then getWith isPrefixOf else exact
+ ads = [ ad | Option _ _ ad _ <- options ]
+ optStr = ("--"++opt)
+
+ long (_:_:_) _ rest = (errAmbig options optStr,rest)
+ long [NoArg a ] [] rest = (Opt a,rest)
+ long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest)
+ long [ReqArg _ d] [] [] = (errReq d optStr,[])
+ long [ReqArg f _] [] (r:rest) = (Opt (f r),rest)
+ long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest)
+ long [OptArg f _] [] rest = (Opt (f Nothing),rest)
+ long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest)
+ long _ _ rest = (UnreqOpt ("--"++ls),rest)
+
+-- handle short option
+shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String])
+shortOpt y ys rs optDescr = short ads ys rs
+ where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ]
+ ads = [ ad | Option _ _ ad _ <- options ]
+ optStr = '-':[y]
+
+ short (_:_:_) _ rest = (errAmbig options optStr,rest)
+ short (NoArg a :_) [] rest = (Opt a,rest)
+ short (NoArg a :_) xs rest = (Opt a,('-':xs):rest)
+ short (ReqArg _ d:_) [] [] = (errReq d optStr,[])
+ short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest)
+ short (ReqArg f _:_) xs rest = (Opt (f xs),rest)
+ short (OptArg f _:_) [] rest = (Opt (f Nothing),rest)
+ short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest)
+ short [] [] rest = (UnreqOpt optStr,rest)
+ short [] xs rest = (UnreqOpt (optStr++xs),rest)
+
+-- miscellaneous error formatting
+
+errAmbig :: [OptDescr a] -> String -> OptKind a
+errAmbig ods optStr = OptErr (usageInfo header ods)
+ where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:"
+
+errReq :: String -> String -> OptKind a
+errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n")
+
+errUnrec :: String -> String
+errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n"
+
+errNoArg :: String -> OptKind a
+errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n")
+
+{-
+-----------------------------------------------------------------------------------------
+-- and here a small and hopefully enlightening example:
+
+data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show
+
+options :: [OptDescr Flag]
+options =
+ [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files",
+ Option ['V','?'] ["version","release"] (NoArg Version) "show version info",
+ Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump",
+ Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"]
+
+out :: Maybe String -> Flag
+out Nothing = Output "stdout"
+out (Just o) = Output o
+
+test :: ArgOrder Flag -> [String] -> String
+test order cmdline = case getOpt order options cmdline of
+ (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n"
+ (_,_,errs) -> concat errs ++ usageInfo header options
+ where header = "Usage: foobar [OPTION...] files..."
+
+-- example runs:
+-- putStr (test RequireOrder ["foo","-v"])
+-- ==> options=[] args=["foo", "-v"]
+-- putStr (test Permute ["foo","-v"])
+-- ==> options=[Verbose] args=["foo"]
+-- putStr (test (ReturnInOrder Arg) ["foo","-v"])
+-- ==> options=[Arg "foo", Verbose] args=[]
+-- putStr (test Permute ["foo","--","-v"])
+-- ==> options=[] args=["foo", "-v"]
+-- putStr (test Permute ["-?o","--name","bar","--na=baz"])
+-- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[]
+-- putStr (test Permute ["--ver","foo"])
+-- ==> option `--ver' is ambiguous; could be one of:
+-- -v --verbose verbosely list files
+-- -V, -? --version, --release show version info
+-- Usage: foobar [OPTION...] files...
+-- -v --verbose verbosely list files
+-- -V, -? --version, --release show version info
+-- -o[FILE] --output[=FILE] use FILE for dump
+-- -n USER --name=USER only dump USER's files
+-----------------------------------------------------------------------------------------
+-}
+
+{- $example
+
+To hopefully illuminate the role of the different data
+structures, here\'s the command-line options for a (very simple)
+compiler:
+
+> module Opts where
+>
+> import Distribution.GetOpt
+> import Data.Maybe ( fromMaybe )
+>
+> data Flag
+> = Verbose | Version
+> | Input String | Output String | LibDir String
+> deriving Show
+>
+> options :: [OptDescr Flag]
+> options =
+> [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr"
+> , Option ['V','?'] ["version"] (NoArg Version) "show version number"
+> , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE"
+> , Option ['c'] [] (OptArg inp "FILE") "input FILE"
+> , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory"
+> ]
+>
+> inp,outp :: Maybe String -> Flag
+> outp = Output . fromMaybe "stdout"
+> inp = Input . fromMaybe "stdin"
+>
+> compilerOpts :: [String] -> IO ([Flag], [String])
+> compilerOpts argv =
+> case getOpt Permute options argv of
+> (o,n,[] ) -> return (o,n)
+> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
+> where header = "Usage: ic [OPTION...] files..."
+
+-}
diff --git a/cabal/Cabal/Distribution/InstalledPackageInfo.hs b/cabal/Cabal/Distribution/InstalledPackageInfo.hs
new file mode 100644
index 0000000..db3a3e6
--- /dev/null
+++ b/cabal/Cabal/Distribution/InstalledPackageInfo.hs
@@ -0,0 +1,294 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.InstalledPackageInfo
+-- Copyright : (c) The University of Glasgow 2004
+--
+-- Maintainer : libraries@haskell.org
+-- Portability : portable
+--
+-- This is the information about an /installed/ package that
+-- is communicated to the @ghc-pkg@ program in order to register
+-- a package. @ghc-pkg@ now consumes this package format (as of version
+-- 6.4). This is specific to GHC at the moment.
+--
+-- The @.cabal@ file format is for describing a package that is not yet
+-- installed. It has a lot of flexibility, like conditionals and dependency
+-- ranges. As such, that format is not at all suitable for describing a package
+-- that has already been built and installed. By the time we get to that stage,
+-- we have resolved all conditionals and resolved dependency version
+-- constraints to exact versions of dependent packages. So, this module defines
+-- the 'InstalledPackageInfo' data structure that contains all the info we keep
+-- about an installed package. There is a parser and pretty printer. The
+-- textual format is rather simpler than the @.cabal@ format: there are no
+-- sections, for example.
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of the University nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+-- This module is meant to be local-only to Distribution...
+
+module Distribution.InstalledPackageInfo (
+ InstalledPackageInfo_(..), InstalledPackageInfo,
+ ParseResult(..), PError(..), PWarning,
+ emptyInstalledPackageInfo,
+ parseInstalledPackageInfo,
+ showInstalledPackageInfo,
+ showInstalledPackageInfoField,
+ fieldsInstalledPackageInfo,
+ ) where
+
+import Distribution.ParseUtils
+ ( FieldDescr(..), ParseResult(..), PError(..), PWarning
+ , simpleField, listField, parseLicenseQ
+ , showFields, showSingleNamedField, parseFieldsFlat
+ , parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ
+ , showFilePath, showToken, boolField, parseOptVersion
+ , parseFreeText, showFreeText )
+import Distribution.License ( License(..) )
+import Distribution.Package
+ ( PackageName(..), PackageIdentifier(..), PackageId, InstalledPackageId(..)
+ , packageName, packageVersion )
+import qualified Distribution.Package as Package
+ ( Package(..) )
+import Distribution.ModuleName
+ ( ModuleName )
+import Distribution.Version
+ ( Version(..) )
+import Distribution.Text
+ ( Text(disp, parse) )
+
+-- -----------------------------------------------------------------------------
+-- The InstalledPackageInfo type
+
+data InstalledPackageInfo_ m
+ = InstalledPackageInfo {
+ -- these parts are exactly the same as PackageDescription
+ installedPackageId :: InstalledPackageId,
+ sourcePackageId :: PackageId,
+ license :: License,
+ copyright :: String,
+ maintainer :: String,
+ author :: String,
+ stability :: String,
+ homepage :: String,
+ pkgUrl :: String,
+ synopsis :: String,
+ description :: String,
+ category :: String,
+ -- these parts are required by an installed package only:
+ exposed :: Bool,
+ exposedModules :: [m],
+ hiddenModules :: [m],
+ trusted :: Bool,
+ importDirs :: [FilePath], -- contain sources in case of Hugs
+ libraryDirs :: [FilePath],
+ hsLibraries :: [String],
+ extraLibraries :: [String],
+ extraGHCiLibraries:: [String], -- overrides extraLibraries for GHCi
+ includeDirs :: [FilePath],
+ includes :: [String],
+ depends :: [InstalledPackageId],
+ hugsOptions :: [String],
+ ccOptions :: [String],
+ ldOptions :: [String],
+ frameworkDirs :: [FilePath],
+ frameworks :: [String],
+ haddockInterfaces :: [FilePath],
+ haddockHTMLs :: [FilePath]
+ }
+ deriving (Read, Show)
+
+instance Package.Package (InstalledPackageInfo_ str) where
+ packageId = sourcePackageId
+
+type InstalledPackageInfo = InstalledPackageInfo_ ModuleName
+
+emptyInstalledPackageInfo :: InstalledPackageInfo_ m
+emptyInstalledPackageInfo
+ = InstalledPackageInfo {
+ installedPackageId = InstalledPackageId "",
+ sourcePackageId = PackageIdentifier (PackageName "") noVersion,
+ license = AllRightsReserved,
+ copyright = "",
+ maintainer = "",
+ author = "",
+ stability = "",
+ homepage = "",
+ pkgUrl = "",
+ synopsis = "",
+ description = "",
+ category = "",
+ exposed = False,
+ exposedModules = [],
+ hiddenModules = [],
+ trusted = False,
+ importDirs = [],
+ libraryDirs = [],
+ hsLibraries = [],
+ extraLibraries = [],
+ extraGHCiLibraries= [],
+ includeDirs = [],
+ includes = [],
+ depends = [],
+ hugsOptions = [],
+ ccOptions = [],
+ ldOptions = [],
+ frameworkDirs = [],
+ frameworks = [],
+ haddockInterfaces = [],
+ haddockHTMLs = []
+ }
+
+noVersion :: Version
+noVersion = Version{ versionBranch=[], versionTags=[] }
+
+-- -----------------------------------------------------------------------------
+-- Parsing
+
+parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo
+parseInstalledPackageInfo =
+ parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo
+
+-- -----------------------------------------------------------------------------
+-- Pretty-printing
+
+showInstalledPackageInfo :: InstalledPackageInfo -> String
+showInstalledPackageInfo = showFields fieldsInstalledPackageInfo
+
+showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)
+showInstalledPackageInfoField = showSingleNamedField fieldsInstalledPackageInfo
+
+-- -----------------------------------------------------------------------------
+-- Description of the fields, for parsing/printing
+
+fieldsInstalledPackageInfo :: [FieldDescr InstalledPackageInfo]
+fieldsInstalledPackageInfo = basicFieldDescrs ++ installedFieldDescrs
+
+basicFieldDescrs :: [FieldDescr InstalledPackageInfo]
+basicFieldDescrs =
+ [ simpleField "name"
+ disp parsePackageNameQ
+ packageName (\name pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgName=name}})
+ , simpleField "version"
+ disp parseOptVersion
+ packageVersion (\ver pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgVersion=ver}})
+ , simpleField "id"
+ disp parse
+ installedPackageId (\ipid pkg -> pkg{installedPackageId=ipid})
+ , simpleField "license"
+ disp parseLicenseQ
+ license (\l pkg -> pkg{license=l})
+ , simpleField "copyright"
+ showFreeText parseFreeText
+ copyright (\val pkg -> pkg{copyright=val})
+ , simpleField "maintainer"
+ showFreeText parseFreeText
+ maintainer (\val pkg -> pkg{maintainer=val})
+ , simpleField "stability"
+ showFreeText parseFreeText
+ stability (\val pkg -> pkg{stability=val})
+ , simpleField "homepage"
+ showFreeText parseFreeText
+ homepage (\val pkg -> pkg{homepage=val})
+ , simpleField "package-url"
+ showFreeText parseFreeText
+ pkgUrl (\val pkg -> pkg{pkgUrl=val})
+ , simpleField "synopsis"
+ showFreeText parseFreeText
+ synopsis (\val pkg -> pkg{synopsis=val})
+ , simpleField "description"
+ showFreeText parseFreeText
+ description (\val pkg -> pkg{description=val})
+ , simpleField "category"
+ showFreeText parseFreeText
+ category (\val pkg -> pkg{category=val})
+ , simpleField "author"
+ showFreeText parseFreeText
+ author (\val pkg -> pkg{author=val})
+ ]
+
+installedFieldDescrs :: [FieldDescr InstalledPackageInfo]
+installedFieldDescrs = [
+ boolField "exposed"
+ exposed (\val pkg -> pkg{exposed=val})
+ , listField "exposed-modules"
+ disp parseModuleNameQ
+ exposedModules (\xs pkg -> pkg{exposedModules=xs})
+ , listField "hidden-modules"
+ disp parseModuleNameQ
+ hiddenModules (\xs pkg -> pkg{hiddenModules=xs})
+ , boolField "trusted"
+ trusted (\val pkg -> pkg{trusted=val})
+ , listField "import-dirs"
+ showFilePath parseFilePathQ
+ importDirs (\xs pkg -> pkg{importDirs=xs})
+ , listField "library-dirs"
+ showFilePath parseFilePathQ
+ libraryDirs (\xs pkg -> pkg{libraryDirs=xs})
+ , listField "hs-libraries"
+ showFilePath parseTokenQ
+ hsLibraries (\xs pkg -> pkg{hsLibraries=xs})
+ , listField "extra-libraries"
+ showToken parseTokenQ
+ extraLibraries (\xs pkg -> pkg{extraLibraries=xs})
+ , listField "extra-ghci-libraries"
+ showToken parseTokenQ
+ extraGHCiLibraries (\xs pkg -> pkg{extraGHCiLibraries=xs})
+ , listField "include-dirs"
+ showFilePath parseFilePathQ
+ includeDirs (\xs pkg -> pkg{includeDirs=xs})
+ , listField "includes"
+ showFilePath parseFilePathQ
+ includes (\xs pkg -> pkg{includes=xs})
+ , listField "depends"
+ disp parse
+ depends (\xs pkg -> pkg{depends=xs})
+ , listField "hugs-options"
+ showToken parseTokenQ
+ hugsOptions (\path pkg -> pkg{hugsOptions=path})
+ , listField "cc-options"
+ showToken parseTokenQ
+ ccOptions (\path pkg -> pkg{ccOptions=path})
+ , listField "ld-options"
+ showToken parseTokenQ
+ ldOptions (\path pkg -> pkg{ldOptions=path})
+ , listField "framework-dirs"
+ showFilePath parseFilePathQ
+ frameworkDirs (\xs pkg -> pkg{frameworkDirs=xs})
+ , listField "frameworks"
+ showToken parseTokenQ
+ frameworks (\xs pkg -> pkg{frameworks=xs})
+ , listField "haddock-interfaces"
+ showFilePath parseFilePathQ
+ haddockInterfaces (\xs pkg -> pkg{haddockInterfaces=xs})
+ , listField "haddock-html"
+ showFilePath parseFilePathQ
+ haddockHTMLs (\xs pkg -> pkg{haddockHTMLs=xs})
+ ]
diff --git a/cabal/Cabal/Distribution/License.hs b/cabal/Cabal/Distribution/License.hs
new file mode 100644
index 0000000..19b54c3
--- /dev/null
+++ b/cabal/Cabal/Distribution/License.hs
@@ -0,0 +1,146 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.License
+-- Copyright : Isaac Jones 2003-2005
+-- Duncan Coutts 2008
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- The License datatype. For more information about these and other
+-- open-source licenses, you may visit <http://www.opensource.org/>.
+--
+-- The @.cabal@ file allows you to specify a license file. Of course you can
+-- use any license you like but people often pick common open source licenses
+-- and it's useful if we can automatically recognise that (eg so we can display
+-- it on the hackage web pages). So you can also specify the license itself in
+-- the @.cabal@ file from a short enumeration defined in this module. It
+-- includes 'GPL', 'LGPL' and 'BSD3' licenses.
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.License (
+ License(..),
+ knownLicenses,
+ ) where
+
+import Distribution.Version (Version(Version))
+
+import Distribution.Text (Text(..), display)
+import qualified Distribution.Compat.ReadP as Parse
+import qualified Text.PrettyPrint as Disp
+import Text.PrettyPrint ((<>))
+import qualified Data.Char as Char (isAlphaNum)
+
+-- |This datatype indicates the license under which your package is
+-- released. It is also wise to add your license to each source file
+-- using the license-file field. The 'AllRightsReserved' constructor
+-- is not actually a license, but states that you are not giving
+-- anyone else a license to use or distribute your work. The comments
+-- below are general guidelines. Please read the licenses themselves
+-- and consult a lawyer if you are unsure of your rights to release
+-- the software.
+--
+data License =
+
+--TODO: * remove BSD4
+
+ -- | GNU Public License. Source code must accompany alterations.
+ GPL (Maybe Version)
+
+ -- | Lesser GPL, Less restrictive than GPL, useful for libraries.
+ | LGPL (Maybe Version)
+
+ -- | 3-clause BSD license, newer, no advertising clause. Very free license.
+ | BSD3
+
+ -- | 4-clause BSD license, older, with advertising clause. You almost
+ -- certainly want to use the BSD3 license instead.
+ | BSD4
+
+ -- | The MIT license, similar to the BSD3. Very free license.
+ | MIT
+
+ -- | The Apache License. Version 2.0 is the current version,
+ -- previous versions are considered historical.
+
+ | Apache (Maybe Version)
+
+ -- | Holder makes no claim to ownership, least restrictive license.
+ | PublicDomain
+
+ -- | No rights are granted to others. Undistributable. Most restrictive.
+ | AllRightsReserved
+
+ -- | Some other license.
+ | OtherLicense
+
+ -- | Not a recognised license.
+ -- Allows us to deal with future extensions more gracefully.
+ | UnknownLicense String
+ deriving (Read, Show, Eq)
+
+knownLicenses :: [License]
+knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3])
+ , LGPL unversioned, LGPL (version [2,1]), LGPL (version [3])
+ , BSD3, MIT
+ , Apache unversioned, Apache (version [2, 0])
+ , PublicDomain, AllRightsReserved, OtherLicense]
+ where
+ unversioned = Nothing
+ version v = Just (Version v [])
+
+instance Text License where
+ disp (GPL version) = Disp.text "GPL" <> dispOptVersion version
+ disp (LGPL version) = Disp.text "LGPL" <> dispOptVersion version
+ disp (Apache version) = Disp.text "Apache" <> dispOptVersion version
+ disp (UnknownLicense other) = Disp.text other
+ disp other = Disp.text (show other)
+
+ parse = do
+ name <- Parse.munch1 (\c -> Char.isAlphaNum c && c /= '-')
+ version <- Parse.option Nothing (Parse.char '-' >> fmap Just parse)
+ return $! case (name, version :: Maybe Version) of
+ ("GPL", _ ) -> GPL version
+ ("LGPL", _ ) -> LGPL version
+ ("BSD3", Nothing) -> BSD3
+ ("BSD4", Nothing) -> BSD4
+ ("MIT", Nothing) -> MIT
+ ("Apache", _ ) -> Apache version
+ ("PublicDomain", Nothing) -> PublicDomain
+ ("AllRightsReserved", Nothing) -> AllRightsReserved
+ ("OtherLicense", Nothing) -> OtherLicense
+ _ -> UnknownLicense $ name
+ ++ maybe "" (('-':) . display) version
+
+dispOptVersion :: Maybe Version -> Disp.Doc
+dispOptVersion Nothing = Disp.empty
+dispOptVersion (Just v) = Disp.char '-' <> disp v
diff --git a/cabal/Cabal/Distribution/Make.hs b/cabal/Cabal/Distribution/Make.hs
new file mode 100644
index 0000000..d085ce3
--- /dev/null
+++ b/cabal/Cabal/Distribution/Make.hs
@@ -0,0 +1,213 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Make
+-- Copyright : Martin Sj&#xF6;gren 2004
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This is an alternative build system that delegates everything to the @make@
+-- program. All the commands just end up calling @make@ with appropriate
+-- arguments. The intention was to allow preexisting packages that used
+-- makefiles to be wrapped into Cabal packages. In practice essentially all
+-- such packages were converted over to the \"Simple\" build system instead.
+-- Consequently this module is not used much and it certainly only sees cursory
+-- maintenance and no testing. Perhaps at some point we should stop pretending
+-- that it works.
+--
+-- Uses the parsed command-line from "Distribution.Simple.Setup" in order to build
+-- Haskell tools using a backend build system based on make. Obviously we
+-- assume that there is a configure script, and that after the ConfigCmd has
+-- been run, there is a Makefile. Further assumptions:
+--
+-- [ConfigCmd] We assume the configure script accepts
+-- @--with-hc@,
+-- @--with-hc-pkg@,
+-- @--prefix@,
+-- @--bindir@,
+-- @--libdir@,
+-- @--libexecdir@,
+-- @--datadir@.
+--
+-- [BuildCmd] We assume that the default Makefile target will build everything.
+--
+-- [InstallCmd] We assume there is an @install@ target. Note that we assume that
+-- this does *not* register the package!
+--
+-- [CopyCmd] We assume there is a @copy@ target, and a variable @$(destdir)@.
+-- The @copy@ target should probably just invoke @make install@
+-- recursively (e.g. @$(MAKE) install prefix=$(destdir)\/$(prefix)
+-- bindir=$(destdir)\/$(bindir)@. The reason we can\'t invoke @make
+-- install@ directly here is that we don\'t know the value of @$(prefix)@.
+--
+-- [SDistCmd] We assume there is a @dist@ target.
+--
+-- [RegisterCmd] We assume there is a @register@ target and a variable @$(user)@.
+--
+-- [UnregisterCmd] We assume there is an @unregister@ target.
+--
+-- [HaddockCmd] We assume there is a @docs@ or @doc@ target.
+
+
+-- copy :
+-- $(MAKE) install prefix=$(destdir)/$(prefix) \
+-- bindir=$(destdir)/$(bindir) \
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.Make (
+ module Distribution.Package,
+ License(..), Version(..),
+ defaultMain, defaultMainArgs, defaultMainNoRead
+ ) where
+
+-- local
+import Distribution.Compat.Exception
+import Distribution.Package --must not specify imports, since we're exporting moule.
+import Distribution.Simple.Program(defaultProgramConfiguration)
+import Distribution.PackageDescription
+import Distribution.Simple.Setup
+import Distribution.Simple.Command
+
+import Distribution.Simple.Utils (rawSystemExit, cabalVersion)
+
+import Distribution.License (License(..))
+import Distribution.Version
+ ( Version(..) )
+import Distribution.Text
+ ( display )
+
+import System.Environment (getArgs, getProgName)
+import Data.List (intersperse)
+import System.Exit
+
+defaultMain :: IO ()
+defaultMain = getArgs >>= defaultMainArgs
+
+defaultMainArgs :: [String] -> IO ()
+defaultMainArgs = defaultMainHelper
+
+{-# DEPRECATED defaultMainNoRead "it ignores its PackageDescription arg" #-}
+defaultMainNoRead :: PackageDescription -> IO ()
+defaultMainNoRead = const defaultMain
+
+defaultMainHelper :: [String] -> IO ()
+defaultMainHelper args =
+ case commandsRun globalCommand commands args of
+ CommandHelp help -> printHelp help
+ CommandList opts -> printOptionsList opts
+ CommandErrors errs -> printErrors errs
+ CommandReadyToGo (flags, commandParse) ->
+ case commandParse of
+ _ | fromFlag (globalVersion flags) -> printVersion
+ | fromFlag (globalNumericVersion flags) -> printNumericVersion
+ CommandHelp help -> printHelp help
+ CommandList opts -> printOptionsList opts
+ CommandErrors errs -> printErrors errs
+ CommandReadyToGo action -> action
+
+ where
+ printHelp help = getProgName >>= putStr . help
+ printOptionsList = putStr . unlines
+ printErrors errs = do
+ putStr (concat (intersperse "\n" errs))
+ exitWith (ExitFailure 1)
+ printNumericVersion = putStrLn $ display cabalVersion
+ printVersion = putStrLn $ "Cabal library version "
+ ++ display cabalVersion
+
+ progs = defaultProgramConfiguration
+ commands =
+ [configureCommand progs `commandAddAction` configureAction
+ ,buildCommand progs `commandAddAction` buildAction
+ ,installCommand `commandAddAction` installAction
+ ,copyCommand `commandAddAction` copyAction
+ ,haddockCommand `commandAddAction` haddockAction
+ ,cleanCommand `commandAddAction` cleanAction
+ ,sdistCommand `commandAddAction` sdistAction
+ ,registerCommand `commandAddAction` registerAction
+ ,unregisterCommand `commandAddAction` unregisterAction
+ ]
+
+configureAction :: ConfigFlags -> [String] -> IO ()
+configureAction flags args = do
+ noExtraFlags args
+ let verbosity = fromFlag (configVerbosity flags)
+ rawSystemExit verbosity "sh" $
+ "configure"
+ : configureArgs backwardsCompatHack flags
+ where backwardsCompatHack = True
+
+copyAction :: CopyFlags -> [String] -> IO ()
+copyAction flags args = do
+ noExtraFlags args
+ let destArgs = case fromFlag $ copyDest flags of
+ NoCopyDest -> ["install"]
+ CopyTo path -> ["copy", "destdir=" ++ path]
+ rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs
+
+installAction :: InstallFlags -> [String] -> IO ()
+installAction flags args = do
+ noExtraFlags args
+ rawSystemExit (fromFlag $ installVerbosity flags) "make" ["install"]
+ rawSystemExit (fromFlag $ installVerbosity flags) "make" ["register"]
+
+haddockAction :: HaddockFlags -> [String] -> IO ()
+haddockAction flags args = do
+ noExtraFlags args
+ rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"]
+ `catchIO` \_ ->
+ rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"]
+
+buildAction :: BuildFlags -> [String] -> IO ()
+buildAction flags args = do
+ noExtraFlags args
+ rawSystemExit (fromFlag $ buildVerbosity flags) "make" []
+
+cleanAction :: CleanFlags -> [String] -> IO ()
+cleanAction flags args = do
+ noExtraFlags args
+ rawSystemExit (fromFlag $ cleanVerbosity flags) "make" ["clean"]
+
+sdistAction :: SDistFlags -> [String] -> IO ()
+sdistAction flags args = do
+ noExtraFlags args
+ rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"]
+
+registerAction :: RegisterFlags -> [String] -> IO ()
+registerAction flags args = do
+ noExtraFlags args
+ rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"]
+
+unregisterAction :: RegisterFlags -> [String] -> IO ()
+unregisterAction flags args = do
+ noExtraFlags args
+ rawSystemExit (fromFlag $ regVerbosity flags) "make" ["unregister"]
diff --git a/cabal/Cabal/Distribution/ModuleName.hs b/cabal/Cabal/Distribution/ModuleName.hs
new file mode 100644
index 0000000..5fe0cc1
--- /dev/null
+++ b/cabal/Cabal/Distribution/ModuleName.hs
@@ -0,0 +1,130 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.ModuleName
+-- Copyright : Duncan Coutts 2008
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- Data type for Haskell module names.
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.ModuleName (
+ ModuleName,
+ fromString,
+ components,
+ toFilePath,
+ main,
+ simple,
+ ) where
+
+import Distribution.Text
+ ( Text(..) )
+
+import qualified Distribution.Compat.ReadP as Parse
+import qualified Text.PrettyPrint as Disp
+import qualified Data.Char as Char
+ ( isAlphaNum, isUpper )
+import System.FilePath
+ ( pathSeparator )
+import Data.List
+ ( intersperse )
+
+-- | A valid Haskell module name.
+--
+newtype ModuleName = ModuleName [String]
+ deriving (Eq, Ord, Read, Show)
+
+instance Text ModuleName where
+ disp (ModuleName ms) =
+ Disp.hcat (intersperse (Disp.char '.') (map Disp.text ms))
+
+ parse = do
+ ms <- Parse.sepBy1 component (Parse.char '.')
+ return (ModuleName ms)
+
+ where
+ component = do
+ c <- Parse.satisfy Char.isUpper
+ cs <- Parse.munch validModuleChar
+ return (c:cs)
+
+validModuleChar :: Char -> Bool
+validModuleChar c = Char.isAlphaNum c || c == '_' || c == '\''
+
+validModuleComponent :: String -> Bool
+validModuleComponent [] = False
+validModuleComponent (c:cs) = Char.isUpper c
+ && all validModuleChar cs
+
+{-# DEPRECATED simple "use ModuleName.fromString instead" #-}
+simple :: String -> ModuleName
+simple str = ModuleName [str]
+
+-- | Construct a 'ModuleName' from a valid module name 'String'.
+--
+-- This is just a convenience function intended for valid module strings. It is
+-- an error if it is used with a string that is not a valid module name. If you
+-- are parsing user input then use 'Distribution.Text.simpleParse' instead.
+--
+fromString :: String -> ModuleName
+fromString string
+ | all validModuleComponent components' = ModuleName components'
+ | otherwise = error badName
+
+ where
+ components' = split string
+ badName = "ModuleName.fromString: invalid module name " ++ show string
+
+ split cs = case break (=='.') cs of
+ (chunk,[]) -> chunk : []
+ (chunk,_:rest) -> chunk : split rest
+
+-- | The module name @Main@.
+--
+main :: ModuleName
+main = ModuleName ["Main"]
+
+-- | The individual components of a hierarchical module name. For example
+--
+-- > components (fromString "A.B.C") = ["A", "B", "C"]
+--
+components :: ModuleName -> [String]
+components (ModuleName ms) = ms
+
+-- | Convert a module name to a file path, but without any file extension.
+-- For example:
+--
+-- > toFilePath (fromString "A.B.C") = "A/B/C"
+--
+toFilePath :: ModuleName -> FilePath
+toFilePath = concat . intersperse [pathSeparator] . components
diff --git a/cabal/Cabal/Distribution/Package.hs b/cabal/Cabal/Distribution/Package.hs
new file mode 100644
index 0000000..0017b8c
--- /dev/null
+++ b/cabal/Cabal/Distribution/Package.hs
@@ -0,0 +1,202 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Package
+-- Copyright : Isaac Jones 2003-2004
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- Defines a package identifier along with a parser and pretty printer for it.
+-- 'PackageIdentifier's consist of a name and an exact version. It also defines
+-- a 'Dependency' data type. A dependency is a package name and a version
+-- range, like @\"foo >= 1.2 && < 2\"@.
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.Package (
+ -- * Package ids
+ PackageName(..),
+ PackageIdentifier(..),
+ PackageId,
+
+ -- * Installed package identifiers
+ InstalledPackageId(..),
+
+ -- * Package source dependencies
+ Dependency(..),
+ thisPackageVersion,
+ notThisPackageVersion,
+ simplifyDependency,
+
+ -- * Package classes
+ Package(..), packageName, packageVersion,
+ PackageFixedDeps(..),
+ ) where
+
+import Distribution.Version
+ ( Version(..), VersionRange, anyVersion, thisVersion
+ , notThisVersion, simplifyVersionRange )
+
+import Distribution.Text (Text(..))
+import qualified Distribution.Compat.ReadP as Parse
+import Distribution.Compat.ReadP ((<++))
+import qualified Text.PrettyPrint as Disp
+import Text.PrettyPrint ((<>), (<+>), text)
+import Control.DeepSeq (NFData(..))
+import qualified Data.Char as Char ( isDigit, isAlphaNum )
+import Data.List ( intersperse )
+import Data.Typeable ( Typeable )
+
+newtype PackageName = PackageName String
+ deriving (Read, Show, Eq, Ord, Typeable)
+
+instance Text PackageName where
+ disp (PackageName n) = Disp.text n
+ parse = do
+ ns <- Parse.sepBy1 component (Parse.char '-')
+ return (PackageName (concat (intersperse "-" ns)))
+ where
+ component = do
+ cs <- Parse.munch1 Char.isAlphaNum
+ if all Char.isDigit cs then Parse.pfail else return cs
+ -- each component must contain an alphabetic character, to avoid
+ -- ambiguity in identifiers like foo-1 (the 1 is the version number).
+
+instance NFData PackageName where
+ rnf (PackageName pkg) = rnf pkg
+
+-- | Type alias so we can use the shorter name PackageId.
+type PackageId = PackageIdentifier
+
+-- | The name and version of a package.
+data PackageIdentifier
+ = PackageIdentifier {
+ pkgName :: PackageName, -- ^The name of this package, eg. foo
+ pkgVersion :: Version -- ^the version of this package, eg 1.2
+ }
+ deriving (Read, Show, Eq, Ord, Typeable)
+
+instance Text PackageIdentifier where
+ disp (PackageIdentifier n v) = case v of
+ Version [] _ -> disp n -- if no version, don't show version.
+ _ -> disp n <> Disp.char '-' <> disp v
+
+ parse = do
+ n <- parse
+ v <- (Parse.char '-' >> parse) <++ return (Version [] [])
+ return (PackageIdentifier n v)
+
+instance NFData PackageIdentifier where
+ rnf (PackageIdentifier name version) = rnf name `seq` rnf version
+
+-- ------------------------------------------------------------
+-- * Installed Package Ids
+-- ------------------------------------------------------------
+
+-- | An InstalledPackageId uniquely identifies an instance of an installed package.
+-- There can be at most one package with a given 'InstalledPackageId'
+-- in a package database, or overlay of databases.
+--
+newtype InstalledPackageId = InstalledPackageId String
+ deriving (Read,Show,Eq,Ord)
+
+instance Text InstalledPackageId where
+ disp (InstalledPackageId str) = text str
+
+ parse = InstalledPackageId `fmap` Parse.munch1 abi_char
+ where abi_char c = Char.isAlphaNum c || c `elem` ":-_."
+
+-- ------------------------------------------------------------
+-- * Package source dependencies
+-- ------------------------------------------------------------
+
+-- | Describes a dependency on a source package (API)
+--
+data Dependency = Dependency PackageName VersionRange
+ deriving (Read, Show, Eq)
+
+instance Text Dependency where
+ disp (Dependency name ver) =
+ disp name <+> disp ver
+
+ parse = do name <- parse
+ Parse.skipSpaces
+ ver <- parse <++ return anyVersion
+ Parse.skipSpaces
+ return (Dependency name ver)
+
+thisPackageVersion :: PackageIdentifier -> Dependency
+thisPackageVersion (PackageIdentifier n v) =
+ Dependency n (thisVersion v)
+
+notThisPackageVersion :: PackageIdentifier -> Dependency
+notThisPackageVersion (PackageIdentifier n v) =
+ Dependency n (notThisVersion v)
+
+-- | Simplify the 'VersionRange' expression in a 'Dependency'.
+-- See 'simplifyVersionRange'.
+--
+simplifyDependency :: Dependency -> Dependency
+simplifyDependency (Dependency name range) =
+ Dependency name (simplifyVersionRange range)
+
+-- | Class of things that have a 'PackageIdentifier'
+--
+-- Types in this class are all notions of a package. This allows us to have
+-- different types for the different phases that packages go though, from
+-- simple name\/id, package description, configured or installed packages.
+--
+-- Not all kinds of packages can be uniquely identified by a
+-- 'PackageIdentifier'. In particular, installed packages cannot, there may be
+-- many installed instances of the same source package.
+--
+class Package pkg where
+ packageId :: pkg -> PackageIdentifier
+
+packageName :: Package pkg => pkg -> PackageName
+packageName = pkgName . packageId
+
+packageVersion :: Package pkg => pkg -> Version
+packageVersion = pkgVersion . packageId
+
+instance Package PackageIdentifier where
+ packageId = id
+
+-- | Subclass of packages that have specific versioned dependencies.
+--
+-- So for example a not-yet-configured package has dependencies on version
+-- ranges, not specific versions. A configured or an already installed package
+-- depends on exact versions. Some operations or data structures (like
+-- dependency graphs) only make sense on this subclass of package types.
+--
+class Package pkg => PackageFixedDeps pkg where
+ depends :: pkg -> [PackageIdentifier]
diff --git a/cabal/Cabal/Distribution/PackageDescription.hs b/cabal/Cabal/Distribution/PackageDescription.hs
new file mode 100644
index 0000000..034479b
--- /dev/null
+++ b/cabal/Cabal/Distribution/PackageDescription.hs
@@ -0,0 +1,1034 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.PackageDescription
+-- Copyright : Isaac Jones 2003-2005
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This defines the data structure for the @.cabal@ file format. There are
+-- several parts to this structure. It has top level info and then 'Library',
+-- 'Executable', 'TestSuite', and 'Benchmark' sections each of which have
+-- associated 'BuildInfo' data that's used to build the library, exe, test, or
+-- benchmark. To further complicate things there is both a 'PackageDescription'
+-- and a 'GenericPackageDescription'. This distinction relates to cabal
+-- configurations. When we initially read a @.cabal@ file we get a
+-- 'GenericPackageDescription' which has all the conditional sections.
+-- Before actually building a package we have to decide
+-- on each conditional. Once we've done that we get a 'PackageDescription'.
+-- It was done this way initially to avoid breaking too much stuff when the
+-- feature was introduced. It could probably do with being rationalised at some
+-- point to make it simpler.
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.PackageDescription (
+ -- * Package descriptions
+ PackageDescription(..),
+ emptyPackageDescription,
+ specVersion,
+ descCabalVersion,
+ BuildType(..),
+ knownBuildTypes,
+
+ -- ** Libraries
+ Library(..),
+ emptyLibrary,
+ withLib,
+ hasLibs,
+ libModules,
+
+ -- ** Executables
+ Executable(..),
+ emptyExecutable,
+ withExe,
+ hasExes,
+ exeModules,
+
+ -- * Tests
+ TestSuite(..),
+ TestSuiteInterface(..),
+ TestType(..),
+ testType,
+ knownTestTypes,
+ emptyTestSuite,
+ hasTests,
+ withTest,
+ testModules,
+ enabledTests,
+
+ -- * Benchmarks
+ Benchmark(..),
+ BenchmarkInterface(..),
+ BenchmarkType(..),
+ benchmarkType,
+ knownBenchmarkTypes,
+ emptyBenchmark,
+ hasBenchmarks,
+ withBenchmark,
+ benchmarkModules,
+ enabledBenchmarks,
+
+ -- * Build information
+ BuildInfo(..),
+ emptyBuildInfo,
+ allBuildInfo,
+ allLanguages,
+ allExtensions,
+ usedExtensions,
+ hcOptions,
+
+ -- ** Supplementary build information
+ HookedBuildInfo,
+ emptyHookedBuildInfo,
+ updatePackageDescription,
+
+ -- * package configuration
+ GenericPackageDescription(..),
+ Flag(..), FlagName(..), FlagAssignment,
+ CondTree(..), ConfVar(..), Condition(..),
+
+ -- * Source repositories
+ SourceRepo(..),
+ RepoKind(..),
+ RepoType(..),
+ knownRepoTypes,
+ ) where
+
+import Data.List (nub, intersperse)
+import Data.Maybe (maybeToList)
+import Data.Monoid (Monoid(mempty, mappend))
+import Data.Typeable ( Typeable )
+import Control.Monad (MonadPlus(mplus))
+import Text.PrettyPrint as Disp
+import qualified Distribution.Compat.ReadP as Parse
+import qualified Data.Char as Char (isAlphaNum, isDigit, toLower)
+
+import Distribution.Package
+ ( PackageName(PackageName), PackageIdentifier(PackageIdentifier)
+ , Dependency, Package(..) )
+import Distribution.ModuleName ( ModuleName )
+import Distribution.Version
+ ( Version(Version), VersionRange, anyVersion, orLaterVersion
+ , asVersionIntervals, LowerBound(..) )
+import Distribution.License (License(AllRightsReserved))
+import Distribution.Compiler (CompilerFlavor)
+import Distribution.System (OS, Arch)
+import Distribution.Text
+ ( Text(..), display )
+import Language.Haskell.Extension
+ ( Language, Extension )
+
+-- -----------------------------------------------------------------------------
+-- The PackageDescription type
+
+-- | This data type is the internal representation of the file @pkg.cabal@.
+-- It contains two kinds of information about the package: information
+-- which is needed for all packages, such as the package name and version, and
+-- information which is needed for the simple build system only, such as
+-- the compiler options and library name.
+--
+data PackageDescription
+ = PackageDescription {
+ -- the following are required by all packages:
+ package :: PackageIdentifier,
+ license :: License,
+ licenseFile :: FilePath,
+ copyright :: String,
+ maintainer :: String,
+ author :: String,
+ stability :: String,
+ testedWith :: [(CompilerFlavor,VersionRange)],
+ homepage :: String,
+ pkgUrl :: String,
+ bugReports :: String,
+ sourceRepos :: [SourceRepo],
+ synopsis :: String, -- ^A one-line summary of this package
+ description :: String, -- ^A more verbose description of this package
+ category :: String,
+ customFieldsPD :: [(String,String)], -- ^Custom fields starting
+ -- with x-, stored in a
+ -- simple assoc-list.
+ buildDepends :: [Dependency],
+ -- | The version of the Cabal spec that this package description uses.
+ -- For historical reasons this is specified with a version range but
+ -- only ranges of the form @>= v@ make sense. We are in the process of
+ -- transitioning to specifying just a single version, not a range.
+ specVersionRaw :: Either Version VersionRange,
+ buildType :: Maybe BuildType,
+ -- components
+ library :: Maybe Library,
+ executables :: [Executable],
+ testSuites :: [TestSuite],
+ benchmarks :: [Benchmark],
+ dataFiles :: [FilePath],
+ dataDir :: FilePath,
+ extraSrcFiles :: [FilePath],
+ extraTmpFiles :: [FilePath]
+ }
+ deriving (Show, Read, Eq)
+
+instance Package PackageDescription where
+ packageId = package
+
+-- | The version of the Cabal spec that this package should be interpreted
+-- against.
+--
+-- Historically we used a version range but we are switching to using a single
+-- version. Currently we accept either. This function converts into a single
+-- version by ignoring upper bounds in the version range.
+--
+specVersion :: PackageDescription -> Version
+specVersion pkg = case specVersionRaw pkg of
+ Left version -> version
+ Right versionRange -> case asVersionIntervals versionRange of
+ [] -> Version [0] []
+ ((LowerBound version _, _):_) -> version
+
+-- | The range of versions of the Cabal tools that this package is intended to
+-- work with.
+--
+-- This function is deprecated and should not be used for new purposes, only to
+-- support old packages that rely on the old interpretation.
+--
+descCabalVersion :: PackageDescription -> VersionRange
+descCabalVersion pkg = case specVersionRaw pkg of
+ Left version -> orLaterVersion version
+ Right versionRange -> versionRange
+{-# DEPRECATED descCabalVersion "Use specVersion instead" #-}
+
+emptyPackageDescription :: PackageDescription
+emptyPackageDescription
+ = PackageDescription {
+ package = PackageIdentifier (PackageName "")
+ (Version [] []),
+ license = AllRightsReserved,
+ licenseFile = "",
+ specVersionRaw = Right anyVersion,
+ buildType = Nothing,
+ copyright = "",
+ maintainer = "",
+ author = "",
+ stability = "",
+ testedWith = [],
+ buildDepends = [],
+ homepage = "",
+ pkgUrl = "",
+ bugReports = "",
+ sourceRepos = [],
+ synopsis = "",
+ description = "",
+ category = "",
+ customFieldsPD = [],
+ library = Nothing,
+ executables = [],
+ testSuites = [],
+ benchmarks = [],
+ dataFiles = [],
+ dataDir = "",
+ extraSrcFiles = [],
+ extraTmpFiles = []
+ }
+
+-- | The type of build system used by this package.
+data BuildType
+ = Simple -- ^ calls @Distribution.Simple.defaultMain@
+ | Configure -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@,
+ -- which invokes @configure@ to generate additional build
+ -- information used by later phases.
+ | Make -- ^ calls @Distribution.Make.defaultMain@
+ | Custom -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default)
+ | UnknownBuildType String
+ -- ^ a package that uses an unknown build type cannot actually
+ -- be built. Doing it this way rather than just giving a
+ -- parse error means we get better error messages and allows
+ -- you to inspect the rest of the package description.
+ deriving (Show, Read, Eq)
+
+knownBuildTypes :: [BuildType]
+knownBuildTypes = [Simple, Configure, Make, Custom]
+
+instance Text BuildType where
+ disp (UnknownBuildType other) = Disp.text other
+ disp other = Disp.text (show other)
+
+ parse = do
+ name <- Parse.munch1 Char.isAlphaNum
+ return $ case name of
+ "Simple" -> Simple
+ "Configure" -> Configure
+ "Custom" -> Custom
+ "Make" -> Make
+ _ -> UnknownBuildType name
+
+-- ---------------------------------------------------------------------------
+-- The Library type
+
+data Library = Library {
+ exposedModules :: [ModuleName],
+ libExposed :: Bool, -- ^ Is the lib to be exposed by default?
+ libBuildInfo :: BuildInfo
+ }
+ deriving (Show, Eq, Read)
+
+instance Monoid Library where
+ mempty = Library {
+ exposedModules = mempty,
+ libExposed = True,
+ libBuildInfo = mempty
+ }
+ mappend a b = Library {
+ exposedModules = combine exposedModules,
+ libExposed = libExposed a && libExposed b, -- so False propagates
+ libBuildInfo = combine libBuildInfo
+ }
+ where combine field = field a `mappend` field b
+
+emptyLibrary :: Library
+emptyLibrary = mempty
+
+-- |does this package have any libraries?
+hasLibs :: PackageDescription -> Bool
+hasLibs p = maybe False (buildable . libBuildInfo) (library p)
+
+-- |'Maybe' version of 'hasLibs'
+maybeHasLibs :: PackageDescription -> Maybe Library
+maybeHasLibs p =
+ library p >>= \lib -> if buildable (libBuildInfo lib)
+ then Just lib
+ else Nothing
+
+-- |If the package description has a library section, call the given
+-- function with the library build info as argument.
+withLib :: PackageDescription -> (Library -> IO ()) -> IO ()
+withLib pkg_descr f =
+ maybe (return ()) f (maybeHasLibs pkg_descr)
+
+-- | Get all the module names from the library (exposed and internal modules)
+libModules :: Library -> [ModuleName]
+libModules lib = exposedModules lib
+ ++ otherModules (libBuildInfo lib)
+
+-- ---------------------------------------------------------------------------
+-- The Executable type
+
+data Executable = Executable {
+ exeName :: String,
+ modulePath :: FilePath,
+ buildInfo :: BuildInfo
+ }
+ deriving (Show, Read, Eq)
+
+instance Monoid Executable where
+ mempty = Executable {
+ exeName = mempty,
+ modulePath = mempty,
+ buildInfo = mempty
+ }
+ mappend a b = Executable{
+ exeName = combine' exeName,
+ modulePath = combine modulePath,
+ buildInfo = combine buildInfo
+ }
+ where combine field = field a `mappend` field b
+ combine' field = case (field a, field b) of
+ ("","") -> ""
+ ("", x) -> x
+ (x, "") -> x
+ (x, y) -> error $ "Ambiguous values for executable field: '"
+ ++ x ++ "' and '" ++ y ++ "'"
+
+emptyExecutable :: Executable
+emptyExecutable = mempty
+
+-- |does this package have any executables?
+hasExes :: PackageDescription -> Bool
+hasExes p = any (buildable . buildInfo) (executables p)
+
+-- | Perform the action on each buildable 'Executable' in the package
+-- description.
+withExe :: PackageDescription -> (Executable -> IO ()) -> IO ()
+withExe pkg_descr f =
+ sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)]
+
+-- | Get all the module names from an exe
+exeModules :: Executable -> [ModuleName]
+exeModules exe = otherModules (buildInfo exe)
+
+-- ---------------------------------------------------------------------------
+-- The TestSuite type
+
+-- | A \"test-suite\" stanza in a cabal file.
+--
+data TestSuite = TestSuite {
+ testName :: String,
+ testInterface :: TestSuiteInterface,
+ testBuildInfo :: BuildInfo,
+ testEnabled :: Bool
+ -- TODO: By having a 'testEnabled' field in the PackageDescription, we
+ -- are mixing build status information (i.e., arguments to 'configure')
+ -- with static package description information. This is undesirable, but
+ -- a better solution is waiting on the next overhaul to the
+ -- GenericPackageDescription -> PackageDescription resolution process.
+ }
+ deriving (Show, Read, Eq)
+
+-- | The test suite interfaces that are currently defined. Each test suite must
+-- specify which interface it supports.
+--
+-- More interfaces may be defined in future, either new revisions or totally
+-- new interfaces.
+--
+data TestSuiteInterface =
+
+ -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form
+ -- of an executable. It returns a zero exit code for success, non-zero for
+ -- failure. The stdout and stderr channels may be logged. It takes no
+ -- command line parameters and nothing on stdin.
+ --
+ TestSuiteExeV10 Version FilePath
+
+ -- | Test interface \"detailed-0.9\". The test-suite takes the form of a
+ -- library containing a designated module that exports \"tests :: [Test]\".
+ --
+ | TestSuiteLibV09 Version ModuleName
+
+ -- | A test suite that does not conform to one of the above interfaces for
+ -- the given reason (e.g. unknown test type).
+ --
+ | TestSuiteUnsupported TestType
+ deriving (Eq, Read, Show)
+
+instance Monoid TestSuite where
+ mempty = TestSuite {
+ testName = mempty,
+ testInterface = mempty,
+ testBuildInfo = mempty,
+ testEnabled = False
+ }
+
+ mappend a b = TestSuite {
+ testName = combine' testName,
+ testInterface = combine testInterface,
+ testBuildInfo = combine testBuildInfo,
+ testEnabled = if testEnabled a then True else testEnabled b
+ }
+ where combine field = field a `mappend` field b
+ combine' f = case (f a, f b) of
+ ("", x) -> x
+ (x, "") -> x
+ (x, y) -> error "Ambiguous values for test field: '"
+ ++ x ++ "' and '" ++ y ++ "'"
+
+instance Monoid TestSuiteInterface where
+ mempty = TestSuiteUnsupported (TestTypeUnknown mempty (Version [] []))
+ mappend a (TestSuiteUnsupported _) = a
+ mappend _ b = b
+
+emptyTestSuite :: TestSuite
+emptyTestSuite = mempty
+
+-- | Does this package have any test suites?
+hasTests :: PackageDescription -> Bool
+hasTests = any (buildable . testBuildInfo) . testSuites
+
+-- | Get all the enabled test suites from a package.
+enabledTests :: PackageDescription -> [TestSuite]
+enabledTests = filter testEnabled . testSuites
+
+-- | Perform an action on each buildable 'TestSuite' in a package.
+withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO ()
+withTest pkg_descr f =
+ mapM_ f $ filter (buildable . testBuildInfo) $ enabledTests pkg_descr
+
+-- | Get all the module names from a test suite.
+testModules :: TestSuite -> [ModuleName]
+testModules test = (case testInterface test of
+ TestSuiteLibV09 _ m -> [m]
+ _ -> [])
+ ++ otherModules (testBuildInfo test)
+
+-- | The \"test-type\" field in the test suite stanza.
+--
+data TestType = TestTypeExe Version -- ^ \"type: exitcode-stdio-x.y\"
+ | TestTypeLib Version -- ^ \"type: detailed-x.y\"
+ | TestTypeUnknown String Version -- ^ Some unknown test type e.g. \"type: foo\"
+ deriving (Show, Read, Eq)
+
+knownTestTypes :: [TestType]
+knownTestTypes = [ TestTypeExe (Version [1,0] [])
+ , TestTypeLib (Version [0,9] []) ]
+
+instance Text TestType where
+ disp (TestTypeExe ver) = text "exitcode-stdio-" <> disp ver
+ disp (TestTypeLib ver) = text "detailed-" <> disp ver
+ disp (TestTypeUnknown name ver) = text name <> char '-' <> disp ver
+
+ parse = do
+ cs <- Parse.sepBy1 component (Parse.char '-')
+ _ <- Parse.char '-'
+ ver <- parse
+ let name = concat (intersperse "-" cs)
+ return $! case lowercase name of
+ "exitcode-stdio" -> TestTypeExe ver
+ "detailed" -> TestTypeLib ver
+ _ -> TestTypeUnknown name ver
+
+ where
+ component = do
+ cs <- Parse.munch1 Char.isAlphaNum
+ if all Char.isDigit cs then Parse.pfail else return cs
+ -- each component must contain an alphabetic character, to avoid
+ -- ambiguity in identifiers like foo-1 (the 1 is the version number).
+
+testType :: TestSuite -> TestType
+testType test = case testInterface test of
+ TestSuiteExeV10 ver _ -> TestTypeExe ver
+ TestSuiteLibV09 ver _ -> TestTypeLib ver
+ TestSuiteUnsupported testtype -> testtype
+
+-- ---------------------------------------------------------------------------
+-- The Benchmark type
+
+-- | A \"benchmark\" stanza in a cabal file.
+--
+data Benchmark = Benchmark {
+ benchmarkName :: String,
+ benchmarkInterface :: BenchmarkInterface,
+ benchmarkBuildInfo :: BuildInfo,
+ benchmarkEnabled :: Bool
+ -- TODO: See TODO for 'testEnabled'.
+ }
+ deriving (Show, Read, Eq)
+
+-- | The benchmark interfaces that are currently defined. Each
+-- benchmark must specify which interface it supports.
+--
+-- More interfaces may be defined in future, either new revisions or
+-- totally new interfaces.
+--
+data BenchmarkInterface =
+
+ -- | Benchmark interface \"exitcode-stdio-1.0\". The benchmark
+ -- takes the form of an executable. It returns a zero exit code
+ -- for success, non-zero for failure. The stdout and stderr
+ -- channels may be logged. It takes no command line parameters
+ -- and nothing on stdin.
+ --
+ BenchmarkExeV10 Version FilePath
+
+ -- | A benchmark that does not conform to one of the above
+ -- interfaces for the given reason (e.g. unknown benchmark type).
+ --
+ | BenchmarkUnsupported BenchmarkType
+ deriving (Eq, Read, Show)
+
+instance Monoid Benchmark where
+ mempty = Benchmark {
+ benchmarkName = mempty,
+ benchmarkInterface = mempty,
+ benchmarkBuildInfo = mempty,
+ benchmarkEnabled = False
+ }
+
+ mappend a b = Benchmark {
+ benchmarkName = combine' benchmarkName,
+ benchmarkInterface = combine benchmarkInterface,
+ benchmarkBuildInfo = combine benchmarkBuildInfo,
+ benchmarkEnabled = if benchmarkEnabled a then True
+ else benchmarkEnabled b
+ }
+ where combine field = field a `mappend` field b
+ combine' f = case (f a, f b) of
+ ("", x) -> x
+ (x, "") -> x
+ (x, y) -> error "Ambiguous values for benchmark field: '"
+ ++ x ++ "' and '" ++ y ++ "'"
+
+instance Monoid BenchmarkInterface where
+ mempty = BenchmarkUnsupported (BenchmarkTypeUnknown mempty (Version [] []))
+ mappend a (BenchmarkUnsupported _) = a
+ mappend _ b = b
+
+emptyBenchmark :: Benchmark
+emptyBenchmark = mempty
+
+-- | Does this package have any benchmarks?
+hasBenchmarks :: PackageDescription -> Bool
+hasBenchmarks = any (buildable . benchmarkBuildInfo) . benchmarks
+
+-- | Get all the enabled benchmarks from a package.
+enabledBenchmarks :: PackageDescription -> [Benchmark]
+enabledBenchmarks = filter benchmarkEnabled . benchmarks
+
+-- | Perform an action on each buildable 'Benchmark' in a package.
+withBenchmark :: PackageDescription -> (Benchmark -> IO ()) -> IO ()
+withBenchmark pkg_descr f =
+ mapM_ f $ filter (buildable . benchmarkBuildInfo) $ enabledBenchmarks pkg_descr
+
+-- | Get all the module names from a benchmark.
+benchmarkModules :: Benchmark -> [ModuleName]
+benchmarkModules benchmark = otherModules (benchmarkBuildInfo benchmark)
+
+-- | The \"benchmark-type\" field in the benchmark stanza.
+--
+data BenchmarkType = BenchmarkTypeExe Version
+ -- ^ \"type: exitcode-stdio-x.y\"
+ | BenchmarkTypeUnknown String Version
+ -- ^ Some unknown benchmark type e.g. \"type: foo\"
+ deriving (Show, Read, Eq)
+
+knownBenchmarkTypes :: [BenchmarkType]
+knownBenchmarkTypes = [ BenchmarkTypeExe (Version [1,0] []) ]
+
+instance Text BenchmarkType where
+ disp (BenchmarkTypeExe ver) = text "exitcode-stdio-" <> disp ver
+ disp (BenchmarkTypeUnknown name ver) = text name <> char '-' <> disp ver
+
+ parse = do
+ cs <- Parse.sepBy1 component (Parse.char '-')
+ _ <- Parse.char '-'
+ ver <- parse
+ let name = concat (intersperse "-" cs)
+ return $! case lowercase name of
+ "exitcode-stdio" -> BenchmarkTypeExe ver
+ _ -> BenchmarkTypeUnknown name ver
+
+ where
+ component = do
+ cs <- Parse.munch1 Char.isAlphaNum
+ if all Char.isDigit cs then Parse.pfail else return cs
+ -- each component must contain an alphabetic character, to avoid
+ -- ambiguity in identifiers like foo-1 (the 1 is the version number).
+
+benchmarkType :: Benchmark -> BenchmarkType
+benchmarkType benchmark = case benchmarkInterface benchmark of
+ BenchmarkExeV10 ver _ -> BenchmarkTypeExe ver
+ BenchmarkUnsupported benchmarktype -> benchmarktype
+
+-- ---------------------------------------------------------------------------
+-- The BuildInfo type
+
+-- Consider refactoring into executable and library versions.
+data BuildInfo = BuildInfo {
+ buildable :: Bool, -- ^ component is buildable here
+ buildTools :: [Dependency], -- ^ tools needed to build this bit
+ cppOptions :: [String], -- ^ options for pre-processing Haskell code
+ ccOptions :: [String], -- ^ options for C compiler
+ ldOptions :: [String], -- ^ options for linker
+ pkgconfigDepends :: [Dependency], -- ^ pkg-config packages that are used
+ frameworks :: [String], -- ^support frameworks for Mac OS X
+ cSources :: [FilePath],
+ hsSourceDirs :: [FilePath], -- ^ where to look for the haskell module hierarchy
+ otherModules :: [ModuleName], -- ^ non-exposed or non-main modules
+
+ defaultLanguage :: Maybe Language,-- ^ language used when not explicitly specified
+ otherLanguages :: [Language], -- ^ other languages used within the package
+ defaultExtensions :: [Extension], -- ^ language extensions used by all modules
+ otherExtensions :: [Extension], -- ^ other language extensions used within the package
+ oldExtensions :: [Extension], -- ^ the old extensions field, treated same as 'defaultExtensions'
+
+ extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package
+ extraLibDirs :: [String],
+ includeDirs :: [FilePath], -- ^directories to find .h files
+ includes :: [FilePath], -- ^ The .h files to be found in includeDirs
+ installIncludes :: [FilePath], -- ^ .h files to install with the package
+ options :: [(CompilerFlavor,[String])],
+ ghcProfOptions :: [String],
+ ghcSharedOptions :: [String],
+ customFieldsBI :: [(String,String)], -- ^Custom fields starting
+ -- with x-, stored in a
+ -- simple assoc-list.
+ targetBuildDepends :: [Dependency] -- ^ Dependencies specific to a library or executable target
+ }
+ deriving (Show,Read,Eq)
+
+instance Monoid BuildInfo where
+ mempty = BuildInfo {
+ buildable = True,
+ buildTools = [],
+ cppOptions = [],
+ ccOptions = [],
+ ldOptions = [],
+ pkgconfigDepends = [],
+ frameworks = [],
+ cSources = [],
+ hsSourceDirs = [],
+ otherModules = [],
+ defaultLanguage = Nothing,
+ otherLanguages = [],
+ defaultExtensions = [],
+ otherExtensions = [],
+ oldExtensions = [],
+ extraLibs = [],
+ extraLibDirs = [],
+ includeDirs = [],
+ includes = [],
+ installIncludes = [],
+ options = [],
+ ghcProfOptions = [],
+ ghcSharedOptions = [],
+ customFieldsBI = [],
+ targetBuildDepends = []
+ }
+ mappend a b = BuildInfo {
+ buildable = buildable a && buildable b,
+ buildTools = combine buildTools,
+ cppOptions = combine cppOptions,
+ ccOptions = combine ccOptions,
+ ldOptions = combine ldOptions,
+ pkgconfigDepends = combine pkgconfigDepends,
+ frameworks = combineNub frameworks,
+ cSources = combineNub cSources,
+ hsSourceDirs = combineNub hsSourceDirs,
+ otherModules = combineNub otherModules,
+ defaultLanguage = combineMby defaultLanguage,
+ otherLanguages = combineNub otherLanguages,
+ defaultExtensions = combineNub defaultExtensions,
+ otherExtensions = combineNub otherExtensions,
+ oldExtensions = combineNub oldExtensions,
+ extraLibs = combine extraLibs,
+ extraLibDirs = combineNub extraLibDirs,
+ includeDirs = combineNub includeDirs,
+ includes = combineNub includes,
+ installIncludes = combineNub installIncludes,
+ options = combine options,
+ ghcProfOptions = combine ghcProfOptions,
+ ghcSharedOptions = combine ghcSharedOptions,
+ customFieldsBI = combine customFieldsBI,
+ targetBuildDepends = combineNub targetBuildDepends
+ }
+ where
+ combine field = field a `mappend` field b
+ combineNub field = nub (combine field)
+ combineMby field = field b `mplus` field a
+
+emptyBuildInfo :: BuildInfo
+emptyBuildInfo = mempty
+
+-- | The 'BuildInfo' for the library (if there is one and it's buildable), and
+-- all buildable executables, test suites and benchmarks. Useful for gathering
+-- dependencies.
+allBuildInfo :: PackageDescription -> [BuildInfo]
+allBuildInfo pkg_descr = [ bi | Just lib <- [library pkg_descr]
+ , let bi = libBuildInfo lib
+ , buildable bi ]
+ ++ [ bi | exe <- executables pkg_descr
+ , let bi = buildInfo exe
+ , buildable bi ]
+ ++ [ bi | tst <- testSuites pkg_descr
+ , let bi = testBuildInfo tst
+ , buildable bi
+ , testEnabled tst ]
+ ++ [ bi | tst <- benchmarks pkg_descr
+ , let bi = benchmarkBuildInfo tst
+ , buildable bi
+ , benchmarkEnabled tst ]
+ --FIXME: many of the places where this is used, we actually want to look at
+ -- unbuildable bits too, probably need separate functions
+
+-- | The 'Language's used by this component
+--
+allLanguages :: BuildInfo -> [Language]
+allLanguages bi = maybeToList (defaultLanguage bi)
+ ++ otherLanguages bi
+
+-- | The 'Extension's that are used somewhere by this component
+--
+allExtensions :: BuildInfo -> [Extension]
+allExtensions bi = usedExtensions bi
+ ++ otherExtensions bi
+
+-- | The 'Extensions' that are used by all modules in this component
+--
+usedExtensions :: BuildInfo -> [Extension]
+usedExtensions bi = oldExtensions bi
+ ++ defaultExtensions bi
+
+type HookedBuildInfo = (Maybe BuildInfo, [(String, BuildInfo)])
+
+emptyHookedBuildInfo :: HookedBuildInfo
+emptyHookedBuildInfo = (Nothing, [])
+
+-- |Select options for a particular Haskell compiler.
+hcOptions :: CompilerFlavor -> BuildInfo -> [String]
+hcOptions hc bi = [ opt | (hc',opts) <- options bi
+ , hc' == hc
+ , opt <- opts ]
+
+-- ------------------------------------------------------------
+-- * Source repos
+-- ------------------------------------------------------------
+
+-- | Information about the source revision control system for a package.
+--
+-- When specifying a repo it is useful to know the meaning or intention of the
+-- information as doing so enables automation. There are two obvious common
+-- purposes: one is to find the repo for the latest development version, the
+-- other is to find the repo for this specific release. The 'ReopKind'
+-- specifies which one we mean (or another custom one).
+--
+-- A package can specify one or the other kind or both. Most will specify just
+-- a head repo but some may want to specify a repo to reconstruct the sources
+-- for this package release.
+--
+-- The required information is the 'RepoType' which tells us if it's using
+-- 'Darcs', 'Git' for example. The 'repoLocation' and other details are
+-- interpreted according to the repo type.
+--
+data SourceRepo = SourceRepo {
+ -- | The kind of repo. This field is required.
+ repoKind :: RepoKind,
+
+ -- | The type of the source repository system for this repo, eg 'Darcs' or
+ -- 'Git'. This field is required.
+ repoType :: Maybe RepoType,
+
+ -- | The location of the repository. For most 'RepoType's this is a URL.
+ -- This field is required.
+ repoLocation :: Maybe String,
+
+ -- | 'CVS' can put multiple \"modules\" on one server and requires a
+ -- module name in addition to the location to identify a particular repo.
+ -- Logically this is part of the location but unfortunately has to be
+ -- specified separately. This field is required for the 'CVS' 'RepoType' and
+ -- should not be given otherwise.
+ repoModule :: Maybe String,
+
+ -- | The name or identifier of the branch, if any. Many source control
+ -- systems have the notion of multiple branches in a repo that exist in the
+ -- same location. For example 'Git' and 'CVS' use this while systems like
+ -- 'Darcs' use different locations for different branches. This field is
+ -- optional but should be used if necessary to identify the sources,
+ -- especially for the 'RepoThis' repo kind.
+ repoBranch :: Maybe String,
+
+ -- | The tag identify a particular state of the repository. This should be
+ -- given for the 'RepoThis' repo kind and not for 'RepoHead' kind.
+ --
+ repoTag :: Maybe String,
+
+ -- | Some repositories contain multiple projects in different subdirectories
+ -- This field specifies the subdirectory where this packages sources can be
+ -- found, eg the subdirectory containing the @.cabal@ file. It is interpreted
+ -- relative to the root of the repository. This field is optional. If not
+ -- given the default is \".\" ie no subdirectory.
+ repoSubdir :: Maybe FilePath
+}
+ deriving (Eq, Read, Show)
+
+-- | What this repo info is for, what it represents.
+--
+data RepoKind =
+ -- | The repository for the \"head\" or development version of the project.
+ -- This repo is where we should track the latest development activity or
+ -- the usual repo people should get to contribute patches.
+ RepoHead
+
+ -- | The repository containing the sources for this exact package version
+ -- or release. For this kind of repo a tag should be given to give enough
+ -- information to re-create the exact sources.
+ | RepoThis
+
+ | RepoKindUnknown String
+ deriving (Eq, Ord, Read, Show)
+
+-- | An enumeration of common source control systems. The fields used in the
+-- 'SourceRepo' depend on the type of repo. The tools and methods used to
+-- obtain and track the repo depend on the repo type.
+--
+data RepoType = Darcs | Git | SVN | CVS
+ | Mercurial | GnuArch | Bazaar | Monotone
+ | OtherRepoType String
+ deriving (Eq, Ord, Read, Show)
+
+knownRepoTypes :: [RepoType]
+knownRepoTypes = [Darcs, Git, SVN, CVS
+ ,Mercurial, GnuArch, Bazaar, Monotone]
+
+repoTypeAliases :: RepoType -> [String]
+repoTypeAliases Bazaar = ["bzr"]
+repoTypeAliases Mercurial = ["hg"]
+repoTypeAliases GnuArch = ["arch"]
+repoTypeAliases _ = []
+
+instance Text RepoKind where
+ disp RepoHead = Disp.text "head"
+ disp RepoThis = Disp.text "this"
+ disp (RepoKindUnknown other) = Disp.text other
+
+ parse = do
+ name <- ident
+ return $ case lowercase name of
+ "head" -> RepoHead
+ "this" -> RepoThis
+ _ -> RepoKindUnknown name
+
+instance Text RepoType where
+ disp (OtherRepoType other) = Disp.text other
+ disp other = Disp.text (lowercase (show other))
+ parse = fmap classifyRepoType ident
+
+classifyRepoType :: String -> RepoType
+classifyRepoType s =
+ case lookup (lowercase s) repoTypeMap of
+ Just repoType' -> repoType'
+ Nothing -> OtherRepoType s
+ where
+ repoTypeMap = [ (name, repoType')
+ | repoType' <- knownRepoTypes
+ , name <- display repoType' : repoTypeAliases repoType' ]
+
+ident :: Parse.ReadP r String
+ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')
+
+lowercase :: String -> String
+lowercase = map Char.toLower
+
+-- ------------------------------------------------------------
+-- * Utils
+-- ------------------------------------------------------------
+
+updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription
+updatePackageDescription (mb_lib_bi, exe_bi) p
+ = p{ executables = updateExecutables exe_bi (executables p)
+ , library = updateLibrary mb_lib_bi (library p)
+ }
+ where
+ updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library
+ updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib})
+ updateLibrary Nothing mb_lib = mb_lib
+ updateLibrary (Just _) Nothing = Nothing
+
+ updateExecutables :: [(String, BuildInfo)] -- ^[(exeName, new buildinfo)]
+ -> [Executable] -- ^list of executables to update
+ -> [Executable] -- ^list with exeNames updated
+ updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi'
+
+ updateExecutable :: (String, BuildInfo) -- ^(exeName, new buildinfo)
+ -> [Executable] -- ^list of executables to update
+ -> [Executable] -- ^libst with exeName updated
+ updateExecutable _ [] = []
+ updateExecutable exe_bi'@(name,bi) (exe:exes)
+ | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes
+ | otherwise = exe : updateExecutable exe_bi' exes
+
+-- ---------------------------------------------------------------------------
+-- The GenericPackageDescription type
+
+data GenericPackageDescription =
+ GenericPackageDescription {
+ packageDescription :: PackageDescription,
+ genPackageFlags :: [Flag],
+ condLibrary :: Maybe (CondTree ConfVar [Dependency] Library),
+ condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)],
+ condTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)],
+ condBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)]
+ }
+ deriving (Show, Eq, Typeable)
+
+instance Package GenericPackageDescription where
+ packageId = packageId . packageDescription
+
+--TODO: make PackageDescription an instance of Text.
+
+-- | A flag can represent a feature to be included, or a way of linking
+-- a target against its dependencies, or in fact whatever you can think of.
+data Flag = MkFlag
+ { flagName :: FlagName
+ , flagDescription :: String
+ , flagDefault :: Bool
+ , flagManual :: Bool
+ }
+ deriving (Show, Eq)
+
+-- | A 'FlagName' is the name of a user-defined configuration flag
+newtype FlagName = FlagName String
+ deriving (Eq, Ord, Show, Read)
+
+-- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to
+-- 'Bool' flag values. It represents the flags chosen by the user or
+-- discovered during configuration. For example @--flags=foo --flags=-bar@
+-- becomes @[("foo", True), ("bar", False)]@
+--
+type FlagAssignment = [(FlagName, Bool)]
+
+-- | A @ConfVar@ represents the variable type used.
+data ConfVar = OS OS
+ | Arch Arch
+ | Flag FlagName
+ | Impl CompilerFlavor VersionRange
+ deriving (Eq, Show)
+
+--instance Text ConfVar where
+-- disp (OS os) = "os(" ++ display os ++ ")"
+-- disp (Arch arch) = "arch(" ++ display arch ++ ")"
+-- disp (Flag (ConfFlag f)) = "flag(" ++ f ++ ")"
+-- disp (Impl c v) = "impl(" ++ display c
+-- ++ " " ++ display v ++ ")"
+
+-- | A boolean expression parameterized over the variable type used.
+data Condition c = Var c
+ | Lit Bool
+ | CNot (Condition c)
+ | COr (Condition c) (Condition c)
+ | CAnd (Condition c) (Condition c)
+ deriving (Show, Eq)
+
+--instance Text c => Text (Condition c) where
+-- disp (Var x) = text (show x)
+-- disp (Lit b) = text (show b)
+-- disp (CNot c) = char '!' <> parens (ppCond c)
+-- disp (COr c1 c2) = parens $ sep [ppCond c1, text "||" <+> ppCond c2]
+-- disp (CAnd c1 c2) = parens $ sep [ppCond c1, text "&&" <+> ppCond c2]
+
+data CondTree v c a = CondNode
+ { condTreeData :: a
+ , condTreeConstraints :: c
+ , condTreeComponents :: [( Condition v
+ , CondTree v c a
+ , Maybe (CondTree v c a))]
+ }
+ deriving (Show, Eq)
+
+--instance (Text v, Text c) => Text (CondTree v c a) where
+-- disp (CondNode _dat cs ifs) =
+-- (text "build-depends: " <+>
+-- disp cs)
+-- $+$
+-- (vcat $ map ppIf ifs)
+-- where
+-- ppIf (c,thenTree,mElseTree) =
+-- ((text "if" <+> ppCond c <> colon) $$
+-- nest 2 (ppCondTree thenTree disp))
+-- $+$ (maybe empty (\t -> text "else: " $$ nest 2 (ppCondTree t disp))
+-- mElseTree)
diff --git a/cabal/Cabal/Distribution/PackageDescription/Check.hs b/cabal/Cabal/Distribution/PackageDescription/Check.hs
new file mode 100644
index 0000000..56afa83
--- /dev/null
+++ b/cabal/Cabal/Distribution/PackageDescription/Check.hs
@@ -0,0 +1,1495 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.PackageDescription.Check
+-- Copyright : Lennart Kolmodin 2008
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This has code for checking for various problems in packages. There is one
+-- set of checks that just looks at a 'PackageDescription' in isolation and
+-- another set of checks that also looks at files in the package. Some of the
+-- checks are basic sanity checks, others are portability standards that we'd
+-- like to encourage. There is a 'PackageCheck' type that distinguishes the
+-- different kinds of check so we can see which ones are appropriate to report
+-- in different situations. This code gets uses when configuring a package when
+-- we consider only basic problems. The higher standard is uses when when
+-- preparing a source tarball and by hackage when uploading new packages. The
+-- reason for this is that we want to hold packages that are expected to be
+-- distributed to a higher standard than packages that are only ever expected
+-- to be used on the author's own environment.
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.PackageDescription.Check (
+ -- * Package Checking
+ PackageCheck(..),
+ checkPackage,
+ checkConfiguredPackage,
+
+ -- ** Checking package contents
+ checkPackageFiles,
+ checkPackageContent,
+ CheckPackageContentOps(..),
+ checkPackageFileNames,
+ ) where
+
+import Data.Maybe
+ ( isNothing, isJust, catMaybes, maybeToList, fromMaybe )
+import Data.List (sort, group, isPrefixOf, nub, find)
+import Control.Monad
+ ( filterM, liftM )
+import qualified System.Directory as System
+ ( doesFileExist, doesDirectoryExist )
+
+import Distribution.Package ( pkgName )
+import Distribution.PackageDescription
+import Distribution.PackageDescription.Configuration
+ ( flattenPackageDescription, finalizePackageDescription )
+import Distribution.Compiler
+ ( CompilerFlavor(..), buildCompilerFlavor, CompilerId(..) )
+import Distribution.System
+ ( OS(..), Arch(..), buildPlatform )
+import Distribution.License
+ ( License(..), knownLicenses )
+import Distribution.Simple.Utils
+ ( cabalVersion, intercalate, parseFileGlob, FileGlob(..), lowercase )
+
+import Distribution.Version
+ ( Version(..)
+ , VersionRange(..), foldVersionRange'
+ , anyVersion, noVersion, thisVersion, laterVersion, earlierVersion
+ , orLaterVersion, orEarlierVersion
+ , unionVersionRanges, intersectVersionRanges
+ , asVersionIntervals, UpperBound(..), isNoVersion )
+import Distribution.Package
+ ( PackageName(PackageName), packageName, packageVersion
+ , Dependency(..) )
+
+import Distribution.Text
+ ( display, disp )
+import qualified Text.PrettyPrint as Disp
+import Text.PrettyPrint ((<>), (<+>))
+
+import qualified Language.Haskell.Extension as Extension (deprecatedExtensions)
+import Language.Haskell.Extension
+ ( Language(UnknownLanguage), knownLanguages, Extension(..), KnownExtension(..) )
+import System.FilePath
+ ( (</>), takeExtension, isRelative, isAbsolute
+ , splitDirectories, splitPath )
+import System.FilePath.Windows as FilePath.Windows
+ ( isValid )
+
+-- | Results of some kind of failed package check.
+--
+-- There are a range of severities, from merely dubious to totally insane.
+-- All of them come with a human readable explanation. In future we may augment
+-- them with more machine readable explanations, for example to help an IDE
+-- suggest automatic corrections.
+--
+data PackageCheck =
+
+ -- | This package description is no good. There's no way it's going to
+ -- build sensibly. This should give an error at configure time.
+ PackageBuildImpossible { explanation :: String }
+
+ -- | A problem that is likely to affect building the package, or an
+ -- issue that we'd like every package author to be aware of, even if
+ -- the package is never distributed.
+ | PackageBuildWarning { explanation :: String }
+
+ -- | An issue that might not be a problem for the package author but
+ -- might be annoying or determental when the package is distributed to
+ -- users. We should encourage distributed packages to be free from these
+ -- issues, but occasionally there are justifiable reasons so we cannot
+ -- ban them entirely.
+ | PackageDistSuspicious { explanation :: String }
+
+ -- | An issue that is ok in the author's environment but is almost
+ -- certain to be a portability problem for other environments. We can
+ -- quite legitimately refuse to publicly distribute packages with these
+ -- problems.
+ | PackageDistInexcusable { explanation :: String }
+
+instance Show PackageCheck where
+ show notice = explanation notice
+
+check :: Bool -> PackageCheck -> Maybe PackageCheck
+check False _ = Nothing
+check True pc = Just pc
+
+-- ------------------------------------------------------------
+-- * Standard checks
+-- ------------------------------------------------------------
+
+-- | Check for common mistakes and problems in package descriptions.
+--
+-- This is the standard collection of checks covering all apsects except
+-- for checks that require looking at files within the package. For those
+-- see 'checkPackageFiles'.
+--
+-- It requires the 'GenericPackageDescription' and optionally a particular
+-- configuration of that package. If you pass 'Nothing' then we just check
+-- a version of the generic description using 'flattenPackageDescription'.
+--
+checkPackage :: GenericPackageDescription
+ -> Maybe PackageDescription
+ -> [PackageCheck]
+checkPackage gpkg mpkg =
+ checkConfiguredPackage pkg
+ ++ checkConditionals gpkg
+ ++ checkPackageVersions gpkg
+ where
+ pkg = fromMaybe (flattenPackageDescription gpkg) mpkg
+
+--TODO: make this variant go away
+-- we should alwaws know the GenericPackageDescription
+checkConfiguredPackage :: PackageDescription -> [PackageCheck]
+checkConfiguredPackage pkg =
+ checkSanity pkg
+ ++ checkFields pkg
+ ++ checkLicense pkg
+ ++ checkSourceRepos pkg
+ ++ checkGhcOptions pkg
+ ++ checkCCOptions pkg
+ ++ checkCPPOptions pkg
+ ++ checkPaths pkg
+ ++ checkCabalVersion pkg
+
+
+-- ------------------------------------------------------------
+-- * Basic sanity checks
+-- ------------------------------------------------------------
+
+-- | Check that this package description is sane.
+--
+checkSanity :: PackageDescription -> [PackageCheck]
+checkSanity pkg =
+ catMaybes [
+
+ check (null . (\(PackageName n) -> n) . packageName $ pkg) $
+ PackageBuildImpossible "No 'name' field."
+
+ , check (null . versionBranch . packageVersion $ pkg) $
+ PackageBuildImpossible "No 'version' field."
+
+ , check (null (executables pkg) && isNothing (library pkg)) $
+ PackageBuildImpossible
+ "No executables and no library found. Nothing to do."
+
+ , check (not (null duplicateNames)) $
+ PackageBuildImpossible $ "Duplicate sections: " ++ commaSep duplicateNames
+ ++ ". The name of every executable, test suite, and benchmark section in"
+ ++ " the package must be unique."
+ ]
+ --TODO: check for name clashes case insensitively: windows file systems cannot cope.
+
+ ++ maybe [] checkLibrary (library pkg)
+ ++ concatMap checkExecutable (executables pkg)
+ ++ concatMap (checkTestSuite pkg) (testSuites pkg)
+ ++ concatMap (checkBenchmark pkg) (benchmarks pkg)
+
+ ++ catMaybes [
+
+ check (specVersion pkg > cabalVersion) $
+ PackageBuildImpossible $
+ "This package description follows version "
+ ++ display (specVersion pkg) ++ " of the Cabal specification. This "
+ ++ "tool only supports up to version " ++ display cabalVersion ++ "."
+ ]
+ where
+ exeNames = map exeName $ executables pkg
+ testNames = map testName $ testSuites pkg
+ bmNames = map benchmarkName $ benchmarks pkg
+ duplicateNames = dups $ exeNames ++ testNames ++ bmNames
+
+checkLibrary :: Library -> [PackageCheck]
+checkLibrary lib =
+ catMaybes [
+
+ check (not (null moduleDuplicates)) $
+ PackageBuildWarning $
+ "Duplicate modules in library: "
+ ++ commaSep (map display moduleDuplicates)
+ ]
+
+ where
+ moduleDuplicates = dups (libModules lib)
+
+checkExecutable :: Executable -> [PackageCheck]
+checkExecutable exe =
+ catMaybes [
+
+ check (null (modulePath exe)) $
+ PackageBuildImpossible $
+ "No 'Main-Is' field found for executable " ++ exeName exe
+
+ , check (not (null (modulePath exe))
+ && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $
+ PackageBuildImpossible $
+ "The 'Main-Is' field must specify a '.hs' or '.lhs' file "
+ ++ "(even if it is generated by a preprocessor)."
+
+ , check (not (null moduleDuplicates)) $
+ PackageBuildWarning $
+ "Duplicate modules in executable '" ++ exeName exe ++ "': "
+ ++ commaSep (map display moduleDuplicates)
+ ]
+ where
+ moduleDuplicates = dups (exeModules exe)
+
+checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck]
+checkTestSuite pkg test =
+ catMaybes [
+
+ case testInterface test of
+ TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $
+ PackageBuildWarning $
+ quote (display tt) ++ " is not a known type of test suite. "
+ ++ "The known test suite types are: "
+ ++ commaSep (map display knownTestTypes)
+
+ TestSuiteUnsupported tt -> Just $
+ PackageBuildWarning $
+ quote (display tt) ++ " is not a supported test suite version. "
+ ++ "The known test suite types are: "
+ ++ commaSep (map display knownTestTypes)
+ _ -> Nothing
+
+ , check (not $ null moduleDuplicates) $
+ PackageBuildWarning $
+ "Duplicate modules in test suite '" ++ testName test ++ "': "
+ ++ commaSep (map display moduleDuplicates)
+
+ , check mainIsWrongExt $
+ PackageBuildImpossible $
+ "The 'main-is' field must specify a '.hs' or '.lhs' file "
+ ++ "(even if it is generated by a preprocessor)."
+
+ -- Test suites might be built as (internal) libraries named after
+ -- the test suite and thus their names must not clash with the
+ -- name of the package.
+ , check libNameClash $
+ PackageBuildImpossible $
+ "The test suite " ++ testName test
+ ++ " has the same name as the package."
+ ]
+ where
+ moduleDuplicates = dups $ testModules test
+
+ mainIsWrongExt = case testInterface test of
+ TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]
+ _ -> False
+
+ libNameClash = testName test `elem` [ libName
+ | _lib <- maybeToList (library pkg)
+ , let PackageName libName =
+ pkgName (package pkg) ]
+
+checkBenchmark :: PackageDescription -> Benchmark -> [PackageCheck]
+checkBenchmark pkg bm =
+ catMaybes [
+
+ case benchmarkInterface bm of
+ BenchmarkUnsupported tt@(BenchmarkTypeUnknown _ _) -> Just $
+ PackageBuildWarning $
+ quote (display tt) ++ " is not a known type of benchmark. "
+ ++ "The known benchmark types are: "
+ ++ commaSep (map display knownBenchmarkTypes)
+
+ BenchmarkUnsupported tt -> Just $
+ PackageBuildWarning $
+ quote (display tt) ++ " is not a supported benchmark version. "
+ ++ "The known benchmark types are: "
+ ++ commaSep (map display knownBenchmarkTypes)
+ _ -> Nothing
+
+ , check (not $ null moduleDuplicates) $
+ PackageBuildWarning $
+ "Duplicate modules in benchmark '" ++ benchmarkName bm ++ "': "
+ ++ commaSep (map display moduleDuplicates)
+
+ , check mainIsWrongExt $
+ PackageBuildImpossible $
+ "The 'main-is' field must specify a '.hs' or '.lhs' file "
+ ++ "(even if it is generated by a preprocessor)."
+
+ -- See comment for similar check on test suites.
+ , check libNameClash $
+ PackageBuildImpossible $
+ "The benchmark " ++ benchmarkName bm
+ ++ " has the same name as the package."
+ ]
+ where
+ moduleDuplicates = dups $ benchmarkModules bm
+
+ mainIsWrongExt = case benchmarkInterface bm of
+ BenchmarkExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]
+ _ -> False
+
+ libNameClash = benchmarkName bm `elem` [ libName
+ | _lib <- maybeToList (library pkg)
+ , let PackageName libName =
+ pkgName (package pkg) ]
+
+-- ------------------------------------------------------------
+-- * Additional pure checks
+-- ------------------------------------------------------------
+
+checkFields :: PackageDescription -> [PackageCheck]
+checkFields pkg =
+ catMaybes [
+
+ check (not . FilePath.Windows.isValid . display . packageName $ pkg) $
+ PackageDistInexcusable $
+ "Unfortunately, the package name '" ++ display (packageName pkg)
+ ++ "' is one of the reserved system file names on Windows. Many tools "
+ ++ "need to convert package names to file names so using this name "
+ ++ "would cause problems."
+
+ , check (isNothing (buildType pkg)) $
+ PackageBuildWarning $
+ "No 'build-type' specified. If you do not need a custom Setup.hs or "
+ ++ "./configure script then use 'build-type: Simple'."
+
+ , case buildType pkg of
+ Just (UnknownBuildType unknown) -> Just $
+ PackageBuildWarning $
+ quote unknown ++ " is not a known 'build-type'. "
+ ++ "The known build types are: "
+ ++ commaSep (map display knownBuildTypes)
+ _ -> Nothing
+
+ , check (not (null unknownCompilers)) $
+ PackageBuildWarning $
+ "Unknown compiler " ++ commaSep (map quote unknownCompilers)
+ ++ " in 'tested-with' field."
+
+ , check (not (null unknownLanguages)) $
+ PackageBuildWarning $
+ "Unknown languages: " ++ commaSep unknownLanguages
+
+ , check (not (null unknownExtensions)) $
+ PackageBuildWarning $
+ "Unknown extensions: " ++ commaSep unknownExtensions
+
+ , check (not (null languagesUsedAsExtensions)) $
+ PackageBuildWarning $
+ "Languages listed as extensions: "
+ ++ commaSep languagesUsedAsExtensions
+ ++ ". Languages must be specified in either the 'default-language' "
+ ++ " or the 'other-languages' field."
+
+ , check (not (null deprecatedExtensions)) $
+ PackageDistSuspicious $
+ "Deprecated extensions: "
+ ++ commaSep (map (quote . display . fst) deprecatedExtensions)
+ ++ ". " ++ intercalate " "
+ [ "Instead of '" ++ display ext
+ ++ "' use '" ++ display replacement ++ "'."
+ | (ext, Just replacement) <- deprecatedExtensions ]
+
+ , check (null (category pkg)) $
+ PackageDistSuspicious "No 'category' field."
+
+ , check (null (maintainer pkg)) $
+ PackageDistSuspicious "No 'maintainer' field."
+
+ , check (null (synopsis pkg) && null (description pkg)) $
+ PackageDistInexcusable $ "No 'synopsis' or 'description' field."
+
+ , check (null (description pkg) && not (null (synopsis pkg))) $
+ PackageDistSuspicious "No 'description' field."
+
+ , check (null (synopsis pkg) && not (null (description pkg))) $
+ PackageDistSuspicious "No 'synopsis' field."
+
+ --TODO: recommend the bug reports url, author and homepage fields
+ --TODO: recommend not using the stability field
+ --TODO: recommend specifying a source repo
+
+ , check (length (synopsis pkg) >= 80) $
+ PackageDistSuspicious
+ "The 'synopsis' field is rather long (max 80 chars is recommended)."
+
+ -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12"
+ , check (not (null testedWithImpossibleRanges)) $
+ PackageDistInexcusable $
+ "Invalid 'tested-with' version range: "
+ ++ commaSep (map display testedWithImpossibleRanges)
+ ++ ". To indicate that you have tested a package with multiple "
+ ++ "different versions of the same compiler use multiple entries, "
+ ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not "
+ ++ "'tested-with: GHC==6.10.4 && ==6.12.3'."
+ ]
+ where
+ unknownCompilers = [ name | (OtherCompiler name, _) <- testedWith pkg ]
+ unknownLanguages = [ name | bi <- allBuildInfo pkg
+ , UnknownLanguage name <- allLanguages bi ]
+ unknownExtensions = [ name | bi <- allBuildInfo pkg
+ , UnknownExtension name <- allExtensions bi
+ , name `notElem` map display knownLanguages ]
+ deprecatedExtensions = nub $ catMaybes
+ [ find ((==ext) . fst) Extension.deprecatedExtensions
+ | bi <- allBuildInfo pkg
+ , ext <- allExtensions bi ]
+ languagesUsedAsExtensions =
+ [ name | bi <- allBuildInfo pkg
+ , UnknownExtension name <- allExtensions bi
+ , name `elem` map display knownLanguages ]
+
+ testedWithImpossibleRanges =
+ [ Dependency (PackageName (display compiler)) vr
+ | (compiler, vr) <- testedWith pkg
+ , isNoVersion vr ]
+
+
+checkLicense :: PackageDescription -> [PackageCheck]
+checkLicense pkg =
+ catMaybes [
+
+ check (license pkg == AllRightsReserved) $
+ PackageDistInexcusable
+ "The 'license' field is missing or specified as AllRightsReserved."
+
+ , case license pkg of
+ UnknownLicense l -> Just $
+ PackageBuildWarning $
+ quote ("license: " ++ l) ++ " is not a recognised license. The "
+ ++ "known licenses are: "
+ ++ commaSep (map display knownLicenses)
+ _ -> Nothing
+
+ , check (license pkg == BSD4) $
+ PackageDistSuspicious $
+ "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' "
+ ++ "refers to the old 4-clause BSD license with the advertising "
+ ++ "clause. 'BSD3' refers the new 3-clause BSD license."
+
+ , case unknownLicenseVersion (license pkg) of
+ Just knownVersions -> Just $
+ PackageDistSuspicious $
+ "'license: " ++ display (license pkg) ++ "' is not a known "
+ ++ "version of that license. The known versions are "
+ ++ commaSep (map display knownVersions)
+ ++ ". If this is not a mistake and you think it should be a known "
+ ++ "version then please file a ticket."
+ _ -> Nothing
+
+ , check (license pkg `notElem` [AllRightsReserved, PublicDomain]
+ -- AllRightsReserved and PublicDomain are not strictly
+ -- licenses so don't need license files.
+ && null (licenseFile pkg)) $
+ PackageDistSuspicious "A 'license-file' is not specified."
+ ]
+ where
+ unknownLicenseVersion (GPL (Just v))
+ | v `notElem` knownVersions = Just knownVersions
+ where knownVersions = [ v' | GPL (Just v') <- knownLicenses ]
+ unknownLicenseVersion (LGPL (Just v))
+ | v `notElem` knownVersions = Just knownVersions
+ where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ]
+ unknownLicenseVersion (Apache (Just v))
+ | v `notElem` knownVersions = Just knownVersions
+ where knownVersions = [ v' | Apache (Just v') <- knownLicenses ]
+ unknownLicenseVersion _ = Nothing
+
+checkSourceRepos :: PackageDescription -> [PackageCheck]
+checkSourceRepos pkg =
+ catMaybes $ concat [[
+
+ case repoKind repo of
+ RepoKindUnknown kind -> Just $ PackageDistInexcusable $
+ quote kind ++ " is not a recognised kind of source-repository. "
+ ++ "The repo kind is usually 'head' or 'this'"
+ _ -> Nothing
+
+ , check (repoType repo == Nothing) $
+ PackageDistInexcusable
+ "The source-repository 'type' is a required field."
+
+ , check (repoLocation repo == Nothing) $
+ PackageDistInexcusable
+ "The source-repository 'location' is a required field."
+
+ , check (repoType repo == Just CVS && repoModule repo == Nothing) $
+ PackageDistInexcusable
+ "For a CVS source-repository, the 'module' is a required field."
+
+ , check (repoKind repo == RepoThis && repoTag repo == Nothing) $
+ PackageDistInexcusable $
+ "For the 'this' kind of source-repository, the 'tag' is a required "
+ ++ "field. It should specify the tag corresponding to this version "
+ ++ "or release of the package."
+
+ , check (maybe False System.FilePath.isAbsolute (repoSubdir repo)) $
+ PackageDistInexcusable
+ "The 'subdir' field of a source-repository must be a relative path."
+ ]
+ | repo <- sourceRepos pkg ]
+
+--TODO: check location looks like a URL for some repo types.
+
+checkGhcOptions :: PackageDescription -> [PackageCheck]
+checkGhcOptions pkg =
+ catMaybes [
+
+ check has_WerrorWall $
+ PackageDistInexcusable $
+ "'ghc-options: -Wall -Werror' makes the package very easy to "
+ ++ "break with future GHC versions because new GHC versions often "
+ ++ "add new warnings. Use just 'ghc-options: -Wall' instead."
+
+ , check (not has_WerrorWall && has_Werror) $
+ PackageDistSuspicious $
+ "'ghc-options: -Werror' makes the package easy to "
+ ++ "break with future GHC versions because new GHC versions often "
+ ++ "add new warnings."
+
+ , checkFlags ["-fasm"] $
+ PackageDistInexcusable $
+ "'ghc-options: -fasm' is unnecessary and will not work on CPU "
+ ++ "architectures other than x86, x86-64, ppc or sparc."
+
+ , checkFlags ["-fvia-C"] $
+ PackageDistSuspicious $
+ "'ghc-options: -fvia-C' is usually unnecessary. If your package "
+ ++ "needs -via-C for correctness rather than performance then it "
+ ++ "is using the FFI incorrectly and will probably not work with GHC "
+ ++ "6.10 or later."
+
+ , checkFlags ["-fdefer-type-errors"] $
+ PackageDistInexcusable $
+ "'ghc-options: -fdefer-type-errors' is fine during development but "
+ ++ "is not appropriate for a distributed package."
+
+ , checkFlags ["-fhpc"] $
+ PackageDistInexcusable $
+ "'ghc-options: -fhpc' is not appropriate for a distributed package."
+
+ , check (any ("-d" `isPrefixOf`) all_ghc_options) $
+ PackageDistInexcusable $
+ "'ghc-options: -d*' debug flags are not appropriate for a distributed package."
+
+ , checkFlags ["-prof"] $
+ PackageBuildWarning $
+ "'ghc-options: -prof' is not necessary and will lead to problems "
+ ++ "when used on a library. Use the configure flag "
+ ++ "--enable-library-profiling and/or --enable-executable-profiling."
+
+ , checkFlags ["-o"] $
+ PackageBuildWarning $
+ "'ghc-options: -o' is not needed. The output files are named automatically."
+
+ , checkFlags ["-hide-package"] $
+ PackageBuildWarning $
+ "'ghc-options: -hide-package' is never needed. Cabal hides all packages."
+
+ , checkFlags ["--make"] $
+ PackageBuildWarning $
+ "'ghc-options: --make' is never needed. Cabal uses this automatically."
+
+ , checkFlags ["-main-is"] $
+ PackageDistSuspicious $
+ "'ghc-options: -main-is' is not portable."
+
+ , checkFlags ["-O0", "-Onot"] $
+ PackageDistSuspicious $
+ "'ghc-options: -O0' is not needed. Use the --disable-optimization configure flag."
+
+ , checkFlags [ "-O", "-O1"] $
+ PackageDistInexcusable $
+ "'ghc-options: -O' is not needed. Cabal automatically adds the '-O' flag. "
+ ++ "Setting it yourself interferes with the --disable-optimization flag."
+
+ , checkFlags ["-O2"] $
+ PackageDistSuspicious $
+ "'ghc-options: -O2' is rarely needed. Check that it is giving a real benefit "
+ ++ "and not just imposing longer compile times on your users."
+
+ , checkFlags ["-split-objs"] $
+ PackageBuildWarning $
+ "'ghc-options: -split-objs' is not needed. Use the --enable-split-objs configure flag."
+
+ , checkFlags ["-optl-Wl,-s", "-optl-s"] $
+ PackageDistInexcusable $
+ "'ghc-options: -optl-Wl,-s' is not needed and is not portable to all"
+ ++ " operating systems. Cabal 1.4 and later automatically strip"
+ ++ " executables. Cabal also has a flag --disable-executable-stripping"
+ ++ " which is necessary when building packages for some Linux"
+ ++ " distributions and using '-optl-Wl,-s' prevents that from working."
+
+ , checkFlags ["-fglasgow-exts"] $
+ PackageDistSuspicious $
+ "Instead of 'ghc-options: -fglasgow-exts' it is preferable to use the 'extensions' field."
+
+ , check ("-threaded" `elem` lib_ghc_options) $
+ PackageDistSuspicious $
+ "'ghc-options: -threaded' has no effect for libraries. It should "
+ ++ "only be used for executables."
+
+ , checkAlternatives "ghc-options" "extensions"
+ [ (flag, display extension) | flag <- all_ghc_options
+ , Just extension <- [ghcExtension flag] ]
+
+ , checkAlternatives "ghc-options" "extensions"
+ [ (flag, extension) | flag@('-':'X':extension) <- all_ghc_options ]
+
+ , checkAlternatives "ghc-options" "cpp-options" $
+ [ (flag, flag) | flag@('-':'D':_) <- all_ghc_options ]
+ ++ [ (flag, flag) | flag@('-':'U':_) <- all_ghc_options ]
+
+ , checkAlternatives "ghc-options" "include-dirs"
+ [ (flag, dir) | flag@('-':'I':dir) <- all_ghc_options ]
+
+ , checkAlternatives "ghc-options" "extra-libraries"
+ [ (flag, lib) | flag@('-':'l':lib) <- all_ghc_options ]
+
+ , checkAlternatives "ghc-options" "extra-lib-dirs"
+ [ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ]
+ ]
+
+ where
+ has_WerrorWall = flip any ghc_options $ \opts ->
+ "-Werror" `elem` opts
+ && ("-Wall" `elem` opts || "-W" `elem` opts)
+ has_Werror = any (\opts -> "-Werror" `elem` opts) ghc_options
+
+ ghc_options = [ strs | bi <- allBuildInfo pkg
+ , (GHC, strs) <- options bi ]
+ all_ghc_options = concat ghc_options
+ lib_ghc_options = maybe [] (hcOptions GHC . libBuildInfo) (library pkg)
+
+ checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck
+ checkFlags flags = check (any (`elem` flags) all_ghc_options)
+
+ ghcExtension ('-':'f':name) = case name of
+ "allow-overlapping-instances" -> Just (EnableExtension OverlappingInstances)
+ "no-allow-overlapping-instances" -> Just (DisableExtension OverlappingInstances)
+ "th" -> Just (EnableExtension TemplateHaskell)
+ "no-th" -> Just (DisableExtension TemplateHaskell)
+ "ffi" -> Just (EnableExtension ForeignFunctionInterface)
+ "no-ffi" -> Just (DisableExtension ForeignFunctionInterface)
+ "fi" -> Just (EnableExtension ForeignFunctionInterface)
+ "no-fi" -> Just (DisableExtension ForeignFunctionInterface)
+ "monomorphism-restriction" -> Just (EnableExtension MonomorphismRestriction)
+ "no-monomorphism-restriction" -> Just (DisableExtension MonomorphismRestriction)
+ "mono-pat-binds" -> Just (EnableExtension MonoPatBinds)
+ "no-mono-pat-binds" -> Just (DisableExtension MonoPatBinds)
+ "allow-undecidable-instances" -> Just (EnableExtension UndecidableInstances)
+ "no-allow-undecidable-instances" -> Just (DisableExtension UndecidableInstances)
+ "allow-incoherent-instances" -> Just (EnableExtension IncoherentInstances)
+ "no-allow-incoherent-instances" -> Just (DisableExtension IncoherentInstances)
+ "arrows" -> Just (EnableExtension Arrows)
+ "no-arrows" -> Just (DisableExtension Arrows)
+ "generics" -> Just (EnableExtension Generics)
+ "no-generics" -> Just (DisableExtension Generics)
+ "implicit-prelude" -> Just (EnableExtension ImplicitPrelude)
+ "no-implicit-prelude" -> Just (DisableExtension ImplicitPrelude)
+ "implicit-params" -> Just (EnableExtension ImplicitParams)
+ "no-implicit-params" -> Just (DisableExtension ImplicitParams)
+ "bang-patterns" -> Just (EnableExtension BangPatterns)
+ "no-bang-patterns" -> Just (DisableExtension BangPatterns)
+ "scoped-type-variables" -> Just (EnableExtension ScopedTypeVariables)
+ "no-scoped-type-variables" -> Just (DisableExtension ScopedTypeVariables)
+ "extended-default-rules" -> Just (EnableExtension ExtendedDefaultRules)
+ "no-extended-default-rules" -> Just (DisableExtension ExtendedDefaultRules)
+ _ -> Nothing
+ ghcExtension "-cpp" = Just (EnableExtension CPP)
+ ghcExtension _ = Nothing
+
+checkCCOptions :: PackageDescription -> [PackageCheck]
+checkCCOptions pkg =
+ catMaybes [
+
+ checkAlternatives "cc-options" "include-dirs"
+ [ (flag, dir) | flag@('-':'I':dir) <- all_ccOptions ]
+
+ , checkAlternatives "cc-options" "extra-libraries"
+ [ (flag, lib) | flag@('-':'l':lib) <- all_ccOptions ]
+
+ , checkAlternatives "cc-options" "extra-lib-dirs"
+ [ (flag, dir) | flag@('-':'L':dir) <- all_ccOptions ]
+
+ , checkAlternatives "ld-options" "extra-libraries"
+ [ (flag, lib) | flag@('-':'l':lib) <- all_ldOptions ]
+
+ , checkAlternatives "ld-options" "extra-lib-dirs"
+ [ (flag, dir) | flag@('-':'L':dir) <- all_ldOptions ]
+
+ , checkCCFlags [ "-O", "-Os", "-O0", "-O1", "-O2", "-O3" ] $
+ PackageDistSuspicious $
+ "'cc-options: -O[n]' is generally not needed. When building with "
+ ++ " optimisations Cabal automatically adds '-O2' for C code. "
+ ++ "Setting it yourself interferes with the --disable-optimization "
+ ++ "flag."
+ ]
+
+ where all_ccOptions = [ opts | bi <- allBuildInfo pkg
+ , opts <- ccOptions bi ]
+ all_ldOptions = [ opts | bi <- allBuildInfo pkg
+ , opts <- ldOptions bi ]
+
+ checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck
+ checkCCFlags flags = check (any (`elem` flags) all_ccOptions)
+
+checkCPPOptions :: PackageDescription -> [PackageCheck]
+checkCPPOptions pkg =
+ catMaybes [
+ checkAlternatives "cpp-options" "include-dirs"
+ [ (flag, dir) | flag@('-':'I':dir) <- all_cppOptions]
+ ]
+ where all_cppOptions = [ opts | bi <- allBuildInfo pkg
+ , opts <- cppOptions bi ]
+
+checkAlternatives :: String -> String -> [(String, String)] -> Maybe PackageCheck
+checkAlternatives badField goodField flags =
+ check (not (null badFlags)) $
+ PackageBuildWarning $
+ "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags)
+ ++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags)
+
+ where (badFlags, goodFlags) = unzip flags
+
+checkPaths :: PackageDescription -> [PackageCheck]
+checkPaths pkg =
+ [ PackageBuildWarning $
+ quote (kind ++ ": " ++ path)
+ ++ " is a relative path outside of the source tree. "
+ ++ "This will not work when generating a tarball with 'sdist'."
+ | (path, kind) <- relPaths ++ absPaths
+ , isOutsideTree path ]
+ ++
+ [ PackageDistInexcusable $
+ quote (kind ++ ": " ++ path) ++ " is an absolute directory."
+ | (path, kind) <- relPaths
+ , isAbsolute path ]
+ ++
+ [ PackageDistInexcusable $
+ quote (kind ++ ": " ++ path) ++ " points inside the 'dist' "
+ ++ "directory. This is not reliable because the location of this "
+ ++ "directory is configurable by the user (or package manager). In "
+ ++ "addition the layout of the 'dist' directory is subject to change "
+ ++ "in future versions of Cabal."
+ | (path, kind) <- relPaths ++ absPaths
+ , isInsideDist path ]
+ ++
+ [ PackageDistInexcusable $
+ "The 'ghc-options' contains the path '" ++ path ++ "' which points "
+ ++ "inside the 'dist' directory. This is not reliable because the "
+ ++ "location of this directory is configurable by the user (or package "
+ ++ "manager). In addition the layout of the 'dist' directory is subject "
+ ++ "to change in future versions of Cabal."
+ | bi <- allBuildInfo pkg
+ , (GHC, flags) <- options bi
+ , path <- flags
+ , isInsideDist path ]
+ where
+ isOutsideTree path = case splitDirectories path of
+ "..":_ -> True
+ ".":"..":_ -> True
+ _ -> False
+ isInsideDist path = case map lowercase (splitDirectories path) of
+ "dist" :_ -> True
+ ".":"dist":_ -> True
+ _ -> False
+ -- paths that must be relative
+ relPaths =
+ [ (path, "extra-src-files") | path <- extraSrcFiles pkg ]
+ ++ [ (path, "extra-tmp-files") | path <- extraTmpFiles pkg ]
+ ++ [ (path, "data-files") | path <- dataFiles pkg ]
+ ++ [ (path, "data-dir") | path <- [dataDir pkg]]
+ ++ concat
+ [ [ (path, "c-sources") | path <- cSources bi ]
+ ++ [ (path, "install-includes") | path <- installIncludes bi ]
+ ++ [ (path, "hs-source-dirs") | path <- hsSourceDirs bi ]
+ | bi <- allBuildInfo pkg ]
+ -- paths that are allowed to be absolute
+ absPaths = concat
+ [ [ (path, "includes") | path <- includes bi ]
+ ++ [ (path, "include-dirs") | path <- includeDirs bi ]
+ ++ [ (path, "extra-lib-dirs") | path <- extraLibDirs bi ]
+ | bi <- allBuildInfo pkg ]
+
+--TODO: check sets of paths that would be interpreted differently between unix
+-- and windows, ie case-sensitive or insensitive. Things that might clash, or
+-- conversely be distinguished.
+
+--TODO: use the tar path checks on all the above paths
+
+-- | Check that the package declares the version in the @\"cabal-version\"@
+-- field correctly.
+--
+checkCabalVersion :: PackageDescription -> [PackageCheck]
+checkCabalVersion pkg =
+ catMaybes [
+
+ -- check syntax of cabal-version field
+ check (specVersion pkg >= Version [1,10] []
+ && not simpleSpecVersionRangeSyntax) $
+ PackageBuildWarning $
+ "Packages relying on Cabal 1.10 or later must only specify a "
+ ++ "version range of the form 'cabal-version: >= x.y'. Use "
+ ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'."
+
+ -- check syntax of cabal-version field
+ , check (specVersion pkg < Version [1,9] []
+ && not simpleSpecVersionRangeSyntax) $
+ PackageDistSuspicious $
+ "It is recommended that the 'cabal-version' field only specify a "
+ ++ "version range of the form '>= x.y'. Use "
+ ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'. "
+ ++ "Tools based on Cabal 1.10 and later will ignore upper bounds."
+
+ -- check syntax of cabal-version field
+ , checkVersion [1,12] simpleSpecVersionSyntax $
+ PackageBuildWarning $
+ "With Cabal 1.10 or earlier, the 'cabal-version' field must use "
+ ++ "range syntax rather than a simple version number. Use "
+ ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'."
+
+ -- check use of test suite sections
+ , checkVersion [1,8] (not (null $ testSuites pkg)) $
+ PackageDistInexcusable $
+ "The 'test-suite' section is new in Cabal 1.10. "
+ ++ "Unfortunately it messes up the parser in older Cabal versions "
+ ++ "so you must specify at least 'cabal-version: >= 1.8', but note "
+ ++ "that only Cabal 1.10 and later can actually run such test suites."
+
+ -- check use of default-language field
+ -- note that we do not need to do an equivalent check for the
+ -- other-language field since that one does not change behaviour
+ , checkVersion [1,10] (any isJust (buildInfoField defaultLanguage)) $
+ PackageBuildWarning $
+ "To use the 'default-language' field the package needs to specify "
+ ++ "at least 'cabal-version: >= 1.10'."
+
+ , check (specVersion pkg >= Version [1,10] []
+ && (any isNothing (buildInfoField defaultLanguage))) $
+ PackageBuildWarning $
+ "Packages using 'cabal-version: >= 1.10' must specify the "
+ ++ "'default-language' field for each component (e.g. Haskell98 or "
+ ++ "Haskell2010). If a component uses different languages in "
+ ++ "different modules then list the other ones in the "
+ ++ "'other-languages' field."
+
+ -- check use of default-extensions field
+ -- don't need to do the equivalent check for other-extensions
+ , checkVersion [1,10] (any (not . null) (buildInfoField defaultExtensions)) $
+ PackageBuildWarning $
+ "To use the 'default-extensions' field the package needs to specify "
+ ++ "at least 'cabal-version: >= 1.10'."
+
+ -- check use of extensions field
+ , check (specVersion pkg >= Version [1,10] []
+ && (any (not . null) (buildInfoField oldExtensions))) $
+ PackageBuildWarning $
+ "For packages using 'cabal-version: >= 1.10' the 'extensions' "
+ ++ "field is deprecated. The new 'default-extensions' field lists "
+ ++ "extensions that are used in all modules in the component, while "
+ ++ "the 'other-extensions' field lists extensions that are used in "
+ ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma."
+
+ -- check use of "foo (>= 1.0 && < 1.4) || >=1.8 " version-range syntax
+ , checkVersion [1,8] (not (null versionRangeExpressions)) $
+ PackageDistInexcusable $
+ "The package uses full version-range expressions "
+ ++ "in a 'build-depends' field: "
+ ++ commaSep (map displayRawDependency versionRangeExpressions)
+ ++ ". To use this new syntax the package needs to specify at least "
+ ++ "'cabal-version: >= 1.8'. Alternatively, if broader compatibility "
+ ++ "is important, then convert to conjunctive normal form, and use "
+ ++ "multiple 'build-depends:' lines, one conjunct per line."
+
+ -- check use of "build-depends: foo == 1.*" syntax
+ , checkVersion [1,6] (not (null depsUsingWildcardSyntax)) $
+ PackageDistInexcusable $
+ "The package uses wildcard syntax in the 'build-depends' field: "
+ ++ commaSep (map display depsUsingWildcardSyntax)
+ ++ ". To use this new syntax the package need to specify at least "
+ ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatability "
+ ++ "is important then use: " ++ commaSep
+ [ display (Dependency name (eliminateWildcardSyntax versionRange))
+ | Dependency name versionRange <- depsUsingWildcardSyntax ]
+
+ -- check use of "tested-with: GHC (>= 1.0 && < 1.4) || >=1.8 " syntax
+ , checkVersion [1,8] (not (null testedWithVersionRangeExpressions)) $
+ PackageDistInexcusable $
+ "The package uses full version-range expressions "
+ ++ "in a 'tested-with' field: "
+ ++ commaSep (map displayRawDependency testedWithVersionRangeExpressions)
+ ++ ". To use this new syntax the package needs to specify at least "
+ ++ "'cabal-version: >= 1.8'."
+
+ -- check use of "tested-with: GHC == 6.12.*" syntax
+ , checkVersion [1,6] (not (null testedWithUsingWildcardSyntax)) $
+ PackageDistInexcusable $
+ "The package uses wildcard syntax in the 'tested-with' field: "
+ ++ commaSep (map display testedWithUsingWildcardSyntax)
+ ++ ". To use this new syntax the package need to specify at least "
+ ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatability "
+ ++ "is important then use: " ++ commaSep
+ [ display (Dependency name (eliminateWildcardSyntax versionRange))
+ | Dependency name versionRange <- testedWithUsingWildcardSyntax ]
+
+ -- check use of "data-files: data/*.txt" syntax
+ , checkVersion [1,6] (not (null dataFilesUsingGlobSyntax)) $
+ PackageDistInexcusable $
+ "Using wildcards like "
+ ++ commaSep (map quote $ take 3 dataFilesUsingGlobSyntax)
+ ++ " in the 'data-files' field requires 'cabal-version: >= 1.6'. "
+ ++ "Alternatively if you require compatability with earlier Cabal "
+ ++ "versions then list all the files explicitly."
+
+ -- check use of "extra-source-files: mk/*.in" syntax
+ , checkVersion [1,6] (not (null extraSrcFilesUsingGlobSyntax)) $
+ PackageDistInexcusable $
+ "Using wildcards like "
+ ++ commaSep (map quote $ take 3 extraSrcFilesUsingGlobSyntax)
+ ++ " in the 'extra-source-files' field requires "
+ ++ "'cabal-version: >= 1.6'. Alternatively if you require "
+ ++ "compatability with earlier Cabal versions then list all the files "
+ ++ "explicitly."
+
+ -- check use of "source-repository" section
+ , checkVersion [1,6] (not (null (sourceRepos pkg))) $
+ PackageDistInexcusable $
+ "The 'source-repository' section is new in Cabal 1.6. "
+ ++ "Unfortunately it messes up the parser in earlier Cabal versions "
+ ++ "so you need to specify 'cabal-version: >= 1.6'."
+
+ -- check for new licenses
+ , checkVersion [1,4] (license pkg `notElem` compatLicenses) $
+ PackageDistInexcusable $
+ "Unfortunately the license " ++ quote (display (license pkg))
+ ++ " messes up the parser in earlier Cabal versions so you need to "
+ ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require "
+ ++ "compatability with earlier Cabal versions then use 'OtherLicense'."
+
+ -- check for new language extensions
+ , checkVersion [1,2,3] (not (null mentionedExtensionsThatNeedCabal12)) $
+ PackageDistInexcusable $
+ "Unfortunately the language extensions "
+ ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal12)
+ ++ " break the parser in earlier Cabal versions so you need to "
+ ++ "specify 'cabal-version: >= 1.2.3'. Alternatively if you require "
+ ++ "compatability with earlier Cabal versions then you may be able to "
+ ++ "use an equivalent compiler-specific flag."
+
+ , checkVersion [1,4] (not (null mentionedExtensionsThatNeedCabal14)) $
+ PackageDistInexcusable $
+ "Unfortunately the language extensions "
+ ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal14)
+ ++ " break the parser in earlier Cabal versions so you need to "
+ ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require "
+ ++ "compatability with earlier Cabal versions then you may be able to "
+ ++ "use an equivalent compiler-specific flag."
+ ]
+ where
+ -- Perform a check on packages that use a version of the spec less than
+ -- the version given. This is for cases where a new Cabal version adds
+ -- a new feature and we want to check that it is not used prior to that
+ -- version.
+ checkVersion :: [Int] -> Bool -> PackageCheck -> Maybe PackageCheck
+ checkVersion ver cond pc
+ | specVersion pkg >= Version ver [] = Nothing
+ | otherwise = check cond pc
+
+ buildInfoField field = map field (allBuildInfo pkg)
+ dataFilesUsingGlobSyntax = filter usesGlobSyntax (dataFiles pkg)
+ extraSrcFilesUsingGlobSyntax = filter usesGlobSyntax (extraSrcFiles pkg)
+ usesGlobSyntax str = case parseFileGlob str of
+ Just (FileGlob _ _) -> True
+ _ -> False
+
+ versionRangeExpressions =
+ [ dep | dep@(Dependency _ vr) <- buildDepends pkg
+ , usesNewVersionRangeSyntax vr ]
+
+ testedWithVersionRangeExpressions =
+ [ Dependency (PackageName (display compiler)) vr
+ | (compiler, vr) <- testedWith pkg
+ , usesNewVersionRangeSyntax vr ]
+
+ simpleSpecVersionRangeSyntax =
+ either (const True)
+ (foldVersionRange'
+ True
+ (\_ -> False)
+ (\_ -> False) (\_ -> False)
+ (\_ -> True) -- >=
+ (\_ -> False)
+ (\_ _ -> False)
+ (\_ _ -> False) (\_ _ -> False)
+ id)
+ (specVersionRaw pkg)
+
+ -- is the cabal-version field a simple version number, rather than a range
+ simpleSpecVersionSyntax =
+ either (const True) (const False) (specVersionRaw pkg)
+
+ usesNewVersionRangeSyntax :: VersionRange -> Bool
+ usesNewVersionRangeSyntax =
+ (> 2) -- uses the new syntax if depth is more than 2
+ . foldVersionRange'
+ (1 :: Int)
+ (const 1)
+ (const 1) (const 1)
+ (const 1) (const 1)
+ (const (const 1))
+ (+) (+)
+ (const 3) -- uses new ()'s syntax
+
+ depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg
+ , usesWildcardSyntax vr ]
+
+ testedWithUsingWildcardSyntax = [ Dependency (PackageName (display compiler)) vr
+ | (compiler, vr) <- testedWith pkg
+ , usesWildcardSyntax vr ]
+
+ usesWildcardSyntax :: VersionRange -> Bool
+ usesWildcardSyntax =
+ foldVersionRange'
+ False (const False)
+ (const False) (const False)
+ (const False) (const False)
+ (\_ _ -> True) -- the wildcard case
+ (||) (||) id
+
+ eliminateWildcardSyntax =
+ foldVersionRange'
+ anyVersion thisVersion
+ laterVersion earlierVersion
+ orLaterVersion orEarlierVersion
+ (\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v'))
+ intersectVersionRanges unionVersionRanges id
+
+ compatLicenses = [ GPL Nothing, LGPL Nothing, BSD3, BSD4
+ , PublicDomain, AllRightsReserved, OtherLicense ]
+
+ mentionedExtensions = [ ext | bi <- allBuildInfo pkg
+ , ext <- allExtensions bi ]
+ mentionedExtensionsThatNeedCabal12 =
+ nub (filter (`elem` compatExtensionsExtra) mentionedExtensions)
+
+ -- As of Cabal-1.4 we can add new extensions without worrying about
+ -- breaking old versions of cabal.
+ mentionedExtensionsThatNeedCabal14 =
+ nub (filter (`notElem` compatExtensions) mentionedExtensions)
+
+ -- The known extensions in Cabal-1.2.3
+ compatExtensions =
+ map EnableExtension
+ [ OverlappingInstances, UndecidableInstances, IncoherentInstances
+ , RecursiveDo, ParallelListComp, MultiParamTypeClasses
+ , FunctionalDependencies, Rank2Types
+ , RankNTypes, PolymorphicComponents, ExistentialQuantification
+ , ScopedTypeVariables, ImplicitParams, FlexibleContexts
+ , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns
+ , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface
+ , Arrows, Generics, NamedFieldPuns, PatternGuards
+ , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms
+ , HereDocuments] ++
+ map DisableExtension
+ [MonomorphismRestriction, ImplicitPrelude] ++
+ compatExtensionsExtra
+
+ -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6
+ -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8)
+ compatExtensionsExtra =
+ map EnableExtension
+ [ KindSignatures, MagicHash, TypeFamilies, StandaloneDeriving
+ , UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms
+ , TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields
+ , OverloadedStrings, GADTs, RelaxedPolyRec
+ , ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable
+ , ConstrainedClassMethods
+ ] ++
+ map DisableExtension
+ [MonoPatBinds]
+
+-- | A variation on the normal 'Text' instance, shows any ()'s in the original
+-- textual syntax. We need to show these otherwise it's confusing to users when
+-- we complain of their presense but do not pretty print them!
+--
+displayRawVersionRange :: VersionRange -> String
+displayRawVersionRange =
+ Disp.render
+ . fst
+ . foldVersionRange' -- precedence:
+ -- All the same as the usual pretty printer, except for the parens
+ ( Disp.text "-any" , 0 :: Int)
+ (\v -> (Disp.text "==" <> disp v , 0))
+ (\v -> (Disp.char '>' <> disp v , 0))
+ (\v -> (Disp.char '<' <> disp v , 0))
+ (\v -> (Disp.text ">=" <> disp v , 0))
+ (\v -> (Disp.text "<=" <> disp v , 0))
+ (\v _ -> (Disp.text "==" <> dispWild v , 0))
+ (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2))
+ (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1))
+ (\(r, _ ) -> (Disp.parens r, 0)) -- parens
+
+ where
+ dispWild (Version b _) =
+ Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b))
+ <> Disp.text ".*"
+ punct p p' | p < p' = Disp.parens
+ | otherwise = id
+
+displayRawDependency :: Dependency -> String
+displayRawDependency (Dependency pkg vr) =
+ display pkg ++ " " ++ displayRawVersionRange vr
+
+
+-- ------------------------------------------------------------
+-- * Checks on the GenericPackageDescription
+-- ------------------------------------------------------------
+
+-- | Check the build-depends fields for any weirdness or bad practise.
+--
+checkPackageVersions :: GenericPackageDescription -> [PackageCheck]
+checkPackageVersions pkg =
+ catMaybes [
+
+ -- Check that the version of base is bounded above.
+ -- For example this bans "build-depends: base >= 3".
+ -- It should probably be "build-depends: base >= 3 && < 4"
+ -- which is the same as "build-depends: base == 3.*"
+ check (not (boundedAbove baseDependency)) $
+ PackageDistInexcusable $
+ "The dependency 'build-depends: base' does not specify an upper "
+ ++ "bound on the version number. Each major release of the 'base' "
+ ++ "package changes the API in various ways and most packages will "
+ ++ "need some changes to compile with it. The recommended practise "
+ ++ "is to specify an upper bound on the version of the 'base' "
+ ++ "package. This ensures your package will continue to build when a "
+ ++ "new major version of the 'base' package is released. If you are "
+ ++ "not sure what upper bound to use then use the next major "
+ ++ "version. For example if you have tested your package with 'base' "
+ ++ "version 2 and 3 then use 'build-depends: base >= 2 && < 4'."
+
+ ]
+ where
+ -- TODO: What we really want to do is test if there exists any
+ -- configuration in which the base version is unboudned above.
+ -- However that's a bit tricky because there are many possible
+ -- configurations. As a cheap easy and safe approximation we will
+ -- pick a single "typical" configuration and check if that has an
+ -- open upper bound. To get a typical configuration we finalise
+ -- using no package index and the current platform.
+ finalised = finalizePackageDescription
+ [] (const True) buildPlatform
+ (CompilerId buildCompilerFlavor (Version [] []))
+ [] pkg
+ baseDependency = case finalised of
+ Right (pkg', _) | not (null baseDeps) ->
+ foldr intersectVersionRanges anyVersion baseDeps
+ where
+ baseDeps =
+ [ vr | Dependency (PackageName "base") vr <- buildDepends pkg' ]
+
+ -- Just in case finalizePackageDescription fails for any reason,
+ -- or if the package doesn't depend on the base package at all,
+ -- then we will just skip the check, since boundedAbove noVersion = True
+ _ -> noVersion
+
+ boundedAbove :: VersionRange -> Bool
+ boundedAbove vr = case asVersionIntervals vr of
+ [] -> True -- this is the inconsistent version range.
+ intervals -> case last intervals of
+ (_, UpperBound _ _) -> True
+ (_, NoUpperBound ) -> False
+
+
+checkConditionals :: GenericPackageDescription -> [PackageCheck]
+checkConditionals pkg =
+ catMaybes [
+
+ check (not $ null unknownOSs) $
+ PackageDistInexcusable $
+ "Unknown operating system name "
+ ++ commaSep (map quote unknownOSs)
+
+ , check (not $ null unknownArches) $
+ PackageDistInexcusable $
+ "Unknown architecture name "
+ ++ commaSep (map quote unknownArches)
+
+ , check (not $ null unknownImpls) $
+ PackageDistInexcusable $
+ "Unknown compiler name "
+ ++ commaSep (map quote unknownImpls)
+ ]
+ where
+ unknownOSs = [ os | OS (OtherOS os) <- conditions ]
+ unknownArches = [ arch | Arch (OtherArch arch) <- conditions ]
+ unknownImpls = [ impl | Impl (OtherCompiler impl) _ <- conditions ]
+ conditions = maybe [] freeVars (condLibrary pkg)
+ ++ concatMap (freeVars . snd) (condExecutables pkg)
+ freeVars (CondNode _ _ ifs) = concatMap compfv ifs
+ compfv (c, ct, mct) = condfv c ++ freeVars ct ++ maybe [] freeVars mct
+ condfv c = case c of
+ Var v -> [v]
+ Lit _ -> []
+ CNot c1 -> condfv c1
+ COr c1 c2 -> condfv c1 ++ condfv c2
+ CAnd c1 c2 -> condfv c1 ++ condfv c2
+
+-- ------------------------------------------------------------
+-- * Checks involving files in the package
+-- ------------------------------------------------------------
+
+-- | Sanity check things that requires IO. It looks at the files in the
+-- package and expects to find the package unpacked in at the given filepath.
+--
+checkPackageFiles :: PackageDescription -> FilePath -> IO [PackageCheck]
+checkPackageFiles pkg root = checkPackageContent checkFilesIO pkg
+ where
+ checkFilesIO = CheckPackageContentOps {
+ doesFileExist = System.doesFileExist . relative,
+ doesDirectoryExist = System.doesDirectoryExist . relative
+ }
+ relative path = root </> path
+
+-- | A record of operations needed to check the contents of packages.
+-- Used by 'checkPackageContent'.
+--
+data CheckPackageContentOps m = CheckPackageContentOps {
+ doesFileExist :: FilePath -> m Bool,
+ doesDirectoryExist :: FilePath -> m Bool
+ }
+
+-- | Sanity check things that requires looking at files in the package.
+-- This is a generalised version of 'checkPackageFiles' that can work in any
+-- monad for which you can provide 'CheckPackageContentOps' operations.
+--
+-- The point of this extra generality is to allow doing checks in some virtual
+-- file system, for example a tarball in memory.
+--
+checkPackageContent :: Monad m => CheckPackageContentOps m
+ -> PackageDescription
+ -> m [PackageCheck]
+checkPackageContent ops pkg = do
+ licenseError <- checkLicenseExists ops pkg
+ setupError <- checkSetupExists ops pkg
+ configureError <- checkConfigureExists ops pkg
+ localPathErrors <- checkLocalPathsExist ops pkg
+ vcsLocation <- checkMissingVcsInfo ops pkg
+
+ return $ catMaybes [licenseError, setupError, configureError]
+ ++ localPathErrors
+ ++ vcsLocation
+
+checkLicenseExists :: Monad m => CheckPackageContentOps m
+ -> PackageDescription
+ -> m (Maybe PackageCheck)
+checkLicenseExists ops pkg
+ | null (licenseFile pkg) = return Nothing
+ | otherwise = do
+ exists <- doesFileExist ops file
+ return $ check (not exists) $
+ PackageBuildWarning $
+ "The 'license-file' field refers to the file " ++ quote file
+ ++ " which does not exist."
+
+ where
+ file = licenseFile pkg
+
+checkSetupExists :: Monad m => CheckPackageContentOps m
+ -> PackageDescription
+ -> m (Maybe PackageCheck)
+checkSetupExists ops _ = do
+ hsexists <- doesFileExist ops "Setup.hs"
+ lhsexists <- doesFileExist ops "Setup.lhs"
+ return $ check (not hsexists && not lhsexists) $
+ PackageDistInexcusable $
+ "The package is missing a Setup.hs or Setup.lhs script."
+
+checkConfigureExists :: Monad m => CheckPackageContentOps m
+ -> PackageDescription
+ -> m (Maybe PackageCheck)
+checkConfigureExists ops PackageDescription { buildType = Just Configure } = do
+ exists <- doesFileExist ops "configure"
+ return $ check (not exists) $
+ PackageBuildWarning $
+ "The 'build-type' is 'Configure' but there is no 'configure' script."
+checkConfigureExists _ _ = return Nothing
+
+checkLocalPathsExist :: Monad m => CheckPackageContentOps m
+ -> PackageDescription
+ -> m [PackageCheck]
+checkLocalPathsExist ops pkg = do
+ let dirs = [ (dir, kind)
+ | bi <- allBuildInfo pkg
+ , (dir, kind) <-
+ [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ]
+ ++ [ (dir, "include-dirs") | dir <- includeDirs bi ]
+ ++ [ (dir, "hs-source-dirs") | dir <- hsSourceDirs bi ]
+ , isRelative dir ]
+ missing <- filterM (liftM not . doesDirectoryExist ops . fst) dirs
+ return [ PackageBuildWarning {
+ explanation = quote (kind ++ ": " ++ dir)
+ ++ " directory does not exist."
+ }
+ | (dir, kind) <- missing ]
+
+checkMissingVcsInfo :: Monad m => CheckPackageContentOps m
+ -> PackageDescription
+ -> m [PackageCheck]
+checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do
+ vcsInUse <- liftM or $ mapM (doesDirectoryExist ops) repoDirnames
+ if vcsInUse
+ then return [ PackageDistSuspicious message ]
+ else return []
+ where
+ repoDirnames = [ dirname | repo <- knownRepoTypes
+ , dirname <- repoTypeDirname repo ]
+ message = "When distributing packages it is encouraged to specify source "
+ ++ "control information in the .cabal file using one or more "
+ ++ "'source-repository' sections. See the Cabal user guide for "
+ ++ "details."
+
+checkMissingVcsInfo _ _ = return []
+
+repoTypeDirname :: RepoType -> [FilePath]
+repoTypeDirname Darcs = ["_darcs"]
+repoTypeDirname Git = [".git"]
+repoTypeDirname SVN = [".svn"]
+repoTypeDirname CVS = ["CVS"]
+repoTypeDirname Mercurial = [".hg"]
+repoTypeDirname GnuArch = [".arch-params"]
+repoTypeDirname Bazaar = [".bzr"]
+repoTypeDirname Monotone = ["_MTN"]
+repoTypeDirname _ = []
+
+-- ------------------------------------------------------------
+-- * Checks involving files in the package
+-- ------------------------------------------------------------
+
+-- | Check the names of all files in a package for portability problems. This
+-- should be done for example when creating or validating a package tarball.
+--
+checkPackageFileNames :: [FilePath] -> [PackageCheck]
+checkPackageFileNames files =
+ (take 1 . catMaybes . map checkWindowsPath $ files)
+ ++ (take 1 . catMaybes . map checkTarPath $ files)
+ -- If we get any of these checks triggering then we're likely to get
+ -- many, and that's probably not helpful, so return at most one.
+
+checkWindowsPath :: FilePath -> Maybe PackageCheck
+checkWindowsPath path =
+ check (not $ FilePath.Windows.isValid path') $
+ PackageDistInexcusable $
+ "Unfortunately, the file " ++ quote path ++ " is not a valid file "
+ ++ "name on Windows which would cause portability problems for this "
+ ++ "package. Windows file names cannot contain any of the characters "
+ ++ "\":*?<>|\" and there are a few reserved names including \"aux\", "
+ ++ "\"nul\", \"con\", \"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"."
+ where
+ path' = ".\\" ++ path
+ -- force a relative name to catch invalid file names like "f:oo" which
+ -- otherwise parse as file "oo" in the current directory on the 'f' drive.
+
+-- | Check a file name is valid for the portable POSIX tar format.
+--
+-- The POSIX tar format has a restriction on the length of file names. It is
+-- unfortunately not a simple restriction like a maximum length. The exact
+-- restriction is that either the whole path be 100 characters or less, or it
+-- be possible to split the path on a directory separator such that the first
+-- part is 155 characters or less and the second part 100 characters or less.
+--
+checkTarPath :: FilePath -> Maybe PackageCheck
+checkTarPath path
+ | length path > 255 = Just longPath
+ | otherwise = case pack nameMax (reverse (splitPath path)) of
+ Left err -> Just err
+ Right [] -> Nothing
+ Right (first:rest) -> case pack prefixMax remainder of
+ Left err -> Just err
+ Right [] -> Nothing
+ Right (_:_) -> Just noSplit
+ where
+ -- drop the '/' between the name and prefix:
+ remainder = init first : rest
+
+ where
+ nameMax, prefixMax :: Int
+ nameMax = 100
+ prefixMax = 155
+
+ pack _ [] = Left emptyName
+ pack maxLen (c:cs)
+ | n > maxLen = Left longName
+ | otherwise = Right (pack' maxLen n cs)
+ where n = length c
+
+ pack' maxLen n (c:cs)
+ | n' <= maxLen = pack' maxLen n' cs
+ where n' = n + length c
+ pack' _ _ cs = cs
+
+ longPath = PackageDistInexcusable $
+ "The following file name is too long to store in a portable POSIX "
+ ++ "format tar archive. The maximum length is 255 ASCII characters.\n"
+ ++ "The file in question is:\n " ++ path
+ longName = PackageDistInexcusable $
+ "The following file name is too long to store in a portable POSIX "
+ ++ "format tar archive. The maximum length for the name part (including "
+ ++ "extension) is 100 ASCII characters. The maximum length for any "
+ ++ "individual directory component is 155.\n"
+ ++ "The file in question is:\n " ++ path
+ noSplit = PackageDistInexcusable $
+ "The following file name is too long to store in a portable POSIX "
+ ++ "format tar archive. While the total length is less than 255 ASCII "
+ ++ "characters, there are unfortunately further restrictions. It has to "
+ ++ "be possible to split the file path on a directory separator into "
+ ++ "two parts such that the first part fits in 155 characters or less "
+ ++ "and the second part fits in 100 characters or less. Basically you "
+ ++ "have to make the file name or directory names shorter, or you could "
+ ++ "split a long directory name into nested subdirectories with shorter "
+ ++ "names.\nThe file in question is:\n " ++ path
+ emptyName = PackageDistInexcusable $
+ "Encountered a file with an empty name, something is very wrong! "
+ ++ "Files with an empty name cannot be stored in a tar archive or in "
+ ++ "standard file systems."
+
+-- ------------------------------------------------------------
+-- * Utils
+-- ------------------------------------------------------------
+
+quote :: String -> String
+quote s = "'" ++ s ++ "'"
+
+commaSep :: [String] -> String
+commaSep = intercalate ", "
+
+dups :: Ord a => [a] -> [a]
+dups xs = [ x | (x:_:_) <- group (sort xs) ]
diff --git a/cabal/Cabal/Distribution/PackageDescription/Configuration.hs b/cabal/Cabal/Distribution/PackageDescription/Configuration.hs
new file mode 100644
index 0000000..19d5fda
--- /dev/null
+++ b/cabal/Cabal/Distribution/PackageDescription/Configuration.hs
@@ -0,0 +1,652 @@
+{-# OPTIONS -cpp #-}
+-- OPTIONS required for ghc-6.4.x compat, and must appear first
+{-# LANGUAGE CPP #-}
+-- -fno-warn-deprecations for use of Map.foldWithKey
+{-# OPTIONS_GHC -cpp -fno-warn-deprecations #-}
+{-# OPTIONS_NHC98 -cpp #-}
+{-# OPTIONS_JHC -fcpp #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Configuration
+-- Copyright : Thomas Schilling, 2007
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This is about the cabal configurations feature. It exports
+-- 'finalizePackageDescription' and 'flattenPackageDescription' which are
+-- functions for converting 'GenericPackageDescription's down to
+-- 'PackageDescription's. It has code for working with the tree of conditions
+-- and resolving or flattening conditions.
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.PackageDescription.Configuration (
+ finalizePackageDescription,
+ flattenPackageDescription,
+
+ -- Utils
+ parseCondition,
+ freeVars,
+ mapCondTree,
+ mapTreeData,
+ mapTreeConds,
+ mapTreeConstrs,
+ ) where
+
+import Distribution.Package
+ ( PackageName, Dependency(..) )
+import Distribution.PackageDescription
+ ( GenericPackageDescription(..), PackageDescription(..)
+ , Library(..), Executable(..), BuildInfo(..)
+ , Flag(..), FlagName(..), FlagAssignment
+ , Benchmark(..), CondTree(..), ConfVar(..), Condition(..)
+ , TestSuite(..) )
+import Distribution.Version
+ ( VersionRange, anyVersion, intersectVersionRanges, withinRange )
+import Distribution.Compiler
+ ( CompilerId(CompilerId) )
+import Distribution.System
+ ( Platform(..), OS, Arch )
+import Distribution.Simple.Utils
+ ( currentDir, lowercase )
+
+import Distribution.Text
+ ( Text(parse) )
+import Distribution.Compat.ReadP as ReadP hiding ( char )
+import Control.Arrow (first)
+import qualified Distribution.Compat.ReadP as ReadP ( char )
+
+import Data.Char ( isAlphaNum )
+import Data.Maybe ( catMaybes, maybeToList )
+import Data.Map ( Map, fromListWith, toList )
+import qualified Data.Map as Map
+import Data.Monoid
+
+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 606)
+import qualified Text.Read as R
+import qualified Text.Read.Lex as L
+#endif
+
+------------------------------------------------------------------------------
+
+-- | Simplify the condition and return its free variables.
+simplifyCondition :: Condition c
+ -> (c -> Either d Bool) -- ^ (partial) variable assignment
+ -> (Condition d, [d])
+simplifyCondition cond i = fv . walk $ cond
+ where
+ walk cnd = case cnd of
+ Var v -> either Var Lit (i v)
+ Lit b -> Lit b
+ CNot c -> case walk c of
+ Lit True -> Lit False
+ Lit False -> Lit True
+ c' -> CNot c'
+ COr c d -> case (walk c, walk d) of
+ (Lit False, d') -> d'
+ (Lit True, _) -> Lit True
+ (c', Lit False) -> c'
+ (_, Lit True) -> Lit True
+ (c',d') -> COr c' d'
+ CAnd c d -> case (walk c, walk d) of
+ (Lit False, _) -> Lit False
+ (Lit True, d') -> d'
+ (_, Lit False) -> Lit False
+ (c', Lit True) -> c'
+ (c',d') -> CAnd c' d'
+ -- gather free vars
+ fv c = (c, fv' c)
+ fv' c = case c of
+ Var v -> [v]
+ Lit _ -> []
+ CNot c' -> fv' c'
+ COr c1 c2 -> fv' c1 ++ fv' c2
+ CAnd c1 c2 -> fv' c1 ++ fv' c2
+
+-- | Simplify a configuration condition using the os and arch names. Returns
+-- the names of all the flags occurring in the condition.
+simplifyWithSysParams :: OS -> Arch -> CompilerId -> Condition ConfVar
+ -> (Condition FlagName, [FlagName])
+simplifyWithSysParams os arch (CompilerId comp compVer) cond = (cond', flags)
+ where
+ (cond', flags) = simplifyCondition cond interp
+ interp (OS os') = Right $ os' == os
+ interp (Arch arch') = Right $ arch' == arch
+ interp (Impl comp' vr) = Right $ comp' == comp
+ && compVer `withinRange` vr
+ interp (Flag f) = Left f
+
+-- TODO: Add instances and check
+--
+-- prop_sC_idempotent cond a o = cond' == cond''
+-- where
+-- cond' = simplifyCondition cond a o
+-- cond'' = simplifyCondition cond' a o
+--
+-- prop_sC_noLits cond a o = isLit res || not (hasLits res)
+-- where
+-- res = simplifyCondition cond a o
+-- hasLits (Lit _) = True
+-- hasLits (CNot c) = hasLits c
+-- hasLits (COr l r) = hasLits l || hasLits r
+-- hasLits (CAnd l r) = hasLits l || hasLits r
+-- hasLits _ = False
+--
+
+-- | Parse a configuration condition from a string.
+parseCondition :: ReadP r (Condition ConfVar)
+parseCondition = condOr
+ where
+ condOr = sepBy1 condAnd (oper "||") >>= return . foldl1 COr
+ condAnd = sepBy1 cond (oper "&&")>>= return . foldl1 CAnd
+ cond = sp >> (boolLiteral +++ inparens condOr +++ notCond +++ osCond
+ +++ archCond +++ flagCond +++ implCond )
+ inparens = between (ReadP.char '(' >> sp) (sp >> ReadP.char ')' >> sp)
+ notCond = ReadP.char '!' >> sp >> cond >>= return . CNot
+ osCond = string "os" >> sp >> inparens osIdent >>= return . Var
+ archCond = string "arch" >> sp >> inparens archIdent >>= return . Var
+ flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var
+ implCond = string "impl" >> sp >> inparens implIdent >>= return . Var
+ boolLiteral = fmap Lit parse
+ archIdent = fmap Arch parse
+ osIdent = fmap OS parse
+ flagIdent = fmap (Flag . FlagName . lowercase) (munch1 isIdentChar)
+ isIdentChar c = isAlphaNum c || c == '_' || c == '-'
+ oper s = sp >> string s >> sp
+ sp = skipSpaces
+ implIdent = do i <- parse
+ vr <- sp >> option anyVersion parse
+ return $ Impl i vr
+
+------------------------------------------------------------------------------
+
+mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w)
+ -> CondTree v c a -> CondTree w d b
+mapCondTree fa fc fcnd (CondNode a c ifs) =
+ CondNode (fa a) (fc c) (map g ifs)
+ where
+ g (cnd, t, me) = (fcnd cnd, mapCondTree fa fc fcnd t,
+ fmap (mapCondTree fa fc fcnd) me)
+
+mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a
+mapTreeConstrs f = mapCondTree id f id
+
+mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a
+mapTreeConds f = mapCondTree id id f
+
+mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b
+mapTreeData f = mapCondTree f id id
+
+-- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for
+-- clarity.
+data DepTestRslt d = DepOk | MissingDeps d
+
+instance Monoid d => Monoid (DepTestRslt d) where
+ mempty = DepOk
+ mappend DepOk x = x
+ mappend x DepOk = x
+ mappend (MissingDeps d) (MissingDeps d') = MissingDeps (d `mappend` d')
+
+
+data BT a = BTN a | BTB (BT a) (BT a) -- very simple binary tree
+
+
+-- | Try to find a flag assignment that satisfies the constaints of all trees.
+--
+-- Returns either the missing dependencies, or a tuple containing the
+-- resulting data, the associated dependencies, and the chosen flag
+-- assignments.
+--
+-- In case of failure, the _smallest_ number of of missing dependencies is
+-- returned. [TODO: Could also be specified with a function argument.]
+--
+-- TODO: The current algorithm is rather naive. A better approach would be to:
+--
+-- * Rule out possible paths, by taking a look at the associated dependencies.
+--
+-- * Infer the required values for the conditions of these paths, and
+-- calculate the required domains for the variables used in these
+-- conditions. Then picking a flag assignment would be linear (I guess).
+--
+-- This would require some sort of SAT solving, though, thus it's not
+-- implemented unless we really need it.
+--
+resolveWithFlags ::
+ [(FlagName,[Bool])]
+ -- ^ Domain for each flag name, will be tested in order.
+ -> OS -- ^ OS as returned by Distribution.System.buildOS
+ -> Arch -- ^ Arch as returned by Distribution.System.buildArch
+ -> CompilerId -- ^ Compiler flavour + version
+ -> [Dependency] -- ^ Additional constraints
+ -> [CondTree ConfVar [Dependency] PDTagged]
+ -> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function.
+ -> Either [Dependency] (TargetSet PDTagged, FlagAssignment)
+ -- ^ Either the missing dependencies (error case), or a pair of
+ -- (set of build targets with dependencies, chosen flag assignments)
+resolveWithFlags dom os arch impl constrs trees checkDeps =
+ case try dom [] of
+ Right r -> Right r
+ Left dbt -> Left $ findShortest dbt
+ where
+ extraConstrs = toDepMap constrs
+
+ -- simplify trees by (partially) evaluating all conditions and converting
+ -- dependencies to dependency maps.
+ simplifiedTrees = map ( mapTreeConstrs toDepMap -- convert to maps
+ . mapTreeConds (fst . simplifyWithSysParams os arch impl))
+ trees
+
+ -- @try@ recursively tries all possible flag assignments in the domain and
+ -- either succeeds or returns a binary tree with the missing dependencies
+ -- encountered in each run. Since the tree is constructed lazily, we
+ -- avoid some computation overhead in the successful case.
+ try [] flags =
+ let targetSet = TargetSet $ flip map simplifiedTrees $
+ -- apply additional constraints to all dependencies
+ first (`constrainBy` extraConstrs) .
+ simplifyCondTree (env flags)
+ deps = overallDependencies targetSet
+ in case checkDeps (fromDepMap deps) of
+ DepOk -> Right (targetSet, flags)
+ MissingDeps mds -> Left (BTN mds)
+
+ try ((n, vals):rest) flags =
+ tryAll $ map (\v -> try rest ((n, v):flags)) vals
+
+ tryAll = foldr mp mz
+
+ -- special version of `mplus' for our local purposes
+ mp (Left xs) (Left ys) = (Left (BTB xs ys))
+ mp (Left _) m@(Right _) = m
+ mp m@(Right _) _ = m
+
+ -- `mzero'
+ mz = Left (BTN [])
+
+ env flags flag = (maybe (Left flag) Right . lookup flag) flags
+
+ -- for the error case we inspect our lazy tree of missing dependencies and
+ -- pick the shortest list of missing dependencies
+ findShortest (BTN x) = x
+ findShortest (BTB lt rt) =
+ let l = findShortest lt
+ r = findShortest rt
+ in case (l,r) of
+ ([], xs) -> xs -- [] is too short
+ (xs, []) -> xs
+ ([x], _) -> [x] -- single elem is optimum
+ (_, [x]) -> [x]
+ (xs, ys) -> if lazyLengthCmp xs ys
+ then xs else ys
+ -- lazy variant of @\xs ys -> length xs <= length ys@
+ lazyLengthCmp [] _ = True
+ lazyLengthCmp _ [] = False
+ lazyLengthCmp (_:xs) (_:ys) = lazyLengthCmp xs ys
+
+-- | A map of dependencies. Newtyped since the default monoid instance is not
+-- appropriate. The monoid instance uses 'intersectVersionRanges'.
+newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName VersionRange }
+#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 606)
+ deriving (Show, Read)
+#else
+-- The Show/Read instance for Data.Map in ghc-6.4 is useless
+-- so we have to re-implement it here:
+instance Show DependencyMap where
+ showsPrec d (DependencyMap m) =
+ showParen (d > 10) (showString "DependencyMap" . shows (M.toList m))
+
+instance Read DependencyMap where
+ readPrec = parens $ R.prec 10 $ do
+ R.Ident "DependencyMap" <- R.lexP
+ xs <- R.readPrec
+ return (DependencyMap (M.fromList xs))
+ where parens :: R.ReadPrec a -> R.ReadPrec a
+ parens p = optional
+ where
+ optional = p R.+++ mandatory
+ mandatory = paren optional
+
+ paren :: R.ReadPrec a -> R.ReadPrec a
+ paren p = do L.Punc "(" <- R.lexP
+ x <- R.reset p
+ L.Punc ")" <- R.lexP
+ return x
+
+ readListPrec = R.readListPrecDefault
+#endif
+
+instance Monoid DependencyMap where
+ mempty = DependencyMap Map.empty
+ (DependencyMap a) `mappend` (DependencyMap b) =
+ DependencyMap (Map.unionWith intersectVersionRanges a b)
+
+toDepMap :: [Dependency] -> DependencyMap
+toDepMap ds =
+ DependencyMap $ fromListWith intersectVersionRanges [ (p,vr) | Dependency p vr <- ds ]
+
+fromDepMap :: DependencyMap -> [Dependency]
+fromDepMap m = [ Dependency p vr | (p,vr) <- toList (unDependencyMap m) ]
+
+simplifyCondTree :: (Monoid a, Monoid d) =>
+ (v -> Either v Bool)
+ -> CondTree v d a
+ -> (d, a)
+simplifyCondTree env (CondNode a d ifs) =
+ foldr mappend (d, a) $ catMaybes $ map simplifyIf ifs
+ where
+ simplifyIf (cnd, t, me) =
+ case simplifyCondition cnd env of
+ (Lit True, _) -> Just $ simplifyCondTree env t
+ (Lit False, _) -> fmap (simplifyCondTree env) me
+ _ -> error $ "Environment not defined for all free vars"
+
+-- | Flatten a CondTree. This will resolve the CondTree by taking all
+-- possible paths into account. Note that since branches represent exclusive
+-- choices this may not result in a \"sane\" result.
+ignoreConditions :: (Monoid a, Monoid c) => CondTree v c a -> (a, c)
+ignoreConditions (CondNode a c ifs) = (a, c) `mappend` mconcat (concatMap f ifs)
+ where f (_, t, me) = ignoreConditions t
+ : maybeToList (fmap ignoreConditions me)
+
+freeVars :: CondTree ConfVar c a -> [FlagName]
+freeVars t = [ f | Flag f <- freeVars' t ]
+ where
+ freeVars' (CondNode _ _ ifs) = concatMap compfv ifs
+ compfv (c, ct, mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct
+ condfv c = case c of
+ Var v -> [v]
+ Lit _ -> []
+ CNot c' -> condfv c'
+ COr c1 c2 -> condfv c1 ++ condfv c2
+ CAnd c1 c2 -> condfv c1 ++ condfv c2
+
+
+------------------------------------------------------------------------------
+
+-- | A set of targets with their package dependencies
+newtype TargetSet a = TargetSet [(DependencyMap, a)]
+
+-- | Combine the target-specific dependencies in a TargetSet to give the
+-- dependencies for the package as a whole.
+overallDependencies :: TargetSet PDTagged -> DependencyMap
+overallDependencies (TargetSet targets) = mconcat depss
+ where
+ (depss, _) = unzip $ filter (removeDisabledSections . snd) targets
+ removeDisabledSections :: PDTagged -> Bool
+ removeDisabledSections (Lib _) = True
+ removeDisabledSections (Exe _ _) = True
+ removeDisabledSections (Test _ t) = testEnabled t
+ removeDisabledSections (Bench _ b) = benchmarkEnabled b
+ removeDisabledSections PDNull = True
+
+-- Apply extra constraints to a dependency map.
+-- Combines dependencies where the result will only contain keys from the left
+-- (first) map. If a key also exists in the right map, both constraints will
+-- be intersected.
+constrainBy :: DependencyMap -- ^ Input map
+ -> DependencyMap -- ^ Extra constraints
+ -> DependencyMap
+constrainBy left extra =
+ DependencyMap $
+ Map.foldWithKey tightenConstraint (unDependencyMap left)
+ (unDependencyMap extra)
+ where tightenConstraint n c l =
+ case Map.lookup n l of
+ Nothing -> l
+ Just vr -> Map.insert n (intersectVersionRanges vr c) l
+
+-- | Collect up the targets in a TargetSet of tagged targets, storing the
+-- dependencies as we go.
+flattenTaggedTargets :: TargetSet PDTagged ->
+ (Maybe Library, [(String, Executable)], [(String, TestSuite)]
+ , [(String, Benchmark)])
+flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], [], []) targets
+ where
+ untag (_, Lib _) (Just _, _, _, _) = bug "Only one library expected"
+ untag (deps, Lib l) (Nothing, exes, tests, bms) =
+ (Just l', exes, tests, bms)
+ where
+ l' = l {
+ libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps }
+ }
+ untag (deps, Exe n e) (mlib, exes, tests, bms)
+ | any ((== n) . fst) exes = bug "Exe with same name found"
+ | any ((== n) . fst) tests = bug "Test sharing name of exe found"
+ | any ((== n) . fst) bms = bug "Benchmark sharing name of exe found"
+ | otherwise = (mlib, exes ++ [(n, e')], tests, bms)
+ where
+ e' = e {
+ buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps }
+ }
+ untag (deps, Test n t) (mlib, exes, tests, bms)
+ | any ((== n) . fst) tests = bug "Test with same name found"
+ | any ((== n) . fst) exes = bug "Test sharing name of exe found"
+ | any ((== n) . fst) bms = bug "Test sharing name of benchmark found"
+ | otherwise = (mlib, exes, tests ++ [(n, t')], bms)
+ where
+ t' = t {
+ testBuildInfo = (testBuildInfo t)
+ { targetBuildDepends = fromDepMap deps }
+ }
+ untag (deps, Bench n b) (mlib, exes, tests, bms)
+ | any ((== n) . fst) bms = bug "Benchmark with same name found"
+ | any ((== n) . fst) exes = bug "Benchmark sharing name of exe found"
+ | any ((== n) . fst) tests = bug "Benchmark sharing name of test found"
+ | otherwise = (mlib, exes, tests, bms ++ [(n, b')])
+ where
+ b' = b {
+ benchmarkBuildInfo = (benchmarkBuildInfo b)
+ { targetBuildDepends = fromDepMap deps }
+ }
+ untag (_, PDNull) x = x -- actually this should not happen, but let's be liberal
+
+
+------------------------------------------------------------------------------
+-- Convert GenericPackageDescription to PackageDescription
+--
+
+data PDTagged = Lib Library
+ | Exe String Executable
+ | Test String TestSuite
+ | Bench String Benchmark
+ | PDNull
+ deriving Show
+
+instance Monoid PDTagged where
+ mempty = PDNull
+ PDNull `mappend` x = x
+ x `mappend` PDNull = x
+ Lib l `mappend` Lib l' = Lib (l `mappend` l')
+ Exe n e `mappend` Exe n' e' | n == n' = Exe n (e `mappend` e')
+ Test n t `mappend` Test n' t' | n == n' = Test n (t `mappend` t')
+ Bench n b `mappend` Bench n' b' | n == n' = Bench n (b `mappend` b')
+ _ `mappend` _ = bug "Cannot combine incompatible tags"
+
+-- | Create a package description with all configurations resolved.
+--
+-- This function takes a `GenericPackageDescription` and several environment
+-- parameters and tries to generate `PackageDescription` by finding a flag
+-- assignment that result in satisfiable dependencies.
+--
+-- It takes as inputs a not necessarily complete specifications of flags
+-- assignments, an optional package index as well as platform parameters. If
+-- some flags are not assigned explicitly, this function will try to pick an
+-- assignment that causes this function to succeed. The package index is
+-- optional since on some platforms we cannot determine which packages have
+-- been installed before. When no package index is supplied, every dependency
+-- is assumed to be satisfiable, therefore all not explicitly assigned flags
+-- will get their default values.
+--
+-- This function will fail if it cannot find a flag assignment that leads to
+-- satisfiable dependencies. (It will not try alternative assignments for
+-- explicitly specified flags.) In case of failure it will return a /minimum/
+-- number of dependencies that could not be satisfied. On success, it will
+-- return the package description and the full flag assignment chosen.
+--
+finalizePackageDescription ::
+ FlagAssignment -- ^ Explicitly specified flag assignments
+ -> (Dependency -> Bool) -- ^ Is a given depenency satisfiable from the set of available packages?
+ -- If this is unknown then use True.
+ -> Platform -- ^ The 'Arch' and 'OS'
+ -> CompilerId -- ^ Compiler + Version
+ -> [Dependency] -- ^ Additional constraints
+ -> GenericPackageDescription
+ -> Either [Dependency]
+ (PackageDescription, FlagAssignment)
+ -- ^ Either missing dependencies or the resolved package
+ -- description along with the flag assignments chosen.
+finalizePackageDescription userflags satisfyDep (Platform arch os) impl constraints
+ (GenericPackageDescription pkg flags mlib0 exes0 tests0 bms0) =
+ case resolveFlags of
+ Right ((mlib, exes', tests', bms'), targetSet, flagVals) ->
+ Right ( pkg { library = mlib
+ , executables = exes'
+ , testSuites = tests'
+ , benchmarks = bms'
+ , buildDepends = fromDepMap (overallDependencies targetSet)
+ --TODO: we need to find a way to avoid pulling in deps
+ -- for non-buildable components. However cannot simply
+ -- filter at this stage, since if the package were not
+ -- available we would have failed already.
+ }
+ , flagVals )
+
+ Left missing -> Left missing
+ where
+ -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data
+ condTrees = maybeToList (fmap (mapTreeData Lib) mlib0 )
+ ++ map (\(name,tree) -> mapTreeData (Exe name) tree) exes0
+ ++ map (\(name,tree) -> mapTreeData (Test name) tree) tests0
+ ++ map (\(name,tree) -> mapTreeData (Bench name) tree) bms0
+
+ resolveFlags =
+ case resolveWithFlags flagChoices os arch impl constraints condTrees check of
+ Right (targetSet, fs) ->
+ let (mlib, exes, tests, bms) = flattenTaggedTargets targetSet in
+ Right ( (fmap libFillInDefaults mlib,
+ map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes,
+ map (\(n,t) -> (testFillInDefaults t) { testName = n }) tests,
+ map (\(n,b) -> (benchFillInDefaults b) { benchmarkName = n }) bms),
+ targetSet, fs)
+ Left missing -> Left missing
+
+ flagChoices = map (\(MkFlag n _ d manual) -> (n, d2c manual n d)) flags
+ d2c manual n b = case lookup n userflags of
+ Just val -> [val]
+ Nothing
+ | manual -> [b]
+ | otherwise -> [b, not b]
+ --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices
+ check ds = if all satisfyDep ds
+ then DepOk
+ else MissingDeps $ filter (not . satisfyDep) ds
+
+{-
+let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] [])
+let tst_p2 = (CondNode [1::Int] [Distribution.Package.Dependency "a" (EarlierVersion (Version [1,0] [])), Distribution.Package.Dependency "a" (LaterVersion (Version [2,0] []))] [])
+
+let p_index = Distribution.Simple.PackageIndex.fromList [Distribution.Package.PackageIdentifier "a" (Version [0,5] []), Distribution.Package.PackageIdentifier "a" (Version [2,5] [])]
+let look = not . null . Distribution.Simple.PackageIndex.lookupDependency p_index
+let looks ds = mconcat $ map (\d -> if look d then DepOk else MissingDeps [d]) ds
+resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p] looks ===> Right ...
+resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p2] looks ===> Left ...
+-}
+
+-- | Flatten a generic package description by ignoring all conditions and just
+-- join the field descriptors into on package description. Note, however,
+-- that this may lead to inconsistent field values, since all values are
+-- joined into one field, which may not be possible in the original package
+-- description, due to the use of exclusive choices (if ... else ...).
+--
+-- TODO: One particularly tricky case is defaulting. In the original package
+-- description, e.g., the source directory might either be the default or a
+-- certain, explicitly set path. Since defaults are filled in only after the
+-- package has been resolved and when no explicit value has been set, the
+-- default path will be missing from the package description returned by this
+-- function.
+flattenPackageDescription :: GenericPackageDescription -> PackageDescription
+flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0 tests0 bms0) =
+ pkg { library = mlib
+ , executables = reverse exes
+ , testSuites = reverse tests
+ , benchmarks = reverse bms
+ , buildDepends = ldeps ++ reverse edeps ++ reverse tdeps ++ reverse bdeps
+ }
+ where
+ (mlib, ldeps) = case mlib0 of
+ Just lib -> let (l,ds) = ignoreConditions lib in
+ (Just (libFillInDefaults l), ds)
+ Nothing -> (Nothing, [])
+ (exes, edeps) = foldr flattenExe ([],[]) exes0
+ (tests, tdeps) = foldr flattenTst ([],[]) tests0
+ (bms, bdeps) = foldr flattenBm ([],[]) bms0
+ flattenExe (n, t) (es, ds) =
+ let (e, ds') = ignoreConditions t in
+ ( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds )
+ flattenTst (n, t) (es, ds) =
+ let (e, ds') = ignoreConditions t in
+ ( (testFillInDefaults $ e { testName = n }) : es, ds' ++ ds )
+ flattenBm (n, t) (es, ds) =
+ let (e, ds') = ignoreConditions t in
+ ( (benchFillInDefaults $ e { benchmarkName = n }) : es, ds' ++ ds )
+
+-- This is in fact rather a hack. The original version just overrode the
+-- default values, however, when adding conditions we had to switch to a
+-- modifier-based approach. There, nothing is ever overwritten, but only
+-- joined together.
+--
+-- This is the cleanest way i could think of, that doesn't require
+-- changing all field parsing functions to return modifiers instead.
+libFillInDefaults :: Library -> Library
+libFillInDefaults lib@(Library { libBuildInfo = bi }) =
+ lib { libBuildInfo = biFillInDefaults bi }
+
+exeFillInDefaults :: Executable -> Executable
+exeFillInDefaults exe@(Executable { buildInfo = bi }) =
+ exe { buildInfo = biFillInDefaults bi }
+
+testFillInDefaults :: TestSuite -> TestSuite
+testFillInDefaults tst@(TestSuite { testBuildInfo = bi }) =
+ tst { testBuildInfo = biFillInDefaults bi }
+
+benchFillInDefaults :: Benchmark -> Benchmark
+benchFillInDefaults bm@(Benchmark { benchmarkBuildInfo = bi }) =
+ bm { benchmarkBuildInfo = biFillInDefaults bi }
+
+biFillInDefaults :: BuildInfo -> BuildInfo
+biFillInDefaults bi =
+ if null (hsSourceDirs bi)
+ then bi { hsSourceDirs = [currentDir] }
+ else bi
+
+bug :: String -> a
+bug msg = error $ msg ++ ". Consider this a bug."
diff --git a/cabal/Cabal/Distribution/PackageDescription/Parse.hs b/cabal/Cabal/Distribution/PackageDescription/Parse.hs
new file mode 100644
index 0000000..fe85990
--- /dev/null
+++ b/cabal/Cabal/Distribution/PackageDescription/Parse.hs
@@ -0,0 +1,1205 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.PackageDescription.Parse
+-- Copyright : Isaac Jones 2003-2005
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This defined parsers and partial pretty printers for the @.cabal@ format.
+-- Some of the complexity in this module is due to the fact that we have to be
+-- backwards compatible with old @.cabal@ files, so there's code to translate
+-- into the newer structure.
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.PackageDescription.Parse (
+ -- * Package descriptions
+ readPackageDescription,
+ writePackageDescription,
+ parsePackageDescription,
+ showPackageDescription,
+
+ -- ** Parsing
+ ParseResult(..),
+ FieldDescr(..),
+ LineNo,
+
+ -- ** Supplementary build information
+ readHookedBuildInfo,
+ parseHookedBuildInfo,
+ writeHookedBuildInfo,
+ showHookedBuildInfo,
+
+ pkgDescrFieldDescrs,
+ libFieldDescrs,
+ executableFieldDescrs,
+ binfoFieldDescrs,
+ sourceRepoFieldDescrs,
+ testSuiteFieldDescrs,
+ flagFieldDescrs
+ ) where
+
+import Data.Char (isSpace)
+import Data.Maybe (listToMaybe, isJust)
+import Data.Monoid ( Monoid(..) )
+import Data.List (nub, unfoldr, partition, (\\))
+import Control.Monad (liftM, foldM, when, unless)
+import System.Directory (doesFileExist)
+import qualified Data.ByteString.Lazy.Char8 as BS.Char8
+
+import Distribution.Text
+ ( Text(disp, parse), display, simpleParse )
+import Distribution.Compat.ReadP
+ ((+++), option)
+import Text.PrettyPrint
+
+import Distribution.ParseUtils hiding (parseFields)
+import Distribution.PackageDescription
+import Distribution.Package
+ ( PackageIdentifier(..), Dependency(..), packageName, packageVersion )
+import Distribution.ModuleName ( ModuleName )
+import Distribution.Version
+ ( Version(Version), orLaterVersion
+ , LowerBound(..), asVersionIntervals )
+import Distribution.Verbosity (Verbosity)
+import Distribution.Compiler (CompilerFlavor(..))
+import Distribution.PackageDescription.Configuration (parseCondition, freeVars)
+import Distribution.Simple.Utils
+ ( die, dieWithLocation, warn, intercalate, lowercase, cabalVersion
+ , withFileContents, withUTF8FileContents
+ , writeFileAtomic, writeUTF8File )
+
+
+-- -----------------------------------------------------------------------------
+-- The PackageDescription type
+
+pkgDescrFieldDescrs :: [FieldDescr PackageDescription]
+pkgDescrFieldDescrs =
+ [ simpleField "name"
+ disp parse
+ packageName (\name pkg -> pkg{package=(package pkg){pkgName=name}})
+ , simpleField "version"
+ disp parse
+ packageVersion (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}})
+ , simpleField "cabal-version"
+ (either disp disp) (liftM Left parse +++ liftM Right parse)
+ specVersionRaw (\v pkg -> pkg{specVersionRaw=v})
+ , simpleField "build-type"
+ (maybe empty disp) (fmap Just parse)
+ buildType (\t pkg -> pkg{buildType=t})
+ , simpleField "license"
+ disp parseLicenseQ
+ license (\l pkg -> pkg{license=l})
+ , simpleField "license-file"
+ showFilePath parseFilePathQ
+ licenseFile (\l pkg -> pkg{licenseFile=l})
+ , simpleField "copyright"
+ showFreeText parseFreeText
+ copyright (\val pkg -> pkg{copyright=val})
+ , simpleField "maintainer"
+ showFreeText parseFreeText
+ maintainer (\val pkg -> pkg{maintainer=val})
+ , commaListField "build-depends"
+ disp parse
+ buildDepends (\xs pkg -> pkg{buildDepends=xs})
+ , simpleField "stability"
+ showFreeText parseFreeText
+ stability (\val pkg -> pkg{stability=val})
+ , simpleField "homepage"
+ showFreeText parseFreeText
+ homepage (\val pkg -> pkg{homepage=val})
+ , simpleField "package-url"
+ showFreeText parseFreeText
+ pkgUrl (\val pkg -> pkg{pkgUrl=val})
+ , simpleField "bug-reports"
+ showFreeText parseFreeText
+ bugReports (\val pkg -> pkg{bugReports=val})
+ , simpleField "synopsis"
+ showFreeText parseFreeText
+ synopsis (\val pkg -> pkg{synopsis=val})
+ , simpleField "description"
+ showFreeText parseFreeText
+ description (\val pkg -> pkg{description=val})
+ , simpleField "category"
+ showFreeText parseFreeText
+ category (\val pkg -> pkg{category=val})
+ , simpleField "author"
+ showFreeText parseFreeText
+ author (\val pkg -> pkg{author=val})
+ , listField "tested-with"
+ showTestedWith parseTestedWithQ
+ testedWith (\val pkg -> pkg{testedWith=val})
+ , listField "data-files"
+ showFilePath parseFilePathQ
+ dataFiles (\val pkg -> pkg{dataFiles=val})
+ , simpleField "data-dir"
+ showFilePath parseFilePathQ
+ dataDir (\val pkg -> pkg{dataDir=val})
+ , listField "extra-source-files"
+ showFilePath parseFilePathQ
+ extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val})
+ , listField "extra-tmp-files"
+ showFilePath parseFilePathQ
+ extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val})
+ ]
+
+-- | Store any fields beginning with "x-" in the customFields field of
+-- a PackageDescription. All other fields will generate a warning.
+storeXFieldsPD :: UnrecFieldParser PackageDescription
+storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD =
+ (customFieldsPD pkg) ++ [(f,val)]}
+storeXFieldsPD _ _ = Nothing
+
+-- ---------------------------------------------------------------------------
+-- The Library type
+
+libFieldDescrs :: [FieldDescr Library]
+libFieldDescrs =
+ [ listField "exposed-modules" disp parseModuleNameQ
+ exposedModules (\mods lib -> lib{exposedModules=mods})
+
+ , boolField "exposed"
+ libExposed (\val lib -> lib{libExposed=val})
+ ] ++ map biToLib binfoFieldDescrs
+ where biToLib = liftField libBuildInfo (\bi lib -> lib{libBuildInfo=bi})
+
+storeXFieldsLib :: UnrecFieldParser Library
+storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) =
+ Just $ l {libBuildInfo = bi{ customFieldsBI = (customFieldsBI bi) ++ [(f,val)]}}
+storeXFieldsLib _ _ = Nothing
+
+-- ---------------------------------------------------------------------------
+-- The Executable type
+
+
+executableFieldDescrs :: [FieldDescr Executable]
+executableFieldDescrs =
+ [ -- note ordering: configuration must come first, for
+ -- showPackageDescription.
+ simpleField "executable"
+ showToken parseTokenQ
+ exeName (\xs exe -> exe{exeName=xs})
+ , simpleField "main-is"
+ showFilePath parseFilePathQ
+ modulePath (\xs exe -> exe{modulePath=xs})
+ ]
+ ++ map biToExe binfoFieldDescrs
+ where biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi})
+
+storeXFieldsExe :: UnrecFieldParser Executable
+storeXFieldsExe (f@('x':'-':_), val) e@(Executable { buildInfo = bi }) =
+ Just $ e {buildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}
+storeXFieldsExe _ _ = Nothing
+
+-- ---------------------------------------------------------------------------
+-- The TestSuite type
+
+-- | An intermediate type just used for parsing the test-suite stanza.
+-- After validation it is converted into the proper 'TestSuite' type.
+data TestSuiteStanza = TestSuiteStanza {
+ testStanzaTestType :: Maybe TestType,
+ testStanzaMainIs :: Maybe FilePath,
+ testStanzaTestModule :: Maybe ModuleName,
+ testStanzaBuildInfo :: BuildInfo
+ }
+
+emptyTestStanza :: TestSuiteStanza
+emptyTestStanza = TestSuiteStanza Nothing Nothing Nothing mempty
+
+testSuiteFieldDescrs :: [FieldDescr TestSuiteStanza]
+testSuiteFieldDescrs =
+ [ simpleField "type"
+ (maybe empty disp) (fmap Just parse)
+ testStanzaTestType (\x suite -> suite { testStanzaTestType = x })
+ , simpleField "main-is"
+ (maybe empty showFilePath) (fmap Just parseFilePathQ)
+ testStanzaMainIs (\x suite -> suite { testStanzaMainIs = x })
+ , simpleField "test-module"
+ (maybe empty disp) (fmap Just parseModuleNameQ)
+ testStanzaTestModule (\x suite -> suite { testStanzaTestModule = x })
+ ]
+ ++ map biToTest binfoFieldDescrs
+ where
+ biToTest = liftField testStanzaBuildInfo
+ (\bi suite -> suite { testStanzaBuildInfo = bi })
+
+storeXFieldsTest :: UnrecFieldParser TestSuiteStanza
+storeXFieldsTest (f@('x':'-':_), val) t@(TestSuiteStanza { testStanzaBuildInfo = bi }) =
+ Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}
+storeXFieldsTest _ _ = Nothing
+
+validateTestSuite :: LineNo -> TestSuiteStanza -> ParseResult TestSuite
+validateTestSuite line stanza =
+ case testStanzaTestType stanza of
+ Nothing -> return $
+ emptyTestSuite { testBuildInfo = testStanzaBuildInfo stanza }
+
+ Just tt@(TestTypeUnknown _ _) ->
+ return emptyTestSuite {
+ testInterface = TestSuiteUnsupported tt,
+ testBuildInfo = testStanzaBuildInfo stanza
+ }
+
+ Just tt | tt `notElem` knownTestTypes ->
+ return emptyTestSuite {
+ testInterface = TestSuiteUnsupported tt,
+ testBuildInfo = testStanzaBuildInfo stanza
+ }
+
+ Just tt@(TestTypeExe ver) ->
+ case testStanzaMainIs stanza of
+ Nothing -> syntaxError line (missingField "main-is" tt)
+ Just file -> do
+ when (isJust (testStanzaTestModule stanza)) $
+ warning (extraField "test-module" tt)
+ return emptyTestSuite {
+ testInterface = TestSuiteExeV10 ver file,
+ testBuildInfo = testStanzaBuildInfo stanza
+ }
+
+ Just tt@(TestTypeLib ver) ->
+ case testStanzaTestModule stanza of
+ Nothing -> syntaxError line (missingField "test-module" tt)
+ Just module_ -> do
+ when (isJust (testStanzaMainIs stanza)) $
+ warning (extraField "main-is" tt)
+ return emptyTestSuite {
+ testInterface = TestSuiteLibV09 ver module_,
+ testBuildInfo = testStanzaBuildInfo stanza
+ }
+
+ where
+ missingField name tt = "The '" ++ name ++ "' field is required for the "
+ ++ display tt ++ " test suite type."
+
+ extraField name tt = "The '" ++ name ++ "' field is not used for the '"
+ ++ display tt ++ "' test suite type."
+
+
+-- ---------------------------------------------------------------------------
+-- The Benchmark type
+
+-- | An intermediate type just used for parsing the benchmark stanza.
+-- After validation it is converted into the proper 'Benchmark' type.
+data BenchmarkStanza = BenchmarkStanza {
+ benchmarkStanzaBenchmarkType :: Maybe BenchmarkType,
+ benchmarkStanzaMainIs :: Maybe FilePath,
+ benchmarkStanzaBenchmarkModule :: Maybe ModuleName,
+ benchmarkStanzaBuildInfo :: BuildInfo
+ }
+
+emptyBenchmarkStanza :: BenchmarkStanza
+emptyBenchmarkStanza = BenchmarkStanza Nothing Nothing Nothing mempty
+
+benchmarkFieldDescrs :: [FieldDescr BenchmarkStanza]
+benchmarkFieldDescrs =
+ [ simpleField "type"
+ (maybe empty disp) (fmap Just parse)
+ benchmarkStanzaBenchmarkType
+ (\x suite -> suite { benchmarkStanzaBenchmarkType = x })
+ , simpleField "main-is"
+ (maybe empty showFilePath) (fmap Just parseFilePathQ)
+ benchmarkStanzaMainIs
+ (\x suite -> suite { benchmarkStanzaMainIs = x })
+ ]
+ ++ map biToBenchmark binfoFieldDescrs
+ where
+ biToBenchmark = liftField benchmarkStanzaBuildInfo
+ (\bi suite -> suite { benchmarkStanzaBuildInfo = bi })
+
+storeXFieldsBenchmark :: UnrecFieldParser BenchmarkStanza
+storeXFieldsBenchmark (f@('x':'-':_), val)
+ t@(BenchmarkStanza { benchmarkStanzaBuildInfo = bi }) =
+ Just $ t {benchmarkStanzaBuildInfo =
+ bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}
+storeXFieldsBenchmark _ _ = Nothing
+
+validateBenchmark :: LineNo -> BenchmarkStanza -> ParseResult Benchmark
+validateBenchmark line stanza =
+ case benchmarkStanzaBenchmarkType stanza of
+ Nothing -> return $
+ emptyBenchmark { benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza }
+
+ Just tt@(BenchmarkTypeUnknown _ _) ->
+ return emptyBenchmark {
+ benchmarkInterface = BenchmarkUnsupported tt,
+ benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza
+ }
+
+ Just tt | tt `notElem` knownBenchmarkTypes ->
+ return emptyBenchmark {
+ benchmarkInterface = BenchmarkUnsupported tt,
+ benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza
+ }
+
+ Just tt@(BenchmarkTypeExe ver) ->
+ case benchmarkStanzaMainIs stanza of
+ Nothing -> syntaxError line (missingField "main-is" tt)
+ Just file -> do
+ when (isJust (benchmarkStanzaBenchmarkModule stanza)) $
+ warning (extraField "benchmark-module" tt)
+ return emptyBenchmark {
+ benchmarkInterface = BenchmarkExeV10 ver file,
+ benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza
+ }
+
+ where
+ missingField name tt = "The '" ++ name ++ "' field is required for the "
+ ++ display tt ++ " benchmark type."
+
+ extraField name tt = "The '" ++ name ++ "' field is not used for the '"
+ ++ display tt ++ "' benchmark type."
+
+-- ---------------------------------------------------------------------------
+-- The BuildInfo type
+
+
+binfoFieldDescrs :: [FieldDescr BuildInfo]
+binfoFieldDescrs =
+ [ boolField "buildable"
+ buildable (\val binfo -> binfo{buildable=val})
+ , commaListField "build-tools"
+ disp parseBuildTool
+ buildTools (\xs binfo -> binfo{buildTools=xs})
+ , spaceListField "cpp-options"
+ showToken parseTokenQ'
+ cppOptions (\val binfo -> binfo{cppOptions=val})
+ , spaceListField "cc-options"
+ showToken parseTokenQ'
+ ccOptions (\val binfo -> binfo{ccOptions=val})
+ , spaceListField "ld-options"
+ showToken parseTokenQ'
+ ldOptions (\val binfo -> binfo{ldOptions=val})
+ , commaListField "pkgconfig-depends"
+ disp parsePkgconfigDependency
+ pkgconfigDepends (\xs binfo -> binfo{pkgconfigDepends=xs})
+ , listField "frameworks"
+ showToken parseTokenQ
+ frameworks (\val binfo -> binfo{frameworks=val})
+ , listField "c-sources"
+ showFilePath parseFilePathQ
+ cSources (\paths binfo -> binfo{cSources=paths})
+
+ , simpleField "default-language"
+ (maybe empty disp) (option Nothing (fmap Just parseLanguageQ))
+ defaultLanguage (\lang binfo -> binfo{defaultLanguage=lang})
+ , listField "other-languages"
+ disp parseLanguageQ
+ otherLanguages (\langs binfo -> binfo{otherLanguages=langs})
+ , listField "default-extensions"
+ disp parseExtensionQ
+ defaultExtensions (\exts binfo -> binfo{defaultExtensions=exts})
+ , listField "other-extensions"
+ disp parseExtensionQ
+ otherExtensions (\exts binfo -> binfo{otherExtensions=exts})
+ , listField "extensions"
+ disp parseExtensionQ
+ oldExtensions (\exts binfo -> binfo{oldExtensions=exts})
+
+ , listField "extra-libraries"
+ showToken parseTokenQ
+ extraLibs (\xs binfo -> binfo{extraLibs=xs})
+ , listField "extra-lib-dirs"
+ showFilePath parseFilePathQ
+ extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs})
+ , listField "includes"
+ showFilePath parseFilePathQ
+ includes (\paths binfo -> binfo{includes=paths})
+ , listField "install-includes"
+ showFilePath parseFilePathQ
+ installIncludes (\paths binfo -> binfo{installIncludes=paths})
+ , listField "include-dirs"
+ showFilePath parseFilePathQ
+ includeDirs (\paths binfo -> binfo{includeDirs=paths})
+ , listField "hs-source-dirs"
+ showFilePath parseFilePathQ
+ hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths})
+ , listField "other-modules"
+ disp parseModuleNameQ
+ otherModules (\val binfo -> binfo{otherModules=val})
+ , listField "ghc-prof-options"
+ text parseTokenQ
+ ghcProfOptions (\val binfo -> binfo{ghcProfOptions=val})
+ , listField "ghc-shared-options"
+ text parseTokenQ
+ ghcSharedOptions (\val binfo -> binfo{ghcSharedOptions=val})
+ , optsField "ghc-options" GHC
+ options (\path binfo -> binfo{options=path})
+ , optsField "hugs-options" Hugs
+ options (\path binfo -> binfo{options=path})
+ , optsField "nhc98-options" NHC
+ options (\path binfo -> binfo{options=path})
+ , optsField "jhc-options" JHC
+ options (\path binfo -> binfo{options=path})
+ ]
+
+storeXFieldsBI :: UnrecFieldParser BuildInfo
+storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):(customFieldsBI bi) }
+storeXFieldsBI _ _ = Nothing
+
+------------------------------------------------------------------------------
+
+flagFieldDescrs :: [FieldDescr Flag]
+flagFieldDescrs =
+ [ simpleField "description"
+ showFreeText parseFreeText
+ flagDescription (\val fl -> fl{ flagDescription = val })
+ , boolField "default"
+ flagDefault (\val fl -> fl{ flagDefault = val })
+ , boolField "manual"
+ flagManual (\val fl -> fl{ flagManual = val })
+ ]
+
+------------------------------------------------------------------------------
+
+sourceRepoFieldDescrs :: [FieldDescr SourceRepo]
+sourceRepoFieldDescrs =
+ [ simpleField "type"
+ (maybe empty disp) (fmap Just parse)
+ repoType (\val repo -> repo { repoType = val })
+ , simpleField "location"
+ (maybe empty showFreeText) (fmap Just parseFreeText)
+ repoLocation (\val repo -> repo { repoLocation = val })
+ , simpleField "module"
+ (maybe empty showToken) (fmap Just parseTokenQ)
+ repoModule (\val repo -> repo { repoModule = val })
+ , simpleField "branch"
+ (maybe empty showToken) (fmap Just parseTokenQ)
+ repoBranch (\val repo -> repo { repoBranch = val })
+ , simpleField "tag"
+ (maybe empty showToken) (fmap Just parseTokenQ)
+ repoTag (\val repo -> repo { repoTag = val })
+ , simpleField "subdir"
+ (maybe empty showFilePath) (fmap Just parseFilePathQ)
+ repoSubdir (\val repo -> repo { repoSubdir = val })
+ ]
+
+-- ---------------------------------------------------------------
+-- Parsing
+
+-- | Given a parser and a filename, return the parse of the file,
+-- after checking if the file exists.
+readAndParseFile :: (FilePath -> (String -> IO a) -> IO a)
+ -> (String -> ParseResult a)
+ -> Verbosity
+ -> FilePath -> IO a
+readAndParseFile withFileContents' parser verbosity fpath = do
+ exists <- doesFileExist fpath
+ when (not exists) (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.")
+ withFileContents' fpath $ \str -> case parser str of
+ ParseFailed e -> do
+ let (line, message) = locatedErrorMsg e
+ dieWithLocation fpath line message
+ ParseOk warnings x -> do
+ mapM_ (warn verbosity . showPWarning fpath) $ reverse warnings
+ return x
+
+readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo
+readHookedBuildInfo =
+ readAndParseFile withFileContents parseHookedBuildInfo
+
+-- |Parse the given package file.
+readPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription
+readPackageDescription =
+ readAndParseFile withUTF8FileContents parsePackageDescription
+
+stanzas :: [Field] -> [[Field]]
+stanzas [] = []
+stanzas (f:fields) = (f:this) : stanzas rest
+ where
+ (this, rest) = break isStanzaHeader fields
+
+isStanzaHeader :: Field -> Bool
+isStanzaHeader (F _ f _) = f == "executable"
+isStanzaHeader _ = False
+
+------------------------------------------------------------------------------
+
+
+mapSimpleFields :: (Field -> ParseResult Field) -> [Field]
+ -> ParseResult [Field]
+mapSimpleFields f fs = mapM walk fs
+ where
+ walk fld@(F _ _ _) = f fld
+ walk (IfBlock l c fs1 fs2) = do
+ fs1' <- mapM walk fs1
+ fs2' <- mapM walk fs2
+ return (IfBlock l c fs1' fs2')
+ walk (Section ln n l fs1) = do
+ fs1' <- mapM walk fs1
+ return (Section ln n l fs1')
+
+-- prop_isMapM fs = mapSimpleFields return fs == return fs
+
+
+-- names of fields that represents dependencies, thus consrca
+constraintFieldNames :: [String]
+constraintFieldNames = ["build-depends"]
+
+-- Possible refactoring would be to have modifiers be explicit about what
+-- they add and define an accessor that specifies what the dependencies
+-- are. This way we would completely reuse the parsing knowledge from the
+-- field descriptor.
+parseConstraint :: Field -> ParseResult [Dependency]
+parseConstraint (F l n v)
+ | n == "build-depends" = runP l n (parseCommaList parse) v
+parseConstraint f = bug $ "Constraint was expected (got: " ++ show f ++ ")"
+
+{-
+headerFieldNames :: [String]
+headerFieldNames = filter (\n -> not (n `elem` constraintFieldNames))
+ . map fieldName $ pkgDescrFieldDescrs
+-}
+
+libFieldNames :: [String]
+libFieldNames = map fieldName libFieldDescrs
+ ++ buildInfoNames ++ constraintFieldNames
+
+-- exeFieldNames :: [String]
+-- exeFieldNames = map fieldName executableFieldDescrs
+-- ++ buildInfoNames
+
+buildInfoNames :: [String]
+buildInfoNames = map fieldName binfoFieldDescrs
+ ++ map fst deprecatedFieldsBuildInfo
+
+-- A minimal implementation of the StateT monad transformer to avoid depending
+-- on the 'mtl' package.
+newtype StT s m a = StT { runStT :: s -> m (a,s) }
+
+instance Monad m => Monad (StT s m) where
+ return a = StT (\s -> return (a,s))
+ StT f >>= g = StT $ \s -> do
+ (a,s') <- f s
+ runStT (g a) s'
+
+get :: Monad m => StT s m s
+get = StT $ \s -> return (s, s)
+
+modify :: Monad m => (s -> s) -> StT s m ()
+modify f = StT $ \s -> return ((),f s)
+
+lift :: Monad m => m a -> StT s m a
+lift m = StT $ \s -> m >>= \a -> return (a,s)
+
+evalStT :: Monad m => StT s m a -> s -> m a
+evalStT st s = runStT st s >>= return . fst
+
+-- Our monad for parsing a list/tree of fields.
+--
+-- The state represents the remaining fields to be processed.
+type PM a = StT [Field] ParseResult a
+
+
+
+-- return look-ahead field or nothing if we're at the end of the file
+peekField :: PM (Maybe Field)
+peekField = get >>= return . listToMaybe
+
+-- Unconditionally discard the first field in our state. Will error when it
+-- reaches end of file. (Yes, that's evil.)
+skipField :: PM ()
+skipField = modify tail
+
+--FIXME: this should take a ByteString, not a String. We have to be able to
+-- decode UTF8 and handle the BOM.
+
+-- | Parses the given file into a 'GenericPackageDescription'.
+--
+-- In Cabal 1.2 the syntax for package descriptions was changed to a format
+-- with sections and possibly indented property descriptions.
+parsePackageDescription :: String -> ParseResult GenericPackageDescription
+parsePackageDescription file = do
+
+ -- This function is quite complex because it needs to be able to parse
+ -- both pre-Cabal-1.2 and post-Cabal-1.2 files. Additionally, it contains
+ -- a lot of parser-related noise since we do not want to depend on Parsec.
+ --
+ -- If we detect an pre-1.2 file we implicitly convert it to post-1.2
+ -- style. See 'sectionizeFields' below for details about the conversion.
+
+ fields0 <- readFields file `catchParseError` \err ->
+ let tabs = findIndentTabs file in
+ case err of
+ -- In case of a TabsError report them all at once.
+ TabsError tabLineNo -> reportTabsError
+ -- but only report the ones including and following
+ -- the one that caused the actual error
+ [ t | t@(lineNo',_) <- tabs
+ , lineNo' >= tabLineNo ]
+ _ -> parseFail err
+
+ let cabalVersionNeeded =
+ head $ [ minVersionBound versionRange
+ | Just versionRange <- [ simpleParse v
+ | F _ "cabal-version" v <- fields0 ] ]
+ ++ [Version [0] []]
+ minVersionBound versionRange =
+ case asVersionIntervals versionRange of
+ [] -> Version [0] []
+ ((LowerBound version _, _):_) -> version
+
+ handleFutureVersionParseFailure cabalVersionNeeded $ do
+
+ let sf = sectionizeFields fields0 -- ensure 1.2 format
+
+ -- figure out and warn about deprecated stuff (warnings are collected
+ -- inside our parsing monad)
+ fields <- mapSimpleFields deprecField sf
+
+ -- Our parsing monad takes the not-yet-parsed fields as its state.
+ -- After each successful parse we remove the field from the state
+ -- ('skipField') and move on to the next one.
+ --
+ -- Things are complicated a bit, because fields take a tree-like
+ -- structure -- they can be sections or "if"/"else" conditionals.
+
+ flip evalStT fields $ do
+
+ -- The header consists of all simple fields up to the first section
+ -- (flag, library, executable).
+ header_fields <- getHeader []
+
+ -- Parses just the header fields and stores them in a
+ -- 'PackageDescription'. Note that our final result is a
+ -- 'GenericPackageDescription'; for pragmatic reasons we just store
+ -- the partially filled-out 'PackageDescription' inside the
+ -- 'GenericPackageDescription'.
+ pkg <- lift $ parseFields pkgDescrFieldDescrs
+ storeXFieldsPD
+ emptyPackageDescription
+ header_fields
+
+ -- 'getBody' assumes that the remaining fields only consist of
+ -- flags, lib and exe sections.
+ (repos, flags, mlib, exes, tests, bms) <- getBody
+ warnIfRest -- warn if getBody did not parse up to the last field.
+ -- warn about using old/new syntax with wrong cabal-version:
+ maybeWarnCabalVersion (not $ oldSyntax fields0) pkg
+ checkForUndefinedFlags flags mlib exes tests
+ return $ GenericPackageDescription
+ pkg { sourceRepos = repos }
+ flags mlib exes tests bms
+
+ where
+ oldSyntax flds = all isSimpleField flds
+ reportTabsError tabs =
+ syntaxError (fst (head tabs)) $
+ "Do not use tabs for indentation (use spaces instead)\n"
+ ++ " Tabs were used at (line,column): " ++ show tabs
+
+ maybeWarnCabalVersion newsyntax pkg
+ | newsyntax && specVersion pkg < Version [1,2] []
+ = lift $ warning $
+ "A package using section syntax must specify at least\n"
+ ++ "'cabal-version: >= 1.2'."
+
+ maybeWarnCabalVersion newsyntax pkg
+ | not newsyntax && specVersion pkg >= Version [1,2] []
+ = lift $ warning $
+ "A package using 'cabal-version: "
+ ++ displaySpecVersion (specVersionRaw pkg)
+ ++ "' must use section syntax. See the Cabal user guide for details."
+ where
+ displaySpecVersion (Left version) = display version
+ displaySpecVersion (Right versionRange) =
+ case asVersionIntervals versionRange of
+ [] {- impossible -} -> display versionRange
+ ((LowerBound version _, _):_) -> display (orLaterVersion version)
+
+ maybeWarnCabalVersion _ _ = return ()
+
+
+ handleFutureVersionParseFailure cabalVersionNeeded parseBody =
+ (unless versionOk (warning message) >> parseBody)
+ `catchParseError` \parseError -> case parseError of
+ TabsError _ -> parseFail parseError
+ _ | versionOk -> parseFail parseError
+ | otherwise -> fail message
+ where versionOk = cabalVersionNeeded <= cabalVersion
+ message = "This package requires at least Cabal version "
+ ++ display cabalVersionNeeded
+
+ -- "Sectionize" an old-style Cabal file. A sectionized file has:
+ --
+ -- * all global fields at the beginning, followed by
+ --
+ -- * all flag declarations, followed by
+ --
+ -- * an optional library section, and an arbitrary number of executable
+ -- sections (in any order).
+ --
+ -- The current implementatition just gathers all library-specific fields
+ -- in a library section and wraps all executable stanzas in an executable
+ -- section.
+ sectionizeFields :: [Field] -> [Field]
+ sectionizeFields fs
+ | oldSyntax fs =
+ let
+ -- "build-depends" is a local field now. To be backwards
+ -- compatible, we still allow it as a global field in old-style
+ -- package description files and translate it to a local field by
+ -- adding it to every non-empty section
+ (hdr0, exes0) = break ((=="executable") . fName) fs
+ (hdr, libfs0) = partition (not . (`elem` libFieldNames) . fName) hdr0
+
+ (deps, libfs) = partition ((== "build-depends") . fName)
+ libfs0
+
+ exes = unfoldr toExe exes0
+ toExe [] = Nothing
+ toExe (F l e n : r)
+ | e == "executable" =
+ let (efs, r') = break ((=="executable") . fName) r
+ in Just (Section l "executable" n (deps ++ efs), r')
+ toExe _ = bug "unexpeced input to 'toExe'"
+ in
+ hdr ++
+ (if null libfs then []
+ else [Section (lineNo (head libfs)) "library" "" (deps ++ libfs)])
+ ++ exes
+ | otherwise = fs
+
+ isSimpleField (F _ _ _) = True
+ isSimpleField _ = False
+
+ -- warn if there's something at the end of the file
+ warnIfRest :: PM ()
+ warnIfRest = do
+ s <- get
+ case s of
+ [] -> return ()
+ _ -> lift $ warning "Ignoring trailing declarations." -- add line no.
+
+ -- all simple fields at the beginning of the file are (considered) header
+ -- fields
+ getHeader :: [Field] -> PM [Field]
+ getHeader acc = peekField >>= \mf -> case mf of
+ Just f@(F _ _ _) -> skipField >> getHeader (f:acc)
+ _ -> return (reverse acc)
+
+ --
+ -- body ::= { repo | flag | library | executable | test }+ -- at most one lib
+ --
+ -- The body consists of an optional sequence of declarations of flags and
+ -- an arbitrary number of executables and at most one library.
+ getBody :: PM ([SourceRepo], [Flag]
+ ,Maybe (CondTree ConfVar [Dependency] Library)
+ ,[(String, CondTree ConfVar [Dependency] Executable)]
+ ,[(String, CondTree ConfVar [Dependency] TestSuite)]
+ ,[(String, CondTree ConfVar [Dependency] Benchmark)])
+ getBody = peekField >>= \mf -> case mf of
+ Just (Section line_no sec_type sec_label sec_fields)
+ | sec_type == "executable" -> do
+ when (null sec_label) $ lift $ syntaxError line_no
+ "'executable' needs one argument (the executable's name)"
+ exename <- lift $ runP line_no "executable" parseTokenQ sec_label
+ flds <- collectFields parseExeFields sec_fields
+ skipField
+ (repos, flags, lib, exes, tests, bms) <- getBody
+ return (repos, flags, lib, (exename, flds): exes, tests, bms)
+
+ | sec_type == "test-suite" -> do
+ when (null sec_label) $ lift $ syntaxError line_no
+ "'test-suite' needs one argument (the test suite's name)"
+ testname <- lift $ runP line_no "test" parseTokenQ sec_label
+ flds <- collectFields (parseTestFields line_no) sec_fields
+
+ -- Check that a valid test suite type has been chosen. A type
+ -- field may be given inside a conditional block, so we must
+ -- check for that before complaining that a type field has not
+ -- been given. The test suite must always have a valid type, so
+ -- we need to check both the 'then' and 'else' blocks, though
+ -- the blocks need not have the same type.
+ let checkTestType ts ct =
+ let ts' = mappend ts $ condTreeData ct
+ -- If a conditional has only a 'then' block and no
+ -- 'else' block, then it cannot have a valid type
+ -- in every branch, unless the type is specified at
+ -- a higher level in the tree.
+ checkComponent (_, _, Nothing) = False
+ -- If a conditional has a 'then' block and an 'else'
+ -- block, both must specify a test type, unless the
+ -- type is specified higher in the tree.
+ checkComponent (_, t, Just e) =
+ checkTestType ts' t && checkTestType ts' e
+ -- Does the current node specify a test type?
+ hasTestType = testInterface ts'
+ /= testInterface emptyTestSuite
+ components = condTreeComponents ct
+ -- If the current level of the tree specifies a type,
+ -- then we are done. If not, then one of the conditional
+ -- branches below the current node must specify a type.
+ -- Each node may have multiple immediate children; we
+ -- only one need one to specify a type because the
+ -- configure step uses 'mappend' to join together the
+ -- results of flag resolution.
+ in hasTestType || (any checkComponent components)
+ if checkTestType emptyTestSuite flds
+ then do
+ skipField
+ (repos, flags, lib, exes, tests, bms) <- getBody
+ return (repos, flags, lib, exes, (testname, flds) : tests, bms)
+ else lift $ syntaxError line_no $
+ "Test suite \"" ++ testname
+ ++ "\" is missing required field \"type\" or the field "
+ ++ "is not present in all conditional branches. The "
+ ++ "available test types are: "
+ ++ intercalate ", " (map display knownTestTypes)
+
+ | sec_type == "benchmark" -> do
+ when (null sec_label) $ lift $ syntaxError line_no
+ "'benchmark' needs one argument (the benchmark's name)"
+ benchname <- lift $ runP line_no "benchmark" parseTokenQ sec_label
+ flds <- collectFields (parseBenchmarkFields line_no) sec_fields
+
+ -- Check that a valid benchmark type has been chosen. A type
+ -- field may be given inside a conditional block, so we must
+ -- check for that before complaining that a type field has not
+ -- been given. The benchmark must always have a valid type, so
+ -- we need to check both the 'then' and 'else' blocks, though
+ -- the blocks need not have the same type.
+ let checkBenchmarkType ts ct =
+ let ts' = mappend ts $ condTreeData ct
+ -- If a conditional has only a 'then' block and no
+ -- 'else' block, then it cannot have a valid type
+ -- in every branch, unless the type is specified at
+ -- a higher level in the tree.
+ checkComponent (_, _, Nothing) = False
+ -- If a conditional has a 'then' block and an 'else'
+ -- block, both must specify a benchmark type, unless the
+ -- type is specified higher in the tree.
+ checkComponent (_, t, Just e) =
+ checkBenchmarkType ts' t && checkBenchmarkType ts' e
+ -- Does the current node specify a benchmark type?
+ hasBenchmarkType = benchmarkInterface ts'
+ /= benchmarkInterface emptyBenchmark
+ components = condTreeComponents ct
+ -- If the current level of the tree specifies a type,
+ -- then we are done. If not, then one of the conditional
+ -- branches below the current node must specify a type.
+ -- Each node may have multiple immediate children; we
+ -- only one need one to specify a type because the
+ -- configure step uses 'mappend' to join together the
+ -- results of flag resolution.
+ in hasBenchmarkType || (any checkComponent components)
+ if checkBenchmarkType emptyBenchmark flds
+ then do
+ skipField
+ (repos, flags, lib, exes, tests, bms) <- getBody
+ return (repos, flags, lib, exes, tests, (benchname, flds) : bms)
+ else lift $ syntaxError line_no $
+ "Benchmark \"" ++ benchname
+ ++ "\" is missing required field \"type\" or the field "
+ ++ "is not present in all conditional branches. The "
+ ++ "available benchmark types are: "
+ ++ intercalate ", " (map display knownBenchmarkTypes)
+
+ | sec_type == "library" -> do
+ when (not (null sec_label)) $ lift $
+ syntaxError line_no "'library' expects no argument"
+ flds <- collectFields parseLibFields sec_fields
+ skipField
+ (repos, flags, lib, exes, tests, bms) <- getBody
+ when (isJust lib) $ lift $ syntaxError line_no
+ "There can only be one library section in a package description."
+ return (repos, flags, Just flds, exes, tests, bms)
+
+ | sec_type == "flag" -> do
+ when (null sec_label) $ lift $
+ syntaxError line_no "'flag' needs one argument (the flag's name)"
+ flag <- lift $ parseFields
+ flagFieldDescrs
+ warnUnrec
+ (MkFlag (FlagName (lowercase sec_label)) "" True False)
+ sec_fields
+ skipField
+ (repos, flags, lib, exes, tests, bms) <- getBody
+ return (repos, flag:flags, lib, exes, tests, bms)
+
+ | sec_type == "source-repository" -> do
+ when (null sec_label) $ lift $ syntaxError line_no $
+ "'source-repository' needs one argument, "
+ ++ "the repo kind which is usually 'head' or 'this'"
+ kind <- case simpleParse sec_label of
+ Just kind -> return kind
+ Nothing -> lift $ syntaxError line_no $
+ "could not parse repo kind: " ++ sec_label
+ repo <- lift $ parseFields
+ sourceRepoFieldDescrs
+ warnUnrec
+ (SourceRepo {
+ repoKind = kind,
+ repoType = Nothing,
+ repoLocation = Nothing,
+ repoModule = Nothing,
+ repoBranch = Nothing,
+ repoTag = Nothing,
+ repoSubdir = Nothing
+ })
+ sec_fields
+ skipField
+ (repos, flags, lib, exes, tests, bms) <- getBody
+ return (repo:repos, flags, lib, exes, tests, bms)
+
+ | otherwise -> do
+ lift $ warning $ "Ignoring unknown section type: " ++ sec_type
+ skipField
+ getBody
+ Just f -> do
+ _ <- lift $ syntaxError (lineNo f) $
+ "Construct not supported at this position: " ++ show f
+ skipField
+ getBody
+ Nothing -> return ([], [], Nothing, [], [], [])
+
+ -- Extracts all fields in a block and returns a 'CondTree'.
+ --
+ -- We have to recurse down into conditionals and we treat fields that
+ -- describe dependencies specially.
+ collectFields :: ([Field] -> PM a) -> [Field]
+ -> PM (CondTree ConfVar [Dependency] a)
+ collectFields parser allflds = do
+
+ let simplFlds = [ F l n v | F l n v <- allflds ]
+ condFlds = [ f | f@(IfBlock _ _ _ _) <- allflds ]
+
+ let (depFlds, dataFlds) = partition isConstraint simplFlds
+
+ a <- parser dataFlds
+ deps <- liftM concat . mapM (lift . parseConstraint) $ depFlds
+
+ ifs <- mapM processIfs condFlds
+
+ return (CondNode a deps ifs)
+ where
+ isConstraint (F _ n _) = n `elem` constraintFieldNames
+ isConstraint _ = False
+
+ processIfs (IfBlock l c t e) = do
+ cnd <- lift $ runP l "if" parseCondition c
+ t' <- collectFields parser t
+ e' <- case e of
+ [] -> return Nothing
+ es -> do fs <- collectFields parser es
+ return (Just fs)
+ return (cnd, t', e')
+ processIfs _ = bug "processIfs called with wrong field type"
+
+ parseLibFields :: [Field] -> PM Library
+ parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary
+
+ -- Note: we don't parse the "executable" field here, hence the tail hack.
+ parseExeFields :: [Field] -> PM Executable
+ parseExeFields = lift . parseFields (tail executableFieldDescrs) storeXFieldsExe emptyExecutable
+
+ parseTestFields :: LineNo -> [Field] -> PM TestSuite
+ parseTestFields line fields = do
+ x <- lift $ parseFields testSuiteFieldDescrs storeXFieldsTest
+ emptyTestStanza fields
+ lift $ validateTestSuite line x
+
+ parseBenchmarkFields :: LineNo -> [Field] -> PM Benchmark
+ parseBenchmarkFields line fields = do
+ x <- lift $ parseFields benchmarkFieldDescrs storeXFieldsBenchmark
+ emptyBenchmarkStanza fields
+ lift $ validateBenchmark line x
+
+ checkForUndefinedFlags ::
+ [Flag] ->
+ Maybe (CondTree ConfVar [Dependency] Library) ->
+ [(String, CondTree ConfVar [Dependency] Executable)] ->
+ [(String, CondTree ConfVar [Dependency] TestSuite)] ->
+ PM ()
+ checkForUndefinedFlags flags mlib exes tests = do
+ let definedFlags = map flagName flags
+ maybe (return ()) (checkCondTreeFlags definedFlags) mlib
+ mapM_ (checkCondTreeFlags definedFlags . snd) exes
+ mapM_ (checkCondTreeFlags definedFlags . snd) tests
+
+ checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM ()
+ checkCondTreeFlags definedFlags ct = do
+ let fv = nub $ freeVars ct
+ when (not . all (`elem` definedFlags) $ fv) $
+ fail $ "These flags are used without having been defined: "
+ ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ]
+
+
+-- | Parse a list of fields, given a list of field descriptions,
+-- a structure to accumulate the parsed fields, and a function
+-- that can decide what to do with fields which don't match any
+-- of the field descriptions.
+parseFields :: [FieldDescr a] -- ^ descriptions of fields we know how to
+ -- parse
+ -> UnrecFieldParser a -- ^ possibly do something with
+ -- unrecognized fields
+ -> a -- ^ accumulator
+ -> [Field] -- ^ fields to be parsed
+ -> ParseResult a
+parseFields descrs unrec ini fields =
+ do (a, unknowns) <- foldM (parseField descrs unrec) (ini, []) fields
+ when (not (null unknowns)) $ do
+ warning $ render $
+ text "Unknown fields:" <+>
+ commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")")
+ (reverse unknowns))
+ $+$
+ text "Fields allowed in this section:" $$
+ nest 4 (commaSep $ map fieldName descrs)
+ return a
+ where
+ commaSep = fsep . punctuate comma . map text
+
+parseField :: [FieldDescr a] -- ^ list of parseable fields
+ -> UnrecFieldParser a -- ^ possibly do something with
+ -- unrecognized fields
+ -> (a,[(Int,String)]) -- ^ accumulated result and warnings
+ -> Field -- ^ the field to be parsed
+ -> ParseResult (a, [(Int,String)])
+parseField ((FieldDescr name _ parser):fields) unrec (a, us) (F line f val)
+ | name == f = parser line val a >>= \a' -> return (a',us)
+ | otherwise = parseField fields unrec (a,us) (F line f val)
+parseField [] unrec (a,us) (F l f val) = return $
+ case unrec (f,val) a of -- no fields matched, see if the 'unrec'
+ Just a' -> (a',us) -- function wants to do anything with it
+ Nothing -> (a, ((l,f):us))
+parseField _ _ _ _ = bug "'parseField' called on a non-field"
+
+deprecatedFields :: [(String,String)]
+deprecatedFields =
+ deprecatedFieldsPkgDescr ++ deprecatedFieldsBuildInfo
+
+deprecatedFieldsPkgDescr :: [(String,String)]
+deprecatedFieldsPkgDescr = [ ("other-files", "extra-source-files") ]
+
+deprecatedFieldsBuildInfo :: [(String,String)]
+deprecatedFieldsBuildInfo = [ ("hs-source-dir","hs-source-dirs") ]
+
+-- Handle deprecated fields
+deprecField :: Field -> ParseResult Field
+deprecField (F line fld val) = do
+ fld' <- case lookup fld deprecatedFields of
+ Nothing -> return fld
+ Just newName -> do
+ warning $ "The field \"" ++ fld
+ ++ "\" is deprecated, please use \"" ++ newName ++ "\""
+ return newName
+ return (F line fld' val)
+deprecField _ = bug "'deprecField' called on a non-field"
+
+
+parseHookedBuildInfo :: String -> ParseResult HookedBuildInfo
+parseHookedBuildInfo inp = do
+ fields <- readFields inp
+ let ss@(mLibFields:exes) = stanzas fields
+ mLib <- parseLib mLibFields
+ biExes <- mapM parseExe (maybe ss (const exes) mLib)
+ return (mLib, biExes)
+ where
+ parseLib :: [Field] -> ParseResult (Maybe BuildInfo)
+ parseLib (bi@((F _ inFieldName _):_))
+ | lowercase inFieldName /= "executable" = liftM Just (parseBI bi)
+ parseLib _ = return Nothing
+
+ parseExe :: [Field] -> ParseResult (String, BuildInfo)
+ parseExe ((F line inFieldName mName):bi)
+ | lowercase inFieldName == "executable"
+ = do bis <- parseBI bi
+ return (mName, bis)
+ | otherwise = syntaxError line "expecting 'executable' at top of stanza"
+ parseExe (_:_) = bug "`parseExe' called on a non-field"
+ parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza"
+
+ parseBI st = parseFields binfoFieldDescrs storeXFieldsBI emptyBuildInfo st
+
+-- ---------------------------------------------------------------------------
+-- Pretty printing
+
+writePackageDescription :: FilePath -> PackageDescription -> IO ()
+writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg)
+
+--TODO: make this use section syntax
+-- add equivalent for GenericPackageDescription
+showPackageDescription :: PackageDescription -> String
+showPackageDescription pkg = render $
+ ppPackage pkg
+ $$ ppCustomFields (customFieldsPD pkg)
+ $$ (case library pkg of
+ Nothing -> empty
+ Just lib -> ppLibrary lib)
+ $$ vcat [ space $$ ppExecutable exe | exe <- executables pkg ]
+ where
+ ppPackage = ppFields pkgDescrFieldDescrs
+ ppLibrary = ppFields libFieldDescrs
+ ppExecutable = ppFields executableFieldDescrs
+
+ppCustomFields :: [(String,String)] -> Doc
+ppCustomFields flds = vcat (map ppCustomField flds)
+
+ppCustomField :: (String,String) -> Doc
+ppCustomField (name,val) = text name <> colon <+> showFreeText val
+
+writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO ()
+writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack
+ . showHookedBuildInfo
+
+showHookedBuildInfo :: HookedBuildInfo -> String
+showHookedBuildInfo (mb_lib_bi, ex_bis) = render $
+ (case mb_lib_bi of
+ Nothing -> empty
+ Just bi -> ppBuildInfo bi)
+ $$ vcat [ space
+ $$ text "executable:" <+> text name
+ $$ ppBuildInfo bi
+ | (name, bi) <- ex_bis ]
+ where
+ ppBuildInfo bi = ppFields binfoFieldDescrs bi
+ $$ ppCustomFields (customFieldsBI bi)
+
+-- replace all tabs used as indentation with whitespace, also return where
+-- tabs were found
+findIndentTabs :: String -> [(Int,Int)]
+findIndentTabs = concatMap checkLine
+ . zip [1..]
+ . lines
+ where
+ checkLine (lineno, l) =
+ let (indent, _content) = span isSpace l
+ tabCols = map fst . filter ((== '\t') . snd) . zip [0..]
+ addLineNo = map (\col -> (lineno,col))
+ in addLineNo (tabCols indent)
+
+--test_findIndentTabs = findIndentTabs $ unlines $
+-- [ "foo", " bar", " \t baz", "\t biz\t", "\t\t \t mib" ]
+
+bug :: String -> a
+bug msg = error $ msg ++ ". Consider this a bug."
diff --git a/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs b/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs
new file mode 100644
index 0000000..b4b8d1d
--- /dev/null
+++ b/cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs
@@ -0,0 +1,238 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Distribution.PackageDescription.PrettyPrint
+-- Copyright : Jürgen Nicklisch-Franken 2010
+-- License : AllRightsReserved
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Stability : provisional
+-- Portability : portable
+--
+-- | Pretty printing for cabal files
+--
+-----------------------------------------------------------------------------
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.PackageDescription.PrettyPrint (
+ writeGenericPackageDescription,
+ showGenericPackageDescription,
+) where
+
+import Distribution.PackageDescription
+ ( TestSuite(..), TestSuiteInterface(..), testType
+ , SourceRepo(..),
+ customFieldsBI, CondTree(..), Condition(..),
+ FlagName(..), ConfVar(..), Executable(..), Library(..),
+ Flag(..), PackageDescription(..),
+ GenericPackageDescription(..))
+import Text.PrettyPrint
+ (hsep, comma, punctuate, fsep, parens, char, nest, empty,
+ isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render)
+import Distribution.Simple.Utils (writeUTF8File)
+import Distribution.ParseUtils (showFreeText, FieldDescr(..))
+import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs,
+ sourceRepoFieldDescrs)
+import Distribution.Package (Dependency(..))
+import Distribution.Text (Text(..))
+import Data.Maybe (isJust, fromJust, isNothing)
+
+indentWith :: Int
+indentWith = 4
+
+-- | Recompile with false for regression testing
+simplifiedPrinting :: Bool
+simplifiedPrinting = False
+
+-- | Writes a .cabal file from a generic package description
+writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO ()
+writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg)
+
+-- | Writes a generic package description to a string
+showGenericPackageDescription :: GenericPackageDescription -> String
+showGenericPackageDescription = render . ppGenericPackageDescription
+
+ppGenericPackageDescription :: GenericPackageDescription -> Doc
+ppGenericPackageDescription gpd =
+ ppPackageDescription (packageDescription gpd)
+ $+$ ppGenPackageFlags (genPackageFlags gpd)
+ $+$ ppLibrary (condLibrary gpd)
+ $+$ ppExecutables (condExecutables gpd)
+ $+$ ppTestSuites (condTestSuites gpd)
+
+ppPackageDescription :: PackageDescription -> Doc
+ppPackageDescription pd = ppFields pkgDescrFieldDescrs pd
+ $+$ ppCustomFields (customFieldsPD pd)
+ $+$ ppSourceRepos (sourceRepos pd)
+
+ppSourceRepos :: [SourceRepo] -> Doc
+ppSourceRepos [] = empty
+ppSourceRepos (hd:tl) = ppSourceRepo hd $+$ ppSourceRepos tl
+
+ppSourceRepo :: SourceRepo -> Doc
+ppSourceRepo repo =
+ emptyLine $ text "source-repository" <+> disp (repoKind repo) $+$
+ (nest indentWith (ppFields sourceRepoFieldDescrs' repo))
+ where
+ sourceRepoFieldDescrs' = [fd | fd <- sourceRepoFieldDescrs, fieldName fd /= "kind"]
+
+ppFields :: [FieldDescr a] -> a -> Doc
+ppFields fields x =
+ vcat [ ppField name (getter x)
+ | FieldDescr name getter _ <- fields]
+
+ppField :: String -> Doc -> Doc
+ppField name fielddoc | isEmpty fielddoc = empty
+ | otherwise = text name <> colon <+> fielddoc
+
+ppDiffFields :: [FieldDescr a] -> a -> a -> Doc
+ppDiffFields fields x y =
+ vcat [ ppField name (getter x)
+ | FieldDescr name getter _ <- fields,
+ render (getter x) /= render (getter y)]
+
+ppCustomFields :: [(String,String)] -> Doc
+ppCustomFields flds = vcat [ppCustomField f | f <- flds]
+
+ppCustomField :: (String,String) -> Doc
+ppCustomField (name,val) = text name <> colon <+> showFreeText val
+
+ppGenPackageFlags :: [Flag] -> Doc
+ppGenPackageFlags flds = vcat [ppFlag f | f <- flds]
+
+ppFlag :: Flag -> Doc
+ppFlag (MkFlag name desc dflt manual) =
+ emptyLine $ text "flag" <+> ppFlagName name $+$
+ (nest indentWith ((if null desc
+ then empty
+ else text "Description: " <+> showFreeText desc) $+$
+ (if dflt then empty else text "Default: False") $+$
+ (if manual then text "Manual: True" else empty)))
+
+ppLibrary :: (Maybe (CondTree ConfVar [Dependency] Library)) -> Doc
+ppLibrary Nothing = empty
+ppLibrary (Just condTree) =
+ emptyLine $ text "library" $+$ nest indentWith (ppCondTree condTree Nothing ppLib)
+ where
+ ppLib lib Nothing = ppFields libFieldDescrs lib
+ $$ ppCustomFields (customFieldsBI (libBuildInfo lib))
+ ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib
+ $$ ppCustomFields (customFieldsBI (libBuildInfo lib))
+
+ppExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] -> Doc
+ppExecutables exes =
+ vcat [emptyLine $ text ("executable " ++ n)
+ $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes]
+ where
+ ppExe (Executable _ modulePath' buildInfo') Nothing =
+ (if modulePath' == "" then empty else text "main-is:" <+> text modulePath')
+ $+$ ppFields binfoFieldDescrs buildInfo'
+ $+$ ppCustomFields (customFieldsBI buildInfo')
+ ppExe (Executable _ modulePath' buildInfo')
+ (Just (Executable _ modulePath2 buildInfo2)) =
+ (if modulePath' == "" || modulePath' == modulePath2
+ then empty else text "main-is:" <+> text modulePath')
+ $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2
+ $+$ ppCustomFields (customFieldsBI buildInfo')
+
+ppTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] -> Doc
+ppTestSuites suites =
+ emptyLine $ vcat [ text ("test-suite " ++ n)
+ $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite)
+ | (n,condTree) <- suites]
+ where
+ ppTestSuite testsuite Nothing =
+ text "type:" <+> disp (testType testsuite)
+ $+$ maybe empty (\f -> text "main-is:" <+> text f)
+ (testSuiteMainIs testsuite)
+ $+$ maybe empty (\m -> text "test-module:" <+> disp m)
+ (testSuiteModule testsuite)
+ $+$ ppFields binfoFieldDescrs (testBuildInfo testsuite)
+ $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite))
+
+ ppTestSuite (TestSuite _ _ buildInfo' _)
+ (Just (TestSuite _ _ buildInfo2 _)) =
+ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2
+ $+$ ppCustomFields (customFieldsBI buildInfo')
+
+ testSuiteMainIs test = case testInterface test of
+ TestSuiteExeV10 _ f -> Just f
+ _ -> Nothing
+
+ testSuiteModule test = case testInterface test of
+ TestSuiteLibV09 _ m -> Just m
+ _ -> Nothing
+
+ppCondition :: Condition ConfVar -> Doc
+ppCondition (Var x) = ppConfVar x
+ppCondition (Lit b) = text (show b)
+ppCondition (CNot c) = char '!' <> (ppCondition c)
+ppCondition (COr c1 c2) = parens (hsep [ppCondition c1, text "||"
+ <+> ppCondition c2])
+ppCondition (CAnd c1 c2) = parens (hsep [ppCondition c1, text "&&"
+ <+> ppCondition c2])
+ppConfVar :: ConfVar -> Doc
+ppConfVar (OS os) = text "os" <> parens (disp os)
+ppConfVar (Arch arch) = text "arch" <> parens (disp arch)
+ppConfVar (Flag name) = text "flag" <> parens (ppFlagName name)
+ppConfVar (Impl c v) = text "impl" <> parens (disp c <+> disp v)
+
+ppFlagName :: FlagName -> Doc
+ppFlagName (FlagName name) = text name
+
+ppCondTree :: CondTree ConfVar [Dependency] a -> Maybe a -> (a -> Maybe a -> Doc) -> Doc
+ppCondTree ct@(CondNode it deps ifs) mbIt ppIt =
+ let res = ppDeps deps
+ $+$ (vcat $ map ppIf ifs)
+ $+$ ppIt it mbIt
+ in if isJust mbIt && isEmpty res
+ then ppCondTree ct Nothing ppIt
+ else res
+ where
+ ppIf (c,thenTree,mElseTree) =
+ ((emptyLine $ text "if" <+> ppCondition c) $$
+ nest indentWith (ppCondTree thenTree
+ (if simplifiedPrinting then (Just it) else Nothing) ppIt))
+ $+$ (if isNothing mElseTree
+ then empty
+ else text "else"
+ $$ nest indentWith (ppCondTree (fromJust mElseTree)
+ (if simplifiedPrinting then (Just it) else Nothing) ppIt))
+
+ppDeps :: [Dependency] -> Doc
+ppDeps [] = empty
+ppDeps deps =
+ text "build-depends:" <+> fsep (punctuate comma (map disp deps))
+
+emptyLine :: Doc -> Doc
+emptyLine d = text " " $+$ d
+
+
+
diff --git a/cabal/Cabal/Distribution/ParseUtils.hs b/cabal/Cabal/Distribution/ParseUtils.hs
new file mode 100644
index 0000000..d390458
--- /dev/null
+++ b/cabal/Cabal/Distribution/ParseUtils.hs
@@ -0,0 +1,715 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.ParseUtils
+-- Copyright : (c) The University of Glasgow 2004
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- Utilities for parsing 'PackageDescription' and 'InstalledPackageInfo'.
+--
+-- The @.cabal@ file format is not trivial, especially with the introduction
+-- of configurations and the section syntax that goes with that. This module
+-- has a bunch of parsing functions that is used by the @.cabal@ parser and a
+-- couple others. It has the parsing framework code and also little parsers for
+-- many of the formats we get in various @.cabal@ file fields, like module
+-- names, comma separated lists etc.
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of the University nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+-- This module is meant to be local-only to Distribution...
+
+-- #hide
+module Distribution.ParseUtils (
+ LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning,
+ runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning,
+ Field(..), fName, lineNo,
+ FieldDescr(..), ppField, ppFields, readFields, readFieldsFlat,
+ showFields, showSingleNamedField, parseFields, parseFieldsFlat,
+ parseFilePathQ, parseTokenQ, parseTokenQ',
+ parseModuleNameQ, parseBuildTool, parsePkgconfigDependency,
+ parseOptVersion, parsePackageNameQ, parseVersionRangeQ,
+ parseTestedWithQ, parseLicenseQ, parseLanguageQ, parseExtensionQ,
+ parseSepList, parseCommaList, parseOptCommaList,
+ showFilePath, showToken, showTestedWith, showFreeText, parseFreeText,
+ field, simpleField, listField, spaceListField, commaListField,
+ optsField, liftField, boolField, parseQuoted,
+
+ UnrecFieldParser, warnUnrec, ignoreUnrec,
+ ) where
+
+import Distribution.Compiler (CompilerFlavor, parseCompilerFlavorCompat)
+import Distribution.License
+import Distribution.Version
+ ( Version(..), VersionRange, anyVersion )
+import Distribution.Package ( PackageName(..), Dependency(..) )
+import Distribution.ModuleName (ModuleName)
+import Distribution.Compat.ReadP as ReadP hiding (get)
+import Distribution.ReadE
+import Distribution.Text
+ ( Text(..) )
+import Distribution.Simple.Utils
+ ( comparing, intercalate, lowercase, normaliseLineEndings )
+import Language.Haskell.Extension
+ ( Language, Extension )
+
+import Text.PrettyPrint hiding (braces)
+import Data.Char (isSpace, toLower, isAlphaNum, isDigit)
+import Data.Maybe (fromMaybe)
+import Data.Tree as Tree (Tree(..), flatten)
+import qualified Data.Map as Map
+import Control.Monad (foldM)
+import System.FilePath (normalise)
+import Data.List (sortBy)
+
+-- -----------------------------------------------------------------------------
+
+type LineNo = Int
+
+data PError = AmbigousParse String LineNo
+ | NoParse String LineNo
+ | TabsError LineNo
+ | FromString String (Maybe LineNo)
+ deriving Show
+
+data PWarning = PWarning String
+ | UTFWarning LineNo String
+ deriving Show
+
+showPWarning :: FilePath -> PWarning -> String
+showPWarning fpath (PWarning msg) =
+ normalise fpath ++ ": " ++ msg
+showPWarning fpath (UTFWarning line fname) =
+ normalise fpath ++ ":" ++ show line
+ ++ ": Invalid UTF-8 text in the '" ++ fname ++ "' field."
+
+data ParseResult a = ParseFailed PError | ParseOk [PWarning] a
+ deriving Show
+
+instance Monad ParseResult where
+ return x = ParseOk [] x
+ ParseFailed err >>= _ = ParseFailed err
+ ParseOk ws x >>= f = case f x of
+ ParseFailed err -> ParseFailed err
+ ParseOk ws' x' -> ParseOk (ws'++ws) x'
+ fail s = ParseFailed (FromString s Nothing)
+
+catchParseError :: ParseResult a -> (PError -> ParseResult a)
+ -> ParseResult a
+p@(ParseOk _ _) `catchParseError` _ = p
+ParseFailed e `catchParseError` k = k e
+
+parseFail :: PError -> ParseResult a
+parseFail = ParseFailed
+
+runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a
+runP line fieldname p s =
+ case [ x | (x,"") <- results ] of
+ [a] -> ParseOk (utf8Warnings line fieldname s) a
+ --TODO: what is this double parse thing all about?
+ -- Can't we just do the all isSpace test the first time?
+ [] -> case [ x | (x,ys) <- results, all isSpace ys ] of
+ [a] -> ParseOk (utf8Warnings line fieldname s) a
+ [] -> ParseFailed (NoParse fieldname line)
+ _ -> ParseFailed (AmbigousParse fieldname line)
+ _ -> ParseFailed (AmbigousParse fieldname line)
+ where results = readP_to_S p s
+
+runE :: LineNo -> String -> ReadE a -> String -> ParseResult a
+runE line fieldname p s =
+ case runReadE p s of
+ Right a -> ParseOk (utf8Warnings line fieldname s) a
+ Left e -> syntaxError line $
+ "Parse of field '" ++ fieldname ++ "' failed (" ++ e ++ "): " ++ s
+
+utf8Warnings :: LineNo -> String -> String -> [PWarning]
+utf8Warnings line fieldname s =
+ take 1 [ UTFWarning n fieldname
+ | (n,l) <- zip [line..] (lines s)
+ , '\xfffd' `elem` l ]
+
+locatedErrorMsg :: PError -> (Maybe LineNo, String)
+locatedErrorMsg (AmbigousParse f n) = (Just n, "Ambiguous parse in field '"++f++"'.")
+locatedErrorMsg (NoParse f n) = (Just n, "Parse of field '"++f++"' failed.")
+locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.")
+locatedErrorMsg (FromString s n) = (n, s)
+
+syntaxError :: LineNo -> String -> ParseResult a
+syntaxError n s = ParseFailed $ FromString s (Just n)
+
+tabsError :: LineNo -> ParseResult a
+tabsError ln = ParseFailed $ TabsError ln
+
+warning :: String -> ParseResult ()
+warning s = ParseOk [PWarning s] ()
+
+-- | Field descriptor. The parameter @a@ parameterizes over where the field's
+-- value is stored in.
+data FieldDescr a
+ = FieldDescr
+ { fieldName :: String
+ , fieldGet :: a -> Doc
+ , fieldSet :: LineNo -> String -> a -> ParseResult a
+ -- ^ @fieldSet n str x@ Parses the field value from the given input
+ -- string @str@ and stores the result in @x@ if the parse was
+ -- successful. Otherwise, reports an error on line number @n@.
+ }
+
+field :: String -> (a -> Doc) -> (ReadP a a) -> FieldDescr a
+field name showF readF =
+ FieldDescr name showF (\line val _st -> runP line name readF val)
+
+-- Lift a field descriptor storing into an 'a' to a field descriptor storing
+-- into a 'b'.
+liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b
+liftField get set (FieldDescr name showF parseF)
+ = FieldDescr name (\b -> showF (get b))
+ (\line str b -> do
+ a <- parseF line str (get b)
+ return (set a b))
+
+-- Parser combinator for simple fields. Takes a field name, a pretty printer,
+-- a parser function, an accessor, and a setter, returns a FieldDescr over the
+-- compoid structure.
+simpleField :: String -> (a -> Doc) -> (ReadP a a)
+ -> (b -> a) -> (a -> b -> b) -> FieldDescr b
+simpleField name showF readF get set
+ = liftField get set $ field name showF readF
+
+commaListField :: String -> (a -> Doc) -> (ReadP [a] a)
+ -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
+commaListField name showF readF get set =
+ liftField get set' $
+ field name (fsep . punctuate comma . map showF) (parseCommaList readF)
+ where
+ set' xs b = set (get b ++ xs) b
+
+spaceListField :: String -> (a -> Doc) -> (ReadP [a] a)
+ -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
+spaceListField name showF readF get set =
+ liftField get set' $
+ field name (fsep . map showF) (parseSpaceList readF)
+ where
+ set' xs b = set (get b ++ xs) b
+
+listField :: String -> (a -> Doc) -> (ReadP [a] a)
+ -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b
+listField name showF readF get set =
+ liftField get set' $
+ field name (fsep . map showF) (parseOptCommaList readF)
+ where
+ set' xs b = set (get b ++ xs) b
+
+optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b
+optsField name flavor get set =
+ liftField (fromMaybe [] . lookup flavor . get)
+ (\opts b -> set (reorder (update flavor opts (get b))) b) $
+ field name (hsep . map text)
+ (sepBy parseTokenQ' (munch1 isSpace))
+ where
+ update _ opts l | all null opts = l --empty opts as if no opts
+ update f opts [] = [(f,opts)]
+ update f opts ((f',opts'):rest)
+ | f == f' = (f, opts' ++ opts) : rest
+ | otherwise = (f',opts') : update f opts rest
+ reorder = sortBy (comparing fst)
+
+-- TODO: this is a bit smelly hack. It's because we want to parse bool fields
+-- liberally but not accept new parses. We cannot do that with ReadP
+-- because it does not support warnings. We need a new parser framwork!
+boolField :: String -> (b -> Bool) -> (Bool -> b -> b) -> FieldDescr b
+boolField name get set = liftField get set (FieldDescr name showF readF)
+ where
+ showF = text . show
+ readF line str _
+ | str == "True" = ParseOk [] True
+ | str == "False" = ParseOk [] False
+ | lstr == "true" = ParseOk [caseWarning] True
+ | lstr == "false" = ParseOk [caseWarning] False
+ | otherwise = ParseFailed (NoParse name line)
+ where
+ lstr = lowercase str
+ caseWarning = PWarning $
+ "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'."
+
+ppFields :: [FieldDescr a] -> a -> Doc
+ppFields fields x = vcat [ ppField name (getter x)
+ | FieldDescr name getter _ <- fields]
+
+ppField :: String -> Doc -> Doc
+ppField name fielddoc = text name <> colon <+> fielddoc
+
+showFields :: [FieldDescr a] -> a -> String
+showFields fields = render . ($+$ text "") . ppFields fields
+
+showSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String)
+showSingleNamedField fields f =
+ case [ get | (FieldDescr f' get _) <- fields, f' == f ] of
+ [] -> Nothing
+ (get:_) -> Just (render . ppField f . get)
+
+parseFields :: [FieldDescr a] -> a -> String -> ParseResult a
+parseFields fields initial = \str ->
+ readFields str >>= accumFields fields initial
+
+parseFieldsFlat :: [FieldDescr a] -> a -> String -> ParseResult a
+parseFieldsFlat fields initial = \str ->
+ readFieldsFlat str >>= accumFields fields initial
+
+accumFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a
+accumFields fields = foldM setField
+ where
+ fieldMap = Map.fromList
+ [ (name, f) | f@(FieldDescr name _ _) <- fields ]
+ setField accum (F line name value) = case Map.lookup name fieldMap of
+ Just (FieldDescr _ _ set) -> set line value accum
+ Nothing -> do
+ warning ("Unrecognized field " ++ name ++ " on line " ++ show line)
+ return accum
+ setField accum f = do
+ warning ("Unrecognized stanza on line " ++ show (lineNo f))
+ return accum
+
+-- | The type of a function which, given a name-value pair of an
+-- unrecognized field, and the current structure being built,
+-- decides whether to incorporate the unrecognized field
+-- (by returning Just x, where x is a possibly modified version
+-- of the structure being built), or not (by returning Nothing).
+type UnrecFieldParser a = (String,String) -> a -> Maybe a
+
+-- | A default unrecognized field parser which simply returns Nothing,
+-- i.e. ignores all unrecognized fields, so warnings will be generated.
+warnUnrec :: UnrecFieldParser a
+warnUnrec _ _ = Nothing
+
+-- | A default unrecognized field parser which silently (i.e. no
+-- warnings will be generated) ignores unrecognized fields, by
+-- returning the structure being built unmodified.
+ignoreUnrec :: UnrecFieldParser a
+ignoreUnrec _ x = Just x
+
+------------------------------------------------------------------------------
+
+-- The data type for our three syntactic categories
+data Field
+ = F LineNo String String
+ -- ^ A regular @<property>: <value>@ field
+ | Section LineNo String String [Field]
+ -- ^ A section with a name and possible parameter. The syntactic
+ -- structure is:
+ --
+ -- @
+ -- <sectionname> <arg> {
+ -- <field>*
+ -- }
+ -- @
+ | IfBlock LineNo String [Field] [Field]
+ -- ^ A conditional block with an optional else branch:
+ --
+ -- @
+ -- if <condition> {
+ -- <field>*
+ -- } else {
+ -- <field>*
+ -- }
+ -- @
+ deriving (Show
+ ,Eq) -- for testing
+
+lineNo :: Field -> LineNo
+lineNo (F n _ _) = n
+lineNo (Section n _ _ _) = n
+lineNo (IfBlock n _ _ _) = n
+
+fName :: Field -> String
+fName (F _ n _) = n
+fName (Section _ n _ _) = n
+fName _ = error "fname: not a field or section"
+
+readFields :: String -> ParseResult [Field]
+readFields input = ifelse
+ =<< mapM (mkField 0)
+ =<< mkTree tokens
+
+ where ls = (lines . normaliseLineEndings) input
+ tokens = (concatMap tokeniseLine . trimLines) ls
+
+readFieldsFlat :: String -> ParseResult [Field]
+readFieldsFlat input = mapM (mkField 0)
+ =<< mkTree tokens
+ where ls = (lines . normaliseLineEndings) input
+ tokens = (concatMap tokeniseLineFlat . trimLines) ls
+
+-- attach line number and determine indentation
+trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)]
+trimLines ls = [ (lineno, indent, hastabs, (trimTrailing l'))
+ | (lineno, l) <- zip [1..] ls
+ , let (sps, l') = span isSpace l
+ indent = length sps
+ hastabs = '\t' `elem` sps
+ , validLine l' ]
+ where validLine ('-':'-':_) = False -- Comment
+ validLine [] = False -- blank line
+ validLine _ = True
+
+-- | We parse generically based on indent level and braces '{' '}'. To do that
+-- we split into lines and then '{' '}' tokens and other spans within a line.
+data Token =
+ -- | The 'Line' token is for bits that /start/ a line, eg:
+ --
+ -- > "\n blah blah { blah"
+ --
+ -- tokenises to:
+ --
+ -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"]
+ --
+ -- so lines are the only ones that can have nested layout, since they
+ -- have a known indentation level.
+ --
+ -- eg: we can't have this:
+ --
+ -- > if ... {
+ -- > } else
+ -- > other
+ --
+ -- because other cannot nest under else, since else doesn't start a line
+ -- so cannot have nested layout. It'd have to be:
+ --
+ -- > if ... {
+ -- > }
+ -- > else
+ -- > other
+ --
+ -- but that's not so common, people would normally use layout or
+ -- brackets not both in a single @if else@ construct.
+ --
+ -- > if ... { foo : bar }
+ -- > else
+ -- > other
+ --
+ -- this is ok
+ Line LineNo Indent HasTabs String
+ | Span LineNo String -- ^ span in a line, following brackets
+ | OpenBracket LineNo | CloseBracket LineNo
+
+type Indent = Int
+type HasTabs = Bool
+
+-- | Tokenise a single line, splitting on '{' '}' and the spans inbetween.
+-- Also trims leading & trailing space on those spans within the line.
+tokeniseLine :: (LineNo, Indent, HasTabs, String) -> [Token]
+tokeniseLine (n0, i, t, l) = case split n0 l of
+ (Span _ l':ss) -> Line n0 i t l' :ss
+ cs -> cs
+ where split _ "" = []
+ split n s = case span (\c -> c /='}' && c /= '{') s of
+ ("", '{' : s') -> OpenBracket n : split n s'
+ (w , '{' : s') -> mkspan n w (OpenBracket n : split n s')
+ ("", '}' : s') -> CloseBracket n : split n s'
+ (w , '}' : s') -> mkspan n w (CloseBracket n : split n s')
+ (w , _) -> mkspan n w []
+
+ mkspan n s ss | null s' = ss
+ | otherwise = Span n s' : ss
+ where s' = trimTrailing (trimLeading s)
+
+tokeniseLineFlat :: (LineNo, Indent, HasTabs, String) -> [Token]
+tokeniseLineFlat (n0, i, t, l)
+ | null l' = []
+ | otherwise = [Line n0 i t l']
+ where
+ l' = trimTrailing (trimLeading l)
+
+trimLeading, trimTrailing :: String -> String
+trimLeading = dropWhile isSpace
+trimTrailing = reverse . dropWhile isSpace . reverse
+
+
+type SyntaxTree = Tree (LineNo, HasTabs, String)
+
+-- | Parse the stream of tokens into a tree of them, based on indent \/ layout
+mkTree :: [Token] -> ParseResult [SyntaxTree]
+mkTree toks =
+ layout 0 [] toks >>= \(trees, trailing) -> case trailing of
+ [] -> return trees
+ OpenBracket n:_ -> syntaxError n "mismatched backets, unexpected {"
+ CloseBracket n:_ -> syntaxError n "mismatched backets, unexpected }"
+ -- the following two should never happen:
+ Span n l :_ -> syntaxError n $ "unexpected span: " ++ show l
+ Line n _ _ l :_ -> syntaxError n $ "unexpected line: " ++ show l
+
+
+-- | Parse the stream of tokens into a tree of them, based on indent
+-- This parse state expect to be in a layout context, though possibly
+-- nested within a braces context so we may still encounter closing braces.
+layout :: Indent -- ^ indent level of the parent\/previous line
+ -> [SyntaxTree] -- ^ accumulating param, trees in this level
+ -> [Token] -- ^ remaining tokens
+ -> ParseResult ([SyntaxTree], [Token])
+ -- ^ collected trees on this level and trailing tokens
+layout _ a [] = return (reverse a, [])
+layout i a (s@(Line _ i' _ _):ss) | i' < i = return (reverse a, s:ss)
+layout i a (Line n _ t l:OpenBracket n':ss) = do
+ (sub, ss') <- braces n' [] ss
+ layout i (Node (n,t,l) sub:a) ss'
+
+layout i a (Span n l:OpenBracket n':ss) = do
+ (sub, ss') <- braces n' [] ss
+ layout i (Node (n,False,l) sub:a) ss'
+
+-- look ahead to see if following lines are more indented, giving a sub-tree
+layout i a (Line n i' t l:ss) = do
+ lookahead <- layout (i'+1) [] ss
+ case lookahead of
+ ([], _) -> layout i (Node (n,t,l) [] :a) ss
+ (ts, ss') -> layout i (Node (n,t,l) ts :a) ss'
+
+layout _ _ ( OpenBracket n :_) = syntaxError n $ "unexpected '{'"
+layout _ a (s@(CloseBracket _):ss) = return (reverse a, s:ss)
+layout _ _ ( Span n l : _) = syntaxError n $ "unexpected span: "
+ ++ show l
+
+-- | Parse the stream of tokens into a tree of them, based on explicit braces
+-- This parse state expects to find a closing bracket.
+braces :: LineNo -- ^ line of the '{', used for error messages
+ -> [SyntaxTree] -- ^ accumulating param, trees in this level
+ -> [Token] -- ^ remaining tokens
+ -> ParseResult ([SyntaxTree],[Token])
+ -- ^ collected trees on this level and trailing tokens
+braces m a (Line n _ t l:OpenBracket n':ss) = do
+ (sub, ss') <- braces n' [] ss
+ braces m (Node (n,t,l) sub:a) ss'
+
+braces m a (Span n l:OpenBracket n':ss) = do
+ (sub, ss') <- braces n' [] ss
+ braces m (Node (n,False,l) sub:a) ss'
+
+braces m a (Line n i t l:ss) = do
+ lookahead <- layout (i+1) [] ss
+ case lookahead of
+ ([], _) -> braces m (Node (n,t,l) [] :a) ss
+ (ts, ss') -> braces m (Node (n,t,l) ts :a) ss'
+
+braces m a (Span n l:ss) = braces m (Node (n,False,l) []:a) ss
+braces _ a (CloseBracket _:ss) = return (reverse a, ss)
+braces n _ [] = syntaxError n $ "opening brace '{'"
+ ++ "has no matching closing brace '}'"
+braces _ _ (OpenBracket n:_) = syntaxError n "unexpected '{'"
+
+-- | Convert the parse tree into the Field AST
+-- Also check for dodgy uses of tabs in indentation.
+mkField :: Int -> SyntaxTree -> ParseResult Field
+mkField d (Node (n,t,_) _) | d >= 1 && t = tabsError n
+mkField d (Node (n,_,l) ts) = case span (\c -> isAlphaNum c || c == '-') l of
+ ([], _) -> syntaxError n $ "unrecognised field or section: " ++ show l
+ (name, rest) -> case trimLeading rest of
+ (':':rest') -> do let followingLines = concatMap Tree.flatten ts
+ tabs = not (null [()| (_,True,_) <- followingLines ])
+ if tabs && d >= 1
+ then tabsError n
+ else return $ F n (map toLower name)
+ (fieldValue rest' followingLines)
+ rest' -> do ts' <- mapM (mkField (d+1)) ts
+ return (Section n (map toLower name) rest' ts')
+ where fieldValue firstLine followingLines =
+ let firstLine' = trimLeading firstLine
+ followingLines' = map (\(_,_,s) -> stripDot s) followingLines
+ allLines | null firstLine' = followingLines'
+ | otherwise = firstLine' : followingLines'
+ in intercalate "\n" allLines
+ stripDot "." = ""
+ stripDot s = s
+
+-- | Convert if/then/else 'Section's to 'IfBlock's
+ifelse :: [Field] -> ParseResult [Field]
+ifelse [] = return []
+ifelse (Section n "if" cond thenpart
+ :Section _ "else" as elsepart:fs)
+ | null cond = syntaxError n "'if' with missing condition"
+ | null thenpart = syntaxError n "'then' branch of 'if' is empty"
+ | not (null as) = syntaxError n "'else' takes no arguments"
+ | null elsepart = syntaxError n "'else' branch of 'if' is empty"
+ | otherwise = do tp <- ifelse thenpart
+ ep <- ifelse elsepart
+ fs' <- ifelse fs
+ return (IfBlock n cond tp ep:fs')
+ifelse (Section n "if" cond thenpart:fs)
+ | null cond = syntaxError n "'if' with missing condition"
+ | null thenpart = syntaxError n "'then' branch of 'if' is empty"
+ | otherwise = do tp <- ifelse thenpart
+ fs' <- ifelse fs
+ return (IfBlock n cond tp []:fs')
+ifelse (Section n "else" _ _:_) = syntaxError n "stray 'else' with no preceding 'if'"
+ifelse (Section n s a fs':fs) = do fs'' <- ifelse fs'
+ fs''' <- ifelse fs
+ return (Section n s a fs'' : fs''')
+ifelse (f:fs) = do fs' <- ifelse fs
+ return (f : fs')
+
+------------------------------------------------------------------------------
+
+-- |parse a module name
+parseModuleNameQ :: ReadP r ModuleName
+parseModuleNameQ = parseQuoted parse <++ parse
+
+parseFilePathQ :: ReadP r FilePath
+parseFilePathQ = parseTokenQ
+ -- removed until normalise is no longer broken, was:
+ -- liftM normalise parseTokenQ
+
+parseBuildTool :: ReadP r Dependency
+parseBuildTool = do name <- parseBuildToolNameQ
+ skipSpaces
+ ver <- parseVersionRangeQ <++ return anyVersion
+ skipSpaces
+ return $ Dependency name ver
+
+parseBuildToolNameQ :: ReadP r PackageName
+parseBuildToolNameQ = parseQuoted parseBuildToolName <++ parseBuildToolName
+
+-- like parsePackageName but accepts symbols in components
+parseBuildToolName :: ReadP r PackageName
+parseBuildToolName = do ns <- sepBy1 component (ReadP.char '-')
+ return (PackageName (intercalate "-" ns))
+ where component = do
+ cs <- munch1 (\c -> isAlphaNum c || c == '+' || c == '_')
+ if all isDigit cs then pfail else return cs
+
+-- pkg-config allows versions and other letters in package names,
+-- eg "gtk+-2.0" is a valid pkg-config package _name_.
+-- It then has a package version number like 2.10.13
+parsePkgconfigDependency :: ReadP r Dependency
+parsePkgconfigDependency = do name <- munch1 (\c -> isAlphaNum c || c `elem` "+-._")
+ skipSpaces
+ ver <- parseVersionRangeQ <++ return anyVersion
+ skipSpaces
+ return $ Dependency (PackageName name) ver
+
+parsePackageNameQ :: ReadP r PackageName
+parsePackageNameQ = parseQuoted parse <++ parse
+
+parseVersionRangeQ :: ReadP r VersionRange
+parseVersionRangeQ = parseQuoted parse <++ parse
+
+parseOptVersion :: ReadP r Version
+parseOptVersion = parseQuoted ver <++ ver
+ where ver :: ReadP r Version
+ ver = parse <++ return noVersion
+ noVersion = Version{ versionBranch=[], versionTags=[] }
+
+parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange)
+parseTestedWithQ = parseQuoted tw <++ tw
+ where
+ tw :: ReadP r (CompilerFlavor,VersionRange)
+ tw = do compiler <- parseCompilerFlavorCompat
+ skipSpaces
+ version <- parse <++ return anyVersion
+ skipSpaces
+ return (compiler,version)
+
+parseLicenseQ :: ReadP r License
+parseLicenseQ = parseQuoted parse <++ parse
+
+-- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a
+-- because the "compat" version of ReadP isn't quite powerful enough. In
+-- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a
+-- Hence the trick above to make 'lic' polymorphic.
+
+parseLanguageQ :: ReadP r Language
+parseLanguageQ = parseQuoted parse <++ parse
+
+parseExtensionQ :: ReadP r Extension
+parseExtensionQ = parseQuoted parse <++ parse
+
+parseHaskellString :: ReadP r String
+parseHaskellString = readS_to_P reads
+
+parseTokenQ :: ReadP r String
+parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',')
+
+parseTokenQ' :: ReadP r String
+parseTokenQ' = parseHaskellString <++ munch1 (\x -> not (isSpace x))
+
+parseSepList :: ReadP r b
+ -> ReadP r a -- ^The parser for the stuff between commas
+ -> ReadP r [a]
+parseSepList sepr p = sepBy p separator
+ where separator = skipSpaces >> sepr >> skipSpaces
+
+parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas
+ -> ReadP r [a]
+parseSpaceList p = sepBy p skipSpaces
+
+parseCommaList :: ReadP r a -- ^The parser for the stuff between commas
+ -> ReadP r [a]
+parseCommaList = parseSepList (ReadP.char ',')
+
+parseOptCommaList :: ReadP r a -- ^The parser for the stuff between commas
+ -> ReadP r [a]
+parseOptCommaList = parseSepList (optional (ReadP.char ','))
+
+parseQuoted :: ReadP r a -> ReadP r a
+parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p
+
+parseFreeText :: ReadP.ReadP s String
+parseFreeText = ReadP.munch (const True)
+
+-- --------------------------------------------
+-- ** Pretty printing
+
+showFilePath :: FilePath -> Doc
+showFilePath = showToken
+
+showToken :: String -> Doc
+showToken str
+ | not (any dodgy str) &&
+ not (null str) = text str
+ | otherwise = text (show str)
+ where dodgy c = isSpace c || c == ','
+
+showTestedWith :: (CompilerFlavor,VersionRange) -> Doc
+showTestedWith (compiler, version) = text (show compiler) <+> disp version
+
+-- | Pretty-print free-format text, ensuring that it is vertically aligned,
+-- and with blank lines replaced by dots for correct re-parsing.
+showFreeText :: String -> Doc
+showFreeText "" = empty
+showFreeText ('\n' :r) = text " " $+$ text "." $+$ showFreeText r
+showFreeText s = vcat [text (if null l then "." else l) | l <- lines_ s]
+
+-- | 'lines_' breaks a string up into a list of strings at newline
+-- characters. The resulting strings do not contain newlines.
+lines_ :: String -> [String]
+lines_ [] = [""]
+lines_ s = let (l, s') = break (== '\n') s
+ in l : case s' of
+ [] -> []
+ (_:s'') -> lines_ s''
diff --git a/cabal/Cabal/Distribution/ReadE.hs b/cabal/Cabal/Distribution/ReadE.hs
new file mode 100644
index 0000000..ce165e2
--- /dev/null
+++ b/cabal/Cabal/Distribution/ReadE.hs
@@ -0,0 +1,81 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.ReadE
+-- Copyright : Jose Iborra 2008
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- Simple parsing with failure
+
+{- Copyright (c) 2007, Jose Iborra
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.ReadE (
+ -- * ReadE
+ ReadE(..), succeedReadE, failReadE,
+ -- * Projections
+ parseReadE, readEOrFail,
+ readP_to_E
+ ) where
+
+import Distribution.Compat.ReadP
+import Data.Char ( isSpace )
+
+-- | Parser with simple error reporting
+newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a}
+type ErrorMsg = String
+
+instance Functor ReadE where
+ fmap f (ReadE p) = ReadE $ \txt -> case p txt of
+ Right a -> Right (f a)
+ Left err -> Left err
+
+succeedReadE :: (String -> a) -> ReadE a
+succeedReadE f = ReadE (Right . f)
+
+failReadE :: ErrorMsg -> ReadE a
+failReadE = ReadE . const Left
+
+parseReadE :: ReadE a -> ReadP r a
+parseReadE (ReadE p) = do
+ txt <- look
+ either fail return (p txt)
+
+readEOrFail :: ReadE a -> (String -> a)
+readEOrFail r = either error id . runReadE r
+
+readP_to_E :: (String -> ErrorMsg) -> ReadP a a -> ReadE a
+readP_to_E err r =
+ ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt
+ , all isSpace s ]
+ of [] -> Left (err txt)
+ (p:_) -> Right p
diff --git a/cabal/Cabal/Distribution/Simple.hs b/cabal/Cabal/Distribution/Simple.hs
new file mode 100644
index 0000000..fef0523
--- /dev/null
+++ b/cabal/Cabal/Distribution/Simple.hs
@@ -0,0 +1,703 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Simple
+-- Copyright : Isaac Jones 2003-2005
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This is the command line front end to the Simple build system. When given
+-- the parsed command-line args and package information, is able to perform
+-- basic commands like configure, build, install, register, etc.
+--
+-- This module exports the main functions that Setup.hs scripts use. It
+-- re-exports the 'UserHooks' type, the standard entry points like
+-- 'defaultMain' and 'defaultMainWithHooks' and the predefined sets of
+-- 'UserHooks' that custom @Setup.hs@ scripts can extend to add their own
+-- behaviour.
+--
+-- This module isn't called \"Simple\" because it's simple. Far from
+-- it. It's called \"Simple\" because it does complicated things to
+-- simple software.
+--
+-- The original idea was that there could be different build systems that all
+-- presented the same compatible command line interfaces. There is still a
+-- "Distribution.Make" system but in practice no packages use it.
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+{-
+Work around this warning:
+libraries/Cabal/Distribution/Simple.hs:78:0:
+ Warning: In the use of `runTests'
+ (imported from Distribution.Simple.UserHooks):
+ Deprecated: "Please use the new testing interface instead!"
+-}
+{-# OPTIONS_GHC -fno-warn-deprecations #-}
+
+module Distribution.Simple (
+ module Distribution.Package,
+ module Distribution.Version,
+ module Distribution.License,
+ module Distribution.Simple.Compiler,
+ module Language.Haskell.Extension,
+ -- * Simple interface
+ defaultMain, defaultMainNoRead, defaultMainArgs,
+ -- * Customization
+ UserHooks(..), Args,
+ defaultMainWithHooks, defaultMainWithHooksArgs,
+ -- ** Standard sets of hooks
+ simpleUserHooks,
+ autoconfUserHooks,
+ defaultUserHooks, emptyUserHooks,
+ -- ** Utils
+ defaultHookedPackageDesc
+ ) where
+
+-- local
+import Distribution.Simple.Compiler hiding (Flag)
+import Distribution.Simple.UserHooks
+import Distribution.Package --must not specify imports, since we're exporting moule.
+import Distribution.PackageDescription
+ ( PackageDescription(..), GenericPackageDescription, Executable(..)
+ , updatePackageDescription, hasLibs
+ , HookedBuildInfo, emptyHookedBuildInfo )
+import Distribution.PackageDescription.Parse
+ ( readPackageDescription, readHookedBuildInfo )
+import Distribution.PackageDescription.Configuration
+ ( flattenPackageDescription )
+import Distribution.Simple.Program
+ ( defaultProgramConfiguration, addKnownPrograms, builtinPrograms
+ , restoreProgramConfiguration, reconfigurePrograms )
+import Distribution.Simple.PreProcess (knownSuffixHandlers, PPSuffixHandler)
+import Distribution.Simple.Setup
+import Distribution.Simple.Command
+
+import Distribution.Simple.Build ( build )
+import Distribution.Simple.SrcDist ( sdist )
+import Distribution.Simple.Register
+ ( register, unregister )
+
+import Distribution.Simple.Configure
+ ( getPersistBuildConfig, maybeGetPersistBuildConfig
+ , writePersistBuildConfig, checkPersistBuildConfigOutdated
+ , configure, checkForeignDeps )
+
+import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )
+import Distribution.Simple.Bench (bench)
+import Distribution.Simple.BuildPaths ( srcPref)
+import Distribution.Simple.Test (test)
+import Distribution.Simple.Install (install)
+import Distribution.Simple.Haddock (haddock, hscolour)
+import Distribution.Simple.Utils
+ (die, notice, info, warn, setupMessage, chattyTry,
+ defaultPackageDesc, defaultHookedPackageDesc,
+ rawSystemExitWithEnv, cabalVersion, topHandler )
+import Distribution.System
+ ( OS(..), buildOS )
+import Distribution.Verbosity
+import Language.Haskell.Extension
+import Distribution.Version
+import Distribution.License
+import Distribution.Text
+ ( display )
+
+-- Base
+import System.Environment(getArgs, getProgName, getEnvironment)
+import System.Directory(removeFile, doesFileExist,
+ doesDirectoryExist, removeDirectoryRecursive)
+import System.Exit
+import System.IO.Error (isDoesNotExistError)
+import Distribution.Compat.Exception (catchIO, throwIOIO)
+
+import Control.Monad (when)
+import Data.List (intersperse, unionBy, nub, (\\))
+
+-- | A simple implementation of @main@ for a Cabal setup script.
+-- It reads the package description file using IO, and performs the
+-- action specified on the command line.
+defaultMain :: IO ()
+defaultMain = getArgs >>= defaultMainHelper simpleUserHooks
+
+-- | A version of 'defaultMain' that is passed the command line
+-- arguments, rather than getting them from the environment.
+defaultMainArgs :: [String] -> IO ()
+defaultMainArgs = defaultMainHelper simpleUserHooks
+
+-- | A customizable version of 'defaultMain'.
+defaultMainWithHooks :: UserHooks -> IO ()
+defaultMainWithHooks hooks = getArgs >>= defaultMainHelper hooks
+
+-- | A customizable version of 'defaultMain' that also takes the command
+-- line arguments.
+defaultMainWithHooksArgs :: UserHooks -> [String] -> IO ()
+defaultMainWithHooksArgs = defaultMainHelper
+
+-- | Like 'defaultMain', but accepts the package description as input
+-- rather than using IO to read it.
+defaultMainNoRead :: GenericPackageDescription -> IO ()
+defaultMainNoRead pkg_descr =
+ getArgs >>=
+ defaultMainHelper simpleUserHooks { readDesc = return (Just pkg_descr) }
+
+defaultMainHelper :: UserHooks -> Args -> IO ()
+defaultMainHelper hooks args = topHandler $
+ case commandsRun globalCommand commands args of
+ CommandHelp help -> printHelp help
+ CommandList opts -> printOptionsList opts
+ CommandErrors errs -> printErrors errs
+ CommandReadyToGo (flags, commandParse) ->
+ case commandParse of
+ _ | fromFlag (globalVersion flags) -> printVersion
+ | fromFlag (globalNumericVersion flags) -> printNumericVersion
+ CommandHelp help -> printHelp help
+ CommandList opts -> printOptionsList opts
+ CommandErrors errs -> printErrors errs
+ CommandReadyToGo action -> action
+
+ where
+ printHelp help = getProgName >>= putStr . help
+ printOptionsList = putStr . unlines
+ printErrors errs = do
+ putStr (concat (intersperse "\n" errs))
+ exitWith (ExitFailure 1)
+ printNumericVersion = putStrLn $ display cabalVersion
+ printVersion = putStrLn $ "Cabal library version "
+ ++ display cabalVersion
+
+ progs = addKnownPrograms (hookedPrograms hooks) defaultProgramConfiguration
+ commands =
+ [configureCommand progs `commandAddAction` \fs as ->
+ configureAction hooks fs as >> return ()
+ ,buildCommand progs `commandAddAction` buildAction hooks
+ ,installCommand `commandAddAction` installAction hooks
+ ,copyCommand `commandAddAction` copyAction hooks
+ ,haddockCommand `commandAddAction` haddockAction hooks
+ ,cleanCommand `commandAddAction` cleanAction hooks
+ ,sdistCommand `commandAddAction` sdistAction hooks
+ ,hscolourCommand `commandAddAction` hscolourAction hooks
+ ,registerCommand `commandAddAction` registerAction hooks
+ ,unregisterCommand `commandAddAction` unregisterAction hooks
+ ,testCommand `commandAddAction` testAction hooks
+ ,benchmarkCommand `commandAddAction` benchAction hooks
+ ]
+
+-- | Combine the preprocessors in the given hooks with the
+-- preprocessors built into cabal.
+allSuffixHandlers :: UserHooks
+ -> [PPSuffixHandler]
+allSuffixHandlers hooks
+ = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers
+ where
+ overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler]
+ overridesPP = unionBy (\x y -> fst x == fst y)
+
+configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo
+configureAction hooks flags args = do
+ let distPref = fromFlag $ configDistPref flags
+ pbi <- preConf hooks args flags
+
+ (mb_pd_file, pkg_descr0) <- confPkgDescr
+
+ -- get_pkg_descr (configVerbosity flags')
+ --let pkg_descr = updatePackageDescription pbi pkg_descr0
+ let epkg_descr = (pkg_descr0, pbi)
+
+ --(warns, ers) <- sanityCheckPackage pkg_descr
+ --errorOut (configVerbosity flags') warns ers
+
+ localbuildinfo0 <- confHook hooks epkg_descr flags
+
+ -- remember the .cabal filename if we know it
+ -- and all the extra command line args
+ let localbuildinfo = localbuildinfo0 {
+ pkgDescrFile = mb_pd_file,
+ extraConfigArgs = args
+ }
+ writePersistBuildConfig distPref localbuildinfo
+
+ let pkg_descr = localPkgDescr localbuildinfo
+ postConf hooks args flags pkg_descr localbuildinfo
+ return localbuildinfo
+ where
+ verbosity = fromFlag (configVerbosity flags)
+ confPkgDescr :: IO (Maybe FilePath, GenericPackageDescription)
+ confPkgDescr = do
+ mdescr <- readDesc hooks
+ case mdescr of
+ Just descr -> return (Nothing, descr)
+ Nothing -> do
+ pdfile <- defaultPackageDesc verbosity
+ descr <- readPackageDescription verbosity pdfile
+ return (Just pdfile, descr)
+
+buildAction :: UserHooks -> BuildFlags -> Args -> IO ()
+buildAction hooks flags args = do
+ let distPref = fromFlag $ buildDistPref flags
+ verbosity = fromFlag $ buildVerbosity flags
+
+ lbi <- getBuildConfig hooks verbosity distPref
+ progs <- reconfigurePrograms verbosity
+ (buildProgramPaths flags)
+ (buildProgramArgs flags)
+ (withPrograms lbi)
+
+ hookedAction preBuild buildHook postBuild
+ (return lbi { withPrograms = progs })
+ hooks flags args
+
+hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO ()
+hscolourAction hooks flags args
+ = do let distPref = fromFlag $ hscolourDistPref flags
+ verbosity = fromFlag $ hscolourVerbosity flags
+ hookedAction preHscolour hscolourHook postHscolour
+ (getBuildConfig hooks verbosity distPref)
+ hooks flags args
+
+haddockAction :: UserHooks -> HaddockFlags -> Args -> IO ()
+haddockAction hooks flags args = do
+ let distPref = fromFlag $ haddockDistPref flags
+ verbosity = fromFlag $ haddockVerbosity flags
+
+ lbi <- getBuildConfig hooks verbosity distPref
+ progs <- reconfigurePrograms verbosity
+ (haddockProgramPaths flags)
+ (haddockProgramArgs flags)
+ (withPrograms lbi)
+
+ hookedAction preHaddock haddockHook postHaddock
+ (return lbi { withPrograms = progs })
+ hooks flags args
+
+cleanAction :: UserHooks -> CleanFlags -> Args -> IO ()
+cleanAction hooks flags args = do
+ pbi <- preClean hooks args flags
+
+ pdfile <- defaultPackageDesc verbosity
+ ppd <- readPackageDescription verbosity pdfile
+ let pkg_descr0 = flattenPackageDescription ppd
+ -- We don't sanity check for clean as an error
+ -- here would prevent cleaning:
+ --sanityCheckHookedBuildInfo pkg_descr0 pbi
+ let pkg_descr = updatePackageDescription pbi pkg_descr0
+
+ cleanHook hooks pkg_descr () hooks flags
+ postClean hooks args flags pkg_descr ()
+ where verbosity = fromFlag (cleanVerbosity flags)
+
+copyAction :: UserHooks -> CopyFlags -> Args -> IO ()
+copyAction hooks flags args
+ = do let distPref = fromFlag $ copyDistPref flags
+ verbosity = fromFlag $ copyVerbosity flags
+ hookedAction preCopy copyHook postCopy
+ (getBuildConfig hooks verbosity distPref)
+ hooks flags args
+
+installAction :: UserHooks -> InstallFlags -> Args -> IO ()
+installAction hooks flags args
+ = do let distPref = fromFlag $ installDistPref flags
+ verbosity = fromFlag $ installVerbosity flags
+ hookedAction preInst instHook postInst
+ (getBuildConfig hooks verbosity distPref)
+ hooks flags args
+
+sdistAction :: UserHooks -> SDistFlags -> Args -> IO ()
+sdistAction hooks flags args = do
+ let distPref = fromFlag $ sDistDistPref flags
+ pbi <- preSDist hooks args flags
+
+ mlbi <- maybeGetPersistBuildConfig distPref
+ pdfile <- defaultPackageDesc verbosity
+ ppd <- readPackageDescription verbosity pdfile
+ let pkg_descr0 = flattenPackageDescription ppd
+ sanityCheckHookedBuildInfo pkg_descr0 pbi
+ let pkg_descr = updatePackageDescription pbi pkg_descr0
+
+ sDistHook hooks pkg_descr mlbi hooks flags
+ postSDist hooks args flags pkg_descr mlbi
+ where verbosity = fromFlag (sDistVerbosity flags)
+
+testAction :: UserHooks -> TestFlags -> Args -> IO ()
+testAction hooks flags args = do
+ let distPref = fromFlag $ testDistPref flags
+ verbosity = fromFlag $ testVerbosity flags
+ localBuildInfo <- getBuildConfig hooks verbosity distPref
+ let pkg_descr = localPkgDescr localBuildInfo
+ -- It is safe to do 'runTests' before the new test handler because the
+ -- default action is a no-op and if the package uses the old test interface
+ -- the new handler will find no tests.
+ runTests hooks args False pkg_descr localBuildInfo
+ --FIXME: this is a hack, passing the args inside the flags
+ -- it's because the args to not get passed to the main test hook
+ let flags' = flags { testList = Flag args }
+ hookedAction preTest testHook postTest
+ (getBuildConfig hooks verbosity distPref)
+ hooks flags' args
+
+benchAction :: UserHooks -> BenchmarkFlags -> Args -> IO ()
+benchAction hooks flags args = do
+ let distPref = fromFlag $ benchmarkDistPref flags
+ verbosity = fromFlag $ benchmarkVerbosity flags
+ hookedActionWithArgs preBench benchHook postBench
+ (getBuildConfig hooks verbosity distPref)
+ hooks flags args
+
+registerAction :: UserHooks -> RegisterFlags -> Args -> IO ()
+registerAction hooks flags args
+ = do let distPref = fromFlag $ regDistPref flags
+ verbosity = fromFlag $ regVerbosity flags
+ hookedAction preReg regHook postReg
+ (getBuildConfig hooks verbosity distPref)
+ hooks flags args
+
+unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO ()
+unregisterAction hooks flags args
+ = do let distPref = fromFlag $ regDistPref flags
+ verbosity = fromFlag $ regVerbosity flags
+ hookedAction preUnreg unregHook postUnreg
+ (getBuildConfig hooks verbosity distPref)
+ hooks flags args
+
+hookedAction :: (UserHooks -> Args -> flags -> IO HookedBuildInfo)
+ -> (UserHooks -> PackageDescription -> LocalBuildInfo
+ -> UserHooks -> flags -> IO ())
+ -> (UserHooks -> Args -> flags -> PackageDescription
+ -> LocalBuildInfo -> IO ())
+ -> IO LocalBuildInfo
+ -> UserHooks -> flags -> Args -> IO ()
+hookedAction pre_hook cmd_hook =
+ hookedActionWithArgs pre_hook (\h _ pd lbi uh flags -> cmd_hook h pd lbi uh flags)
+
+hookedActionWithArgs :: (UserHooks -> Args -> flags -> IO HookedBuildInfo)
+ -> (UserHooks -> Args -> PackageDescription -> LocalBuildInfo
+ -> UserHooks -> flags -> IO ())
+ -> (UserHooks -> Args -> flags -> PackageDescription
+ -> LocalBuildInfo -> IO ())
+ -> IO LocalBuildInfo
+ -> UserHooks -> flags -> Args -> IO ()
+hookedActionWithArgs pre_hook cmd_hook post_hook get_build_config hooks flags args = do
+ pbi <- pre_hook hooks args flags
+ localbuildinfo <- get_build_config
+ let pkg_descr0 = localPkgDescr localbuildinfo
+ --pkg_descr0 <- get_pkg_descr (get_verbose flags)
+ sanityCheckHookedBuildInfo pkg_descr0 pbi
+ let pkg_descr = updatePackageDescription pbi pkg_descr0
+ -- TODO: should we write the modified package descr back to the
+ -- localbuildinfo?
+ cmd_hook hooks args pkg_descr localbuildinfo hooks flags
+ post_hook hooks args flags pkg_descr localbuildinfo
+
+sanityCheckHookedBuildInfo :: PackageDescription -> HookedBuildInfo -> IO ()
+sanityCheckHookedBuildInfo PackageDescription { library = Nothing } (Just _,_)
+ = die $ "The buildinfo contains info for a library, "
+ ++ "but the package does not have a library."
+
+sanityCheckHookedBuildInfo pkg_descr (_, hookExes)
+ | not (null nonExistant)
+ = die $ "The buildinfo contains info for an executable called '"
+ ++ head nonExistant ++ "' but the package does not have a "
+ ++ "executable with that name."
+ where
+ pkgExeNames = nub (map exeName (executables pkg_descr))
+ hookExeNames = nub (map fst hookExes)
+ nonExistant = hookExeNames \\ pkgExeNames
+
+sanityCheckHookedBuildInfo _ _ = return ()
+
+
+getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo
+getBuildConfig hooks verbosity distPref = do
+ lbi_wo_programs <- getPersistBuildConfig distPref
+ -- Restore info about unconfigured programs, since it is not serialized
+ let lbi = lbi_wo_programs {
+ withPrograms = restoreProgramConfiguration
+ (builtinPrograms ++ hookedPrograms hooks)
+ (withPrograms lbi_wo_programs)
+ }
+
+ case pkgDescrFile lbi of
+ Nothing -> return lbi
+ Just pkg_descr_file -> do
+ outdated <- checkPersistBuildConfigOutdated distPref pkg_descr_file
+ if outdated
+ then reconfigure pkg_descr_file lbi
+ else return lbi
+
+ where
+ reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo
+ reconfigure pkg_descr_file lbi = do
+ notice verbosity $ pkg_descr_file ++ " has been changed. "
+ ++ "Re-configuring with most recently used options. "
+ ++ "If this fails, please run configure manually.\n"
+ let cFlags = configFlags lbi
+ let cFlags' = cFlags {
+ -- Since the list of unconfigured programs is not serialized,
+ -- restore it to the same value as normally used at the beginning
+ -- of a conigure run:
+ configPrograms = restoreProgramConfiguration
+ (builtinPrograms ++ hookedPrograms hooks)
+ (configPrograms cFlags),
+
+ -- Use the current, not saved verbosity level:
+ configVerbosity = Flag verbosity
+ }
+ configureAction hooks cFlags' (extraConfigArgs lbi)
+
+
+-- --------------------------------------------------------------------------
+-- Cleaning
+
+clean :: PackageDescription -> CleanFlags -> IO ()
+clean pkg_descr flags = do
+ let distPref = fromFlag $ cleanDistPref flags
+ notice verbosity "cleaning..."
+
+ maybeConfig <- if fromFlag (cleanSaveConf flags)
+ then maybeGetPersistBuildConfig distPref
+ else return Nothing
+
+ -- remove the whole dist/ directory rather than tracking exactly what files
+ -- we created in there.
+ chattyTry "removing dist/" $ do
+ exists <- doesDirectoryExist distPref
+ when exists (removeDirectoryRecursive distPref)
+
+ -- Any extra files the user wants to remove
+ mapM_ removeFileOrDirectory (extraTmpFiles pkg_descr)
+
+ -- If the user wanted to save the config, write it back
+ maybe (return ()) (writePersistBuildConfig distPref) maybeConfig
+
+ where
+ removeFileOrDirectory :: FilePath -> IO ()
+ removeFileOrDirectory fname = do
+ isDir <- doesDirectoryExist fname
+ isFile <- doesFileExist fname
+ if isDir then removeDirectoryRecursive fname
+ else if isFile then removeFile fname
+ else return ()
+ verbosity = fromFlag (cleanVerbosity flags)
+
+-- --------------------------------------------------------------------------
+-- Default hooks
+
+-- | Hooks that correspond to a plain instantiation of the
+-- \"simple\" build system
+simpleUserHooks :: UserHooks
+simpleUserHooks =
+ emptyUserHooks {
+ confHook = configure,
+ postConf = finalChecks,
+ buildHook = defaultBuildHook,
+ copyHook = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params
+ testHook = defaultTestHook,
+ benchHook = defaultBenchHook,
+ instHook = defaultInstallHook,
+ sDistHook = \p l h f -> sdist p l f srcPref (allSuffixHandlers h),
+ cleanHook = \p _ _ f -> clean p f,
+ hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f,
+ haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f,
+ regHook = defaultRegHook,
+ unregHook = \p l _ f -> unregister p l f
+ }
+ where
+ finalChecks _args flags pkg_descr lbi =
+ checkForeignDeps pkg_descr lbi (lessVerbose verbosity)
+ where
+ verbosity = fromFlag (configVerbosity flags)
+
+-- | Basic autoconf 'UserHooks':
+--
+-- * 'postConf' runs @.\/configure@, if present.
+--
+-- * the pre-hooks 'preBuild', 'preClean', 'preCopy', 'preInst',
+-- 'preReg' and 'preUnreg' read additional build information from
+-- /package/@.buildinfo@, if present.
+--
+-- Thus @configure@ can use local system information to generate
+-- /package/@.buildinfo@ and possibly other files.
+
+{-# DEPRECATED defaultUserHooks
+ "Use simpleUserHooks or autoconfUserHooks, unless you need Cabal-1.2\n compatibility in which case you must stick with defaultUserHooks" #-}
+defaultUserHooks :: UserHooks
+defaultUserHooks = autoconfUserHooks {
+ confHook = \pkg flags -> do
+ let verbosity = fromFlag (configVerbosity flags)
+ warn verbosity $
+ "defaultUserHooks in Setup script is deprecated."
+ confHook autoconfUserHooks pkg flags,
+ postConf = oldCompatPostConf
+ }
+ -- This is the annoying old version that only runs configure if it exists.
+ -- It's here for compatibility with existing Setup.hs scripts. See:
+ -- http://hackage.haskell.org/trac/hackage/ticket/165
+ where oldCompatPostConf args flags pkg_descr lbi
+ = do let verbosity = fromFlag (configVerbosity flags)
+ noExtraFlags args
+ confExists <- doesFileExist "configure"
+ when confExists $
+ runConfigureScript verbosity
+ backwardsCompatHack flags lbi
+
+ pbi <- getHookedBuildInfo verbosity
+ sanityCheckHookedBuildInfo pkg_descr pbi
+ let pkg_descr' = updatePackageDescription pbi pkg_descr
+ postConf simpleUserHooks args flags pkg_descr' lbi
+
+ backwardsCompatHack = True
+
+autoconfUserHooks :: UserHooks
+autoconfUserHooks
+ = simpleUserHooks
+ {
+ postConf = defaultPostConf,
+ preBuild = readHook buildVerbosity,
+ preClean = readHook cleanVerbosity,
+ preCopy = readHook copyVerbosity,
+ preInst = readHook installVerbosity,
+ preHscolour = readHook hscolourVerbosity,
+ preHaddock = readHook haddockVerbosity,
+ preReg = readHook regVerbosity,
+ preUnreg = readHook regVerbosity
+ }
+ where defaultPostConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ()
+ defaultPostConf args flags pkg_descr lbi
+ = do let verbosity = fromFlag (configVerbosity flags)
+ noExtraFlags args
+ confExists <- doesFileExist "configure"
+ if confExists
+ then runConfigureScript verbosity
+ backwardsCompatHack flags lbi
+ else die "configure script not found."
+
+ pbi <- getHookedBuildInfo verbosity
+ sanityCheckHookedBuildInfo pkg_descr pbi
+ let pkg_descr' = updatePackageDescription pbi pkg_descr
+ postConf simpleUserHooks args flags pkg_descr' lbi
+
+ backwardsCompatHack = False
+
+ readHook :: (a -> Flag Verbosity) -> Args -> a -> IO HookedBuildInfo
+ readHook get_verbosity a flags = do
+ noExtraFlags a
+ getHookedBuildInfo verbosity
+ where
+ verbosity = fromFlag (get_verbosity flags)
+
+runConfigureScript :: Verbosity -> Bool -> ConfigFlags -> LocalBuildInfo
+ -> IO ()
+runConfigureScript verbosity backwardsCompatHack flags lbi = do
+
+ env <- getEnvironment
+ let programConfig = withPrograms lbi
+ (ccProg, ccFlags) <- configureCCompiler verbosity programConfig
+ -- The C compiler's compilation and linker flags (e.g.
+ -- "C compiler flags" and "Gcc Linker flags" from GHC) have already
+ -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS
+ -- to ccFlags
+ -- We don't try and tell configure which ld to use, as we don't have
+ -- a way to pass its flags too
+ let env' = appendToEnvironment ("CFLAGS", unwords ccFlags)
+ env
+ args' = args ++ ["--with-gcc=" ++ ccProg]
+ handleNoWindowsSH $
+ rawSystemExitWithEnv verbosity "sh" args' env'
+
+ where
+ args = "configure" : configureArgs backwardsCompatHack flags
+
+ appendToEnvironment (key, val) [] = [(key, val)]
+ appendToEnvironment (key, val) (kv@(k, v) : rest)
+ | key == k = (key, v ++ " " ++ val) : rest
+ | otherwise = kv : appendToEnvironment (key, val) rest
+
+ handleNoWindowsSH action
+ | buildOS /= Windows
+ = action
+
+ | otherwise
+ = action
+ `catchIO` \ioe -> if isDoesNotExistError ioe
+ then die notFoundMsg
+ else throwIOIO ioe
+
+ notFoundMsg = "The package has a './configure' script. This requires a "
+ ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin."
+
+getHookedBuildInfo :: Verbosity -> IO HookedBuildInfo
+getHookedBuildInfo verbosity = do
+ maybe_infoFile <- defaultHookedPackageDesc
+ case maybe_infoFile of
+ Nothing -> return emptyHookedBuildInfo
+ Just infoFile -> do
+ info verbosity $ "Reading parameters from " ++ infoFile
+ readHookedBuildInfo verbosity infoFile
+
+defaultTestHook :: PackageDescription -> LocalBuildInfo
+ -> UserHooks -> TestFlags -> IO ()
+defaultTestHook pkg_descr localbuildinfo _ flags =
+ test pkg_descr localbuildinfo flags
+
+defaultBenchHook :: Args -> PackageDescription -> LocalBuildInfo
+ -> UserHooks -> BenchmarkFlags -> IO ()
+defaultBenchHook args pkg_descr localbuildinfo _ flags =
+ bench args pkg_descr localbuildinfo flags
+
+defaultInstallHook :: PackageDescription -> LocalBuildInfo
+ -> UserHooks -> InstallFlags -> IO ()
+defaultInstallHook pkg_descr localbuildinfo _ flags = do
+ let copyFlags = defaultCopyFlags {
+ copyDistPref = installDistPref flags,
+ copyDest = toFlag NoCopyDest,
+ copyVerbosity = installVerbosity flags
+ }
+ install pkg_descr localbuildinfo copyFlags
+ let registerFlags = defaultRegisterFlags {
+ regDistPref = installDistPref flags,
+ regInPlace = installInPlace flags,
+ regPackageDB = installPackageDB flags,
+ regVerbosity = installVerbosity flags
+ }
+ when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags
+
+defaultBuildHook :: PackageDescription -> LocalBuildInfo
+ -> UserHooks -> BuildFlags -> IO ()
+defaultBuildHook pkg_descr localbuildinfo hooks flags =
+ build pkg_descr localbuildinfo flags (allSuffixHandlers hooks)
+
+defaultRegHook :: PackageDescription -> LocalBuildInfo
+ -> UserHooks -> RegisterFlags -> IO ()
+defaultRegHook pkg_descr localbuildinfo _ flags =
+ if hasLibs pkg_descr
+ then register pkg_descr localbuildinfo flags
+ else setupMessage verbosity
+ "Package contains no library to register:" (packageId pkg_descr)
+ where verbosity = fromFlag (regVerbosity flags)
diff --git a/cabal/Cabal/Distribution/Simple/Bench.hs b/cabal/Cabal/Distribution/Simple/Bench.hs
new file mode 100644
index 0000000..f34c888
--- /dev/null
+++ b/cabal/Cabal/Distribution/Simple/Bench.hs
@@ -0,0 +1,156 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Simple.Bench
+-- Copyright : Johan Tibell 2011
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This is the entry point into running the benchmarks in a built
+-- package. It performs the \"@.\/setup bench@\" action. It runs
+-- benchmarks designated in the package description.
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.Simple.Bench
+ ( bench
+ ) where
+
+import qualified Distribution.PackageDescription as PD
+ ( PackageDescription(..), BuildInfo(buildable)
+ , Benchmark(..), BenchmarkInterface(..), benchmarkType, hasBenchmarks )
+import Distribution.Simple.BuildPaths ( exeExtension )
+import Distribution.Simple.Compiler ( Compiler(..) )
+import Distribution.Simple.InstallDirs
+ ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)
+ , substPathTemplate , toPathTemplate, PathTemplate )
+import qualified Distribution.Simple.LocalBuildInfo as LBI
+ ( LocalBuildInfo(..) )
+import Distribution.Simple.Setup ( BenchmarkFlags(..), fromFlag )
+import Distribution.Simple.UserHooks ( Args )
+import Distribution.Simple.Utils ( die, notice, rawSystemExitCode )
+import Distribution.Text
+
+import Control.Monad ( when, unless )
+import System.Exit ( ExitCode(..), exitFailure, exitWith )
+import System.Directory ( doesFileExist )
+import System.FilePath ( (</>), (<.>) )
+
+-- | Perform the \"@.\/setup bench@\" action.
+bench :: Args -- ^positional command-line arguments
+ -> PD.PackageDescription -- ^information from the .cabal file
+ -> LBI.LocalBuildInfo -- ^information from the configure step
+ -> BenchmarkFlags -- ^flags sent to benchmark
+ -> IO ()
+bench args pkg_descr lbi flags = do
+ let verbosity = fromFlag $ benchmarkVerbosity flags
+ benchmarkNames = args
+ pkgBenchmarks = PD.benchmarks pkg_descr
+ enabledBenchmarks = [ t | t <- pkgBenchmarks
+ , PD.benchmarkEnabled t
+ , PD.buildable (PD.benchmarkBuildInfo t) ]
+
+ -- Run the benchmark
+ doBench :: PD.Benchmark -> IO ExitCode
+ doBench bm =
+ case PD.benchmarkInterface bm of
+ PD.BenchmarkExeV10 _ _ -> do
+ let cmd = LBI.buildDir lbi </> PD.benchmarkName bm
+ </> PD.benchmarkName bm <.> exeExtension
+ options = map (benchOption pkg_descr lbi bm) $
+ benchmarkOptions flags
+ name = PD.benchmarkName bm
+ -- Check that the benchmark executable exists.
+ exists <- doesFileExist cmd
+ unless exists $ die $
+ "Error: Could not find benchmark program \""
+ ++ cmd ++ "\". Did you build the package first?"
+
+ notice verbosity $ startMessage name
+ -- This will redirect the child process
+ -- stdout/stderr to the parent process.
+ exitcode <- rawSystemExitCode verbosity cmd options
+ notice verbosity $ finishMessage name exitcode
+ return exitcode
+
+ _ -> do
+ notice verbosity $ "No support for running "
+ ++ "benchmark " ++ PD.benchmarkName bm ++ " of type: "
+ ++ show (disp $ PD.benchmarkType bm)
+ exitFailure
+
+ when (not $ PD.hasBenchmarks pkg_descr) $ do
+ notice verbosity "Package has no benchmarks."
+ exitWith ExitSuccess
+
+ when (PD.hasBenchmarks pkg_descr && null enabledBenchmarks) $
+ die $ "No benchmarks enabled. Did you remember to configure with "
+ ++ "\'--enable-benchmarks\'?"
+
+ bmsToRun <- case benchmarkNames of
+ [] -> return enabledBenchmarks
+ names -> flip mapM names $ \bmName ->
+ let benchmarkMap = zip enabledNames enabledBenchmarks
+ enabledNames = map PD.benchmarkName enabledBenchmarks
+ allNames = map PD.benchmarkName pkgBenchmarks
+ in case lookup bmName benchmarkMap of
+ Just t -> return t
+ _ | bmName `elem` allNames ->
+ die $ "Package configured with benchmark "
+ ++ bmName ++ " disabled."
+ | otherwise -> die $ "no such benchmark: " ++ bmName
+
+ let totalBenchmarks = length bmsToRun
+ notice verbosity $ "Running " ++ show totalBenchmarks ++ " benchmarks..."
+ exitcodes <- mapM doBench bmsToRun
+ let allOk = totalBenchmarks == length (filter (== ExitSuccess) exitcodes)
+ unless allOk exitFailure
+ where
+ startMessage name = "Benchmark " ++ name ++ ": RUNNING...\n"
+ finishMessage name exitcode = "Benchmark " ++ name ++ ": "
+ ++ (case exitcode of
+ ExitSuccess -> "FINISH"
+ ExitFailure _ -> "ERROR")
+
+
+-- TODO: This is abusing the notion of a 'PathTemplate'. The result
+-- isn't neccesarily a path.
+benchOption :: PD.PackageDescription
+ -> LBI.LocalBuildInfo
+ -> PD.Benchmark
+ -> PathTemplate
+ -> String
+benchOption pkg_descr lbi bm template =
+ fromPathTemplate $ substPathTemplate env template
+ where
+ env = initialPathTemplateEnv
+ (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) ++
+ [(BenchmarkNameVar, toPathTemplate $ PD.benchmarkName bm)]
diff --git a/cabal/Cabal/Distribution/Simple/Build.hs b/cabal/Cabal/Distribution/Simple/Build.hs
new file mode 100644
index 0000000..6fbcfb1
--- /dev/null
+++ b/cabal/Cabal/Distribution/Simple/Build.hs
@@ -0,0 +1,349 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Simple.Build
+-- Copyright : Isaac Jones 2003-2005,
+-- Ross Paterson 2006,
+-- Duncan Coutts 2007-2008
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- This is the entry point to actually building the modules in a package. It
+-- doesn't actually do much itself, most of the work is delegated to
+-- compiler-specific actions. It does do some non-compiler specific bits like
+-- running pre-processors.
+--
+
+{- Copyright (c) 2003-2005, Isaac Jones
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.Simple.Build (
+ build,
+
+ initialBuildSteps,
+ writeAutogenFiles,
+ ) where
+
+import qualified Distribution.Simple.GHC as GHC
+import qualified Distribution.Simple.JHC as JHC
+import qualified Distribution.Simple.LHC as LHC
+import qualified Distribution.Simple.NHC as NHC
+import qualified Distribution.Simple.Hugs as Hugs
+import qualified Distribution.Simple.UHC as UHC
+
+import qualified Distribution.Simple.Build.Macros as Build.Macros
+import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule
+
+import Distribution.Package
+ ( Package(..), PackageName(..), PackageIdentifier(..)
+ , Dependency(..), thisPackageVersion )
+import Distribution.Simple.Compiler
+ ( CompilerFlavor(..), compilerFlavor, PackageDB(..) )
+import Distribution.PackageDescription
+ ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..)
+ , TestSuite(..), TestSuiteInterface(..), Benchmark(..)
+ , BenchmarkInterface(..) )
+import qualified Distribution.InstalledPackageInfo as IPI
+import qualified Distribution.ModuleName as ModuleName
+
+import Distribution.Simple.Setup
+ ( BuildFlags(..), fromFlag )
+import Distribution.Simple.PreProcess
+ ( preprocessComponent, PPSuffixHandler )
+import Distribution.Simple.LocalBuildInfo
+ ( LocalBuildInfo(compiler, buildDir, withPackageDB, withPrograms)
+ , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI
+ , componentBuildInfo, inplacePackageId )
+import Distribution.Simple.Program.Types
+import Distribution.Simple.Program.Db
+import Distribution.Simple.BuildPaths
+ ( autogenModulesDir, autogenModuleName, cppHeaderName, exeExtension )
+import Distribution.Simple.Register
+ ( registerPackage, inplaceInstalledPackageInfo )
+import Distribution.Simple.Test ( stubFilePath, stubName )
+import Distribution.Simple.Utils
+ ( createDirectoryIfMissingVerbose, rewriteFile
+ , die, info, setupMessage )
+
+import Distribution.Verbosity
+ ( Verbosity )
+import Distribution.Text
+ ( display )
+
+import Data.Maybe
+ ( maybeToList )
+import Data.List
+ ( intersect )
+import Control.Monad
+ ( unless )
+import System.FilePath
+ ( (</>), (<.>) )
+import System.Directory
+ ( getCurrentDirectory )
+
+-- -----------------------------------------------------------------------------
+-- |Build the libraries and executables in this package.
+
+build :: PackageDescription -- ^ Mostly information from the .cabal file
+ -> LocalBuildInfo -- ^ Configuration information
+ -> BuildFlags -- ^ Flags that the user passed to build
+ -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling
+ -> IO ()
+build pkg_descr lbi flags suffixes = do
+ let distPref = fromFlag (buildDistPref flags)
+ verbosity = fromFlag (buildVerbosity flags)
+ initialBuildSteps distPref pkg_descr lbi verbosity
+ setupMessage verbosity "Building" (packageId pkg_descr)
+
+ internalPackageDB <- createInternalPackageDB distPref
+
+ withComponentsLBI pkg_descr lbi $ \comp clbi ->
+ let bi = componentBuildInfo comp
+ progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)
+ lbi' = lbi {
+ withPrograms = progs',
+ withPackageDB = withPackageDB lbi ++ [internalPackageDB]
+ }
+ in buildComponent verbosity pkg_descr lbi' suffixes comp clbi distPref
+
+
+buildComponent :: Verbosity
+ -> PackageDescription
+ -> LocalBuildInfo
+ -> [PPSuffixHandler]
+ -> Component
+ -> ComponentLocalBuildInfo
+ -> FilePath
+ -> IO ()
+buildComponent verbosity pkg_descr lbi suffixes
+ comp@(CLib lib) clbi distPref = do
+ preprocessComponent pkg_descr comp lbi False verbosity suffixes
+ info verbosity "Building library..."
+ buildLib verbosity pkg_descr lbi lib clbi
+
+ -- Register the library in-place, so exes can depend
+ -- on internally defined libraries.
+ pwd <- getCurrentDirectory
+ let installedPkgInfo =
+ (inplaceInstalledPackageInfo pwd distPref pkg_descr lib lbi clbi) {
+ -- The inplace registration uses the "-inplace" suffix,
+ -- not an ABI hash.
+ IPI.installedPackageId = inplacePackageId (packageId installedPkgInfo)
+ }
+ registerPackage verbosity
+ installedPkgInfo pkg_descr lbi True -- True meaning inplace
+ (withPackageDB lbi)
+
+
+buildComponent verbosity pkg_descr lbi suffixes
+ comp@(CExe exe) clbi _ = do
+ preprocessComponent pkg_descr comp lbi False verbosity suffixes
+ info verbosity $ "Building executable " ++ exeName exe ++ "..."
+ buildExe verbosity pkg_descr lbi exe clbi
+
+
+buildComponent verbosity pkg_descr lbi suffixes
+ comp@(CTest
+ test@TestSuite { testInterface = TestSuiteExeV10 _ f })
+ clbi _distPref = do
+ let bi = testBuildInfo test
+ exe = Executable {
+ exeName = testName test,
+ modulePath = f,
+ buildInfo = bi
+ }
+ preprocessComponent pkg_descr comp lbi False verbosity suffixes
+ info verbosity $ "Building test suite " ++ testName test ++ "..."
+ buildExe verbosity pkg_descr lbi exe clbi
+
+
+buildComponent verbosity pkg_descr lbi suffixes
+ comp@(CTest
+ test@TestSuite { testInterface = TestSuiteLibV09 _ m })
+ clbi distPref = do
+ pwd <- getCurrentDirectory
+ let bi = testBuildInfo test
+ lib = Library {
+ exposedModules = [ m ],
+ libExposed = True,
+ libBuildInfo = bi
+ }
+ pkg = pkg_descr {
+ package = (package pkg_descr) {
+ pkgName = PackageName (testName test)
+ }
+ , buildDepends = targetBuildDepends $ testBuildInfo test
+ , executables = []
+ , testSuites = []
+ , library = Just lib
+ }
+ ipi = (inplaceInstalledPackageInfo pwd distPref pkg lib lbi clbi) {
+ IPI.installedPackageId = inplacePackageId $ packageId ipi
+ }
+ testDir = buildDir lbi </> stubName test
+ </> stubName test ++ "-tmp"
+ testLibDep = thisPackageVersion $ package pkg
+ exe = Executable {
+ exeName = stubName test,
+ modulePath = stubFilePath test,
+ buildInfo = (testBuildInfo test) {
+ hsSourceDirs = [ testDir ],
+ targetBuildDepends = testLibDep
+ : (targetBuildDepends $ testBuildInfo test)
+ }
+ }
+ -- | The stub executable needs a new 'ComponentLocalBuildInfo'
+ -- that exposes the relevant test suite library.
+ exeClbi = clbi {
+ componentPackageDeps =
+ (IPI.installedPackageId ipi, packageId ipi)
+ : (filter (\(_, x) -> let PackageName name = pkgName x
+ in name == "Cabal" || name == "base")
+ (componentPackageDeps clbi))
+ }
+ preprocessComponent pkg_descr comp lbi False verbosity suffixes
+ info verbosity $ "Building test suite " ++ testName test ++ "..."
+ buildLib verbosity pkg lbi lib clbi
+ registerPackage verbosity ipi pkg lbi True $ withPackageDB lbi
+ buildExe verbosity pkg_descr lbi exe exeClbi
+
+
+buildComponent _ _ _ _
+ (CTest TestSuite { testInterface = TestSuiteUnsupported tt })
+ _ _ =
+ die $ "No support for building test suite type " ++ display tt
+
+
+buildComponent verbosity pkg_descr lbi suffixes
+ comp@(CBench
+ bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f })
+ clbi _ = do
+ let bi = benchmarkBuildInfo bm
+ exe = Executable
+ { exeName = benchmarkName bm
+ , modulePath = f
+ , buildInfo = bi
+ }
+ preprocessComponent pkg_descr comp lbi False verbosity suffixes
+ info verbosity $ "Building benchmark " ++ benchmarkName bm ++ "..."
+ buildExe verbosity pkg_descr lbi exe clbi
+
+
+buildComponent _ _ _ _
+ (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt })
+ _ _ =
+ die $ "No support for building benchmark type " ++ display tt
+
+
+-- | Initialize a new package db file for libraries defined
+-- internally to the package.
+createInternalPackageDB :: FilePath -> IO PackageDB
+createInternalPackageDB distPref = do
+ let dbFile = distPref </> "package.conf.inplace"
+ packageDB = SpecificPackageDB dbFile
+ writeFile dbFile "[]"
+ return packageDB
+
+addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo
+ -> ProgramDb -> ProgramDb
+addInternalBuildTools pkg lbi bi progs =
+ foldr updateProgram progs internalBuildTools
+ where
+ internalBuildTools =
+ [ simpleConfiguredProgram toolName (FoundOnSystem toolLocation)
+ | toolName <- toolNames
+ , let toolLocation = buildDir lbi </> toolName </> toolName <.> exeExtension ]
+ toolNames = intersect buildToolNames internalExeNames
+ internalExeNames = map exeName (executables pkg)
+ buildToolNames = map buildToolName (buildTools bi)
+ where
+ buildToolName (Dependency (PackageName name) _ ) = name
+
+
+-- TODO: build separate libs in separate dirs so that we can build
+-- multiple libs, e.g. for 'LibTest' library-style testsuites
+buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo
+ -> Library -> ComponentLocalBuildInfo -> IO ()
+buildLib verbosity pkg_descr lbi lib clbi =
+ case compilerFlavor (compiler lbi) of
+ GHC -> GHC.buildLib verbosity pkg_descr lbi lib clbi
+ JHC -> JHC.buildLib verbosity pkg_descr lbi lib clbi
+ LHC -> LHC.buildLib verbosity pkg_descr lbi lib clbi
+ Hugs -> Hugs.buildLib verbosity pkg_descr lbi lib clbi
+ NHC -> NHC.buildLib verbosity pkg_descr lbi lib clbi
+ UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi
+ _ -> die "Building is not supported with this compiler."
+
+buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo
+ -> Executable -> ComponentLocalBuildInfo -> IO ()
+buildExe verbosity pkg_descr lbi exe clbi =
+ case compilerFlavor (compiler lbi) of
+ GHC -> GHC.buildExe verbosity pkg_descr lbi exe clbi
+ JHC -> JHC.buildExe verbosity pkg_descr lbi exe clbi
+ LHC -> LHC.buildExe verbosity pkg_descr lbi exe clbi
+ Hugs -> Hugs.buildExe verbosity pkg_descr lbi exe clbi
+ NHC -> NHC.buildExe verbosity pkg_descr lbi exe clbi
+ UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi
+ _ -> die "Building is not supported with this compiler."
+
+initialBuildSteps :: FilePath -- ^"dist" prefix
+ -> PackageDescription -- ^mostly information from the .cabal file
+ -> LocalBuildInfo -- ^Configuration information
+ -> Verbosity -- ^The verbosity to use
+ -> IO ()
+initialBuildSteps _distPref pkg_descr lbi verbosity = do
+ -- check that there's something to build
+ let buildInfos =
+ map libBuildInfo (maybeToList (library pkg_descr)) ++
+ map buildInfo (executables pkg_descr)