diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 80c05e47..714c48e9 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -73,7 +73,7 @@ jobs: run: cabal build all - name: Run tests - run: cabal test all --test-option=--color --test-show-details=streaming --jobs=1 + run: cabal test all --test-option=--color=always --test-option=--size-cutoff=999999 --test-show-details=streaming --jobs=1 - name: Check cabal file run: cabal check diff --git a/hackport.cabal b/hackport.cabal index 17d29c80..169cc83a 100644 --- a/hackport.cabal +++ b/hackport.cabal @@ -20,6 +20,10 @@ tested-with: , GHC == 9.6.4 , GHC == 9.8.2 +data-files: + , tests/data/golden/*.out + , tests/data/golden/*.ebuild + source-repository head type: git location: git://github.com/gentoo-haskell/hackport.git @@ -814,6 +818,7 @@ library hackport-internal , parallel >=3.2.1.0 , parsec , pretty + , prettyprinter , process , QuickCheck , split @@ -847,6 +852,7 @@ library hackport-internal Hackport.Command.Update Hackport.Completion Hackport.Env + Hackport.Pretty Hackport.Util Merge Merge.Dependencies @@ -1058,6 +1064,8 @@ test-suite doctests-v2 test-suite spec import: warnings + if flag(threads) + ghc-options: -threaded -rtsopts -with-rtsopts=-N type: exitcode-stdio-1.0 default-language: Haskell2010 main-is: Main.hs @@ -1067,12 +1075,14 @@ test-suite spec Portage.CabalSpec Portage.Dependency.PrintSpec Portage.EBuildSpec + Portage.EBuild.Golden Portage.GHCCoreSpec Portage.Metadata.RemoteIdSpec Portage.MetadataSpec Portage.PackageIdSpec Portage.VersionSpec QuickCheck.Instances + Paths_hackport build-depends: , hackport-external-libs-Cabal-syntax @@ -1095,6 +1105,9 @@ test-suite spec , process , QuickCheck >=2.0 , split + , tasty + , tasty-golden + , tasty-hspec , text , time , xml diff --git a/src/Cabal2Ebuild.hs b/src/Cabal2Ebuild.hs index 6a33d36d..4604be92 100644 --- a/src/Cabal2Ebuild.hs +++ b/src/Cabal2Ebuild.hs @@ -30,7 +30,8 @@ import qualified Distribution.Version as Cabal ( VersionRange , cataVersionRange, normaliseVersionRange , majorUpperBound, mkVersion ) import Distribution.Version (VersionRangeF(..)) -import Distribution.Pretty (prettyShow) +import qualified Distribution.Pretty as Disp +import Hackport.Pretty (prettyShow) import qualified Distribution.Utils.ShortText as ST @@ -54,7 +55,7 @@ cabal2ebuild cat pkg = Portage.ebuildTemplate { E.name = Portage.cabal_pn_to_PN cabal_pn, E.category = prettyShow cat, E.hackage_name= cabalPkgName, - E.version = prettyShow (Cabal.pkgVersion (Cabal.package pkg)), + E.version = Disp.prettyShow (Cabal.pkgVersion (Cabal.package pkg)), E.revision = getHackageRevision, E.sourceURIs = getSourceURIs, E.description = ST.fromShortText $ if ST.null (Cabal.synopsis pkg) @@ -78,7 +79,7 @@ cabal2ebuild cat pkg = Portage.ebuildTemplate { else []) } where cabal_pn = Cabal.pkgName $ Cabal.package pkg - cabalPkgName = prettyShow cabal_pn + cabalPkgName = Disp.prettyShow cabal_pn hasLibs = isJust (Cabal.library pkg) hasTests = (not . null) (Cabal.testSuites pkg) getHackageRevision = diff --git a/src/Hackport/Pretty.hs b/src/Hackport/Pretty.hs new file mode 100644 index 00000000..08a25a7a --- /dev/null +++ b/src/Hackport/Pretty.hs @@ -0,0 +1,16 @@ +module Hackport.Pretty + ( renderDoc + , prettyShow + , module Prettyprinter + ) where + +import Prettyprinter hiding (cat) +import Prettyprinter.Render.String + +renderDoc :: Doc ann -> String +renderDoc + = renderString + . layoutPretty defaultLayoutOptions { layoutPageWidth = Unbounded } + +prettyShow :: Pretty a => a -> String +prettyShow = renderDoc . pretty diff --git a/src/Merge.hs b/src/Merge.hs index de9a5ea1..85e597c4 100644 --- a/src/Merge.hs +++ b/src/Merge.hs @@ -12,6 +12,7 @@ Core functionality of the @merge@ command of @HackPort@. module Merge ( merge , mergeGenericPackageDescription + , mkEbuild ) where import Control.Applicative @@ -37,7 +38,8 @@ 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 qualified Distribution.Pretty as Disp +import Hackport.Pretty (prettyShow) -- cabal-install @@ -157,7 +159,7 @@ merge repoContext packageString users_cabal_flags notice $ "Ambiguous names: " ++ L.intercalate ", " names forM_ pkgs $ \ps -> do let p_name = (cabal_pkg_to_pn . NE.head) ps - showPkg = prettyShow . Cabal.pkgVersion . CabalInstall.srcpkgPackageId + showPkg = Disp.prettyShow . Cabal.pkgVersion . CabalInstall.srcpkgPackageId notice $ p_name ++ ": " ++ L.intercalate ", " (map showPkg (NE.toList ps)) return $ pkgs >>= NE.toList @@ -168,7 +170,7 @@ merge repoContext packageString users_cabal_flags Nothing -> do putStrLn "No such version for that package, available versions:" forM_ availablePkgs $ \ avail -> - putStrLn (prettyShow . CabalInstall.srcpkgPackageId $ avail) + putStrLn (Disp.prettyShow . CabalInstall.srcpkgPackageId $ avail) throw (ArgumentError "no such version for that package") Just avail -> return avail @@ -179,7 +181,7 @@ merge repoContext packageString users_cabal_flags forM_ availablePkgs $ \ avail -> do let match_text | CabalInstall.srcpkgPackageId avail == CabalInstall.srcpkgPackageId selectedPkg = "* " | otherwise = "- " - info $ match_text ++ (prettyShow . CabalInstall.srcpkgPackageId $ avail) + info $ match_text ++ (Disp.prettyShow . CabalInstall.srcpkgPackageId $ avail) let cabal_pkgId = CabalInstall.srcpkgPackageId selectedPkg norm_pkgName = Cabal.packageName (Portage.normalizeCabalPackageId cabal_pkgId) @@ -251,7 +253,7 @@ mergeGenericPackageDescription cat pkgGenericDesc fetch users_cabal_flags = do debug "searching for minimal suitable ghc version" (compiler_info, ghc_packages, pkgDesc0, _flags, pix) <- case GHCCore.minimumGHCVersionToBuildPackage pkgGenericDesc (Cabal.mkFlagAssignment user_specified_fas) of Just v -> return v - Nothing -> let pn = prettyShow merged_cabal_pkg_name + Nothing -> let pn = Disp.prettyShow merged_cabal_pkg_name cn = prettyShow cat in error $ unlines [ "mergeGenericPackageDescription: failed to find suitable GHC for " ++ pn , " You can try to merge the package manually:" @@ -395,17 +397,17 @@ mergeGenericPackageDescription cat pkgGenericDesc fetch users_cabal_flags = do A.inColor A.Yellow True A.Default "This may take a while." debug $ "buildDepends pkgDesc0 raw: " ++ Cabal.showPackageDescription pkgDesc0 - debug $ "buildDepends pkgDesc0: " ++ show (map prettyShow (Merge.exeAndLibDeps pkgDesc0)) - debug $ "buildDepends pkgDesc: " ++ show (map prettyShow (Merge.buildDepends pkgDesc)) + debug $ "buildDepends pkgDesc0: " ++ show (map Disp.prettyShow (Merge.exeAndLibDeps pkgDesc0)) + debug $ "buildDepends pkgDesc: " ++ show (map Disp.prettyShow (Merge.buildDepends pkgDesc)) -- warnings <- errorWarnOnUnbuildable (prettyShow cat) - (prettyShow merged_cabal_pkg_name) + (Disp.prettyShow merged_cabal_pkg_name) pkgDesc0 - notice $ "Accepted depends: " ++ show (map prettyShow accepted_deps) - notice $ "Skipped depends: " ++ show (map prettyShow skipped_deps) + notice $ "Accepted depends: " ++ show (map Disp.prettyShow accepted_deps) + notice $ "Skipped depends: " ++ show (map Disp.prettyShow skipped_deps) notice $ "Dead flags: " ++ show (map pp_fa irresolvable_flag_assignments) notice $ "Dropped flags: " ++ show (map (Cabal.unFlagName.fst) common_fa) notice $ "Active flags: " ++ show (map Cabal.unFlagName active_flags) @@ -423,47 +425,16 @@ mergeGenericPackageDescription cat pkgGenericDesc fetch users_cabal_flags = do Just [] -> die "No output from 'portageq envvar ARCH'" Just (l:_) -> pure l - let pp_fn (cabal_fn, yesno) = b yesno ++ Cabal.unFlagName cabal_fn - where b True = "" - b False = "-" - - -- 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 - - build_configure_call :: [String] -> [String] - build_configure_call [] = [] - build_configure_call conf_args = icalate " \\" $ - "haskell-cabal_src_configure" : - map ('\t':) conf_args - - -- returns list USE-parameters to './setup configure' - selected_flags :: ([Cabal.FlagName], CabalFlags) -> [String] - selected_flags ([], []) = [] - selected_flags (active_fns, users_fas) = map snd (L.sortBy (compare `on` fst) flag_pairs) - where flag_pairs :: [(String, String)] - flag_pairs = active_pairs ++ users_pairs - active_pairs = map (\fn -> (fn, "$(cabal_flag " ++ cfn_to_iuse fn ++ " " ++ fn ++ ")")) $ map Cabal.unFlagName active_fns - users_pairs = map (\fa -> ((Cabal.unFlagName . fst) fa, "--flag=" ++ pp_fn fa)) users_fas - to_iuse x = let fn = Cabal.unFlagName $ Cabal.flagName x - p = if Cabal.flagDefault x then "+" else "" - in p ++ cfn_to_iuse fn - - ebuild = (\e -> e { E.iuse = E.iuse e ++ map to_iuse active_flag_descs }) - . ( case requested_cabal_flags of - Nothing -> id - Just ucf -> (\e -> e { E.used_options = E.used_options e ++ [("flags", ucf)] })) - $ (C2E.cabal2ebuild cat (Merge.packageDescription pkgDesc)) - { E.depend = Merge.dep tdeps - , E.depend_extra = S.toList $ Merge.dep_e tdeps - , E.rdepend = Merge.rdep tdeps - , E.rdepend_extra = S.toList $ Merge.rdep_e tdeps - , E.src_configure = build_configure_call $ - selected_flags (active_flags, user_specified_fas) - , E.keywords = [ '~' : thisArch ] - } + let ebuild = mkEbuild + requested_cabal_flags + cat + pkgDesc + tdeps + active_flags + user_specified_fas + cf_to_iuse_rename + thisArch + active_flag_descs let active_flag_descs_renamed = (\f -> f { Cabal.flagName = Cabal.mkFlagName . cfn_to_iuse . Cabal.unFlagName @@ -474,7 +445,7 @@ mergeGenericPackageDescription cat pkgGenericDesc fetch users_cabal_flags = do when fetch $ do let cabal_pkgId = Cabal.packageId (Merge.packageDescription pkgDesc) norm_pkgName = Cabal.packageName (Portage.normalizeCabalPackageId cabal_pkgId) - fetchDigestAndCheck (overlayPath prettyShow cat prettyShow norm_pkgName) + fetchDigestAndCheck (overlayPath prettyShow cat Disp.prettyShow norm_pkgName) $ Portage.fromCabalPackageId cat cabal_pkgId forM_ warnings $ notice . ("\n" ++) @@ -489,7 +460,7 @@ fetchDigestAndCheck -> Portage.PackageId -- ^ newest ebuild -> Env env () fetchDigestAndCheck ebuildDir pkgId = do - let ebuild = prettyShow (Portage.cabalPkgName . Portage.packageId $ pkgId) + let ebuild = Disp.prettyShow (Portage.cabalPkgName . Portage.packageId $ pkgId) ++ "-" ++ prettyShow (Portage.pkgVersion pkgId) <.> "ebuild" withWorkingDirectory ebuildDir $ do notice "Recalculating digests..." @@ -601,6 +572,76 @@ mergeEbuild existing_meta pkgdir ebuild flags = do notice $ "Writing " ++ emeta liftIO $ T.writeFile mpath updatedMetaText +mkEbuild + :: Maybe String + -> Portage.Category + -> Merge.RetroPackageDescription + -> Merge.EDep + -> [Cabal.FlagName] + -> CabalFlags + -> [(String, String)] + -> String + -> [Cabal.PackageFlag] + -> E.EBuild +mkEbuild + requested_cabal_flags + cat + pkgDesc + tdeps + active_flags + user_specified_fas + cf_to_iuse_rename + thisArch + active_flag_descs + = (\e -> e { E.iuse = E.iuse e ++ map to_iuse active_flag_descs }) + . ( case requested_cabal_flags of + Nothing -> id + Just ucf -> (\e -> e { E.used_options = E.used_options e ++ [("flags", ucf)] })) + $ (C2E.cabal2ebuild cat (Merge.packageDescription pkgDesc)) + { E.depend = Merge.dep tdeps + , E.depend_extra = S.toList $ Merge.dep_e tdeps + , E.rdepend = Merge.rdep tdeps + , E.rdepend_extra = S.toList $ Merge.rdep_e tdeps + , E.src_configure = build_configure_call $ + selected_flags (active_flags, user_specified_fas) + , E.keywords = [ '~' : thisArch ] + } + where + icalate :: [a] -> [[a]] -> [[a]] + icalate _s [] = [] + icalate _s [x] = [x] + icalate s (x:xs) = (x ++ s) : icalate s xs + + build_configure_call :: [String] -> [String] + build_configure_call [] = [] + build_configure_call conf_args = icalate " \\" $ + "haskell-cabal_src_configure" : + map ('\t':) conf_args + + selected_flags :: ([Cabal.FlagName], CabalFlags) -> [String] + selected_flags ([], []) = [] + selected_flags (active_fns, users_fas) = map snd (L.sortBy (compare `on` fst) flag_pairs) + where flag_pairs :: [(String, String)] + flag_pairs = active_pairs ++ users_pairs + active_pairs = map (\fn -> (fn, "$(cabal_flag " ++ cfn_to_iuse fn ++ " " ++ fn ++ ")")) $ map Cabal.unFlagName active_fns + users_pairs = map (\fa -> ((Cabal.unFlagName . fst) fa, "--flag=" ++ pp_fn fa)) users_fas + + to_iuse :: Cabal.PackageFlag -> String + to_iuse x = let fn = Cabal.unFlagName $ Cabal.flagName x + p = if Cabal.flagDefault x then "+" else "" + in p ++ cfn_to_iuse fn + + cfn_to_iuse :: String -> String + cfn_to_iuse cfn = + case lookup cfn cf_to_iuse_rename of + Nothing -> Merge.mangle_iuse cfn + Just ein -> ein + + pp_fn :: (Cabal.FlagName, Bool) -> String + pp_fn (cabal_fn, yesno) = b yesno ++ Cabal.unFlagName cabal_fn + where b True = "" + b False = "-" + -- -- TODO: Make it so this is automatically fixed instead of requiring manual -- intervention diff --git a/src/Portage/Dependency/Print.hs b/src/Portage/Dependency/Print.hs index 0b1d667a..f3a23557 100644 --- a/src/Portage/Dependency/Print.hs +++ b/src/Portage/Dependency/Print.hs @@ -1,9 +1,11 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Portage.Dependency.Print ( dep2str , dep2str_noindent + , showDepend ) where import Portage.Version @@ -11,75 +13,85 @@ import Portage.Use import Portage.PackageId -import qualified Distribution.Pretty as DP (Pretty(..)) -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ( vcat, nest, render ) -import Text.PrettyPrint as PP ((<>)) +import Data.Default.Class +import Data.Maybe (catMaybes) +import Hackport.Pretty import Portage.Dependency.Types -dispSlot :: SlotDepend -> Disp.Doc -dispSlot AnySlot = Disp.empty -dispSlot AnyBuildTimeSlot = Disp.text ":=" -dispSlot (GivenSlot slot) = Disp.text (':' : slot) +dispSlot :: SlotDepend -> Doc ann +dispSlot AnySlot = emptyDoc +dispSlot AnyBuildTimeSlot = ":=" +dispSlot (GivenSlot slot) = ":" <> pretty slot -dispLBound :: PackageName -> LBound -> Disp.Doc -dispLBound pn (StrictLB v) = Disp.char '>' PP.<> DP.pretty pn <-> DP.pretty v -dispLBound pn (NonstrictLB v) = Disp.text ">=" PP.<> DP.pretty pn <-> DP.pretty v +dispLBound :: PackageName -> LBound -> Doc ann +dispLBound pn (StrictLB v) = ">" <> pretty pn <-> pretty v +dispLBound pn (NonstrictLB v) = ">=" <> pretty pn <-> pretty v dispLBound _pn ZeroB = error "unhandled 'dispLBound ZeroB'" -dispUBound :: PackageName -> UBound -> Disp.Doc -dispUBound pn (StrictUB v) = Disp.char '<' PP.<> DP.pretty pn <-> DP.pretty v -dispUBound pn (NonstrictUB v) = Disp.text "<=" PP.<> DP.pretty pn <-> DP.pretty v +dispUBound :: PackageName -> UBound -> Doc ann +dispUBound pn (StrictUB v) = "<" <> pretty pn <-> pretty v +dispUBound pn (NonstrictUB v) = "<=" <> pretty pn <-> pretty v dispUBound _pn InfinityB = error "unhandled 'dispUBound Infinity'" -dispDAttr :: DAttr -> Disp.Doc -dispDAttr (DAttr s u) = dispSlot s PP.<> dispUses u +dispDAttr :: DAttr -> Doc ann +dispDAttr (DAttr s u) = dispSlot s <> dispUses u dep2str :: Int -> Dependency -> String -dep2str start_indent = render . nest start_indent . showDepend +dep2str start_indent = renderDoc . nest start_indent . showDepend dep2str_noindent :: Dependency -> String -dep2str_noindent = render . showDepend +dep2str_noindent = renderDoc . showDepend -(<->) :: Disp.Doc -> Disp.Doc -> Disp.Doc -a <-> b = a PP.<> Disp.char '-' PP.<> b +(<->) :: Doc ann -> Doc ann -> Doc ann +a <-> b = a <> "-" <> b -sp :: Disp.Doc -sp = Disp.char ' ' +sp :: Doc ann +sp = " " -sparens :: Disp.Doc -> Disp.Doc -sparens doc = Disp.parens (sp PP.<> valign doc PP.<> sp) +sparens :: Doc ann -> Doc ann +sparens doc = parens (sp <> valign doc <> sp) -valign :: Disp.Doc -> Disp.Doc +valign :: Doc ann -> Doc ann valign d = nest 0 d -showDepend :: Dependency -> Disp.Doc +showDepend :: Dependency -> Doc ann showDepend (DependAtom (Atom pn range dattr)) = case range of -- any version - DRange ZeroB InfinityB -> DP.pretty pn PP.<> dispDAttr dattr - DRange ZeroB ub -> dispUBound pn ub PP.<> dispDAttr dattr - DRange lb InfinityB -> dispLBound pn lb PP.<> dispDAttr dattr + DRange ZeroB InfinityB -> pretty 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 (DependAtom (Atom pn (DRange lb InfinityB) dattr)) - PP.<> Disp.char ' ' - PP.<> showDepend (DependAtom (Atom pn (DRange ZeroB ub) dattr)) - DExact v -> Disp.char '~' PP.<> DP.pretty pn <-> DP.pretty v { versionRevision = 0 } PP.<> dispDAttr dattr + DRange lb ub -> showDepend (DependAtom (Atom pn (DRange lb InfinityB) dattr)) + <+> showDepend (DependAtom (Atom pn (DRange ZeroB ub) def)) + DExact v -> "~" <> pretty pn <-> pretty v { versionRevision = 0 } <> dispDAttr dattr -showDepend (DependIfUse u td fd) = valign $ vcat [td_doc, fd_doc] +showDepend (DependIfUse u td fd) = valign $ vcat $ catMaybes [td_doc, fd_doc] where td_doc - | is_empty_dependency td = Disp.empty - | otherwise = DP.pretty u PP.<> Disp.char '?' PP.<> sp PP.<> sparens (showDepend td) + | is_empty_dependency td = Nothing + | otherwise = Just $ vcat + [ pretty u <> "?" <+> "(" + , indent 1 (emptyDoc <> showDepend td) + , ")" + ] fd_doc - | is_empty_dependency fd = Disp.empty - | otherwise = Disp.char '!' PP.<> DP.pretty u PP.<> Disp.char '?' PP.<> sp PP.<> sparens (showDepend fd) -showDepend (DependAnyOf deps) = Disp.text "||" PP.<> sp PP.<> sparens (vcat $ map showDependInAnyOf deps) -showDepend (DependAllOf deps) = valign $ vcat $ map showDepend deps + | is_empty_dependency fd = Nothing + | otherwise = Just $ vcat + [ "!" <> pretty u <> "?" <+> "(" + , indent 1 (emptyDoc <> showDepend fd) + , ")" + ] +showDepend (DependAnyOf deps) = vcat $ + [ "||" <+> "(" + , indent 1 (vcat (map showDependInAnyOf deps)) + , ")" + ] +showDepend (DependAllOf deps) = vcat $ map showDepend deps -- needs special grouping -showDependInAnyOf :: Dependency -> Disp.Doc +showDependInAnyOf :: Dependency -> Doc ann 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 diff --git a/src/Portage/Dependency/Types.hs b/src/Portage/Dependency/Types.hs index bd0255a4..966cd71a 100644 --- a/src/Portage/Dependency/Types.hs +++ b/src/Portage/Dependency/Types.hs @@ -30,7 +30,7 @@ import Data.Default.Class data SlotDepend = AnySlot -- ^ nothing special | AnyBuildTimeSlot -- ^ ':=' | GivenSlot String -- ^ ':slotno' - deriving (Eq, Show, Ord) + deriving (Eq, Show, Read, Ord) instance NFData SlotDepend where rnf AnySlot = () @@ -41,7 +41,7 @@ instance NFData SlotDepend where data LBound = StrictLB Version -- ^ greater than (>) | NonstrictLB Version -- ^ greater than or equal to (>=) | ZeroB -- ^ no lower bound - deriving (Eq, Show) + deriving (Eq, Show, Read) instance NFData LBound where rnf (StrictLB v) = rnf v @@ -64,7 +64,7 @@ instance Ord LBound where data UBound = StrictUB Version -- ^ less than (<) | NonstrictUB Version -- ^ less than or equal to (<=) | InfinityB -- ^ no upper bound - deriving (Eq, Show) + deriving (Eq, Show, Read) instance NFData UBound where rnf (StrictUB v) = rnf v @@ -90,7 +90,7 @@ instance Ord UBound where -- version range between a given 'LBound' and 'UBound'. data DRange = DRange LBound UBound | DExact Version - deriving (Eq, Show, Ord) + deriving (Eq, Show, Read, Ord) instance NFData DRange where rnf (DRange l u) = rnf l `seq` rnf u @@ -108,7 +108,7 @@ range_as_broad_as (DRange llow lup) (DRange rlow rup) range_as_broad_as _ _ = False data DAttr = DAttr SlotDepend [UseFlag] - deriving (Eq, Show, Ord) + deriving (Eq, Show, Read, Ord) instance NFData DAttr where rnf (DAttr sd uf) = rnf sd `seq` rnf uf @@ -120,7 +120,7 @@ data Dependency = DependAtom Atom | DependAnyOf [Dependency] | DependAllOf [Dependency] | DependIfUse Use Dependency Dependency -- u? ( td ) !u? ( fd ) - deriving (Eq, Show, Ord) + deriving (Eq, Show, Read, Ord) instance NFData Dependency where rnf (DependAtom a) = rnf a @@ -128,7 +128,7 @@ instance NFData Dependency where 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) +data Atom = Atom PackageName DRange DAttr deriving (Eq, Show, Read, Ord) instance NFData Atom where rnf (Atom pn dr da) = rnf pn `seq` rnf dr `seq` rnf da diff --git a/src/Portage/EBuild.hs b/src/Portage/EBuild.hs index c09579b2..8f5974ce 100644 --- a/src/Portage/EBuild.hs +++ b/src/Portage/EBuild.hs @@ -7,6 +7,13 @@ Functions and types related to interpreting and manipulating an ebuild, as understood by the Portage package manager. -} {-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +-- Needed to get OverloadedStrings to work +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + module Portage.EBuild ( EBuild(..) , ebuildTemplate @@ -14,7 +21,6 @@ module Portage.EBuild -- hspec exports , sort_iuse , drop_tdot - , quote , toHttps ) where @@ -29,6 +35,12 @@ import qualified Data.Function as F import qualified Data.List as L import qualified Data.List.Split as LS import Data.Version(Version(..)) +import Control.Monad.Trans.Writer.CPS +import Data.Foldable (toList) +import Data.Maybe (catMaybes) +import Data.Monoid (Endo(..)) -- more efficient list concat +import Hackport.Pretty +import GHC.Exts (IsString(..)) import Network.URI import qualified Paths_hackport(version) @@ -63,6 +75,7 @@ data EBuild = EBuild , used_options :: [(String, String)] -- ^ hints to ebuild writers/readers -- on what hackport options were used to produce an ebuild } + deriving (Show, Read, Eq) getHackportVersion :: Version -> String getHackportVersion Version {versionBranch=(x:s)} = foldl (\y z -> y ++ "." ++ (show z)) (show x) s @@ -97,62 +110,65 @@ ebuildTemplate = EBuild { -- | Pretty-print an 'EBuild' as a 'String'. showEBuild :: TC.UTCTime -> EBuild -> String -showEBuild now ebuild = - ss ("# Copyright 1999-" ++ this_year ++ " Gentoo Authors"). nl. - ss "# Distributed under the terms of the GNU General Public License v2". nl. - nl. - ss "EAPI=8". nl. - nl. - ss ("# ebuild generated by hackport " ++ hackportVersion ebuild). nl. - sconcat (map (\(k, v) -> ss "#hackport: " . ss k . ss ": " . ss v . nl) $ used_options ebuild). - nl. - beforeInherit. - ss "CABAL_FEATURES=". quote' (sepBy " " $ map render (features ebuild)). nl. - ss "inherit haskell-cabal". nl. - nl. - ss "DESCRIPTION=". quote (drop_tdot $ description ebuild). nl. - ss "HOMEPAGE=". quote (toHttps $ expandVars (homepage 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. - (if null (iuse ebuild) - then nl - else ss "IUSE=". quote' (sepBy " " . sort_iuse $ L.nub $ iuse ebuild). nl. nl - ) . - dep_str "RDEPEND" (rdepend_extra ebuild) (rdepend ebuild). - dep_str "DEPEND" ( depend_extra ebuild) ( depend ebuild). - - verbatim (nl . ss "src_prepare() {" . nl) - (src_prepare ebuild) - (ss "}" . nl). - - verbatim (nl. ss "src_configure() {" . nl) - (src_configure ebuild) - (ss "}" . nl). - - id $ [] +showEBuild now ebuild = replaceLeadingSpaces $ renderDoc $ execLinesBuilder $ do + fromDoc $ "# Copyright 1999-" <> this_year <> " Gentoo Authors" + "# Distributed under the terms of the GNU General Public License v2" + emptyLine + "EAPI=8" + emptyLine + fromDoc $ "# ebuild generated by hackport" <+> pretty (hackportVersion ebuild) + let optLine (k,v) = "#hackport: " <> pretty k <> ": " <> pretty v + fromDocs $ map optLine (used_options ebuild) + emptyLine + preFeatures + fromDoc $ "CABAL_FEATURES=" <> dquotes (hsep (map (pretty . render) (features ebuild))) + "inherit haskell-cabal" + emptyLine + fromDoc $ "DESCRIPTION=" <> dquotes (pretty (drop_tdot (description ebuild))) + fromDoc $ "HOMEPAGE=" <> dquotes (pretty (toHttps (expandVars (homepage ebuild)))) + emptyLine + fromDoc $ "LICENSE=" <> (either (\err -> dquotes emptyDoc <> "\t# FIXME: " <> pretty err) + (dquotes . pretty) + (license ebuild) ) + fromDoc $ "SLOT=" <> dquotes (pretty (slot ebuild)) + fromDoc $ "KEYWORDS=" <> dquotes (hsep (map pretty (keywords ebuild))) + fromDocs $ + if null (iuse ebuild) + then Nothing + else + let iuseList = hsep $ map pretty $ sort_iuse $ L.nub $ iuse ebuild + in Just $ "IUSE=" <> dquotes iuseList + emptyLine + dep_str "RDEPEND" (rdepend_extra ebuild) (rdepend ebuild) + dep_str "DEPEND" ( depend_extra ebuild) ( depend ebuild) + verbatim + (vsep [emptyDoc, "src_prepare() {"]) + (map pretty (src_prepare ebuild)) + "}" + verbatim + (vsep [emptyDoc, "src_configure() {"]) + (map pretty (src_configure ebuild)) + "}" where expandVars = replaceMultiVars [ ( name ebuild, "${PN}") , (hackage_name ebuild, "${HACKAGE_N}") ] + this_year :: Doc ann + this_year = pretty $ TC.formatTime TC.defaultTimeLocale "%Y" now - this_year :: String - this_year = TC.formatTime TC.defaultTimeLocale "%Y" now + preFeatures = + let rev = revLine (revision ebuild) + pn = pnLine <$> cabal_pn ebuild + preList = catMaybes [rev, pn] + in if null preList + then pure () + else fromDocs $ preList ++ [emptyDoc] - beforeInherit = - case (revision ebuild, cabal_pn ebuild) of - ("0", Nothing) -> id - (r , pn ) -> revLine r. pnLine pn. nl + revLine "0" = Nothing + revLine r = Just $ "CABAL_HACKAGE_REVISION=" <> pretty r - revLine "0" = id - revLine r = ss ("CABAL_HACKAGE_REVISION=" ++ r). nl - - pnLine Nothing = id - pnLine (Just pn) = ss "CABAL_PN=". quote pn. nl + pnLine pn = "CABAL_PN=" <> dquotes (pretty pn) -- | Convert http urls into https urls, unless whitelisted as http-only. -- @@ -185,7 +201,7 @@ toHttps x = -- >>> sort_iuse ["+a","b"] -- ["+a","b"] sort_iuse :: [String] -> [String] -sort_iuse = L.sortBy (compare `F.on` dropWhile ( `elem` "+")) +sort_iuse = L.sortBy (compare `F.on` dropWhile ( `elem` ("+" :: String))) -- | Drop trailing dot(s). -- @@ -196,70 +212,21 @@ sort_iuse = L.sortBy (compare `F.on` dropWhile ( `elem` "+")) drop_tdot :: String -> String drop_tdot = reverse . dropWhile (== '.') . reverse -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 - -sconcat :: [DString] -> DString -sconcat = L.foldl' (.) id - --- 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 dep = ss var. sc '='. quote' (ss $ drop_leadings $ unlines extra ++ deps_s). nl - where indent = 1 * tab_size - deps_s = tabify (dep2str indent $ PN.normalize_depend dep) - drop_leadings = dropWhile (== '\t') - --- | Place a 'String' between quotes, and correctly handle special characters. -quote :: String -> DString -quote str = sc '"'. ss (esc str). sc '"' - where - esc = concatMap esc' - esc' c = - case c of - '\\' -> "\\\\" - '"' -> "\\\"" - '\n' -> " " - '`' -> "'" - _ -> [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 +-- | Print the @pre@ line, each line in the list and the @post@ line, _only_ +-- if the list is not empty. +verbatim :: Doc ann -> [Doc ann] -> Doc ann -> LinesBuilder ann () +verbatim pre s post + | null s = pure () + | otherwise = fromDocs $ [pre] ++ s ++ [post] + +dep_str :: Doc ann -> [String] -> Dependency -> LinesBuilder ann () +dep_str var extra dep = fromDoc $ vsep + [ var <> "=\"" + , indent 1 ( + vsep (map pretty extra ++ [showDepend (PN.normalize_depend dep)]) + ) + , "\"" + ] getRestIfPrefix :: String -- ^ the prefix -> String -- ^ the string @@ -286,3 +253,39 @@ 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) + + +emptyLine :: LinesBuilder ann () +emptyLine = fromDoc emptyDoc + +fromDoc :: Doc ann -> LinesBuilder ann () +fromDoc = fromDocs . (:[]) + +fromDocs :: Foldable t => t (Doc ann) -> LinesBuilder ann () +fromDocs = LinesBuilder . tell . Endo . (\x -> (toList x ++)) + +-- | Builds up a list of @prettyprinter@ 'Doc's and then concats them with +-- 'vcat'. It is helpful for when a logical piece of the ebuild may use a +-- variable number of lines, including no lines at all. +-- +-- Since it is a 'Monad', it can be used in a @do@ block. +-- +-- Uses 'Endo' internally for more efficient list concats +newtype LinesBuilder ann a = LinesBuilder (Writer (Endo [Doc ann]) a) + deriving (Functor, Applicative, Monad) + +-- TypeFamilies/TypeOperators needs to be used here otherwise we get errors +-- when we go try to use OverloadedStrings +instance (a ~ ()) => IsString (LinesBuilder ann a) where + fromString = fromDoc . fromString + +execLinesBuilder :: LinesBuilder ann a -> Doc ann +execLinesBuilder (LinesBuilder w) = vsep (appEndo (execWriter w) []) + +-- | Replace any leading spaces on each line with tabs +replaceLeadingSpaces :: String -> String +replaceLeadingSpaces = unlines . map go . lines + where + go (' ' : rest) = '\t' : go rest + go rest = rest + diff --git a/src/Portage/EBuild/CabalFeature.hs b/src/Portage/EBuild/CabalFeature.hs index 273e4dbd..84ccfd98 100644 --- a/src/Portage/EBuild/CabalFeature.hs +++ b/src/Portage/EBuild/CabalFeature.hs @@ -13,7 +13,7 @@ data CabalFeature = Lib | Hoogle | HsColour | TestSuite - deriving Eq + deriving (Show, Read, Eq) instance Render CabalFeature where render = \case diff --git a/src/Portage/PackageId.hs b/src/Portage/PackageId.hs index 2e4b4002..421f1485 100644 --- a/src/Portage/PackageId.hs +++ b/src/Portage/PackageId.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} {-| Module : Portage.PackageId License : GPL-3+ @@ -25,15 +26,17 @@ module Portage.PackageId ( import qualified Distribution.Compat.CharParsing as P import qualified Distribution.Package as Cabal import Distribution.Parsec (CabalParsing(..), Parsec(..), explicitEitherParsec) -import Distribution.Pretty (Pretty(..), prettyShow) +import qualified Distribution.Pretty as Disp 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 ((<>)) +-- import qualified Text.PrettyPrint as Disp +-- import Text.PrettyPrint ((<>)) import System.FilePath (()) +import Prettyprinter hiding (cat) +import Prettyprinter.Render.String #if MIN_VERSION_base(4,11,0) import Prelude hiding ((<>)) @@ -54,7 +57,7 @@ instance NFData Category where rnf (Category c) = rnf c instance Pretty Category where - pretty (Category c) = Disp.text c + pretty (Category c) = pretty c instance Parsec Category where parsec = Category <$> P.munch1 categoryChar @@ -66,7 +69,7 @@ instance NFData PackageName where instance Pretty PackageName where pretty (PackageName cat name) = - pretty cat <> Disp.char '/' <> pretty name + pretty cat <> "/" <> pretty (Disp.prettyShow name) instance Parsec PackageName where parsec = do @@ -80,7 +83,7 @@ instance NFData PackageId where instance Pretty PackageId where pretty (PackageId name version) = - pretty name <> Disp.char '-' <> pretty version + pretty name <> "-" <> pretty version instance Parsec PackageId where parsec = do @@ -95,7 +98,7 @@ instance Parsec PackageId where -- "dev-haskell/foo-bar2/foo-bar2-3.0.0b_rc2-r1.ebuild" packageIdToFilePath :: PackageId -> FilePath packageIdToFilePath (PackageId (PackageName cat pn) version) = - prettyShow cat prettyShow pn prettyShow pn <-> prettyShow version <.> "ebuild" + prettyShow cat Disp.prettyShow pn Disp.prettyShow pn <-> prettyShow version <.> "ebuild" where a <-> b = a ++ '-':b a <.> b = a ++ '.':b @@ -200,4 +203,10 @@ parseCabalPackageName = do -- >>> cabal_pn_to_PN (Cabal.mkPackageName "FooBar1") -- "foobar1" cabal_pn_to_PN :: Cabal.PackageName -> String -cabal_pn_to_PN = map Char.toLower . prettyShow +cabal_pn_to_PN = map Char.toLower . Disp.prettyShow + +prettyShow :: Pretty a => a -> String +prettyShow + = renderString + . layoutPretty defaultLayoutOptions { layoutPageWidth = Unbounded } + . pretty diff --git a/src/Portage/Resolve.hs b/src/Portage/Resolve.hs index 183d777e..e2f9fd02 100644 --- a/src/Portage/Resolve.hs +++ b/src/Portage/Resolve.hs @@ -10,9 +10,9 @@ import qualified Portage.Overlay as Overlay import qualified Portage.PackageId as Portage import Distribution.Verbosity -import Distribution.Pretty (prettyShow) import qualified Distribution.Package as Cabal import Distribution.Simple.Utils +import Hackport.Pretty (prettyShow) import qualified Data.Map as Map diff --git a/src/Portage/Use.hs b/src/Portage/Use.hs index 6792ad1e..a5f05791 100644 --- a/src/Portage/Use.hs +++ b/src/Portage/Use.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Portage.Use ( -- * main structures @@ -11,9 +12,11 @@ module Portage.Use ( mkQUse ) where -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ((<>)) -import Distribution.Pretty (Pretty(..)) +-- import qualified Text.PrettyPrint as Disp +-- import Text.PrettyPrint ((<>)) +-- import Distribution.Pretty (Pretty(..), prettyShow) +-- import qualified Prettyprinter as PP +import Prettyprinter import Control.DeepSeq (NFData(..)) @@ -48,16 +51,16 @@ mkNotUse = N . UseFlag mkQUse :: Use -> UseFlag mkQUse = Q . UseFlag -showModificator :: UseFlag -> Disp.Doc +showModificator :: UseFlag -> Doc ann showModificator (UseFlag u) = pretty u -showModificator (X u) = Disp.char '!' <> pretty u -showModificator (Q u) = pretty u <> Disp.char '?' -showModificator (E u) = pretty u <> Disp.char '=' -showModificator (N u) = Disp.char '-' <> pretty u +showModificator (X u) = "!" <> pretty u +showModificator (Q u) = pretty u <> "?" +showModificator (E u) = pretty u <> "=" +showModificator (N u) = "-" <> pretty u -dispUses :: [UseFlag] -> Disp.Doc -dispUses [] = Disp.empty -dispUses us = Disp.brackets $ Disp.hcat $ (Disp.punctuate (Disp.text ",")) $ map pretty us +dispUses :: [UseFlag] -> Doc ann +dispUses [] = emptyDoc +dispUses us = brackets $ hcat $ (punctuate ",") $ map pretty us newtype Use = Use String deriving (Eq, Read, Show) @@ -66,7 +69,7 @@ instance NFData Use where rnf (Use s) = rnf s instance Pretty Use where - pretty (Use u) = Disp.text u + pretty (Use u) = pretty u instance Ord Use where compare (Use a) (Use b) = case (a,b) of diff --git a/src/Portage/Version.hs b/src/Portage/Version.hs index a39c40e2..e91771dc 100644 --- a/src/Portage/Version.hs +++ b/src/Portage/Version.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} {-| Author : Andres Loeh Stability : provisional @@ -19,20 +20,13 @@ module Portage.Version ( import qualified Distribution.Version as Cabal -import Distribution.Pretty (Pretty(..)) - import Distribution.Parsec (Parsec(..)) import qualified Distribution.Compat.CharParsing as P -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ((<>)) import qualified Data.List.NonEmpty as NE +import Prettyprinter import Control.DeepSeq (NFData(..)) -#if MIN_VERSION_base(4,11,0) -import Prelude hiding ((<>)) -#endif - -- | Portage-style version type. data Version = Version { versionNumber :: [Int] -- ^ @[1,42,3]@ ~= 1.42.3 , versionChar :: (Maybe Char) -- ^ optional letter @@ -49,11 +43,11 @@ instance Pretty Version where pretty (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 pretty - dispRev 0 = Disp.empty - dispRev n = Disp.text "-r" <> Disp.int n + dispVer = hcat . punctuate "." . map pretty + dispC = maybe emptyDoc pretty + dispSuf = hcat . map pretty + dispRev 0 = emptyDoc + dispRev n = "-r" <> pretty n -- | 'Version' parser using 'Parsec'. instance Parsec Version where @@ -105,16 +99,16 @@ instance NFData Suffix where instance Pretty Suffix where pretty 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 + Alpha n -> "_alpha" <> dispPos n + Beta n -> "_beta" <> dispPos n + Pre n -> "_pre" <> dispPos n + RC n -> "_rc" <> dispPos n + P n -> "_p" <> dispPos n where - dispPos :: Int -> Disp.Doc - dispPos 0 = Disp.empty - dispPos n = Disp.int n + dispPos :: Int -> Doc ann + dispPos 0 = emptyDoc + dispPos n = pretty n instance Parsec Suffix where parsec = P.char '_' diff --git a/src/Status.hs b/src/Status.hs index 1a9ed537..2e610ec5 100644 --- a/src/Status.hs +++ b/src/Status.hs @@ -30,8 +30,9 @@ import Control.Monad -- cabal import qualified Distribution.Package as Cabal (pkgName) import qualified Distribution.Simple.Utils as Cabal (equating) -import Distribution.Pretty (prettyShow) +import qualified Distribution.Pretty as Disp import Distribution.Parsec (simpleParsec) +import Hackport.Pretty (prettyShow) import qualified Distribution.Client.GlobalFlags as CabalInstall import qualified Distribution.Client.IndexUtils as CabalInstall @@ -182,7 +183,7 @@ statusPrinter packages = liftIO $ do let (PackageName c p) = pkg putStr (bold (show ix)) putStr " " - putStr $ prettyShow c ++ '/' : bold (prettyShow p) + putStr $ prettyShow c ++ '/' : bold (Disp.prettyShow p) putStr " " forM_ ebuilds $ \e -> do putStr $ toColor (fmap (prettyShow . pkgVersion . ebuildId) e) diff --git a/tests/data/golden/hakyll-4.16.1.0.ebuild b/tests/data/golden/hakyll-4.16.1.0.ebuild new file mode 100644 index 00000000..4494785b --- /dev/null +++ b/tests/data/golden/hakyll-4.16.1.0.ebuild @@ -0,0 +1,105 @@ +# Copyright 1999-2023 Gentoo Authors +# Distributed under the terms of the GNU General Public License v2 + +EAPI=8 + +# ebuild generated by hackport 0.8.4.0 + +CABAL_FEATURES="lib profile haddock hoogle hscolour test-suite" +inherit haskell-cabal + +DESCRIPTION="A static website compiler library" +HOMEPAGE="https://jaspervdj.be/hakyll" + +LICENSE="BSD" +SLOT="0/${PV}" +KEYWORDS="~amd64" +IUSE="buildwebsite +checkexternal +previewserver +usepandoc +watchserver" + +RDEPEND=" + >=dev-haskell/blaze-html-0.5:=[profile?] =dev-haskell/blaze-markup-0.5.1:=[profile?] =dev-haskell/data-default-0.4:=[profile?] =dev-haskell/file-embed-0.0.10.1:=[profile?] =dev-haskell/lrucache-1.1.1:=[profile?] =dev-haskell/optparse-applicative-0.12:=[profile?] =dev-haskell/parsec-3:=[profile?] =dev-haskell/random-1:=[profile?] =dev-haskell/regex-tdfa-1.1:=[profile?] =dev-haskell/resourcet-1.1:=[profile?] =dev-haskell/scientific-0.3.4:=[profile?] =dev-haskell/tagsoup-0.13.1:=[profile?] =dev-haskell/vector-0.11:=[profile?] =dev-haskell/yaml-0.8.11:=[profile?] =dev-lang/ghc-8.10.6:= + || ( + ( >=dev-haskell/aeson-1 =dev-haskell/aeson-2 =dev-haskell/text-0.11 =app-text/pandoc-2.11 =app-text/pandoc-3 =dev-haskell/http-conduit-2.2:=[profile?] =dev-haskell/fsnotify-0.2:=[profile?] =dev-haskell/http-types-0.9:=[profile?] =dev-haskell/warp-3.2:=[profile?] =dev-haskell/http-types-0.7:=[profile?] =dev-haskell/fsnotify-0.2:=[profile?] =app-text/pandoc-2.11 =app-text/pandoc-3 - readPackageString (prettyShow cat ++ "/" ++ prettyShow name ++ + readPackageString (prettyShow cat ++ "/" ++ Disp.prettyShow name ++ if (versionNumber version) == [] then "" else "-" ++ prettyShow version) @@ -38,7 +39,7 @@ spec = do (versionRevision version) /= 0 then Left (ArgumentError ("Could not parse [category/]package[-version]: " ++ prettyShow cat ++ "/" ++ - prettyShow name ++ + Disp.prettyShow name ++ if (versionNumber version) == [] then "" else "-" ++ prettyShow version)) diff --git a/tests/spec/Portage/EBuild/Golden.hs b/tests/spec/Portage/EBuild/Golden.hs new file mode 100644 index 00000000..5949dc33 --- /dev/null +++ b/tests/spec/Portage/EBuild/Golden.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Portage.EBuild.Golden (goldenTests) where + +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.Encoding as LBS +import Data.Time.Clock (UTCTime) +import System.FilePath (takeBaseName, replaceExtension) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.Golden (goldenVsStringDiff, findByExtension) + +import Portage.EBuild (showEBuild) +import Paths_hackport (getDataFileName) + +goldenTests :: IO TestTree +goldenTests = do + dataDir <- getDataFileName "tests/data/golden/" + -- @.out@ files were generated by 'pretty-simple' outputting live 'EBuild's + outFiles <- findByExtension [".out"] dataDir + pure $ testGroup "hackport golden tests" $ map runTest outFiles + where + runTest :: FilePath -> TestTree + runTest outFile = + goldenVsStringDiff + (takeBaseName outFile) -- test name + (\ref new -> ["/usr/bin/diff", "-u", "--color=always", ref, new]) + (replaceExtension outFile ".ebuild") -- golden file path + (readTestFile outFile) -- action whose result is tested + + readTestFile :: FilePath -> IO LBS.ByteString + readTestFile = + fmap (LBS.encodeUtf8 . T.pack . showEBuild time2023 . read) . readFile + + time2023 :: UTCTime + time2023 = read "2023-01-03 00:00:00 UTC" diff --git a/tests/spec/Portage/EBuildSpec.hs b/tests/spec/Portage/EBuildSpec.hs index 7b41b934..48f95ba9 100644 --- a/tests/spec/Portage/EBuildSpec.hs +++ b/tests/spec/Portage/EBuildSpec.hs @@ -14,14 +14,6 @@ spec = do drop_tdot "foo." `shouldBe` "foo" drop_tdot "foo..." `shouldBe` "foo" drop_tdot "foo" `shouldBe` "foo" - describe "quote" $ do - it "should correctly surround a string with special characters in quotes" $ 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\"" describe "toHttps" $ do it "should not convert whitelisted http-only homepages into https homepages" $ do toHttps "http://leksah.org" `shouldBe` "http://leksah.org" diff --git a/tests/spec/Portage/PackageIdSpec.hs b/tests/spec/Portage/PackageIdSpec.hs index 33c5c1c0..88d6503b 100644 --- a/tests/spec/Portage/PackageIdSpec.hs +++ b/tests/spec/Portage/PackageIdSpec.hs @@ -7,7 +7,8 @@ import QuickCheck.Instances import qualified Data.Char as Char import qualified Distribution.Package as Cabal -import Distribution.Pretty (prettyShow) +import qualified Distribution.Pretty as Disp +import Hackport.Pretty (prettyShow) import Portage.PackageId @@ -20,7 +21,7 @@ spec = do in \(ComplexVersion version) -> packageIdToFilePath (PackageId (PackageName cat name) version) `shouldBe` - "dev-haskell/" ++ prettyShow name ++ "/" ++ prettyShow name ++ "-" ++ + "dev-haskell/" ++ Disp.prettyShow name ++ "/" ++ Disp.prettyShow name ++ "-" ++ prettyShow version ++ ".ebuild" describe "filePathToPackageId" $ do @@ -29,14 +30,14 @@ spec = do name = Cabal.mkPackageName "foo-bar2+" in \(ComplexVersion version) -> filePathToPackageId cat - (prettyShow name ++ "-" ++ prettyShow version) + (Disp.prettyShow name ++ "-" ++ prettyShow version) `shouldBe` Just (PackageId (PackageName cat name) version) prop "returns Nothing on a malformed FilePath" $ do let cat = Category "dev-haskell" name = Cabal.mkPackageName "foo-bar-2+" in \(ComplexVersion version) -> - filePathToPackageId cat (prettyShow name ++ "-" ++ prettyShow version) + filePathToPackageId cat (Disp.prettyShow name ++ "-" ++ prettyShow version) `shouldBe` Nothing @@ -50,7 +51,7 @@ spec = do let cat = Category "dev-haskell" name = Cabal.mkPackageName "package-name1+" in \(ComplexVersion version) -> - parseFriendlyPackage (prettyShow cat ++ "/" ++ prettyShow name + parseFriendlyPackage (prettyShow cat ++ "/" ++ Disp.prettyShow name ++ "-" ++ prettyShow version) `shouldBe` Right (Just cat, name, Just version) @@ -58,7 +59,7 @@ spec = do let cat = Category "dev-haskell" name = Cabal.mkPackageName "package-name-1+" in \(ComplexVersion version) -> - parseFriendlyPackage (prettyShow cat ++ "/" ++ prettyShow name + parseFriendlyPackage (prettyShow cat ++ "/" ++ Disp.prettyShow name ++ "-" ++ prettyShow version) `shouldNotBe` Right (Just cat, name, Just version) diff --git a/tests/spec/RunTests.hs b/tests/spec/RunTests.hs deleted file mode 100644 index 319b5ae2..00000000 --- a/tests/spec/RunTests.hs +++ /dev/null @@ -1,15 +0,0 @@ -module RunTests - (run_tests) where - -import Control.Monad (when) - -import System.Exit (exitFailure) -import Test.HUnit - -something_broke :: Counts -> Bool -something_broke stats = errors stats + failures stats > 0 - -run_tests :: Test -> IO () -run_tests tests = - do stats <- runTestTT tests - when (something_broke stats) exitFailure