diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,22 @@ `arch-hs` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 0.10.0.0 + +* Add `arch-hs-sync list` to list Haskell packages in [community] + +* Remove generating meta package + +* Add `--install-deps` to call pacman to install all dependencies of a target + +* Fix the list of packages to be packed is not consistent + +* Add `--no-skip-missing` to consider abnormal dependencies in packaging + +* Update dependency versions + +* Update name preset + ## 0.9.1.0 * Support Cabal 3.4 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -285,7 +285,7 @@ including renaming, matching license, and filling out dependencies etc. However, packaging haven't been done so far. `arch-hs` can't guarantee that this package can be built by ghc with the latest dependencies; -hence some patchs may be required in `prepare()`, such as [uusi](#Uusi). +hence some patches may be required in `prepare()`, such as [uusi](#Uusi). ## Options @@ -388,6 +388,14 @@ * recommended package order * system dependencies * flags + +### No skip missing + +``` +$ arch-hs --no-skip-missing TARGET +``` + +With `--no-skip-missing`, `arch-hs` will try to package if the dependent of this package exist whereas this package does not. ## [Name preset](https://github.com/berberman/arch-hs/blob/master/data/NAME_PRESET.json) diff --git a/app/Args.hs b/app/Args.hs --- a/app/Args.hs +++ b/app/Args.hs @@ -25,8 +25,9 @@ optFileTrace :: FilePath, optUusi :: Bool, optForce :: Bool, - optMetaDir :: FilePath, + optInstallDeps :: Bool, optJson :: FilePath, + optNoSkipMissing :: Bool, optTarget :: PackageName } @@ -83,17 +84,19 @@ ( long "force" <> help "Try to package even if target is provided" ) - <*> strOption - ( long "meta" - <> metavar "PATH" - <> help "Path to target meta package" - <> value "" + <*> switch + ( long "install-deps" + <> help "Call pacman to install existing dependencies of the target" ) <*> strOption ( long "json" <> metavar "PATH" <> help "Path to json output (empty means do not write output as json to file)" <> value "" + ) + <*> switch + ( long "no-skip-missing" + <> help "Try to package if the dependent of this package exist whereas this package does not" ) <*> argument optPackageNameReader (metavar "TARGET") diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -12,6 +12,7 @@ import Control.Monad (filterM, forM_, unless) import qualified Data.Aeson as A import qualified Data.ByteString.Lazy as LBS +import Data.Conduit.Process (system) import Data.Containers.ListUtils (nubOrd) import Data.IORef (IORef, modifyIORef', newIORef, readIORef) import Data.List.NonEmpty (toList) @@ -39,6 +40,7 @@ import Network.HTTP.Client (Manager) import Network.HTTP.Client.TLS (newTlsManager) import System.Directory (createDirectoryIfMissing) +import System.Exit (ExitCode (ExitFailure, ExitSuccess)) import System.FilePath (takeFileName) app :: @@ -49,25 +51,26 @@ [String] -> Bool -> Bool -> - FilePath -> + Bool -> FilePath -> + Bool -> (DBKind -> IO FilesDB) -> Sem r () -app target path aurSupport skip uusi force metaPath jsonPath loadFilesDB' = do +app target path aurSupport skip uusi force installDeps jsonPath noSkipMissing loadFilesDB' = do (deps, sublibs, sysDeps) <- getDependencies (fmap mkUnqualComponentName skip) Nothing target inCommunity <- isInCommunity target when inCommunity $ if force - then printWarn $ "Target has been provided by" <+> ppCommunity <> comma <+> "but you passed --force" + then printWarn $ "Target has been provided by" <+> ppCommunity <> comma <+> "but you specified --force" else throw $ TargetExist target ByCommunity when aurSupport $ do inAur <- isInAur target when inAur $ if force - then printWarn $ "Target has been provided by" <+> ppAur <> comma <+> "but you passed --force" + then printWarn $ "Target has been provided by" <+> ppAur <> comma <+> "but you specified --force" else throw $ TargetExist target ByAur let removeSublibs pkgs = @@ -93,15 +96,21 @@ printWarn $ "Package" <+> dquotes (pretty parent) <+> "is provided without" <> colon forM_ children $ putStrLn . unPackageName + unless (null abnormalDependencies || noSkipMissing) $ + printWarn "Those package(s) are ignored unless you specify --no-skip-missing" + let fillProvidedPkgs provideList provider = map (\x -> if (x ^. pkgName) `elem` provideList then ProvidedPackage (x ^. pkgName) provider else x) fillProvidedDeps provideList provider = map (pkgDeps %~ each %~ (\y -> if y ^. depName `elem` provideList then y & depProvider ?~ provider else y)) filledByCommunity = fillProvidedPkgs communityProvideList ByCommunity . fillProvidedDeps communityProvideList ByCommunity $ grouped + -- after filling community toBePacked1 = filledByCommunity ^.. each . filtered (not . isProvided) + (filledByBoth, toBePacked2) <- do when aurSupport $ printInfo "Start searching AUR..." aurProvideList <- if aurSupport - then filterM (\n -> do printInfo ("Searching" <+> viaPretty n); isInAur n) $ filter (\x -> not $ x == target && force) $ toBePacked1 ^.. each . pkgName + then -- after filling aur. toBePacked1 should not appear after the next line + filterM (\n -> do printInfo ("Searching" <+> viaPretty n); isInAur n) $ filter (\x -> not $ x == target && force) $ toBePacked1 ^.. each . pkgName else return [] let a = fillProvidedPkgs aurProvideList ByAur . fillProvidedDeps aurProvideList ByAur $ filledByCommunity b = a ^.. each . filtered (not . isProvided) @@ -114,16 +123,24 @@ embed $ T.putStrLn . prettySolvedPkgs $ filledByBoth printInfo "Recommended package order:" - -- remove missingChildren from the graph, so that we don't need package them if they are not our target - let vertexesToBeRemoved = missingChildren <> filledByBoth ^.. each . filtered isProvided ^.. each . pkgName + -- remove missingChildren from the graph iff noSkipMissing is not enabled + let vertexesToBeRemoved = (if noSkipMissing then [] else missingChildren) <> filledByBoth ^.. each . filtered isProvided ^.. each . pkgName removeSelfCycle g = foldr (\n acc -> GL.removeEdge n n acc) g $ toBePacked2 ^.. each . pkgName newGraph = GL.induce (`notElem` vertexesToBeRemoved) deps flattened <- case G.topSort . GL.skeleton $ removeSelfCycle newGraph of Left c -> throw . CyclicExist $ toList c Right x -> return $ filter (`notElem` sublibs) x - embed . putDoc $ (prettyDeps . reverse $ flattened) <> line <> line + -- after removing missing children + -- toBePacked1 and toBePacked2 should appear after the next line + let toBePacked3 = filter (\x -> x ^. pkgName `elem` flattened) toBePacked2 + -- add sign for missing children if we have + embed . putDoc $ (prettyDeps . reverse $ map (\x -> (x, x `elem` missingChildren)) flattened) <> line <> line + + unless (null missingChildren) $ + embed . putDoc $ annotate italicized $ yellowStarInParens <+> "indicates a missing package" <> line <> line + let sysDepsToBePacked = Map.filterWithKey (\k _ -> k `elem` flattened) sysDeps unless (null sysDepsToBePacked) $ do @@ -189,33 +206,27 @@ writeFile fileName txt printInfo $ "Write file" <> colon <+> pretty fileName ) - toBePacked2 + toBePacked3 - unless (null metaPath) $ do - cabal <- getLatestCabal target - let url = getUrl $ packageDescription cabal - name = unPackageName target - template = N.metaTemplate (T.pack url) (T.pack name) - providedDepends pkg = + when installDeps $ do + let providedDepends pkg = pkg ^. pkgDeps ^.. each . filtered (\x -> depNotMyself (pkg ^. pkgName) x && depNotInGHCLib x && x ^. depProvider == Just ByCommunity) - toStr x = "'" <> (unArchLinuxName . toArchLinuxName . _depName) x <> "'" - depends = case unwords . nubOrd . fmap toStr . mconcat $ providedDepends <$> toBePacked2 of - [] -> "" - xs -> " " <> xs + toStr = unArchLinuxName . toArchLinuxName . _depName + depends = unwords . nubOrd . fmap toStr . mconcat $ providedDepends <$> toBePacked3 flattened' = filter (/= target) flattened - comment = case flattened' of - [] -> "\n" - [x] -> "# The following dependency is missing in community: " <> unPackageName x - _ -> "# Following dependencies are missing in community:" <> intercalate ", " (unPackageName <$> flattened') - txt = template (T.pack comment) (T.pack depends) - dir = metaPath "haskell-" <> name <> "-meta" - fileName = dir "PKGBUILD" - embed $ do - createDirectoryIfMissing True dir - writeFile fileName (T.unpack txt) - printInfo $ "Write file" <> colon <+> pretty fileName + case flattened' of + [] -> pure () + [x] -> printWarn $ "The following dependency is missing in" <+> ppCommunity <> colon <+> pretty (unPackageName x) + xs -> printWarn $ "Following dependencies are missing in" <+> ppCommunity <> colon <+> hsep (punctuate comma (pretty . unPackageName <$> xs)) + embed $ putDoc line + case depends of + [] -> printInfo "No extra dependency to install" + xs -> + embed (system $ "sudo pacman --needed -S " <> xs) >>= \case + ExitSuccess -> printSuccess "Installed successfully" + ExitFailure c -> printError $ "pacman exited with" <+> pretty c ----------------------------------------------------------------------------- data EmergedSysDep = Solved File ArchLinuxName | Unsolved File @@ -305,9 +316,9 @@ printInfo "You chose to skip:" putDoc $ prettySkip optSkip <> line <> line - when optAur $ printInfo "You passed -a, searching AUR may takes a long time" + when optAur $ printInfo "You specified -a, searching AUR may takes a long time" - when optUusi $ printInfo "You passed --uusi, uusi will become makedepends of each package" + when optUusi $ printInfo "You specified --uusi, uusi will become makedepends of each package" hackage <- loadHackageDBFromOptions optHackage @@ -337,7 +348,7 @@ optFileTrace ref manager - (subsumeGHCVersion $ app optTarget optOutputDir optAur optSkip optUusi optForce optMetaDir optJson (loadFilesDBFromOptions optFilesDB)) + (subsumeGHCVersion $ app optTarget optOutputDir optAur optSkip optUusi optForce optInstallDeps optJson optNoSkipMissing (loadFilesDBFromOptions optFilesDB)) & printAppResult ----------------------------------------------------------------------------- diff --git a/arch-hs.cabal b/arch-hs.cabal --- a/arch-hs.cabal +++ b/arch-hs.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: arch-hs -version: 0.9.1.0 +version: 0.10.0.0 synopsis: Distribute hackage packages to archlinux description: @arch-hs@ is a command-line program, which simplifies the process of producing @@ -23,7 +23,7 @@ CHANGELOG.md README.md -tested-with: GHC ==8.10.5 || ==9.0.1 +tested-with: GHC ==8.10.7 || ==9.0.2 source-repository head type: git @@ -37,7 +37,7 @@ common common-options build-depends: , aeson ^>=1.5.4 - , algebraic-graphs ^>=0.5 + , algebraic-graphs >=0.5 && <0.7 , arch-web ^>=0.1.0 , base >=4.12 && <5 , bytestring @@ -52,7 +52,7 @@ , hackage-db ^>=2.1.0 , http-client , http-client-tls - , megaparsec ^>=9.0.0 || ^>=9.1.0 + , megaparsec ^>=9.0.0 || ^>=9.1.0 || ^>=9.2.0 , microlens ^>=0.4.11 , microlens-th ^>=0.4.3 , neat-interpolation ^>=0.5.1 diff --git a/data/NAME_PRESET.json b/data/NAME_PRESET.json --- a/data/NAME_PRESET.json +++ b/data/NAME_PRESET.json @@ -39,6 +39,7 @@ "haskell-gtk": "gtk3", "haskell-graphscc": "GraphSCC", "haskell-hopenpgp": "hOpenPGP", + "haskell-htf": "HTF", "haskell-http": "HTTP", "haskell-hunit": "HUnit", "haskell-ifelse": "IfElse", @@ -51,6 +52,7 @@ "haskell-missingh": "MissingH", "haskell-monadlib": "monadLib", "haskell-monadrandom": "MonadRandom", + "haskell-onetuple": "OneTuple", "haskell-only": "Only", "haskell-hsopenssl": "HsOpenSSL", "haskell-hsyaml": "HsYAML", diff --git a/src/Distribution/ArchHs/FilesDB.hs b/src/Distribution/ArchHs/FilesDB.hs --- a/src/Distribution/ArchHs/FilesDB.hs +++ b/src/Distribution/ArchHs/FilesDB.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} + -- | Copyright: (c) 2020-2021 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman @@ -111,7 +112,7 @@ loadFilesDB db dir = Map.fromList <$> runConduitRes (loadFilesDBC db dir .| mergeResult .| sinkList) -- | Lookup which Arch Linux package contains this @file@ from given files db. --- This query is bad in performance, since it traverses the entire db. +-- This query is bad in performance, since it traverses the entire db. lookupPkg :: File -> FilesDB -> [ArchLinuxName] lookupPkg file = Map.foldrWithKey (\k v acc -> if file `elem` v then k : acc else acc) [] diff --git a/src/Distribution/ArchHs/Local.hs b/src/Distribution/ArchHs/Local.hs --- a/src/Distribution/ArchHs/Local.hs +++ b/src/Distribution/ArchHs/Local.hs @@ -24,7 +24,6 @@ "integer-simple", "bytestring-builder", "nats", - "old-time", "integer", "unsupported-ghc-version", "rts", diff --git a/src/Distribution/ArchHs/Name.hs b/src/Distribution/ArchHs/Name.hs --- a/src/Distribution/ArchHs/Name.hs +++ b/src/Distribution/ArchHs/Name.hs @@ -159,8 +159,7 @@ -- i.e. it is in @preset@ or has @haskell-@ prefix. -- Attention: There is no guarantee that the package exists in hackage. isHaskellPackage :: ArchLinuxName -> Bool -isHaskellPackage (toArchLinuxRep -> rep) = - (rep `elem` communityListP || "haskell-" `isPrefixOf` unsafeUnMyName rep) +isHaskellPackage (toArchLinuxRep -> rep) = rep `elem` communityListP || "haskell-" `isPrefixOf` unsafeUnMyName rep -- | Check if a package is GHC or GHC Libs diff --git a/src/Distribution/ArchHs/PP.hs b/src/Distribution/ArchHs/PP.hs --- a/src/Distribution/ArchHs/PP.hs +++ b/src/Distribution/ArchHs/PP.hs @@ -19,6 +19,7 @@ align2col, dui, cuo, + yellowStarInParens, ppCommunity, ppAur, ppDBKind, @@ -80,6 +81,9 @@ dui :: Doc AnsiStyle dui = annGreen "✔" +yellowStarInParens :: Doc AnsiStyle +yellowStarInParens = annYellow $ parens (pretty '*') + prettySkip :: [String] -> Doc AnsiStyle prettySkip = hsep . punctuate comma . fmap (annotate (color Magenta) . pretty) @@ -91,10 +95,18 @@ prettyFlagAssignment :: FlagAssignment -> Doc AnsiStyle prettyFlagAssignment = vsep . fmap (\(n, v) -> "⚐" <+> annotate (color Yellow) (viaPretty n) <> colon <+> annotate (color Cyan) (pretty v)) . unFlagAssignment -prettyDeps :: [PackageName] -> Doc AnsiStyle +prettyDeps :: [(PackageName, Bool)] -> Doc AnsiStyle prettyDeps = vsep - . fmap (\(i :: Int, n) -> pretty i <> dot <+> viaPretty n) + . fmap + ( \(i :: Int, (pkg, star)) -> + pretty i + <> dot <+> viaPretty pkg + <> ( if star + then space <> yellowStarInParens + else mempty + ) + ) . zip [1 ..] prettyFlags :: [(PackageName, [PkgFlag])] -> Doc AnsiStyle diff --git a/src/Distribution/ArchHs/PkgBuild.hs b/src/Distribution/ArchHs/PkgBuild.hs --- a/src/Distribution/ArchHs/PkgBuild.hs +++ b/src/Distribution/ArchHs/PkgBuild.hs @@ -14,7 +14,6 @@ showArchLicense, applyTemplate, felixTemplate, - metaTemplate, ) where @@ -177,21 +176,3 @@ runhaskell Setup copy --destdir="$$pkgdir"$licenseF } |] - --- | A fixed template of a haskell meta package. -metaTemplate :: Text -> Text -> Text -> Text -> Text -metaTemplate url pkgname comment depends = - [text| - # This file was generated by https://github.com/berberman/arch-hs, please check it manually. - # This is a meta package, containing only dependencies of the target. - # Maintainer: Your Name - - pkgname=haskell-$pkgname-meta - pkgver=1 - pkgrel=1 - pkgdesc="Dependencies of $pkgname" - url="$url" - arch=('x86_64') - $comment - depends=('ghc-libs'$depends) - |] diff --git a/src/Distribution/ArchHs/Utils.hs b/src/Distribution/ArchHs/Utils.hs --- a/src/Distribution/ArchHs/Utils.hs +++ b/src/Distribution/ArchHs/Utils.hs @@ -162,11 +162,11 @@ | otherwise = def -- | Trace with prefix @[TRACE]@. -trace' :: MemberWithError Trace r => String -> Sem r () +trace' :: Member Trace r => String -> Sem r () trace' s = trace $ "[TRACE] " <> s -- | Trace 'GHC.Stack.CallStack'. -traceCallStack :: (HasCallStack, MemberWithError Trace r) => Sem r () +traceCallStack :: (HasCallStack, Member Trace r) => Sem r () traceCallStack = do trace . prefix $ prettyCallStack callStack where diff --git a/sync/Args.hs b/sync/Args.hs --- a/sync/Args.hs +++ b/sync/Args.hs @@ -2,6 +2,7 @@ ( CommonOptions (..), SubmitOptions (..), CheckOptions (..), + ListOptions (..), Mode (..), runArgsParser, ) @@ -58,8 +59,22 @@ ----------------------------------------------------------------------------- -data Mode = Submit CommonOptions SubmitOptions | Check CommonOptions CheckOptions +newtype ListOptions = ListOptions + { optWithVersion :: Bool + } +listOptionsParser :: Parser ListOptions +listOptionsParser = + ListOptions + <$> switch (short 'v' <> long "with-version" <> help "Show package version") + +----------------------------------------------------------------------------- + +data Mode + = Submit CommonOptions SubmitOptions + | Check CommonOptions CheckOptions + | List CommunityDBOptions ListOptions + runArgsParser :: IO Mode runArgsParser = snd <$> do @@ -79,3 +94,8 @@ "check inconsistencies of Haskell packages version" id (Check <$> commonOptionsParser <*> checkOptionsParser) + addCommand + "list" + "list all Haskell packages in [community]" + id + (List <$> communityDBOptionsParser <*> listOptionsParser) diff --git a/sync/Check.hs b/sync/Check.hs --- a/sync/Check.hs +++ b/sync/Check.hs @@ -19,26 +19,28 @@ <+> "in" <+> ppCommunity <+> "has version" - <+> (if isHackageNewer then annRed else annGreen) (viaPretty archVersion) + <+> (if isHackageNewer then annRed else annGreen) + (viaPretty archVersion) <> comma - <+> "but linked" - <+> annMagneta (pretty (unPackageName hackageName)) - <+> "in" - <+> annCyan "Hackage" - <+> "has" - <+> (if isHackageNewer then "a newer" else "an older") - <+> "version" - <+> (if isHackageNewer then annGreen else annRed) (viaPretty hackageVersion) + <+> "but linked" + <+> annMagneta (pretty (unPackageName hackageName)) + <+> "in" + <+> annCyan "Hackage" + <+> "has" + <+> (if isHackageNewer then "a newer" else "an older") + <+> "version" + <+> (if isHackageNewer then annGreen else annRed) + (viaPretty hackageVersion) | (archName, rawArchVersion, cabal) <- linked, let hackageName = packageName cabal hackageVersion = packageVersion cabal, - archVersion <- maybeToList $ simpleParsec rawArchVersion, includeGHC || not (isGHCLibs hackageName), + archVersion <- maybeToList $ simpleParsec rawArchVersion, archVersion /= hackageVersion, let isHackageNewer = hackageVersion > archVersion ] - if (null result) + if null result then printSuccess "Finished checking" else do - printWarn $ "Finished checking with inconsistenc(ies):" + printWarn "Finished checking with inconsistenc(ies):" embed $ putDoc $ vcat result <> line diff --git a/sync/Main.hs b/sync/Main.hs --- a/sync/Main.hs +++ b/sync/Main.hs @@ -7,9 +7,11 @@ import Args import Check import Control.Monad (unless) +import qualified Data.Map.Strict as Map import Distribution.ArchHs.Exception import Distribution.ArchHs.Hackage import Distribution.ArchHs.Internal.Prelude +import Distribution.ArchHs.Name (isHaskellPackage) import Distribution.ArchHs.Options import Distribution.ArchHs.PP import Distribution.ArchHs.Types @@ -27,7 +29,7 @@ HackageDB -> Bool -> IO (Either MyException ()) -runCheck community hackage includeGHC= +runCheck community hackage includeGHC = ( runFinal . embedToFinal @IO . errorToIOFinal @@ -82,3 +84,11 @@ community <- loadCommunityDBFromOptions optCommunityDB hackage <- loadHackageDBFromOptions optHackage runCheck community hackage optShowGHCLibs & printAppResult + List CommunityDBOptions {..} ListOptions {..} -> do + community <- loadCommunityDBFromOptions + putStrLn $ + unlines + [ unArchLinuxName name <> (if optWithVersion then ": " <> version else "") + | (name, version) <- Map.toList community, + isHaskellPackage name + ] diff --git a/sync/Submit.hs b/sync/Submit.hs --- a/sync/Submit.hs +++ b/sync/Submit.hs @@ -27,7 +27,7 @@ linked <- linkedHaskellPackages pure $ sortOn - (\x -> x ^. _1) + (^. _1) [ (unPackageName hackageName, version, prefix <> tweakedName) | (archLinuxName, version, packageName -> hackageName) <- linked, let tweakedName = diff --git a/sync/Utils.hs b/sync/Utils.hs --- a/sync/Utils.hs +++ b/sync/Utils.hs @@ -17,7 +17,7 @@ linkedHaskellPackages :: Members [CommunityEnv, HackageEnv, WithMyErr, Embed IO] r => - Sem r ([(ArchLinuxName, ArchLinuxVersion, GenericPackageDescription)]) + Sem r [(ArchLinuxName, ArchLinuxVersion, GenericPackageDescription)] linkedHaskellPackages = do communityHaskellPackages <- filter (isHaskellPackage . fst) . Map.toList <$> ask @CommunityDB hackagePackages <- Map.keys <$> ask @HackageDB