summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSergeiTrofimovich <>2020-12-18 21:21:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-12-18 21:21:00 (GMT)
commit1c627324540b5e5dd26d8d132ce0b45fcc822416 (patch)
tree19633a594668dc9836a540c845d4d5980000fa5f
parent6a34325817453a52d191983799f983e9605ce870 (diff)
version 0.6.7HEAD0.6.7master
-rw-r--r--Main.hs12
-rw-r--r--Merge.hs115
-rw-r--r--Merge/Dependencies.hs19
-rw-r--r--Merge/Utils.hs44
-rw-r--r--Portage/Cabal.hs9
-rw-r--r--Portage/Dependency/Builder.hs4
-rw-r--r--Portage/Dependency/Types.hs37
-rw-r--r--Portage/EBuild.hs38
-rw-r--r--Portage/Host.hs11
-rw-r--r--Portage/Metadata.hs75
-rw-r--r--Portage/Overlay.hs2
-rw-r--r--Portage/PackageId.hs10
-rw-r--r--Portage/Use.hs12
-rw-r--r--Portage/Version.hs12
-rw-r--r--Status.hs9
-rw-r--r--hackport.cabal12
-rw-r--r--tests/Merge/UtilsSpec.hs14
-rw-r--r--tests/Merge/UtilsSpec.hs~53
-rw-r--r--tests/Portage/EBuildSpec.hs5
-rw-r--r--tests/Portage/MetadataSpec.hs42
-rw-r--r--tests/Portage/VersionSpec.hs6
-rw-r--r--tests/QuickCheck/Instances.hs2
22 files changed, 356 insertions, 187 deletions
diff --git a/Main.hs b/Main.hs
index bf9afd2..495f7d3 100644
--- a/Main.hs
+++ b/Main.hs
@@ -5,8 +5,6 @@ module Main (main) where
import Control.Monad
import Data.Maybe
import Data.List
-import Data.Monoid
- ( Monoid(..) )
import qualified Data.Semigroup as S
-- cabal
@@ -63,13 +61,11 @@ data ListFlags = ListFlags {
listVerbosity :: Flag Verbosity
}
-#if MIN_VERSION_base(4,9,0)
instance S.Semigroup ListFlags where
a <> b = ListFlags {
listVerbosity = combine listVerbosity
}
where combine field = field a S.<> field b
-#endif
instance Monoid ListFlags where
mempty = ListFlags {
@@ -136,21 +132,19 @@ data MakeEbuildFlags = MakeEbuildFlags {
, makeEbuildCabalFlags :: Flag (Maybe String)
}
-#if MIN_VERSION_base(4,9,0)
instance S.Semigroup MakeEbuildFlags where
a <> b = MakeEbuildFlags {
makeEbuildVerbosity = combine makeEbuildVerbosity
, makeEbuildCabalFlags = makeEbuildCabalFlags b
}
where combine field = field a S.<> field b
-#endif
instance Monoid MakeEbuildFlags where
mempty = MakeEbuildFlags {
makeEbuildVerbosity = mempty
, makeEbuildCabalFlags = mempty
}
-#if MIN_VERSION_base(4,9,0)
+#if !MIN_VERSION_base(4,11,0)
mappend a b = MakeEbuildFlags {
makeEbuildVerbosity = combine makeEbuildVerbosity
, makeEbuildCabalFlags = makeEbuildCabalFlags b
@@ -208,13 +202,11 @@ data UpdateFlags = UpdateFlags {
updateVerbosity :: Flag Verbosity
}
-#if MIN_VERSION_base(4,9,0)
instance S.Semigroup UpdateFlags where
a <> b = UpdateFlags {
updateVerbosity = combine updateVerbosity
}
where combine field = field a S.<> field b
-#endif
instance Monoid UpdateFlags where
mempty = UpdateFlags {
@@ -322,14 +314,12 @@ data MergeFlags = MergeFlags {
, mergeCabalFlags :: Flag (Maybe String)
}
-#if MIN_VERSION_base(4,9,0)
instance S.Semigroup MergeFlags where
a <> b = MergeFlags {
mergeVerbosity = combine mergeVerbosity
, mergeCabalFlags = mergeCabalFlags b
}
where combine field = field a S.<> field b
-#endif
instance Monoid MergeFlags where
mempty = MergeFlags {
diff --git a/Merge.hs b/Merge.hs
index 5d90d73..5fd3024 100644
--- a/Merge.hs
+++ b/Merge.hs
@@ -10,13 +10,14 @@ module Merge
, mergeGenericPackageDescription
) where
-import Control.Monad
-import Control.Exception
+import Control.Concurrent.Async
+import Control.Monad
+import Control.Exception
import qualified Data.Text as T
import qualified Data.Text.IO as T
-import Data.Function (on)
+import Data.Function (on)
import qualified Data.Map.Strict as Map
-import Data.Maybe
+import Data.Maybe
import qualified Data.List as L
import qualified Data.Set as S
import qualified Data.Time.Clock as TC
@@ -29,31 +30,33 @@ import qualified Distribution.PackageDescription.PrettyPrint as Cabal (showPacka
import qualified Distribution.Solver.Types.SourcePackage as CabalInstall
import qualified Distribution.Solver.Types.PackageIndex as CabalInstall
-import Distribution.Pretty (prettyShow)
-import Distribution.Verbosity
-import Distribution.Simple.Utils
+import Distribution.Pretty (prettyShow)
+import Distribution.Verbosity
+import Distribution.Simple.Utils
-- cabal-install
-import Distribution.Client.IndexUtils ( getSourcePackages )
+import Distribution.Client.IndexUtils ( getSourcePackages )
import qualified Distribution.Client.GlobalFlags as CabalInstall
-import Distribution.Client.Types
+import Distribution.Client.Types
-- others
+import Control.Parallel.Strategies
import qualified Data.List.Split as DLS
-import System.Directory ( getCurrentDirectory
+import System.Directory ( getCurrentDirectory
, setCurrentDirectory
, createDirectoryIfMissing
, doesFileExist
, listDirectory
)
-import System.Process (system)
-import System.FilePath ((</>),(<.>))
-import System.Exit
+import System.Process
+import System.FilePath ((</>),(<.>))
+import System.Exit
+-- hackport
import qualified AnsiColor as A
import qualified Cabal2Ebuild as C2E
import qualified Portage.EBuild as E
import qualified Portage.EMeta as EM
-import Error as E
+import Error as E
import qualified Portage.Cabal as Portage
import qualified Portage.PackageId as Portage
@@ -251,6 +254,7 @@ mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch us
case lookup cfn cf_to_iuse_rename of
Nothing -> Merge.mangle_iuse cfn
Just ein -> ein
+
-- key idea is to generate all possible list of flags
deps1 :: [(CabalFlags, Merge.EDep)]
deps1 = [ ( f `updateFa` Cabal.unFlagAssignment fr
@@ -269,7 +273,7 @@ mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch us
-- TODO: drop ghc libraries from tests depends as well
-- (see deepseq in hackport-0.3.5 as an example)
, let pkgDesc_filtered_bdeps = Merge.RetroPackageDescription pkgDesc1 ad
- ]
+ ] `using` parList rdeepseq
where
updateFa :: CabalFlags -> CabalFlags -> CabalFlags
updateFa [] _ = []
@@ -341,6 +345,18 @@ mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch us
cabal_to_emerge_dep :: Merge.RetroPackageDescription -> Merge.EDep
cabal_to_emerge_dep cabal_pkg = Merge.resolveDependencies overlay cabal_pkg compiler_info ghc_packages merged_cabal_pkg_name
+ -- When there are lots of package flags, computation of every possible flag combination
+ -- can take a while (e.g., 12 package flags = 2^12 possible flag combinations).
+ -- Warn the user about this if there are at least 12 package flags. 'cabal_flag_descs'
+ -- is usually an overestimation since it includes flags that hackport will strip out,
+ -- but using it instead of 'active_flag_descs' avoids forcing the very computation we
+ -- are trying to warn the user about.
+ when (length cabal_flag_descs >= 12) $
+ notice verbosity $ "There are up to " ++
+ A.bold (show (2^(length cabal_flag_descs) :: Int)) ++
+ " possible flag combinations.\n" ++
+ A.inColor A.Yellow True A.Default "This may take a while."
+
debug verbosity $ "buildDepends pkgDesc0 raw: " ++ Cabal.showPackageDescription pkgDesc0
debug verbosity $ "buildDepends pkgDesc0: " ++ show (map prettyShow (Merge.exeAndLibDeps pkgDesc0))
debug verbosity $ "buildDepends pkgDesc: " ++ show (map prettyShow (Merge.buildDepends pkgDesc))
@@ -396,28 +412,52 @@ mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch us
Just ucf -> (\e -> e { E.used_options = E.used_options e ++ [("flags", ucf)] }))
$ C2E.cabal2ebuild cat (Merge.packageDescription pkgDesc)
- mergeEbuild verbosity existing_meta pkgdir ebuild active_flag_descs
+ let active_flag_descs_renamed =
+ (\f -> f { Cabal.flagName = Cabal.mkFlagName . cfn_to_iuse . Cabal.unFlagName
+ . Cabal.flagName $ f }) <$> active_flag_descs
+ iuse_flag_descs <- Merge.dropIfUseExpands active_flag_descs_renamed
+ mergeEbuild verbosity existing_meta pkgdir ebuild iuse_flag_descs
+
when fetch $ do
let cabal_pkgId = Cabal.packageId (Merge.packageDescription pkgDesc)
norm_pkgName = Cabal.packageName (Portage.normalizeCabalPackageId cabal_pkgId)
fetchDigestAndCheck verbosity (overlayPath </> prettyShow cat </> prettyShow norm_pkgName)
+ $ Portage.fromCabalPackageId cat cabal_pkgId
--- | Run various @repoman@ commands in the directory of the newly-generated ebuild.
+-- | Run @ebuild@, @pkgcheck@ and @repoman@ commands in the directory of the
+-- newly-generated ebuild.
+--
-- This will ensure well-formed ebuilds and @metadata.xml@, and will update (if possible)
-- the @Manifest@ file.
+--
+-- @pkgcheck@ and @repoman@ will run concurrently.
fetchDigestAndCheck :: Verbosity
-> FilePath -- ^ directory of ebuild
+ -> Portage.PackageId -- ^ newest 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 ()
+fetchDigestAndCheck verbosity ebuildDir pkgId =
+ let ebuild = prettyShow (Portage.cabalPkgName . Portage.packageId $ pkgId)
+ ++ "-" ++ prettyShow (Portage.pkgVersion pkgId) <.> "ebuild"
+ in withWorkingDirectory ebuildDir $ do
+ notice verbosity "Recalculating digests..."
+ emEx <- system $ "ebuild " ++ ebuild ++ " manifest > /dev/null 2>&1"
+ when (emEx /= ExitSuccess) $
+ notice verbosity "ebuild manifest failed horribly. Do something about it!"
+
+ notice verbosity $ "Running " ++ A.bold "repoman full --include-dev " ++
+ "and " ++ A.bold "pkgcheck scan" ++ "..."
+
+ (rfEx,(psEx,psOut,_)) <- system "repoman full --include-dev"
+ `concurrently`
+ readCreateProcessWithExitCode (shell "pkgcheck scan --color True") ""
+
+ when (rfEx /= ExitSuccess) $
+ notice verbosity "repoman full --include-dev found an error. Do something about it!"
+ when (psEx /= ExitSuccess) $ -- this should never be true, even with QA issues.
+ notice verbosity $ A.inColor A.Red True A.Default "pkgcheck scan failed."
+ notice verbosity psOut
+
+ return ()
withWorkingDirectory :: FilePath -> IO a -> IO a
withWorkingDirectory newDir action = do
@@ -450,7 +490,11 @@ mergeEbuild verbosity existing_meta pkgdir ebuild flags = do
-- Create the @metadata.xml@ string, adding new USE flags (if any) to those of
-- the existing @metadata.xml@. If an existing flag has a new and old description,
-- the new one takes precedence.
- default_meta = Portage.makeDefaultMetadata (E.long_desc ebuild)
+ default_meta = Portage.makeDefaultMetadata
+ -- Ensure that the long description does not equal the
+ -- ebuild description, which fails Gentoo QA.
+ (if E.long_desc ebuild == E.description ebuild
+ then "" else E.long_desc ebuild)
$ Merge.metaFlags flags `Map.union`
Portage.metadataUseFlags current_meta'
-- Create a 'Map.Map' of USE flags with updated descriptions.
@@ -463,17 +507,15 @@ mergeEbuild verbosity existing_meta pkgdir ebuild flags = do
createDirectoryIfMissing True edir
now <- TC.getCurrentTime
- let (existing_keywords, existing_license, existing_description) = (EM.keywords existing_meta, EM.license existing_meta, EM.description existing_meta)
+ let (existing_keywords, existing_license) = (EM.keywords existing_meta, EM.license existing_meta)
new_keywords = maybe (E.keywords ebuild) (map Merge.to_unstable) existing_keywords
new_license = either (\err -> maybe (Left err)
Right
existing_license)
Right
(E.license ebuild)
- new_description = maybe (E.description ebuild) id existing_description
ebuild' = ebuild { E.keywords = new_keywords
, E.license = new_license
- , E.description = new_description
}
s_ebuild' = E.showEBuild now ebuild'
@@ -484,11 +526,12 @@ mergeEbuild verbosity existing_meta pkgdir ebuild flags = do
length s_ebuild' `seq` T.writeFile epath (T.pack s_ebuild')
when (current_meta /= default_meta) $ do
- notice verbosity $ A.bold $ "Default and current " ++ emeta ++ " differ."
- if (new_flags /= Map.empty)
- then notice verbosity $ "New or updated USE flags:\n" ++
- (unlines $ Portage.prettyPrintFlagsHuman new_flags)
- else notice verbosity "No new USE flags."
+ when (current_meta /= T.empty) $ do
+ notice verbosity $ A.bold $ "Default and current " ++ emeta ++ " differ."
+ if (new_flags /= Map.empty)
+ then notice verbosity $ "New or updated USE flags:\n" ++
+ (unlines $ Portage.prettyPrintFlagsHuman new_flags)
+ else notice verbosity "No new USE flags."
notice verbosity $ "Writing " ++ emeta
T.writeFile mpath default_meta
diff --git a/Merge/Dependencies.hs b/Merge/Dependencies.hs
index 6e1a0e6..af7afbc 100644
--- a/Merge/Dependencies.hs
+++ b/Merge/Dependencies.hs
@@ -14,9 +14,13 @@ module Merge.Dependencies
, resolveDependencies
) where
-import Data.Maybe ( isJust, isNothing )
-import Data.Monoid ( Monoid, mempty )
+import Control.DeepSeq (NFData(..))
+import Control.Parallel.Strategies
+import Data.Maybe ( isJust, isNothing )
import qualified Data.List as L
+#if !MIN_VERSION_base(4,11,0)
+import Data.Semigroup (Semigroup(..))
+#endif
import qualified Data.Set as S
import qualified Distribution.CabalSpecVersion as Cabal
@@ -41,10 +45,6 @@ import qualified Portage.GHCCore as GHCCore
import Debug.Trace ( trace )
-#if MIN_VERSION_base(4,9,0)
-import Data.Semigroup (Semigroup(..))
-#endif
-
-- | Dependencies of an ebuild.
data EDep = EDep
{
@@ -55,6 +55,9 @@ data EDep = EDep
}
deriving (Show, Eq, Ord)
+instance NFData EDep where
+ rnf (EDep rd rde d de) = rnf rd `seq` rnf rde `seq` rnf d `seq` rnf de
+
-- | Cabal-1 style 'Cabal.PackageDescription', with a top-level 'buildDepends' function.
data RetroPackageDescription = RetroPackageDescription {
packageDescription :: Cabal.PackageDescription,
@@ -73,7 +76,6 @@ exeAndLibDeps pkg = concatMap (Cabal.targetBuildDepends . Cabal.buildInfo)
concatMap (Cabal.targetBuildDepends . Cabal.libBuildInfo)
(Cabal.allLibraries pkg)
-#if MIN_VERSION_base(4,9,0)
instance Semigroup EDep where
(EDep rdepA rdep_eA depA dep_eA) <> (EDep rdepB rdep_eB depB dep_eB) = EDep
{ rdep = Portage.DependAllOf [rdepA, rdepB]
@@ -81,7 +83,6 @@ instance Semigroup EDep where
, dep = Portage.DependAllOf [depA, depB]
, dep_e = dep_eA `S.union` dep_eB
}
-#endif
instance Monoid EDep where
mempty = EDep
@@ -175,7 +176,7 @@ resolveDependencies overlay pkg compiler_info ghc_package_names merged_cabal_pkg
add_profile = Portage.addDepUseFlag (Portage.mkQUse (Portage.Use "profile"))
-- remove depends present in common section
remove_raw_common = filter (\d -> not (Portage.dep_as_broad_as d raw_haskell_deps))
- . map PN.normalize_depend
+ . map PN.normalize_depend
---------------------------------------------------------------
-- Custom-setup dependencies
diff --git a/Merge/Utils.hs b/Merge/Utils.hs
index af2685e..4e286a0 100644
--- a/Merge/Utils.hs
+++ b/Merge/Utils.hs
@@ -13,14 +13,20 @@ module Merge.Utils
, mangle_iuse
, to_unstable
, metaFlags
+ , dropIfUseExpands
+ -- hspec exports
+ , dropIfUseExpand
) where
import qualified Control.Monad as M
-import Data.Maybe (mapMaybe)
+import qualified Data.Char as C
+import Data.Maybe (catMaybes, mapMaybe)
import qualified Data.List as L
import qualified Data.Map.Strict as Map
+import qualified System.Directory as SD
import qualified System.FilePath as SF
-
+import System.FilePath ((</>))
+import System.Process (readCreateProcess, shell)
import Error
import qualified Portage.PackageId as Portage
@@ -140,3 +146,37 @@ to_unstable kw =
-- fromList [("foo","bar")]
metaFlags :: [Cabal.PackageFlag] -> Map.Map String String
metaFlags flags = Map.fromList $ zip (mangle_iuse . Cabal.unFlagName . Cabal.flagName <$> flags) (Cabal.flagDescription <$> flags)
+
+-- | Return a list of @USE_EXPAND@s maintained by ::gentoo.
+--
+-- First, 'getUseExpands' runs @portageq@ to determine the 'FilePath' of the
+-- directory containing valid @USE_EXPAND@s. If the 'FilePath' exists,
+-- it drops the filename extensions to return a list of @USE_EXPAND@s
+-- as Portage understands them. If the 'FilePath' does not exist, 'getUseExpands'
+-- supplies a bare-bones list of @USE_EXPAND@s.
+getUseExpands :: IO [String]
+getUseExpands = do
+ portDir <- readCreateProcess (shell "portageq get_repo_path / gentoo") ""
+ let use_expands_dir = (L.dropWhileEnd C.isSpace portDir) </> "profiles" </> "desc"
+ path_exists <- SD.doesPathExist use_expands_dir
+ if path_exists
+ then do use_expands_contents <- SD.listDirectory use_expands_dir
+ return (SF.dropExtension <$> use_expands_contents)
+ -- Provide some sensible defaults if hackport cannot find ::gentoo
+ else let use_expands_contents = ["cpu_flags_arm","cpu_flags_ppc","cpu_flags_x86"]
+ in return use_expands_contents
+
+-- | Return a 'Cabal.PackageFlag' if it is not a @USE_EXPAND@.
+--
+-- If the 'Cabal.flagName' has a prefix matching any valid @USE_EXPAND@,
+-- then return 'Nothing'. Otherwise return 'Just' 'Cabal.PackageFlag'.
+dropIfUseExpand :: [String] -> Cabal.PackageFlag -> Maybe Cabal.PackageFlag
+dropIfUseExpand use_expands flag =
+ if True `elem` (L.isPrefixOf <$> use_expands <*> [Cabal.unFlagName . Cabal.flagName $ flag])
+ then Nothing else Just flag
+
+-- | Strip @USE_EXPAND@s from a ['Cabal.PackageFlag'].
+dropIfUseExpands :: [Cabal.PackageFlag] -> IO [Cabal.PackageFlag]
+dropIfUseExpands flags = do
+ use_expands <- getUseExpands
+ return $ catMaybes (dropIfUseExpand use_expands <$> flags)
diff --git a/Portage/Cabal.hs b/Portage/Cabal.hs
index 3b74889..a8f73a9 100644
--- a/Portage/Cabal.hs
+++ b/Portage/Cabal.hs
@@ -39,17 +39,17 @@ convertLicense :: SPDX.License -> Either String String
convertLicense l =
case Cabal.licenseFromSPDX l of
-- good ones
- Cabal.AGPL mv -> Right $ "AGPL-" ++ case (Cabal.prettyShow <$> mv) of
+ Cabal.AGPL mv -> Right $ "AGPL-" ++ case Cabal.prettyShow <$> mv of
Just "3" -> "3"
Just "3.0" -> "3+"
_ -> "3" -- almost certainly version 3
- Cabal.GPL mv -> Right $ "GPL-" ++ case (Cabal.prettyShow <$> mv) of
+ Cabal.GPL mv -> Right $ "GPL-" ++ case Cabal.prettyShow <$> mv of
Just "2" -> "2"
Just "2.0" -> "2+"
Just "3" -> "3"
Just "3.0" -> "3+"
_ -> "2" -- possibly version 2
- Cabal.LGPL mv -> Right $ "LGPL-" ++ case (Cabal.prettyShow <$> mv) of
+ Cabal.LGPL mv -> Right $ "LGPL-" ++ case Cabal.prettyShow <$> mv of
Just "2" -> "2"
-- Cabal can't handle 2.0+ properly
Just "2.0" -> "2"
@@ -61,7 +61,8 @@ convertLicense l =
Cabal.BSD4 -> Right "BSD-4"
Cabal.PublicDomain -> Right "public-domain"
Cabal.MIT -> Right "MIT"
- Cabal.Apache mv -> Right $ "Apache-" ++ (maybe "1.1" Cabal.prettyShow mv) -- probably version 1.1
+ Cabal.Apache mv -> Right $ "Apache-" ++
+ maybe "1.1" Cabal.prettyShow mv -- probably version 1.1
Cabal.ISC -> Right "ISC"
Cabal.MPL v -> Right $ "MPL-" ++ Cabal.prettyShow v -- probably version 1.0
-- bad ones
diff --git a/Portage/Dependency/Builder.hs b/Portage/Dependency/Builder.hs
index 61bb755..edd4793 100644
--- a/Portage/Dependency/Builder.hs
+++ b/Portage/Dependency/Builder.hs
@@ -23,9 +23,7 @@ setSlotDep n = overAtom (\(Atom pn dr (DAttr _s u)) -> Atom pn dr (DAttr n u))
mkUseDependency :: (Bool, Use) -> Dependency -> Dependency
mkUseDependency (b, u) d =
- case b of
- True -> DependIfUse u d empty_dependency
- False -> DependIfUse u empty_dependency d
+ if b then DependIfUse u d empty_dependency else DependIfUse u empty_dependency d
overAtom :: (Atom -> Atom) -> Dependency -> Dependency
overAtom f (DependAllOf d) = DependAllOf $ map (overAtom f) d
diff --git a/Portage/Dependency/Types.hs b/Portage/Dependency/Types.hs
index e36c5a9..ff5e0b7 100644
--- a/Portage/Dependency/Types.hs
+++ b/Portage/Dependency/Types.hs
@@ -20,8 +20,10 @@ module Portage.Dependency.Types
, range_is_case_of
) where
-import Portage.PackageId
-import Portage.Use
+import Portage.PackageId
+import Portage.Use
+
+import Control.DeepSeq (NFData(..))
-- | Type of SLOT dependency of a dependency.
data SlotDepend = AnySlot -- ^ nothing special
@@ -29,12 +31,22 @@ data SlotDepend = AnySlot -- ^ nothing special
| GivenSlot String -- ^ ':slotno'
deriving (Eq, Show, Ord)
+instance NFData SlotDepend where
+ rnf AnySlot = ()
+ rnf AnyBuildTimeSlot = ()
+ rnf (GivenSlot s) = rnf s
+
-- | Type of lower bound of a dependency.
data LBound = StrictLB Version -- ^ greater than (>)
| NonstrictLB Version -- ^ greater than or equal to (>=)
| ZeroB -- ^ no lower bound
deriving (Eq, Show)
+instance NFData LBound where
+ rnf (StrictLB v) = rnf v
+ rnf (NonstrictLB v) = rnf v
+ rnf ZeroB = ()
+
instance Ord LBound where
compare ZeroB ZeroB = EQ
compare ZeroB _ = LT
@@ -53,6 +65,11 @@ data UBound = StrictUB Version -- ^ less than (<)
| InfinityB -- ^ no upper bound
deriving (Eq, Show)
+instance NFData UBound where
+ rnf (StrictUB v) = rnf v
+ rnf (NonstrictUB v) = rnf v
+ rnf InfinityB = ()
+
instance Ord UBound where
compare InfinityB InfinityB = EQ
compare InfinityB _ = GT
@@ -74,6 +91,10 @@ data DRange = DRange LBound UBound
| DExact Version
deriving (Eq, Show, Ord)
+instance NFData DRange where
+ rnf (DRange l u) = rnf l `seq` rnf u
+ rnf (DExact v) = rnf v
+
range_is_case_of :: DRange -> DRange -> Bool
range_is_case_of (DRange llow lup) (DRange rlow rup)
| llow >= rlow && lup <= rup = True
@@ -88,14 +109,26 @@ range_as_broad_as _ _ = False
data DAttr = DAttr SlotDepend [UseFlag]
deriving (Eq, Show, Ord)
+instance NFData DAttr where
+ rnf (DAttr sd uf) = rnf sd `seq` rnf uf
+
data Dependency = DependAtom Atom
| DependAnyOf [Dependency]
| DependAllOf [Dependency]
| DependIfUse Use Dependency Dependency -- u? ( td ) !u? ( fd )
deriving (Eq, Show, Ord)
+instance NFData Dependency where
+ rnf (DependAtom a) = rnf a
+ rnf (DependAnyOf ds) = rnf ds
+ rnf (DependAllOf ds) = rnf ds
+ rnf (DependIfUse u d d') = rnf u `seq` rnf d `seq` rnf d'
+
data Atom = Atom PackageName DRange DAttr deriving (Eq, Show, Ord)
+instance NFData Atom where
+ rnf (Atom pn dr da) = rnf pn `seq` rnf dr `seq` rnf da
+
-- | True if left 'Dependency' constraint is the same as (or looser than) right
-- 'Dependency' constraint.
dep_as_broad_as :: Dependency -> Dependency -> Bool
diff --git a/Portage/EBuild.hs b/Portage/EBuild.hs
index 35ecd76..3a25405 100644
--- a/Portage/EBuild.hs
+++ b/Portage/EBuild.hs
@@ -18,9 +18,9 @@ module Portage.EBuild
, quote
) where
-import Portage.Dependency
-import Portage.EBuild.CabalFeature
-import Portage.EBuild.Render
+import Portage.Dependency
+import Portage.EBuild.CabalFeature
+import Portage.EBuild.Render
import qualified Portage.Dependency.Normalize as PN
import qualified Data.Time.Clock as TC
@@ -28,7 +28,9 @@ import qualified Data.Time.Format as TC
import qualified Data.Function as F
import qualified Data.List as L
import qualified Data.List.Split as LS
-import Data.Version(Version(..))
+import Data.Version(Version(..))
+
+import Network.URI
import qualified Paths_hackport(version)
#if ! MIN_VERSION_time(1,5,0)
@@ -75,7 +77,7 @@ ebuildTemplate = EBuild {
hackportVersion = getHackportVersion Paths_hackport.version,
description = "",
long_desc = "",
- homepage = "http://hackage.haskell.org/package/${HACKAGE_N}",
+ homepage = "https://hackage.haskell.org/package/${HACKAGE_N}",
license = Left "unassigned license?",
slot = "0",
keywords = ["~amd64","~x86"],
@@ -154,11 +156,31 @@ showEBuild now ebuild =
expandVars = replaceMultiVars [ ( name ebuild, "${PN}")
, (hackage_name ebuild, "${HACKAGE_N}")
]
- -- TODO: this needs to be more generic
- toHttps = replace "http://github.com/" "https://github.com/"
+
+ replace old new = L.intercalate new . LS.splitOn old
+ -- add to this list with any https-aware websites
+ -- TODO: perhaps convert this to a list of http-only webpages,
+ -- given the prominence of https these days (year 2020).
+ httpsHomepages = Just <$> [ "github.com"
+ , "hackage.haskell.org"
+ , "www.haskell.org"
+ , "hledger.org"
+ , "jaspervdj.be"
+ , "www.yesodweb.com"
+ ]
+ toHttps :: String -> String
+ toHttps x =
+ case parseURI x of
+ Just uri -> if uriScheme uri == "http:" &&
+ (uriRegName <$> uriAuthority uri)
+ `elem`
+ httpsHomepages
+ then replace "http" "https" x
+ else x
+ Nothing -> x
+
this_year :: String
this_year = TC.formatTime TC.defaultTimeLocale "%Y" now
- replace old new = L.intercalate new . LS.splitOn old
-- | Sort IUSE alphabetically
--
diff --git a/Portage/Host.hs b/Portage/Host.hs
index f151535..775b14f 100644
--- a/Portage/Host.hs
+++ b/Portage/Host.hs
@@ -5,8 +5,7 @@ module Portage.Host
import Util (run_cmd)
import qualified Data.List.Split as DLS
-import Data.Maybe (fromJust, isJust, catMaybes)
-import Control.Applicative ( (<$>) )
+import Data.Maybe (fromJust, isJust, mapMaybe)
import qualified System.Directory as D
import System.FilePath ((</>))
@@ -61,9 +60,7 @@ 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
+ if exists then read <$> readFile config_path else return Nothing
----------
-- Paludis
@@ -75,7 +72,7 @@ getPaludisInfo = fmap parsePaludisInfo <$> run_cmd "cave info"
parsePaludisInfo :: String -> LocalInfo
parsePaludisInfo text =
let chunks = DLS.splitOn [""] . lines $ text
- repositories = catMaybes (map parseRepository chunks)
+ repositories = mapMaybe parseRepository chunks
in fromJust (mkLocalInfo repositories)
where
parseRepository :: [String] -> Maybe (String, (String, String))
@@ -110,7 +107,7 @@ askPortageq = do
hsRepo <- run_cmd "portageq get_repo_path / haskell"
--There really ought to be both distdir and portdir,
--but maybe no hsRepo defined yet.
- let info = if any (==Nothing) [distdir,portdir]
+ let info = if Nothing `elem` [distdir,portdir]
then Nothing
else Just LocalInfo
{ distfiles_dir = grab distdir
diff --git a/Portage/Metadata.hs b/Portage/Metadata.hs
index ded3a2e..68c25c1 100644
--- a/Portage/Metadata.hs
+++ b/Portage/Metadata.hs
@@ -17,9 +17,10 @@ module Portage.Metadata
import qualified AnsiColor as A
-import qualified Data.Text as T
-import qualified Data.Text.IO as T
+import qualified Data.List as L
import qualified Data.Map.Strict as Map
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
import Text.XML.Light
@@ -76,14 +77,16 @@ parseMetadata xml =
-- | Pretty print as valid XML a list of flags and their descriptions
-- from a given 'Map.Map'.
prettyPrintFlags :: Map.Map String String -> [String]
-prettyPrintFlags m = (\(name,description) -> "\t\t<flag name=\"" ++ name ++
- "\">" ++ description ++ "</flag>")
+prettyPrintFlags m = (\(name,description) ->
+ "\t\t<flag name=\"" ++ name ++ "\">" ++
+ (L.intercalate " " . lines $ description) ++ "</flag>")
<$> Map.toAscList m
-- | Pretty print a human-readable list of flags and their descriptions
-- from a given 'Map.Map'.
prettyPrintFlagsHuman :: Map.Map String String -> [String]
-prettyPrintFlagsHuman m = (\(name,description) -> A.bold (name ++ ": ") ++ description)
+prettyPrintFlagsHuman m = (\(name,description) -> A.bold (name ++ ": ") ++
+ (L.intercalate " " . lines $ description))
<$> Map.toAscList m
-- | A minimal metadata for use as a fallback value.
@@ -94,27 +97,43 @@ makeMinimalMetadata = Metadata { metadataEmails = ["haskell@gentoo.org"]
-- don't use Text.XML.Light as we like our own pretty printer
-- | Pretty print the @metadata.xml@ string.
+--
+-- This function will additionally print the @<use>@ and @<longdescription>@
+-- xml elements if:
+--
+-- 1. There are USE flags to fill the @<use>@ element, which cannot be empty;
+-- and
+-- 2. The long description is greater than 150 characters long.
+--
+-- The long description also cannot be identical to the @DESCRIPTION@ field
+-- in an ebuild in order to pass Gentoo QA, but this is checked for outside
+-- of this function. See "Merge" for an example usage.
makeDefaultMetadata :: String -> Map.Map String String -> T.Text
-makeDefaultMetadata long_description flags =
- T.pack $ unlines [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
- , "<!DOCTYPE pkgmetadata SYSTEM \"http://www.gentoo.org/dtd/metadata.dtd\">"
- , "<pkgmetadata>"
- , "\t<maintainer type=\"project\">"
- , "\t\t<email>haskell@gentoo.org</email>"
- , "\t\t<name>Gentoo Haskell</name>"
- , "\t</maintainer>"
- , "\t<use>\n" ++ (unlines $ prettyPrintFlags flags) ++ "\t</use>"
- , (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>"
- ]
+makeDefaultMetadata long_description flags = T.pack $
+ unlines [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
+ , "<!DOCTYPE pkgmetadata SYSTEM \"http://www.gentoo.org/dtd/metadata.dtd\">"
+ , "<pkgmetadata>"
+ , "\t<maintainer type=\"project\">"
+ , "\t\t<email>haskell@gentoo.org</email>"
+ , "\t\t<name>Gentoo Haskell</name>"
+ , "\t</maintainer>"
+ ++ if flags == Map.empty
+ then []
+ else "\n\t<use>\n" ++ (unlines $ prettyPrintFlags flags) ++ "\t</use>"
+ ++ if long_description == "" || length long_description <= 150
+ then []
+ else "\n" ++
+ (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 from <longdescription>
+ . (++ "\n") -- append newline
+ ) long_description
+ , "</pkgmetadata>"
+ ]
diff --git a/Portage/Overlay.hs b/Portage/Overlay.hs
index 39ca011..96f8e06 100644
--- a/Portage/Overlay.hs
+++ b/Portage/Overlay.hs
@@ -26,8 +26,6 @@ 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,
diff --git a/Portage/PackageId.hs b/Portage/PackageId.hs
index c4e575d..2e4b400 100644
--- a/Portage/PackageId.hs
+++ b/Portage/PackageId.hs
@@ -29,6 +29,7 @@ import Distribution.Pretty (Pretty(..), prettyShow)
import qualified Portage.Version as Portage
+import Control.DeepSeq (NFData(..))
import qualified Data.Char as Char
import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint ((<>))
@@ -49,6 +50,9 @@ data PackageName = PackageName { category :: Category, cabalPkgName :: Cabal.Pac
data PackageId = PackageId { packageId :: PackageName, pkgVersion :: Portage.Version }
deriving (Eq, Ord, Show, Read)
+instance NFData Category where
+ rnf (Category c) = rnf c
+
instance Pretty Category where
pretty (Category c) = Disp.text c
@@ -57,6 +61,9 @@ instance Parsec Category where
where
categoryChar c = Char.isAlphaNum c || c == '-'
+instance NFData PackageName where
+ rnf (PackageName c pn) = rnf c `seq` rnf pn
+
instance Pretty PackageName where
pretty (PackageName cat name) =
pretty cat <> Disp.char '/' <> pretty name
@@ -68,6 +75,9 @@ instance Parsec PackageName where
name <- parseCabalPackageName
return $ PackageName cat name
+instance NFData PackageId where
+ rnf (PackageId pId pv) = rnf pId `seq` rnf pv
+
instance Pretty PackageId where
pretty (PackageId name version) =
pretty name <> Disp.char '-' <> pretty version
diff --git a/Portage/Use.hs b/Portage/Use.hs
index 51a5505..dbc2565 100644
--- a/Portage/Use.hs
+++ b/Portage/Use.hs
@@ -15,6 +15,8 @@ import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint ((<>))
import Distribution.Pretty (Pretty(..))
+import Control.DeepSeq (NFData(..))
+
#if MIN_VERSION_base(4,11,0)
import Prelude hiding ((<>))
#endif
@@ -27,6 +29,13 @@ data UseFlag = UseFlag Use -- ^ no modificator
| N UseFlag -- ^ - modificator
deriving (Eq,Show,Ord,Read)
+instance NFData UseFlag where
+ rnf (UseFlag u) = rnf u
+ rnf (E f) = rnf f
+ rnf (Q f) = rnf f
+ rnf (X f) = rnf f
+ rnf (N f) = rnf f
+
instance Pretty UseFlag where
pretty = showModificator
@@ -53,6 +62,9 @@ dispUses us = Disp.brackets $ Disp.hcat $ (Disp.punctuate (Disp.text ", ")) $ ma
newtype Use = Use String
deriving (Eq, Read, Show)
+instance NFData Use where
+ rnf (Use s) = rnf s
+
instance Pretty Use where
pretty (Use u) = Disp.text u
diff --git a/Portage/Version.hs b/Portage/Version.hs
index b2b1255..a39c40e 100644
--- a/Portage/Version.hs
+++ b/Portage/Version.hs
@@ -27,6 +27,8 @@ import qualified Text.PrettyPrint as Disp
import Text.PrettyPrint ((<>))
import qualified Data.List.NonEmpty as NE
+import Control.DeepSeq (NFData(..))
+
#if MIN_VERSION_base(4,11,0)
import Prelude hiding ((<>))
#endif
@@ -39,6 +41,9 @@ data Version = Version { versionNumber :: [Int] -- ^ @[1,42,3]@ ~= 1.42
}
deriving (Eq, Ord, Show, Read)
+instance NFData Version where
+ rnf (Version n c s r) = rnf n `seq` rnf c `seq` rnf s `seq` rnf r
+
-- | Prints a valid Portage 'Version' string.
instance Pretty Version where
pretty (Version ver c suf rev) =
@@ -91,6 +96,13 @@ is_live v =
data Suffix = Alpha Int | Beta Int | Pre Int | RC Int | P Int
deriving (Eq, Ord, Show, Read)
+instance NFData Suffix where
+ rnf (Alpha n) = rnf n
+ rnf (Beta n) = rnf n
+ rnf (Pre n) = rnf n
+ rnf (RC n) = rnf n
+ rnf (P n) = rnf n
+
instance Pretty Suffix where
pretty suf = case suf of
Alpha n -> Disp.text "_alpha" <> dispPos n
diff --git a/Status.hs b/Status.hs
index 26f5210..facf2ba 100644
--- a/Status.hs
+++ b/Status.hs
@@ -246,6 +246,13 @@ equals fp1 fp2 = do
equal' :: BS.ByteString -> BS.ByteString -> Bool
equal' = Cabal.equating essence
where
- essence = filter (not . isEmpty) . filter (not . isComment) . BS.lines
+ essence = filter (not . isEmpty)
+ . filter (not . isComment)
+ . filter (not . isHOMEPAGE)
+ . BS.lines
isComment = BS.isPrefixOf (BS.pack "#") . BS.dropWhile isSpace
+ -- HOMEPAGE= frequently gets updated for http:// / https://.
+ -- It's to much noise usually and should really be fixed
+ -- in upstream Cabal definition.
+ isHOMEPAGE = BS.isPrefixOf (BS.pack "HOMEPAGE=") . BS.dropWhile isSpace
isEmpty = BS.null . BS.dropWhile isSpace
diff --git a/hackport.cabal b/hackport.cabal
index 260eaab..06de381 100644
--- a/hackport.cabal
+++ b/hackport.cabal
@@ -1,6 +1,6 @@
Name: hackport
-Version: 0.6.6
-License: GPL-3
+Version: 0.6.7
+License: GPL
License-file: LICENSE
Author: Henning G√ľnther, Duncan Coutts, Lennart Kolmodin
Maintainer: Gentoo Haskell team <haskell@gentoo.org>
@@ -16,10 +16,10 @@ source-repository head
location: git://github.com/gentoo-haskell/hackport.git
Executable hackport
- ghc-options: -Wall
+ ghc-options: -Wall -threaded +RTS -N -RTS
ghc-prof-options: -caf-all -auto-all -rtsopts
Main-Is: Main.hs
- Default-Language: Haskell98
+ Default-Language: Haskell2010
Hs-Source-Dirs:
.,
cabal,
@@ -37,6 +37,7 @@ Executable hackport
filepath >= 1.3.0.1,
HTTP >= 4000.1.5,
network >= 2.6, network-uri >= 2.6,
+ parallel >= 3.2.1.0,
parsec >= 3.1.13,
pretty >= 1.1.1,
process >= 1.1.0.2,
@@ -57,7 +58,7 @@ Executable hackport
random >= 1.0,
stm >= 2.0,
-- hackage-security depends
- base16-bytestring >= 0.1.1,
+ base16-bytestring >= 0.1.1 && < 1,
base64-bytestring >= 1.0,
cryptohash-sha256 >= 0.11,
ed25519,
@@ -758,6 +759,7 @@ test-suite spec
filepath,
hspec >= 2.0,
mtl,
+ network-uri,
parsec,
pretty,
process,
diff --git a/tests/Merge/UtilsSpec.hs b/tests/Merge/UtilsSpec.hs
index bcfd8dd..9f8eb1f 100644
--- a/tests/Merge/UtilsSpec.hs
+++ b/tests/Merge/UtilsSpec.hs
@@ -7,6 +7,7 @@ import QuickCheck.Instances
import Control.Applicative (liftA2)
import qualified Data.Map.Strict as Map
+import Data.Maybe (catMaybes)
import qualified Data.List as L
import Error
@@ -118,3 +119,16 @@ spec = do
\name desc -> metaFlags [(Cabal.emptyFlag (Cabal.mkFlagName name))
{ Cabal.flagDescription = desc }] ==
Map.fromList [(mangle_iuse name,desc)]
+
+ describe "dropIfUseExpand" $ do
+ it "drops a USE flag if it is a USE_EXPAND, otherwise preserves it" $ do
+ let use_expands = ["cpu_flags_x86","cpu_flags_arm"]
+ flags = Cabal.emptyFlag . Cabal.mkFlagName <$>
+ [ "cpu_flags_x86_sse4_2"
+ , "foo"
+ , "bar"
+ , "baz"
+ , "cpu_flags_arm_v8"
+ ]
+ Cabal.unFlagName . Cabal.flagName <$> catMaybes (dropIfUseExpand use_expands <$> flags)
+ `shouldBe` ["foo","bar","baz"]
diff --git a/tests/Merge/UtilsSpec.hs~ b/tests/Merge/UtilsSpec.hs~
deleted file mode 100644
index c7a59ff..0000000
--- a/tests/Merge/UtilsSpec.hs~
+++ /dev/null
@@ -1,53 +0,0 @@
-module Merge.UtilsSpec (spec) where
-
-import Test.Hspec
-
-import Error
-import Merge.Utils
-import Portage.PackageId
-
-import qualified Distribution.Package as Cabal
-
-spec :: Spec
-spec = do
- describe "(<.>)" $ do
- it "adds a dot (.) between two strings" $ do
- "foo" <.> "bar" `shouldBe` "foo.bar"
-
- describe "readPackageString" $ do
- context "when the package string is valid" $ do
- it "returns a Right tuple containing the parsed information" $ do
- readPackageString ["dev-haskell/packagename1-1.0.0"]
- `shouldBe` Right ( Just (Category "dev-haskell")
- , Cabal.mkPackageName "packagename1"
- , Just (Version [1,0,0] Nothing [] 0)
- )
- context "when the package string is empty" $ do
- it "returns a Left HackPortError" $ do
- readPackageString []
- `shouldBe`
- Left (ArgumentError "Need an argument, [category/]package[-version]")
- context "when the package string contains too many arguments" $ do
- it "returns a Left HackPortError" $ do
- let args = ["dev-haskell/packagename1-1.0.0", "dev-haskell/packagename2-1.0.0"]
- readPackageString args
- `shouldBe`
- Left (ArgumentError ("Too many arguments: " ++ unwords args))
-
-
-
-
- -- describe "getPreviousPackageId" $ do
- -- it "returns the PackageId of the previous version" $ do
- -- let ebuildDir = [ "foo-bar2-3.0.0b_rc2-r1.ebuild"
- -- , "foo-bar2-3.0.0b_rc2-r2.ebuild"
- -- , "foo-bar2-3.0.1.ebuild"
- -- , "metadata.xml"
- -- , "Manifest"
- -- , "files"
- -- ]
- -- newPkgId = PackageId (PackageName (Category "dev-haskell")
- -- (Cabal.mkPackageName "foo-bar2"))
- -- Version
-
-
diff --git a/tests/Portage/EBuildSpec.hs b/tests/Portage/EBuildSpec.hs
index b15aad7..b8d3797 100644
--- a/tests/Portage/EBuildSpec.hs
+++ b/tests/Portage/EBuildSpec.hs
@@ -26,4 +26,7 @@ spec = do
quote "Reading, writing and manipulating '.tar' archives." ""
`shouldBe`
"\"Reading, writing and manipulating \'.tar\' archives.\""
-
+ quote "Extras for the \"contravariant\" package" ""
+ `shouldBe`
+ "\"Extras for the \\\"contravariant\\\" package\""
+
diff --git a/tests/Portage/MetadataSpec.hs b/tests/Portage/MetadataSpec.hs
index bd744b9..2f6443a 100644
--- a/tests/Portage/MetadataSpec.hs
+++ b/tests/Portage/MetadataSpec.hs
@@ -3,6 +3,7 @@ module Portage.MetadataSpec (spec) where
import Test.Hspec
import Test.Hspec.QuickCheck
+import qualified Data.List as L
import qualified Data.Text as T
import qualified Data.Map.Strict as Map
@@ -25,16 +26,17 @@ spec = do
prop "should correctly format a single USE flag name with its description" $ do
\name description -> prettyPrintFlags (Map.singleton name description) ==
["\t\t<flag name=\"" ++ name ++
- "\">" ++ description ++ "</flag>"]
+ "\">" ++ (L.intercalate " " . lines $ description)
+ ++ "</flag>"]
prop "should have a length equal to the number of USE flags" $ do
\flags -> length (prettyPrintFlags flags) == Map.size flags
describe "makeDefaultMetadata" $ do
- context "when writing a minimal metadata.xml" $ do
+ context "when writing a minimal metadata.xml with no USE flags" $ do
it "should have a certain number of lines" $ do
-- This is the number of lines in a skeleton metadata.xml.
-- If it does not equal this number, the formatting may be wrong.
- length (T.lines (makeDefaultMetadata "" Map.empty)) `shouldBe` 13
+ length (T.lines (makeDefaultMetadata "" Map.empty)) `shouldBe` 8
it "should have a certain format" $ do
let desc = "foo"
correctMetadata = T.pack $ unlines
@@ -45,20 +47,15 @@ spec = do
, "\t\t<email>haskell@gentoo.org</email>"
, "\t\t<name>Gentoo Haskell</name>"
, "\t</maintainer>"
- , "\t<use>"
- , "\t</use>"
- , "\t<longdescription>"
- , "\t\t" ++ desc
- , "\t</longdescription>"
, "</pkgmetadata>"
]
in makeDefaultMetadata desc Map.empty `shouldBe` correctMetadata
context "when writing a metadata.xml with USE flags" $ do
- it "should have a certain number of lines relative to the number of USE flags" $ do
+ it "should have a certain number of lines" $ do
let flags = Map.singleton "name" "description"
in length (T.lines (makeDefaultMetadata "" flags))
- `shouldBe` 13 + (Map.size flags)
- it "should have a certain format" $ do
+ `shouldBe` 10 + (Map.size flags)
+ it "should have a certain format, including the <use> element" $ do
let desc = "foo"
flags = Map.singleton "name" "description"
correctMetadata = T.pack $ unlines
@@ -72,6 +69,29 @@ spec = do
, "\t<use>"
, "\t\t<flag name=\"name\">description</flag>"
, "\t</use>"
+ , "</pkgmetadata>"
+ ]
+ in makeDefaultMetadata desc flags `shouldBe` correctMetadata
+ context "when writing a metadata.xml with a valid long description and USE flags" $ do
+ it "has a certain number of lines" $ do
+ let desc = replicate 151 'a'
+ flags = Map.singleton "name" "description"
+ in length (T.lines (makeDefaultMetadata desc flags))
+ `shouldBe` 13 + (Map.size flags)
+ it "writes the <longdescription> and <use> elements into the metadata.xml" $ do
+ let desc = replicate 151 'a'
+ flags = Map.singleton "name" "description"
+ correctMetadata = T.pack $ unlines
+ [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"
+ , "<!DOCTYPE pkgmetadata SYSTEM \"http://www.gentoo.org/dtd/metadata.dtd\">"
+ , "<pkgmetadata>"
+ , "\t<maintainer type=\"project\">"
+ , "\t\t<email>haskell@gentoo.org</email>"
+ , "\t\t<name>Gentoo Haskell</name>"
+ , "\t</maintainer>"
+ , "\t<use>"
+ , "\t\t<flag name=\"name\">description</flag>"
+ , "\t</use>"
, "\t<longdescription>"
, "\t\t" ++ desc
, "\t</longdescription>"
diff --git a/tests/Portage/VersionSpec.hs b/tests/Portage/VersionSpec.hs
index c3a0390..fbd8406 100644
--- a/tests/Portage/VersionSpec.hs
+++ b/tests/Portage/VersionSpec.hs
@@ -2,8 +2,8 @@ module Portage.VersionSpec (spec) where
import Test.Hspec
import Test.Hspec.QuickCheck
-
import QuickCheck.Instances
+
import qualified Distribution.Version as Cabal
import Portage.Version
@@ -12,8 +12,8 @@ spec :: Spec
spec = do
describe "is_live" $ do
prop "determines if a Portage version is live" $ do
- \(ComplexVersion v) -> is_live v ==
- if length (versionNumber v) >= 1 && last (versionNumber v) >= 9999
+ \(ComplexVersion v) -> is_live v `shouldBe`
+ if last (versionNumber v) >= 9999
then True else False
describe "fromCabalVersion" $ do
diff --git a/tests/QuickCheck/Instances.hs b/tests/QuickCheck/Instances.hs
index f034851..d5bda8d 100644
--- a/tests/QuickCheck/Instances.hs
+++ b/tests/QuickCheck/Instances.hs
@@ -38,7 +38,7 @@ instance Arbitrary ValidSuffix where
instance Arbitrary ComplexVersion where
arbitrary = do
v <- listOf1 $ getNonNegative <$> arbitrary
- c <- Just <$> choose ('a','z')
+ c <- oneof $ [Just <$> choose ('a','z'), elements [Nothing]]
s <- listOf $ getSuffix <$> arbitrary
(NonNegative r) <- arbitrary
return $ ComplexVersion $ Version v (if length v == 1 then Nothing else c) s r