diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -41,5 +41,5 @@ cabal build --only-dependencies --enable-tests --enable-benchmarks - name: Build run: cabal v2-build --enable-tests all - - name: Run hspec tests - run: cabal v2-test spec --test-option=--color --test-show-details=streaming + - name: Run all enabled tests + run: cabal test --test-option=--color --test-show-details=streaming diff --git a/AnsiColor.hs b/AnsiColor.hs deleted file mode 100644 --- a/AnsiColor.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-| - Stability : provisional - Portability : haskell98 - - Simplistic ANSI color support. --} - -module AnsiColor - ( Color(..) - , bold - , inColor - ) where - -import Data.List - -data Color = Black - | Red - | Green - | Yellow - | Blue - | Magenta - | Cyan - | White - | Default - deriving Enum - -esc :: [String] -> String -esc [] = "" -esc xs = "\ESC[" ++ (intercalate ";" 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 :: 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] diff --git a/Cabal2Ebuild.hs b/Cabal2Ebuild.hs deleted file mode 100644 --- a/Cabal2Ebuild.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-| -Module : Cabal2Ebuild -Copyright : (C) 2005, Duncan Coutts -License : GPL-2+ -Maintainer : haskell@gentoo.org - -A program for generating a Gentoo ebuild from a .cabal file --} --- 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. --- -module Cabal2Ebuild - (cabal2ebuild - ,convertDependencies - ,convertDependency) where - -import qualified Distribution.PackageDescription as Cabal - ( PackageDescription(..), license) -import qualified Distribution.Package as Cabal ( PackageIdentifier(..) - , Dependency(..)) -import qualified Distribution.Version as Cabal ( VersionRange - , cataVersionRange, normaliseVersionRange - , majorUpperBound, mkVersion ) -import Distribution.Version (VersionRangeF(..)) -import Distribution.Pretty (prettyShow) - -import qualified Distribution.Utils.ShortText as ST - -import Data.Char (isUpper) -import Data.Maybe - -import Portage.Dependency -import qualified Portage.Cabal as Portage -import qualified Portage.PackageId as Portage -import qualified Portage.EBuild as Portage -import qualified Portage.EBuild.CabalFeature as Portage -import qualified Portage.Resolve as Portage -import qualified Portage.EBuild as E -import qualified Portage.Overlay as O -import Portage.Version - --- | Generate a 'Portage.EBuild' from a 'Portage.Category' and a 'Cabal.PackageDescription'. -cabal2ebuild :: Portage.Category -> Cabal.PackageDescription -> Portage.EBuild -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.description = ST.fromShortText $ if ST.null (Cabal.synopsis pkg) - then Cabal.description pkg - else Cabal.synopsis pkg, - E.homepage = thisHomepage, - E.license = Portage.convertLicense $ Cabal.license pkg, - E.slot = (E.slot E.ebuildTemplate) ++ (if hasLibs then "/${PV}" else ""), - E.my_pn = if any isUpper cabalPkgName then Just cabalPkgName else Nothing, - E.features = E.features E.ebuildTemplate - ++ (if hasLibs then ([ Portage.Lib - , Portage.Profile - , Portage.Haddock - , Portage.Hoogle - ] - ++ if cabalPkgName == "hscolour" - then [] - else [Portage.HsColour]) - else []) - ++ (if hasTests then [Portage.TestSuite] - else []) - } where - cabal_pn = Cabal.pkgName $ Cabal.package pkg - cabalPkgName = prettyShow cabal_pn - hasLibs = isJust (Cabal.library pkg) - hasTests = (not . null) (Cabal.testSuites pkg) - thisHomepage = if (ST.null $ Cabal.homepage pkg) - then E.homepage E.ebuildTemplate - else ST.fromShortText $ Cabal.homepage pkg - --- | Map 'convertDependency' over ['Cabal.Dependency']. -convertDependencies :: O.Overlay -> Portage.Category -> [Cabal.Dependency] -> [Dependency] -convertDependencies overlay category = map (convertDependency overlay category) - --- | Convert 'Cabal.Dependency' into 'Dependency'. -convertDependency :: O.Overlay -> Portage.Category -> Cabal.Dependency -> Dependency -convertDependency overlay category (Cabal.Dependency pname versionRange _lib) - = 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 = DependAtom (Atom pn dr (DAttr AnySlot [])) - p_v v = fromCabalVersion v - - convert :: Cabal.VersionRange -> Dependency - convert = Cabal.cataVersionRange alg . Cabal.normaliseVersionRange - where - alg (ThisVersionF v) = mk_p $ DExact $ p_v v - alg (LaterVersionF v) = mk_p $ DRange (StrictLB $ p_v v) InfinityB - alg (EarlierVersionF v) = mk_p $ DRange ZeroB $ StrictUB $ p_v v - alg (OrLaterVersionF v) = if v == Cabal.mkVersion [0] -- any version - then mk_p $ DRange ZeroB InfinityB - else mk_p $ DRange (NonstrictLB $ p_v v) - InfinityB - alg (OrEarlierVersionF v) = mk_p $ DRange ZeroB $ NonstrictUB $ p_v v - alg (MajorBoundVersionF v) = mk_p $ DRange (NonstrictLB $ p_v v) - $ StrictUB $ p_v $ Cabal.majorUpperBound v - alg (UnionVersionRangesF v1 v2) = DependAnyOf [v1, v2] - alg (IntersectVersionRangesF v1 v2) = DependAllOf [v1, v2] diff --git a/Error.hs b/Error.hs deleted file mode 100644 --- a/Error.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module Error (HackPortError(..), throwEx, catchEx, hackPortShowError) where - -import Data.Typeable -import Control.Exception.Extensible as EE - --- | Type holding all of the 'HackPortError' constructors. -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 - , Eq -- ^ needed for spec test-suite - ) - -instance Exception HackPortError where - --- | Throw a 'HackPortError'. -throwEx :: HackPortError -> IO a -throwEx = EE.throw - --- | Catch a 'HackPortError'. -catchEx :: IO a -> (HackPortError -> IO a) -> IO a -catchEx = EE.catch - --- | Show the error string for a given 'HackPortError'. -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 repository's location. Either set a repository 'haskell' in '/etc/portage/repos.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' " - NoOverlay -> "Unable to find a repository 'haskell'. Consider defining it in '/etc/portage/repos.conf' and verify '~/.hackport/repositories' (in overlay_list) 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/HackPort/GlobalFlags.hs b/HackPort/GlobalFlags.hs deleted file mode 100644 --- a/HackPort/GlobalFlags.hs +++ /dev/null @@ -1,51 +0,0 @@ -module HackPort.GlobalFlags - ( GlobalFlags(..) - , defaultGlobalFlags - , withHackPortContext - ) where - -import qualified Distribution.Verbosity as DV -import qualified Distribution.Simple.Setup as DSS -import qualified Distribution.Client.Config as DCC -import qualified Distribution.Client.GlobalFlags as DCG -import qualified Distribution.Client.Types as DCT -import qualified Distribution.Utils.NubList as DUN - -import qualified Network.URI as NU - -import System.FilePath (()) - -import qualified Overlays - --- | Type containing global flags. -data GlobalFlags = - GlobalFlags { globalVersion :: DSS.Flag Bool - , globalNumericVersion :: DSS.Flag Bool - , globalPathToOverlay :: DSS.Flag (Maybe FilePath) - , globalPathToPortage :: DSS.Flag (Maybe FilePath) - } - --- | Default 'GlobalFlags'. -defaultGlobalFlags :: GlobalFlags -defaultGlobalFlags = - GlobalFlags { globalVersion = DSS.Flag False - , globalNumericVersion = DSS.Flag False - , globalPathToOverlay = DSS.Flag Nothing - , globalPathToPortage = DSS.Flag Nothing - } - --- | Default remote repository. Defaults to [hackage](hackage.haskell.org). -defaultRemoteRepo :: DCT.RemoteRepo -defaultRemoteRepo = DCC.addInfoForKnownRepos $ (DCT.emptyRemoteRepo (DCT.RepoName name)) { DCT.remoteRepoURI = uri } - where - Just uri = NU.parseURI "https://hackage.haskell.org/" - name = "hackage.haskell.org" - -withHackPortContext :: DV.Verbosity -> GlobalFlags -> (DCG.RepoContext -> IO a) -> IO a -withHackPortContext verbosity global_flags callback = do - overlayPath <- Overlays.getOverlayPath verbosity (DSS.fromFlag $ globalPathToOverlay global_flags) - let flags = DCG.defaultGlobalFlags { - DCG.globalRemoteRepos = DUN.toNubList [defaultRemoteRepo] - , DCG.globalCacheDir = DSS.Flag $ overlayPath ".hackport" - } - DCG.withRepoContext verbosity flags callback diff --git a/Main.hs b/Main.hs deleted file mode 100644 --- a/Main.hs +++ /dev/null @@ -1,491 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Main (main) where - -import Control.Monad -import Data.Maybe -import Data.List -import qualified Data.Semigroup as S - --- cabal -import Distribution.Simple.Setup - ( Flag(..), fromFlag - , trueArg - , optionVerbosity - ) - -import Distribution.Simple.Command -- commandsRun -import Distribution.Simple.Utils ( dieNoVerbosity, cabalVersion, warn ) -import qualified Distribution.PackageDescription.Parsec as Cabal -import qualified Distribution.Package as Cabal -import Distribution.Verbosity (Verbosity, normal) - -import Data.Version (showVersion) -import Distribution.Pretty (prettyShow) -import Distribution.Parsec (simpleParsec) - -import qualified Distribution.Client.Setup as CabalInstall -import qualified Distribution.Client.Types as CabalInstall -import qualified Distribution.Client.Update as CabalInstall - -import qualified Distribution.Client.IndexUtils as CabalInstall -import qualified Distribution.Solver.Types.SourcePackage as CabalInstall -import qualified Distribution.Solver.Types.PackageIndex as CabalInstall - -import Portage.Overlay as Overlay ( loadLazy, inOverlay ) -import Portage.Host as Host ( getInfo, portage_dir ) -import Portage.PackageId ( normalizeCabalPackageId ) - -import System.Environment ( getArgs, getProgName ) -import System.Directory ( doesDirectoryExist ) -import System.Exit ( exitFailure ) -{-# LANGUAGE CPP #-} - -import System.FilePath ( () ) - -import qualified HackPort.GlobalFlags as H - -import Error -import Status -import Overlays -import Merge - -import qualified Paths_cabal_install -import qualified Paths_hackport - ------------------------------------------------------------------------ --- List ------------------------------------------------------------------------ - -data ListFlags = ListFlags { - listVerbosity :: Flag Verbosity - } - -instance S.Semigroup ListFlags where - a <> b = ListFlags { - listVerbosity = combine listVerbosity - } - where combine field = field a S.<> field b - -instance Monoid ListFlags where - mempty = ListFlags { - listVerbosity = mempty - } -#if !(MIN_VERSION_base(4,11,0)) - mappend a b = ListFlags { - listVerbosity = combine listVerbosity - } - where combine field = field a `mappend` field b -#endif - -defaultListFlags :: ListFlags -defaultListFlags = ListFlags { - listVerbosity = Flag normal - } - -listCommand :: CommandUI ListFlags -listCommand = CommandUI { - commandName = "list", - commandSynopsis = "List package versions matching pattern", - commandUsage = usagePackages "list", - commandDescription = Nothing, - commandNotes = Nothing, - - 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] -> H.GlobalFlags -> IO () -listAction flags extraArgs globalFlags = do - let verbosity = fromFlag (listVerbosity flags) - H.withHackPortContext verbosity globalFlags $ \repoContext -> do - overlayPath <- getOverlayPath verbosity (fromFlag $ H.globalPathToOverlay globalFlags) - index <- fmap CabalInstall.packageIndex (CabalInstall.getSourcePackages verbosity repoContext) - overlay <- Overlay.loadLazy overlayPath - let pkgs | null extraArgs = CabalInstall.allPackages index - | otherwise = concatMap (concatMap snd . CabalInstall.searchByNameSubstring index) extraArgs - normalized = map (normalizeCabalPackageId . CabalInstall.srcpkgPackageId) 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 ++ prettyShow pkgId - - ------------------------------------------------------------------------ --- Make Ebuild ------------------------------------------------------------------------ - -data MakeEbuildFlags = MakeEbuildFlags { - makeEbuildVerbosity :: Flag Verbosity - , makeEbuildCabalFlags :: Flag (Maybe String) - } - -instance S.Semigroup MakeEbuildFlags where - a <> b = MakeEbuildFlags { - makeEbuildVerbosity = combine makeEbuildVerbosity - , makeEbuildCabalFlags = makeEbuildCabalFlags b - } - where combine field = field a S.<> field b - -instance Monoid MakeEbuildFlags where - mempty = MakeEbuildFlags { - makeEbuildVerbosity = mempty - , makeEbuildCabalFlags = mempty - } -#if !MIN_VERSION_base(4,11,0) - mappend a b = MakeEbuildFlags { - makeEbuildVerbosity = combine makeEbuildVerbosity - , makeEbuildCabalFlags = makeEbuildCabalFlags b - } - where combine field = field a `mappend` field b -#endif - -defaultMakeEbuildFlags :: MakeEbuildFlags -defaultMakeEbuildFlags = MakeEbuildFlags { - makeEbuildVerbosity = Flag normal - , makeEbuildCabalFlags = Flag Nothing - } - -makeEbuildAction :: MakeEbuildFlags -> [String] -> H.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. ") - cat <- case simpleParsec catstr of - Just c -> return c - Nothing -> throwEx (ArgumentError ("could not parse category: " ++ catstr)) - let verbosity = fromFlag (makeEbuildVerbosity flags) - overlayPath <- getOverlayPath verbosity (fromFlag $ H.globalPathToOverlay globalFlags) - forM_ cabals $ \cabalFileName -> do - pkg <- Cabal.readGenericPackageDescription normal cabalFileName - mergeGenericPackageDescription verbosity overlayPath cat pkg False (fromFlag $ makeEbuildCabalFlags flags) - -makeEbuildCommand :: CommandUI MakeEbuildFlags -makeEbuildCommand = CommandUI { - commandName = "make-ebuild", - commandSynopsis = "Make an ebuild from a .cabal file", - commandUsage = \_ -> [], - commandDescription = Nothing, - commandNotes = Nothing, - - commandDefaultFlags = defaultMakeEbuildFlags, - commandOptions = \_showOrParseArgs -> - [ optionVerbosity makeEbuildVerbosity (\v flags -> flags { makeEbuildVerbosity = v }) - - , option "f" ["flags"] - (unlines [ "Set cabal flags to certain state." - , "Example: --flags=-all_extensions" - ]) - makeEbuildCabalFlags - (\cabal_flags v -> v{ makeEbuildCabalFlags = cabal_flags }) - (reqArg' "cabal_flags" (Flag . Just) (\(Flag ms) -> catMaybes [ms])) - ] - } - ------------------------------------------------------------------------ --- Update ------------------------------------------------------------------------ - -data UpdateFlags = UpdateFlags { - updateVerbosity :: Flag Verbosity - } - -instance S.Semigroup UpdateFlags where - a <> b = UpdateFlags { - updateVerbosity = combine updateVerbosity - } - where combine field = field a S.<> field b - -instance Monoid UpdateFlags where - mempty = UpdateFlags { - updateVerbosity = mempty - } -#if !(MIN_VERSION_base(4,11,0)) - mappend a b = UpdateFlags { - updateVerbosity = combine updateVerbosity - } - where combine field = field a `mappend` field b -#endif - -defaultUpdateFlags :: UpdateFlags -defaultUpdateFlags = UpdateFlags { - updateVerbosity = Flag normal - } - -updateCommand :: CommandUI UpdateFlags -updateCommand = CommandUI { - commandName = "update", - commandSynopsis = "Update the local package database", - commandUsage = usageFlags "update", - commandDescription = Nothing, - commandNotes = Nothing, - - 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] -> H.GlobalFlags -> IO () -updateAction flags extraArgs globalFlags = do - unless (null extraArgs) $ - dieNoVerbosity $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs - let verbosity = fromFlag (updateVerbosity flags) - - H.withHackPortContext verbosity globalFlags $ \repoContext -> - -- TODO: parse user's flags as cabal-iinstall does. - -- Currently I'm lazy to adapt new flag and user: - -- defaultUpdateFlags - let updateFlags = commandDefaultFlags CabalInstall.updateCommand - in CabalInstall.update verbosity updateFlags repoContext - ------------------------------------------------------------------------ --- 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 up-to-date status against other repos (hackage, ::gentoo)", - commandUsage = usagePackages "status", - commandDescription = Nothing, - commandNotes = Nothing, - - 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] -> H.GlobalFlags -> IO () -statusAction flags args globalFlags = do - let verbosity = fromFlag (statusVerbosity flags) - direction = fromFlag (statusDirection flags) - portagePath <- getPortageDir verbosity globalFlags - overlayPath <- getOverlayPath verbosity (fromFlag $ H.globalPathToOverlay globalFlags) - - H.withHackPortContext verbosity globalFlags $ \repoContext -> - runStatus verbosity portagePath overlayPath direction args repoContext - ------------------------------------------------------------------------ --- Merge ------------------------------------------------------------------------ - -data MergeFlags = MergeFlags { - mergeVerbosity :: Flag Verbosity - , mergeCabalFlags :: Flag (Maybe String) - } - -instance S.Semigroup MergeFlags where - a <> b = MergeFlags { - mergeVerbosity = combine mergeVerbosity - , mergeCabalFlags = mergeCabalFlags b - } - where combine field = field a S.<> field b - -instance Monoid MergeFlags where - mempty = MergeFlags { - mergeVerbosity = mempty - , mergeCabalFlags = mempty - } -#if !(MIN_VERSION_base(4,11,0)) - mappend a b = MergeFlags { - mergeVerbosity = combine mergeVerbosity - , mergeCabalFlags = mergeCabalFlags b - } - where combine field = field a `mappend` field b -#endif - -defaultMergeFlags :: MergeFlags -defaultMergeFlags = MergeFlags { - mergeVerbosity = Flag normal - , mergeCabalFlags = Flag Nothing - } - -mergeCommand :: CommandUI MergeFlags -mergeCommand = CommandUI { - commandName = "merge", - commandSynopsis = "Make an ebuild out of hackage package", - commandUsage = usagePackages "merge", - commandDescription = Nothing, - commandNotes = Nothing, - - commandDefaultFlags = defaultMergeFlags, - commandOptions = \_showOrParseArgs -> - [ optionVerbosity mergeVerbosity (\v flags -> flags { mergeVerbosity = v }) - - , option "f" ["flags"] - (unlines [ "Set cabal flags to certain state." - , "Example: --flags=-all_extensions" - ]) - mergeCabalFlags - (\cabal_flags v -> v{ mergeCabalFlags = cabal_flags}) - (reqArg' "cabal_flags" (Flag . Just) (\(Flag ms) -> catMaybes [ms])) - ] - } - -mergeAction :: MergeFlags -> [String] -> H.GlobalFlags -> IO () -mergeAction flags extraArgs globalFlags = do - let verbosity = fromFlag (mergeVerbosity flags) - overlayPath <- getOverlayPath verbosity (fromFlag $ H.globalPathToOverlay globalFlags) - - H.withHackPortContext verbosity globalFlags $ \repoContext -> - merge verbosity repoContext extraArgs overlayPath (fromFlag $ mergeCabalFlags flags) - ------------------------------------------------------------------------ --- Utils ------------------------------------------------------------------------ - -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 -> H.GlobalFlags -> IO FilePath -getPortageDir verbosity globalFlags = do - let portagePathM = fromFlag (H.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 ------------------------------------------------------------------------ - -globalCommand :: CommandUI H.GlobalFlags -globalCommand = CommandUI { - commandName = "", - commandSynopsis = "HackPort is an .ebuild generator from .cabal files with hackage index support", - commandDescription = Just $ \pname -> - let - commands' = commands ++ [commandAddAction helpCommandUI undefined] - cmdDescs = getNormalCommandDescriptions commands' - maxlen = maximum $ [length name | (name, _) <- cmdDescs] - align str = str ++ replicate (maxlen - length str) ' ' - in - "Commands:\n" - ++ unlines [ " " ++ align name ++ " " ++ descr - | (name, descr) <- cmdDescs ] - ++ "\n" - ++ "For more information about a command use\n" - ++ " " ++ pname ++ " COMMAND --help\n\n" - ++ "Typical steps for generating ebuilds from hackage packages:\n" - ++ concat [ " " ++ pname ++ " " ++ x ++ "\n" - | x <- ["update", "merge "]] - ++ "\n" - ++ "Advanced usage:\n" - ++ concat [ " " ++ pname ++ " " ++ x ++ "\n" - | x <- ["update", "make-ebuild "]], - - commandNotes = Nothing, - commandUsage = \pname -> "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n", - commandDefaultFlags = H.defaultGlobalFlags, - commandOptions = \_showOrParseArgs -> - [ option ['V'] ["version"] - "Print version information" - H.globalVersion (\v flags -> flags { H.globalVersion = v }) - trueArg - , option [] ["numeric-version"] - "Print just the version number" - H.globalNumericVersion (\v flags -> flags { H.globalNumericVersion = v }) - trueArg - , option ['p'] ["overlay-path"] - "Override search path list where .hackport/ lives (default list: ['.', paludis-ovls or emerge-ovls])" - H.globalPathToOverlay (\ovrl_path flags -> flags { H.globalPathToOverlay = ovrl_path }) - (reqArg' "PATH" (Flag . Just) (\(Flag ms) -> catMaybes [ms])) - , option [] ["portage-path"] - "Override path to your portage tree" - H.globalPathToPortage (\port_path flags -> flags { H.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 (H.globalVersion globalflags) -> printVersion - | fromFlag (H.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 $ showVersion Paths_hackport.version - printVersion = putStrLn $ "hackport version " - ++ showVersion Paths_hackport.version - ++ "\nusing cabal-install " - ++ showVersion Paths_cabal_install.version - ++ " and the Cabal library version " - ++ prettyShow cabalVersion - errorHandler :: HackPortError -> IO () - errorHandler e = do - putStrLn (hackPortShowError e) - -commands :: [Command (H.GlobalFlags -> IO ())] -commands = - [ listCommand `commandAddAction` listAction - , makeEbuildCommand `commandAddAction` makeEbuildAction - , statusCommand `commandAddAction` statusAction - , updateCommand `commandAddAction` updateAction - , mergeCommand `commandAddAction` mergeAction - ] - -main :: IO () -main = getArgs >>= mainWorker diff --git a/Merge.hs b/Merge.hs deleted file mode 100644 --- a/Merge.hs +++ /dev/null @@ -1,533 +0,0 @@ -{-| -Module : Merge -License : GPL-3+ -Maintainer : haskell@gentoo.org - -Core functionality of the @merge@ command of @HackPort@. --} -module Merge - ( merge - , mergeGenericPackageDescription - ) where - -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 qualified Data.Map.Strict as Map -import Data.Maybe -import qualified Data.List as L -import qualified Data.Set as S -import qualified Data.Time.Clock as TC - --- cabal -import qualified Distribution.Package as Cabal -import qualified Distribution.Version as Cabal -import qualified Distribution.PackageDescription as Cabal -import qualified Distribution.PackageDescription.PrettyPrint as Cabal (showPackageDescription) -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 - --- cabal-install -import Distribution.Client.IndexUtils ( getSourcePackages ) -import qualified Distribution.Client.GlobalFlags as CabalInstall -import Distribution.Client.Types --- others -import Control.Parallel.Strategies -import qualified Data.List.Split as DLS -import System.Directory ( getCurrentDirectory - , setCurrentDirectory - , createDirectoryIfMissing - , doesFileExist - , listDirectory - ) -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 qualified Portage.Cabal as Portage -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.Use as Portage - -import qualified Portage.GHCCore as GHCCore - -import qualified Merge.Dependencies as Merge -import qualified Merge.Utils as Merge - -{- -Requested features: - * Add files to git? --} - --- | Call @diff@ between two ebuilds. -diffEbuilds :: FilePath -> Portage.PackageId -> Portage.PackageId -> IO () -diffEbuilds fp a b = do _ <- system $ "diff -u --color=auto " - ++ fp Portage.packageIdToFilePath a ++ " " - ++ fp Portage.packageIdToFilePath b - exitSuccess - --- | 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 :: [UnresolvedSourcePackage] -> Maybe Cabal.Version -> Maybe UnresolvedSourcePackage -resolveVersion avails Nothing = Just $ L.maximumBy (comparing (Cabal.pkgVersion . CabalInstall.srcpkgPackageId)) avails -resolveVersion avails (Just ver) = listToMaybe (filter match avails) - where - match avail = ver == Cabal.pkgVersion (CabalInstall.srcpkgPackageId avail) - --- | This function is executed by the @merge@ command of @HackPort@. --- Its functionality is as follows: --- --- 1. Feed user input to 'readPackageString' --- 2. Look for a matching package on the @hackage@ database --- 3. Run 'mergeGenericPackageDescription' with the supplied information --- 4. Generate a coloured diff between the old and new ebuilds. --- --- Various information is printed in between these steps depending on the --- 'Verbosity'. -merge :: Verbosity -> CabalInstall.RepoContext -> [String] -> FilePath -> Maybe String -> IO () -merge verbosity repoContext args overlayPath users_cabal_flags = do - (m_category, user_pName, m_version) <- - case Merge.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 user_pname_str = Cabal.unPackageName user_pName - - overlay <- Overlay.loadLazy overlayPath - -- portage_path <- Host.portage_dir `fmap` Host.getInfo - -- portage <- Overlay.loadLazy portage_path - index <- fmap packageIndex $ getSourcePackages verbosity repoContext - - -- find all packages that maches the user specified package name - availablePkgs <- - case map snd (CabalInstall.searchByName index user_pname_str) of - [] -> throwEx (PackageNotFound user_pname_str) - [pkg] -> return pkg - pkgs -> do let cabal_pkg_to_pn pkg = Cabal.unPackageName $ Cabal.pkgName (CabalInstall.srcpkgPackageId pkg) - 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 (prettyShow . Cabal.pkgVersion . CabalInstall.srcpkgPackageId) 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 (prettyShow . CabalInstall.srcpkgPackageId $ 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 | CabalInstall.srcpkgPackageId avail == CabalInstall.srcpkgPackageId selectedPkg = "* " - | otherwise = "- " - info verbosity $ match_text ++ (prettyShow . CabalInstall.srcpkgPackageId $ avail) - - let cabal_pkgId = CabalInstall.srcpkgPackageId selectedPkg - norm_pkgName = Cabal.packageName (Portage.normalizeCabalPackageId cabal_pkgId) - cat <- maybe (Portage.resolveCategory verbosity overlay norm_pkgName) return m_category - mergeGenericPackageDescription verbosity overlayPath cat (CabalInstall.srcpkgDescription selectedPkg) True users_cabal_flags - - -- Maybe generate a diff - let pkgPath = overlayPath (Portage.unCategory cat) (Cabal.unPackageName norm_pkgName) - newPkgId = Portage.fromCabalPackageId cat cabal_pkgId - pkgDir <- listDirectory pkgPath - case Merge.getPreviousPackageId pkgDir newPkgId of - Just validPkg -> do info verbosity "Generating a diff..." - diffEbuilds overlayPath validPkg newPkgId - _ -> info verbosity "Nothing to diff!" - --- used to be FlagAssignment in Cabal but now it's an opaque type -type CabalFlags = [(Cabal.FlagName, Bool)] - --- | Generate an ebuild from a 'Cabal.GenericPackageDescription'. -mergeGenericPackageDescription :: Verbosity -> FilePath -> Portage.Category -> Cabal.GenericPackageDescription -> Bool -> Maybe String -> IO () -mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch users_cabal_flags = do - overlay <- Overlay.loadLazy overlayPath - let merged_cabal_pkg_name = Cabal.pkgName (Cabal.package (Cabal.packageDescription pkgGenericDesc)) - merged_PN = Portage.cabal_pn_to_PN merged_cabal_pkg_name - pkgdir = overlayPath Portage.unCategory cat merged_PN - existing_meta <- EM.findExistingMeta pkgdir - let requested_cabal_flags = Merge.first_just_of [users_cabal_flags, EM.cabal_flags existing_meta] - - -- accepts things, like: "cabal_flag:iuse_name", "+cabal_flag", "-cabal_flag" - read_fas :: Maybe String -> (CabalFlags, [(String, String)]) - read_fas Nothing = ([], []) - read_fas (Just user_fas_s) = (user_fas, user_renames) - where user_fas = [ (cf, b) - | ((cf, _), Just b) <- cn_in_mb - ] - user_renames = [ (cfn, ein) - | ((cabal_cfn, ein), Nothing) <- cn_in_mb - , let cfn = Cabal.unFlagName cabal_cfn - ] - cn_in_mb = map read_fa $ DLS.splitOn "," user_fas_s - read_fa :: String -> ((Cabal.FlagName, String), Maybe Bool) - read_fa [] = error $ "read_fas: empty flag?" - read_fa (op:flag) = - case op of - '+' -> (get_rename flag, Just True) - '-' -> (get_rename flag, Just False) - _ -> (get_rename (op:flag), Nothing) - where get_rename :: String -> (Cabal.FlagName, String) - get_rename s = - case DLS.splitOn ":" s of - [cabal_flag_name] -> (Cabal.mkFlagName cabal_flag_name, cabal_flag_name) - [cabal_flag_name, iuse_name] -> (Cabal.mkFlagName cabal_flag_name, iuse_name) - _ -> error $ "get_rename: too many components" ++ show (s) - - (user_specified_fas, cf_to_iuse_rename) = read_fas requested_cabal_flags - - debug verbosity "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 - cn = prettyShow cat - in error $ unlines [ "mergeGenericPackageDescription: failed to find suitable GHC for " ++ pn - , " You can try to merge the package manually:" - , " $ cabal unpack " ++ pn - , " $ cd " ++ pn ++ "*/" - , " # fix " ++ pn ++ ".cabal" - , " $ hackport make-ebuild " ++ cn ++ " " ++ pn ++ ".cabal" - ] - - let (accepted_deps, skipped_deps) = Portage.partition_depends ghc_packages merged_cabal_pkg_name - (Merge.exeAndLibDeps pkgDesc0) - - pkgDesc = Merge.RetroPackageDescription pkgDesc0 accepted_deps - cabal_flag_descs = Cabal.genPackageFlags pkgGenericDesc - all_flags = map Cabal.flagName cabal_flag_descs - make_fas :: [Cabal.PackageFlag] -> [CabalFlags] - make_fas [] = [[]] - make_fas (f:rest) = [ (fn, is_enabled) : fas - | fas <- make_fas rest - , let fn = Cabal.flagName f - users_choice = lookup fn user_specified_fas - , is_enabled <- maybe [False, True] - (\b -> [b]) - users_choice - ] - all_possible_flag_assignments :: [CabalFlags] - all_possible_flag_assignments = make_fas cabal_flag_descs - - pp_fa :: CabalFlags -> String - pp_fa fa = L.intercalate ", " [ (if b then '+' else '-') : f - | (cabal_f, b) <- fa - , let f = Cabal.unFlagName cabal_f - ] - - 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 - - -- key idea is to generate all possible list of flags - deps1 :: [(CabalFlags, Merge.EDep)] - deps1 = [ ( f `updateFa` Cabal.unFlagAssignment fr - , cabal_to_emerge_dep pkgDesc_filtered_bdeps) - | f <- all_possible_flag_assignments - , Right (pkgDesc1,fr) <- [GHCCore.finalizePD (Cabal.mkFlagAssignment f) - GHCCore.defaultComponentRequestedSpec - (GHCCore.dependencySatisfiable pix) - GHCCore.platform - compiler_info - [] - pkgGenericDesc] - -- drop circular deps and shipped deps - , let (ad, _sd) = Portage.partition_depends ghc_packages merged_cabal_pkg_name - (Merge.exeAndLibDeps pkgDesc1) - -- 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 [] _ = [] - updateFa (x:xs) y = case lookup (fst x) y of - -- TODO: when does this code get triggered? - Nothing -> x : updateFa xs y - Just y' -> (fst x,y') : updateFa xs y - -- then remove all flags that can't be changed - successfully_resolved_flag_assignments = map fst deps1 - common_fa = L.foldl1' L.intersect successfully_resolved_flag_assignments - common_flags = map fst common_fa - active_flags = all_flags L.\\ common_flags - active_flag_descs = filter (\x -> Cabal.flagName x `elem` active_flags) cabal_flag_descs - irresolvable_flag_assignments = all_possible_flag_assignments L.\\ successfully_resolved_flag_assignments - -- flags, not guarding any dependency variation, like: - -- if flag(foo) - -- ghc-options: -O2 - (irrelevant_flags, deps1') = L.foldl' drop_irrelevant ([], deps1) active_flags - where drop_irrelevant :: ([Cabal.FlagName], [(CabalFlags, Merge.EDep)]) -> Cabal.FlagName -> ([Cabal.FlagName], [(CabalFlags, Merge.EDep)]) - drop_irrelevant (ifs, ds) f = - case fenabled_ds' == fdisabled_ds' of - True -> (f:ifs, fenabled_ds') - False -> ( ifs, ds) - where (fenabled_ds', fdisabled_ds') = ( L.sort $ map drop_f fenabled_ds - , L.sort $ map drop_f fdisabled_ds - ) - drop_f :: (CabalFlags, Merge.EDep) -> (CabalFlags, Merge.EDep) - drop_f (fas, d) = (filter ((f /=) . fst) fas, d) - (fenabled_ds, fdisabled_ds) = L.partition is_fe ds - is_fe :: (CabalFlags, Merge.EDep) -> Bool - is_fe (fas, _d) = - case lookup f fas of - Just v -> v - -- should not happen - Nothing -> error $ unwords [ "ERROR: drop_irrelevant: searched for missing flag" - , show f - , "in assignment" - , show fas - ] - - -- and finally prettify all deps: - leave_only_dynamic_fa :: CabalFlags -> CabalFlags - leave_only_dynamic_fa fa = filter (\(fn, _) -> all (fn /=) irrelevant_flags) $ fa L.\\ common_fa - - -- build roughly balanced complete dependency tree instead of skewed one - bimerge :: [Merge.EDep] -> Merge.EDep - bimerge deps = case go deps of - [] -> mempty - [r] -> r - _ -> error "bimerge: something bad happened" - where go deps' = - case deps' of - (d1:d2:ds) -> go (mappend d1 d2 : go ds) - _ -> deps' - - tdeps :: Merge.EDep - tdeps = bimerge $ map set_fa_to_ed deps1' - - set_fa_to_ed :: (CabalFlags, Merge.EDep) -> Merge.EDep - set_fa_to_ed (fa, ed) = ed { Merge.rdep = liftFlags (leave_only_dynamic_fa fa) $ Merge.rdep ed - , Merge.dep = liftFlags (leave_only_dynamic_fa fa) $ Merge.dep ed - } - - liftFlags :: CabalFlags -> Portage.Dependency -> Portage.Dependency - liftFlags fs e = let k = foldr (\(y,b) x -> Portage.mkUseDependency (b, Portage.Use . cfn_to_iuse . Cabal.unFlagName $ y) . x) - id fs - in k e - - 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)) - - notice verbosity $ "Accepted depends: " ++ show (map prettyShow accepted_deps) - notice verbosity $ "Skipped depends: " ++ show (map prettyShow skipped_deps) - notice verbosity $ "Dead flags: " ++ show (map pp_fa irresolvable_flag_assignments) - notice verbosity $ "Dropped flags: " ++ show (map (Cabal.unFlagName.fst) common_fa) - notice verbosity $ "Active flags: " ++ show (map Cabal.unFlagName active_flags) - notice verbosity $ "Irrelevant flags: " ++ show (map Cabal.unFlagName irrelevant_flags) - -- mapM_ print tdeps - - forM_ ghc_packages $ - \name -> info verbosity $ "Excluded packages (comes with ghc): " ++ Cabal.unPackageName name - - 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.depend = Merge.dep tdeps} ) - . (\e -> e { E.depend_extra = S.toList $ Merge.dep_e tdeps } ) - . (\e -> e { E.rdepend = Merge.rdep tdeps} ) - . (\e -> e { E.rdepend_extra = S.toList $ Merge.rdep_e tdeps } ) - . (\e -> e { E.src_configure = build_configure_call $ - selected_flags (active_flags, user_specified_fas) } ) - . (\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) - - 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 @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 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 - oldDir <- getCurrentDirectory - bracket - (setCurrentDirectory newDir) - (\_ -> setCurrentDirectory oldDir) - (\_ -> action) - --- | Write the ebuild (and sometimes a new @metadata.xml@) to its directory. -mergeEbuild :: Verbosity -> EM.EMeta -> FilePath -> E.EBuild -> [Cabal.PackageFlag] -> IO () -mergeEbuild verbosity existing_meta pkgdir ebuild flags = do - let edir = pkgdir - elocal = E.name ebuild ++"-"++ E.version ebuild <.> "ebuild" - epath = edir elocal - emeta = "metadata.xml" - mpath = edir emeta - yet_meta <- doesFileExist mpath - -- If there is an existing @metadata.xml@, read it in as a 'T.Text'. - -- Otherwise return 'T.empty'. We only use this once more to directly - -- compare to @default_meta@ before writing it. - current_meta <- if yet_meta - then T.readFile mpath - else return T.empty - -- Either create an object of the 'Portage.Metadata' type from a valid @current_meta@, - -- or supply a default minimal metadata object. Note the difference to @current_meta@: - -- @current_meta@ is of type 'T.Text', @current_meta'@ is of type 'Portage.Metadata'. - let current_meta' = fromMaybe Portage.makeMinimalMetadata - (Portage.pureMetadataFromFile current_meta) - -- 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 - $ Merge.metaFlags flags `Map.union` - Portage.metadataUseFlags current_meta' - -- Create a 'Map.Map' of USE flags with updated descriptions. - new_flags = Map.differenceWith (\new old -> if (new /= old) - then Just $ old ++ A.bold (" -> " ++ new) - else Nothing) - (Merge.metaFlags flags) - $ Portage.metadataUseFlags current_meta' - - createDirectoryIfMissing True edir - now <- TC.getCurrentTime - - 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) - ebuild' = ebuild { E.keywords = new_keywords - , E.license = new_license - } - s_ebuild' = E.showEBuild now 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` T.writeFile epath (T.pack s_ebuild') - - when (current_meta /= default_meta) $ do - 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 deleted file mode 100644 --- a/Merge/Dependencies.hs +++ /dev/null @@ -1,583 +0,0 @@ -{-| -Module : Merge.Dependencies -License : GPL-3+ -Maintainer : haskell@gentoo.org - -Merge a package from @hackage@ to an ebuild. --} -{-# LANGUAGE CPP #-} -module Merge.Dependencies - ( EDep(..) - , RetroPackageDescription(..) - , exeAndLibDeps - , mkRetroPD - , resolveDependencies - ) where - -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 -import qualified Distribution.Compat.NonEmptySet as NES -import qualified Distribution.Package as Cabal -import qualified Distribution.PackageDescription as Cabal -import qualified Distribution.Version as Cabal -import qualified Distribution.Pretty as Cabal - -import qualified Distribution.Compiler as Cabal - -import qualified Portage.Cabal as Portage -import qualified Portage.Dependency as Portage -import qualified Portage.Dependency.Normalize as PN -import qualified Portage.Overlay as Portage -import qualified Portage.PackageId as Portage -import qualified Portage.Use as Portage -import qualified Portage.Tables 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 :: S.Set String, - dep :: Portage.Dependency, - dep_e :: S.Set String - } - 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, - buildDepends :: [Cabal.Dependency] - } deriving (Show) - --- | Construct a 'RetroPackageDescription' using 'exeAndLibDeps' for the 'buildDepends'. -mkRetroPD :: Cabal.PackageDescription -> RetroPackageDescription -mkRetroPD pd = RetroPackageDescription { packageDescription = pd, buildDepends = exeAndLibDeps pd } - --- | Extract only the build dependencies for libraries and executables for a given package. -exeAndLibDeps :: Cabal.PackageDescription -> [Cabal.Dependency] -exeAndLibDeps pkg = concatMap (Cabal.targetBuildDepends . Cabal.buildInfo) - (Cabal.executables pkg) - `L.union` - concatMap (Cabal.targetBuildDepends . Cabal.libBuildInfo) - (Cabal.allLibraries pkg) - -instance Semigroup EDep where - (EDep rdepA rdep_eA depA dep_eA) <> (EDep rdepB rdep_eB depB dep_eB) = EDep - { rdep = Portage.DependAllOf [rdepA, rdepB] - , rdep_e = rdep_eA `S.union` rdep_eB - , dep = Portage.DependAllOf [depA, depB] - , dep_e = dep_eA `S.union` dep_eB - } - -instance Monoid EDep where - mempty = EDep - { - rdep = Portage.empty_dependency, - rdep_e = S.empty, - dep = Portage.empty_dependency, - dep_e = S.empty - } -#if !(MIN_VERSION_base(4,11,0)) - (EDep rdepA rdep_eA depA dep_eA) `mappend` (EDep rdepB rdep_eB depB dep_eB) = EDep - { rdep = Portage.DependAllOf [rdepA, rdepB] - , rdep_e = rdep_eA `S.union` rdep_eB - , dep = Portage.DependAllOf [depA, depB] - , dep_e = dep_eA `S.union` dep_eB - } -#endif - --- | Resolve package dependencies from a 'RetroPackageDescription' into an 'EDep'. -resolveDependencies :: Portage.Overlay -> RetroPackageDescription -> Cabal.CompilerInfo - -> [Cabal.PackageName] -> Cabal.PackageName - -> EDep -resolveDependencies overlay pkg compiler_info ghc_package_names merged_cabal_pkg_name = edeps - where - -- hasBuildableExes p = any (buildable . buildInfo) . executables $ p - treatAsLibrary :: Bool - treatAsLibrary = isJust (Cabal.library (packageDescription pkg)) - -- without slot business - raw_haskell_deps :: Portage.Dependency - raw_haskell_deps = PN.normalize_depend $ Portage.DependAllOf $ haskellDependencies overlay (buildDepends pkg) - test_deps :: Portage.Dependency - test_deps = Portage.mkUseDependency (True, Portage.Use "test") $ - Portage.DependAllOf $ - remove_raw_common $ - testDependencies overlay (packageDescription pkg) ghc_package_names merged_cabal_pkg_name - cabal_dep :: Portage.Dependency - cabal_dep = cabalDependency overlay (packageDescription pkg) compiler_info - ghc_dep :: Portage.Dependency - ghc_dep = compilerInfoToDependency compiler_info - extra_libs :: Portage.Dependency - extra_libs = Portage.DependAllOf $ findCLibs (packageDescription pkg) - pkg_config_libs :: [Portage.Dependency] - pkg_config_libs = pkgConfigDependencies overlay (packageDescription pkg) - pkg_config_tools :: Portage.Dependency - pkg_config_tools = Portage.DependAllOf $ if L.null pkg_config_libs - then [] - else [any_c_p "virtual" "pkgconfig"] - build_tools :: Portage.Dependency - build_tools = Portage.DependAllOf $ pkg_config_tools : legacyBuildToolsDependencies (packageDescription pkg) - ++ hackageBuildToolsDependencies overlay (packageDescription pkg) - - setup_deps :: Portage.Dependency - setup_deps = PN.normalize_depend $ Portage.DependAllOf $ - remove_raw_common $ - setupDependencies overlay (packageDescription pkg) ghc_package_names merged_cabal_pkg_name - - edeps :: EDep - edeps - | treatAsLibrary = mempty - { - dep = Portage.DependAllOf - [ cabal_dep - , setup_deps - , build_tools - , test_deps - ], - dep_e = S.singleton "${RDEPEND}", - rdep = Portage.DependAllOf - [ Portage.set_build_slot ghc_dep - , Portage.set_build_slot $ add_profile $ raw_haskell_deps - , extra_libs - , Portage.DependAllOf pkg_config_libs - ] - } - | otherwise = mempty - { - dep = Portage.DependAllOf - [ cabal_dep - , setup_deps - , build_tools - , test_deps - ], - dep_e = S.singleton "${RDEPEND}", - rdep = Portage.DependAllOf - [ Portage.set_build_slot ghc_dep - , Portage.set_build_slot $ raw_haskell_deps - , extra_libs - , Portage.DependAllOf pkg_config_libs - ] - } - 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 - ---------------------------------------------------------------- --- Custom-setup dependencies --- TODO: move partitioning part to Merge:mergeGenericPackageDescription ---------------------------------------------------------------- - -setupDependencies :: Portage.Overlay -> Cabal.PackageDescription -> [Cabal.PackageName] -> Cabal.PackageName -> [Portage.Dependency] -setupDependencies overlay pkg ghc_package_names merged_cabal_pkg_name = deps - where cabalDeps = maybe [] id $ Cabal.setupDepends `fmap` Cabal.setupBuildInfo pkg - cabalDeps' = fst $ Portage.partition_depends ghc_package_names merged_cabal_pkg_name cabalDeps - deps = C2E.convertDependencies overlay (Portage.Category "dev-haskell") cabalDeps' - ---------------------------------------------------------------- --- Test-suite dependencies --- TODO: move partitioning part to Merge:mergeGenericPackageDescription ---------------------------------------------------------------- - -testDependencies :: Portage.Overlay -> Cabal.PackageDescription -> [Cabal.PackageName] -> Cabal.PackageName -> [Portage.Dependency] -testDependencies overlay pkg ghc_package_names merged_cabal_pkg_name = deps - where cabalDeps = concatMap (Cabal.targetBuildDepends . Cabal.testBuildInfo) (Cabal.testSuites pkg) - cabalDeps' = fst $ Portage.partition_depends ghc_package_names merged_cabal_pkg_name cabalDeps - deps = C2E.convertDependencies overlay (Portage.Category "dev-haskell") cabalDeps' - ---------------------------------------------------------------- --- Haskell packages ---------------------------------------------------------------- - -haskellDependencies :: Portage.Overlay -> [Cabal.Dependency] {- PackageDescription -} -> [Portage.Dependency] -haskellDependencies overlay 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 -> Cabal.PackageDescription -> Cabal.CompilerInfo -> Portage.Dependency -cabalDependency overlay pkg ~(Cabal.CompilerInfo { - Cabal.compilerInfoId = - Cabal.CompilerId Cabal.GHC cabal_version - }) = - C2E.convertDependency overlay - (Portage.Category "dev-haskell") - (Cabal.Dependency (Cabal.mkPackageName "Cabal") - finalCabalDep (NES.singleton Cabal.defaultLibName)) - where - versionNumbers = Cabal.versionNumbers cabal_version - userCabalVersion = Cabal.orLaterVersion $ Cabal.mkVersion - $ Cabal.cabalSpecToVersionDigits $ Cabal.specVersion pkg - shippedCabalVersion = GHCCore.cabalFromGHC versionNumbers - shippedCabalDep = maybe Cabal.anyVersion Cabal.orLaterVersion shippedCabalVersion - finalCabalDep = Cabal.simplifyVersionRange - (Cabal.intersectVersionRanges - userCabalVersion - shippedCabalDep) - ---------------------------------------------------------------- --- GHC Dependency ---------------------------------------------------------------- - -compilerInfoToDependency :: Cabal.CompilerInfo -> Portage.Dependency -compilerInfoToDependency ~(Cabal.CompilerInfo { - Cabal.compilerInfoId = - Cabal.CompilerId Cabal.GHC cabal_version}) = - at_least_c_p_v "dev-lang" "ghc" (Cabal.versionNumbers cabal_version) - ---------------------------------------------------------------- --- C Libraries ---------------------------------------------------------------- - -findCLibs :: Cabal.PackageDescription -> [Portage.Dependency] -findCLibs (Cabal.PackageDescription { Cabal.library = lib, Cabal.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 = concatMap (Cabal.extraLibs . Cabal.libBuildInfo) $ maybe [] return lib - exeE = concatMap Cabal.extraLibs (filter Cabal.buildable (map Cabal.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.DependAtom $ - 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.DependAtom $ - 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" [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 (Portage.Use "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") - , ("alut", any_c_p "media-libs" "freealut") - , ("openal", any_c_p "media-libs" "openal") - , ("iw", any_c_p "net-wireless" "wireless-tools") - , ("attr", any_c_p "sys-apps" "attr") - , ("ncurses", any_c_p "sys-libs" "ncurses") - , ("panel", any_c_p "sys-libs" "ncurses") - , ("nanomsg", any_c_p "dev-libs" "nanomsg") - , ("pgf", any_c_p "media-libs" "libpgf") - , ("ssh2", any_c_p "net-libs" "libssh2") - , ("dl", any_c_p "virtual" "libc") - , ("glfw", any_c_p "media-libs" "glfw") - , ("nettle", any_c_p "dev-libs" "nettle") - , ("Xpm", any_c_p "x11-libs" "libXpm") - , ("Xss", any_c_p "x11-libs" "libXScrnSaver") - , ("tag_c", any_c_p "media-libs" "taglib") - , ("magic", any_c_p "sys-apps" "file") - , ("crypt", any_c_p_s_u "virtual" "libcrypt" Portage.AnyBuildTimeSlot []) - , ("Xrender", any_c_p "x11-libs" "libXrender") - , ("Xcursor", any_c_p "x11-libs" "libXcursor") - , ("Xinerama", any_c_p "x11-libs" "libXinerama") - , ("wayland-client", any_c_p "dev-libs" "wayland") - , ("wayland-cursor", any_c_p "dev-libs" "wayland") - , ("wayland-server", any_c_p "dev-libs" "wayland") - , ("wayland-egl", any_c_p_s_u "media-libs" "mesa" Portage.AnySlot [Portage.mkUse (Portage.Use "wayland")]) - , ("xkbcommon", any_c_p "x11-libs" "libxkbcommon") - , ("SDL_gfx", any_c_p "media-libs" "sdl-gfx") - , ("SDL_image", any_c_p "media-libs" "sdl-image") - , ("SDL_ttf", any_c_p "media-libs" "sdl-ttf") - , ("odbc", any_c_p "dev-db" "unixODBC") - , ("uuid", any_c_p "sys-apps" "util-linux") - , ("notify", any_c_p "x11-libs" "libnotify") - , ("SDL2", any_c_p " media-libs" "libsdl2") - , ("SDL2_mixer", any_c_p "media-libs" "sdl2-mixer") - , ("blas", any_c_p "virtual" "blas") - , ("lapack", any_c_p "virtual" "lapack") - ] - ---------------------------------------------------------------- --- Build Tools (legacy, a list of well-known tools) ---------------------------------------------------------------- - -legacyBuildToolsDependencies :: Cabal.PackageDescription -> [Portage.Dependency] -legacyBuildToolsDependencies (Cabal.PackageDescription { Cabal.library = lib, Cabal.executables = exes }) = L.nub $ - [ case pkg of - Just p -> p - Nothing -> trace ("WARNING: Unknown build tool '" ++ Cabal.prettyShow exe ++ "'. Check the generated ebuild.") - (any_c_p "unknown-build-tool" pn) - | exe@(Cabal.LegacyExeDependency pn _range) <- cabalDeps - , pkg <- return (lookup pn buildToolsTable) - ] - where - cabalDeps = filter notProvided $ depL ++ depE - depL = concatMap (Cabal.buildTools . Cabal.libBuildInfo) $ maybe [] return lib - depE = concatMap Cabal.buildTools (filter Cabal.buildable (map Cabal.buildInfo exes)) - notProvided (Cabal.LegacyExeDependency 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", any_c_p "dev-haskell" "cabal-install") - , ("cabal-install", any_c_p "dev-haskell" "cabal-install") - , ("cpphs", any_c_p "dev-haskell" "cpphs") - , ("ghc", any_c_p "dev-lang" "ghc") - , ("gtk2hsTypeGen", any_c_p "dev-haskell" "gtk2hs-buildtools") - , ("gtk2hsHookGenerator", any_c_p "dev-haskell" "gtk2hs-buildtools") - , ("gtk2hsC2hs", any_c_p "dev-haskell" "gtk2hs-buildtools") - , ("hsb2hs", any_c_p "dev-haskell" "hsb2hs") - , ("hsx2hs", any_c_p "dev-haskell" "hsx2hs") - , ("llvm-config", any_c_p "sys-devel" "llvm") - ] - --- tools that are provided by ghc or some other existing program --- so we do not need dependencies on them -buildToolsProvided :: [String] -buildToolsProvided = ["hsc2hs"] - ---------------------------------------------------------------- --- Hackage Build Tools (behind `build-tool-depends`) ---------------------------------------------------------------- - -hackageBuildToolsDependencies :: Portage.Overlay -> Cabal.PackageDescription -> [Portage.Dependency] -hackageBuildToolsDependencies overlay (Cabal.PackageDescription { Cabal.library = lib, Cabal.executables = exes }) = - haskellDependencies overlay $ L.nub $ - [ Cabal.Dependency pn versionRange $ NES.singleton Cabal.defaultLibName - | Cabal.ExeDependency pn _component versionRange <- cabalDeps - ] - where - cabalDeps = depL ++ depE - depL = concatMap (Cabal.buildToolDepends . Cabal.libBuildInfo) $ maybe [] return lib - depE = concatMap Cabal.buildToolDepends (filter Cabal.buildable (map Cabal.buildInfo exes)) - ---------------------------------------------------------------- --- pkg-config ---------------------------------------------------------------- - -pkgConfigDependencies :: Portage.Overlay -> Cabal.PackageDescription -> [Portage.Dependency] -pkgConfigDependencies overlay (Cabal.PackageDescription { Cabal.library = lib, Cabal.executables = exes }) = L.nub $ resolvePkgConfigs overlay cabalDeps - where - cabalDeps = depL ++ depE - depL = concatMap (Cabal.pkgconfigDepends . Cabal.libBuildInfo) $ maybe [] return lib - depE = concatMap Cabal.pkgconfigDepends (filter Cabal.buildable (map Cabal.buildInfo exes)) - -resolvePkgConfigs :: Portage.Overlay -> [Cabal.PkgconfigDependency] -> [Portage.Dependency] -resolvePkgConfigs overlay cdeps = - [ case resolvePkgConfig overlay pkg of - Just d -> d - Nothing -> trace ("WARNING: Could not resolve pkg-config: " ++ Cabal.prettyShow pkg ++ ". Check generated ebuild.") - (any_c_p "unknown-pkg-config" pn) - | pkg@(Cabal.PkgconfigDependency cabal_pn _range) <- cdeps - , let pn = Cabal.unPkgconfigName cabal_pn - ] - -resolvePkgConfig :: Portage.Overlay -> Cabal.PkgconfigDependency -> Maybe Portage.Dependency -resolvePkgConfig _overlay (Cabal.PkgconfigDependency cabal_pn _cabalVersion) = do - (cat,portname, slot) <- lookup (Cabal.unPkgconfigName cabal_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)) - ,("atk", ("dev-libs", "atk", 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")) - ,("gobject-introspection-1.0", ("dev-libs", "gobject-introspection", - Portage.AnySlot)) - ,("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-3.0", ("x11-libs", "gtk+", Portage.GivenSlot "3")) - ,("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")) - - ,("gtk+-3.0", ("x11-libs", "gtk+", Portage.GivenSlot "3")) - ,("webkitgtk-3.0", ("net-libs", "webkit-gtk", Portage.GivenSlot "3")) - - ,("cairo", ("x11-libs", "cairo", Portage.AnySlot)) -- need [svg] for dev-haskell/cairo - ,("cairo-gobject", ("x11-libs", "cairo", Portage.AnySlot)) -- need [glib] 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)) - - ,("javascriptcoregtk-4.0", ("net-libs", "webkit-gtk", Portage.GivenSlot "4")) - ,("webkit2gtk-4.0", ("net-libs", "webkit-gtk", Portage.GivenSlot "4")) - - ,("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)) - ,("libsoup-2.4", ("net-libs", "libsoup", Portage.GivenSlot "2.4")) - ,("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")) - ,("gtksourceview-3.0", ("x11-libs", "gtksourceview", Portage.GivenSlot "3.0")) - - ,("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)) - ,("ncurses", ("sys-libs", "ncurses", Portage.AnySlot)) - ,("ncursesw", ("sys-libs", "ncurses", Portage.AnySlot)) - ,("panel", ("sys-libs", "ncurses", Portage.AnySlot)) - ,("panelw", ("sys-libs", "ncurses", Portage.AnySlot)) - ,("libssh2", ("net-libs", "libssh2", Portage.AnySlot)) - ,("SDL_image", ("media-libs", "sdl-image", Portage.AnySlot)) - ,("libzmq", ("net-libs", "zeromq", Portage.AnySlot)) - ,("taglib_c", ("media-libs", "taglib", Portage.AnySlot)) - ,("libcurl", ("net-misc", "curl", Portage.AnySlot)) - ,("libpq", ("dev-db", "postgresql", Portage.AnySlot)) - ,("poppler-glib", ("app-text", "poppler", Portage.AnySlot)) - ,("gsl", ("sci-libs", "gsl", Portage.AnySlot)) - ,("libvirt", ("app-emulation", "libvirt", Portage.AnySlot)) - - ,("Qt5Core", ("dev-qt", "qtcore", Portage.GivenSlot "5")) - ,("Qt5Gui", ("dev-qt", "qtgui", Portage.GivenSlot "5")) - ,("Qt5Qml", ("dev-qt", "qtdeclarative", Portage.GivenSlot "5")) - ,("Qt5Quick", ("dev-qt", "qtdeclarative", Portage.GivenSlot "5")) - ,("Qt5Widgets", ("dev-qt", "qtwidgets", Portage.GivenSlot "5")) - - ,("sdl2", ("media-libs", "libsdl2", Portage.AnySlot)) - ,("SDL2_image", ("media-libs", "sdl2-image", Portage.AnySlot)) - ,("SDL2_mixer", ("media-libs", "sdl2-mixer", Portage.AnySlot)) - ,("zlib", ("sys-libs", "zlib", Portage.AnySlot)) - ] diff --git a/Merge/Utils.hs b/Merge/Utils.hs deleted file mode 100644 --- a/Merge/Utils.hs +++ /dev/null @@ -1,212 +0,0 @@ -{-| -Module : Merge.Utils -License : GPL-3+ -Maintainer : haskell@gentoo.org - -Internal helper functions for "Merge". --} -module Merge.Utils - ( readPackageString - , getPreviousPackageId - , first_just_of - , drop_prefix - , squash_debug - , convert_underscores - , mangle_iuse - , to_unstable - , metaFlags - , dropIfUseExpands - -- hspec exports - , dropIfUseExpand - ) where - -import qualified Control.Applicative as A -import qualified Control.Monad as M -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 - -import qualified Distribution.Package as Cabal -import qualified Distribution.PackageDescription as Cabal - --- | Parse a ['String'] as a valid package string. E.g. @category\/name-1.0.0@. --- Return 'HackPortError' if the string to parse is invalid. --- --- When the ['String'] is valid: --- --- >>> readPackageString ["dev-haskell/packagename1-1.0.0"] --- Right (Just (Category {unCategory = "dev-haskell"}),PackageName "packagename1",Just (Version {versionNumber = [1,0,0], versionChar = Nothing, versionSuffix = [], versionRevision = 0})) --- --- When the ['String'] is empty: --- --- >>> readPackageString [] --- Left ... -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 - Right v@(_,_,Nothing) -> return v - -- we only allow versions we can convert into cabal versions - Right v@(_,_,Just (Portage.Version _ Nothing [] 0)) -> return v - Left e -> Left $ ArgumentError $ "Could not parse [category/]package[-version]: " - ++ packageString ++ "\nParsec error: " ++ e - _ -> Left $ ArgumentError $ "Could not parse [category/]package[-version]: " - ++ packageString - --- | Maybe return a 'Portage.PackageId' of the next highest version for a given --- package, relative to the provided 'Portage.PackageId'. --- --- For example: --- --- >>> let ebuildDir = ["foo-bar2-3.0.1.ebuild","metadata.xml"] --- >>> let newPkgId = Portage.PackageId (Portage.PackageName (Portage.Category "dev-haskell") (Cabal.mkPackageName "foo-bar2")) (Portage.Version [3,0,2] Nothing [] 0 ) --- --- >>> getPreviousPackageId ebuildDir newPkgId --- Just (PackageId {packageId = PackageName {category = Category {unCategory = "dev-haskell"}, cabalPkgName = PackageName "foo-bar2"}, pkgVersion = Version {versionNumber = [3,0,1], versionChar = Nothing, versionSuffix = [], versionRevision = 0}}) -getPreviousPackageId :: [FilePath] -- ^ list of ebuilds for given package - -> Portage.PackageId -- ^ new PackageId - -> Maybe Portage.PackageId -- ^ maybe PackageId of previous version -getPreviousPackageId pkgDir newPkgId = do - let pkgIds = reverse - . L.sortOn (Portage.pkgVersion) - . filter ( filter (\fp -> SF.takeExtension fp == ".ebuild") pkgDir - case pkgIds of - x:_ -> Just x - _ -> Nothing - --- | Alias for 'msum'. --- --- prop> \a -> first_just_of a == M.msum a -first_just_of :: [Maybe a] -> Maybe a -first_just_of = M.msum - --- | Remove @with@ or @use@ prefixes from flag names. --- --- >>> drop_prefix "with_conduit" --- "conduit" --- >>> drop_prefix "use-https" --- "https" --- >>> drop_prefix "no_examples" --- "no_examples" -drop_prefix :: String -> String -drop_prefix x = - let prefixes = ["with","use"] - separators = ["-","_"] - combinations = A.liftA2 (++) prefixes separators - in case catMaybes (A.liftA2 L.stripPrefix combinations [x]) of - [z] -> z - _ -> x - --- | Squash debug-related @USE@ flags under the @debug@ global --- @USE@ flag. --- --- >>> squash_debug "use-debug-foo" --- "debug" --- >>> squash_debug "foo-bar" --- "foo-bar" -squash_debug :: String -> String -squash_debug flag = if "debug" `L.isInfixOf` (C.toLower <$> flag) - then "debug" - else flag - --- | Gentoo allows underscore ('_') names in @IUSE@ only for --- @USE_EXPAND@ values. If it's not a user-specified rename mangle --- it into a hyphen ('-'). --- --- >>> convert_underscores "remove_my_underscores" --- "remove-my-underscores" -convert_underscores :: String -> String -convert_underscores = map f - where f '_' = '-' - f c = c - --- | Perform all @IUSE@ mangling. --- --- >>> mangle_iuse "use_foo-bar_debug" --- "debug" --- >>> mangle_iuse "with-bar_quux" --- "bar-quux" -mangle_iuse :: String -> String -mangle_iuse = squash_debug . drop_prefix . convert_underscores - --- | Convert all stable keywords to testing (unstable) keywords. --- Preserve arch masks (-). --- --- >>> to_unstable "amd64" --- "~amd64" --- >>> to_unstable "~amd64" --- "~amd64" --- >>> to_unstable "-amd64" --- "-amd64" -to_unstable :: String -> String -to_unstable kw = - case kw of - '~':_ -> kw - '-':_ -> kw - _ -> '~':kw - --- | Generate a 'Map.Map' of 'Cabal.PackageFlag' names and their descriptions. --- --- For example, if we construct a singleton list holding a 'Cabal.PackageFlag' with --- 'Cabal.FlagName' @foo@ and 'Cabal.FlagDescription' @bar@, we should get --- a 'Map.Map' containing those values: --- --- >>> let flags = [(Cabal.emptyFlag (Cabal.mkFlagName "foo")) {Cabal.flagDescription = "bar"}] --- >>> metaFlags flags --- 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 or (A.liftA2 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/Overlays.hs b/Overlays.hs deleted file mode 100644 --- a/Overlays.hs +++ /dev/null @@ -1,69 +0,0 @@ -module Overlays - ( getOverlayPath - ) where - -import Control.Monad -import Data.List (nub, inits) -import Data.Maybe (maybeToList, listToMaybe, isJust, fromJust) -import qualified System.Directory as SD -import System.FilePath ((), splitPath, joinPath) - -import Error -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 <- SD.doesDirectoryExist (x ".hackport") - 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 <- SD.getCurrentDirectory - let lookIn = map joinPath . reverse . inits . splitPath $ curDir - fmap listToMaybe (filterM probe lookIn) - - where - probe dir = SD.doesDirectoryExist (dir "dev-haskell") diff --git a/Portage/Cabal.hs b/Portage/Cabal.hs deleted file mode 100644 --- a/Portage/Cabal.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-| -Module : Portage.Cabal -License : GPL-3+ -Maintainer : haskell@gentoo.org - -Utilities to extract and manipulate information from a package's @.cabal@ file, -such as its license and dependencies. --} -module Portage.Cabal - ( convertLicense - , partition_depends - ) where - -import qualified Data.List as L - -import qualified Distribution.License as Cabal -import qualified Distribution.SPDX as SPDX -import qualified Distribution.Package as Cabal -import qualified Distribution.Pretty as Cabal - --- | Convert the Cabal 'SPDX.License' into the Gentoo format, as a 'String'. --- --- Generally, if the license is one of the common free-software or --- open-source licenses, 'convertLicense' should return the license --- as a 'Right' 'String': --- --- >>> convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.GPL_3_0_or_later) --- Right "GPL-3+" --- --- >>> convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.GPL_3_0_only) --- Right "GPL-3" --- --- If it is a more obscure license, this should alert the user by returning --- a 'Left' 'String': --- --- >>> convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.EUPL_1_1) --- Left ... -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 - Just "3" -> "3" - Just "3.0" -> "3+" - _ -> "3" -- almost certainly version 3 - 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 - Just "2" -> "2" - -- Cabal can't handle 2.0+ properly - Just "2.0" -> "2" - Just "3" -> "3" - Just "3.0" -> "3+" - _ -> "2.1" -- probably version 2.1 - Cabal.BSD2 -> Right "BSD-2" - 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.prettyShow mv -- probably version 1.1 - Cabal.ISC -> Right "ISC" - Cabal.MPL v -> Right $ "MPL-" ++ Cabal.prettyShow v -- probably version 1.0 - -- 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 "(Other) Please look at license file of package and pick it manually." - Cabal.UnspecifiedLicense -> Left "(Unspecified) Please look at license file of package and pick it manually." - --- | Extract only the dependencies which are not bundled with @GHC@. -partition_depends :: [Cabal.PackageName] -> Cabal.PackageName -> [Cabal.Dependency] -> ([Cabal.Dependency], [Cabal.Dependency]) -partition_depends ghc_package_names merged_cabal_pkg_name = L.partition (not . is_internal_depend) - where is_internal_depend (Cabal.Dependency pn _vr _lib) = is_itself || is_ghc_package - where is_itself = pn == merged_cabal_pkg_name - is_ghc_package = pn `elem` ghc_package_names diff --git a/Portage/Dependency.hs b/Portage/Dependency.hs deleted file mode 100644 --- a/Portage/Dependency.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Portage.Dependency - ( - module Portage.Dependency.Builder - , module Portage.Dependency.Print - , module Portage.Dependency.Types - ) where - -import Portage.Dependency.Builder -import Portage.Dependency.Print -import Portage.Dependency.Types diff --git a/Portage/Dependency/Builder.hs b/Portage/Dependency/Builder.hs deleted file mode 100644 --- a/Portage/Dependency/Builder.hs +++ /dev/null @@ -1,32 +0,0 @@ -{- | Basic helpers to build depend structures -} -module Portage.Dependency.Builder - ( - empty_dependency - , addDepUseFlag - , setSlotDep - , mkUseDependency - , overAtom - ) where - -import Portage.Dependency.Types -import Portage.Use - --- TODO: remove it and switch to 'SatisfiedDepend' instead -empty_dependency :: Dependency -empty_dependency = DependAllOf [] - -addDepUseFlag :: UseFlag -> Dependency -> Dependency -addDepUseFlag n = overAtom (\(Atom pn dr (DAttr s u)) -> Atom pn dr (DAttr s (n:u))) - -setSlotDep :: SlotDepend -> Dependency -> Dependency -setSlotDep n = overAtom (\(Atom pn dr (DAttr _s u)) -> Atom pn dr (DAttr n u)) - -mkUseDependency :: (Bool, Use) -> Dependency -> Dependency -mkUseDependency (b, u) 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 -overAtom f (DependAnyOf d) = DependAnyOf $ map (overAtom f) d -overAtom f (DependIfUse u d1 d2) = DependIfUse u (f `overAtom` d1) (f `overAtom` d2) -overAtom f (DependAtom a) = DependAtom (f a) diff --git a/Portage/Dependency/Normalize.hs b/Portage/Dependency/Normalize.hs deleted file mode 100644 --- a/Portage/Dependency/Normalize.hs +++ /dev/null @@ -1,398 +0,0 @@ -module Portage.Dependency.Normalize - ( - normalize_depend - ) where - -import qualified Control.Arrow as A -import Control.Monad -import qualified Data.List as L -import qualified Data.Set as S -import Data.Maybe - -import Portage.Dependency.Builder -import Portage.Dependency.Types -import Portage.Use - -import Debug.Trace - -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) - -stabilize_pass :: (Dependency -> Dependency) -> Dependency -> Dependency -stabilize_pass pass d - | d == d' = d' - | otherwise = go d' - where go = stabilize_pass pass - d' = pass d - --- remove one layer of redundancy -normalization_step :: Int -> Dependency -> Dependency -normalization_step level = - id - . tp "PC2" (stabilize_pass (tp "PC2 step" propagate_context)) - . tp "F3" (stabilize_pass flatten) - . tp "LC" lift_context - . tp "PC1" (stabilize_pass (tp "PC1 step" propagate_context)) - . tp "F2" (stabilize_pass flatten) - . tp "RD" (stabilize_pass remove_duplicates) - . tp "RE" (stabilize_pass remove_empty) - . tp "SD" sort_deps - . tp "CUG" combine_use_guards - . tp "F1" (stabilize_pass flatten) - . tp "CAR" combine_atom_ranges - where tp :: String -> (Dependency -> Dependency) -> Dependency -> Dependency - tp pass_name pass d = t False d' - where d' = pass d - t False = id - t True = - trace (unwords [ "PASS" - , show level - , ":" - , pass_name - , show (length (show d)) - , "->" - , show (length (show d')) - ]) - -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 td fd -> DependIfUse use (go td) (go fd) - DependAllOf deps -> DependAllOf $ filter (not . is_empty_dependency) $ map go deps - DependAnyOf deps -> DependAnyOf $ map go deps - -- no change - DependAtom _ -> d - where go = remove_empty - -s_uniq :: [Dependency] -> [Dependency] -s_uniq = S.toList . S.fromList - --- Ideally 'combine_atom_ranges' should handle those as well -remove_duplicates :: Dependency -> Dependency -remove_duplicates d = - case d of - DependIfUse use td fd -> DependIfUse use (go td) (go fd) - DependAnyOf deps -> DependAnyOf $ s_uniq $ map go deps - DependAllOf deps -> DependAllOf $ s_uniq $ map go deps - DependAtom _ -> d - where go = remove_duplicates - --- TODO: implement flattening AnyOf the same way it's done for AllOf --- DependAnyOf [DependAnyOf [something], rest] -> DependAnyOf $ something ++ rest -flatten :: Dependency -> Dependency -flatten d = - case d of - DependIfUse use td fd -> DependIfUse use (go td) (go fd) - DependAnyOf [dep] -> go dep - DependAnyOf deps -> DependAnyOf $ map go deps - - DependAllOf deps -> case L.partition is_dall_of deps of - ([], []) -> empty_dependency - ([], [dep]) -> dep - ([], ndall) -> DependAllOf $ map go ndall - (dall, ndall) -> go $ DependAllOf $ s_uniq $ (concatMap undall dall) ++ ndall - DependAtom _ -> d - where go :: Dependency -> Dependency - go = flatten - - is_dall_of :: Dependency -> Bool - is_dall_of d' = - case d' of - DependAllOf _deps -> True - _ -> False - undall :: Dependency -> [Dependency] - undall ~(DependAllOf ds) = ds - --- joins atoms with different version boundaries --- DependAllOf [ DRange ">=foo-1" Inf, Drange Zero " DRange ">=foo-1" " Dependency -combine_atom_ranges d = - case d of - DependIfUse use td fd -> DependIfUse use (go td) (go fd) - DependAllOf deps -> DependAllOf $ map go $ find_atom_intersections deps - DependAnyOf deps -> DependAnyOf $ map go $ find_atom_concatenations deps - DependAtom _ -> d - where go = combine_atom_ranges - -find_atom_intersections :: [Dependency] -> [Dependency] -find_atom_intersections = map merge_depends . L.groupBy is_mergeable - where is_mergeable :: Dependency -> Dependency -> Bool - is_mergeable (DependAtom (Atom lpn _ldrange lattr)) (DependAtom (Atom rpn _rdrange rattr)) - = (lpn, lattr) == (rpn, rattr) - is_mergeable _ _ - = False - - merge_depends :: [Dependency] -> Dependency - merge_depends [x] = x - merge_depends xs = L.foldl1' merge_pair xs - - merge_pair :: Dependency -> Dependency -> Dependency - merge_pair (DependAtom (Atom lp ld la)) (DependAtom (Atom rp rd ra)) - | lp /= rp = error "merge_pair got different 'PackageName's" - | la /= ra = error "merge_pair got different 'DAttr's" - | otherwise = DependAtom (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_atom_concatenations :: [Dependency] -> [Dependency] -find_atom_concatenations = id - --- Eliminate use guarded redundancy: --- a? ( foo ) --- a? ( bar ) --- gets translated to --- a? ( foo bar ) - --- a? ( foo bar ) --- !a? ( foo baz ) --- gets translated to --- foo --- a? ( bar ) --- !a? ( baz ) - -combine_use_guards :: Dependency -> Dependency -combine_use_guards d = - case d of - DependIfUse use td fd -> pop_common $ DependIfUse use (go td) (go fd) - DependAllOf deps -> DependAllOf $ map go $ find_use_intersections deps - DependAnyOf deps -> DependAnyOf $ map go $ find_use_concatenations deps - DependAtom _ -> d - where go = combine_use_guards - -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 _ltd _lfd) (DependIfUse ru _rtd _rfd) - | lu == ru = True - is_use_mergeable _ _ = False - - merge_use_intersections :: [Dependency] -> Dependency - merge_use_intersections [x] = x - merge_use_intersections ds = pop_common $ DependIfUse u (DependAllOf tds) (DependAllOf fds) - where DependIfUse u _tf _fd = head ds - tfdeps ~(DependIfUse _u td fd) = (td, fd) - (tds, fds) = unzip $ map tfdeps ds - -pop_common :: Dependency -> Dependency --- depend --- a? ( x ) !a? ( x ) --- gets translated to --- x -pop_common (DependIfUse _u td fd) - | td == fd = fd -pop_common d'@(DependIfUse _u td fd) = - case td_ctx `L.intersect` fd_ctx of - [] -> d' - common_ctx -> stabilize_pass flatten $ DependAllOf $ propagate_context' common_ctx d' : common_ctx - where td_ctx = lift_context' td - fd_ctx = lift_context' fd -pop_common x = x - --- TODO -find_use_concatenations :: [Dependency] -> [Dependency] -find_use_concatenations = id - --- Eliminate top-down redundancy: --- foo/bar --- u? ( foo/bar --- bar/baz ) --- gets translated to --- foo/bar --- u? ( bar/baz ) --- --- and more complex redundancy: --- v? ( foo/bar ) --- u? ( !v? ( foo/bar ) ) --- gets translated to --- v? ( foo/bar ) --- u? ( foo/bar ) -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 -propagate_context' :: [Dependency] -> Dependency -> Dependency -propagate_context' ctx d = - case d of - _ | d `elem` ctx -> empty_dependency - DependIfUse use td fd -> let (t_ctx_comp, t_refined_ctx) = refine_context (True, use) ctx - (f_ctx_comp, f_refined_ctx) = refine_context (False, use) ctx - tdr = go t_refined_ctx td - fdr = go f_refined_ctx fd - ctx_comp = filter (not . is_empty_dependency) $ - concat [ (lift_context' tdr `L.intersect` (concatMap lift_context' t_ctx_comp)) - , (lift_context' fdr `L.intersect` (concatMap lift_context' f_ctx_comp)) - ] - diu_refined = DependIfUse use tdr - fdr - in case ctx_comp of - [] -> diu_refined - _ -> go ctx $ - DependAllOf [ DependAllOf ctx_comp - , go ctx_comp diu_refined - ] - DependAllOf deps -> DependAllOf $ fromJust $ msum $ - [ v - | (optimized_d, other_deps) <- slice_list deps - , let ctx' = ctx ++ other_deps - d' = go ctx' optimized_d - d'ctx = d' : ctx - v = case d' /= optimized_d of - True -> Just (d':map (go d'ctx) other_deps) - False -> Nothing -- haven't managed to optimize anything - ] ++ [Just deps] -- unmodified - DependAnyOf deps -> DependAnyOf $ map (go ctx) deps - DependAtom _ -> case any (dep_as_broad_as d) ctx of - True -> empty_dependency - False -> d - where go c = propagate_context' c - --- returns (complement-dependencies, simplified-dependencies) -refine_context :: (Bool, Use) -> [Dependency] -> ([Dependency], [Dependency]) -refine_context use_cond = unzip . map (A.second (stabilize_pass flatten) . refine_ctx_unit use_cond) - where refine_ctx_unit :: (Bool, Use) -> Dependency -> (Dependency, Dependency) - refine_ctx_unit uc@(bu, u) d = - case d of - DependIfUse u' td fd - -> case u == u' of - False -> ( empty_dependency - , DependIfUse u' (snd $ refine_ctx_unit uc td) - (snd $ refine_ctx_unit uc fd) - ) - True -> case bu of - True -> (fd, snd $ refine_ctx_unit uc td) - False -> (td, snd $ refine_ctx_unit uc fd) - _ -> (empty_dependency, d) - --- generates all pairs of: --- (list_element, list_without_element) --- example: --- [1,2,3] --- yields --- [(1, [2,3]), (2,[1,3]), (3,[1,2])] -slice_list :: [e] -> [(e, [e])] -slice_list [] = [] -slice_list (e:es) = (e, es) : map (\(v, vs) -> (v, e : vs)) (slice_list es) - --- 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 ) --- TODO: better add propagation in this exact place to keep tree shrinking only -lift_context :: Dependency -> Dependency -lift_context d = - case d of - DependIfUse _use _td _fd -> case L.delete d new_ctx of - [] -> d - new_ctx' -> propagate_context $ DependAllOf $ d : new_ctx' - DependAllOf deps -> case new_ctx L.\\ deps of - [] -> d - new_ctx' -> DependAllOf $ deps ++ new_ctx' - -- the lift itself - DependAnyOf _deps -> case L.delete d new_ctx of - [] -> d - new_ctx' -> propagate_context $ DependAllOf $ d : new_ctx' - DependAtom _ -> d - where new_ctx = lift_context' d - --- lift everything that can be shared somewhere else --- propagate_context will then pick some bits from here --- and remove them deep inside. --- It's the most fragile and powerfull pass -lift_context' :: Dependency -> [Dependency] -lift_context' d = - case d of - DependIfUse _use td fd -> d : extract_common_constraints (map lift_context' [td, fd]) - DependAllOf deps -> L.nub $ concatMap lift_context' deps - DependAnyOf deps -> d : extract_common_constraints (map lift_context' deps) - DependAtom _ -> [d] - --- it extracts common part of dependency comstraints. --- Some examples: --- 'a b c' and 'b c d' have common 'b c' --- 'u? ( a b )' and 'u? ( b c )' have common 'u? ( b )' part --- 'a? ( b? ( x y ) )' and !a? ( b? ( y z ) )' have common 'b? ( y )' -extract_common_constraints :: [[Dependency]] -> [Dependency] -extract_common_constraints [] = [] -extract_common_constraints dss@(ds:dst) = common_atoms ++ common_use_guards - where common_atoms :: [Dependency] - common_atoms = L.foldl1' L.intersect dss - common_use_guards :: [Dependency] - common_use_guards = [ DependIfUse u (DependAllOf tdi) (DependAllOf fdi) - | DependIfUse u td fd <- ds - , Just (tds, fds) <- [find_matching_use_deps dst u ([lift_context' td], [lift_context' fd])] - , let tdi = extract_common_constraints tds - fdi = extract_common_constraints fds - , not (null tdi && null fdi) - ] - -find_matching_use_deps :: [[Dependency]] -> Use -> ([[Dependency]], [[Dependency]]) -> Maybe ([[Dependency]], [[Dependency]]) -find_matching_use_deps dss u (tds, fds) = - case dss of - [] -> Just (tds, fds) - (ds:dst) -> case [ (tc, fc) - | DependIfUse u' td fd <- ds - , u' == u - , let tc = lift_context' td - fc = lift_context' fd - , not (null tc && null fc) - ] of - [] -> Nothing - pairs -> find_matching_use_deps dst u (map fst pairs ++ tds, map snd pairs ++ fds) - --- reorders depends to make them more attractive --- for other normalization algorithms --- and for final pretty-printer -sort_deps :: Dependency -> Dependency -sort_deps d = - case d of - DependIfUse lu lt lf - | is_empty_dependency lf -> - case lt of - DependIfUse ru rt rf - -- b? ( a? ( d ) ) - | ru < lu && is_empty_dependency rf -> mkUseDependency (True, ru) $ mkUseDependency (True, lu) (go rt) - -- b? ( !a? ( d ) ) - | ru < lu && is_empty_dependency rt -> mkUseDependency (False, ru) $ mkUseDependency (True, lu) (go rf) - _ -> DependIfUse lu (go lt) (go lf) - | is_empty_dependency lt -> - case lf of - DependIfUse ru rt rf - -- !b? ( a? ( d ) ) - | ru < lu && is_empty_dependency rf -> mkUseDependency (True, ru) $ mkUseDependency (False, lu) (go rt) - -- !b? ( !a? ( d ) ) - | ru < lu && is_empty_dependency rt -> mkUseDependency (False, ru) $ mkUseDependency (False, lu) (go rf) - _ -> DependIfUse lu (go lt) (go lf) - DependIfUse use td fd -> DependIfUse use (go td) (go fd) - DependAnyOf deps -> DependAnyOf $ L.sort $ map go deps - DependAllOf deps -> DependAllOf $ L.sort $ map go deps - DependAtom _ -> d - where go = sort_deps - --- remove various types of redundancy -normalize_depend :: Dependency -> Dependency -normalize_depend = normalize_depend' 50 0 -- arbitrary limit - -normalize_depend' :: Int -> Int -> Dependency -> Dependency -normalize_depend' max_level level d - | level >= max_level = trace "WARNING: Normalize_depend hung up. Optimization is incomplete." d -normalize_depend' max_level level d = next_step next_d - where next_d = normalization_step level d - next_step | d == next_d = id - | otherwise = normalize_depend' max_level (level + 1) diff --git a/Portage/Dependency/Print.hs b/Portage/Dependency/Print.hs deleted file mode 100644 --- a/Portage/Dependency/Print.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Portage.Dependency.Print - ( - dep2str - , dep2str_noindent - ) where - -import Portage.Version -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 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 '>' PP.<> DP.pretty pn <-> DP.pretty v -dispLBound pn (NonstrictLB v) = Disp.text ">=" PP.<> DP.pretty pn <-> DP.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 _pn InfinityB = error "unhandled 'dispUBound Infinity'" - -dispDAttr :: DAttr -> Disp.Doc -dispDAttr (DAttr s u) = dispSlot s PP.<> dispUses u - -dep2str :: Int -> Dependency -> String -dep2str start_indent = render . nest start_indent . showDepend - -dep2str_noindent :: Dependency -> String -dep2str_noindent = render . showDepend - -(<->) :: Disp.Doc -> Disp.Doc -> Disp.Doc -a <-> b = a PP.<> Disp.char '-' PP.<> b - -sp :: Disp.Doc -sp = Disp.char ' ' - -sparens :: Disp.Doc -> Disp.Doc -sparens doc = Disp.parens (sp PP.<> valign doc PP.<> sp) - -valign :: Disp.Doc -> Disp.Doc -valign d = nest 0 d - -showDepend :: Dependency -> Disp.Doc -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 - -- 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 - -showDepend (DependIfUse u td fd) = valign $ vcat [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) - 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 - --- 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@(DependAtom (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 deleted file mode 100644 --- a/Portage/Dependency/Types.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-| -Module : Portage.Dependency.Types -License : GPL-3+ -Maintainer : haskell@gentoo.org - -Functions and types related to processing Portage dependencies. --} -module Portage.Dependency.Types - ( - SlotDepend(..) - , LBound(..) - , UBound(..) - , DRange(..) - , DAttr(..) - , Dependency(..) - , Atom(..) - , dep_as_broad_as - , is_empty_dependency - , dep_is_case_of - , range_is_case_of - ) where - -import Portage.PackageId -import Portage.Use - -import Control.DeepSeq (NFData(..)) - --- | Type of SLOT dependency of a dependency. -data SlotDepend = AnySlot -- ^ nothing special - | AnyBuildTimeSlot -- ^ ':=' - | 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 - compare _ ZeroB = GT - compare (StrictLB lv) (StrictLB rv) = compare lv rv - compare (NonstrictLB lv) (NonstrictLB rv) = compare lv rv - compare (StrictLB lv) (NonstrictLB rv) = case compare lv rv of - EQ -> GT - r -> r - compare (NonstrictLB lv) (StrictLB rv) = case compare lv rv of - EQ -> LT - r -> r --- | Type of upper bound of a dependency. -data UBound = StrictUB Version -- ^ less than (<) - | NonstrictUB Version -- ^ less than or equal to (<=) - | 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 - compare _ InfinityB = LT - compare (StrictUB lv) (StrictUB rv) = compare lv rv - compare (NonstrictUB lv) (NonstrictUB rv) = compare lv rv - compare (StrictUB lv) (NonstrictUB rv) = case compare lv rv of - EQ -> LT - r -> r - compare (NonstrictUB lv) (StrictUB rv) = case compare lv rv of - EQ -> GT - r -> r - --- | Type of dependency version. --- --- A dependency version may either be an exact 'Version' or a --- version range between a given 'LBound' and 'UBound'. -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 -range_is_case_of _ _ = False - --- | True if left 'DRange' covers at least as much as the right 'DRange'. -range_as_broad_as :: DRange -> DRange -> Bool -range_as_broad_as (DRange llow lup) (DRange rlow rup) - | llow <= rlow && lup >= rup = True -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 -dep_as_broad_as l r - -- very broad (not only on atoms) special case - | l == r = True --- atoms -dep_as_broad_as (DependAtom (Atom lpn lr lda)) (DependAtom (Atom rpn rr rda)) - | lpn == rpn && lda == rda = lr `range_as_broad_as` rr --- AllOf (very common case in context propagation) -dep_as_broad_as d (DependAllOf deps) - | any (dep_as_broad_as d) deps = True -dep_as_broad_as _ _ = False - --- TODO: remove it and switch to 'SatisfiedDepend' instead -is_empty_dependency :: Dependency -> Bool -is_empty_dependency d = - case d of - DependIfUse _use td fd - -> is_empty_dependency td && is_empty_dependency fd - DependAnyOf [] - -> True -- 'any (const True) [] == False' and we don't want it - DependAnyOf deps - -> any is_empty_dependency deps - DependAllOf deps - -> all is_empty_dependency deps - DependAtom _ - -> False - -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 (DependAtom (Atom lpn lr lda)) (DependAtom (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 deleted file mode 100644 --- a/Portage/EBuild.hs +++ /dev/null @@ -1,293 +0,0 @@ -{-| -Module : Portage.EBuild -License : GPL-3+ -Maintainer : haskell@gentoo.org - -Functions and types related to interpreting and manipulating an ebuild, -as understood by the Portage package manager. --} -{-# LANGUAGE CPP #-} -module Portage.EBuild - ( EBuild(..) - , ebuildTemplate - , showEBuild - , src_uri - -- hspec exports - , sort_iuse - , drop_tdot - , quote - , toHttps - ) where - -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 -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 Network.URI -import qualified Paths_hackport(version) - -#if ! MIN_VERSION_time(1,5,0) -import qualified System.Locale as TC -#endif - --- | Type representing the information contained in an @.ebuild@. -data EBuild = EBuild { - name :: String, - category :: String, - hackage_name :: String, -- might differ a bit (we mangle case) - version :: String, - hackportVersion :: String, - description :: String, - homepage :: String, - license :: Either String String, - slot :: String, - keywords :: [String], - iuse :: [String], - depend :: Dependency, - depend_extra :: [String], - rdepend :: Dependency, - rdepend_extra :: [String] - , features :: [CabalFeature] - , 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 - , used_options :: [(String, String)] -- ^ hints to ebuild writers/readers - -- on what hackport options were used to produce an ebuild - } - -getHackportVersion :: Version -> String -getHackportVersion Version {versionBranch=(x:s)} = foldl (\y z -> y ++ "." ++ (show z)) (show x) s -getHackportVersion Version {versionBranch=[]} = "" - --- | Generate a minimal 'EBuild' template. -ebuildTemplate :: EBuild -ebuildTemplate = EBuild { - name = "foobar", - category = "dev-haskell", - hackage_name = "FooBar", - version = "0.1", - hackportVersion = getHackportVersion Paths_hackport.version, - description = "", - homepage = "https://hackage.haskell.org/package/${HACKAGE_N}", - license = Left "unassigned license?", - slot = "0", - keywords = ["~amd64","~x86"], - iuse = [], - depend = empty_dependency, - depend_extra = [], - rdepend = empty_dependency, - rdepend_extra = [], - features = [], - my_pn = Nothing - , src_prepare = [] - , src_configure = [] - , used_options = [] - } - --- | 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_template --- "https://hackage.haskell.org/package/${P}/${P}.tar.gz" -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 -> "https://hackage.haskell.org/package/${P}/${P}.tar.gz" - -- use MY_X variables (defined in showEBuild) as we've renamed the - -- package - Just _ -> "https://hackage.haskell.org/package/${MY_P}/${MY_P}.tar.gz" - --- | 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. - ss "CABAL_FEATURES=". quote' (sepBy " " $ map render (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. - ss "S=". quote ("${WORKDIR}/${MY_P}"). nl. nl). - ss "DESCRIPTION=". quote (drop_tdot $ description ebuild). nl. - ss "HOMEPAGE=". quote (toHttps $ expandVars (homepage ebuild)). nl. - ss "SRC_URI=". quote (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. - (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 $ [] - where - expandVars = replaceMultiVars [ ( name ebuild, "${PN}") - , (hackage_name ebuild, "${HACKAGE_N}") - ] - - - this_year :: String - this_year = TC.formatTime TC.defaultTimeLocale "%Y" now - --- | Convert http urls into https urls, unless whitelisted as http-only. --- --- >>> toHttps "http://darcs.net" --- "http://darcs.net" --- >>> toHttps "http://pandoc.org" --- "https://pandoc.org" --- >>> toHttps "https://github.com" --- "https://github.com" -toHttps :: String -> String -toHttps x = - case parseURI x of - Just uri -> if uriScheme uri == "http:" && - (uriRegName <$> uriAuthority uri) - `notElem` - httpOnlyHomepages - then replace "http" "https" x - else x - Nothing -> x - where - replace old new = L.intercalate new . LS.splitOn old - -- add to this list with any non https-aware websites - httpOnlyHomepages = Just <$> [ "leksah.org" - , "darcs.net" - , "khumba.net" - ] - --- | Sort IUSE alphabetically --- --- >>> sort_iuse ["+a","b"] --- ["+a","b"] -sort_iuse :: [String] -> [String] -sort_iuse = L.sortBy (compare `F.on` dropWhile ( `elem` "+")) - --- | Drop trailing dot(s). --- --- >>> drop_tdot "foo." --- "foo" --- >>> drop_tdot "foo..." --- "foo" -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 - -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/EBuild/CabalFeature.hs b/Portage/EBuild/CabalFeature.hs deleted file mode 100644 --- a/Portage/EBuild/CabalFeature.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - --- | Support for CABAL_FEATURES="..." in haskell-cabal .ebuild files. --- See haskell-cabal.eclass for details on each of those. -module Portage.EBuild.CabalFeature (CabalFeature(..)) where - -import Portage.EBuild.Render - --- | Type representing @CABAL_FEATURES@ in an ebuild. -data CabalFeature = Lib - | Profile - | Haddock - | Hoogle - | HsColour - | TestSuite - deriving Eq - -instance Render CabalFeature where - render = \case - Lib -> "lib" - Profile -> "profile" - Haddock -> "haddock" - Hoogle -> "hoogle" - HsColour -> "hscolour" - TestSuite -> "test-suite" diff --git a/Portage/EBuild/Render.hs b/Portage/EBuild/Render.hs deleted file mode 100644 --- a/Portage/EBuild/Render.hs +++ /dev/null @@ -1,6 +0,0 @@ --- CABAL_FEATURES="..." in haskell-cabal .ebuild files -module Portage.EBuild.Render (Render(..)) where - -class Render a where - render :: a -> String - diff --git a/Portage/EMeta.hs b/Portage/EMeta.hs deleted file mode 100644 --- a/Portage/EMeta.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-| -Module : Portage.EMeta -License : GPL-3+ -Maintainer : haskell@gentoo.org - -Functions to propagate existing ebuild information -(such as its licence, description, switched flags etc.) to -a new ebuild. --} -module Portage.EMeta - ( EMeta(..) - , findExistingMeta - ) where - -import Control.Monad -import Data.Char (isSpace) -import qualified Data.List as L - -import System.Directory (doesDirectoryExist, getDirectoryContents) -import System.FilePath (()) -import Text.Printf - --- | Extract a value of variable in \'var=\"val\"\' format. --- There should be exactly one variable assignment in the ebuild. --- It's a bit of an 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 (L.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' assignments:\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 - --- | Extract a value of variable in \'#hackport: var: val\' format. --- There should be exactly one variable assignment in the ebuild. -extract_hackport_var :: FilePath -> String -> String -> Maybe String -extract_hackport_var ebuild_path s_ebuild var_name = - case filter (L.isPrefixOf var_prefix) $ lines s_ebuild of - [] -> Nothing - [var_line] -> Just $ skip_prefix var_line - other -> bail_out $ printf "strange '%s' assignmets:\n%s" var_name (unlines other) - - where var_prefix = "#hackport: " ++ var_name ++ ": " - skip_prefix = drop (length var_prefix) - bail_out :: String -> e - bail_out msg = error $ printf "%s:extract_hackport_var %s" ebuild_path msg - --- | Extract the existing keywords from an ebuild. -extractKeywords :: FilePath -> String -> Maybe [String] -extractKeywords ebuild_path s_ebuild = - words `fmap ` extract_quoted_string ebuild_path s_ebuild "KEYWORDS" - --- | Extract the existing license from an ebuild. -extractLicense :: FilePath -> String -> Maybe String -extractLicense ebuild_path s_ebuild = - extract_quoted_string ebuild_path s_ebuild "LICENSE" - --- | Extract the existing Cabal flags from an ebuild. -extractCabalFlags :: FilePath -> String -> Maybe String -extractCabalFlags ebuild_path s_ebuild = - extract_hackport_var ebuild_path s_ebuild "flags" - --- | Extract the existing description from an ebuild. -extractDescription :: FilePath -> String -> Maybe String -extractDescription ebuild_path s_ebuild = - extract_quoted_string ebuild_path s_ebuild "DESCRIPTION" - --- | Type representing the aggregated (best inferred) metadata for a --- new ebuild of a package. -data EMeta = EMeta { keywords :: Maybe [String] - , license :: Maybe String - , cabal_flags :: Maybe String - , description :: Maybe String - } - --- | Find the existing package metadata from the last available ebuild. -findExistingMeta :: FilePath -> IO EMeta -findExistingMeta pkgdir = - do ebuilds <- filter (L.isSuffixOf ".ebuild") `fmap` do b <- doesDirectoryExist pkgdir - if b then getDirectoryContents pkgdir - else return [] - -- TODO: version sort - e_metas <- forM ebuilds $ \e -> - do let e_path = pkgdir e - e_conts <- readFile e_path - return EMeta { keywords = extractKeywords e e_conts - , license = extractLicense e e_conts - , cabal_flags = extractCabalFlags e e_conts - , description = extractDescription 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 - , cabal_flags = get_latest $ map cabal_flags e_metas - , description = get_latest $ map description e_metas - } - return aggregated_meta diff --git a/Portage/GHCCore.hs b/Portage/GHCCore.hs deleted file mode 100644 --- a/Portage/GHCCore.hs +++ /dev/null @@ -1,483 +0,0 @@ -{-| -Module : Portage.GHCCore -License : GPL-3+ -Maintainer : haskell@gentoo.org - -Guess the appropriate GHC version from packages depended upon. --} -module Portage.GHCCore - ( minimumGHCVersionToBuildPackage - , cabalFromGHC - , defaultComponentRequestedSpec - , finalizePD - , platform - , dependencySatisfiable - -- hspec exports - , packageIsCoreInAnyGHC - ) where - -import qualified Distribution.Compiler as DC -import qualified Distribution.Package as Cabal -import qualified Distribution.Version as Cabal -import Distribution.Version -import Distribution.Simple.PackageIndex -import Distribution.InstalledPackageInfo as IPI - -import Distribution.PackageDescription -import Distribution.PackageDescription.Configuration -import Distribution.Compiler (CompilerId(..), CompilerFlavor(GHC)) -import Distribution.System -import Distribution.Types.ComponentRequestedSpec (defaultComponentRequestedSpec) - -import Distribution.Pretty (prettyShow) - -import Data.Maybe -import Data.List ( nub ) - -import Debug.Trace - --- | Try each @GHC@ version in the specified order, from left to right. --- The first @GHC@ version in this list is a minimum default. -ghcs :: [(DC.CompilerInfo, InstalledPackageIndex)] -ghcs = modern_ghcs - where modern_ghcs = [ghc843, ghc863, ghc865, ghc881, ghc883, ghc884, ghc8101, ghc8104, ghc902] - --- | Maybe determine the appropriate 'Cabal.Version' of the @Cabal@ package --- from a given @GHC@ version. --- --- >>> cabalFromGHC [8,8,3] --- Just (mkVersion [3,0,1,0]) --- >>> cabalFromGHC [9,9,9,9] --- Nothing -cabalFromGHC :: [Int] -> Maybe Cabal.Version -cabalFromGHC ver = lookup ver table - where - table = [ ([8,4,3], Cabal.mkVersion [2,2,0,1]) - , ([8,6,3], Cabal.mkVersion [2,4,0,1]) - , ([8,6,5], Cabal.mkVersion [2,4,0,1]) - , ([8,8,1], Cabal.mkVersion [3,0,0,0]) - , ([8,8,3], Cabal.mkVersion [3,0,1,0]) - , ([8,8,4], Cabal.mkVersion [3,0,1,0]) - , ([8,10,1], Cabal.mkVersion [3,2,0,0]) - , ([8,10,4], Cabal.mkVersion [3,2,1,0]) - , ([9,0,2], Cabal.mkVersion [3,4,1,0]) - ] - -platform :: Platform -platform = Platform X86_64 Linux - --- | Is the package a core dependency of a specific version of @GHC@? --- --- >>> packageIsCore (mkIndex ghc883_pkgs) (Cabal.mkPackageName "binary") --- True --- >>> all (== True) ((packageIsCore (mkIndex ghc883_pkgs)) <$> (packageNamesFromPackageIndex (mkIndex ghc883_pkgs))) --- True -packageIsCore :: InstalledPackageIndex -> Cabal.PackageName -> Bool -packageIsCore index pn = not . null $ lookupPackageName index pn - --- | Is the package a core dependency of any version of @GHC@? --- >>> packageIsCoreInAnyGHC (Cabal.mkPackageName "array") --- True -packageIsCoreInAnyGHC :: Cabal.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 :: InstalledPackageIndex -> Cabal.Dependency -> Bool -dependencySatisfiable pindex dep@(Cabal.Dependency pn _rang _lib) - | Cabal.unPackageName pn == "Win32" = False -- only exists on windows, not in linux - | not . null $ lookupDependency pindex (Cabal.depPkgName dep) (Cabal.depVerRange 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 - -> FlagAssignment - -> (DC.CompilerInfo, InstalledPackageIndex) - -> Either [Cabal.Dependency] (PackageDescription, FlagAssignment) -packageBuildableWithGHCVersion pkg user_specified_fas (compiler_info, pkgIndex) = trace_failure $ - finalizePD user_specified_fas defaultComponentRequestedSpec (dependencySatisfiable pkgIndex) platform compiler_info [] pkg - where trace_failure v = case v of - (Left deps) -> trace (unwords ["rejecting dep:" , show_compiler compiler_info - , "as", show_deps deps - , "were not found." - ] - ) v - _ -> trace (unwords ["accepting dep:" , show_compiler compiler_info - ] - ) v - show_deps = show . map prettyShow - show_compiler (DC.CompilerInfo { DC.compilerInfoId = CompilerId GHC v }) = "ghc-" ++ prettyShow 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 -> FlagAssignment -> Maybe ( DC.CompilerInfo - , [Cabal.PackageName] - , PackageDescription - , FlagAssignment - , InstalledPackageIndex) -minimumGHCVersionToBuildPackage gpd user_specified_fas = - listToMaybe [ (cinfo, packageNamesFromPackageIndex pix, pkg_desc, picked_flags, pix) - | g@(cinfo, pix) <- ghcs - , Right (pkg_desc, picked_flags) <- return (packageBuildableWithGHCVersion gpd user_specified_fas g)] - --- | Create an 'InstalledPackageIndex' from a ['Cabal.PackageIdentifier']. --- This is used to generate an index of core @GHC@ packages from the provided --- ['Cabal.PackageIdentifier'] functions, e.g. 'ghc883_pkgs'. -mkIndex :: [Cabal.PackageIdentifier] -> InstalledPackageIndex -mkIndex pids = fromList - [ emptyInstalledPackageInfo - { sourcePackageId = pindex - , exposed = True - } - | pindex@(Cabal.PackageIdentifier _name _version) <- pids ] - -packageNamesFromPackageIndex :: InstalledPackageIndex -> [Cabal.PackageName] -packageNamesFromPackageIndex pix = nub $ map fst $ allPackagesByName pix - -ghc :: [Int] -> DC.CompilerInfo -ghc nrs = DC.unknownCompilerInfo c_id DC.NoAbiTag - where c_id = CompilerId GHC (mkVersion nrs) - -ghc902 :: (DC.CompilerInfo, InstalledPackageIndex) -ghc902 = (ghc [9,0,2], mkIndex ghc902_pkgs) - -ghc8104 :: (DC.CompilerInfo, InstalledPackageIndex) -ghc8104 = (ghc [8,10,4], mkIndex ghc8104_pkgs) - -ghc8101 :: (DC.CompilerInfo, InstalledPackageIndex) -ghc8101 = (ghc [8,10,1], mkIndex ghc8101_pkgs) - -ghc884 :: (DC.CompilerInfo, InstalledPackageIndex) -ghc884 = (ghc [8,8,4], mkIndex ghc884_pkgs) - -ghc883 :: (DC.CompilerInfo, InstalledPackageIndex) -ghc883 = (ghc [8,8,3], mkIndex ghc883_pkgs) - -ghc881 :: (DC.CompilerInfo, InstalledPackageIndex) -ghc881 = (ghc [8,8,1], mkIndex ghc881_pkgs) - -ghc865 :: (DC.CompilerInfo, InstalledPackageIndex) -ghc865 = (ghc [8,6,5], mkIndex ghc865_pkgs) - -ghc863 :: (DC.CompilerInfo, InstalledPackageIndex) -ghc863 = (ghc [8,6,3], mkIndex ghc863_pkgs) - -ghc843 :: (DC.CompilerInfo, InstalledPackageIndex) -ghc843 = (ghc [8,4,3], mkIndex ghc843_pkgs) - --- | Non-upgradeable core packages --- Sources: --- * release notes --- example: https://downloads.haskell.org/~ghc/8.6.5/docs/html/users_guide/8.6.5-notes.html --- * our binary tarballs (package.conf.d.initial subdir) --- * ancient: http://haskell.org/haskellwiki/Libraries_released_with_GHC -ghc902_pkgs :: [Cabal.PackageIdentifier] -ghc902_pkgs = - [ p "array" [0,5,4,0] - , p "base" [4,15,1,0] - , p "binary" [0,8,8,0] -- used by libghc - , p "bytestring" [0,10,12,1] --- , p "Cabal" [3,4,1,0] package is upgradeable - , p "containers" [0,6,4,1] - , p "deepseq" [1,4,5,0] -- used by time - , p "directory" [1,3,6,2] - , p "filepath" [1,4,2,1] - , p "exceptions" [0,10,4] -- used by libghc - , p "ghc-bignum" [1,1] - , p "ghc-boot" [9,0,2] - , p "ghc-boot-th" [9,0,2] - , p "ghc-compact" [0,1,0,0] - , p "ghc-prim" [0,7,0] - , p "ghc-heap" [9,0,2] - , p "ghci" [9,0,2] --- , p "haskeline" [0,8,2] package is upgradeable - , p "hpc" [0,6,1,0] -- used by libghc - , p "integer-gmp" [1,1] - , p "mtl" [2,2,2] -- used by exceptions - , p "parsec" [3,1,14,0] -- used by exceptions - , p "pretty" [1,1,3,6] - , p "process" [1,6,13,2] - -- , p "stm" [2,5,0,0] package is upgradeable(?) - , p "template-haskell" [2,17,0,0] -- used by libghc - , p "terminfo" [0,4,1,5] -- used by libghc - , p "text" [1,2,5,0] -- used by libghc - , p "time" [1,9,3,0] -- used by unix, directory, hpc, ghc. unsafe to upgrade - , p "transformers" [0,5,6,2] -- used by libghc - , p "unix" [2,7,2,2] --- , p "xhtml" [3000,2,2,1] - ] - -ghc8104_pkgs :: [Cabal.PackageIdentifier] -ghc8104_pkgs = - [ p "array" [0,5,4,0] - , p "base" [4,14,1,0] - , p "binary" [0,8,8,0] -- used by libghc - , p "bytestring" [0,10,12,0] --- , p "Cabal" [3,2,1,0] package is upgradeable - , p "containers" [0,6,2,1] - , p "deepseq" [1,4,4,0] -- used by time - , p "directory" [1,3,6,0] - , p "filepath" [1,4,2,1] - , p "exceptions" [0,10,4] -- used by libghc in ghc-9.0.2 - , p "ghc-boot" [8,10,4] - , p "ghc-boot-th" [8,10,4] - , p "ghc-compact" [0,1,0,0] - , p "ghc-prim" [0,6,1,0] - , p "ghc-heap" [8,10,4] - , p "ghci" [8,10,4] --- , p "haskeline" [0,8,0,1] package is upgradeable - , p "hpc" [0,6,1,0] -- used by libghc - , p "integer-gmp" [1,0,3,0] - , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 - , p "parsec" [3,1,14,0] -- used by exceptions in ghc-9.0.2 - , p "pretty" [1,1,3,6] - , p "process" [1,6,9,0] - -- , p "stm" [2,5,0,0] package is upgradeable(?) - , p "template-haskell" [2,16,0,0] -- used by libghc - , p "terminfo" [0,4,1,4] -- used by libghc in ghc-9.0.2 - , p "text" [1,2,4,1] -- used by libghc in ghc-9.0.2 - , p "time" [1,9,3,0] -- used by unix, directory, hpc, ghc. unsafe to upgrade - , p "transformers" [0,5,6,2] -- used by libghc - , p "unix" [2,7,2,2] --- , p "xhtml" [3000,2,2,1] - ] - -ghc8101_pkgs :: [Cabal.PackageIdentifier] -ghc8101_pkgs = - [ p "array" [0,5,4,0] - , p "base" [4,14,0,0] - , p "binary" [0,8,8,0] -- used by libghc - , p "bytestring" [0,10,10,0] --- , p "Cabal" [3,2,0,0] package is upgradeable - , p "containers" [0,6,2,1] - , p "deepseq" [1,4,4,0] -- used by time - , p "directory" [1,3,6,0] - , p "filepath" [1,4,2,1] - , p "exceptions" [0,10,4] -- used by libghc in ghc-9.0.2 - , p "ghc-boot" [8,10,1] - , p "ghc-boot-th" [8,10,1] - , p "ghc-compact" [0,1,0,0] - , p "ghc-prim" [0,6,1,0] - , p "ghc-heap" [8,10,1] - , p "ghci" [8,10,1] --- , p "haskeline" [0,8,0,0] package is upgradeable - , p "hpc" [0,6,1,0] -- used by libghc - , p "integer-gmp" [1,0,3,0] - , p "mtl" [2,2,2] -- used by libghc in ghc-9.0.2 - , p "parsec" [3,1,14,0] -- used by libghc in ghc-9.0.2 - , p "pretty" [1,1,3,6] - , p "process" [1,6,8,2] - -- , p "stm" [2,5,0,0] package is upgradeable(?) - , p "template-haskell" [2,16,0,0] -- used by libghc - , p "terminfo" [0,4,1,4] -- used by libghc in ghc-9.0.2 - , p "text" [1,2,3,2] -- used by libghc in ghc-9.0.2 - , p "time" [1,9,3,0] -- used by unix, directory, hpc, ghc. unsafe to upgrade - , p "transformers" [0,5,6,2] -- used by libghc - , p "unix" [2,7,2,2] --- , p "xhtml" [3000,2,2,1] - ] - -ghc884_pkgs :: [Cabal.PackageIdentifier] -ghc884_pkgs = - [ p "array" [0,5,4,0] - , p "base" [4,13,0,0] - , p "binary" [0,8,7,0] -- used by libghc - , p "bytestring" [0,10,10,1] --- , p "Cabal" [3,0,1,0] package is upgradeable - , p "containers" [0,6,2,1] - , p "deepseq" [1,4,4,0] -- used by time - , p "directory" [1,3,6,0] - , p "filepath" [1,4,2,1] - , p "ghc-boot" [8,8,4] - , p "ghc-boot-th" [8,8,4] - , p "ghc-compact" [0,1,0,0] - , p "ghc-prim" [0,5,3,0] - , p "ghci" [8,8,4] --- , p "haskeline" [0,7,5,0] package is upgradeable - , p "hpc" [0,6,0,3] -- used by libghc - , p "integer-gmp" [1,0,2,0] - , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 - , p "parsec" [3,1,14,0] -- used by exceptions in ghc-9.0.2 - , p "pretty" [1,1,3,6] - , p "process" [1,6,9,0] - -- , p "stm" [2,5,0,0] package is upgradeable(?) - , p "template-haskell" [2,15,0,0] -- used by libghc - , p "terminfo" [0,4,1,4] -- used by libghc in ghc-9.0.2 - , p "text" [1,2,4,0] -- used by libghc in ghc-9.0.2 - , p "time" [1,9,3,0] -- used by unix, directory, hpc, ghc. unsafe to upgrade - , p "transformers" [0,5,6,2] -- used by libghc - , p "unix" [2,7,2,2] --- , p "xhtml" [3000,2,2,1] - ] - -ghc883_pkgs :: [Cabal.PackageIdentifier] -ghc883_pkgs = - [ p "array" [0,5,4,0] - , p "base" [4,13,0,0] - , p "binary" [0,8,7,0] -- used by libghc - , p "bytestring" [0,10,10,0] --- , p "Cabal" [3,0,1,0] package is upgradeable - , p "containers" [0,6,2,1] - , p "deepseq" [1,4,4,0] -- used by time - , p "directory" [1,3,6,0] - , p "filepath" [1,4,2,1] - , p "ghc-boot" [8,8,3] - , p "ghc-boot-th" [8,8,3] - , p "ghc-compact" [0,1,0,0] - , p "ghc-prim" [0,5,3,0] - , p "ghci" [8,8,3] --- , p "haskeline" [0,7,5,0] package is upgradeable - , p "hpc" [0,6,0,3] -- used by libghc - , p "integer-gmp" [1,0,2,0] - , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 - , p "parsec" [3,1,14,0] -- used by exceptions in ghc-9.0.2 - , p "pretty" [1,1,3,6] - , p "process" [1,6,8,0] - -- , p "stm" [2,5,0,0] package is upgradeable(?) - , p "template-haskell" [2,15,0,0] -- used by libghc - , p "terminfo" [0,4,1,4] -- used by libghc in ghc-9.0.2 - , p "text" [1,2,4,0] -- used by libghc in ghc-9.0.2 - , p "time" [1,9,3,0] -- used by unix, directory, hpc, ghc. unsafe to upgrade - , p "transformers" [0,5,6,2] -- used by libghc - , p "unix" [2,7,2,2] --- , p "xhtml" [3000,2,2,1] - ] - -ghc881_pkgs :: [Cabal.PackageIdentifier] -ghc881_pkgs = - [ p "array" [0,5,4,0] - , p "base" [4,13,0,0] - , p "binary" [0,8,7,0] -- used by libghc - , p "bytestring" [0,10,9,0] --- , p "Cabal" [3,0,0,0] package is upgradeable - , p "containers" [0,6,2,1] - , p "deepseq" [1,4,4,0] -- used by time - , p "directory" [1,3,3,2] - , p "filepath" [1,4,2,1] - , p "ghc-boot" [8,8,1] - , p "ghc-boot-th" [8,8,1] - , p "ghc-compact" [0,1,0,0] - , p "ghc-prim" [0,5,3,0] - , p "ghci" [8,8,1] --- , p "haskeline" [0,7,4,3] package is upgradeable - , p "hpc" [0,6,0,3] -- used by libghc - , p "integer-gmp" [1,0,2,0] - , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 - , p "parsec" [3,1,14,0] -- used by exceptions in ghc-9.0.2 - , p "pretty" [1,1,3,6] - , p "process" [1,6,5,1] - -- , p "stm" [2,5,0,0] package is upgradeable(?) - , p "template-haskell" [2,15,0,0] -- used by libghc - , p "terminfo" [0,4,1,4] -- used by libghc in ghc-9.0.2 - , p "text" [1,2,4,0] -- used by libghc in ghc-9.0.2 - , p "time" [1,9,3,0] -- used by unix, directory, hpc, ghc. unsafe to upgrade - , p "transformers" [0,5,6,2] -- used by libghc - , p "unix" [2,7,2,2] --- , p "xhtml" [3000,2,2,1] - ] - -ghc865_pkgs :: [Cabal.PackageIdentifier] -ghc865_pkgs = - [ p "array" [0,5,3,0] - , p "base" [4,12,0,0] - , p "binary" [0,8,6,0] -- used by libghc - , p "bytestring" [0,10,8,2] --- , p "Cabal" [2,4,0,1] package is upgradeable - , p "containers" [0,6,0,1] - , p "deepseq" [1,4,4,0] -- used by time - , p "directory" [1,3,3,0] - , p "filepath" [1,4,2,1] - , p "ghc-boot" [8,6,5] - , p "ghc-boot-th" [8,6,5] - , p "ghc-compact" [0,1,0,0] - , p "ghc-prim" [0,5,3,0] - , p "ghci" [8,6,5] --- , p "haskeline" [0,7,4,3] package is upgradeable - , p "hpc" [0,6,0,3] -- used by libghc - , p "integer-gmp" [1,0,2,0] - , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 - , p "parsec" [3,1,13,0] -- used by exceptions in ghc-9.0.2 - , p "pretty" [1,1,3,6] - , p "process" [1,6,5,0] - -- , p "stm" [2,5,0,0] package is upgradeable(?) - , p "template-haskell" [2,14,0,0] -- used by libghc - , p "terminfo" [0,4,1,2] -- used by libghc in ghc-9.0.2 - , p "text" [1,2,3,1] -- used by libghc in ghc-9.0.2 - , p "time" [1,8,0,2] -- used by unix, directory, hpc, ghc. unsafe to upgrade - , p "transformers" [0,5,6,2] -- used by libghc - , p "unix" [2,7,2,2] --- , p "xhtml" [3000,2,2,1] - ] - -ghc863_pkgs :: [Cabal.PackageIdentifier] -ghc863_pkgs = - [ p "array" [0,5,3,0] - , p "base" [4,12,0,0] - , p "binary" [0,8,6,0] -- used by libghc - , p "bytestring" [0,10,8,2] --- , p "Cabal" [2,4,0,1] package is upgradeable - , p "containers" [0,6,0,1] - , p "deepseq" [1,4,4,0] -- used by time - , p "directory" [1,3,3,0] - , p "filepath" [1,4,2,1] - , p "ghc-boot" [8,6,3] - , p "ghc-boot-th" [8,6,3] - , p "ghc-compact" [0,1,0,0] - , p "ghc-prim" [0,5,3,0] - , p "ghci" [8,6,3] --- , p "haskeline" [0,7,4,3] package is upgradeable - , p "hpc" [0,6,0,3] -- used by libghc - , p "integer-gmp" [1,0,2,0] - , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 - , p "parsec" [3,1,13,0] -- used by exceptions in ghc-9.0.2 - , p "pretty" [1,1,3,6] - , p "process" [1,6,3,0] - -- , p "stm" [2,5,0,0] package is upgradeable(?) - , p "template-haskell" [2,14,0,0] -- used by libghc - , p "terminfo" [0,4,1,2] -- used by libghc in ghc-9.0.2 - , p "text" [1,2,3,1] -- used by libghc in ghc-9.0.2 - , p "time" [1,8,0,2] -- used by unix, directory, hpc, ghc. unsafe to upgrade - , p "transformers" [0,5,5,0] -- used by libghc - , p "unix" [2,7,2,2] --- , p "xhtml" [3000,2,2,1] - ] - -ghc843_pkgs :: [Cabal.PackageIdentifier] -ghc843_pkgs = - [ p "array" [0,5,2,0] - , p "base" [4,11,1,0] - , p "binary" [0,8,5,1] -- used by libghc - , p "bytestring" [0,10,8,2] --- , p "Cabal" [2,2,0,1] package is upgradeable - , p "containers" [0,5,11,2] - , p "deepseq" [1,4,3,0] -- used by time - , p "directory" [1,3,1,5] - , p "filepath" [1,4,2] - , p "ghc-boot" [8,4,3] - , p "ghc-boot-th" [8,4,3] - , p "ghc-compact" [0,1,0,0] - , p "ghc-prim" [0,5,2,0] - , p "ghci" [8,4,3] --- , p "haskeline" [0,7,4,2] package is upgradeable - , p "hpc" [0,6,0,3] -- used by libghc - , p "integer-gmp" [1,0,2,0] - , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 - , p "parsec" [3,1,13,0] -- used by exceptions in ghc-9.0.2 - , p "pretty" [1,1,3,6] - , p "process" [1,6,3,0] - -- , p "stm" [2,4,5,0] package is upgradeable(?) - , p "template-haskell" [2,13,0,0] -- used by libghc - , p "terminfo" [0,4,1,1] -- used by libghc in ghc-9.0.2 - , p "text" [1,2,3,0] -- used by libghc in ghc-9.0.2 - , p "time" [1,8,0,2] -- used by unix, directory, hpc, ghc. unsafe to upgrade - , p "transformers" [0,5,5,0] -- used by libghc - , p "unix" [2,7,2,2] --- , p "xhtml" [3000,2,2,1] - ] - -p :: String -> [Int] -> Cabal.PackageIdentifier -p pn vs = Cabal.PackageIdentifier (Cabal.mkPackageName pn) (mkVersion vs) diff --git a/Portage/Host.hs b/Portage/Host.hs deleted file mode 100644 --- a/Portage/Host.hs +++ /dev/null @@ -1,121 +0,0 @@ -module Portage.Host - ( getInfo -- :: IO [(String, String)] - , LocalInfo(..) - ) where - -import Util (run_cmd) -import qualified Data.List.Split as DLS -import Data.Maybe (fromJust, isJust, mapMaybe) - -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 - , askPortageq - , 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 - if exists then read <$> readFile config_path else return Nothing - ----------- --- Paludis ----------- - -getPaludisInfo :: IO (Maybe LocalInfo) -getPaludisInfo = fmap parsePaludisInfo <$> run_cmd "cave info" - -parsePaludisInfo :: String -> LocalInfo -parsePaludisInfo text = - let chunks = DLS.splitOn [""] . lines $ text - repositories = mapMaybe 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 - }) - ---------- --- Emerge ---------- - -askPortageq :: IO (Maybe LocalInfo) -askPortageq = do - distdir <- run_cmd "portageq distdir" - portdir <- run_cmd "portageq get_repo_path / gentoo" - 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 Nothing `elem` [distdir,portdir] - then Nothing - else Just LocalInfo - { distfiles_dir = grab distdir - , portage_dir = grab portdir - , overlay_list = iffy hsRepo - } - --init: kill newline char - where grab = init . fromJust - iffy Nothing = [] - iffy (Just repo) = [init repo] - return info diff --git a/Portage/Metadata.hs b/Portage/Metadata.hs deleted file mode 100644 --- a/Portage/Metadata.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-| -Module : Portage.Metadata -License : GPL-3+ -Maintainer : haskell@gentoo.org - -Functions and types related to @metadata.xml@ processing --} -module Portage.Metadata - ( Metadata(..) - , metadataFromFile - , pureMetadataFromFile - , stripGlobalUseFlags -- exported for hspec - , prettyPrintFlags -- exported for hspec - , prettyPrintFlagsHuman - , makeDefaultMetadata - , makeMinimalMetadata - ) where - -import qualified AnsiColor as A - -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 - --- | A data type for the Gentoo-specific @metadata.xml@ file. --- Currently defines functions for the maintainer email and --- USE flags and their descriptions. -data Metadata = Metadata - { metadataEmails :: [String] -- ^ This should /always/ be [\"haskell@gentoo.org\"]. - , metadataUseFlags :: Map.Map String String -- ^ Only /active/ USE flags, if any. - } deriving (Eq, Show) - --- | Maybe return a 'Metadata' from a 'T.Text'. --- --- Trying to parse an empty 'T.Text' should return 'Nothing': --- --- >>> pureMetadataFromFile T.empty --- Nothing --- --- Parsing a @metadata.xml@ /without/ USE flags should /always/ be equivalent --- to 'makeMinimalMetadata': --- --- >>> pureMetadataFromFile (makeDefaultMetadata Map.empty) == Just makeMinimalMetadata --- True --- --- Parsing a @metadata.xml@ /with/ USE flags should /always/ be equivalent --- to 'makeMinimalMetadata' /plus/ the supplied USE flags: --- --- >>> pureMetadataFromFile (makeDefaultMetadata (Map.fromList [("name","description")])) == Just (makeMinimalMetadata {metadataUseFlags = Map.fromList [("name","description")] } ) --- True -pureMetadataFromFile :: T.Text -> Maybe Metadata -pureMetadataFromFile file = parseXMLDoc file >>= \doc -> parseMetadata doc - --- | Apply 'pureMetadataFromFile' to a 'FilePath'. -metadataFromFile :: FilePath -> IO (Maybe Metadata) -metadataFromFile fp = pureMetadataFromFile <$> T.readFile fp - --- | Extract the maintainer email and USE flags from a supplied XML 'Element'. --- --- If we're parsing a blank 'Element' or otherwise empty @metadata.xml@: --- >>> parseMetadata blank_element --- Just (Metadata {metadataEmails = [], metadataUseFlags = fromList []}) -parseMetadata :: Element -> Maybe Metadata -parseMetadata xml = - return Metadata { metadataEmails = strContent <$> findElements (unqual "email") xml - , metadataUseFlags = - -- find the flag name - let x = findElement (unqual "use") xml - y = onlyElems $ concatMap elContent x - z = attrVal <$> concatMap elAttribs y - -- find the flag description - a = concatMap elContent y - b = cdData <$> onlyText a - in Map.fromList $ zip z b - } - --- | Remove global @USE@ flags from the flags 'Map.Map', as these should not be --- within the local @metadata.xml@. For now, this is manually specified rather than --- parsing @use.desc@. -stripGlobalUseFlags :: Map.Map String String -> Map.Map String String -stripGlobalUseFlags m = foldr1 Map.intersection (Map.delete <$> globals <*> [m]) - where - globals = [ "debug" - , "examples" - , "static" - ] - --- | 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" ++ - (showElement - . add_attr (Attr (blank_name { qName = "name" }) name) - . unode "flag" $ description)) - <$> (Map.toAscList . stripGlobalUseFlags $ 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 ++ ": ") ++ - (L.intercalate " " . lines $ description)) - <$> (Map.toAscList . stripGlobalUseFlags $ m) - --- | A minimal metadata for use as a fallback value. -makeMinimalMetadata :: Metadata -makeMinimalMetadata = Metadata { metadataEmails = ["haskell@gentoo.org"] - , metadataUseFlags = Map.empty - } - --- don't use Text.XML.Light as we like our own pretty printer --- | Pretty print the @metadata.xml@ string. -makeDefaultMetadata :: Map.Map String String -> T.Text -makeDefaultMetadata flags = T.pack $ - unlines [ "" - , "" - , "" - , "\t" - , "\t\thaskell@gentoo.org" - , "\t\tGentoo Haskell" - , "\t" - ++ if flags == Map.empty - then "" - else "\n\t\n" ++ (unlines $ prettyPrintFlags flags) ++ "\t" - , "" - ] diff --git a/Portage/Overlay.hs b/Portage/Overlay.hs deleted file mode 100644 --- a/Portage/Overlay.hs +++ /dev/null @@ -1,189 +0,0 @@ -module Portage.Overlay - ( ExistingEbuild(..) - , Overlay(..) - , loadLazy - , readOverlay, readOverlayByPackage - , getDirectoryTree, DirectoryTree - - , reduceOverlay - , filterByEmail - , inOverlay - ) - where - -import qualified Portage.PackageId as Portage -import qualified Portage.Metadata as Portage - -import qualified Distribution.Package as Cabal - -import Distribution.Parsec (simpleParsec) -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) - -data ExistingEbuild = ExistingEbuild { - ebuildId :: Portage.PackageId, - ebuildCabalId :: Cabal.PackageIdentifier, - ebuildPath :: FilePath - } deriving (Show,Ord,Eq) - -instance Cabal.Package ExistingEbuild where - packageId = ebuildCabalId - -instance Cabal.HasUnitId ExistingEbuild where - installedUnitId _ = error "Portage.Cabal.installedUnitId: FIXME: should not be used" - --- | Type describing an overlay. -data Overlay = Overlay { - overlayPath :: FilePath, - overlayMap :: Map Portage.PackageName [ExistingEbuild], - overlayMetadata :: Map Portage.PackageName Portage.Metadata - } deriving Show - --- | Is 'Cabal.PackageId' found in 'Overlay'? -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 - ] - -filterByEmail :: ([String] -> Bool) -> Overlay -> Overlay -filterByEmail p overlay = overlay - { overlayMetadata = metadataMap' - , overlayMap = pkgMap' - } - where - metadataMap' = Map.filter (p . Portage.metadataEmails) (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 = -- gah! - map (maximumBy (comparing (Portage.pkgVersion . ebuildId))) - . groupBy (equating (versionNumbers . Portage.pkgVersion . ebuildId)) - . sortOn (Portage.pkgVersion . ebuildId) - -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 <- [simpleParsec dir] ] - - packages :: Portage.Category -> DirectoryTree - -> [(Portage.PackageName, DirectoryTree)] - packages category entries = - [ (Portage.PackageName category name, entries') - | Directory dir entries' <- entries - , Just name <- [simpleParsec 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) <- [simpleParsec 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 deleted file mode 100644 --- a/Portage/PackageId.hs +++ /dev/null @@ -1,203 +0,0 @@ -{-# LANGUAGE CPP #-} -{-| -Module : Portage.PackageId -License : GPL-3+ -Maintainer : haskell@gentoo.org - -Portage package identifiers, which unlike Cabal ones include a category. --} -module Portage.PackageId ( - Category(..), - PackageName(..), - PackageId(..), - Portage.Version(..), - mkPackageName, - fromCabalPackageId, - toCabalPackageId, - parseFriendlyPackage, - normalizeCabalPackageName, - normalizeCabalPackageId, - filePathToPackageId, - packageIdToFilePath, - cabal_pn_to_PN - ) where - -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 Portage.Version as Portage - -import Control.DeepSeq (NFData(..)) -import qualified Data.Char as Char -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ((<>)) -import System.FilePath (()) - -#if MIN_VERSION_base(4,11,0) -import Prelude hiding ((<>)) -#endif - -newtype Category = Category { unCategory :: String } - deriving (Eq, Ord, Show, Read) - --- | Portage-style 'PackageName', containing a 'Category' and a 'Cabal.PackageName'. -data PackageName = PackageName { category :: Category, cabalPkgName :: Cabal.PackageName } - deriving (Eq, Ord, Show, Read) - --- | Portage-style 'PackageId', containing a 'PackageName' and a 'Portage.Version'. -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 - -instance Parsec Category where - parsec = Category <$> P.munch1 categoryChar - 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 - -instance Parsec PackageName where - parsec = do - cat <- parsec - _ <- P.char '/' - 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 - -instance Parsec PackageId where - parsec = do - name <- parsec - _ <- P.char '-' - version <- parsec - return $ PackageId name version - --- | Transform a 'PackageId' into a 'FilePath'. --- --- >>> packageIdToFilePath (PackageId (PackageName (Category "dev-haskell") (Cabal.mkPackageName "foo-bar2")) (Portage.Version [3,0,0] (Just 'b') [Portage.RC 2] 1 )) --- "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" - where - a <-> b = a ++ '-':b - a <.> b = a ++ '.':b - --- | Maybe generate a 'PackageId' from a 'FilePath'. Note that the 'FilePath' must have its --- file extension stripped before being passed to 'filePathToPackageId'. --- --- >>> filePathToPackageId (Category "dev-haskell") "foo-bar2-3.0.0b_rc2-r1" --- Just (PackageId {packageId = PackageName {category = Category {unCategory = "dev-haskell"}, cabalPkgName = PackageName "foo-bar2"}, pkgVersion = Version {versionNumber = [3,0,0], versionChar = Just 'b', versionSuffix = [RC 2], versionRevision = 1}}) -filePathToPackageId :: Category -> FilePath -> Maybe PackageId -filePathToPackageId cat fp = - case explicitEitherParsec parser fp of - Right x -> Just x - _ -> Nothing - where - parser = do - pn <- parseCabalPackageName - _ <- P.char '-' - v <- parsec - return $ PackageId (PackageName cat pn) v - --- | Create a 'PackageName' from supplied category and package name 'String's. -mkPackageName :: String -> String -> PackageName -mkPackageName cat package = PackageName (Category cat) (Cabal.mkPackageName package) - --- | Create a 'PackageId' from a 'Category' and 'Cabal.PackageIdentifier'. -fromCabalPackageId :: Category -> Cabal.PackageIdentifier -> PackageId -fromCabalPackageId cat (Cabal.PackageIdentifier name version) = - PackageId (PackageName cat (normalizeCabalPackageName name)) - (Portage.fromCabalVersion version) - --- | Convert a 'Cabal.PackageName' into lowercase. Internally uses --- 'cabal_pn_to_PN'. --- --- >>> normalizeCabalPackageName (Cabal.mkPackageName "FooBar1") --- PackageName "foobar1" -normalizeCabalPackageName :: Cabal.PackageName -> Cabal.PackageName -normalizeCabalPackageName = - Cabal.mkPackageName . cabal_pn_to_PN - --- | Apply 'normalizeCabalPackageName' to the 'Cabal.PackageName' of --- a supplied 'Cabal.PackageIdentifier'. -normalizeCabalPackageId :: Cabal.PackageIdentifier -> Cabal.PackageIdentifier -normalizeCabalPackageId (Cabal.PackageIdentifier name version) = - Cabal.PackageIdentifier (normalizeCabalPackageName name) version - --- | Convert a 'PackageId' into a 'Maybe' 'Cabal.PackageIdentifier'. -toCabalPackageId :: PackageId -> Maybe Cabal.PackageIdentifier -toCabalPackageId (PackageId (PackageName _cat name) version) = - fmap (Cabal.PackageIdentifier name) - (Portage.toCabalVersion version) - --- | Parse a 'String' as a package in the form of @[category\/]name[-version]@: --- --- Note that we /cannot/ use the 'parsec' function to parse the 'Cabal.PackageName', --- since it fails the entire parse if it tries to parse a 'Version'. --- See 'parseCabalPackageName' below. --- --- If parsing a valid package string: --- --- >>> parseFriendlyPackage "category-name/package-name1-0.0.0.1a_beta2-r4" --- Right (Just (Category {unCategory = "category-name"}),PackageName "package-name1",Just (Version {versionNumber = [0,0,0,1], versionChar = Just 'a', versionSuffix = [Beta 2], versionRevision = 4})) --- --- If malformed, return an error string: --- --- >>> parseFriendlyPackage "category-name/package-name-1-0.0.0.1a_beta2-r4" --- Left ... -parseFriendlyPackage :: String -> Either String (Maybe Category, Cabal.PackageName, Maybe Portage.Version) -parseFriendlyPackage str = explicitEitherParsec parser str - where - parser = do - mc <- P.optional . P.try $ do - c <- parsec - _ <- P.char '/' - return c - p <- parseCabalPackageName - mv <- P.optional $ do - _ <- P.char '-' - v <- parsec - return v - return (mc, p, mv) - --- | Parse a 'Cabal.PackageName'. --- --- This parser is a replacement for 'parsecUnqualComponentName' which fails when --- trying to parse a 'Version'. -parseCabalPackageName :: CabalParsing m => m Cabal.PackageName -parseCabalPackageName = do - pn <- P.some . P.try $ - P.choice - [ P.alphaNum - , P.char '+' - , P.char '-' <* P.notFollowedBy (P.some P.digit <* P.notFollowedBy P.letter) - ] - return $ Cabal.mkPackageName pn - --- | Pretty-print a lowercase 'Cabal.PackageName'. --- --- Note the difference between this function and 'normalizeCabalPackageName': --- this function returns a 'String', the other a 'Cabal.PackageName'. --- --- >>> cabal_pn_to_PN (Cabal.mkPackageName "FooBar1") --- "foobar1" -cabal_pn_to_PN :: Cabal.PackageName -> String -cabal_pn_to_PN = map Char.toLower . prettyShow diff --git a/Portage/Resolve.hs b/Portage/Resolve.hs deleted file mode 100644 --- a/Portage/Resolve.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# 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.Pretty (prettyShow) -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: " - ++ prettyShow cat - return cat - cats -> do - warn verbosity $ "Multiple matches of categories: " ++ unwords (map prettyShow 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/Tables.hs b/Portage/Tables.hs deleted file mode 100644 --- a/Portage/Tables.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-| -Module : Portage.Tables -License : GPL-3+ -Maintainer : haskell@gentoo.org - -Tables of Portage-specific conversions. --} -module Portage.Tables - ( set_build_slot - ) where - -import Portage.Dependency.Builder -import Portage.Dependency.Types -import Portage.PackageId - -import Data.Monoid - --- | Set the @SLOT@ for a given 'Dependency'. -set_build_slot :: Dependency -> Dependency -set_build_slot = - overAtom $ \a@(Atom pn dr (DAttr _ u)) -> - case mconcat $ map (First . matches a) slottedPkgs of - First (Just s) -> Atom pn dr (DAttr s u) - First Nothing -> Atom pn dr (DAttr AnyBuildTimeSlot u) - where - matches (Atom pn _ _) (nm,s) - | pn == nm = Just s - | otherwise = Nothing - --- | List of 'PackageName's with their corresponding default 'SlotDepend's. --- --- For example, dependency @QuickCheck@ has its @SLOT@ always set to @2@. -slottedPkgs :: [(PackageName, SlotDepend)] -slottedPkgs = - [ (mkPackageName "dev-haskell" "quickcheck", GivenSlot "2=") - , (mkPackageName "dev-haskell" "hdbc", GivenSlot "2=") - ] diff --git a/Portage/Use.hs b/Portage/Use.hs deleted file mode 100644 --- a/Portage/Use.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Portage.Use ( - -- * main structures - UseFlag(..), - Use(..), - dispUses, - -- * helpers - mkUse, - mkNotUse, - mkQUse - ) where - -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 - --- | 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 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 - -mkUse :: Use -> UseFlag -mkUse = UseFlag - -mkNotUse :: Use -> UseFlag -mkNotUse = N . UseFlag - -mkQUse :: Use -> UseFlag -mkQUse = Q . UseFlag - -showModificator :: UseFlag -> Disp.Doc -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 - -dispUses :: [UseFlag] -> Disp.Doc -dispUses [] = Disp.empty -dispUses us = Disp.brackets $ Disp.hcat $ (Disp.punctuate (Disp.text ", ")) $ map pretty us - -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 - -instance Ord Use where - compare (Use a) (Use b) = case (a,b) of - ("test", "test") -> EQ - ("test", _) -> LT - (_, "test") -> GT - (_, _) -> a `compare` b diff --git a/Portage/Version.hs b/Portage/Version.hs deleted file mode 100644 --- a/Portage/Version.hs +++ /dev/null @@ -1,146 +0,0 @@ -{-# LANGUAGE CPP #-} -{-| - Author : Andres Loeh - 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.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 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 - , versionSuffix :: [Suffix] - , versionRevision :: Int -- ^ revision, 0 means none - } - 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) = - 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 - --- | 'Version' parser using 'Parsec'. -instance Parsec Version where - parsec = do - ver <- P.sepByNonEmpty digits (P.char '.') - c <- P.optional P.lower - suf <- P.many parsec - rev <- P.option 0 $ P.string "-r" *> digits - return $ Version (NE.toList ver) c suf rev - --- | Check if the ebuild is a live ebuild, i.e. if its 'Version' is @9999@. --- --- foo-9999* is treated as live ebuild --- Cabal-1.17.9999* as well --- --- >>> let (c,s,r) = (Nothing,[],0) --- >>> is_live (Version [1,0,0] c s r) --- False --- >>> is_live (Version [999] c s r) --- False --- >>> is_live (Version [1,0,0,9999] c s r) --- True --- >>> is_live (Version [9999] c s r) --- True --- --- $ --- prop> \verNum char rev -> is_live (Version verNum char [] rev) == if length verNum >= 1 && last verNum >= 9999 then True else False -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 - --- | Various allowed suffixes in Portage versions. -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 - 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 - -instance Parsec Suffix where - parsec = P.char '_' - *> P.choice - [ P.string "alpha" >> fmap Alpha maybeDigits - , P.string "beta" >> fmap Beta maybeDigits - , P.try (P.string "pre") >> fmap Pre maybeDigits - , P.string "rc" >> fmap RC maybeDigits - , P.string "p" >> fmap P maybeDigits - ] - where - maybeDigits = P.option 0 digits - --- | Convert from a 'Cabal.Version' to a Portage 'Version'. --- --- prop> \verNum -> fromCabalVersion (Cabal.mkVersion verNum) == Version verNum Nothing [] 0 -fromCabalVersion :: Cabal.Version -> Version -fromCabalVersion cabal_version = Version (Cabal.versionNumbers cabal_version) Nothing [] 0 - --- | Convert from a Portage 'Version' to a 'Cabal.Version'. --- $ --- prop> \verNum char rev -> toCabalVersion (Version verNum char [] rev) == if char == Nothing then Just (Cabal.mkVersion verNum) else Nothing -toCabalVersion :: Version -> Maybe Cabal.Version -toCabalVersion (Version nums Nothing [] _) = Just (Cabal.mkVersion nums) -toCabalVersion _ = Nothing - --- | Parser which munches digits. -digits :: P.CharParsing m => m Int -digits = read <$> P.some P.digit diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,7 +1,6 @@ -#!/usr/bin/runhaskell module Main (main) where -import Distribution.Simple +import Distribution.Extra.Doctest ( defaultMainWithDoctests ) main :: IO () -main = defaultMain +main = defaultMainWithDoctests "doctests" diff --git a/Status.hs b/Status.hs deleted file mode 100644 --- a/Status.hs +++ /dev/null @@ -1,258 +0,0 @@ -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 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.Monad - --- cabal -import qualified Distribution.Verbosity as Cabal -import qualified Distribution.Package as Cabal (pkgName) -import qualified Distribution.Simple.Utils as Cabal (comparing, die', equating) -import Distribution.Pretty (prettyShow) -import Distribution.Parsec (simpleParsec) - -import qualified Distribution.Client.GlobalFlags as CabalInstall -import qualified Distribution.Client.IndexUtils as CabalInstall -import qualified Distribution.Client.Types as CabalInstall ( SourcePackageDb(..) ) -import qualified Distribution.Solver.Types.PackageIndex as CabalInstall -import qualified Distribution.Solver.Types.SourcePackage as CabalInstall ( SourcePackage(..) ) - -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 = Cabal.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 :: Cabal.Verbosity -> CabalInstall.RepoContext -> Overlay -> IO [[PackageId]] -loadHackage verbosity repoContext overlay = do - CabalInstall.SourcePackageDb { packageIndex = pindex } <- CabalInstall.getSourcePackages verbosity repoContext - let get_cat cabal_pkg = case resolveCategories overlay (Cabal.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) - . CabalInstall.srcpkgPackageId)) - (CabalInstall.allPackagesByName pindex) - return pkg_infos - -status :: Cabal.Verbosity -> FilePath -> FilePath -> CabalInstall.RepoContext -> IO (Map PackageName [FileStatus ExistingEbuild]) -status verbosity portdir overlaydir repoContext = do - overlay <- loadLazy overlaydir - hackage <- loadHackage verbosity repoContext overlay - portage <- filterByEmail ("haskell@gentoo.org" `elem`) <$> loadLazy portdir - let (over, both, port) = portageDiff (overlayMap overlay) (overlayMap portage) - - both' <- T.forM both $ mapM $ \e -> 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 (Cabal.equating ebuildId)) le re) - hack = (( -- We merge package names as we do case-insensitive match. - -- Hackage contains the following 2 package names: - -- ... Cabal-1.24.0.0 Cabal-1.24.1.0 - -- cabal-0.0.0.0 - -- We need to pick both lists of versions, not the first. - -- TODO: have a way to distict between them in the output. - Map.fromListWith (++) $ - 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 :: Cabal.Verbosity -> FilePath -> FilePath -> StatusDirection -> [String] -> CabalInstall.RepoContext -> IO () -runStatus verbosity portdir overlaydir direction pkgs repoContext = do - let pkgFilter = case direction of - OverlayToPortage -> toPortageFilter - PortagePlusOverlay -> id - HackageToOverlay -> fromHackageFilter - pkgs' <- forM pkgs $ \p -> - case simpleParsec p of - Nothing -> Cabal.die' verbosity ("Could not parse package name: " ++ p ++ ". Format cat/pkg") - Just pn -> return pn - tree0 <- status verbosity portdir overlaydir repoContext - 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 - HackageOnly _ -> False - 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_ (zip [(1 :: Int) ..] $ Map.toAscList packages) $ \(ix, (pkg, ebuilds)) -> do - let (PackageName c p) = pkg - putStr (bold (show ix)) - putStr " " - putStr $ prettyShow c ++ '/' : bold (prettyShow p) - putStr " " - forM_ ebuilds $ \e -> do - putStr $ toColor (fmap (prettyShow . 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 $ Cabal.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 (Cabal.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' = Cabal.equating essence - where - 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/Util.hs b/Util.hs deleted file mode 100644 --- a/Util.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-| - Author : Sergei Trofimovich - 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/exe/Main.hs b/exe/Main.hs new file mode 100644 --- /dev/null +++ b/exe/Main.hs @@ -0,0 +1,491 @@ +{-# LANGUAGE CPP #-} + +module Main (main) where + +import Control.Monad +import Data.Maybe +import Data.List +import qualified Data.Semigroup as S + +-- cabal +import Distribution.Simple.Setup + ( Flag(..), fromFlag + , trueArg + , optionVerbosity + ) + +import Distribution.Simple.Command -- commandsRun +import Distribution.Simple.Utils ( dieNoVerbosity, cabalVersion, warn ) +import qualified Distribution.PackageDescription.Parsec as Cabal +import qualified Distribution.Package as Cabal +import Distribution.Verbosity (Verbosity, normal) + +import Data.Version (showVersion) +import Distribution.Pretty (prettyShow) +import Distribution.Parsec (simpleParsec) + +import qualified Distribution.Client.Setup as CabalInstall +import qualified Distribution.Client.Types as CabalInstall +import qualified Distribution.Client.Update as CabalInstall + +import qualified Distribution.Client.IndexUtils as CabalInstall +import qualified Distribution.Solver.Types.SourcePackage as CabalInstall +import qualified Distribution.Solver.Types.PackageIndex as CabalInstall + +import Portage.Overlay as Overlay ( loadLazy, inOverlay ) +import Portage.Host as Host ( getInfo, portage_dir ) +import Portage.PackageId ( normalizeCabalPackageId ) + +import System.Environment ( getArgs, getProgName ) +import System.Directory ( doesDirectoryExist ) +import System.Exit ( exitFailure ) +{-# LANGUAGE CPP #-} + +import System.FilePath ( () ) + +import qualified HackPort.GlobalFlags as H + +import Error +import Status +import Overlays +import Merge + +import qualified Paths_cabal_install +import qualified Paths_hackport + +----------------------------------------------------------------------- +-- List +----------------------------------------------------------------------- + +data ListFlags = ListFlags { + listVerbosity :: Flag Verbosity + } + +instance S.Semigroup ListFlags where + a <> b = ListFlags { + listVerbosity = combine listVerbosity + } + where combine field = field a S.<> field b + +instance Monoid ListFlags where + mempty = ListFlags { + listVerbosity = mempty + } +#if !(MIN_VERSION_base(4,11,0)) + mappend a b = ListFlags { + listVerbosity = combine listVerbosity + } + where combine field = field a `mappend` field b +#endif + +defaultListFlags :: ListFlags +defaultListFlags = ListFlags { + listVerbosity = Flag normal + } + +listCommand :: CommandUI ListFlags +listCommand = CommandUI { + commandName = "list", + commandSynopsis = "List package versions matching pattern", + commandUsage = usagePackages "list", + commandDescription = Nothing, + commandNotes = Nothing, + + 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] -> H.GlobalFlags -> IO () +listAction flags extraArgs globalFlags = do + let verbosity = fromFlag (listVerbosity flags) + H.withHackPortContext verbosity globalFlags $ \repoContext -> do + overlayPath <- getOverlayPath verbosity (fromFlag $ H.globalPathToOverlay globalFlags) + index <- fmap CabalInstall.packageIndex (CabalInstall.getSourcePackages verbosity repoContext) + overlay <- Overlay.loadLazy overlayPath + let pkgs | null extraArgs = CabalInstall.allPackages index + | otherwise = concatMap (concatMap snd . CabalInstall.searchByNameSubstring index) extraArgs + normalized = map (normalizeCabalPackageId . CabalInstall.srcpkgPackageId) 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 ++ prettyShow pkgId + + +----------------------------------------------------------------------- +-- Make Ebuild +----------------------------------------------------------------------- + +data MakeEbuildFlags = MakeEbuildFlags { + makeEbuildVerbosity :: Flag Verbosity + , makeEbuildCabalFlags :: Flag (Maybe String) + } + +instance S.Semigroup MakeEbuildFlags where + a <> b = MakeEbuildFlags { + makeEbuildVerbosity = combine makeEbuildVerbosity + , makeEbuildCabalFlags = makeEbuildCabalFlags b + } + where combine field = field a S.<> field b + +instance Monoid MakeEbuildFlags where + mempty = MakeEbuildFlags { + makeEbuildVerbosity = mempty + , makeEbuildCabalFlags = mempty + } +#if !MIN_VERSION_base(4,11,0) + mappend a b = MakeEbuildFlags { + makeEbuildVerbosity = combine makeEbuildVerbosity + , makeEbuildCabalFlags = makeEbuildCabalFlags b + } + where combine field = field a `mappend` field b +#endif + +defaultMakeEbuildFlags :: MakeEbuildFlags +defaultMakeEbuildFlags = MakeEbuildFlags { + makeEbuildVerbosity = Flag normal + , makeEbuildCabalFlags = Flag Nothing + } + +makeEbuildAction :: MakeEbuildFlags -> [String] -> H.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. ") + cat <- case simpleParsec catstr of + Just c -> return c + Nothing -> throwEx (ArgumentError ("could not parse category: " ++ catstr)) + let verbosity = fromFlag (makeEbuildVerbosity flags) + overlayPath <- getOverlayPath verbosity (fromFlag $ H.globalPathToOverlay globalFlags) + forM_ cabals $ \cabalFileName -> do + pkg <- Cabal.readGenericPackageDescription normal cabalFileName + mergeGenericPackageDescription verbosity overlayPath cat pkg False (fromFlag $ makeEbuildCabalFlags flags) + +makeEbuildCommand :: CommandUI MakeEbuildFlags +makeEbuildCommand = CommandUI { + commandName = "make-ebuild", + commandSynopsis = "Make an ebuild from a .cabal file", + commandUsage = \_ -> [], + commandDescription = Nothing, + commandNotes = Nothing, + + commandDefaultFlags = defaultMakeEbuildFlags, + commandOptions = \_showOrParseArgs -> + [ optionVerbosity makeEbuildVerbosity (\v flags -> flags { makeEbuildVerbosity = v }) + + , option "f" ["flags"] + (unlines [ "Set cabal flags to certain state." + , "Example: --flags=-all_extensions" + ]) + makeEbuildCabalFlags + (\cabal_flags v -> v{ makeEbuildCabalFlags = cabal_flags }) + (reqArg' "cabal_flags" (Flag . Just) (\(Flag ms) -> catMaybes [ms])) + ] + } + +----------------------------------------------------------------------- +-- Update +----------------------------------------------------------------------- + +data UpdateFlags = UpdateFlags { + updateVerbosity :: Flag Verbosity + } + +instance S.Semigroup UpdateFlags where + a <> b = UpdateFlags { + updateVerbosity = combine updateVerbosity + } + where combine field = field a S.<> field b + +instance Monoid UpdateFlags where + mempty = UpdateFlags { + updateVerbosity = mempty + } +#if !(MIN_VERSION_base(4,11,0)) + mappend a b = UpdateFlags { + updateVerbosity = combine updateVerbosity + } + where combine field = field a `mappend` field b +#endif + +defaultUpdateFlags :: UpdateFlags +defaultUpdateFlags = UpdateFlags { + updateVerbosity = Flag normal + } + +updateCommand :: CommandUI UpdateFlags +updateCommand = CommandUI { + commandName = "update", + commandSynopsis = "Update the local package database", + commandUsage = usageFlags "update", + commandDescription = Nothing, + commandNotes = Nothing, + + 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] -> H.GlobalFlags -> IO () +updateAction flags extraArgs globalFlags = do + unless (null extraArgs) $ + dieNoVerbosity $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs + let verbosity = fromFlag (updateVerbosity flags) + + H.withHackPortContext verbosity globalFlags $ \repoContext -> + -- TODO: parse user's flags as cabal-iinstall does. + -- Currently I'm lazy to adapt new flag and user: + -- defaultUpdateFlags + let updateFlags = commandDefaultFlags CabalInstall.updateCommand + in CabalInstall.update verbosity updateFlags repoContext + +----------------------------------------------------------------------- +-- 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 up-to-date status against other repos (hackage, ::gentoo)", + commandUsage = usagePackages "status", + commandDescription = Nothing, + commandNotes = Nothing, + + 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] -> H.GlobalFlags -> IO () +statusAction flags args globalFlags = do + let verbosity = fromFlag (statusVerbosity flags) + direction = fromFlag (statusDirection flags) + portagePath <- getPortageDir verbosity globalFlags + overlayPath <- getOverlayPath verbosity (fromFlag $ H.globalPathToOverlay globalFlags) + + H.withHackPortContext verbosity globalFlags $ \repoContext -> + runStatus verbosity portagePath overlayPath direction args repoContext + +----------------------------------------------------------------------- +-- Merge +----------------------------------------------------------------------- + +data MergeFlags = MergeFlags { + mergeVerbosity :: Flag Verbosity + , mergeCabalFlags :: Flag (Maybe String) + } + +instance S.Semigroup MergeFlags where + a <> b = MergeFlags { + mergeVerbosity = combine mergeVerbosity + , mergeCabalFlags = mergeCabalFlags b + } + where combine field = field a S.<> field b + +instance Monoid MergeFlags where + mempty = MergeFlags { + mergeVerbosity = mempty + , mergeCabalFlags = mempty + } +#if !(MIN_VERSION_base(4,11,0)) + mappend a b = MergeFlags { + mergeVerbosity = combine mergeVerbosity + , mergeCabalFlags = mergeCabalFlags b + } + where combine field = field a `mappend` field b +#endif + +defaultMergeFlags :: MergeFlags +defaultMergeFlags = MergeFlags { + mergeVerbosity = Flag normal + , mergeCabalFlags = Flag Nothing + } + +mergeCommand :: CommandUI MergeFlags +mergeCommand = CommandUI { + commandName = "merge", + commandSynopsis = "Make an ebuild out of hackage package", + commandUsage = usagePackages "merge", + commandDescription = Nothing, + commandNotes = Nothing, + + commandDefaultFlags = defaultMergeFlags, + commandOptions = \_showOrParseArgs -> + [ optionVerbosity mergeVerbosity (\v flags -> flags { mergeVerbosity = v }) + + , option "f" ["flags"] + (unlines [ "Set cabal flags to certain state." + , "Example: --flags=-all_extensions" + ]) + mergeCabalFlags + (\cabal_flags v -> v{ mergeCabalFlags = cabal_flags}) + (reqArg' "cabal_flags" (Flag . Just) (\(Flag ms) -> catMaybes [ms])) + ] + } + +mergeAction :: MergeFlags -> [String] -> H.GlobalFlags -> IO () +mergeAction flags extraArgs globalFlags = do + let verbosity = fromFlag (mergeVerbosity flags) + overlayPath <- getOverlayPath verbosity (fromFlag $ H.globalPathToOverlay globalFlags) + + H.withHackPortContext verbosity globalFlags $ \repoContext -> + merge verbosity repoContext extraArgs overlayPath (fromFlag $ mergeCabalFlags flags) + +----------------------------------------------------------------------- +-- Utils +----------------------------------------------------------------------- + +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 -> H.GlobalFlags -> IO FilePath +getPortageDir verbosity globalFlags = do + let portagePathM = fromFlag (H.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 +----------------------------------------------------------------------- + +globalCommand :: CommandUI H.GlobalFlags +globalCommand = CommandUI { + commandName = "", + commandSynopsis = "HackPort is an .ebuild generator from .cabal files with hackage index support", + commandDescription = Just $ \pname -> + let + commands' = commands ++ [commandAddAction helpCommandUI undefined] + cmdDescs = getNormalCommandDescriptions commands' + maxlen = maximum $ [length name | (name, _) <- cmdDescs] + align str = str ++ replicate (maxlen - length str) ' ' + in + "Commands:\n" + ++ unlines [ " " ++ align name ++ " " ++ descr + | (name, descr) <- cmdDescs ] + ++ "\n" + ++ "For more information about a command use\n" + ++ " " ++ pname ++ " COMMAND --help\n\n" + ++ "Typical steps for generating ebuilds from hackage packages:\n" + ++ concat [ " " ++ pname ++ " " ++ x ++ "\n" + | x <- ["update", "merge "]] + ++ "\n" + ++ "Advanced usage:\n" + ++ concat [ " " ++ pname ++ " " ++ x ++ "\n" + | x <- ["update", "make-ebuild "]], + + commandNotes = Nothing, + commandUsage = \pname -> "Usage: " ++ pname ++ " [GLOBAL FLAGS] [COMMAND [FLAGS]]\n", + commandDefaultFlags = H.defaultGlobalFlags, + commandOptions = \_showOrParseArgs -> + [ option ['V'] ["version"] + "Print version information" + H.globalVersion (\v flags -> flags { H.globalVersion = v }) + trueArg + , option [] ["numeric-version"] + "Print just the version number" + H.globalNumericVersion (\v flags -> flags { H.globalNumericVersion = v }) + trueArg + , option ['p'] ["overlay-path"] + "Override search path list where .hackport/ lives (default list: ['.', paludis-ovls or emerge-ovls])" + H.globalPathToOverlay (\ovrl_path flags -> flags { H.globalPathToOverlay = ovrl_path }) + (reqArg' "PATH" (Flag . Just) (\(Flag ms) -> catMaybes [ms])) + , option [] ["portage-path"] + "Override path to your portage tree" + H.globalPathToPortage (\port_path flags -> flags { H.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 (H.globalVersion globalflags) -> printVersion + | fromFlag (H.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 $ showVersion Paths_hackport.version + printVersion = putStrLn $ "hackport version " + ++ showVersion Paths_hackport.version + ++ "\nusing cabal-install " + ++ showVersion Paths_cabal_install.version + ++ " and the Cabal library version " + ++ prettyShow cabalVersion + errorHandler :: HackPortError -> IO () + errorHandler e = do + putStrLn (hackPortShowError e) + +commands :: [Command (H.GlobalFlags -> IO ())] +commands = + [ listCommand `commandAddAction` listAction + , makeEbuildCommand `commandAddAction` makeEbuildAction + , statusCommand `commandAddAction` statusAction + , updateCommand `commandAddAction` updateAction + , mergeCommand `commandAddAction` mergeAction + ] + +main :: IO () +main = getArgs >>= mainWorker diff --git a/hackport.cabal b/hackport.cabal --- a/hackport.cabal +++ b/hackport.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.2 Name: hackport -Version: 0.7.1.1 +Version: 0.7.1.2 License: GPL-3.0-or-later License-file: LICENSE Author: Henning Günther, Duncan Coutts, Lennart Kolmodin @@ -15,128 +15,134 @@ type: git location: git://github.com/gentoo-haskell/hackport.git -Executable hackport - ghc-options: -Wall -threaded +RTS -N -RTS -with-rtsopts=-N - ghc-prof-options: -caf-all -auto-all -rtsopts - Main-Is: Main.hs +flag cabal-v1 + description: Build for cabal-v1 (Setup.hs/gentoo-haskell) compatibility + manual: True + default: False + +library hackport-external-libs-Cabal Default-Language: Haskell2010 - Hs-Source-Dirs: - ., - cabal, - cabal/Cabal, - cabal/cabal-install, - hackage-security/hackage-security/src + Hs-Source-Dirs: cabal, cabal/Cabal + Build-Depends: - array >= 0.4.0.1, - base >= 4.9 && < 5, - bytestring >= 0.10, - containers >= 0.5, - deepseq >= 1.3.0.1, - directory >= 1.2, - extensible-exceptions, - 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, - old-locale >= 1.0, - split, - tar >= 0.5, - time >= 1.4.0.1, - zlib >= 0.5.3, - xml >= 1.3.7, - -- cabal depends - binary >= 0.5.1.1, - text >= 1.2.3.0, - transformers >= 0.3, - unix >= 2.5, - -- cabal-install depends - async >= 2.0, - hashable >= 1.0, - random >= 1.0, - stm >= 2.0, - -- hackage-security depends - base16-bytestring >= 0.1.1 && < 1.1, - base64-bytestring >= 1.0, - cryptohash-sha256 >= 0.11, - ed25519, - ghc-prim, - lukko >= 0.1, - mtl >= 2.1, - template-haskell + array >= 0.4.0.1, + base >= 4.6 && <5, + bytestring >= 0.10.0.0, + containers >= 0.5.0.0, + deepseq >= 1.3.0.1, + directory >= 1.2, + filepath >= 1.3.0.1, + pretty >= 1.1.1, + process >= 1.1.0.2, + time >= 1.4.0.1, + binary >= 0.7, + unix >= 2.6, + transformers >=0.4.1.0, + mtl >= 2.1, + text >= 1.2.3.0, + parsec >= 3.1.13.0 - default-extensions: - -- hackage-security - DefaultSignatures, - DeriveDataTypeable, - DoAndIfThenElse, - EmptyDataDecls, - ExistentialQuantification, - ForeignFunctionInterface, - FlexibleContexts, - FlexibleInstances, - GADTs, - GeneralizedNewtypeDeriving, - KindSignatures, - MultiParamTypeClasses, - -- cabal - PatternGuards, - RankNTypes, - RecordWildCards, - ScopedTypeVariables, - StandaloneDeriving, - TypeFamilies, - TypeOperators, - ViewPatterns other-extensions: - DeriveDataTypeable, - -- extensions due to bundled cabal-install - CPP, - ForeignFunctionInterface, - -- hackage-security extensions - DefaultSignatures, - GeneralizedNewtypeDeriving, - GADTs, - KindSignatures, - RankNTypes, - RecordWildCards, + BangPatterns + CPP + DefaultSignatures + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + ExistentialQuantification + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + ImplicitParams + KindSignatures + NondecreasingIndentation + OverloadedStrings + PatternSynonyms + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + Trustworthy + TypeFamilies TypeOperators + TypeSynonymInstances + UndecidableInstances + exposed-modules: + Distribution.CabalSpecVersion + Distribution.Compat.Binary + Distribution.Compat.CharParsing + Distribution.Compat.Directory + Distribution.Compat.Environment + Distribution.Compat.Graph + Distribution.Compat.Lens + Distribution.Compat.NonEmptySet + Distribution.Compat.Prelude.Internal + Distribution.Compat.Time + Distribution.Compat.Typeable + Distribution.Compiler + Distribution.FieldGrammar + Distribution.FieldGrammar.Newtypes + Distribution.Fields + Distribution.Fields.ParseResult + Distribution.InstalledPackageInfo + Distribution.License + Distribution.ModuleName + Distribution.Package + Distribution.PackageDescription + Distribution.PackageDescription.Configuration + Distribution.PackageDescription.Parsec + Distribution.PackageDescription.PrettyPrint + Distribution.Parsec + Distribution.Parsec.Error + Distribution.Parsec.Position + Distribution.Parsec.Warning + Distribution.Pretty + Distribution.ReadE + Distribution.SPDX + Distribution.Simple.Command + Distribution.Simple.Compiler + Distribution.Simple.Configure + Distribution.Simple.Flag + Distribution.Simple.InstallDirs + Distribution.Simple.PackageIndex + Distribution.Simple.Program + Distribution.Simple.Program.Db + Distribution.Simple.Program.Run + Distribution.Simple.Setup + Distribution.Simple.Utils + Distribution.SPDX.License + Distribution.System + Distribution.Text + Distribution.Types.AnnotatedId + Distribution.Types.ComponentId + Distribution.Types.ComponentRequestedSpec + Distribution.Types.ComponentName + Distribution.Types.Dependency + Distribution.Types.Flag + Distribution.Types.GivenComponent + Distribution.Types.InstalledPackageInfo + Distribution.Types.LibraryName + Distribution.Types.MungedPackageId + Distribution.Types.PackageId + Distribution.Types.PackageName + Distribution.Types.PackageVersionConstraint + Distribution.Types.SourceRepo + Distribution.Types.UnitId + Distribution.Types.UnqualComponentName + Distribution.Types.Version + Distribution.Types.VersionRange + Distribution.Utils.Generic + Distribution.Utils.NubList + Distribution.Utils.ShortText + Distribution.Utils.Structured + Distribution.Verbosity + Distribution.Version + Language.Haskell.Extension + other-modules: - -- hackport modules - AnsiColor - Cabal2Ebuild - Error - HackPort.GlobalFlags - Merge - Merge.Dependencies - Merge.Utils - Overlays - Paths_hackport - Portage.Cabal - Portage.Dependency - Portage.Dependency.Builder - Portage.Dependency.Normalize - Portage.Dependency.Print - Portage.Dependency.Types - Portage.EBuild - Portage.EBuild.CabalFeature - Portage.EBuild.Render - Portage.EMeta - Portage.GHCCore - Portage.Host - Portage.Metadata - Portage.Overlay - Portage.PackageId - Portage.Resolve - Portage.Tables - Portage.Use - Portage.Version - Status - Util - -- cabal modules Distribution.Backpack Distribution.Backpack.ComponentsGraph Distribution.Backpack.Configure @@ -153,119 +159,37 @@ Distribution.Backpack.PreModuleShape Distribution.Backpack.ReadyComponent Distribution.Backpack.UnifyM - Distribution.CabalSpecVersion - Distribution.Client.BuildReports.Types - Distribution.Client.CmdInstall.ClientInstallFlags - Distribution.Client.Compat.Directory - Distribution.Client.Compat.Orphans - Distribution.Client.Compat.Prelude - Distribution.Client.Compat.Semaphore - Distribution.Client.Config - Distribution.Client.Dependency.Types - Distribution.Client.FetchUtils - Distribution.Client.GZipUtils - Distribution.Client.GlobalFlags - Distribution.Client.HashValue - Distribution.Client.HttpUtils - Distribution.Client.IndexUtils - Distribution.Client.IndexUtils.ActiveRepos - Distribution.Client.IndexUtils.IndexState - Distribution.Client.IndexUtils.Timestamp - Distribution.Client.Init.Defaults - Distribution.Client.Init.Types - Distribution.Client.JobControl - Distribution.Client.ManpageFlags - Distribution.Client.ParseUtils - Distribution.Client.ProjectFlags - Distribution.Client.Security.DNS - Distribution.Client.Security.HTTP - Distribution.Client.Setup - Distribution.Client.Tar - Distribution.Client.Targets - Distribution.Client.Types - Distribution.Client.Types.AllowNewer - Distribution.Client.Types.BuildResults - Distribution.Client.Types.ConfiguredId - Distribution.Client.Types.ConfiguredPackage - Distribution.Client.Types.Credentials - Distribution.Client.Types.InstallMethod - Distribution.Client.Types.OverwritePolicy - Distribution.Client.Types.PackageLocation - Distribution.Client.Types.PackageSpecifier - Distribution.Client.Types.ReadyPackage - Distribution.Client.Types.Repo - Distribution.Client.Types.RepoName - Distribution.Client.Types.SourcePackageDb - Distribution.Client.Types.SourceRepo - Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy - Distribution.Client.Update - Distribution.Client.Utils - Distribution.Client.World Distribution.Compat.Async - Distribution.Compat.Binary - Distribution.Compat.CharParsing Distribution.Compat.CopyFile Distribution.Compat.CreatePipe Distribution.Compat.DList - Distribution.Compat.Directory - Distribution.Compat.Environment Distribution.Compat.Exception Distribution.Compat.FilePath - Distribution.Compat.Graph Distribution.Compat.Internal.TempFile - Distribution.Compat.Lens Distribution.Compat.MonadFail Distribution.Compat.Newtype - Distribution.Compat.NonEmptySet Distribution.Compat.Parsing Distribution.Compat.Prelude - Distribution.Compat.Prelude.Internal Distribution.Compat.Process Distribution.Compat.Semigroup Distribution.Compat.Stack - Distribution.Compat.Time - Distribution.Compat.Typeable - Distribution.Compiler - Distribution.Deprecated.ParseUtils - Distribution.Deprecated.ReadP - Distribution.Deprecated.ViewAsFieldDescr - Distribution.FieldGrammar Distribution.FieldGrammar.Class Distribution.FieldGrammar.FieldDescrs - Distribution.FieldGrammar.Newtypes Distribution.FieldGrammar.Parsec Distribution.FieldGrammar.Pretty - Distribution.Fields Distribution.Fields.ConfVar Distribution.Fields.Field Distribution.Fields.Lexer Distribution.Fields.LexerMonad - Distribution.Fields.ParseResult Distribution.Fields.Parser Distribution.Fields.Pretty Distribution.GetOpt - Distribution.InstalledPackageInfo Distribution.Lex - Distribution.License - Distribution.ModuleName - Distribution.Package - Distribution.PackageDescription Distribution.PackageDescription.Check - Distribution.PackageDescription.Configuration Distribution.PackageDescription.FieldGrammar - Distribution.PackageDescription.Parsec - Distribution.PackageDescription.PrettyPrint Distribution.PackageDescription.Quirks Distribution.PackageDescription.Utils - Distribution.Parsec - Distribution.Parsec.Error Distribution.Parsec.FieldLineStream - Distribution.Parsec.Position - Distribution.Parsec.Warning - Distribution.Pretty - Distribution.ReadE - Distribution.SPDX - Distribution.SPDX.License Distribution.SPDX.LicenseExceptionId Distribution.SPDX.LicenseExpression Distribution.SPDX.LicenseId @@ -276,10 +200,6 @@ Distribution.Simple.BuildTarget Distribution.Simple.BuildToolDepends Distribution.Simple.CCompiler - Distribution.Simple.Command - Distribution.Simple.Compiler - Distribution.Simple.Configure - Distribution.Simple.Flag Distribution.Simple.GHC Distribution.Simple.GHC.EnvironmentParser Distribution.Simple.GHC.ImplInfo @@ -288,16 +208,12 @@ Distribution.Simple.Glob Distribution.Simple.HaskellSuite Distribution.Simple.Hpc - Distribution.Simple.InstallDirs Distribution.Simple.InstallDirs.Internal Distribution.Simple.LocalBuildInfo - 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.Find Distribution.Simple.Program.GHC Distribution.Simple.Program.HcPkg @@ -305,31 +221,14 @@ Distribution.Simple.Program.Internal Distribution.Simple.Program.Ld Distribution.Simple.Program.ResponseFile - Distribution.Simple.Program.Run Distribution.Simple.Program.Strip Distribution.Simple.Program.Types - Distribution.Simple.Setup Distribution.Simple.Test.LibV09 Distribution.Simple.Test.Log Distribution.Simple.UHC - Distribution.Simple.Utils - Distribution.Solver.Compat.Prelude - Distribution.Solver.Types.ComponentDeps - Distribution.Solver.Types.ConstraintSource - Distribution.Solver.Types.LabeledPackageConstraint - Distribution.Solver.Types.OptionalStanza - Distribution.Solver.Types.PackageConstraint - Distribution.Solver.Types.PackageFixedDeps - Distribution.Solver.Types.PackageIndex - Distribution.Solver.Types.PackagePath - Distribution.Solver.Types.Settings - Distribution.Solver.Types.SourcePackage - Distribution.System Distribution.TestSuite - Distribution.Text Distribution.Types.AbiDependency Distribution.Types.AbiHash - Distribution.Types.AnnotatedId Distribution.Types.Benchmark Distribution.Types.Benchmark.Lens Distribution.Types.BenchmarkInterface @@ -338,98 +237,135 @@ Distribution.Types.BuildInfo.Lens Distribution.Types.BuildType Distribution.Types.Component - Distribution.Types.ComponentId Distribution.Types.ComponentInclude Distribution.Types.ComponentLocalBuildInfo - Distribution.Types.ComponentName - Distribution.Types.ComponentRequestedSpec Distribution.Types.CondTree Distribution.Types.Condition Distribution.Types.ConfVar - Distribution.Types.Dependency Distribution.Types.DependencyMap Distribution.Types.ExeDependency Distribution.Types.Executable Distribution.Types.Executable.Lens Distribution.Types.ExecutableScope Distribution.Types.ExposedModule - Distribution.Types.Flag Distribution.Types.ForeignLib Distribution.Types.ForeignLib.Lens Distribution.Types.ForeignLibOption Distribution.Types.ForeignLibType Distribution.Types.GenericPackageDescription Distribution.Types.GenericPackageDescription.Lens - Distribution.Types.GivenComponent Distribution.Types.HookedBuildInfo Distribution.Types.IncludeRenaming - Distribution.Types.InstalledPackageInfo Distribution.Types.InstalledPackageInfo.FieldGrammar Distribution.Types.InstalledPackageInfo.Lens Distribution.Types.LegacyExeDependency Distribution.Types.Lens Distribution.Types.Library Distribution.Types.Library.Lens - Distribution.Types.LibraryName Distribution.Types.LibraryVisibility Distribution.Types.LocalBuildInfo Distribution.Types.Mixin Distribution.Types.Module Distribution.Types.ModuleReexport Distribution.Types.ModuleRenaming - Distribution.Types.MungedPackageId Distribution.Types.MungedPackageName Distribution.Types.PackageDescription Distribution.Types.PackageDescription.Lens - Distribution.Types.PackageId Distribution.Types.PackageId.Lens - Distribution.Types.PackageName Distribution.Types.PackageName.Magic - Distribution.Types.PackageVersionConstraint Distribution.Types.PkgconfigDependency Distribution.Types.PkgconfigName Distribution.Types.PkgconfigVersion Distribution.Types.PkgconfigVersionRange Distribution.Types.SetupBuildInfo Distribution.Types.SetupBuildInfo.Lens - Distribution.Types.SourceRepo Distribution.Types.SourceRepo.Lens Distribution.Types.TargetInfo Distribution.Types.TestSuite Distribution.Types.TestSuite.Lens Distribution.Types.TestSuiteInterface Distribution.Types.TestType - Distribution.Types.UnitId - Distribution.Types.UnqualComponentName - Distribution.Types.Version Distribution.Types.VersionInterval - Distribution.Types.VersionRange Distribution.Types.VersionRange.Internal Distribution.Utils.Base62 - Distribution.Utils.Generic Distribution.Utils.IOData Distribution.Utils.LogProgress Distribution.Utils.MD5 Distribution.Utils.MapAccum - Distribution.Utils.NubList Distribution.Utils.Progress - Distribution.Utils.ShortText Distribution.Utils.String - Distribution.Utils.Structured Distribution.Utils.UnionFind - Distribution.Verbosity Distribution.Verbosity.Internal - Distribution.Version - Language.Haskell.Extension - Paths_cabal_install - -- hackage-security modules + Paths_Cabal + +library hackport-external-libs-hackage-security + Default-Language: Haskell2010 + Hs-Source-Dirs: hackage-security/hackage-security/src + + build-depends: + hackport-external-libs-Cabal, + base >= 4.10, + base16-bytestring >= 0.1.1, + base64-bytestring >= 1.0, + bytestring >= 0.9, + containers >= 0.4, + directory >= 1.2, + ed25519 >= 0.0, + filepath >= 1.2, + mtl >= 2.2, + network >= 3.0, + network-uri >= 2.5, + parsec >= 3.1, + pretty >= 1.0, + cryptohash-sha256 >= 0.11, + tar >= 0.5, + template-haskell >= 2.7, + time >= 1.2, + transformers >= 0.3, + zlib >= 0.5, + ghc-prim + + default-extensions: + DefaultSignatures + DeriveDataTypeable + DeriveFunctor + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + KindSignatures + MultiParamTypeClasses + NamedFieldPuns + NoMonomorphismRestriction + RankNTypes + RecordWildCards + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeFamilies + TypeOperators + ViewPatterns + other-extensions: + BangPatterns + CPP + OverlappingInstances + PackageImports + UndecidableInstances + + exposed-modules: Hackage.Security.Client - Hackage.Security.Client.Formats - Hackage.Security.Client.Repository Hackage.Security.Client.Repository.Cache Hackage.Security.Client.Repository.HttpLib Hackage.Security.Client.Repository.Local Hackage.Security.Client.Repository.Remote + Hackage.Security.Util.Checked + Hackage.Security.Util.Path + Hackage.Security.Util.Pretty + Hackage.Security.Util.Some + + other-modules: + Hackage.Security.Client.Formats + Hackage.Security.Client.Repository Hackage.Security.Client.Verify Hackage.Security.JSON Hackage.Security.Key @@ -453,32 +389,211 @@ Hackage.Security.Trusted Hackage.Security.Trusted.TCB Hackage.Security.Util.Base64 - Hackage.Security.Util.Checked Hackage.Security.Util.Exit Hackage.Security.Util.IO Hackage.Security.Util.JSON Hackage.Security.Util.Lens - Hackage.Security.Util.Path - Hackage.Security.Util.Pretty - Hackage.Security.Util.Some Hackage.Security.Util.Stack Hackage.Security.Util.TypedEmbedded Prelude Text.JSON.Canonical - autogen-modules: +library hackport-external-libs-cabal-install + Default-Language: Haskell2010 + Hs-Source-Dirs: cabal, cabal/cabal-install + + build-depends: + hackport-external-libs-Cabal, + hackport-external-libs-hackage-security, + async >= 2.0, + array >= 0.4, + base >= 4.8, + base16-bytestring >= 0.1.1, + binary >= 0.7.3, + bytestring >= 0.10.6.0, + containers >= 0.5.6.2, + cryptohash-sha256 >= 0.11, + deepseq >= 1.4.1.1, + directory >= 1.2.2.0, + echo >= 0.1.3, + edit-distance >= 0.2.2, + filepath >= 1.4.0.0, + hashable >= 1.0, + HTTP >= 4000.1.5, + mtl >= 2.0, + network-uri >= 2.6.0.2, + network >= 2.6, + pretty >= 1.1, + process >= 1.2.3.0, + random >= 1, + stm >= 2.0, + tar >= 0.5.0.3, + time >= 1.5.0.1, + transformers >= 0.4.2.0, + zlib >= 0.5.3, + text >= 1.2.3, + parsec >= 3.1.13.0, + regex-base >= 0.94.0.0, + regex-posix >= 0.96.0.0, + resolv >= 0.1.1 + + exposed-modules: + Distribution.Client.Config + Distribution.Client.GlobalFlags + Distribution.Client.IndexUtils + Distribution.Client.Setup + Distribution.Client.Types + Distribution.Client.Update + Distribution.Solver.Types.PackageIndex + Distribution.Solver.Types.SourcePackage Paths_cabal_install + + other-modules: + Distribution.Client.BuildReports.Types + Distribution.Client.CmdInstall.ClientInstallFlags + Distribution.Client.Compat.Directory + Distribution.Client.Compat.Orphans + Distribution.Client.Compat.Prelude + Distribution.Client.Compat.Semaphore + Distribution.Client.Dependency.Types + Distribution.Client.FetchUtils + Distribution.Client.GZipUtils + Distribution.Client.HashValue + Distribution.Client.HttpUtils + Distribution.Client.IndexUtils.ActiveRepos + Distribution.Client.IndexUtils.IndexState + Distribution.Client.IndexUtils.Timestamp + Distribution.Client.Init.Defaults + Distribution.Client.Init.Types + Distribution.Client.JobControl + Distribution.Client.ManpageFlags + Distribution.Client.ParseUtils + Distribution.Client.ProjectFlags + Distribution.Client.Security.DNS + Distribution.Client.Security.HTTP + Distribution.Client.Tar + Distribution.Client.Targets + Distribution.Client.Types.AllowNewer + Distribution.Client.Types.BuildResults + Distribution.Client.Types.ConfiguredId + Distribution.Client.Types.ConfiguredPackage + Distribution.Client.Types.Credentials + Distribution.Client.Types.InstallMethod + Distribution.Client.Types.OverwritePolicy + Distribution.Client.Types.PackageLocation + Distribution.Client.Types.PackageSpecifier + Distribution.Client.Types.ReadyPackage + Distribution.Client.Types.Repo + Distribution.Client.Types.RepoName + Distribution.Client.Types.SourcePackageDb + Distribution.Client.Types.SourceRepo + Distribution.Client.Types.WriteGhcEnvironmentFilesPolicy + Distribution.Client.Utils + Distribution.Client.World + Distribution.Deprecated.ParseUtils + Distribution.Deprecated.ReadP + Distribution.Deprecated.ViewAsFieldDescr + Distribution.Solver.Compat.Prelude + Distribution.Solver.Types.ComponentDeps + Distribution.Solver.Types.ConstraintSource + Distribution.Solver.Types.LabeledPackageConstraint + Distribution.Solver.Types.OptionalStanza + Distribution.Solver.Types.PackageConstraint + Distribution.Solver.Types.PackageFixedDeps + Distribution.Solver.Types.PackagePath + Distribution.Solver.Types.Settings + +library hackport-internal + Default-Language: Haskell2010 + Hs-Source-Dirs: src + Build-Depends: + hackport-external-libs-Cabal, + hackport-external-libs-cabal-install, + async, + base, + bytestring, + containers, + deepseq, + directory, + extensible-exceptions, + filepath, + network-uri, + parallel >= 3.2.1.0, + pretty, + process, + split, + text, + time, + xml, + -- Needed for doctests-v2 to work + QuickCheck, + template-haskell + + other-extensions: + DeriveDataTypeable + + exposed-modules: + Error + Merge + Overlays + Status + HackPort.GlobalFlags + Portage.Host + Portage.Overlay + Portage.PackageId Paths_hackport + other-modules: + AnsiColor + Cabal2Ebuild + Merge.Dependencies + Merge.Utils + Portage.Cabal + Portage.Dependency + Portage.Dependency.Builder + Portage.Dependency.Normalize + Portage.Dependency.Print + Portage.Dependency.Types + Portage.EBuild + Portage.EBuild.CabalFeature + Portage.EBuild.Render + Portage.EMeta + Portage.GHCCore + Portage.Metadata + Portage.Resolve + Portage.Tables + Portage.Use + Portage.Version + Util + + autogen-modules: + Paths_hackport + +Executable hackport + ghc-options: -Wall -threaded +RTS -N -RTS -with-rtsopts=-N + ghc-prof-options: -caf-all -auto-all -rtsopts + Main-Is: Main.hs + Default-Language: Haskell2010 + Hs-Source-Dirs: exe + Build-Depends: + hackport-external-libs-Cabal, + hackport-external-libs-cabal-install, + hackport-internal, + base, + directory, + filepath + other-modules: Paths_hackport + Test-Suite test-resolve-category -- requires a local Portage overlay, thus fails in a sandboxed test. buildable: False ghc-options: -Wall Type: exitcode-stdio-1.0 Default-Language: Haskell98 - Main-Is: tests/resolveCat.hs - Hs-Source-Dirs: ., cabal, cabal/Cabal, cabal/cabal-install, tests - Build-Depends: array, + Main-Is: resolveCat.hs + Hs-Source-Dirs: src, tests + Build-Depends: hackport-external-libs, + array, base, binary, deepseq, @@ -509,9 +624,10 @@ ghc-options: -Wall Type: exitcode-stdio-1.0 Default-Language: Haskell98 - Main-Is: tests/print_deps.hs - Hs-Source-Dirs: ., cabal, cabal/Cabal, cabal/cabal-install, tests - Build-Depends: array, + Main-Is: print_deps.hs + Hs-Source-Dirs: src, tests + Build-Depends: hackport-external-libs, + array, base, binary, deepseq, @@ -541,9 +657,10 @@ ghc-options: -Wall Type: exitcode-stdio-1.0 Default-Language: Haskell98 - Main-Is: tests/normalize_deps.hs - Hs-Source-Dirs: ., cabal, cabal/Cabal, cabal/cabal-install, tests - Build-Depends: array, + Main-Is: normalize_deps.hs + Hs-Source-Dirs: src, tests + Build-Depends: hackport-external-libs, + array, base, binary, deepseq, @@ -568,213 +685,112 @@ DoAndIfThenElse test-suite doctests + x-doctest-components: lib:hackport-internal exe:hackport type: exitcode-stdio-1.0 + Hs-Source-Dirs: tests ghc-options: -threaded default-language: Haskell98 - main-is: tests/doctests.hs + main-is: doctests.hs build-depends: base, doctest >= 0.8, + cabal-doctest, template-haskell, - QuickCheck + QuickCheck, + directory, + filepath, + base-compat, + Glob + other-modules: Paths_hackport + if !flag(cabal-v1) + buildable: False +test-suite doctests-v2 + type: exitcode-stdio-1.0 + default-language: Haskell98 + main-is: tests/doctests-v2.hs + build-depends: base, process + build-tool-depends: + cabal-install:cabal >= 3.2, + doctest:doctest >= 0.8 + + other-extensions: + CPP + + if flag(cabal-v1) + buildable: False + test-suite spec ghc-options: -Wall Type: exitcode-stdio-1.0 Default-Language: Haskell2010 - Main-Is: tests/Spec.hs - Hs-Source-Dirs: ., cabal, cabal/Cabal, cabal/cabal-install, tests - other-modules: Merge.UtilsSpec - Portage.CabalSpec - Portage.Dependency.PrintSpec - Portage.EBuildSpec - Portage.GHCCoreSpec - Portage.MetadataSpec - Portage.PackageIdSpec - Portage.VersionSpec - QuickCheck.Instances - -- cabal: - Distribution.Backpack - Distribution.CabalSpecVersion - Distribution.Compat.Async - Distribution.Compat.Binary - Distribution.Compat.CharParsing - Distribution.Compat.CopyFile - Distribution.Compat.DList - Distribution.Compat.Exception - Distribution.Compat.FilePath - Distribution.Compat.Graph - Distribution.Compat.Internal.TempFile - Distribution.Compat.Lens - Distribution.Compat.MonadFail - Distribution.Compat.Newtype - Distribution.Compat.NonEmptySet - Distribution.Compat.Parsing - Distribution.Compat.Prelude - Distribution.Compat.Process - Distribution.Compat.Semigroup - Distribution.Compat.Stack - Distribution.Compat.Typeable - Distribution.Compiler - Distribution.FieldGrammar - Distribution.FieldGrammar.Class - Distribution.FieldGrammar.FieldDescrs - Distribution.FieldGrammar.Newtypes - Distribution.FieldGrammar.Parsec - Distribution.FieldGrammar.Pretty - Distribution.Fields - Distribution.Fields.Field - Distribution.Fields.Lexer - Distribution.Fields.LexerMonad - Distribution.Fields.ParseResult - Distribution.Fields.Parser - Distribution.Fields.Pretty - Distribution.InstalledPackageInfo - Distribution.License - Distribution.ModuleName - Distribution.Package - Distribution.PackageDescription - Distribution.PackageDescription.Configuration - Distribution.PackageDescription.Utils - Distribution.Parsec - Distribution.Parsec.Error - Distribution.Parsec.FieldLineStream - Distribution.Parsec.Position - Distribution.Parsec.Warning - Distribution.Pretty - Distribution.ReadE - Distribution.SPDX - Distribution.SPDX.License - Distribution.SPDX.LicenseExceptionId - Distribution.SPDX.LicenseExpression - Distribution.SPDX.LicenseId - Distribution.SPDX.LicenseListVersion - Distribution.SPDX.LicenseReference - Distribution.Simple.PackageIndex - Distribution.Simple.Utils - Distribution.System - Distribution.Types.AbiDependency - Distribution.Types.AbiHash - Distribution.Types.Benchmark - Distribution.Types.Benchmark.Lens - Distribution.Types.BenchmarkInterface - Distribution.Types.BenchmarkType - Distribution.Types.BuildInfo - Distribution.Types.BuildInfo.Lens - Distribution.Types.BuildType - Distribution.Types.Component - Distribution.Types.ComponentId - Distribution.Types.ComponentName - Distribution.Types.ComponentRequestedSpec - Distribution.Types.CondTree - Distribution.Types.Condition - Distribution.Types.ConfVar - Distribution.Types.Dependency - Distribution.Types.DependencyMap - Distribution.Types.ExeDependency - Distribution.Types.Executable - Distribution.Types.Executable.Lens - Distribution.Types.ExecutableScope - Distribution.Types.ExposedModule - Distribution.Types.Flag - Distribution.Types.ForeignLib - Distribution.Types.ForeignLib.Lens - Distribution.Types.ForeignLibOption - Distribution.Types.ForeignLibType - Distribution.Types.GenericPackageDescription - Distribution.Types.GenericPackageDescription.Lens - Distribution.Types.HookedBuildInfo - Distribution.Types.IncludeRenaming - Distribution.Types.InstalledPackageInfo - Distribution.Types.InstalledPackageInfo.FieldGrammar - Distribution.Types.InstalledPackageInfo.Lens - Distribution.Types.LegacyExeDependency - Distribution.Types.Library - Distribution.Types.Library.Lens - Distribution.Types.LibraryName - Distribution.Types.LibraryVisibility - Distribution.Types.Mixin - Distribution.Types.Module - Distribution.Types.ModuleReexport - Distribution.Types.ModuleRenaming - Distribution.Types.MungedPackageId - Distribution.Types.MungedPackageName - Distribution.Types.PackageDescription - Distribution.Types.PackageDescription.Lens - Distribution.Types.PackageId - Distribution.Types.PackageId.Lens - Distribution.Types.PackageName - Distribution.Types.PackageVersionConstraint - Distribution.Types.PkgconfigDependency - Distribution.Types.PkgconfigName - Distribution.Types.PkgconfigVersion - Distribution.Types.PkgconfigVersionRange - Distribution.Types.SetupBuildInfo - Distribution.Types.SetupBuildInfo.Lens - Distribution.Types.SourceRepo - Distribution.Types.TestSuite - Distribution.Types.TestSuite.Lens - Distribution.Types.TestSuiteInterface - Distribution.Types.TestType - Distribution.Types.UnitId - Distribution.Types.UnqualComponentName - Distribution.Types.Version - Distribution.Types.VersionInterval - Distribution.Types.VersionRange - Distribution.Types.VersionRange.Internal - Distribution.Utils.Base62 - Distribution.Utils.Generic - Distribution.Utils.IOData - Distribution.Utils.MD5 - Distribution.Utils.ShortText - Distribution.Utils.String - Distribution.Utils.Structured - Distribution.Verbosity - Distribution.Verbosity.Internal - Distribution.Version - Language.Haskell.Extension - -- hackport: - AnsiColor - Error - Merge.Utils - Paths_hackport - Portage.Cabal - Portage.Dependency - Portage.Dependency.Builder - Portage.Dependency.Normalize - Portage.Dependency.Print - Portage.Dependency.Types - Portage.EBuild - Portage.EBuild.CabalFeature - Portage.EBuild.Render - Portage.GHCCore - Portage.Metadata - Portage.PackageId - Portage.Use - Portage.Version - build-tool-depends: hspec-discover:hspec-discover == 2.* - Build-Depends: array, - base, - binary, - deepseq, - bytestring, - containers, - directory, - extensible-exceptions, - filepath, - hspec >= 2.0, - mtl, - network-uri, - parsec, - pretty, - process, - QuickCheck >= 2.0, - split, - text, - time, - transformers, - unix, - xml - default-extensions: - -- cabal - PatternGuards, - DoAndIfThenElse + Main-Is: Spec.hs + Hs-Source-Dirs: src, tests + other-modules: + Merge.UtilsSpec + Portage.CabalSpec + Portage.Dependency.PrintSpec + Portage.EBuildSpec + Portage.GHCCoreSpec + Portage.MetadataSpec + Portage.PackageIdSpec + Portage.VersionSpec + QuickCheck.Instances + + -- hackport-internal + Error + Merge + Overlays + Status + HackPort.GlobalFlags + Portage.Host + Portage.Overlay + Portage.PackageId + Paths_hackport + AnsiColor + Cabal2Ebuild + Merge.Dependencies + Merge.Utils + Portage.Cabal + Portage.Dependency + Portage.Dependency.Builder + Portage.Dependency.Normalize + Portage.Dependency.Print + Portage.Dependency.Types + Portage.EBuild + Portage.EBuild.CabalFeature + Portage.EBuild.Render + Portage.EMeta + Portage.GHCCore + Portage.Metadata + Portage.Resolve + Portage.Tables + Portage.Use + Portage.Version + Util + + Build-Depends: + hackport-external-libs-Cabal, + hackport-external-libs-cabal-install, + async, + base, + bytestring, + containers, + deepseq, + directory, + extensible-exceptions, + filepath, + hspec >= 2.0, + network-uri, + parallel, + pretty, + process, + QuickCheck >= 2.0, + split, + text, + time, + xml + + build-tool-depends: hspec-discover:hspec-discover >= 2.0 + + other-extensions: + DeriveDataTypeable diff --git a/src/AnsiColor.hs b/src/AnsiColor.hs new file mode 100644 --- /dev/null +++ b/src/AnsiColor.hs @@ -0,0 +1,46 @@ +{-| + Stability : provisional + Portability : haskell98 + + Simplistic ANSI color support. +-} + +module AnsiColor + ( Color(..) + , bold + , inColor + ) where + +import Data.List + +data Color = Black + | Red + | Green + | Yellow + | Blue + | Magenta + | Cyan + | White + | Default + deriving Enum + +esc :: [String] -> String +esc [] = "" +esc xs = "\ESC[" ++ (intercalate ";" 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 :: 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] diff --git a/src/Cabal2Ebuild.hs b/src/Cabal2Ebuild.hs new file mode 100644 --- /dev/null +++ b/src/Cabal2Ebuild.hs @@ -0,0 +1,114 @@ +{-| +Module : Cabal2Ebuild +Copyright : (C) 2005, Duncan Coutts +License : GPL-2+ +Maintainer : haskell@gentoo.org + +A program for generating a Gentoo ebuild from a .cabal file +-} +-- 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. +-- +module Cabal2Ebuild + (cabal2ebuild + ,convertDependencies + ,convertDependency) where + +import qualified Distribution.PackageDescription as Cabal + ( PackageDescription(..), license) +import qualified Distribution.Package as Cabal ( PackageIdentifier(..) + , Dependency(..)) +import qualified Distribution.Version as Cabal ( VersionRange + , cataVersionRange, normaliseVersionRange + , majorUpperBound, mkVersion ) +import Distribution.Version (VersionRangeF(..)) +import Distribution.Pretty (prettyShow) + +import qualified Distribution.Utils.ShortText as ST + +import Data.Char (isUpper) +import Data.Maybe + +import Portage.Dependency +import qualified Portage.Cabal as Portage +import qualified Portage.PackageId as Portage +import qualified Portage.EBuild as Portage +import qualified Portage.EBuild.CabalFeature as Portage +import qualified Portage.Resolve as Portage +import qualified Portage.EBuild as E +import qualified Portage.Overlay as O +import Portage.Version + +-- | Generate a 'Portage.EBuild' from a 'Portage.Category' and a 'Cabal.PackageDescription'. +cabal2ebuild :: Portage.Category -> Cabal.PackageDescription -> Portage.EBuild +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.description = ST.fromShortText $ if ST.null (Cabal.synopsis pkg) + then Cabal.description pkg + else Cabal.synopsis pkg, + E.homepage = thisHomepage, + E.license = Portage.convertLicense $ Cabal.license pkg, + E.slot = (E.slot E.ebuildTemplate) ++ (if hasLibs then "/${PV}" else ""), + E.my_pn = if any isUpper cabalPkgName then Just cabalPkgName else Nothing, + E.features = E.features E.ebuildTemplate + ++ (if hasLibs then ([ Portage.Lib + , Portage.Profile + , Portage.Haddock + , Portage.Hoogle + ] + ++ if cabalPkgName == "hscolour" + then [] + else [Portage.HsColour]) + else []) + ++ (if hasTests then [Portage.TestSuite] + else []) + } where + cabal_pn = Cabal.pkgName $ Cabal.package pkg + cabalPkgName = prettyShow cabal_pn + hasLibs = isJust (Cabal.library pkg) + hasTests = (not . null) (Cabal.testSuites pkg) + thisHomepage = if (ST.null $ Cabal.homepage pkg) + then E.homepage E.ebuildTemplate + else ST.fromShortText $ Cabal.homepage pkg + +-- | Map 'convertDependency' over ['Cabal.Dependency']. +convertDependencies :: O.Overlay -> Portage.Category -> [Cabal.Dependency] -> [Dependency] +convertDependencies overlay category = map (convertDependency overlay category) + +-- | Convert 'Cabal.Dependency' into 'Dependency'. +convertDependency :: O.Overlay -> Portage.Category -> Cabal.Dependency -> Dependency +convertDependency overlay category (Cabal.Dependency pname versionRange _lib) + = 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 = DependAtom (Atom pn dr (DAttr AnySlot [])) + p_v v = fromCabalVersion v + + convert :: Cabal.VersionRange -> Dependency + convert = Cabal.cataVersionRange alg . Cabal.normaliseVersionRange + where + alg (ThisVersionF v) = mk_p $ DExact $ p_v v + alg (LaterVersionF v) = mk_p $ DRange (StrictLB $ p_v v) InfinityB + alg (EarlierVersionF v) = mk_p $ DRange ZeroB $ StrictUB $ p_v v + alg (OrLaterVersionF v) = if v == Cabal.mkVersion [0] -- any version + then mk_p $ DRange ZeroB InfinityB + else mk_p $ DRange (NonstrictLB $ p_v v) + InfinityB + alg (OrEarlierVersionF v) = mk_p $ DRange ZeroB $ NonstrictUB $ p_v v + alg (MajorBoundVersionF v) = mk_p $ DRange (NonstrictLB $ p_v v) + $ StrictUB $ p_v $ Cabal.majorUpperBound v + alg (UnionVersionRangesF v1 v2) = DependAnyOf [v1, v2] + alg (IntersectVersionRangesF v1 v2) = DependAllOf [v1, v2] diff --git a/src/Error.hs b/src/Error.hs new file mode 100644 --- /dev/null +++ b/src/Error.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Error (HackPortError(..), throwEx, catchEx, hackPortShowError) where + +import Data.Typeable +import Control.Exception.Extensible as EE + +-- | Type holding all of the 'HackPortError' constructors. +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 + , Eq -- ^ needed for spec test-suite + ) + +instance Exception HackPortError where + +-- | Throw a 'HackPortError'. +throwEx :: HackPortError -> IO a +throwEx = EE.throw + +-- | Catch a 'HackPortError'. +catchEx :: IO a -> (HackPortError -> IO a) -> IO a +catchEx = EE.catch + +-- | Show the error string for a given 'HackPortError'. +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 repository's location. Either set a repository 'haskell' in '/etc/portage/repos.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' " + NoOverlay -> "Unable to find a repository 'haskell'. Consider defining it in '/etc/portage/repos.conf' and verify '~/.hackport/repositories' (in overlay_list) 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/src/HackPort/GlobalFlags.hs b/src/HackPort/GlobalFlags.hs new file mode 100644 --- /dev/null +++ b/src/HackPort/GlobalFlags.hs @@ -0,0 +1,51 @@ +module HackPort.GlobalFlags + ( GlobalFlags(..) + , defaultGlobalFlags + , withHackPortContext + ) where + +import qualified Distribution.Verbosity as DV +import qualified Distribution.Simple.Setup as DSS +import qualified Distribution.Client.Config as DCC +import qualified Distribution.Client.GlobalFlags as DCG +import qualified Distribution.Client.Types as DCT +import qualified Distribution.Utils.NubList as DUN + +import qualified Network.URI as NU + +import System.FilePath (()) + +import qualified Overlays + +-- | Type containing global flags. +data GlobalFlags = + GlobalFlags { globalVersion :: DSS.Flag Bool + , globalNumericVersion :: DSS.Flag Bool + , globalPathToOverlay :: DSS.Flag (Maybe FilePath) + , globalPathToPortage :: DSS.Flag (Maybe FilePath) + } + +-- | Default 'GlobalFlags'. +defaultGlobalFlags :: GlobalFlags +defaultGlobalFlags = + GlobalFlags { globalVersion = DSS.Flag False + , globalNumericVersion = DSS.Flag False + , globalPathToOverlay = DSS.Flag Nothing + , globalPathToPortage = DSS.Flag Nothing + } + +-- | Default remote repository. Defaults to [hackage](hackage.haskell.org). +defaultRemoteRepo :: DCT.RemoteRepo +defaultRemoteRepo = DCC.addInfoForKnownRepos $ (DCT.emptyRemoteRepo (DCT.RepoName name)) { DCT.remoteRepoURI = uri } + where + Just uri = NU.parseURI "https://hackage.haskell.org/" + name = "hackage.haskell.org" + +withHackPortContext :: DV.Verbosity -> GlobalFlags -> (DCG.RepoContext -> IO a) -> IO a +withHackPortContext verbosity global_flags callback = do + overlayPath <- Overlays.getOverlayPath verbosity (DSS.fromFlag $ globalPathToOverlay global_flags) + let flags = DCG.defaultGlobalFlags { + DCG.globalRemoteRepos = DUN.toNubList [defaultRemoteRepo] + , DCG.globalCacheDir = DSS.Flag $ overlayPath ".hackport" + } + DCG.withRepoContext verbosity flags callback diff --git a/src/Merge.hs b/src/Merge.hs new file mode 100644 --- /dev/null +++ b/src/Merge.hs @@ -0,0 +1,525 @@ +{-| +Module : Merge +License : GPL-3+ +Maintainer : haskell@gentoo.org + +Core functionality of the @merge@ command of @HackPort@. +-} +module Merge + ( merge + , mergeGenericPackageDescription + ) where + +import Control.Monad +import Control.Exception +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Function (on) +import qualified Data.Map.Strict as Map +import Data.Maybe +import qualified Data.List as L +import qualified Data.Set as S +import qualified Data.Time.Clock as TC + +-- cabal +import qualified Distribution.Package as Cabal +import qualified Distribution.Version as Cabal +import qualified Distribution.PackageDescription as Cabal +import qualified Distribution.PackageDescription.PrettyPrint as Cabal (showPackageDescription) +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 + +-- cabal-install +import Distribution.Client.IndexUtils ( getSourcePackages ) +import qualified Distribution.Client.GlobalFlags as CabalInstall +import Distribution.Client.Types +-- others +import Control.Parallel.Strategies +import qualified Data.List.Split as DLS +import System.Directory ( getCurrentDirectory + , setCurrentDirectory + , createDirectoryIfMissing + , doesFileExist + , listDirectory + ) +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 qualified Portage.Cabal as Portage +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.Use as Portage + +import qualified Portage.GHCCore as GHCCore + +import qualified Merge.Dependencies as Merge +import qualified Merge.Utils as Merge + +{- +Requested features: + * Add files to git? +-} + +-- | Call @diff@ between two ebuilds. +diffEbuilds :: FilePath -> Portage.PackageId -> Portage.PackageId -> IO () +diffEbuilds fp a b = do _ <- system $ "diff -u --color=auto " + ++ fp Portage.packageIdToFilePath a ++ " " + ++ fp Portage.packageIdToFilePath b + exitSuccess + +-- | 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 :: [UnresolvedSourcePackage] -> Maybe Cabal.Version -> Maybe UnresolvedSourcePackage +resolveVersion avails Nothing = Just $ L.maximumBy (comparing (Cabal.pkgVersion . CabalInstall.srcpkgPackageId)) avails +resolveVersion avails (Just ver) = listToMaybe (filter match avails) + where + match avail = ver == Cabal.pkgVersion (CabalInstall.srcpkgPackageId avail) + +-- | This function is executed by the @merge@ command of @HackPort@. +-- Its functionality is as follows: +-- +-- 1. Feed user input to 'readPackageString' +-- 2. Look for a matching package on the @hackage@ database +-- 3. Run 'mergeGenericPackageDescription' with the supplied information +-- 4. Generate a coloured diff between the old and new ebuilds. +-- +-- Various information is printed in between these steps depending on the +-- 'Verbosity'. +merge :: Verbosity -> CabalInstall.RepoContext -> [String] -> FilePath -> Maybe String -> IO () +merge verbosity repoContext args overlayPath users_cabal_flags = do + (m_category, user_pName, m_version) <- + case Merge.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 user_pname_str = Cabal.unPackageName user_pName + + overlay <- Overlay.loadLazy overlayPath + -- portage_path <- Host.portage_dir `fmap` Host.getInfo + -- portage <- Overlay.loadLazy portage_path + index <- fmap packageIndex $ getSourcePackages verbosity repoContext + + -- find all packages that maches the user specified package name + availablePkgs <- + case map snd (CabalInstall.searchByName index user_pname_str) of + [] -> throwEx (PackageNotFound user_pname_str) + [pkg] -> return pkg + pkgs -> do let cabal_pkg_to_pn pkg = Cabal.unPackageName $ Cabal.pkgName (CabalInstall.srcpkgPackageId pkg) + 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 (prettyShow . Cabal.pkgVersion . CabalInstall.srcpkgPackageId) 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 (prettyShow . CabalInstall.srcpkgPackageId $ 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 | CabalInstall.srcpkgPackageId avail == CabalInstall.srcpkgPackageId selectedPkg = "* " + | otherwise = "- " + info verbosity $ match_text ++ (prettyShow . CabalInstall.srcpkgPackageId $ avail) + + let cabal_pkgId = CabalInstall.srcpkgPackageId selectedPkg + norm_pkgName = Cabal.packageName (Portage.normalizeCabalPackageId cabal_pkgId) + cat <- maybe (Portage.resolveCategory verbosity overlay norm_pkgName) return m_category + mergeGenericPackageDescription verbosity overlayPath cat (CabalInstall.srcpkgDescription selectedPkg) True users_cabal_flags + + -- Maybe generate a diff + let pkgPath = overlayPath (Portage.unCategory cat) (Cabal.unPackageName norm_pkgName) + newPkgId = Portage.fromCabalPackageId cat cabal_pkgId + pkgDir <- listDirectory pkgPath + case Merge.getPreviousPackageId pkgDir newPkgId of + Just validPkg -> do info verbosity "Generating a diff..." + diffEbuilds overlayPath validPkg newPkgId + _ -> info verbosity "Nothing to diff!" + +-- used to be FlagAssignment in Cabal but now it's an opaque type +type CabalFlags = [(Cabal.FlagName, Bool)] + +-- | Generate an ebuild from a 'Cabal.GenericPackageDescription'. +mergeGenericPackageDescription :: Verbosity -> FilePath -> Portage.Category -> Cabal.GenericPackageDescription -> Bool -> Maybe String -> IO () +mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch users_cabal_flags = do + overlay <- Overlay.loadLazy overlayPath + let merged_cabal_pkg_name = Cabal.pkgName (Cabal.package (Cabal.packageDescription pkgGenericDesc)) + merged_PN = Portage.cabal_pn_to_PN merged_cabal_pkg_name + pkgdir = overlayPath Portage.unCategory cat merged_PN + existing_meta <- EM.findExistingMeta pkgdir + let requested_cabal_flags = Merge.first_just_of [users_cabal_flags, EM.cabal_flags existing_meta] + + -- accepts things, like: "cabal_flag:iuse_name", "+cabal_flag", "-cabal_flag" + read_fas :: Maybe String -> (CabalFlags, [(String, String)]) + read_fas Nothing = ([], []) + read_fas (Just user_fas_s) = (user_fas, user_renames) + where user_fas = [ (cf, b) + | ((cf, _), Just b) <- cn_in_mb + ] + user_renames = [ (cfn, ein) + | ((cabal_cfn, ein), Nothing) <- cn_in_mb + , let cfn = Cabal.unFlagName cabal_cfn + ] + cn_in_mb = map read_fa $ DLS.splitOn "," user_fas_s + read_fa :: String -> ((Cabal.FlagName, String), Maybe Bool) + read_fa [] = error $ "read_fas: empty flag?" + read_fa (op:flag) = + case op of + '+' -> (get_rename flag, Just True) + '-' -> (get_rename flag, Just False) + _ -> (get_rename (op:flag), Nothing) + where get_rename :: String -> (Cabal.FlagName, String) + get_rename s = + case DLS.splitOn ":" s of + [cabal_flag_name] -> (Cabal.mkFlagName cabal_flag_name, cabal_flag_name) + [cabal_flag_name, iuse_name] -> (Cabal.mkFlagName cabal_flag_name, iuse_name) + _ -> error $ "get_rename: too many components" ++ show (s) + + (user_specified_fas, cf_to_iuse_rename) = read_fas requested_cabal_flags + + debug verbosity "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 + cn = prettyShow cat + in error $ unlines [ "mergeGenericPackageDescription: failed to find suitable GHC for " ++ pn + , " You can try to merge the package manually:" + , " $ cabal unpack " ++ pn + , " $ cd " ++ pn ++ "*/" + , " # fix " ++ pn ++ ".cabal" + , " $ hackport make-ebuild " ++ cn ++ " " ++ pn ++ ".cabal" + ] + + let (accepted_deps, skipped_deps) = Portage.partition_depends ghc_packages merged_cabal_pkg_name + (Merge.exeAndLibDeps pkgDesc0) + + pkgDesc = Merge.RetroPackageDescription pkgDesc0 accepted_deps + cabal_flag_descs = Cabal.genPackageFlags pkgGenericDesc + all_flags = map Cabal.flagName cabal_flag_descs + make_fas :: [Cabal.PackageFlag] -> [CabalFlags] + make_fas [] = [[]] + make_fas (f:rest) = [ (fn, is_enabled) : fas + | fas <- make_fas rest + , let fn = Cabal.flagName f + users_choice = lookup fn user_specified_fas + , is_enabled <- maybe [False, True] + (\b -> [b]) + users_choice + ] + all_possible_flag_assignments :: [CabalFlags] + all_possible_flag_assignments = make_fas cabal_flag_descs + + pp_fa :: CabalFlags -> String + pp_fa fa = L.intercalate ", " [ (if b then '+' else '-') : f + | (cabal_f, b) <- fa + , let f = Cabal.unFlagName cabal_f + ] + + 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 + + -- key idea is to generate all possible list of flags + deps1 :: [(CabalFlags, Merge.EDep)] + deps1 = [ ( f `updateFa` Cabal.unFlagAssignment fr + , cabal_to_emerge_dep pkgDesc_filtered_bdeps) + | f <- all_possible_flag_assignments + , Right (pkgDesc1,fr) <- [GHCCore.finalizePD (Cabal.mkFlagAssignment f) + GHCCore.defaultComponentRequestedSpec + (GHCCore.dependencySatisfiable pix) + GHCCore.platform + compiler_info + [] + pkgGenericDesc] + -- drop circular deps and shipped deps + , let (ad, _sd) = Portage.partition_depends ghc_packages merged_cabal_pkg_name + (Merge.exeAndLibDeps pkgDesc1) + -- 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 [] _ = [] + updateFa (x:xs) y = case lookup (fst x) y of + -- TODO: when does this code get triggered? + Nothing -> x : updateFa xs y + Just y' -> (fst x,y') : updateFa xs y + -- then remove all flags that can't be changed + successfully_resolved_flag_assignments = map fst deps1 + common_fa = L.foldl1' L.intersect successfully_resolved_flag_assignments + common_flags = map fst common_fa + active_flags = all_flags L.\\ common_flags + active_flag_descs = filter (\x -> Cabal.flagName x `elem` active_flags) cabal_flag_descs + irresolvable_flag_assignments = all_possible_flag_assignments L.\\ successfully_resolved_flag_assignments + -- flags, not guarding any dependency variation, like: + -- if flag(foo) + -- ghc-options: -O2 + (irrelevant_flags, deps1') = L.foldl' drop_irrelevant ([], deps1) active_flags + where drop_irrelevant :: ([Cabal.FlagName], [(CabalFlags, Merge.EDep)]) -> Cabal.FlagName -> ([Cabal.FlagName], [(CabalFlags, Merge.EDep)]) + drop_irrelevant (ifs, ds) f = + case fenabled_ds' == fdisabled_ds' of + True -> (f:ifs, fenabled_ds') + False -> ( ifs, ds) + where (fenabled_ds', fdisabled_ds') = ( L.sort $ map drop_f fenabled_ds + , L.sort $ map drop_f fdisabled_ds + ) + drop_f :: (CabalFlags, Merge.EDep) -> (CabalFlags, Merge.EDep) + drop_f (fas, d) = (filter ((f /=) . fst) fas, d) + (fenabled_ds, fdisabled_ds) = L.partition is_fe ds + is_fe :: (CabalFlags, Merge.EDep) -> Bool + is_fe (fas, _d) = + case lookup f fas of + Just v -> v + -- should not happen + Nothing -> error $ unwords [ "ERROR: drop_irrelevant: searched for missing flag" + , show f + , "in assignment" + , show fas + ] + + -- and finally prettify all deps: + leave_only_dynamic_fa :: CabalFlags -> CabalFlags + leave_only_dynamic_fa fa = filter (\(fn, _) -> all (fn /=) irrelevant_flags) $ fa L.\\ common_fa + + -- build roughly balanced complete dependency tree instead of skewed one + bimerge :: [Merge.EDep] -> Merge.EDep + bimerge deps = case go deps of + [] -> mempty + [r] -> r + _ -> error "bimerge: something bad happened" + where go deps' = + case deps' of + (d1:d2:ds) -> go (mappend d1 d2 : go ds) + _ -> deps' + + tdeps :: Merge.EDep + tdeps = bimerge $ map set_fa_to_ed deps1' + + set_fa_to_ed :: (CabalFlags, Merge.EDep) -> Merge.EDep + set_fa_to_ed (fa, ed) = ed { Merge.rdep = liftFlags (leave_only_dynamic_fa fa) $ Merge.rdep ed + , Merge.dep = liftFlags (leave_only_dynamic_fa fa) $ Merge.dep ed + } + + liftFlags :: CabalFlags -> Portage.Dependency -> Portage.Dependency + liftFlags fs e = let k = foldr (\(y,b) x -> Portage.mkUseDependency (b, Portage.Use . cfn_to_iuse . Cabal.unFlagName $ y) . x) + id fs + in k e + + 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)) + + notice verbosity $ "Accepted depends: " ++ show (map prettyShow accepted_deps) + notice verbosity $ "Skipped depends: " ++ show (map prettyShow skipped_deps) + notice verbosity $ "Dead flags: " ++ show (map pp_fa irresolvable_flag_assignments) + notice verbosity $ "Dropped flags: " ++ show (map (Cabal.unFlagName.fst) common_fa) + notice verbosity $ "Active flags: " ++ show (map Cabal.unFlagName active_flags) + notice verbosity $ "Irrelevant flags: " ++ show (map Cabal.unFlagName irrelevant_flags) + -- mapM_ print tdeps + + forM_ ghc_packages $ + \name -> info verbosity $ "Excluded packages (comes with ghc): " ++ Cabal.unPackageName name + + 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.depend = Merge.dep tdeps} ) + . (\e -> e { E.depend_extra = S.toList $ Merge.dep_e tdeps } ) + . (\e -> e { E.rdepend = Merge.rdep tdeps} ) + . (\e -> e { E.rdepend_extra = S.toList $ Merge.rdep_e tdeps } ) + . (\e -> e { E.src_configure = build_configure_call $ + selected_flags (active_flags, user_specified_fas) } ) + . (\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) + + 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 @ebuild@ and @pkgcheck@ 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. +fetchDigestAndCheck :: Verbosity + -> FilePath -- ^ directory of ebuild + -> Portage.PackageId -- ^ newest ebuild + -> IO () +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 "pkgcheck scan..." + + (psEx,psOut,_) <- readCreateProcessWithExitCode (shell "pkgcheck scan --color True") "" + + 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 + oldDir <- getCurrentDirectory + bracket + (setCurrentDirectory newDir) + (\_ -> setCurrentDirectory oldDir) + (\_ -> action) + +-- | Write the ebuild (and sometimes a new @metadata.xml@) to its directory. +mergeEbuild :: Verbosity -> EM.EMeta -> FilePath -> E.EBuild -> [Cabal.PackageFlag] -> IO () +mergeEbuild verbosity existing_meta pkgdir ebuild flags = do + let edir = pkgdir + elocal = E.name ebuild ++"-"++ E.version ebuild <.> "ebuild" + epath = edir elocal + emeta = "metadata.xml" + mpath = edir emeta + yet_meta <- doesFileExist mpath + -- If there is an existing @metadata.xml@, read it in as a 'T.Text'. + -- Otherwise return 'T.empty'. We only use this once more to directly + -- compare to @default_meta@ before writing it. + current_meta <- if yet_meta + then T.readFile mpath + else return T.empty + -- Either create an object of the 'Portage.Metadata' type from a valid @current_meta@, + -- or supply a default minimal metadata object. Note the difference to @current_meta@: + -- @current_meta@ is of type 'T.Text', @current_meta'@ is of type 'Portage.Metadata'. + let current_meta' = fromMaybe Portage.makeMinimalMetadata + (Portage.pureMetadataFromFile current_meta) + -- 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 + $ Merge.metaFlags flags `Map.union` + Portage.metadataUseFlags current_meta' + -- Create a 'Map.Map' of USE flags with updated descriptions. + new_flags = Map.differenceWith (\new old -> if (new /= old) + then Just $ old ++ A.bold (" -> " ++ new) + else Nothing) + (Merge.metaFlags flags) + $ Portage.metadataUseFlags current_meta' + + createDirectoryIfMissing True edir + now <- TC.getCurrentTime + + 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) + ebuild' = ebuild { E.keywords = new_keywords + , E.license = new_license + } + s_ebuild' = E.showEBuild now 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` T.writeFile epath (T.pack s_ebuild') + + when (current_meta /= default_meta) $ do + 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/src/Merge/Dependencies.hs b/src/Merge/Dependencies.hs new file mode 100644 --- /dev/null +++ b/src/Merge/Dependencies.hs @@ -0,0 +1,583 @@ +{-| +Module : Merge.Dependencies +License : GPL-3+ +Maintainer : haskell@gentoo.org + +Merge a package from @hackage@ to an ebuild. +-} +{-# LANGUAGE CPP #-} +module Merge.Dependencies + ( EDep(..) + , RetroPackageDescription(..) + , exeAndLibDeps + , mkRetroPD + , resolveDependencies + ) where + +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 +import qualified Distribution.Compat.NonEmptySet as NES +import qualified Distribution.Package as Cabal +import qualified Distribution.PackageDescription as Cabal +import qualified Distribution.Version as Cabal +import qualified Distribution.Pretty as Cabal + +import qualified Distribution.Compiler as Cabal + +import qualified Portage.Cabal as Portage +import qualified Portage.Dependency as Portage +import qualified Portage.Dependency.Normalize as PN +import qualified Portage.Overlay as Portage +import qualified Portage.PackageId as Portage +import qualified Portage.Use as Portage +import qualified Portage.Tables 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 :: S.Set String, + dep :: Portage.Dependency, + dep_e :: S.Set String + } + 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, + buildDepends :: [Cabal.Dependency] + } deriving (Show) + +-- | Construct a 'RetroPackageDescription' using 'exeAndLibDeps' for the 'buildDepends'. +mkRetroPD :: Cabal.PackageDescription -> RetroPackageDescription +mkRetroPD pd = RetroPackageDescription { packageDescription = pd, buildDepends = exeAndLibDeps pd } + +-- | Extract only the build dependencies for libraries and executables for a given package. +exeAndLibDeps :: Cabal.PackageDescription -> [Cabal.Dependency] +exeAndLibDeps pkg = concatMap (Cabal.targetBuildDepends . Cabal.buildInfo) + (Cabal.executables pkg) + `L.union` + concatMap (Cabal.targetBuildDepends . Cabal.libBuildInfo) + (Cabal.allLibraries pkg) + +instance Semigroup EDep where + (EDep rdepA rdep_eA depA dep_eA) <> (EDep rdepB rdep_eB depB dep_eB) = EDep + { rdep = Portage.DependAllOf [rdepA, rdepB] + , rdep_e = rdep_eA `S.union` rdep_eB + , dep = Portage.DependAllOf [depA, depB] + , dep_e = dep_eA `S.union` dep_eB + } + +instance Monoid EDep where + mempty = EDep + { + rdep = Portage.empty_dependency, + rdep_e = S.empty, + dep = Portage.empty_dependency, + dep_e = S.empty + } +#if !(MIN_VERSION_base(4,11,0)) + (EDep rdepA rdep_eA depA dep_eA) `mappend` (EDep rdepB rdep_eB depB dep_eB) = EDep + { rdep = Portage.DependAllOf [rdepA, rdepB] + , rdep_e = rdep_eA `S.union` rdep_eB + , dep = Portage.DependAllOf [depA, depB] + , dep_e = dep_eA `S.union` dep_eB + } +#endif + +-- | Resolve package dependencies from a 'RetroPackageDescription' into an 'EDep'. +resolveDependencies :: Portage.Overlay -> RetroPackageDescription -> Cabal.CompilerInfo + -> [Cabal.PackageName] -> Cabal.PackageName + -> EDep +resolveDependencies overlay pkg compiler_info ghc_package_names merged_cabal_pkg_name = edeps + where + -- hasBuildableExes p = any (buildable . buildInfo) . executables $ p + treatAsLibrary :: Bool + treatAsLibrary = isJust (Cabal.library (packageDescription pkg)) + -- without slot business + raw_haskell_deps :: Portage.Dependency + raw_haskell_deps = PN.normalize_depend $ Portage.DependAllOf $ haskellDependencies overlay (buildDepends pkg) + test_deps :: Portage.Dependency + test_deps = Portage.mkUseDependency (True, Portage.Use "test") $ + Portage.DependAllOf $ + remove_raw_common $ + testDependencies overlay (packageDescription pkg) ghc_package_names merged_cabal_pkg_name + cabal_dep :: Portage.Dependency + cabal_dep = cabalDependency overlay (packageDescription pkg) compiler_info + ghc_dep :: Portage.Dependency + ghc_dep = compilerInfoToDependency compiler_info + extra_libs :: Portage.Dependency + extra_libs = Portage.DependAllOf $ findCLibs (packageDescription pkg) + pkg_config_libs :: [Portage.Dependency] + pkg_config_libs = pkgConfigDependencies overlay (packageDescription pkg) + pkg_config_tools :: Portage.Dependency + pkg_config_tools = Portage.DependAllOf $ if L.null pkg_config_libs + then [] + else [any_c_p "virtual" "pkgconfig"] + build_tools :: Portage.Dependency + build_tools = Portage.DependAllOf $ pkg_config_tools : legacyBuildToolsDependencies (packageDescription pkg) + ++ hackageBuildToolsDependencies overlay (packageDescription pkg) + + setup_deps :: Portage.Dependency + setup_deps = PN.normalize_depend $ Portage.DependAllOf $ + remove_raw_common $ + setupDependencies overlay (packageDescription pkg) ghc_package_names merged_cabal_pkg_name + + edeps :: EDep + edeps + | treatAsLibrary = mempty + { + dep = Portage.DependAllOf + [ cabal_dep + , setup_deps + , build_tools + , test_deps + ], + dep_e = S.singleton "${RDEPEND}", + rdep = Portage.DependAllOf + [ Portage.set_build_slot ghc_dep + , Portage.set_build_slot $ add_profile $ raw_haskell_deps + , extra_libs + , Portage.DependAllOf pkg_config_libs + ] + } + | otherwise = mempty + { + dep = Portage.DependAllOf + [ cabal_dep + , setup_deps + , build_tools + , test_deps + ], + dep_e = S.singleton "${RDEPEND}", + rdep = Portage.DependAllOf + [ Portage.set_build_slot ghc_dep + , Portage.set_build_slot $ raw_haskell_deps + , extra_libs + , Portage.DependAllOf pkg_config_libs + ] + } + 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 + +--------------------------------------------------------------- +-- Custom-setup dependencies +-- TODO: move partitioning part to Merge:mergeGenericPackageDescription +--------------------------------------------------------------- + +setupDependencies :: Portage.Overlay -> Cabal.PackageDescription -> [Cabal.PackageName] -> Cabal.PackageName -> [Portage.Dependency] +setupDependencies overlay pkg ghc_package_names merged_cabal_pkg_name = deps + where cabalDeps = maybe [] id $ Cabal.setupDepends `fmap` Cabal.setupBuildInfo pkg + cabalDeps' = fst $ Portage.partition_depends ghc_package_names merged_cabal_pkg_name cabalDeps + deps = C2E.convertDependencies overlay (Portage.Category "dev-haskell") cabalDeps' + +--------------------------------------------------------------- +-- Test-suite dependencies +-- TODO: move partitioning part to Merge:mergeGenericPackageDescription +--------------------------------------------------------------- + +testDependencies :: Portage.Overlay -> Cabal.PackageDescription -> [Cabal.PackageName] -> Cabal.PackageName -> [Portage.Dependency] +testDependencies overlay pkg ghc_package_names merged_cabal_pkg_name = deps + where cabalDeps = concatMap (Cabal.targetBuildDepends . Cabal.testBuildInfo) (Cabal.testSuites pkg) + cabalDeps' = fst $ Portage.partition_depends ghc_package_names merged_cabal_pkg_name cabalDeps + deps = C2E.convertDependencies overlay (Portage.Category "dev-haskell") cabalDeps' + +--------------------------------------------------------------- +-- Haskell packages +--------------------------------------------------------------- + +haskellDependencies :: Portage.Overlay -> [Cabal.Dependency] {- PackageDescription -} -> [Portage.Dependency] +haskellDependencies overlay 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 -> Cabal.PackageDescription -> Cabal.CompilerInfo -> Portage.Dependency +cabalDependency overlay pkg ~(Cabal.CompilerInfo { + Cabal.compilerInfoId = + Cabal.CompilerId Cabal.GHC cabal_version + }) = + C2E.convertDependency overlay + (Portage.Category "dev-haskell") + (Cabal.Dependency (Cabal.mkPackageName "Cabal") + finalCabalDep (NES.singleton Cabal.defaultLibName)) + where + versionNumbers = Cabal.versionNumbers cabal_version + userCabalVersion = Cabal.orLaterVersion $ Cabal.mkVersion + $ Cabal.cabalSpecToVersionDigits $ Cabal.specVersion pkg + shippedCabalVersion = GHCCore.cabalFromGHC versionNumbers + shippedCabalDep = maybe Cabal.anyVersion Cabal.orLaterVersion shippedCabalVersion + finalCabalDep = Cabal.simplifyVersionRange + (Cabal.intersectVersionRanges + userCabalVersion + shippedCabalDep) + +--------------------------------------------------------------- +-- GHC Dependency +--------------------------------------------------------------- + +compilerInfoToDependency :: Cabal.CompilerInfo -> Portage.Dependency +compilerInfoToDependency ~(Cabal.CompilerInfo { + Cabal.compilerInfoId = + Cabal.CompilerId Cabal.GHC cabal_version}) = + at_least_c_p_v "dev-lang" "ghc" (Cabal.versionNumbers cabal_version) + +--------------------------------------------------------------- +-- C Libraries +--------------------------------------------------------------- + +findCLibs :: Cabal.PackageDescription -> [Portage.Dependency] +findCLibs (Cabal.PackageDescription { Cabal.library = lib, Cabal.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 = concatMap (Cabal.extraLibs . Cabal.libBuildInfo) $ maybe [] return lib + exeE = concatMap Cabal.extraLibs (filter Cabal.buildable (map Cabal.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.DependAtom $ + 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.DependAtom $ + 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" [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 (Portage.Use "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") + , ("alut", any_c_p "media-libs" "freealut") + , ("openal", any_c_p "media-libs" "openal") + , ("iw", any_c_p "net-wireless" "wireless-tools") + , ("attr", any_c_p "sys-apps" "attr") + , ("ncurses", any_c_p "sys-libs" "ncurses") + , ("panel", any_c_p "sys-libs" "ncurses") + , ("nanomsg", any_c_p "dev-libs" "nanomsg") + , ("pgf", any_c_p "media-libs" "libpgf") + , ("ssh2", any_c_p "net-libs" "libssh2") + , ("dl", any_c_p "virtual" "libc") + , ("glfw", any_c_p "media-libs" "glfw") + , ("nettle", any_c_p "dev-libs" "nettle") + , ("Xpm", any_c_p "x11-libs" "libXpm") + , ("Xss", any_c_p "x11-libs" "libXScrnSaver") + , ("tag_c", any_c_p "media-libs" "taglib") + , ("magic", any_c_p "sys-apps" "file") + , ("crypt", any_c_p_s_u "virtual" "libcrypt" Portage.AnyBuildTimeSlot []) + , ("Xrender", any_c_p "x11-libs" "libXrender") + , ("Xcursor", any_c_p "x11-libs" "libXcursor") + , ("Xinerama", any_c_p "x11-libs" "libXinerama") + , ("wayland-client", any_c_p "dev-libs" "wayland") + , ("wayland-cursor", any_c_p "dev-libs" "wayland") + , ("wayland-server", any_c_p "dev-libs" "wayland") + , ("wayland-egl", any_c_p_s_u "media-libs" "mesa" Portage.AnySlot [Portage.mkUse (Portage.Use "wayland")]) + , ("xkbcommon", any_c_p "x11-libs" "libxkbcommon") + , ("SDL_gfx", any_c_p "media-libs" "sdl-gfx") + , ("SDL_image", any_c_p "media-libs" "sdl-image") + , ("SDL_ttf", any_c_p "media-libs" "sdl-ttf") + , ("odbc", any_c_p "dev-db" "unixODBC") + , ("uuid", any_c_p "sys-apps" "util-linux") + , ("notify", any_c_p "x11-libs" "libnotify") + , ("SDL2", any_c_p " media-libs" "libsdl2") + , ("SDL2_mixer", any_c_p "media-libs" "sdl2-mixer") + , ("blas", any_c_p "virtual" "blas") + , ("lapack", any_c_p "virtual" "lapack") + ] + +--------------------------------------------------------------- +-- Build Tools (legacy, a list of well-known tools) +--------------------------------------------------------------- + +legacyBuildToolsDependencies :: Cabal.PackageDescription -> [Portage.Dependency] +legacyBuildToolsDependencies (Cabal.PackageDescription { Cabal.library = lib, Cabal.executables = exes }) = L.nub $ + [ case pkg of + Just p -> p + Nothing -> trace ("WARNING: Unknown build tool '" ++ Cabal.prettyShow exe ++ "'. Check the generated ebuild.") + (any_c_p "unknown-build-tool" pn) + | exe@(Cabal.LegacyExeDependency pn _range) <- cabalDeps + , pkg <- return (lookup pn buildToolsTable) + ] + where + cabalDeps = filter notProvided $ depL ++ depE + depL = concatMap (Cabal.buildTools . Cabal.libBuildInfo) $ maybe [] return lib + depE = concatMap Cabal.buildTools (filter Cabal.buildable (map Cabal.buildInfo exes)) + notProvided (Cabal.LegacyExeDependency 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", any_c_p "dev-haskell" "cabal-install") + , ("cabal-install", any_c_p "dev-haskell" "cabal-install") + , ("cpphs", any_c_p "dev-haskell" "cpphs") + , ("ghc", any_c_p "dev-lang" "ghc") + , ("gtk2hsTypeGen", any_c_p "dev-haskell" "gtk2hs-buildtools") + , ("gtk2hsHookGenerator", any_c_p "dev-haskell" "gtk2hs-buildtools") + , ("gtk2hsC2hs", any_c_p "dev-haskell" "gtk2hs-buildtools") + , ("hsb2hs", any_c_p "dev-haskell" "hsb2hs") + , ("hsx2hs", any_c_p "dev-haskell" "hsx2hs") + , ("llvm-config", any_c_p "sys-devel" "llvm") + ] + +-- tools that are provided by ghc or some other existing program +-- so we do not need dependencies on them +buildToolsProvided :: [String] +buildToolsProvided = ["hsc2hs"] + +--------------------------------------------------------------- +-- Hackage Build Tools (behind `build-tool-depends`) +--------------------------------------------------------------- + +hackageBuildToolsDependencies :: Portage.Overlay -> Cabal.PackageDescription -> [Portage.Dependency] +hackageBuildToolsDependencies overlay (Cabal.PackageDescription { Cabal.library = lib, Cabal.executables = exes }) = + haskellDependencies overlay $ L.nub $ + [ Cabal.Dependency pn versionRange $ NES.singleton Cabal.defaultLibName + | Cabal.ExeDependency pn _component versionRange <- cabalDeps + ] + where + cabalDeps = depL ++ depE + depL = concatMap (Cabal.buildToolDepends . Cabal.libBuildInfo) $ maybe [] return lib + depE = concatMap Cabal.buildToolDepends (filter Cabal.buildable (map Cabal.buildInfo exes)) + +--------------------------------------------------------------- +-- pkg-config +--------------------------------------------------------------- + +pkgConfigDependencies :: Portage.Overlay -> Cabal.PackageDescription -> [Portage.Dependency] +pkgConfigDependencies overlay (Cabal.PackageDescription { Cabal.library = lib, Cabal.executables = exes }) = L.nub $ resolvePkgConfigs overlay cabalDeps + where + cabalDeps = depL ++ depE + depL = concatMap (Cabal.pkgconfigDepends . Cabal.libBuildInfo) $ maybe [] return lib + depE = concatMap Cabal.pkgconfigDepends (filter Cabal.buildable (map Cabal.buildInfo exes)) + +resolvePkgConfigs :: Portage.Overlay -> [Cabal.PkgconfigDependency] -> [Portage.Dependency] +resolvePkgConfigs overlay cdeps = + [ case resolvePkgConfig overlay pkg of + Just d -> d + Nothing -> trace ("WARNING: Could not resolve pkg-config: " ++ Cabal.prettyShow pkg ++ ". Check generated ebuild.") + (any_c_p "unknown-pkg-config" pn) + | pkg@(Cabal.PkgconfigDependency cabal_pn _range) <- cdeps + , let pn = Cabal.unPkgconfigName cabal_pn + ] + +resolvePkgConfig :: Portage.Overlay -> Cabal.PkgconfigDependency -> Maybe Portage.Dependency +resolvePkgConfig _overlay (Cabal.PkgconfigDependency cabal_pn _cabalVersion) = do + (cat,portname, slot) <- lookup (Cabal.unPkgconfigName cabal_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)) + ,("atk", ("dev-libs", "atk", 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")) + ,("gobject-introspection-1.0", ("dev-libs", "gobject-introspection", + Portage.AnySlot)) + ,("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-3.0", ("x11-libs", "gtk+", Portage.GivenSlot "3")) + ,("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")) + + ,("gtk+-3.0", ("x11-libs", "gtk+", Portage.GivenSlot "3")) + ,("webkitgtk-3.0", ("net-libs", "webkit-gtk", Portage.GivenSlot "3")) + + ,("cairo", ("x11-libs", "cairo", Portage.AnySlot)) -- need [svg] for dev-haskell/cairo + ,("cairo-gobject", ("x11-libs", "cairo", Portage.AnySlot)) -- need [glib] 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)) + + ,("javascriptcoregtk-4.0", ("net-libs", "webkit-gtk", Portage.GivenSlot "4")) + ,("webkit2gtk-4.0", ("net-libs", "webkit-gtk", Portage.GivenSlot "4")) + + ,("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)) + ,("libsoup-2.4", ("net-libs", "libsoup", Portage.GivenSlot "2.4")) + ,("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")) + ,("gtksourceview-3.0", ("x11-libs", "gtksourceview", Portage.GivenSlot "3.0")) + + ,("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)) + ,("ncurses", ("sys-libs", "ncurses", Portage.AnySlot)) + ,("ncursesw", ("sys-libs", "ncurses", Portage.AnySlot)) + ,("panel", ("sys-libs", "ncurses", Portage.AnySlot)) + ,("panelw", ("sys-libs", "ncurses", Portage.AnySlot)) + ,("libssh2", ("net-libs", "libssh2", Portage.AnySlot)) + ,("SDL_image", ("media-libs", "sdl-image", Portage.AnySlot)) + ,("libzmq", ("net-libs", "zeromq", Portage.AnySlot)) + ,("taglib_c", ("media-libs", "taglib", Portage.AnySlot)) + ,("libcurl", ("net-misc", "curl", Portage.AnySlot)) + ,("libpq", ("dev-db", "postgresql", Portage.AnySlot)) + ,("poppler-glib", ("app-text", "poppler", Portage.AnySlot)) + ,("gsl", ("sci-libs", "gsl", Portage.AnySlot)) + ,("libvirt", ("app-emulation", "libvirt", Portage.AnySlot)) + + ,("Qt5Core", ("dev-qt", "qtcore", Portage.GivenSlot "5")) + ,("Qt5Gui", ("dev-qt", "qtgui", Portage.GivenSlot "5")) + ,("Qt5Qml", ("dev-qt", "qtdeclarative", Portage.GivenSlot "5")) + ,("Qt5Quick", ("dev-qt", "qtdeclarative", Portage.GivenSlot "5")) + ,("Qt5Widgets", ("dev-qt", "qtwidgets", Portage.GivenSlot "5")) + + ,("sdl2", ("media-libs", "libsdl2", Portage.AnySlot)) + ,("SDL2_image", ("media-libs", "sdl2-image", Portage.AnySlot)) + ,("SDL2_mixer", ("media-libs", "sdl2-mixer", Portage.AnySlot)) + ,("zlib", ("sys-libs", "zlib", Portage.AnySlot)) + ] diff --git a/src/Merge/Utils.hs b/src/Merge/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Merge/Utils.hs @@ -0,0 +1,212 @@ +{-| +Module : Merge.Utils +License : GPL-3+ +Maintainer : haskell@gentoo.org + +Internal helper functions for "Merge". +-} +module Merge.Utils + ( readPackageString + , getPreviousPackageId + , first_just_of + , drop_prefix + , squash_debug + , convert_underscores + , mangle_iuse + , to_unstable + , metaFlags + , dropIfUseExpands + -- hspec exports + , dropIfUseExpand + ) where + +import qualified Control.Applicative as A +import qualified Control.Monad as M +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 + +import qualified Distribution.Package as Cabal +import qualified Distribution.PackageDescription as Cabal + +-- | Parse a ['String'] as a valid package string. E.g. @category\/name-1.0.0@. +-- Return 'HackPortError' if the string to parse is invalid. +-- +-- When the ['String'] is valid: +-- +-- >>> readPackageString ["dev-haskell/packagename1-1.0.0"] +-- Right (Just (Category {unCategory = "dev-haskell"}),PackageName "packagename1",Just (Version {versionNumber = [1,0,0], versionChar = Nothing, versionSuffix = [], versionRevision = 0})) +-- +-- When the ['String'] is empty: +-- +-- >>> readPackageString [] +-- Left ... +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 + Right v@(_,_,Nothing) -> return v + -- we only allow versions we can convert into cabal versions + Right v@(_,_,Just (Portage.Version _ Nothing [] 0)) -> return v + Left e -> Left $ ArgumentError $ "Could not parse [category/]package[-version]: " + ++ packageString ++ "\nParsec error: " ++ e + _ -> Left $ ArgumentError $ "Could not parse [category/]package[-version]: " + ++ packageString + +-- | Maybe return a 'Portage.PackageId' of the next highest version for a given +-- package, relative to the provided 'Portage.PackageId'. +-- +-- For example: +-- +-- >>> let ebuildDir = ["foo-bar2-3.0.1.ebuild","metadata.xml"] +-- >>> let newPkgId = Portage.PackageId (Portage.PackageName (Portage.Category "dev-haskell") (Cabal.mkPackageName "foo-bar2")) (Portage.Version [3,0,2] Nothing [] 0 ) +-- +-- >>> getPreviousPackageId ebuildDir newPkgId +-- Just (PackageId {packageId = PackageName {category = Category {unCategory = "dev-haskell"}, cabalPkgName = PackageName "foo-bar2"}, pkgVersion = Version {versionNumber = [3,0,1], versionChar = Nothing, versionSuffix = [], versionRevision = 0}}) +getPreviousPackageId :: [FilePath] -- ^ list of ebuilds for given package + -> Portage.PackageId -- ^ new PackageId + -> Maybe Portage.PackageId -- ^ maybe PackageId of previous version +getPreviousPackageId pkgDir newPkgId = do + let pkgIds = reverse + . L.sortOn (Portage.pkgVersion) + . filter ( filter (\fp -> SF.takeExtension fp == ".ebuild") pkgDir + case pkgIds of + x:_ -> Just x + _ -> Nothing + +-- | Alias for 'msum'. +-- +-- prop> \a -> first_just_of a == M.msum a +first_just_of :: [Maybe a] -> Maybe a +first_just_of = M.msum + +-- | Remove @with@ or @use@ prefixes from flag names. +-- +-- >>> drop_prefix "with_conduit" +-- "conduit" +-- >>> drop_prefix "use-https" +-- "https" +-- >>> drop_prefix "no_examples" +-- "no_examples" +drop_prefix :: String -> String +drop_prefix x = + let prefixes = ["with","use"] + separators = ["-","_"] + combinations = A.liftA2 (++) prefixes separators + in case catMaybes (A.liftA2 L.stripPrefix combinations [x]) of + [z] -> z + _ -> x + +-- | Squash debug-related @USE@ flags under the @debug@ global +-- @USE@ flag. +-- +-- >>> squash_debug "use-debug-foo" +-- "debug" +-- >>> squash_debug "foo-bar" +-- "foo-bar" +squash_debug :: String -> String +squash_debug flag = if "debug" `L.isInfixOf` (C.toLower <$> flag) + then "debug" + else flag + +-- | Gentoo allows underscore ('_') names in @IUSE@ only for +-- @USE_EXPAND@ values. If it's not a user-specified rename mangle +-- it into a hyphen ('-'). +-- +-- >>> convert_underscores "remove_my_underscores" +-- "remove-my-underscores" +convert_underscores :: String -> String +convert_underscores = map f + where f '_' = '-' + f c = c + +-- | Perform all @IUSE@ mangling. +-- +-- >>> mangle_iuse "use_foo-bar_debug" +-- "debug" +-- >>> mangle_iuse "with-bar_quux" +-- "bar-quux" +mangle_iuse :: String -> String +mangle_iuse = squash_debug . drop_prefix . convert_underscores + +-- | Convert all stable keywords to testing (unstable) keywords. +-- Preserve arch masks (-). +-- +-- >>> to_unstable "amd64" +-- "~amd64" +-- >>> to_unstable "~amd64" +-- "~amd64" +-- >>> to_unstable "-amd64" +-- "-amd64" +to_unstable :: String -> String +to_unstable kw = + case kw of + '~':_ -> kw + '-':_ -> kw + _ -> '~':kw + +-- | Generate a 'Map.Map' of 'Cabal.PackageFlag' names and their descriptions. +-- +-- For example, if we construct a singleton list holding a 'Cabal.PackageFlag' with +-- 'Cabal.FlagName' @foo@ and 'Cabal.FlagDescription' @bar@, we should get +-- a 'Map.Map' containing those values: +-- +-- >>> let flags = [(Cabal.emptyFlag (Cabal.mkFlagName "foo")) {Cabal.flagDescription = "bar"}] +-- >>> metaFlags flags +-- 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 or (A.liftA2 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/src/Overlays.hs b/src/Overlays.hs new file mode 100644 --- /dev/null +++ b/src/Overlays.hs @@ -0,0 +1,69 @@ +module Overlays + ( getOverlayPath + ) where + +import Control.Monad +import Data.List (nub, inits) +import Data.Maybe (maybeToList, listToMaybe, isJust, fromJust) +import qualified System.Directory as SD +import System.FilePath ((), splitPath, joinPath) + +import Error +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 <- SD.doesDirectoryExist (x ".hackport") + 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 <- SD.getCurrentDirectory + let lookIn = map joinPath . reverse . inits . splitPath $ curDir + fmap listToMaybe (filterM probe lookIn) + + where + probe dir = SD.doesDirectoryExist (dir "dev-haskell") diff --git a/src/Portage/Cabal.hs b/src/Portage/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/Portage/Cabal.hs @@ -0,0 +1,79 @@ +{-| +Module : Portage.Cabal +License : GPL-3+ +Maintainer : haskell@gentoo.org + +Utilities to extract and manipulate information from a package's @.cabal@ file, +such as its license and dependencies. +-} +module Portage.Cabal + ( convertLicense + , partition_depends + ) where + +import qualified Data.List as L + +import qualified Distribution.License as Cabal +import qualified Distribution.SPDX as SPDX +import qualified Distribution.Package as Cabal +import qualified Distribution.Pretty as Cabal + +-- | Convert the Cabal 'SPDX.License' into the Gentoo format, as a 'String'. +-- +-- Generally, if the license is one of the common free-software or +-- open-source licenses, 'convertLicense' should return the license +-- as a 'Right' 'String': +-- +-- >>> convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.GPL_3_0_or_later) +-- Right "GPL-3+" +-- +-- >>> convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.GPL_3_0_only) +-- Right "GPL-3" +-- +-- If it is a more obscure license, this should alert the user by returning +-- a 'Left' 'String': +-- +-- >>> convertLicense (SPDX.License $ SPDX.simpleLicenseExpression SPDX.EUPL_1_1) +-- Left ... +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 + Just "3" -> "3" + Just "3.0" -> "3+" + _ -> "3" -- almost certainly version 3 + 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 + Just "2" -> "2" + -- Cabal can't handle 2.0+ properly + Just "2.0" -> "2" + Just "3" -> "3" + Just "3.0" -> "3+" + _ -> "2.1" -- probably version 2.1 + Cabal.BSD2 -> Right "BSD-2" + 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.prettyShow mv -- probably version 1.1 + Cabal.ISC -> Right "ISC" + Cabal.MPL v -> Right $ "MPL-" ++ Cabal.prettyShow v -- probably version 1.0 + -- 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 "(Other) Please look at license file of package and pick it manually." + Cabal.UnspecifiedLicense -> Left "(Unspecified) Please look at license file of package and pick it manually." + +-- | Extract only the dependencies which are not bundled with @GHC@. +partition_depends :: [Cabal.PackageName] -> Cabal.PackageName -> [Cabal.Dependency] -> ([Cabal.Dependency], [Cabal.Dependency]) +partition_depends ghc_package_names merged_cabal_pkg_name = L.partition (not . is_internal_depend) + where is_internal_depend (Cabal.Dependency pn _vr _lib) = is_itself || is_ghc_package + where is_itself = pn == merged_cabal_pkg_name + is_ghc_package = pn `elem` ghc_package_names diff --git a/src/Portage/Dependency.hs b/src/Portage/Dependency.hs new file mode 100644 --- /dev/null +++ b/src/Portage/Dependency.hs @@ -0,0 +1,10 @@ +module Portage.Dependency + ( + module Portage.Dependency.Builder + , module Portage.Dependency.Print + , module Portage.Dependency.Types + ) where + +import Portage.Dependency.Builder +import Portage.Dependency.Print +import Portage.Dependency.Types diff --git a/src/Portage/Dependency/Builder.hs b/src/Portage/Dependency/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Portage/Dependency/Builder.hs @@ -0,0 +1,32 @@ +{- | Basic helpers to build depend structures -} +module Portage.Dependency.Builder + ( + empty_dependency + , addDepUseFlag + , setSlotDep + , mkUseDependency + , overAtom + ) where + +import Portage.Dependency.Types +import Portage.Use + +-- TODO: remove it and switch to 'SatisfiedDepend' instead +empty_dependency :: Dependency +empty_dependency = DependAllOf [] + +addDepUseFlag :: UseFlag -> Dependency -> Dependency +addDepUseFlag n = overAtom (\(Atom pn dr (DAttr s u)) -> Atom pn dr (DAttr s (n:u))) + +setSlotDep :: SlotDepend -> Dependency -> Dependency +setSlotDep n = overAtom (\(Atom pn dr (DAttr _s u)) -> Atom pn dr (DAttr n u)) + +mkUseDependency :: (Bool, Use) -> Dependency -> Dependency +mkUseDependency (b, u) 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 +overAtom f (DependAnyOf d) = DependAnyOf $ map (overAtom f) d +overAtom f (DependIfUse u d1 d2) = DependIfUse u (f `overAtom` d1) (f `overAtom` d2) +overAtom f (DependAtom a) = DependAtom (f a) diff --git a/src/Portage/Dependency/Normalize.hs b/src/Portage/Dependency/Normalize.hs new file mode 100644 --- /dev/null +++ b/src/Portage/Dependency/Normalize.hs @@ -0,0 +1,398 @@ +module Portage.Dependency.Normalize + ( + normalize_depend + ) where + +import qualified Control.Arrow as A +import Control.Monad +import qualified Data.List as L +import qualified Data.Set as S +import Data.Maybe + +import Portage.Dependency.Builder +import Portage.Dependency.Types +import Portage.Use + +import Debug.Trace + +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) + +stabilize_pass :: (Dependency -> Dependency) -> Dependency -> Dependency +stabilize_pass pass d + | d == d' = d' + | otherwise = go d' + where go = stabilize_pass pass + d' = pass d + +-- remove one layer of redundancy +normalization_step :: Int -> Dependency -> Dependency +normalization_step level = + id + . tp "PC2" (stabilize_pass (tp "PC2 step" propagate_context)) + . tp "F3" (stabilize_pass flatten) + . tp "LC" lift_context + . tp "PC1" (stabilize_pass (tp "PC1 step" propagate_context)) + . tp "F2" (stabilize_pass flatten) + . tp "RD" (stabilize_pass remove_duplicates) + . tp "RE" (stabilize_pass remove_empty) + . tp "SD" sort_deps + . tp "CUG" combine_use_guards + . tp "F1" (stabilize_pass flatten) + . tp "CAR" combine_atom_ranges + where tp :: String -> (Dependency -> Dependency) -> Dependency -> Dependency + tp pass_name pass d = t False d' + where d' = pass d + t False = id + t True = + trace (unwords [ "PASS" + , show level + , ":" + , pass_name + , show (length (show d)) + , "->" + , show (length (show d')) + ]) + +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 td fd -> DependIfUse use (go td) (go fd) + DependAllOf deps -> DependAllOf $ filter (not . is_empty_dependency) $ map go deps + DependAnyOf deps -> DependAnyOf $ map go deps + -- no change + DependAtom _ -> d + where go = remove_empty + +s_uniq :: [Dependency] -> [Dependency] +s_uniq = S.toList . S.fromList + +-- Ideally 'combine_atom_ranges' should handle those as well +remove_duplicates :: Dependency -> Dependency +remove_duplicates d = + case d of + DependIfUse use td fd -> DependIfUse use (go td) (go fd) + DependAnyOf deps -> DependAnyOf $ s_uniq $ map go deps + DependAllOf deps -> DependAllOf $ s_uniq $ map go deps + DependAtom _ -> d + where go = remove_duplicates + +-- TODO: implement flattening AnyOf the same way it's done for AllOf +-- DependAnyOf [DependAnyOf [something], rest] -> DependAnyOf $ something ++ rest +flatten :: Dependency -> Dependency +flatten d = + case d of + DependIfUse use td fd -> DependIfUse use (go td) (go fd) + DependAnyOf [dep] -> go dep + DependAnyOf deps -> DependAnyOf $ map go deps + + DependAllOf deps -> case L.partition is_dall_of deps of + ([], []) -> empty_dependency + ([], [dep]) -> dep + ([], ndall) -> DependAllOf $ map go ndall + (dall, ndall) -> go $ DependAllOf $ s_uniq $ (concatMap undall dall) ++ ndall + DependAtom _ -> d + where go :: Dependency -> Dependency + go = flatten + + is_dall_of :: Dependency -> Bool + is_dall_of d' = + case d' of + DependAllOf _deps -> True + _ -> False + undall :: Dependency -> [Dependency] + undall ~(DependAllOf ds) = ds + +-- joins atoms with different version boundaries +-- DependAllOf [ DRange ">=foo-1" Inf, Drange Zero " DRange ">=foo-1" " Dependency +combine_atom_ranges d = + case d of + DependIfUse use td fd -> DependIfUse use (go td) (go fd) + DependAllOf deps -> DependAllOf $ map go $ find_atom_intersections deps + DependAnyOf deps -> DependAnyOf $ map go $ find_atom_concatenations deps + DependAtom _ -> d + where go = combine_atom_ranges + +find_atom_intersections :: [Dependency] -> [Dependency] +find_atom_intersections = map merge_depends . L.groupBy is_mergeable + where is_mergeable :: Dependency -> Dependency -> Bool + is_mergeable (DependAtom (Atom lpn _ldrange lattr)) (DependAtom (Atom rpn _rdrange rattr)) + = (lpn, lattr) == (rpn, rattr) + is_mergeable _ _ + = False + + merge_depends :: [Dependency] -> Dependency + merge_depends [x] = x + merge_depends xs = L.foldl1' merge_pair xs + + merge_pair :: Dependency -> Dependency -> Dependency + merge_pair (DependAtom (Atom lp ld la)) (DependAtom (Atom rp rd ra)) + | lp /= rp = error "merge_pair got different 'PackageName's" + | la /= ra = error "merge_pair got different 'DAttr's" + | otherwise = DependAtom (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_atom_concatenations :: [Dependency] -> [Dependency] +find_atom_concatenations = id + +-- Eliminate use guarded redundancy: +-- a? ( foo ) +-- a? ( bar ) +-- gets translated to +-- a? ( foo bar ) + +-- a? ( foo bar ) +-- !a? ( foo baz ) +-- gets translated to +-- foo +-- a? ( bar ) +-- !a? ( baz ) + +combine_use_guards :: Dependency -> Dependency +combine_use_guards d = + case d of + DependIfUse use td fd -> pop_common $ DependIfUse use (go td) (go fd) + DependAllOf deps -> DependAllOf $ map go $ find_use_intersections deps + DependAnyOf deps -> DependAnyOf $ map go $ find_use_concatenations deps + DependAtom _ -> d + where go = combine_use_guards + +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 _ltd _lfd) (DependIfUse ru _rtd _rfd) + | lu == ru = True + is_use_mergeable _ _ = False + + merge_use_intersections :: [Dependency] -> Dependency + merge_use_intersections [x] = x + merge_use_intersections ds = pop_common $ DependIfUse u (DependAllOf tds) (DependAllOf fds) + where DependIfUse u _tf _fd = head ds + tfdeps ~(DependIfUse _u td fd) = (td, fd) + (tds, fds) = unzip $ map tfdeps ds + +pop_common :: Dependency -> Dependency +-- depend +-- a? ( x ) !a? ( x ) +-- gets translated to +-- x +pop_common (DependIfUse _u td fd) + | td == fd = fd +pop_common d'@(DependIfUse _u td fd) = + case td_ctx `L.intersect` fd_ctx of + [] -> d' + common_ctx -> stabilize_pass flatten $ DependAllOf $ propagate_context' common_ctx d' : common_ctx + where td_ctx = lift_context' td + fd_ctx = lift_context' fd +pop_common x = x + +-- TODO +find_use_concatenations :: [Dependency] -> [Dependency] +find_use_concatenations = id + +-- Eliminate top-down redundancy: +-- foo/bar +-- u? ( foo/bar +-- bar/baz ) +-- gets translated to +-- foo/bar +-- u? ( bar/baz ) +-- +-- and more complex redundancy: +-- v? ( foo/bar ) +-- u? ( !v? ( foo/bar ) ) +-- gets translated to +-- v? ( foo/bar ) +-- u? ( foo/bar ) +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 +propagate_context' :: [Dependency] -> Dependency -> Dependency +propagate_context' ctx d = + case d of + _ | d `elem` ctx -> empty_dependency + DependIfUse use td fd -> let (t_ctx_comp, t_refined_ctx) = refine_context (True, use) ctx + (f_ctx_comp, f_refined_ctx) = refine_context (False, use) ctx + tdr = go t_refined_ctx td + fdr = go f_refined_ctx fd + ctx_comp = filter (not . is_empty_dependency) $ + concat [ (lift_context' tdr `L.intersect` (concatMap lift_context' t_ctx_comp)) + , (lift_context' fdr `L.intersect` (concatMap lift_context' f_ctx_comp)) + ] + diu_refined = DependIfUse use tdr + fdr + in case ctx_comp of + [] -> diu_refined + _ -> go ctx $ + DependAllOf [ DependAllOf ctx_comp + , go ctx_comp diu_refined + ] + DependAllOf deps -> DependAllOf $ fromJust $ msum $ + [ v + | (optimized_d, other_deps) <- slice_list deps + , let ctx' = ctx ++ other_deps + d' = go ctx' optimized_d + d'ctx = d' : ctx + v = case d' /= optimized_d of + True -> Just (d':map (go d'ctx) other_deps) + False -> Nothing -- haven't managed to optimize anything + ] ++ [Just deps] -- unmodified + DependAnyOf deps -> DependAnyOf $ map (go ctx) deps + DependAtom _ -> case any (dep_as_broad_as d) ctx of + True -> empty_dependency + False -> d + where go c = propagate_context' c + +-- returns (complement-dependencies, simplified-dependencies) +refine_context :: (Bool, Use) -> [Dependency] -> ([Dependency], [Dependency]) +refine_context use_cond = unzip . map (A.second (stabilize_pass flatten) . refine_ctx_unit use_cond) + where refine_ctx_unit :: (Bool, Use) -> Dependency -> (Dependency, Dependency) + refine_ctx_unit uc@(bu, u) d = + case d of + DependIfUse u' td fd + -> case u == u' of + False -> ( empty_dependency + , DependIfUse u' (snd $ refine_ctx_unit uc td) + (snd $ refine_ctx_unit uc fd) + ) + True -> case bu of + True -> (fd, snd $ refine_ctx_unit uc td) + False -> (td, snd $ refine_ctx_unit uc fd) + _ -> (empty_dependency, d) + +-- generates all pairs of: +-- (list_element, list_without_element) +-- example: +-- [1,2,3] +-- yields +-- [(1, [2,3]), (2,[1,3]), (3,[1,2])] +slice_list :: [e] -> [(e, [e])] +slice_list [] = [] +slice_list (e:es) = (e, es) : map (\(v, vs) -> (v, e : vs)) (slice_list es) + +-- 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 ) +-- TODO: better add propagation in this exact place to keep tree shrinking only +lift_context :: Dependency -> Dependency +lift_context d = + case d of + DependIfUse _use _td _fd -> case L.delete d new_ctx of + [] -> d + new_ctx' -> propagate_context $ DependAllOf $ d : new_ctx' + DependAllOf deps -> case new_ctx L.\\ deps of + [] -> d + new_ctx' -> DependAllOf $ deps ++ new_ctx' + -- the lift itself + DependAnyOf _deps -> case L.delete d new_ctx of + [] -> d + new_ctx' -> propagate_context $ DependAllOf $ d : new_ctx' + DependAtom _ -> d + where new_ctx = lift_context' d + +-- lift everything that can be shared somewhere else +-- propagate_context will then pick some bits from here +-- and remove them deep inside. +-- It's the most fragile and powerfull pass +lift_context' :: Dependency -> [Dependency] +lift_context' d = + case d of + DependIfUse _use td fd -> d : extract_common_constraints (map lift_context' [td, fd]) + DependAllOf deps -> L.nub $ concatMap lift_context' deps + DependAnyOf deps -> d : extract_common_constraints (map lift_context' deps) + DependAtom _ -> [d] + +-- it extracts common part of dependency comstraints. +-- Some examples: +-- 'a b c' and 'b c d' have common 'b c' +-- 'u? ( a b )' and 'u? ( b c )' have common 'u? ( b )' part +-- 'a? ( b? ( x y ) )' and !a? ( b? ( y z ) )' have common 'b? ( y )' +extract_common_constraints :: [[Dependency]] -> [Dependency] +extract_common_constraints [] = [] +extract_common_constraints dss@(ds:dst) = common_atoms ++ common_use_guards + where common_atoms :: [Dependency] + common_atoms = L.foldl1' L.intersect dss + common_use_guards :: [Dependency] + common_use_guards = [ DependIfUse u (DependAllOf tdi) (DependAllOf fdi) + | DependIfUse u td fd <- ds + , Just (tds, fds) <- [find_matching_use_deps dst u ([lift_context' td], [lift_context' fd])] + , let tdi = extract_common_constraints tds + fdi = extract_common_constraints fds + , not (null tdi && null fdi) + ] + +find_matching_use_deps :: [[Dependency]] -> Use -> ([[Dependency]], [[Dependency]]) -> Maybe ([[Dependency]], [[Dependency]]) +find_matching_use_deps dss u (tds, fds) = + case dss of + [] -> Just (tds, fds) + (ds:dst) -> case [ (tc, fc) + | DependIfUse u' td fd <- ds + , u' == u + , let tc = lift_context' td + fc = lift_context' fd + , not (null tc && null fc) + ] of + [] -> Nothing + pairs -> find_matching_use_deps dst u (map fst pairs ++ tds, map snd pairs ++ fds) + +-- reorders depends to make them more attractive +-- for other normalization algorithms +-- and for final pretty-printer +sort_deps :: Dependency -> Dependency +sort_deps d = + case d of + DependIfUse lu lt lf + | is_empty_dependency lf -> + case lt of + DependIfUse ru rt rf + -- b? ( a? ( d ) ) + | ru < lu && is_empty_dependency rf -> mkUseDependency (True, ru) $ mkUseDependency (True, lu) (go rt) + -- b? ( !a? ( d ) ) + | ru < lu && is_empty_dependency rt -> mkUseDependency (False, ru) $ mkUseDependency (True, lu) (go rf) + _ -> DependIfUse lu (go lt) (go lf) + | is_empty_dependency lt -> + case lf of + DependIfUse ru rt rf + -- !b? ( a? ( d ) ) + | ru < lu && is_empty_dependency rf -> mkUseDependency (True, ru) $ mkUseDependency (False, lu) (go rt) + -- !b? ( !a? ( d ) ) + | ru < lu && is_empty_dependency rt -> mkUseDependency (False, ru) $ mkUseDependency (False, lu) (go rf) + _ -> DependIfUse lu (go lt) (go lf) + DependIfUse use td fd -> DependIfUse use (go td) (go fd) + DependAnyOf deps -> DependAnyOf $ L.sort $ map go deps + DependAllOf deps -> DependAllOf $ L.sort $ map go deps + DependAtom _ -> d + where go = sort_deps + +-- remove various types of redundancy +normalize_depend :: Dependency -> Dependency +normalize_depend = normalize_depend' 50 0 -- arbitrary limit + +normalize_depend' :: Int -> Int -> Dependency -> Dependency +normalize_depend' max_level level d + | level >= max_level = trace "WARNING: Normalize_depend hung up. Optimization is incomplete." d +normalize_depend' max_level level d = next_step next_d + where next_d = normalization_step level d + next_step | d == next_d = id + | otherwise = normalize_depend' max_level (level + 1) diff --git a/src/Portage/Dependency/Print.hs b/src/Portage/Dependency/Print.hs new file mode 100644 --- /dev/null +++ b/src/Portage/Dependency/Print.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE CPP #-} + +module Portage.Dependency.Print + ( + dep2str + , dep2str_noindent + ) where + +import Portage.Version +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 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 '>' PP.<> DP.pretty pn <-> DP.pretty v +dispLBound pn (NonstrictLB v) = Disp.text ">=" PP.<> DP.pretty pn <-> DP.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 _pn InfinityB = error "unhandled 'dispUBound Infinity'" + +dispDAttr :: DAttr -> Disp.Doc +dispDAttr (DAttr s u) = dispSlot s PP.<> dispUses u + +dep2str :: Int -> Dependency -> String +dep2str start_indent = render . nest start_indent . showDepend + +dep2str_noindent :: Dependency -> String +dep2str_noindent = render . showDepend + +(<->) :: Disp.Doc -> Disp.Doc -> Disp.Doc +a <-> b = a PP.<> Disp.char '-' PP.<> b + +sp :: Disp.Doc +sp = Disp.char ' ' + +sparens :: Disp.Doc -> Disp.Doc +sparens doc = Disp.parens (sp PP.<> valign doc PP.<> sp) + +valign :: Disp.Doc -> Disp.Doc +valign d = nest 0 d + +showDepend :: Dependency -> Disp.Doc +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 + -- 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 + +showDepend (DependIfUse u td fd) = valign $ vcat [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) + 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 + +-- 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@(DependAtom (Atom _pn (DRange lb ub) _dattr)) + | lb /= ZeroB && ub /= InfinityB + = sparens (showDepend d) +-- rest are fine +showDependInAnyOf d = showDepend d diff --git a/src/Portage/Dependency/Types.hs b/src/Portage/Dependency/Types.hs new file mode 100644 --- /dev/null +++ b/src/Portage/Dependency/Types.hs @@ -0,0 +1,168 @@ +{-| +Module : Portage.Dependency.Types +License : GPL-3+ +Maintainer : haskell@gentoo.org + +Functions and types related to processing Portage dependencies. +-} +module Portage.Dependency.Types + ( + SlotDepend(..) + , LBound(..) + , UBound(..) + , DRange(..) + , DAttr(..) + , Dependency(..) + , Atom(..) + , dep_as_broad_as + , is_empty_dependency + , dep_is_case_of + , range_is_case_of + ) where + +import Portage.PackageId +import Portage.Use + +import Control.DeepSeq (NFData(..)) + +-- | Type of SLOT dependency of a dependency. +data SlotDepend = AnySlot -- ^ nothing special + | AnyBuildTimeSlot -- ^ ':=' + | 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 + compare _ ZeroB = GT + compare (StrictLB lv) (StrictLB rv) = compare lv rv + compare (NonstrictLB lv) (NonstrictLB rv) = compare lv rv + compare (StrictLB lv) (NonstrictLB rv) = case compare lv rv of + EQ -> GT + r -> r + compare (NonstrictLB lv) (StrictLB rv) = case compare lv rv of + EQ -> LT + r -> r +-- | Type of upper bound of a dependency. +data UBound = StrictUB Version -- ^ less than (<) + | NonstrictUB Version -- ^ less than or equal to (<=) + | 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 + compare _ InfinityB = LT + compare (StrictUB lv) (StrictUB rv) = compare lv rv + compare (NonstrictUB lv) (NonstrictUB rv) = compare lv rv + compare (StrictUB lv) (NonstrictUB rv) = case compare lv rv of + EQ -> LT + r -> r + compare (NonstrictUB lv) (StrictUB rv) = case compare lv rv of + EQ -> GT + r -> r + +-- | Type of dependency version. +-- +-- A dependency version may either be an exact 'Version' or a +-- version range between a given 'LBound' and 'UBound'. +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 +range_is_case_of _ _ = False + +-- | True if left 'DRange' covers at least as much as the right 'DRange'. +range_as_broad_as :: DRange -> DRange -> Bool +range_as_broad_as (DRange llow lup) (DRange rlow rup) + | llow <= rlow && lup >= rup = True +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 +dep_as_broad_as l r + -- very broad (not only on atoms) special case + | l == r = True +-- atoms +dep_as_broad_as (DependAtom (Atom lpn lr lda)) (DependAtom (Atom rpn rr rda)) + | lpn == rpn && lda == rda = lr `range_as_broad_as` rr +-- AllOf (very common case in context propagation) +dep_as_broad_as d (DependAllOf deps) + | any (dep_as_broad_as d) deps = True +dep_as_broad_as _ _ = False + +-- TODO: remove it and switch to 'SatisfiedDepend' instead +is_empty_dependency :: Dependency -> Bool +is_empty_dependency d = + case d of + DependIfUse _use td fd + -> is_empty_dependency td && is_empty_dependency fd + DependAnyOf [] + -> True -- 'any (const True) [] == False' and we don't want it + DependAnyOf deps + -> any is_empty_dependency deps + DependAllOf deps + -> all is_empty_dependency deps + DependAtom _ + -> False + +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 (DependAtom (Atom lpn lr lda)) (DependAtom (Atom rpn rr rda)) + | lpn == rpn && lda == rda = lr `range_is_case_of` rr +dep_is_case_of _ _ = False diff --git a/src/Portage/EBuild.hs b/src/Portage/EBuild.hs new file mode 100644 --- /dev/null +++ b/src/Portage/EBuild.hs @@ -0,0 +1,293 @@ +{-| +Module : Portage.EBuild +License : GPL-3+ +Maintainer : haskell@gentoo.org + +Functions and types related to interpreting and manipulating an ebuild, +as understood by the Portage package manager. +-} +{-# LANGUAGE CPP #-} +module Portage.EBuild + ( EBuild(..) + , ebuildTemplate + , showEBuild + , src_uri + -- hspec exports + , sort_iuse + , drop_tdot + , quote + , toHttps + ) where + +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 +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 Network.URI +import qualified Paths_hackport(version) + +#if ! MIN_VERSION_time(1,5,0) +import qualified System.Locale as TC +#endif + +-- | Type representing the information contained in an @.ebuild@. +data EBuild = EBuild { + name :: String, + category :: String, + hackage_name :: String, -- might differ a bit (we mangle case) + version :: String, + hackportVersion :: String, + description :: String, + homepage :: String, + license :: Either String String, + slot :: String, + keywords :: [String], + iuse :: [String], + depend :: Dependency, + depend_extra :: [String], + rdepend :: Dependency, + rdepend_extra :: [String] + , features :: [CabalFeature] + , 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 + , used_options :: [(String, String)] -- ^ hints to ebuild writers/readers + -- on what hackport options were used to produce an ebuild + } + +getHackportVersion :: Version -> String +getHackportVersion Version {versionBranch=(x:s)} = foldl (\y z -> y ++ "." ++ (show z)) (show x) s +getHackportVersion Version {versionBranch=[]} = "" + +-- | Generate a minimal 'EBuild' template. +ebuildTemplate :: EBuild +ebuildTemplate = EBuild { + name = "foobar", + category = "dev-haskell", + hackage_name = "FooBar", + version = "0.1", + hackportVersion = getHackportVersion Paths_hackport.version, + description = "", + homepage = "https://hackage.haskell.org/package/${HACKAGE_N}", + license = Left "unassigned license?", + slot = "0", + keywords = ["~amd64","~x86"], + iuse = [], + depend = empty_dependency, + depend_extra = [], + rdepend = empty_dependency, + rdepend_extra = [], + features = [], + my_pn = Nothing + , src_prepare = [] + , src_configure = [] + , used_options = [] + } + +-- | Given an EBuild, give the URI to the tarball of the source code. +-- Assumes that the server is always hackage.haskell.org. +-- +-- >>> src_uri ebuildTemplate +-- "https://hackage.haskell.org/package/${P}/${P}.tar.gz" +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 -> "https://hackage.haskell.org/package/${P}/${P}.tar.gz" + -- use MY_X variables (defined in showEBuild) as we've renamed the + -- package + Just _ -> "https://hackage.haskell.org/package/${MY_P}/${MY_P}.tar.gz" + +-- | 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. + ss "CABAL_FEATURES=". quote' (sepBy " " $ map render (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. + ss "S=". quote ("${WORKDIR}/${MY_P}"). nl. nl). + ss "DESCRIPTION=". quote (drop_tdot $ description ebuild). nl. + ss "HOMEPAGE=". quote (toHttps $ expandVars (homepage ebuild)). nl. + ss "SRC_URI=". quote (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. + (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 $ [] + where + expandVars = replaceMultiVars [ ( name ebuild, "${PN}") + , (hackage_name ebuild, "${HACKAGE_N}") + ] + + + this_year :: String + this_year = TC.formatTime TC.defaultTimeLocale "%Y" now + +-- | Convert http urls into https urls, unless whitelisted as http-only. +-- +-- >>> toHttps "http://darcs.net" +-- "http://darcs.net" +-- >>> toHttps "http://pandoc.org" +-- "https://pandoc.org" +-- >>> toHttps "https://github.com" +-- "https://github.com" +toHttps :: String -> String +toHttps x = + case parseURI x of + Just uri -> if uriScheme uri == "http:" && + (uriRegName <$> uriAuthority uri) + `notElem` + httpOnlyHomepages + then replace "http" "https" x + else x + Nothing -> x + where + replace old new = L.intercalate new . LS.splitOn old + -- add to this list with any non https-aware websites + httpOnlyHomepages = Just <$> [ "leksah.org" + , "darcs.net" + , "khumba.net" + ] + +-- | Sort IUSE alphabetically +-- +-- >>> sort_iuse ["+a","b"] +-- ["+a","b"] +sort_iuse :: [String] -> [String] +sort_iuse = L.sortBy (compare `F.on` dropWhile ( `elem` "+")) + +-- | Drop trailing dot(s). +-- +-- >>> drop_tdot "foo." +-- "foo" +-- >>> drop_tdot "foo..." +-- "foo" +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 + +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/src/Portage/EBuild/CabalFeature.hs b/src/Portage/EBuild/CabalFeature.hs new file mode 100644 --- /dev/null +++ b/src/Portage/EBuild/CabalFeature.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE LambdaCase #-} + +-- | Support for CABAL_FEATURES="..." in haskell-cabal .ebuild files. +-- See haskell-cabal.eclass for details on each of those. +module Portage.EBuild.CabalFeature (CabalFeature(..)) where + +import Portage.EBuild.Render + +-- | Type representing @CABAL_FEATURES@ in an ebuild. +data CabalFeature = Lib + | Profile + | Haddock + | Hoogle + | HsColour + | TestSuite + deriving Eq + +instance Render CabalFeature where + render = \case + Lib -> "lib" + Profile -> "profile" + Haddock -> "haddock" + Hoogle -> "hoogle" + HsColour -> "hscolour" + TestSuite -> "test-suite" diff --git a/src/Portage/EBuild/Render.hs b/src/Portage/EBuild/Render.hs new file mode 100644 --- /dev/null +++ b/src/Portage/EBuild/Render.hs @@ -0,0 +1,6 @@ +-- CABAL_FEATURES="..." in haskell-cabal .ebuild files +module Portage.EBuild.Render (Render(..)) where + +class Render a where + render :: a -> String + diff --git a/src/Portage/EMeta.hs b/src/Portage/EMeta.hs new file mode 100644 --- /dev/null +++ b/src/Portage/EMeta.hs @@ -0,0 +1,107 @@ +{-| +Module : Portage.EMeta +License : GPL-3+ +Maintainer : haskell@gentoo.org + +Functions to propagate existing ebuild information +(such as its licence, description, switched flags etc.) to +a new ebuild. +-} +module Portage.EMeta + ( EMeta(..) + , findExistingMeta + ) where + +import Control.Monad +import Data.Char (isSpace) +import qualified Data.List as L + +import System.Directory (doesDirectoryExist, getDirectoryContents) +import System.FilePath (()) +import Text.Printf + +-- | Extract a value of variable in \'var=\"val\"\' format. +-- There should be exactly one variable assignment in the ebuild. +-- It's a bit of an 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 (L.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' assignments:\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 + +-- | Extract a value of variable in \'#hackport: var: val\' format. +-- There should be exactly one variable assignment in the ebuild. +extract_hackport_var :: FilePath -> String -> String -> Maybe String +extract_hackport_var ebuild_path s_ebuild var_name = + case filter (L.isPrefixOf var_prefix) $ lines s_ebuild of + [] -> Nothing + [var_line] -> Just $ skip_prefix var_line + other -> bail_out $ printf "strange '%s' assignmets:\n%s" var_name (unlines other) + + where var_prefix = "#hackport: " ++ var_name ++ ": " + skip_prefix = drop (length var_prefix) + bail_out :: String -> e + bail_out msg = error $ printf "%s:extract_hackport_var %s" ebuild_path msg + +-- | Extract the existing keywords from an ebuild. +extractKeywords :: FilePath -> String -> Maybe [String] +extractKeywords ebuild_path s_ebuild = + words `fmap ` extract_quoted_string ebuild_path s_ebuild "KEYWORDS" + +-- | Extract the existing license from an ebuild. +extractLicense :: FilePath -> String -> Maybe String +extractLicense ebuild_path s_ebuild = + extract_quoted_string ebuild_path s_ebuild "LICENSE" + +-- | Extract the existing Cabal flags from an ebuild. +extractCabalFlags :: FilePath -> String -> Maybe String +extractCabalFlags ebuild_path s_ebuild = + extract_hackport_var ebuild_path s_ebuild "flags" + +-- | Extract the existing description from an ebuild. +extractDescription :: FilePath -> String -> Maybe String +extractDescription ebuild_path s_ebuild = + extract_quoted_string ebuild_path s_ebuild "DESCRIPTION" + +-- | Type representing the aggregated (best inferred) metadata for a +-- new ebuild of a package. +data EMeta = EMeta { keywords :: Maybe [String] + , license :: Maybe String + , cabal_flags :: Maybe String + , description :: Maybe String + } + +-- | Find the existing package metadata from the last available ebuild. +findExistingMeta :: FilePath -> IO EMeta +findExistingMeta pkgdir = + do ebuilds <- filter (L.isSuffixOf ".ebuild") `fmap` do b <- doesDirectoryExist pkgdir + if b then getDirectoryContents pkgdir + else return [] + -- TODO: version sort + e_metas <- forM ebuilds $ \e -> + do let e_path = pkgdir e + e_conts <- readFile e_path + return EMeta { keywords = extractKeywords e e_conts + , license = extractLicense e e_conts + , cabal_flags = extractCabalFlags e e_conts + , description = extractDescription 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 + , cabal_flags = get_latest $ map cabal_flags e_metas + , description = get_latest $ map description e_metas + } + return aggregated_meta diff --git a/src/Portage/GHCCore.hs b/src/Portage/GHCCore.hs new file mode 100644 --- /dev/null +++ b/src/Portage/GHCCore.hs @@ -0,0 +1,483 @@ +{-| +Module : Portage.GHCCore +License : GPL-3+ +Maintainer : haskell@gentoo.org + +Guess the appropriate GHC version from packages depended upon. +-} +module Portage.GHCCore + ( minimumGHCVersionToBuildPackage + , cabalFromGHC + , defaultComponentRequestedSpec + , finalizePD + , platform + , dependencySatisfiable + -- hspec exports + , packageIsCoreInAnyGHC + ) where + +import qualified Distribution.Compiler as DC +import qualified Distribution.Package as Cabal +import qualified Distribution.Version as Cabal +import Distribution.Version +import Distribution.Simple.PackageIndex +import Distribution.InstalledPackageInfo as IPI + +import Distribution.PackageDescription +import Distribution.PackageDescription.Configuration +import Distribution.Compiler (CompilerId(..), CompilerFlavor(GHC)) +import Distribution.System +import Distribution.Types.ComponentRequestedSpec (defaultComponentRequestedSpec) + +import Distribution.Pretty (prettyShow) + +import Data.Maybe +import Data.List ( nub ) + +import Debug.Trace + +-- | Try each @GHC@ version in the specified order, from left to right. +-- The first @GHC@ version in this list is a minimum default. +ghcs :: [(DC.CompilerInfo, InstalledPackageIndex)] +ghcs = modern_ghcs + where modern_ghcs = [ghc843, ghc863, ghc865, ghc881, ghc883, ghc884, ghc8101, ghc8104, ghc902] + +-- | Maybe determine the appropriate 'Cabal.Version' of the @Cabal@ package +-- from a given @GHC@ version. +-- +-- >>> cabalFromGHC [8,8,3] +-- Just (mkVersion [3,0,1,0]) +-- >>> cabalFromGHC [9,9,9,9] +-- Nothing +cabalFromGHC :: [Int] -> Maybe Cabal.Version +cabalFromGHC ver = lookup ver table + where + table = [ ([8,4,3], Cabal.mkVersion [2,2,0,1]) + , ([8,6,3], Cabal.mkVersion [2,4,0,1]) + , ([8,6,5], Cabal.mkVersion [2,4,0,1]) + , ([8,8,1], Cabal.mkVersion [3,0,0,0]) + , ([8,8,3], Cabal.mkVersion [3,0,1,0]) + , ([8,8,4], Cabal.mkVersion [3,0,1,0]) + , ([8,10,1], Cabal.mkVersion [3,2,0,0]) + , ([8,10,4], Cabal.mkVersion [3,2,1,0]) + , ([9,0,2], Cabal.mkVersion [3,4,1,0]) + ] + +platform :: Platform +platform = Platform X86_64 Linux + +-- | Is the package a core dependency of a specific version of @GHC@? +-- +-- >>> packageIsCore (mkIndex ghc883_pkgs) (Cabal.mkPackageName "binary") +-- True +-- >>> all (== True) ((packageIsCore (mkIndex ghc883_pkgs)) <$> (packageNamesFromPackageIndex (mkIndex ghc883_pkgs))) +-- True +packageIsCore :: InstalledPackageIndex -> Cabal.PackageName -> Bool +packageIsCore index pn = not . null $ lookupPackageName index pn + +-- | Is the package a core dependency of any version of @GHC@? +-- >>> packageIsCoreInAnyGHC (Cabal.mkPackageName "array") +-- True +packageIsCoreInAnyGHC :: Cabal.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 :: InstalledPackageIndex -> Cabal.Dependency -> Bool +dependencySatisfiable pindex dep@(Cabal.Dependency pn _rang _lib) + | Cabal.unPackageName pn == "Win32" = False -- only exists on windows, not in linux + | not . null $ lookupDependency pindex (Cabal.depPkgName dep) (Cabal.depVerRange 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 + -> FlagAssignment + -> (DC.CompilerInfo, InstalledPackageIndex) + -> Either [Cabal.Dependency] (PackageDescription, FlagAssignment) +packageBuildableWithGHCVersion pkg user_specified_fas (compiler_info, pkgIndex) = trace_failure $ + finalizePD user_specified_fas defaultComponentRequestedSpec (dependencySatisfiable pkgIndex) platform compiler_info [] pkg + where trace_failure v = case v of + (Left deps) -> trace (unwords ["rejecting dep:" , show_compiler compiler_info + , "as", show_deps deps + , "were not found." + ] + ) v + _ -> trace (unwords ["accepting dep:" , show_compiler compiler_info + ] + ) v + show_deps = show . map prettyShow + show_compiler (DC.CompilerInfo { DC.compilerInfoId = CompilerId GHC v }) = "ghc-" ++ prettyShow 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 -> FlagAssignment -> Maybe ( DC.CompilerInfo + , [Cabal.PackageName] + , PackageDescription + , FlagAssignment + , InstalledPackageIndex) +minimumGHCVersionToBuildPackage gpd user_specified_fas = + listToMaybe [ (cinfo, packageNamesFromPackageIndex pix, pkg_desc, picked_flags, pix) + | g@(cinfo, pix) <- ghcs + , Right (pkg_desc, picked_flags) <- return (packageBuildableWithGHCVersion gpd user_specified_fas g)] + +-- | Create an 'InstalledPackageIndex' from a ['Cabal.PackageIdentifier']. +-- This is used to generate an index of core @GHC@ packages from the provided +-- ['Cabal.PackageIdentifier'] functions, e.g. 'ghc883_pkgs'. +mkIndex :: [Cabal.PackageIdentifier] -> InstalledPackageIndex +mkIndex pids = fromList + [ emptyInstalledPackageInfo + { sourcePackageId = pindex + , exposed = True + } + | pindex@(Cabal.PackageIdentifier _name _version) <- pids ] + +packageNamesFromPackageIndex :: InstalledPackageIndex -> [Cabal.PackageName] +packageNamesFromPackageIndex pix = nub $ map fst $ allPackagesByName pix + +ghc :: [Int] -> DC.CompilerInfo +ghc nrs = DC.unknownCompilerInfo c_id DC.NoAbiTag + where c_id = CompilerId GHC (mkVersion nrs) + +ghc902 :: (DC.CompilerInfo, InstalledPackageIndex) +ghc902 = (ghc [9,0,2], mkIndex ghc902_pkgs) + +ghc8104 :: (DC.CompilerInfo, InstalledPackageIndex) +ghc8104 = (ghc [8,10,4], mkIndex ghc8104_pkgs) + +ghc8101 :: (DC.CompilerInfo, InstalledPackageIndex) +ghc8101 = (ghc [8,10,1], mkIndex ghc8101_pkgs) + +ghc884 :: (DC.CompilerInfo, InstalledPackageIndex) +ghc884 = (ghc [8,8,4], mkIndex ghc884_pkgs) + +ghc883 :: (DC.CompilerInfo, InstalledPackageIndex) +ghc883 = (ghc [8,8,3], mkIndex ghc883_pkgs) + +ghc881 :: (DC.CompilerInfo, InstalledPackageIndex) +ghc881 = (ghc [8,8,1], mkIndex ghc881_pkgs) + +ghc865 :: (DC.CompilerInfo, InstalledPackageIndex) +ghc865 = (ghc [8,6,5], mkIndex ghc865_pkgs) + +ghc863 :: (DC.CompilerInfo, InstalledPackageIndex) +ghc863 = (ghc [8,6,3], mkIndex ghc863_pkgs) + +ghc843 :: (DC.CompilerInfo, InstalledPackageIndex) +ghc843 = (ghc [8,4,3], mkIndex ghc843_pkgs) + +-- | Non-upgradeable core packages +-- Sources: +-- * release notes +-- example: https://downloads.haskell.org/~ghc/8.6.5/docs/html/users_guide/8.6.5-notes.html +-- * our binary tarballs (package.conf.d.initial subdir) +-- * ancient: http://haskell.org/haskellwiki/Libraries_released_with_GHC +ghc902_pkgs :: [Cabal.PackageIdentifier] +ghc902_pkgs = + [ p "array" [0,5,4,0] + , p "base" [4,15,1,0] + , p "binary" [0,8,8,0] -- used by libghc + , p "bytestring" [0,10,12,1] +-- , p "Cabal" [3,4,1,0] package is upgradeable + , p "containers" [0,6,4,1] + , p "deepseq" [1,4,5,0] -- used by time + , p "directory" [1,3,6,2] + , p "filepath" [1,4,2,1] + , p "exceptions" [0,10,4] -- used by libghc + , p "ghc-bignum" [1,1] + , p "ghc-boot" [9,0,2] + , p "ghc-boot-th" [9,0,2] + , p "ghc-compact" [0,1,0,0] + , p "ghc-prim" [0,7,0] + , p "ghc-heap" [9,0,2] + , p "ghci" [9,0,2] +-- , p "haskeline" [0,8,2] package is upgradeable + , p "hpc" [0,6,1,0] -- used by libghc + , p "integer-gmp" [1,1] + , p "mtl" [2,2,2] -- used by exceptions + , p "parsec" [3,1,14,0] -- used by exceptions + , p "pretty" [1,1,3,6] + , p "process" [1,6,13,2] + -- , p "stm" [2,5,0,0] package is upgradeable(?) + , p "template-haskell" [2,17,0,0] -- used by libghc + , p "terminfo" [0,4,1,5] -- used by libghc + , p "text" [1,2,5,0] -- used by libghc + , p "time" [1,9,3,0] -- used by unix, directory, hpc, ghc. unsafe to upgrade + , p "transformers" [0,5,6,2] -- used by libghc + , p "unix" [2,7,2,2] +-- , p "xhtml" [3000,2,2,1] + ] + +ghc8104_pkgs :: [Cabal.PackageIdentifier] +ghc8104_pkgs = + [ p "array" [0,5,4,0] + , p "base" [4,14,1,0] + , p "binary" [0,8,8,0] -- used by libghc + , p "bytestring" [0,10,12,0] +-- , p "Cabal" [3,2,1,0] package is upgradeable + , p "containers" [0,6,2,1] + , p "deepseq" [1,4,4,0] -- used by time + , p "directory" [1,3,6,0] + , p "filepath" [1,4,2,1] + , p "exceptions" [0,10,4] -- used by libghc in ghc-9.0.2 + , p "ghc-boot" [8,10,4] + , p "ghc-boot-th" [8,10,4] + , p "ghc-compact" [0,1,0,0] + , p "ghc-prim" [0,6,1,0] + , p "ghc-heap" [8,10,4] + , p "ghci" [8,10,4] +-- , p "haskeline" [0,8,0,1] package is upgradeable + , p "hpc" [0,6,1,0] -- used by libghc + , p "integer-gmp" [1,0,3,0] + , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 + , p "parsec" [3,1,14,0] -- used by exceptions in ghc-9.0.2 + , p "pretty" [1,1,3,6] + , p "process" [1,6,9,0] + -- , p "stm" [2,5,0,0] package is upgradeable(?) + , p "template-haskell" [2,16,0,0] -- used by libghc + , p "terminfo" [0,4,1,4] -- used by libghc in ghc-9.0.2 + , p "text" [1,2,4,1] -- used by libghc in ghc-9.0.2 + , p "time" [1,9,3,0] -- used by unix, directory, hpc, ghc. unsafe to upgrade + , p "transformers" [0,5,6,2] -- used by libghc + , p "unix" [2,7,2,2] +-- , p "xhtml" [3000,2,2,1] + ] + +ghc8101_pkgs :: [Cabal.PackageIdentifier] +ghc8101_pkgs = + [ p "array" [0,5,4,0] + , p "base" [4,14,0,0] + , p "binary" [0,8,8,0] -- used by libghc + , p "bytestring" [0,10,10,0] +-- , p "Cabal" [3,2,0,0] package is upgradeable + , p "containers" [0,6,2,1] + , p "deepseq" [1,4,4,0] -- used by time + , p "directory" [1,3,6,0] + , p "filepath" [1,4,2,1] + , p "exceptions" [0,10,4] -- used by libghc in ghc-9.0.2 + , p "ghc-boot" [8,10,1] + , p "ghc-boot-th" [8,10,1] + , p "ghc-compact" [0,1,0,0] + , p "ghc-prim" [0,6,1,0] + , p "ghc-heap" [8,10,1] + , p "ghci" [8,10,1] +-- , p "haskeline" [0,8,0,0] package is upgradeable + , p "hpc" [0,6,1,0] -- used by libghc + , p "integer-gmp" [1,0,3,0] + , p "mtl" [2,2,2] -- used by libghc in ghc-9.0.2 + , p "parsec" [3,1,14,0] -- used by libghc in ghc-9.0.2 + , p "pretty" [1,1,3,6] + , p "process" [1,6,8,2] + -- , p "stm" [2,5,0,0] package is upgradeable(?) + , p "template-haskell" [2,16,0,0] -- used by libghc + , p "terminfo" [0,4,1,4] -- used by libghc in ghc-9.0.2 + , p "text" [1,2,3,2] -- used by libghc in ghc-9.0.2 + , p "time" [1,9,3,0] -- used by unix, directory, hpc, ghc. unsafe to upgrade + , p "transformers" [0,5,6,2] -- used by libghc + , p "unix" [2,7,2,2] +-- , p "xhtml" [3000,2,2,1] + ] + +ghc884_pkgs :: [Cabal.PackageIdentifier] +ghc884_pkgs = + [ p "array" [0,5,4,0] + , p "base" [4,13,0,0] + , p "binary" [0,8,7,0] -- used by libghc + , p "bytestring" [0,10,10,1] +-- , p "Cabal" [3,0,1,0] package is upgradeable + , p "containers" [0,6,2,1] + , p "deepseq" [1,4,4,0] -- used by time + , p "directory" [1,3,6,0] + , p "filepath" [1,4,2,1] + , p "ghc-boot" [8,8,4] + , p "ghc-boot-th" [8,8,4] + , p "ghc-compact" [0,1,0,0] + , p "ghc-prim" [0,5,3,0] + , p "ghci" [8,8,4] +-- , p "haskeline" [0,7,5,0] package is upgradeable + , p "hpc" [0,6,0,3] -- used by libghc + , p "integer-gmp" [1,0,2,0] + , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 + , p "parsec" [3,1,14,0] -- used by exceptions in ghc-9.0.2 + , p "pretty" [1,1,3,6] + , p "process" [1,6,9,0] + -- , p "stm" [2,5,0,0] package is upgradeable(?) + , p "template-haskell" [2,15,0,0] -- used by libghc + , p "terminfo" [0,4,1,4] -- used by libghc in ghc-9.0.2 + , p "text" [1,2,4,0] -- used by libghc in ghc-9.0.2 + , p "time" [1,9,3,0] -- used by unix, directory, hpc, ghc. unsafe to upgrade + , p "transformers" [0,5,6,2] -- used by libghc + , p "unix" [2,7,2,2] +-- , p "xhtml" [3000,2,2,1] + ] + +ghc883_pkgs :: [Cabal.PackageIdentifier] +ghc883_pkgs = + [ p "array" [0,5,4,0] + , p "base" [4,13,0,0] + , p "binary" [0,8,7,0] -- used by libghc + , p "bytestring" [0,10,10,0] +-- , p "Cabal" [3,0,1,0] package is upgradeable + , p "containers" [0,6,2,1] + , p "deepseq" [1,4,4,0] -- used by time + , p "directory" [1,3,6,0] + , p "filepath" [1,4,2,1] + , p "ghc-boot" [8,8,3] + , p "ghc-boot-th" [8,8,3] + , p "ghc-compact" [0,1,0,0] + , p "ghc-prim" [0,5,3,0] + , p "ghci" [8,8,3] +-- , p "haskeline" [0,7,5,0] package is upgradeable + , p "hpc" [0,6,0,3] -- used by libghc + , p "integer-gmp" [1,0,2,0] + , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 + , p "parsec" [3,1,14,0] -- used by exceptions in ghc-9.0.2 + , p "pretty" [1,1,3,6] + , p "process" [1,6,8,0] + -- , p "stm" [2,5,0,0] package is upgradeable(?) + , p "template-haskell" [2,15,0,0] -- used by libghc + , p "terminfo" [0,4,1,4] -- used by libghc in ghc-9.0.2 + , p "text" [1,2,4,0] -- used by libghc in ghc-9.0.2 + , p "time" [1,9,3,0] -- used by unix, directory, hpc, ghc. unsafe to upgrade + , p "transformers" [0,5,6,2] -- used by libghc + , p "unix" [2,7,2,2] +-- , p "xhtml" [3000,2,2,1] + ] + +ghc881_pkgs :: [Cabal.PackageIdentifier] +ghc881_pkgs = + [ p "array" [0,5,4,0] + , p "base" [4,13,0,0] + , p "binary" [0,8,7,0] -- used by libghc + , p "bytestring" [0,10,9,0] +-- , p "Cabal" [3,0,0,0] package is upgradeable + , p "containers" [0,6,2,1] + , p "deepseq" [1,4,4,0] -- used by time + , p "directory" [1,3,3,2] + , p "filepath" [1,4,2,1] + , p "ghc-boot" [8,8,1] + , p "ghc-boot-th" [8,8,1] + , p "ghc-compact" [0,1,0,0] + , p "ghc-prim" [0,5,3,0] + , p "ghci" [8,8,1] +-- , p "haskeline" [0,7,4,3] package is upgradeable + , p "hpc" [0,6,0,3] -- used by libghc + , p "integer-gmp" [1,0,2,0] + , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 + , p "parsec" [3,1,14,0] -- used by exceptions in ghc-9.0.2 + , p "pretty" [1,1,3,6] + , p "process" [1,6,5,1] + -- , p "stm" [2,5,0,0] package is upgradeable(?) + , p "template-haskell" [2,15,0,0] -- used by libghc + , p "terminfo" [0,4,1,4] -- used by libghc in ghc-9.0.2 + , p "text" [1,2,4,0] -- used by libghc in ghc-9.0.2 + , p "time" [1,9,3,0] -- used by unix, directory, hpc, ghc. unsafe to upgrade + , p "transformers" [0,5,6,2] -- used by libghc + , p "unix" [2,7,2,2] +-- , p "xhtml" [3000,2,2,1] + ] + +ghc865_pkgs :: [Cabal.PackageIdentifier] +ghc865_pkgs = + [ p "array" [0,5,3,0] + , p "base" [4,12,0,0] + , p "binary" [0,8,6,0] -- used by libghc + , p "bytestring" [0,10,8,2] +-- , p "Cabal" [2,4,0,1] package is upgradeable + , p "containers" [0,6,0,1] + , p "deepseq" [1,4,4,0] -- used by time + , p "directory" [1,3,3,0] + , p "filepath" [1,4,2,1] + , p "ghc-boot" [8,6,5] + , p "ghc-boot-th" [8,6,5] + , p "ghc-compact" [0,1,0,0] + , p "ghc-prim" [0,5,3,0] + , p "ghci" [8,6,5] +-- , p "haskeline" [0,7,4,3] package is upgradeable + , p "hpc" [0,6,0,3] -- used by libghc + , p "integer-gmp" [1,0,2,0] + , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 + , p "parsec" [3,1,13,0] -- used by exceptions in ghc-9.0.2 + , p "pretty" [1,1,3,6] + , p "process" [1,6,5,0] + -- , p "stm" [2,5,0,0] package is upgradeable(?) + , p "template-haskell" [2,14,0,0] -- used by libghc + , p "terminfo" [0,4,1,2] -- used by libghc in ghc-9.0.2 + , p "text" [1,2,3,1] -- used by libghc in ghc-9.0.2 + , p "time" [1,8,0,2] -- used by unix, directory, hpc, ghc. unsafe to upgrade + , p "transformers" [0,5,6,2] -- used by libghc + , p "unix" [2,7,2,2] +-- , p "xhtml" [3000,2,2,1] + ] + +ghc863_pkgs :: [Cabal.PackageIdentifier] +ghc863_pkgs = + [ p "array" [0,5,3,0] + , p "base" [4,12,0,0] + , p "binary" [0,8,6,0] -- used by libghc + , p "bytestring" [0,10,8,2] +-- , p "Cabal" [2,4,0,1] package is upgradeable + , p "containers" [0,6,0,1] + , p "deepseq" [1,4,4,0] -- used by time + , p "directory" [1,3,3,0] + , p "filepath" [1,4,2,1] + , p "ghc-boot" [8,6,3] + , p "ghc-boot-th" [8,6,3] + , p "ghc-compact" [0,1,0,0] + , p "ghc-prim" [0,5,3,0] + , p "ghci" [8,6,3] +-- , p "haskeline" [0,7,4,3] package is upgradeable + , p "hpc" [0,6,0,3] -- used by libghc + , p "integer-gmp" [1,0,2,0] + , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 + , p "parsec" [3,1,13,0] -- used by exceptions in ghc-9.0.2 + , p "pretty" [1,1,3,6] + , p "process" [1,6,3,0] + -- , p "stm" [2,5,0,0] package is upgradeable(?) + , p "template-haskell" [2,14,0,0] -- used by libghc + , p "terminfo" [0,4,1,2] -- used by libghc in ghc-9.0.2 + , p "text" [1,2,3,1] -- used by libghc in ghc-9.0.2 + , p "time" [1,8,0,2] -- used by unix, directory, hpc, ghc. unsafe to upgrade + , p "transformers" [0,5,5,0] -- used by libghc + , p "unix" [2,7,2,2] +-- , p "xhtml" [3000,2,2,1] + ] + +ghc843_pkgs :: [Cabal.PackageIdentifier] +ghc843_pkgs = + [ p "array" [0,5,2,0] + , p "base" [4,11,1,0] + , p "binary" [0,8,5,1] -- used by libghc + , p "bytestring" [0,10,8,2] +-- , p "Cabal" [2,2,0,1] package is upgradeable + , p "containers" [0,5,11,2] + , p "deepseq" [1,4,3,0] -- used by time + , p "directory" [1,3,1,5] + , p "filepath" [1,4,2] + , p "ghc-boot" [8,4,3] + , p "ghc-boot-th" [8,4,3] + , p "ghc-compact" [0,1,0,0] + , p "ghc-prim" [0,5,2,0] + , p "ghci" [8,4,3] +-- , p "haskeline" [0,7,4,2] package is upgradeable + , p "hpc" [0,6,0,3] -- used by libghc + , p "integer-gmp" [1,0,2,0] + , p "mtl" [2,2,2] -- used by exceptions in ghc-9.0.2 + , p "parsec" [3,1,13,0] -- used by exceptions in ghc-9.0.2 + , p "pretty" [1,1,3,6] + , p "process" [1,6,3,0] + -- , p "stm" [2,4,5,0] package is upgradeable(?) + , p "template-haskell" [2,13,0,0] -- used by libghc + , p "terminfo" [0,4,1,1] -- used by libghc in ghc-9.0.2 + , p "text" [1,2,3,0] -- used by libghc in ghc-9.0.2 + , p "time" [1,8,0,2] -- used by unix, directory, hpc, ghc. unsafe to upgrade + , p "transformers" [0,5,5,0] -- used by libghc + , p "unix" [2,7,2,2] +-- , p "xhtml" [3000,2,2,1] + ] + +p :: String -> [Int] -> Cabal.PackageIdentifier +p pn vs = Cabal.PackageIdentifier (Cabal.mkPackageName pn) (mkVersion vs) diff --git a/src/Portage/Host.hs b/src/Portage/Host.hs new file mode 100644 --- /dev/null +++ b/src/Portage/Host.hs @@ -0,0 +1,121 @@ +module Portage.Host + ( getInfo -- :: IO [(String, String)] + , LocalInfo(..) + ) where + +import Util (run_cmd) +import qualified Data.List.Split as DLS +import Data.Maybe (fromJust, isJust, mapMaybe) + +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 + , askPortageq + , 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 + if exists then read <$> readFile config_path else return Nothing + +---------- +-- Paludis +---------- + +getPaludisInfo :: IO (Maybe LocalInfo) +getPaludisInfo = fmap parsePaludisInfo <$> run_cmd "cave info" + +parsePaludisInfo :: String -> LocalInfo +parsePaludisInfo text = + let chunks = DLS.splitOn [""] . lines $ text + repositories = mapMaybe 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 + }) + +--------- +-- Emerge +--------- + +askPortageq :: IO (Maybe LocalInfo) +askPortageq = do + distdir <- run_cmd "portageq distdir" + portdir <- run_cmd "portageq get_repo_path / gentoo" + 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 Nothing `elem` [distdir,portdir] + then Nothing + else Just LocalInfo + { distfiles_dir = grab distdir + , portage_dir = grab portdir + , overlay_list = iffy hsRepo + } + --init: kill newline char + where grab = init . fromJust + iffy Nothing = [] + iffy (Just repo) = [init repo] + return info diff --git a/src/Portage/Metadata.hs b/src/Portage/Metadata.hs new file mode 100644 --- /dev/null +++ b/src/Portage/Metadata.hs @@ -0,0 +1,129 @@ +{-| +Module : Portage.Metadata +License : GPL-3+ +Maintainer : haskell@gentoo.org + +Functions and types related to @metadata.xml@ processing +-} +module Portage.Metadata + ( Metadata(..) + , metadataFromFile + , pureMetadataFromFile + , stripGlobalUseFlags -- exported for hspec + , prettyPrintFlags -- exported for hspec + , prettyPrintFlagsHuman + , makeDefaultMetadata + , makeMinimalMetadata + ) where + +import qualified AnsiColor as A + +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 + +-- | A data type for the Gentoo-specific @metadata.xml@ file. +-- Currently defines functions for the maintainer email and +-- USE flags and their descriptions. +data Metadata = Metadata + { metadataEmails :: [String] -- ^ This should /always/ be [\"haskell@gentoo.org\"]. + , metadataUseFlags :: Map.Map String String -- ^ Only /active/ USE flags, if any. + } deriving (Eq, Show) + +-- | Maybe return a 'Metadata' from a 'T.Text'. +-- +-- Trying to parse an empty 'T.Text' should return 'Nothing': +-- +-- >>> pureMetadataFromFile T.empty +-- Nothing +-- +-- Parsing a @metadata.xml@ /without/ USE flags should /always/ be equivalent +-- to 'makeMinimalMetadata': +-- +-- >>> pureMetadataFromFile (makeDefaultMetadata Map.empty) == Just makeMinimalMetadata +-- True +-- +-- Parsing a @metadata.xml@ /with/ USE flags should /always/ be equivalent +-- to 'makeMinimalMetadata' /plus/ the supplied USE flags: +-- +-- >>> pureMetadataFromFile (makeDefaultMetadata (Map.fromList [("name","description")])) == Just (makeMinimalMetadata {metadataUseFlags = Map.fromList [("name","description")] } ) +-- True +pureMetadataFromFile :: T.Text -> Maybe Metadata +pureMetadataFromFile file = parseXMLDoc file >>= \doc -> parseMetadata doc + +-- | Apply 'pureMetadataFromFile' to a 'FilePath'. +metadataFromFile :: FilePath -> IO (Maybe Metadata) +metadataFromFile fp = pureMetadataFromFile <$> T.readFile fp + +-- | Extract the maintainer email and USE flags from a supplied XML 'Element'. +-- +-- If we're parsing a blank 'Element' or otherwise empty @metadata.xml@: +-- >>> parseMetadata blank_element +-- Just (Metadata {metadataEmails = [], metadataUseFlags = fromList []}) +parseMetadata :: Element -> Maybe Metadata +parseMetadata xml = + return Metadata { metadataEmails = strContent <$> findElements (unqual "email") xml + , metadataUseFlags = + -- find the flag name + let x = findElement (unqual "use") xml + y = onlyElems $ concatMap elContent x + z = attrVal <$> concatMap elAttribs y + -- find the flag description + a = concatMap elContent y + b = cdData <$> onlyText a + in Map.fromList $ zip z b + } + +-- | Remove global @USE@ flags from the flags 'Map.Map', as these should not be +-- within the local @metadata.xml@. For now, this is manually specified rather than +-- parsing @use.desc@. +stripGlobalUseFlags :: Map.Map String String -> Map.Map String String +stripGlobalUseFlags m = foldr1 Map.intersection (Map.delete <$> globals <*> [m]) + where + globals = [ "debug" + , "examples" + , "static" + ] + +-- | 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" ++ + (showElement + . add_attr (Attr (blank_name { qName = "name" }) name) + . unode "flag" $ description)) + <$> (Map.toAscList . stripGlobalUseFlags $ 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 ++ ": ") ++ + (L.intercalate " " . lines $ description)) + <$> (Map.toAscList . stripGlobalUseFlags $ m) + +-- | A minimal metadata for use as a fallback value. +makeMinimalMetadata :: Metadata +makeMinimalMetadata = Metadata { metadataEmails = ["haskell@gentoo.org"] + , metadataUseFlags = Map.empty + } + +-- don't use Text.XML.Light as we like our own pretty printer +-- | Pretty print the @metadata.xml@ string. +makeDefaultMetadata :: Map.Map String String -> T.Text +makeDefaultMetadata flags = T.pack $ + unlines [ "" + , "" + , "" + , "\t" + , "\t\thaskell@gentoo.org" + , "\t\tGentoo Haskell" + , "\t" + ++ if flags == Map.empty + then "" + else "\n\t\n" ++ (unlines $ prettyPrintFlags flags) ++ "\t" + , "" + ] diff --git a/src/Portage/Overlay.hs b/src/Portage/Overlay.hs new file mode 100644 --- /dev/null +++ b/src/Portage/Overlay.hs @@ -0,0 +1,189 @@ +module Portage.Overlay + ( ExistingEbuild(..) + , Overlay(..) + , loadLazy + , readOverlay, readOverlayByPackage + , getDirectoryTree, DirectoryTree + + , reduceOverlay + , filterByEmail + , inOverlay + ) + where + +import qualified Portage.PackageId as Portage +import qualified Portage.Metadata as Portage + +import qualified Distribution.Package as Cabal + +import Distribution.Parsec (simpleParsec) +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) + +data ExistingEbuild = ExistingEbuild { + ebuildId :: Portage.PackageId, + ebuildCabalId :: Cabal.PackageIdentifier, + ebuildPath :: FilePath + } deriving (Show,Ord,Eq) + +instance Cabal.Package ExistingEbuild where + packageId = ebuildCabalId + +instance Cabal.HasUnitId ExistingEbuild where + installedUnitId _ = error "Portage.Cabal.installedUnitId: FIXME: should not be used" + +-- | Type describing an overlay. +data Overlay = Overlay { + overlayPath :: FilePath, + overlayMap :: Map Portage.PackageName [ExistingEbuild], + overlayMetadata :: Map Portage.PackageName Portage.Metadata + } deriving Show + +-- | Is 'Cabal.PackageId' found in 'Overlay'? +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 + ] + +filterByEmail :: ([String] -> Bool) -> Overlay -> Overlay +filterByEmail p overlay = overlay + { overlayMetadata = metadataMap' + , overlayMap = pkgMap' + } + where + metadataMap' = Map.filter (p . Portage.metadataEmails) (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 = -- gah! + map (maximumBy (comparing (Portage.pkgVersion . ebuildId))) + . groupBy (equating (versionNumbers . Portage.pkgVersion . ebuildId)) + . sortOn (Portage.pkgVersion . ebuildId) + +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 <- [simpleParsec dir] ] + + packages :: Portage.Category -> DirectoryTree + -> [(Portage.PackageName, DirectoryTree)] + packages category entries = + [ (Portage.PackageName category name, entries') + | Directory dir entries' <- entries + , Just name <- [simpleParsec 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) <- [simpleParsec 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/src/Portage/PackageId.hs b/src/Portage/PackageId.hs new file mode 100644 --- /dev/null +++ b/src/Portage/PackageId.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE CPP #-} +{-| +Module : Portage.PackageId +License : GPL-3+ +Maintainer : haskell@gentoo.org + +Portage package identifiers, which unlike Cabal ones include a category. +-} +module Portage.PackageId ( + Category(..), + PackageName(..), + PackageId(..), + Portage.Version(..), + mkPackageName, + fromCabalPackageId, + toCabalPackageId, + parseFriendlyPackage, + normalizeCabalPackageName, + normalizeCabalPackageId, + filePathToPackageId, + packageIdToFilePath, + cabal_pn_to_PN + ) where + +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 Portage.Version as Portage + +import Control.DeepSeq (NFData(..)) +import qualified Data.Char as Char +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>)) +import System.FilePath (()) + +#if MIN_VERSION_base(4,11,0) +import Prelude hiding ((<>)) +#endif + +newtype Category = Category { unCategory :: String } + deriving (Eq, Ord, Show, Read) + +-- | Portage-style 'PackageName', containing a 'Category' and a 'Cabal.PackageName'. +data PackageName = PackageName { category :: Category, cabalPkgName :: Cabal.PackageName } + deriving (Eq, Ord, Show, Read) + +-- | Portage-style 'PackageId', containing a 'PackageName' and a 'Portage.Version'. +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 + +instance Parsec Category where + parsec = Category <$> P.munch1 categoryChar + 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 + +instance Parsec PackageName where + parsec = do + cat <- parsec + _ <- P.char '/' + 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 + +instance Parsec PackageId where + parsec = do + name <- parsec + _ <- P.char '-' + version <- parsec + return $ PackageId name version + +-- | Transform a 'PackageId' into a 'FilePath'. +-- +-- >>> packageIdToFilePath (PackageId (PackageName (Category "dev-haskell") (Cabal.mkPackageName "foo-bar2")) (Portage.Version [3,0,0] (Just 'b') [Portage.RC 2] 1 )) +-- "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" + where + a <-> b = a ++ '-':b + a <.> b = a ++ '.':b + +-- | Maybe generate a 'PackageId' from a 'FilePath'. Note that the 'FilePath' must have its +-- file extension stripped before being passed to 'filePathToPackageId'. +-- +-- >>> filePathToPackageId (Category "dev-haskell") "foo-bar2-3.0.0b_rc2-r1" +-- Just (PackageId {packageId = PackageName {category = Category {unCategory = "dev-haskell"}, cabalPkgName = PackageName "foo-bar2"}, pkgVersion = Version {versionNumber = [3,0,0], versionChar = Just 'b', versionSuffix = [RC 2], versionRevision = 1}}) +filePathToPackageId :: Category -> FilePath -> Maybe PackageId +filePathToPackageId cat fp = + case explicitEitherParsec parser fp of + Right x -> Just x + _ -> Nothing + where + parser = do + pn <- parseCabalPackageName + _ <- P.char '-' + v <- parsec + return $ PackageId (PackageName cat pn) v + +-- | Create a 'PackageName' from supplied category and package name 'String's. +mkPackageName :: String -> String -> PackageName +mkPackageName cat package = PackageName (Category cat) (Cabal.mkPackageName package) + +-- | Create a 'PackageId' from a 'Category' and 'Cabal.PackageIdentifier'. +fromCabalPackageId :: Category -> Cabal.PackageIdentifier -> PackageId +fromCabalPackageId cat (Cabal.PackageIdentifier name version) = + PackageId (PackageName cat (normalizeCabalPackageName name)) + (Portage.fromCabalVersion version) + +-- | Convert a 'Cabal.PackageName' into lowercase. Internally uses +-- 'cabal_pn_to_PN'. +-- +-- >>> normalizeCabalPackageName (Cabal.mkPackageName "FooBar1") +-- PackageName "foobar1" +normalizeCabalPackageName :: Cabal.PackageName -> Cabal.PackageName +normalizeCabalPackageName = + Cabal.mkPackageName . cabal_pn_to_PN + +-- | Apply 'normalizeCabalPackageName' to the 'Cabal.PackageName' of +-- a supplied 'Cabal.PackageIdentifier'. +normalizeCabalPackageId :: Cabal.PackageIdentifier -> Cabal.PackageIdentifier +normalizeCabalPackageId (Cabal.PackageIdentifier name version) = + Cabal.PackageIdentifier (normalizeCabalPackageName name) version + +-- | Convert a 'PackageId' into a 'Maybe' 'Cabal.PackageIdentifier'. +toCabalPackageId :: PackageId -> Maybe Cabal.PackageIdentifier +toCabalPackageId (PackageId (PackageName _cat name) version) = + fmap (Cabal.PackageIdentifier name) + (Portage.toCabalVersion version) + +-- | Parse a 'String' as a package in the form of @[category\/]name[-version]@: +-- +-- Note that we /cannot/ use the 'parsec' function to parse the 'Cabal.PackageName', +-- since it fails the entire parse if it tries to parse a 'Version'. +-- See 'parseCabalPackageName' below. +-- +-- If parsing a valid package string: +-- +-- >>> parseFriendlyPackage "category-name/package-name1-0.0.0.1a_beta2-r4" +-- Right (Just (Category {unCategory = "category-name"}),PackageName "package-name1",Just (Version {versionNumber = [0,0,0,1], versionChar = Just 'a', versionSuffix = [Beta 2], versionRevision = 4})) +-- +-- If malformed, return an error string: +-- +-- >>> parseFriendlyPackage "category-name/package-name-1-0.0.0.1a_beta2-r4" +-- Left ... +parseFriendlyPackage :: String -> Either String (Maybe Category, Cabal.PackageName, Maybe Portage.Version) +parseFriendlyPackage str = explicitEitherParsec parser str + where + parser = do + mc <- P.optional . P.try $ do + c <- parsec + _ <- P.char '/' + return c + p <- parseCabalPackageName + mv <- P.optional $ do + _ <- P.char '-' + v <- parsec + return v + return (mc, p, mv) + +-- | Parse a 'Cabal.PackageName'. +-- +-- This parser is a replacement for 'parsecUnqualComponentName' which fails when +-- trying to parse a 'Version'. +parseCabalPackageName :: CabalParsing m => m Cabal.PackageName +parseCabalPackageName = do + pn <- P.some . P.try $ + P.choice + [ P.alphaNum + , P.char '+' + , P.char '-' <* P.notFollowedBy (P.some P.digit <* P.notFollowedBy P.letter) + ] + return $ Cabal.mkPackageName pn + +-- | Pretty-print a lowercase 'Cabal.PackageName'. +-- +-- Note the difference between this function and 'normalizeCabalPackageName': +-- this function returns a 'String', the other a 'Cabal.PackageName'. +-- +-- >>> cabal_pn_to_PN (Cabal.mkPackageName "FooBar1") +-- "foobar1" +cabal_pn_to_PN :: Cabal.PackageName -> String +cabal_pn_to_PN = map Char.toLower . prettyShow diff --git a/src/Portage/Resolve.hs b/src/Portage/Resolve.hs new file mode 100644 --- /dev/null +++ b/src/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.Pretty (prettyShow) +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: " + ++ prettyShow cat + return cat + cats -> do + warn verbosity $ "Multiple matches of categories: " ++ unwords (map prettyShow 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/src/Portage/Tables.hs b/src/Portage/Tables.hs new file mode 100644 --- /dev/null +++ b/src/Portage/Tables.hs @@ -0,0 +1,37 @@ +{-| +Module : Portage.Tables +License : GPL-3+ +Maintainer : haskell@gentoo.org + +Tables of Portage-specific conversions. +-} +module Portage.Tables + ( set_build_slot + ) where + +import Portage.Dependency.Builder +import Portage.Dependency.Types +import Portage.PackageId + +import Data.Monoid + +-- | Set the @SLOT@ for a given 'Dependency'. +set_build_slot :: Dependency -> Dependency +set_build_slot = + overAtom $ \a@(Atom pn dr (DAttr _ u)) -> + case mconcat $ map (First . matches a) slottedPkgs of + First (Just s) -> Atom pn dr (DAttr s u) + First Nothing -> Atom pn dr (DAttr AnyBuildTimeSlot u) + where + matches (Atom pn _ _) (nm,s) + | pn == nm = Just s + | otherwise = Nothing + +-- | List of 'PackageName's with their corresponding default 'SlotDepend's. +-- +-- For example, dependency @QuickCheck@ has its @SLOT@ always set to @2@. +slottedPkgs :: [(PackageName, SlotDepend)] +slottedPkgs = + [ (mkPackageName "dev-haskell" "quickcheck", GivenSlot "2=") + , (mkPackageName "dev-haskell" "hdbc", GivenSlot "2=") + ] diff --git a/src/Portage/Use.hs b/src/Portage/Use.hs new file mode 100644 --- /dev/null +++ b/src/Portage/Use.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE CPP #-} + +module Portage.Use ( + -- * main structures + UseFlag(..), + Use(..), + dispUses, + -- * helpers + mkUse, + mkNotUse, + mkQUse + ) where + +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 + +-- | 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 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 + +mkUse :: Use -> UseFlag +mkUse = UseFlag + +mkNotUse :: Use -> UseFlag +mkNotUse = N . UseFlag + +mkQUse :: Use -> UseFlag +mkQUse = Q . UseFlag + +showModificator :: UseFlag -> Disp.Doc +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 + +dispUses :: [UseFlag] -> Disp.Doc +dispUses [] = Disp.empty +dispUses us = Disp.brackets $ Disp.hcat $ (Disp.punctuate (Disp.text ", ")) $ map pretty us + +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 + +instance Ord Use where + compare (Use a) (Use b) = case (a,b) of + ("test", "test") -> EQ + ("test", _) -> LT + (_, "test") -> GT + (_, _) -> a `compare` b diff --git a/src/Portage/Version.hs b/src/Portage/Version.hs new file mode 100644 --- /dev/null +++ b/src/Portage/Version.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE CPP #-} +{-| + Author : Andres Loeh + 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.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 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 + , versionSuffix :: [Suffix] + , versionRevision :: Int -- ^ revision, 0 means none + } + 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) = + 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 + +-- | 'Version' parser using 'Parsec'. +instance Parsec Version where + parsec = do + ver <- P.sepByNonEmpty digits (P.char '.') + c <- P.optional P.lower + suf <- P.many parsec + rev <- P.option 0 $ P.string "-r" *> digits + return $ Version (NE.toList ver) c suf rev + +-- | Check if the ebuild is a live ebuild, i.e. if its 'Version' is @9999@. +-- +-- foo-9999* is treated as live ebuild +-- Cabal-1.17.9999* as well +-- +-- >>> let (c,s,r) = (Nothing,[],0) +-- >>> is_live (Version [1,0,0] c s r) +-- False +-- >>> is_live (Version [999] c s r) +-- False +-- >>> is_live (Version [1,0,0,9999] c s r) +-- True +-- >>> is_live (Version [9999] c s r) +-- True +-- +-- $ +-- prop> \verNum char rev -> is_live (Version verNum char [] rev) == if length verNum >= 1 && last verNum >= 9999 then True else False +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 + +-- | Various allowed suffixes in Portage versions. +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 + 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 + +instance Parsec Suffix where + parsec = P.char '_' + *> P.choice + [ P.string "alpha" >> fmap Alpha maybeDigits + , P.string "beta" >> fmap Beta maybeDigits + , P.try (P.string "pre") >> fmap Pre maybeDigits + , P.string "rc" >> fmap RC maybeDigits + , P.string "p" >> fmap P maybeDigits + ] + where + maybeDigits = P.option 0 digits + +-- | Convert from a 'Cabal.Version' to a Portage 'Version'. +-- +-- prop> \verNum -> fromCabalVersion (Cabal.mkVersion verNum) == Version verNum Nothing [] 0 +fromCabalVersion :: Cabal.Version -> Version +fromCabalVersion cabal_version = Version (Cabal.versionNumbers cabal_version) Nothing [] 0 + +-- | Convert from a Portage 'Version' to a 'Cabal.Version'. +-- $ +-- prop> \verNum char rev -> toCabalVersion (Version verNum char [] rev) == if char == Nothing then Just (Cabal.mkVersion verNum) else Nothing +toCabalVersion :: Version -> Maybe Cabal.Version +toCabalVersion (Version nums Nothing [] _) = Just (Cabal.mkVersion nums) +toCabalVersion _ = Nothing + +-- | Parser which munches digits. +digits :: P.CharParsing m => m Int +digits = read <$> P.some P.digit diff --git a/src/Status.hs b/src/Status.hs new file mode 100644 --- /dev/null +++ b/src/Status.hs @@ -0,0 +1,258 @@ +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 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.Monad + +-- cabal +import qualified Distribution.Verbosity as Cabal +import qualified Distribution.Package as Cabal (pkgName) +import qualified Distribution.Simple.Utils as Cabal (comparing, die', equating) +import Distribution.Pretty (prettyShow) +import Distribution.Parsec (simpleParsec) + +import qualified Distribution.Client.GlobalFlags as CabalInstall +import qualified Distribution.Client.IndexUtils as CabalInstall +import qualified Distribution.Client.Types as CabalInstall ( SourcePackageDb(..) ) +import qualified Distribution.Solver.Types.PackageIndex as CabalInstall +import qualified Distribution.Solver.Types.SourcePackage as CabalInstall ( SourcePackage(..) ) + +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 = Cabal.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 :: Cabal.Verbosity -> CabalInstall.RepoContext -> Overlay -> IO [[PackageId]] +loadHackage verbosity repoContext overlay = do + CabalInstall.SourcePackageDb { CabalInstall.packageIndex = pindex } <- CabalInstall.getSourcePackages verbosity repoContext + let get_cat cabal_pkg = case resolveCategories overlay (Cabal.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) + . CabalInstall.srcpkgPackageId)) + (CabalInstall.allPackagesByName pindex) + return pkg_infos + +status :: Cabal.Verbosity -> FilePath -> FilePath -> CabalInstall.RepoContext -> IO (Map PackageName [FileStatus ExistingEbuild]) +status verbosity portdir overlaydir repoContext = do + overlay <- loadLazy overlaydir + hackage <- loadHackage verbosity repoContext overlay + portage <- filterByEmail ("haskell@gentoo.org" `elem`) <$> loadLazy portdir + let (over, both, port) = portageDiff (overlayMap overlay) (overlayMap portage) + + both' <- T.forM both $ mapM $ \e -> 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 (Cabal.equating ebuildId)) le re) + hack = (( -- We merge package names as we do case-insensitive match. + -- Hackage contains the following 2 package names: + -- ... Cabal-1.24.0.0 Cabal-1.24.1.0 + -- cabal-0.0.0.0 + -- We need to pick both lists of versions, not the first. + -- TODO: have a way to distict between them in the output. + Map.fromListWith (++) $ + 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 :: Cabal.Verbosity -> FilePath -> FilePath -> StatusDirection -> [String] -> CabalInstall.RepoContext -> IO () +runStatus verbosity portdir overlaydir direction pkgs repoContext = do + let pkgFilter = case direction of + OverlayToPortage -> toPortageFilter + PortagePlusOverlay -> id + HackageToOverlay -> fromHackageFilter + pkgs' <- forM pkgs $ \p -> + case simpleParsec p of + Nothing -> Cabal.die' verbosity ("Could not parse package name: " ++ p ++ ". Format cat/pkg") + Just pn -> return pn + tree0 <- status verbosity portdir overlaydir repoContext + 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 + HackageOnly _ -> False + 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_ (zip [(1 :: Int) ..] $ Map.toAscList packages) $ \(ix, (pkg, ebuilds)) -> do + let (PackageName c p) = pkg + putStr (bold (show ix)) + putStr " " + putStr $ prettyShow c ++ '/' : bold (prettyShow p) + putStr " " + forM_ ebuilds $ \e -> do + putStr $ toColor (fmap (prettyShow . 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 $ Cabal.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 (Cabal.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' = Cabal.equating essence + where + 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/src/Util.hs b/src/Util.hs new file mode 100644 --- /dev/null +++ b/src/Util.hs @@ -0,0 +1,31 @@ +{-| + Author : Sergei Trofimovich + 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/tests/doctests-v2.hs b/tests/doctests-v2.hs new file mode 100644 --- /dev/null +++ b/tests/doctests-v2.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE CPP #-} + +module Main (main) where + +import Control.Monad.Fail (fail) +import Data.Foldable (for_) +import System.Exit (ExitCode (..), exitWith) +import System.Process (readProcess, createProcess, proc, waitForProcess, getProcessExitCode) + +#if !MIN_VERSION_base(4,13,0) +import Prelude hiding (fail) +#endif + + +main :: IO () +main = do + doctestPath <- head . lines <$> readProcess "cabal" ["list-bin", "doctest"] [] + + let components = + [ "hackport:lib:hackport-internal" + , "hackport:exe:hackport" + ] + + for_ components $ \component -> do + let cabalArgs = + [ "repl" + , "--with-compiler=" ++ doctestPath + , component + ] + putStrLn $ "Running: cabal " ++ unwords cabalArgs + (_, _, _, processHandle) <- createProcess (proc "cabal" cabalArgs) + waitForProcess processHandle + exitCode <- getProcessExitCode processHandle + case exitCode of + Nothing -> fail "No exit code from cabal process..." + Just ExitSuccess -> pure () + Just c@(ExitFailure i) -> do + putStrLn $ "\nFailure: cabal process returned exit code " ++ show i + exitWith c diff --git a/tests/doctests.hs b/tests/doctests.hs --- a/tests/doctests.hs +++ b/tests/doctests.hs @@ -1,12 +1,36 @@ module Main where -import Test.DocTest --- Some modules fail to find module Paths_hackport, which is generated during building. --- There is a way to make this work properly, but for now just test modules which --- don't import Paths_hackport. -main = doctest [ "Portage/Cabal.hs" - , "Portage/GHCCore.hs" - , "Portage/PackageId.hs" - , "Portage/Version.hs" - , "Portage/Metadata.hs" - ] +import Build_doctests (Component (..), Name (..), components) +import Test.DocTest (doctest) +import Data.Foldable (for_) +import qualified Data.List as L +import GHC.IO.Encoding (setLocaleEncoding) +import System.Directory (getCurrentDirectory, makeAbsolute) +import System.Environment.Compat (unsetEnv) +import System.FilePath.Glob (glob) +import System.FilePath.Posix (()) +import System.IO (utf8) + +main :: IO () +main = do + setLocaleEncoding utf8 + unsetEnv "GHC_ENVIRONMENT" + pwd <- getCurrentDirectory + prefix <- makeAbsolute pwd + + for_ components $ \(Component name pkgs flags _) -> do + putStrLn "----------" + print name + + maybeSources <- case name of + NameLib (Just "hackport-internal") -> Just <$> glob (prefix "src" "**/*.hs") + NameExe "hackport" -> Just <$> glob (prefix "exe" "**/*.hs") + _ -> fail $ + "Unexpected component: " ++ show name ++ "\n" ++ + "Please edit tests/doctests.hs to add sources for this component." + + for_ maybeSources $ \sources -> do + let args = flags ++ pkgs ++ sources + putStrLn "Flags passed:" + for_ args $ \a -> putStr " " *> print a + doctest args