diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog + +`arch-hs` uses [PVP Versioning][1]. +The changelog is available [on GitHub][2]. + +## 0.0.0.0 + +* Initially created. + +[1]: https://pvp.haskell.org +[2]: https://github.com/berberman/arch-hs/releases diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2020 berberman + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,341 @@ +# arch-hs + +[![GitHub CI](https://github.com/berberman/arch-hs/workflows/CI/badge.svg)](https://github.com/berberman/arch-hs/actions) +[![Build Status](https://travis-ci.com/berberman/arch-hs.svg?branch=master)](https://travis-ci.com/berberman/arch-hs) +[![Hackage](https://img.shields.io/hackage/v/arch-hs.svg?logo=haskell)](https://hackage.haskell.org/package/arch-hs) +[![MIT license](https://img.shields.io/badge/license-MIT-blue.svg)](LICENSE) + +A program generating PKGBUILD for hackage packages. Special thanks to [felixonmars](https://github.com/felixonmars/). + +**Notice that `arch-hs` will always support only the latest GHC version.** + + +## Introduction + +Given the name of a package in hackage, `arch-hs` can generate its corresponding PKGBUILD draft. +It has a naive built-in dependency solver, which can fetch all dependencies we need to produce a archlinux package. +During the dependency calculation, all version constraints will be discarded due to the arch haskell packaging strategy, +and packages already exist in the [community](https://www.archlinux.org/packages/) will be excluded. + +## Prerequisite + +`arch-hs` is just a PKGBUILD text file generator, which is not integrated with `pacman`, depending on nothing than: + +* Pacman database (`community.db`), ~~i.e., archlinux system.~~ the db file can be specified manually for now. + +* Hackage database tarball (`01-index.tar`, or `00-index.tar` previously), usually provided by `cabal-install`. + +## Installation + +### Install the latest release + +``` +# pacman -S arch-hs +``` + +Install it directly using `pacman`. + +### Install the development version + +``` +$ yay -S arch-hs-git +``` + +Install it using your AUR helper, or just `pacman` with [archlinxcn](https://github.com/archlinuxcn/repo), which provides pre-built binary, following the latest git commit. + +### Build from source (for development) + +``` +$ git clone https://github.com/berberman/arch-hs +``` + +Then build and install it via stack or cabal. + +#### Stack +``` +$ stack install +``` + +#### Cabal (dynamic) +``` +$ cabal configure --disable-library-vanilla --enable-shared --enable-executable-dynamic --ghc-options=-dynamic +$ cabal install +``` + +## Usage + +Just run `arch-hs` in command line with options and a target. Here is an example: +we will create the archlinux package of `dhall-lsp-server`: + +``` +$ arch-hs -o "/home/berberman/Desktop/test/" dhall-lsp-server + +...... + + ⓘ Recommended package order (from topological sort): +1. haskell-lsp-types +2. haskell-lsp +3. dhall-lsp-server + + ⓘ Detected flags from targets (their values will keep default unless you specify): +haskell-lsp + ⚐ demo: + description: Build the lsp-hello demo executable + default: False + isManual: False + + ⓘ Write file: /home/berberman/Desktop/test/dhall-lsp-server/PKGBUILD + ⓘ Write file: /home/berberman/Desktop/test/haskell-lsp/PKGBUILD + ⓘ Write file: /home/berberman/Desktop/test/haskell-lsp-types/PKGBUILD + ✔ Success! + +``` + +This message tells that in order to package `dhall-lsp-server`, we must package `haskell-lsp-types` +and `haskell-lsp` sequentially, because they don't present in archlinux community repo. + +``` +/home/berberman/Desktop/test +├── dhall-lsp-server +│   └── PKGBUILD +├── haskell-lsp +│   └── PKGBUILD +└── haskell-lsp-types + └── PKGBUILD +``` + +`arch-hs` will generate PKGBUILD for each packages. Let's see what we have in `./haskell-lsp/PKGBUILD`: + +``` bash +# This file was generated by arch-hs, please check it manually. +# Maintainer: Your Name + +_hkgname=haskell-lsp +pkgname=haskell-lsp +pkgver=0.22.0.0 +pkgrel=1 +pkgdesc="Haskell library for the Microsoft Language Server Protocol" +url="https://github.com/alanz/haskell-lsp" +license=("custom:MIT") +arch=('x86_64') +depends=('ghc-libs' 'haskell-aeson' 'haskell-async' 'haskell-attoparsec' 'haskell-data-default' 'haskell-hashable' 'haskell-lsp-types' 'haskell-hslogger' 'haskell-lens' 'haskell-network-uri' 'haskell-rope-utf16-splay' 'haskell-sorted-list' 'haskell-temporary' 'haskell-unordered-containers' 'haskell-vector') +makedepends=('ghc' 'haskell-quickcheck' 'haskell-hspec' 'haskell-hspec-discover' 'haskell-quickcheck-instances') +source=("https://hackage.haskell.org/packages/archive/$_hkgname/$pkgver/$_hkgname-$pkgver.tar.gz") +sha256sums=('SKIP') + +prepare(){ + cd $_hkgname-$pkgver +} + +build() { + cd $_hkgname-$pkgver + + runhaskell Setup configure -O --enable-shared --enable-executable-dynamic --disable-library-vanilla \ + --prefix=/usr --docdir=/usr/share/doc/$pkgname --enable-tests \ + --dynlibdir=/usr/lib --libsubdir=\$compiler/site-local/\$pkgid \ + --ghc-option=-optl-Wl\,-z\,relro\,-z\,now \ + --ghc-option='-pie' + + runhaskell Setup build + runhaskell Setup register --gen-script + runhaskell Setup unregister --gen-script + sed -i -r -e "s|ghc-pkg.*update[^ ]* |&'--force' |" register.sh + sed -i -r -e "s|ghc-pkg.*unregister[^ ]* |&'--force' |" unregister.sh +} + +check() { + cd $_hkgname-$pkgver + runhaskell Setup test +} + +package() { + cd $_hkgname-$pkgver + + install -D -m744 register.sh "$pkgdir"/usr/share/haskell/register/$pkgname.sh + install -D -m744 unregister.sh "$pkgdir"/usr/share/haskell/unregister/$pkgname.sh + runhaskell Setup copy --destdir="$pkgdir" + install -D -m644 "LICENSE" "${pkgdir}/usr/share/licenses/${pkgname}/LICENSE" + rm -f "${pkgdir}/usr/share/doc/${pkgname}/LICENSE" +} +``` + +`arch-hs` will collect the information from hackage db, and apply it into a fixed template after some processing steps +including renaming, matching license, and filling out dependencies etc. +If the package doesn't have test suits, `check()` will be removed. However, packaging haven't been done so far. +`arch-hs` may does well statically, but we should guarantee that this package can be built by ghc with the latest dependencies; +hence some patchs may be required in `prepare()`. + + +## Options + +### Output +``` +$ arch-hs -o "/home/berberman/Desktop/test/" termonad +``` + +This will generate a series of PKGBUILD including `termonad` with its dependencies into the output dir. + +### Flag Assignments +``` +$ arch-hs -f inline-c:gsl-example:true termonad +``` + +Using `-f` can pass flags, which may affect the results of rsolving. + +### AUR Searching +``` +$ arch-hs -a termonad +``` + +Using `-a` can regard AUR as another package provider. `arch-hs` will try to search missing packages in AUR. + +### Skipping Components +``` +$ arch-hs -s termonad-test termonad +``` + +Using `-s` can force skip runnable components in dependency rsolving. +This is useful when a package doesn't provide flag to disable its runnables, which will be built by default but are trivial in system level packaging. +Notice that this only makes sense in the lifetime of `arch-hs`, whereas generated PKGBUILD and actual build processes will not be affected. + +### Extra Cabal Files + +``` +$ arch-hs -e /home/berberman/arch-hs/arch-hs.cabal arch-hs +``` + +Using `-e` can can include extra `.cabal` files as supplementary. Useful when the target like `arch-hs` hasn't been released to hackage. + +### Help + +``` +$ arch-hs --help +arch-hs - a program generating PKGBUILD for hackage packages. + +Usage: arch-hs [-h|--hackage PATH] [-c|--community PATH] [-o|--output PATH] + [-f|--flags package_name:flag_name:true|false,...] + [-s|--skip component_name,...] [-e|--extra PATH_1,...] [-a|--aur] + TARGET + Try to reach the TARGET QAQ. + +Available options: + -h,--hackage PATH Path to hackage index + tarball (default: "~/.cabal/packages/YOUR_HACKAGE_MIRROR/01-index.tar | 00-index.tar") + -c,--community PATH Path to + community.db (default: "/var/lib/pacman/sync/community.db") + -o,--output PATH Output path to generated PKGBUILD files (empty means + dry run) + -f,--flags package_name:flag_name:true|false,... + Flag assignments for packages - e.g. + inline-c:gsl-example:true (separated by ',') + -s,--skip component_name,... + Skip a runnable component (executable, test suit, or + benchmark) in dependency calculation + -e,--extra PATH_1,... Extra cabal files' path - e.g. + /home/berberman/arch-hs/arch-hs.cabal + -a,--aur Enable AUR searching + -h,--help Show this help text + +``` + +For all available options, have a look at the help message. + +## Diff + +`arch-hs` also provides a component called `arch-hs-diff`. `arch-hs-diff` can show differences of information used in PKGBUILD between two versions of a hackage package. +This is useful in the subsequent maintenance of a package. Example: + +``` +$ arch-hs-diff HTTP 4000.3.14 4000.3.15 + ▶ You didn't pass -f, different flag values may make difference in dependency resolving. + ⓘ Start running... + ⓘ Downloading cabal file from https://hackage.haskell.org/package/HTTP-4000.3.14/revision/0.cabal... + ⓘ Downloading cabal file from https://hackage.haskell.org/package/HTTP-4000.3.15/revision/0.cabal... +Package: HTTP +Version: 4000.3.14 ⇒ 4000.3.15 +Synopsis: A library for client-side HTTP +URL: https://github.com/haskell/HTTP +Depends: + base >=4.3.0.0 && <4.14 + time >=1.1.2.3 && <1.10 + array >=0.3.0.2 && <0.6 + bytestring >=0.9.1.5 && <0.11 + mtl >=2.0 && <2.3 + network-uri ==2.6.* + network >=2.6 && <3.2 + parsec >=2.0 && <3.2 +-------------------------------------- + base >=4.3.0.0 && <4.15 + time >=1.1.2.3 && <1.11 + array >=0.3.0.2 && <0.6 + bytestring >=0.9.1.5 && <0.11 + mtl >=2.0 && <2.3 + network-uri ==2.6.* + network >=2.6 && <3.2 + parsec >=2.0 && <3.2 +MakeDepends: + deepseq >=1.3.0.0 && <1.5 + HUnit >=1.2.0.1 && <1.7 + httpd-shed >=0.4 && <0.5 + mtl >=1.1.1.0 && <2.3 + pureMD5 >=0.2.4 && <2.2 + split >=0.1.3 && <0.3 + test-framework >=0.2.0 && <0.9 + test-framework-hunit >=0.3.0 && <0.4 +Flags: + HTTP + ⚐ mtl1: + description: Use the old mtl version 1. + default: False + isManual: False + ⚐ warn-as-error: + description: Build with warnings-as-errors + default: False + isManual: True + ⚐ conduit10: + description: Use version 1.0.x or below of the conduit package (for the test suite) + default: False + isManual: False + ⚐ warp-tests: + description: Test against warp + default: False + isManual: True + ⚐ network-uri: + description: Get Network.URI from the network-uri package + default: True + isManual: False + + + ✔ Success! +``` + +`arch-hs-diff` does not require hackage db, it downloads cabal files from hackage server instead. + +## Limitations + +* The dependency solver will **ONLY** expand the dependencies of *executables* and *libraries* recursively, because +circular dependency lies ubiquitously involving *test suites*, *benchmarks*, and their *buildTools*. + +* Currently, `arch-hs`'s functionality is limited to dependency processing, whereas necessary procedures like +file patches, loose of version constraints, etc. are need to be done manually, so **DO NOT** give too much trust in generated PKGBUILD files. + +## ToDoList + +- [ ] **Standardized pretty printing**. + +- [ ] Structuralized PKGBUILD template. + +- [x] AUR support. + +- [ ] Logging system. + +- [ ] A watchdog during dependency calculation. + +- [x] Working with given `.cabal` files which haven't been released to hackage. + +- [ ] Using `hackage-security` to manage hackage index tarball. + + +## Contributing + +Issues and PRs are always welcome. **\_(:з」∠)\_** diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Args.hs b/app/Args.hs new file mode 100644 --- /dev/null +++ b/app/Args.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +module Args + ( Options (..), + runArgsParser, + ) +where + +import qualified Data.Map.Strict as Map +import Distribution.ArchHs.Types (FlagAssignments) +import Distribution.Types.PackageName (PackageName) +import OptionParse + +data Options = Options + { optHackagePath :: FilePath, + optCommunityPath :: FilePath, + optOutputDir :: FilePath, + optFlags :: FlagAssignments, + optSkip :: [String], + optExtraCabalPath :: [FilePath], + optAur :: Bool, + optTarget :: PackageName + } + deriving stock (Show) + +cmdOptions :: Parser Options +cmdOptions = + Options + <$> strOption + ( long "hackage" + <> metavar "PATH" + <> short 'h' + <> help "Path to hackage index tarball" + <> showDefault + <> value "~/.cabal/packages/YOUR_HACKAGE_MIRROR/01-index.tar | 00-index.tar" + ) + <*> strOption + ( long "community" + <> metavar "PATH" + <> short 'c' + <> help "Path to community.db" + <> showDefault + <> value "/var/lib/pacman/sync/community.db" + ) + <*> strOption + ( long "output" + <> metavar "PATH" + <> short 'o' + <> help "Output path to generated PKGBUILD files (empty means dry run)" + <> value "" + ) + <*> option + optFlagReader + ( long "flags" + <> metavar "package_name:flag_name:true|false,..." + <> short 'f' + <> help "Flag assignments for packages - e.g. inline-c:gsl-example:true (separated by ',')" + <> value Map.empty + ) + <*> option + optSkippedReader + ( long "skip" + <> metavar "component_name,..." + <> short 's' + <> help "Skip a runnable component (executable, test suit, or benchmark) in dependency calculation" + <> value [] + ) + <*> option + optExtraCabalReader + ( long "extra" + <> metavar "PATH_1,..." + <> short 'e' + <> help "Extra cabal files' path - e.g. /home/berberman/arch-hs/arch-hs.cabal" + <> value [] + ) + <*> switch + ( long "aur" + <> short 'a' + <> help "Enable AUR searching" + ) + <*> argument optPackageNameReader (metavar "TARGET") + +runArgsParser :: IO Options +runArgsParser = + execParser $ + info + (cmdOptions <**> helper) + ( fullDesc + <> progDesc "Try to reach the TARGET QAQ." + <> header "arch-hs - a program generating PKGBUILD for hackage packages." + ) diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +module Main (main) where + +import qualified Algebra.Graph.AdjacencyMap.Algorithm as G +import qualified Algebra.Graph.Labelled.AdjacencyMap as G +import Args +import qualified Colourista as C +import Conduit +import qualified Control.Exception as CE +import Control.Monad (filterM, when) +import Data.List (groupBy, intercalate, isInfixOf, nub) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import qualified Data.Text as T +import Distribution.ArchHs.Aur +import Distribution.ArchHs.Community +import Distribution.ArchHs.Core +import Distribution.ArchHs.Hackage +import Distribution.ArchHs.Local +import Distribution.ArchHs.PP +import qualified Distribution.ArchHs.PkgBuild as N +import Distribution.ArchHs.Types +import Distribution.ArchHs.Utils (getTwo) +import Distribution.Hackage.DB (HackageDB) +import Distribution.PackageDescription (FlagAssignment) +import Distribution.Types.PackageName + ( PackageName, + unPackageName, + ) +import Distribution.Types.UnqualComponentName (mkUnqualComponentName) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (takeFileName, ()) + +app :: + Members '[Embed IO, CommunityEnv, HackageEnv, FlagAssignmentsEnv, DependencyRecord, Aur, WithMyErr] r => + PackageName -> + FilePath -> + Bool -> + [String] -> + Sem r () +app target path aurSupport skip = do + deps <- getDependencies Set.empty (fmap mkUnqualComponentName skip) True target + inCommunity <- isInCommunity target + when inCommunity $ throw $ TargetExist target ByCommunity + + if aurSupport + then do + inAur <- isInAur target + when inAur $ throw $ TargetExist target ByAur + else return () + + let grouped = groupDeps deps + namesFromSolved x = x ^.. each . pkgName <> x ^.. each . pkgDeps . each . depName + allNames = nub $ namesFromSolved grouped + communityProvideList <- (<> ghcLibList) <$> filterM isInCommunity allNames + let fillProvidedPkgs provideList provider = mapC (\x -> if (x ^. pkgName) `elem` provideList then ProvidedPackage (x ^. pkgName) provider else x) + fillProvidedDeps provideList provider = mapC (pkgDeps %~ each %~ (\y -> if y ^. depName `elem` provideList then y & depProvider .~ (Just provider) else y)) + cooked = + runConduitPure $ + yieldMany grouped + .| fillProvidedPkgs communityProvideList ByCommunity + .| fillProvidedDeps communityProvideList ByCommunity + .| sinkList + toBePacked = cooked ^.. each . filtered (\case ProvidedPackage _ _ -> False; _ -> True) + (cookedAgain, toBePackedAgain) <- do + embed . when aurSupport $ C.infoMessage "Start searching AUR..." + aurProvideList <- if aurSupport then filterM (\n -> do embed $ C.infoMessage ("Searching " <> (T.pack $ unPackageName n)); isInAur n) $ toBePacked ^.. each . pkgName else return [] + let cookedAgain = + if aurSupport + then + runConduitPure $ + yieldMany cooked + .| fillProvidedPkgs aurProvideList ByAur + .| fillProvidedDeps aurProvideList ByAur + .| sinkList + else cooked + toBePackedAgain = + if aurSupport + then cookedAgain ^.. each . filtered (\case ProvidedPackage _ _ -> False; _ -> True) + else toBePacked + return (cookedAgain, toBePackedAgain) + + embed $ C.infoMessage "Solved target:" + embed $ putStrLn . prettySolvedPkgs $ cookedAgain + + let flattened = filter (`elem` (toBePackedAgain ^.. each . pkgName)) $ G.reachable target $ G.skeleton deps + embed $ C.infoMessage "Recommended package order (from topological sort):" + embed $ putStrLn . prettyDeps $ flattened + flags <- filter (\(_, l) -> length l /= 0) <$> mapM (\n -> (n,) <$> getPackageFlag n) flattened + + embed $ + when (length flags /= 0) $ do + C.infoMessage "Detected flags from targets (their values will keep default unless you specify):" + putStrLn . prettyFlags $ flags + + let dry = path == "" + embed $ when dry $ C.warningMessage "You didn't pass -o, PKGBUILD files will not be generated." + when (not dry) $ + mapM_ + ( \solved -> do + pkgBuild <- cabalToPkgBuild solved + let pName = "haskell-" <> N._pkgName pkgBuild + dir = path pName + fileName = dir "PKGBUILD" + txt = N.applyTemplate pkgBuild + embed $ createDirectoryIfMissing True dir + embed $ writeFile fileName txt + embed $ C.infoMessage $ "Write file: " <> T.pack fileName + ) + toBePackedAgain + +runApp :: + HackageDB -> + CommunityDB -> + Map.Map PackageName FlagAssignment -> + Sem '[CommunityEnv, HackageEnv, FlagAssignmentsEnv, DependencyRecord, Aur, WithMyErr, Embed IO, Final IO] a -> + IO (Either MyException a) +runApp hackage community flags = + runFinal + . embedToFinal + . errorToIOFinal + . aurToIO + . evalState Map.empty + . runReader flags + . runReader hackage + . runReader community + +main :: IO () +main = CE.catch @CE.IOException + ( do + Options {..} <- runArgsParser + + let useDefaultHackage = isInfixOf "YOUR_HACKAGE_MIRROR" $ optHackagePath + useDefaultCommunity = "/var/lib/pacman/sync/community.db" == optCommunityPath + + when useDefaultHackage $ C.skipMessage "You didn't pass -h, use hackage index file from default places." + when useDefaultCommunity $ C.skipMessage "You didn't pass -c, use community db file from default places." + + let isFlagEmpty = optFlags == Map.empty + isSkipEmpty = optSkip == [] + + when isFlagEmpty $ C.skipMessage "You didn't pass -f, different flag values may make difference in dependency resolving." + when (not isFlagEmpty) $ do + C.infoMessage "You assigned flags:" + putStrLn . prettyFlagAssignments $ optFlags + + when (not isSkipEmpty) $ do + C.infoMessage "You chose to skip:" + putStrLn $ prettySkip optSkip + + when optAur $ C.infoMessage "You passed -a, searching AUR may takes a long time." + + hackage <- loadHackageDB =<< if useDefaultHackage then lookupHackagePath else return optHackagePath + C.infoMessage "Loading hackage..." + + let isExtraEmpty = optExtraCabalPath == [] + + when (not isExtraEmpty) $ + C.infoMessage $ "You added " <> (T.pack . intercalate ", " $ map takeFileName optExtraCabalPath) <> " as extra cabal file(s), starting parsing right now." + + parsedExtra <- mapM parseCabalFile optExtraCabalPath + + let newHackage = foldr (\x acc -> x `insertDB` acc) hackage parsedExtra + + community <- loadProcessedCommunity $ if useDefaultCommunity then defaultCommunityPath else optCommunityPath + C.infoMessage "Loading community.db..." + + C.infoMessage "Start running..." + + runApp newHackage community optFlags (app optTarget optOutputDir optAur optSkip) >>= \case + Left x -> C.errorMessage $ "Runtime Error: " <> (T.pack . show $ x) + _ -> C.successMessage "Success!" + ) + $ \e -> C.errorMessage $ "IOException: " <> (T.pack . show $ e) + +----------------------------------------------------------------------------- + +groupDeps :: G.AdjacencyMap (Set.Set DependencyType) PackageName -> [SolvedPackage] +groupDeps = + fmap (\(name, deps) -> SolvedPackage name $ fmap (uncurry . flip $ SolvedDependency Nothing) deps) + . fmap ((\(a, b, c) -> (head b, zip a c)) . unzip3) + . groupBy (\x y -> uncurry (==) (getTwo _2 x y)) + . fmap (_1 %~ Set.toList) + . Set.toList + . G.edgeSet diff --git a/arch-hs.cabal b/arch-hs.cabal new file mode 100644 --- /dev/null +++ b/arch-hs.cabal @@ -0,0 +1,121 @@ +cabal-version: 2.4 +name: arch-hs +version: 0.0.0.0 +synopsis: A program generating PKGBUILD for hackage packages. +description: + @arch-hs@ is a command-line program, which simplifies the process of producing + and maintaining haskell packages for archlinux distribution by automating the + PKGBUILD generation with the dependency resolving and template filling. Packagers should follow the + . +homepage: https://github.com/berberman/arch-hs +bug-reports: https://github.com/berberman/arch-hs/issues +license: MIT +license-file: LICENSE +author: berberman +maintainer: berberman <1793913507@qq.com> +copyright: 2020 berberman +category: Distribution +build-type: Simple +extra-doc-files: README.md + CHANGELOG.md +tested-with: GHC == 8.10.2 + +source-repository head + type: git + location: https://github.com/berberman/arch-hs.git +common common-options + build-depends: base ^>= 4.14.0, + Cabal ^>= 3.2.0, + aeson ^>= 1.5.4, + req ^>= 3.6.0, + hackage-db ^>= 2.1.0, + conduit ^>= 1.3.2, + containers ^>= 0.6.2, + deepseq ^>= 1.4.4, + algebraic-graphs ^>= 0.5, + megaparsec ^>= 8.0.0, + directory ^>= 1.3.6, + bytestring ^>= 0.10.10, + tar-conduit ^>= 0.3.2, + conduit-extra ^>= 1.3.5, + split ^>= 0.2.3, + neat-interpolation ^>= 0.5.1, + text ^>= 1.2.3, + microlens ^>= 0.4.11, + microlens-th ^>= 0.4.3, + polysemy ^>= 1.3.0, + filepath ^>= 1.4.2, + colourista ^>= 0.1, + template-haskell ^>= 2.16.0, + optparse-applicative ^>= 0.15.1 + + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -O2 + -flate-specialise + -fspecialise-aggressively + -Wredundant-constraints + -fhide-source-paths + -Wmissing-export-lists + -Wpartial-fields + -Wmissing-deriving-strategies + + default-language: Haskell2010 + default-extensions: DataKinds + FlexibleContexts + GADTs + LambdaCase + PolyKinds + RankNTypes + ScopedTypeVariables + TypeApplications + TypeOperators + TypeFamilies +library + import: common-options + hs-source-dirs: src + exposed-modules: Distribution.ArchHs.Aur, + Distribution.ArchHs.PkgDesc, + Distribution.ArchHs.Community, + Distribution.ArchHs.Core, + Distribution.ArchHs.Hackage, + Distribution.ArchHs.Local, + Distribution.ArchHs.PkgBuild, + Distribution.ArchHs.Types, + Distribution.ArchHs.Utils, + Distribution.ArchHs.PP, + OptionParse, + Data.Aeson.Ext, + Polysemy.Req + +executable arch-hs + import: common-options + hs-source-dirs: app + main-is: Main.hs + other-modules: Args + build-depends: arch-hs + ghc-options: -threaded + -rtsopts + -with-rtsopts=-N + +executable arch-hs-diff + import: common-options + hs-source-dirs: diff + main-is: Main.hs + other-modules: Diff + build-depends: arch-hs + ghc-options: -threaded + -rtsopts + -with-rtsopts=-N + +executable arch-hs-uusi + import: common-options + hs-source-dirs: uusi + main-is: Main.hs + build-depends: arch-hs, process + ghc-options: -threaded + -rtsopts + -with-rtsopts=-N diff --git a/diff/Diff.hs b/diff/Diff.hs new file mode 100644 --- /dev/null +++ b/diff/Diff.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Diff + ( diffCabal, + Options (..), + runArgsParser, + ) +where + +import qualified Colourista as C +import qualified Control.Exception as CE +import Data.List (intercalate, nub, sortBy, (\\)) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Distribution.ArchHs.Core +import Distribution.ArchHs.PP (prettyFlags) +import Distribution.ArchHs.Types +import Distribution.ArchHs.Utils +import Distribution.PackageDescription +import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe) +import Distribution.Pretty (prettyShow) +import qualified Distribution.Types.BuildInfo.Lens as L +import Distribution.Types.Dependency +import Distribution.Types.PackageName +import Distribution.Types.UnqualComponentName +import Distribution.Utils.ShortText (fromShortText) +import Distribution.Version +import Network.HTTP.Req hiding (header) +import OptionParse + +data Options = Options + { optFlags :: FlagAssignments, + optPackageName :: PackageName, + optVersionA :: Version, + optVersionB :: Version + } + +cmdOptions :: Parser Options +cmdOptions = + Options + <$> option + optFlagReader + ( long "flags" + <> metavar "package_name:flag_name:true|false,..." + <> short 'f' + <> help "Flag assignments for packages - e.g. inline-c:gsl-example:true (separated by ',')" + <> value Map.empty + ) + <*> argument optPackageNameReader (metavar "TARGET") + <*> argument optVersionReader (metavar "VERSION_A") + <*> argument optVersionReader (metavar "VERSION_B") + +runArgsParser :: IO Options +runArgsParser = + execParser $ + info + (cmdOptions <**> helper) + ( fullDesc + <> progDesc "Try to reach the TARGET QAQ." + <> header "arch-hs-diff - a program creating diff between different versions of a cabal file." + ) + +----------------------------------------------------------------------------- + +-- This parts are duplicated from Core.hs with modifications. + +type VersionedList = [(PackageName, VersionRange)] + +type VersionedComponentList = [(UnqualComponentName, VersionedList)] + +collectLibDeps :: Member FlagAssignmentsEnv r => GenericPackageDescription -> Sem r (VersionedList, VersionedList) +collectLibDeps cabal = do + case cabal & condLibrary of + Just lib -> do + bInfo <- evalConditionTree cabal lib + let libDeps = fmap unDepV $ buildDependsIfBuild bInfo + toolDeps = fmap unExeV $ buildToolDependsIfBuild bInfo + return (libDeps, toolDeps) + Nothing -> return ([], []) + +collectRunnableDeps :: + (Semigroup k, L.HasBuildInfo k, Member FlagAssignmentsEnv r) => + (GenericPackageDescription -> [(UnqualComponentName, CondTree ConfVar [Dependency] k)]) -> + GenericPackageDescription -> + [UnqualComponentName] -> + Sem r (VersionedComponentList, VersionedComponentList) +collectRunnableDeps f cabal skip = do + let exes = cabal & f + bInfo <- filter (not . (`elem` skip) . fst) . zip (exes <&> fst) <$> mapM (evalConditionTree cabal . snd) exes + let runnableDeps = bInfo <&> ((_2 %~) $ fmap unDepV . buildDependsIfBuild) + toolDeps = bInfo <&> ((_2 %~) $ fmap unExeV . buildToolDependsIfBuild) + return (runnableDeps, toolDeps) + +collectExeDeps :: Member FlagAssignmentsEnv r => GenericPackageDescription -> [UnqualComponentName] -> Sem r (VersionedComponentList, VersionedComponentList) +collectExeDeps = collectRunnableDeps condExecutables + +collectTestDeps :: Member FlagAssignmentsEnv r => GenericPackageDescription -> [UnqualComponentName] -> Sem r (VersionedComponentList, VersionedComponentList) +collectTestDeps = collectRunnableDeps condTestSuites + +getCabalFromHackage :: Members [Embed IO, WithMyErr] r => PackageName -> Version -> Sem r GenericPackageDescription +getCabalFromHackage name version = do + let urlPath = T.pack $ unPackageName name <> "-" <> prettyShow version + api = https "hackage.haskell.org" /: "package" /: urlPath /: "revision" /: "0.cabal" + r = req GET api NoReqBody bsResponse mempty + embed $ C.infoMessage $ "Downloading cabal file from " <> renderUrl api <> "..." + response <- embed $ CE.try @HttpException (runReq defaultHttpConfig r) + result <- case response of + Left _ -> throw $ VersionError name version + Right x -> return x + case parseGenericPackageDescriptionMaybe $ responseBody result of + Just x -> return x + _ -> embed @IO $ fail $ "Failed to parse .cabal file from " <> show api + +----------------------------------------------------------------------------- + +diffCabal :: Members [FlagAssignmentsEnv, WithMyErr, Embed IO] r => PackageName -> Version -> Version -> Sem r String +diffCabal name a b = do + ga <- getCabalFromHackage name a + gb <- getCabalFromHackage name b + let pa = packageDescription ga + pb = packageDescription gb + fa = genPackageFlags ga + fb = genPackageFlags ga + (ba, ma) <- directDependencies ga + (bb, mb) <- directDependencies gb + return $ + unlines + [ C.formatWith [C.magenta] "Package: " <> unPackageName name, + ver pa pb, + desc pa pb, + url pa pb, + dep "Depends: \n" ba bb, + dep "MakeDepends: \n" ma mb, + flags name fa fb + ] + +directDependencies :: + Member FlagAssignmentsEnv r => + GenericPackageDescription -> + Sem r ([String], [String]) +directDependencies cabal = do + (libDeps, libToolsDeps) <- collectLibDeps cabal + (exeDeps, exeToolsDeps) <- collectExeDeps cabal [] + (testDeps, testToolsDeps) <- collectTestDeps cabal [] + let connectVersionWithName (n, range) = unPackageName n <> " " <> prettyShow range + flatten = mconcat . fmap snd + l = libDeps + lt = libToolsDeps + e = flatten exeDeps + et = flatten exeToolsDeps + t = flatten testDeps + tt = flatten testToolsDeps + notMyself = (/= (getPkgName' cabal)) + distinct = filter (notMyself . fst) . nub + depends = distinct $ l <> e + makedepends = (distinct $ lt <> et <> t <> tt) \\ depends + return (fmap connectVersionWithName depends, fmap connectVersionWithName makedepends) + +diffTerm :: String -> (a -> String) -> a -> a -> String +diffTerm s f a b = + let (ra, rb) = (f a, f b) + in (C.formatWith [C.magenta] s) + <> (if ra == rb then ra else ((C.formatWith [C.red] ra) <> " ⇒ " <> C.formatWith [C.green] rb)) + +desc :: PackageDescription -> PackageDescription -> String +desc = diffTerm "Synopsis: " $ fromShortText . synopsis + +ver :: PackageDescription -> PackageDescription -> String +ver = diffTerm "Version: " (prettyShow . getPkgVersion) + +url :: PackageDescription -> PackageDescription -> String +url = diffTerm "URL: " getUrl + +dep :: String -> [String] -> [String] -> String +dep s a b = + (C.formatWith [C.magenta] s) <> " " <> case (diffOld <> diffNew) of + [] -> joinToString a + _ -> + (joinToString $ fmap (\x -> red (x `elem` diffOld) x) a) + <> "\n" + <> replicate 38 '-' + <> "\n" + <> " " + <> (joinToString $ fmap (\x -> green (x `elem` diffNew) x) b) + where + diffNew = b \\ a + diffOld = a \\ b + joinToString [] = "[]" + joinToString xs = intercalate "\n " $ sortBy (\x y -> head (toLower' x) `compare` head (toLower' y)) xs + red p x = if p then C.formatWith [C.red] x else x + green p x = if p then C.formatWith [C.green] x else x + +flags :: PackageName -> [Flag] -> [Flag] -> String +flags name a b = + (C.formatWith [C.magenta] "Flags:\n") <> " " <> case (diffOld <> diffNew) of + [] -> joinToString a + _ -> + (joinToString a) + <> "\n" + <> replicate 38 '-' + <> "\n" + <> " " + <> (joinToString b) + where + diffNew = b \\ a + diffOld = a \\ b + joinToString [] = "[]" + joinToString xs = prettyFlags [(name, xs)] diff --git a/diff/Main.hs b/diff/Main.hs new file mode 100644 --- /dev/null +++ b/diff/Main.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Main (main) where + +import qualified Colourista as C +import qualified Control.Exception as CE +import Control.Monad (when) +import qualified Data.Map as Map +import qualified Data.Text as T +import Diff +import Distribution.ArchHs.PP (prettyFlagAssignments) +import Distribution.ArchHs.Types + +main :: IO () +main = CE.catch @CE.IOException + ( do + Options {..} <- runArgsParser + + let isFlagEmpty = Map.null optFlags + when isFlagEmpty $ C.skipMessage "You didn't pass -f, different flag values may make difference in dependency resolving." + when (not isFlagEmpty) $ do + C.infoMessage "You assigned flags:" + putStrLn . prettyFlagAssignments $ optFlags + + C.infoMessage "Start running..." + runDiff optFlags (diffCabal optPackageName optVersionA optVersionB) >>= \case + Left x -> C.errorMessage $ "Runtime Error: " <> (T.pack . show $ x) + Right r -> putStrLn r >> C.successMessage "Success!" + ) + $ \e -> C.errorMessage $ "IOException: " <> (T.pack . show $ e) + +runDiff :: FlagAssignments -> Sem '[FlagAssignmentsEnv, WithMyErr, Embed IO, Final IO] a -> IO (Either MyException a) +runDiff flags = runFinal . embedToFinal . errorToIOFinal . (runReader flags) diff --git a/src/Data/Aeson/Ext.hs b/src/Data/Aeson/Ext.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Ext.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK hide #-} + +module Data.Aeson.Ext + ( generateJSONInstance, + parseJSONDrop, + toJSONDrop, + ) +where + +import Data.Aeson +import Data.Aeson.Types +import GHC.Generics (Generic, Rep) +import Language.Haskell.TH + +dropSize :: Type -> Q Int +dropSize (ConT n) = do + info <- reify n + case info of + (TyConI (DataD _ _ [] _ cons _)) -> go cons + (TyConI (NewtypeD _ _ _ _ con _)) -> go [con] + _ -> fail "Unsupported." + where + -- Try only the first record constructor + rec (x : _) = case x of + (RecC _ f) -> f + _ -> fail "Unsupported" + rec [] = fail "Unsupported" + go cons = do + let fields = rec cons + -- Find prefix from the first field + let (name, _, _) = head fields + let str = nameBase name + return . (+ 1) $ length str - length (dropWhile (/= '_') str) +dropSize _ = fail "Unsupported" + +generateToJSONInstance :: Name -> DecQ +generateToJSONInstance targetType = + conT targetType >>= dropSize >>= \s -> instanceD (cxt []) (appT (conT ''ToJSON) (conT targetType)) [gen_f $ fromIntegral s] + where + gen_f s = funD (mkName "toJSON") [clause [] (normalB (varE 'toJSONDrop `appE` litE (integerL s))) []] + +generateFromJSONInstance :: Name -> DecQ +generateFromJSONInstance targetType = + conT targetType >>= dropSize >>= \s -> instanceD (cxt []) (appT (conT ''FromJSON) (conT targetType)) [gen_f $ fromIntegral s] + where + gen_f s = funD (mkName "parseJSON") [clause [] (normalB (varE 'parseJSONDrop `appE` litE (integerL s))) []] + +generateJSONInstance :: Name -> Q [Dec] +generateJSONInstance name = do + from <- generateFromJSONInstance name + to <- generateToJSONInstance name + return [from, to] + +toJSONDrop :: + forall a. + (Generic a, GToJSON Zero (Rep a)) => + Int -> + a -> + Value +toJSONDrop prefix = + genericToJSON defaultOptions {fieldLabelModifier = drop prefix, omitNothingFields = True, sumEncoding = UntaggedValue} + +parseJSONDrop :: + forall a. + (Generic a, GFromJSON Zero (Rep a)) => + Int -> + Value -> + Parser a +parseJSONDrop prefix = genericParseJSON defaultOptions {fieldLabelModifier = drop prefix, sumEncoding = UntaggedValue} diff --git a/src/Distribution/ArchHs/Aur.hs b/src/Distribution/ArchHs/Aur.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/ArchHs/Aur.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Copyright: (c) 2020 berberman +-- SPDX-License-Identifier: MIT +-- Maintainer: berberman <1793913507@qq.com> +-- This module supports searching. +module Distribution.ArchHs.Aur + ( AurReply (..), + AurSearch (..), + AurInfo (..), + Aur, + searchByName, + infoByName, + isInAur, + aurToIO, + ) +where + +import Data.Aeson +import Data.Aeson.Ext +import Data.Text (Text, pack) +import Distribution.ArchHs.Utils +import Distribution.Types.PackageName (PackageName, unPackageName) +import GHC.Generics (Generic) +import Network.HTTP.Req +import Polysemy +import Polysemy.Req + +-- | AUR response +data AurReply a = AurReply + { r_version :: Int, + r_type :: String, + r_resultcount :: Int, + r_results :: [a] + } + deriving stock (Show, Generic) + +-- | AUR search result +data AurSearch = AurSearch + { s_ID :: Int, + s_Name :: String, + s_PackageBaseID :: Int, + s_PackageBase :: String, + s_Version :: String, + s_Description :: String, + s_URL :: String, + s_NumVotes :: Int, + s_Popularity :: Double, + s_OutOfDate :: Maybe Int, + s_Maintainer :: Maybe String, + s_FirstSubmitted :: Int, -- UTC + s_LastModified :: Int, -- UTC + s_URLPath :: String + } + deriving stock (Show, Generic) + +-- | AUR info result +data AurInfo = AurInfo + { i_ID :: Int, + i_Name :: String, + i_PackageBaseID :: Int, + i_PackageBase :: String, + i_Version :: String, + i_Description :: String, + i_URL :: String, + i_NumVotes :: Int, + i_Popularity :: Double, + i_OutOfDate :: Maybe Int, + i_Maintainer :: Maybe String, + i_FirstSubmitted :: Int, -- UTC + i_LastModified :: Int, -- UTC + i_URLPath :: String, + i_Depends :: Maybe [String], + i_MakeDepends :: Maybe [String], + i_OptDepends :: Maybe [String], + i_CheckDepends :: Maybe [String], + i_Conflicts :: Maybe [String], + i_Provides :: Maybe [String], + i_Replaces :: Maybe [String], + i_Groups :: Maybe [String], + i_License :: Maybe [String], + i_Keywords :: Maybe [String] + } + deriving stock (Show, Generic) + +instance (FromJSON a) => FromJSON (AurReply a) where + parseJSON (Object v) = + AurReply + <$> v .: "version" + <*> v .: "type" + <*> v .: "resultcount" + <*> v .: "results" + parseJSON _ = fail "Unable to parse AUR reply." + +instance (ToJSON a) => ToJSON (AurReply a) + +$(generateJSONInstance ''AurSearch) +$(generateJSONInstance ''AurInfo) + +-- | AUR Effect +data Aur m a where + -- | Serach a package from AUR + SearchByName :: String -> Aur m (Maybe AurSearch) + -- | Get package info from AUR + InfoByName :: String -> Aur m (Maybe AurInfo) + -- | Check whether a __haskell__ package exists in AUR + IsInAur :: PackageName -> Aur m Bool + +makeSem ''Aur + +baseURL :: Url 'Https +baseURL = https "aur.archlinux.org" /: "rpc" + +-- | Run 'Aur' effect. +aurToIO :: Member (Embed IO) r => Sem (Aur ': r) a -> Sem r a +aurToIO = interpret $ \case + (SearchByName name) -> do + let parms = + "v" =: ("5" :: Text) + <> "type" =: ("search" :: Text) + <> "by" =: ("name" :: Text) + <> "arg" =: (pack name) + r = req GET baseURL NoReqBody jsonResponse parms + response <- reqToIO r + let body :: AurReply AurSearch = responseBody response + return $ case r_resultcount body of + 1 -> Just . head $ r_results body + _ -> Nothing + (InfoByName name) -> do + let parms = + "v" =: ("5" :: Text) + <> "type" =: ("info" :: Text) + <> "by" =: ("name" :: Text) + <> "arg[]" =: (pack name) + r = req GET baseURL NoReqBody jsonResponse parms + response <- reqToIO r + let body :: AurReply AurInfo = responseBody response + return $ case r_resultcount body of + 1 -> Just . head $ r_results body + _ -> Nothing + (IsInAur name) -> do + result <- aurToIO . searchByName . fixName $ unPackageName name + return $ case result of + Just _ -> True + _ -> False diff --git a/src/Distribution/ArchHs/Community.hs b/src/Distribution/ArchHs/Community.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/ArchHs/Community.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_HADDOCK prune, ignore-exports #-} + +-- | Copyright: (c) 2020 berberman +-- SPDX-License-Identifier: MIT +-- Maintainer: berberman <1793913507@qq.com> +-- This module provides functios operating with @community.db@ of pacman. +module Distribution.ArchHs.Community + ( defaultCommunityPath, + loadProcessedCommunity, + isInCommunity, + ) +where + +import Conduit +import Control.Monad (when) +import qualified Data.Conduit.Tar as Tar +import qualified Data.Conduit.Zlib as Zlib +import Data.List (intercalate) +import Data.List.Split (splitOn) +import qualified Data.Set as Set +import Distribution.ArchHs.Types +import Distribution.ArchHs.Utils +import Distribution.Types.PackageName (PackageName, unPackageName) +import System.FilePath (()) + +-- | Default path to @community.db@. +defaultCommunityPath :: FilePath +defaultCommunityPath = "/" "var" "lib" "pacman" "sync" "community.db" + +loadCommunity :: + (MonadResource m, PrimMonad m, MonadThrow m) => + FilePath -> + ConduitT i FilePath m () +loadCommunity path = do + sourceFileBS path .| Zlib.ungzip .| Tar.untarChunks .| Tar.withEntries action + where + action header = + when (Tar.headerFileType header == Tar.FTNormal) $ + yield $ Tar.headerFilePath header + +cookCommunity :: (Monad m) => ConduitT FilePath FilePath m () +cookCommunity = mapC (go . (splitOn "-")) + where + go list = case length list of + 3 -> list !! 0 + s -> + if list !! 0 == "haskell" + then intercalate "-" . fst . splitAt (s - 3) . tail $ list + else intercalate "-" . fst . splitAt (s - 2) $ list + +-- | Load @community.db@ from @path@, removing @haskell-@ prefix. +loadProcessedCommunity :: (MonadUnliftIO m, PrimMonad m, MonadThrow m) => FilePath -> m CommunityDB +loadProcessedCommunity path = fmap Set.fromList $ runConduitRes $ loadCommunity path .| cookCommunity .| sinkList + +-- | Check if a package from hackage exists in archlinux community repo. +-- A name conversion occurs during the checking to fit 'loadProcessedCommunity'. +-- +-- >>> "aeson" --> "aeson" +-- >>> "Cabal" --> "cabal" +-- >>> "haskell-a" --> "a" +isInCommunity :: Member CommunityEnv r => PackageName -> Sem r Bool +isInCommunity name = + ask @CommunityDB >>= \db -> + return $ case splitOn "-" . unPackageName $ name of + ("haskell" : xs) -> intercalate "-" xs `elem` db + _ -> (toLower' $ unPackageName name) `elem` db diff --git a/src/Distribution/ArchHs/Core.hs b/src/Distribution/ArchHs/Core.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/ArchHs/Core.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | Copyright: (c) 2020 berberman +-- SPDX-License-Identifier: MIT +-- Maintainer: berberman <1793913507@qq.com> +-- The core functions of @arch-hs@. +module Distribution.ArchHs.Core + ( getDependencies, + cabalToPkgBuild, + evalConditionTree, + ) +where + +import qualified Algebra.Graph.Labelled.AdjacencyMap as G +import Data.List (intercalate, stripPrefix) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Distribution.ArchHs.Hackage +import Distribution.ArchHs.Local +import Distribution.ArchHs.PkgBuild +import Distribution.ArchHs.Types +import Distribution.ArchHs.Utils +import Distribution.Compiler (CompilerFlavor (..)) +import Distribution.PackageDescription +import Distribution.Pretty (prettyShow) +import Distribution.SPDX +import Distribution.System (Arch (X86_64), OS (Linux)) +import qualified Distribution.Types.BuildInfo.Lens as L +import Distribution.Types.CondTree (simplifyCondTree) +import Distribution.Types.Dependency (Dependency) +import Distribution.Types.PackageName (PackageName, unPackageName) +import Distribution.Types.UnqualComponentName (UnqualComponentName) +import Distribution.Types.Version (mkVersion) +import Distribution.Types.VersionRange +import Distribution.Utils.ShortText (fromShortText) + +archEnv :: FlagAssignment -> ConfVar -> Either ConfVar Bool +archEnv _ (OS Linux) = Right True +archEnv _ (OS _) = Right False +archEnv _ (Arch X86_64) = Right True +archEnv _ (Arch _) = Right False +archEnv _ (Impl GHC range) = Right $ withinRange (mkVersion [8, 10, 2]) range +archEnv _ (Impl _ _) = Right False +archEnv assignment f@(Flag f') = go f $ lookupFlagAssignment f' assignment + where + go _ (Just r) = Right r + go x Nothing = Left x + +-- | Simplify the condition tree from 'GenericPackageDescription' with given flag assignments and archlinux system assumption. +evalConditionTree :: + (Semigroup k, L.HasBuildInfo k, Member FlagAssignmentsEnv r) => + GenericPackageDescription -> + CondTree ConfVar [Dependency] k -> + Sem r BuildInfo +evalConditionTree cabal cond = do + flagAssignments <- ask + let name = getPkgName' cabal + packageFlags = genPackageFlags cabal + defaultFlagAssignments = + foldr (\f acc -> insertFlagAssignment (flagName f) (flagDefault f) acc) (mkFlagAssignment []) packageFlags + flagAssignment = case Map.lookup name flagAssignments of + Just f -> unFlagAssignment f + _ -> [] + flagNames = fmap fst flagAssignment + thisFlag = + mkFlagAssignment + . (<> flagAssignment) + . filter (\(fName, _) -> fName `notElem` flagNames) + $ (unFlagAssignment defaultFlagAssignments) + return $ (^. L.buildInfo) . snd $ simplifyCondTree (archEnv thisFlag) cond + +----------------------------------------------------------------------------- + +-- | Get dependencies of a package recursively. +-- All version constraints will be discarded, +-- and only packages depended by executables, libraries, and test suits will be collected. +getDependencies :: + Members [HackageEnv, FlagAssignmentsEnv, WithMyErr, DependencyRecord] r => + -- | Resolved + Set PackageName -> + -- | Skipped + [UnqualComponentName] -> + -- | Whether recursive + Bool -> + -- | Target + PackageName -> + Sem r (G.AdjacencyMap (Set DependencyType) PackageName) +getDependencies resolved skip recursive name = do + cabal <- getLatestCabal name + -- Ignore subLibraries + (libDeps, libToolsDeps) <- collectLibDeps cabal + (exeDeps, exeToolsDeps) <- collectExeDeps cabal skip + (testDeps, testToolsDeps) <- collectTestDeps cabal skip + -- Ignore benchmarks + -- (benchDeps, benchToolsDeps) <- collectBenchMarkDeps cabal skip + let uname :: (UnqualComponentName -> DependencyType) -> ComponentPkgList -> [(DependencyType, PkgList)] + uname cons list = zip (fmap (cons . fst) list) (fmap snd list) + + flatten :: [(DependencyType, PkgList)] -> [(DependencyType, PackageName)] + flatten list = mconcat $ fmap (\(t, pkgs) -> zip (repeat t) pkgs) list + + withThisName :: [(DependencyType, PackageName)] -> [(DependencyType, PackageName, PackageName)] + withThisName = fmap (\(t, pkg) -> (t, name, pkg)) + + ignored = filter (\x -> not $ x `elem` ignoreList || x == name || x `elem` resolved) + filterNot p = filter (not . p) + + currentLib = G.edges $ zip3 (repeat $ Set.singleton CLib) (repeat name) $ filterNot (`elem` ignoreList) libDeps + currentLibDeps = G.edges $ zip3 (repeat $ Set.singleton CLibBuildTools) (repeat name) $ filterNot (`elem` ignoreList) libToolsDeps + + runnableEdges k l = G.edges $ fmap (\(x, y, z) -> (Set.singleton x, y, z)) . withThisName . filterNot (\(_, x) -> x `elem` ignoreList) . flatten . uname k $ l + + currentExe = runnableEdges CExe exeDeps + currentExeTools = runnableEdges CExeBuildTools exeToolsDeps + currentTest = runnableEdges CTest testDeps + currentTestTools = runnableEdges CTestBuildTools testToolsDeps + + -- currentBench = runnableEdges Types.Benchmark benchDeps + -- currentBenchTools = runnableEdges BenchmarkBuildTools benchToolsDeps + + (<+>) = G.overlay + -- Only solve lib & exe deps recursively. + nextLib <- mapM (getDependencies (Set.insert name resolved) skip recursive) $ ignored libDeps + nextExe <- mapM (getDependencies (Set.insert name resolved) skip recursive) $ ignored . fmap snd . flatten . uname CExe $ exeDeps + return $ + currentLib + <+> currentLibDeps + <+> currentExe + <+> currentExeTools + <+> currentTest + <+> currentTestTools + -- <+> currentBench + -- <+> currentBenchTools + <+> if recursive + then (G.overlays nextLib) <+> (G.overlays nextExe) + else G.empty + +collectLibDeps :: Members [FlagAssignmentsEnv, DependencyRecord] r => GenericPackageDescription -> Sem r (PkgList, PkgList) +collectLibDeps cabal = do + case cabal & condLibrary of + Just lib -> do + let name = getPkgName' cabal + info <- evalConditionTree cabal lib + let libDeps = fmap unDepV $ buildDependsIfBuild info + toolDeps = fmap unExeV $ buildToolDependsIfBuild info + updateDependencyRecord name libDeps + updateDependencyRecord name toolDeps + return (fmap fst libDeps, fmap fst toolDeps) + Nothing -> return ([], []) + +collectRunnableDeps :: + (Semigroup k, L.HasBuildInfo k, Members [FlagAssignmentsEnv, DependencyRecord] r) => + (GenericPackageDescription -> [(UnqualComponentName, CondTree ConfVar [Dependency] k)]) -> + GenericPackageDescription -> + [UnqualComponentName] -> + Sem r (ComponentPkgList, ComponentPkgList) +collectRunnableDeps f cabal skip = do + let exes = cabal & f + name = getPkgName' cabal + info <- filter (not . (`elem` skip) . fst) . zip (exes <&> fst) <$> mapM (evalConditionTree cabal . snd) exes + let runnableDeps = info <&> ((_2 %~) $ fmap unDepV . buildDependsIfBuild) + toolDeps = info <&> ((_2 %~) $ fmap unExeV . buildToolDependsIfBuild) + k = fmap (\(c, l) -> (c, fmap fst l)) + mapM_ (updateDependencyRecord name) $ fmap snd runnableDeps + mapM_ (updateDependencyRecord name) $ fmap snd toolDeps + return (k runnableDeps, k toolDeps) + +collectExeDeps :: Members [FlagAssignmentsEnv, DependencyRecord] r => GenericPackageDescription -> [UnqualComponentName] -> Sem r (ComponentPkgList, ComponentPkgList) +collectExeDeps = collectRunnableDeps condExecutables + +collectTestDeps :: Members [FlagAssignmentsEnv, DependencyRecord] r => GenericPackageDescription -> [UnqualComponentName] -> Sem r (ComponentPkgList, ComponentPkgList) +collectTestDeps = collectRunnableDeps condTestSuites + +updateDependencyRecord :: Member DependencyRecord r => PackageName -> [(PackageName, VersionRange)] -> Sem r () +updateDependencyRecord parent deps = modify' $ Map.insertWith (<>) parent deps + +-- collectBenchMarkDeps :: Members [HackageEnv, FlagAssignmentEnv] r => GenericPackageDescription -> [UnqualComponentName] -> Sem r (ComponentPkgList, ComponentPkgList) +-- collectBenchMarkDeps = collectRunnableDeps condBenchmarks + +----------------------------------------------------------------------------- + +-- | Generate 'PkgBuild' for a 'SolvedPackage'. +cabalToPkgBuild :: Members [HackageEnv, FlagAssignmentsEnv, WithMyErr] r => SolvedPackage -> Sem r PkgBuild +cabalToPkgBuild pkg = do + let name = pkg ^. pkgName + cabal <- packageDescription <$> (getLatestCabal name) + let _hkgName = pkg ^. pkgName & unPackageName + rawName = toLower' _hkgName + _pkgName = maybe rawName id $ stripPrefix "haskell-" rawName + _pkgVer = prettyShow $ getPkgVersion cabal + _pkgDesc = fromShortText $ synopsis cabal + getL (NONE) = "" + getL (License e) = getE e + getE (ELicense (ELicenseId x) _) = show . mapLicense $ x + getE (ELicense (ELicenseIdPlus x) _) = show . mapLicense $ x + getE (ELicense (ELicenseRef x) _) = "custom:" <> licenseRef x + getE (EAnd x y) = getE x <> " " <> getE y + getE (EOr x y) = getE x <> " " <> getE y + + _license = getL . license $ cabal + _enableCheck = any id $ pkg ^. pkgDeps & mapped %~ (\dep -> selectDepKind Test dep && dep ^. depName == pkg ^. pkgName) + depends = pkg ^. pkgDeps ^.. each . filtered (\x -> notMyself x && notInGHCLib x && (selectDepKind Lib x || selectDepKind Exe x)) + makeDepends = + pkg ^. pkgDeps + ^.. each + . filtered + ( \x -> + x `notElem` depends + && notMyself x + && notInGHCLib x + && ( selectDepKind LibBuildTools x + || selectDepKind Test x + || selectDepKind TestBuildTools x + ) + ) + depsToString deps = deps <&> (wrap . fixName . unPackageName . _depName) & intercalate " " + _depends = depsToString depends + _makeDepends = depsToString makeDepends + _url = getUrl cabal + wrap s = '\'' : s <> "\'" + notInGHCLib x = (x ^. depName) `notElem` ghcLibList + notMyself x = x ^. depName /= name + selectDepKind k x = k `elem` (x ^. depType & mapped %~ dependencyTypeToKind) + return PkgBuild {..} diff --git a/src/Distribution/ArchHs/Hackage.hs b/src/Distribution/ArchHs/Hackage.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/ArchHs/Hackage.hs @@ -0,0 +1,101 @@ +-- | Copyright: (c) 2020 berberman +-- SPDX-License-Identifier: MIT +-- Maintainer: berberman <1793913507@qq.com> +-- This module provides functions operating with 'HackageDB' and 'GenericPackageDescription'. +module Distribution.ArchHs.Hackage + ( lookupHackagePath, + loadHackageDB, + insertDB, + parseCabalFile, + getLatestCabal, + getCabal, + getPackageFlag, + traverseHackage, + ) +where + +import Control.Applicative (Alternative ((<|>))) +import qualified Data.ByteString as BS +import qualified Data.Map as Map +import Data.Maybe (fromJust) +import Distribution.ArchHs.Types +import Distribution.ArchHs.Utils +import Distribution.Hackage.DB +import Distribution.PackageDescription.Parsec (parseGenericPackageDescriptionMaybe) +import Distribution.Types.Flag (Flag) +import Distribution.Types.GenericPackageDescription (GenericPackageDescription, genPackageFlags, packageDescription) +import Distribution.Types.PackageName (PackageName) +import Distribution.Version (Version, nullVersion) +import System.Directory +import System.FilePath (()) + +-- | Look up hackage tarball path from @~/.cabal@. +-- Arbitrary hackage mirror is potential to be selected. +-- Preferred to @01-index.tar@, whereas fallback to @00-index.tar@. +lookupHackagePath :: IO FilePath +lookupHackagePath = do + home <- (\d -> d ".cabal" "packages") <$> getHomeDirectory + subs <- fmap (home ) <$> listDirectory home + legacy <- findFile subs "00-index.tar" + new <- findFile subs "01-index.tar" + case new <|> legacy of + Just x -> return x + Nothing -> fail $ "Unable to find hackage index tarball from " <> show subs + +-- | Read and parse hackage index tarball. +loadHackageDB :: FilePath -> IO HackageDB +loadHackageDB = readTarball Nothing + +-- | Insert a 'GenericPackageDescription' into 'HackageDB'. +insertDB :: GenericPackageDescription -> HackageDB -> HackageDB +insertDB cabal db = Map.insert name packageData db + where + name = getPkgName $ packageDescription cabal + version = getPkgVersion $ packageDescription cabal + versionData = VersionData cabal $ Map.empty + packageData = Map.singleton version versionData + +-- | Read and parse @.cabal@ file. +parseCabalFile :: FilePath -> IO GenericPackageDescription +parseCabalFile path = do + bs <- BS.readFile path + case parseGenericPackageDescriptionMaybe bs of + Just x -> return x + _ -> fail $ "Failed to parse .cabal from " <> path + +-- | Get the latest 'GenericPackageDescription'. +getLatestCabal :: Members [HackageEnv, WithMyErr] r => PackageName -> Sem r GenericPackageDescription +getLatestCabal name = do + db <- ask @HackageDB + case Map.lookup name db of + (Just m) -> case Map.lookupMax m of + Just (_, vdata) -> return $ vdata & cabalFile + Nothing -> throw $ VersionError name nullVersion + Nothing -> throw $ PkgNotFound name + +-- | Get 'GenericPackageDescription' with a specific version. +getCabal :: Members [HackageEnv, WithMyErr] r => PackageName -> Version -> Sem r GenericPackageDescription +getCabal name version = do + db <- ask @HackageDB + case Map.lookup name db of + (Just m) -> case Map.lookup version m of + Just vdata -> return $ vdata & cabalFile + Nothing -> throw $ VersionError name version + Nothing -> throw $ PkgNotFound name + +-- | Get flags of a package. +getPackageFlag :: Members [HackageEnv, WithMyErr] r => PackageName -> Sem r [Flag] +getPackageFlag name = do + cabal <- getLatestCabal name + return $ cabal & genPackageFlags + +-- | Traverse hackage packages. +traverseHackage :: (Member HackageEnv r, Applicative f) => ((PackageName, GenericPackageDescription) -> f b) -> Sem r (f [b]) +traverseHackage f = do + db <- ask @HackageDB + let x = + Map.toList + . Map.map (cabalFile . (^. _2) . fromJust) + . Map.filter (/= Nothing) + $ Map.map Map.lookupMax db + return $ traverse f x diff --git a/src/Distribution/ArchHs/Local.hs b/src/Distribution/ArchHs/Local.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/ArchHs/Local.hs @@ -0,0 +1,74 @@ +-- | Copyright: (c) 2020 berberman +-- SPDX-License-Identifier: MIT +-- Maintainer: berberman <1793913507@qq.com> +-- This module maintains names of packages which are need special treatments during dependency resolving or PKGBUILD generating. +module Distribution.ArchHs.Local + ( ignoreList, + ghcLibList, + ) +where + +import Distribution.ArchHs.Types +import Distribution.Types.PackageName + +-- | Packages should be dropped in dependency resolving. +ignoreList :: PkgList +ignoreList = + mkPackageName + <$> [ "unbuildable", + "invalid-cabal-flag-settings", + "par-classes", + "fail", + "integer-simple", + "bytestring-builder", + "nats", + "old-time", + "old-locale", + "integer", + "unsupported-ghc-version", + "base", + "ghc", + "ghc-prim", + "ghcjs-prim", + "ghc-bignum", + "hans", + "Win32" + ] + +-- | Packages already provided by . +ghcLibList :: PkgList +ghcLibList = + mkPackageName + <$> [ "array", + "base", + "binary", + "bytestring", + "Cabal", + "containers", + "deepseq", + "directory", + "exceptions", + "filepath", + "ghc-boot", + "ghc-boot-th", + "ghc-compact", + "ghc-heap", + "ghci", + "ghc-prim", + "haskeline", + "hpc", + "integer-gmp", + "libiserv", + "mtl", + "parsec", + "pretty", + "process", + "stm", + "template-haskell", + "terminfo", + "text", + "time", + "transformers", + "unix", + "xhtml" + ] diff --git a/src/Distribution/ArchHs/PP.hs b/src/Distribution/ArchHs/PP.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/ArchHs/PP.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_HADDOCK hide #-} + +module Distribution.ArchHs.PP + ( prettySkip, + prettyFlagAssignments, + prettyFlags, + prettySolvedPkgs, + prettyDeps, + ) +where + +import qualified Colourista as C +import Data.List (intercalate) +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Distribution.ArchHs.Types +import Distribution.PackageDescription + ( Flag (flagDefault, flagDescription, flagManual, flagName), + FlagAssignment, + unFlagAssignment, + unFlagName, + ) +import Distribution.Types.PackageName + ( PackageName, + unPackageName, + ) + +prettySkip :: [String] -> String +prettySkip = C.formatWith [C.magenta] . intercalate ", " + +prettyFlagAssignments :: Map.Map PackageName FlagAssignment -> String +prettyFlagAssignments m = mconcat $ fmap (fmap (\(n, a) -> C.formatWith [C.magenta] (unPackageName n) <> "\n" <> C.formatWith [C.indent 4] (prettyFlagAssignment a))) Map.toList m + +prettyFlagAssignment :: FlagAssignment -> String +prettyFlagAssignment m = mconcat $ fmap (\(n, v) -> "⚐ " <> C.formatWith [C.yellow] (unFlagName n) <> " : " <> C.formatWith [C.cyan] (show v) <> "\n") $ unFlagAssignment m + +prettyDeps :: [PackageName] -> String +prettyDeps list = + mconcat $ + fmap (\(i, n) -> show @Int i <> ". " <> unPackageName n <> "\n") $ + zip [1 ..] $ + reverse list + +prettyFlags :: [(PackageName, [Flag])] -> String +prettyFlags = mconcat . fmap (\(name, flags) -> (C.formatWith [C.magenta] $ unPackageName name <> "\n") <> mconcat (fmap (C.formatWith [C.indent 4] . prettyFlag) flags)) + +prettyFlag :: Flag -> String +prettyFlag f = "⚐ " <> C.formatWith [C.yellow] name <> ":\n" <> mconcat (fmap (C.formatWith [C.indent 6] . (<> "\n")) $ ["description: " <> desc, "default: " <> def, "isManual: " <> manual]) + where + name = unFlagName . flagName $ f + desc = flagDescription f + def = show $ flagDefault f + manual = show $ flagManual f + +prettySolvedPkgs :: [SolvedPackage] -> String +prettySolvedPkgs = con . mconcat . fmap prettySolvedPkg + +prettySolvedPkg :: SolvedPackage -> [(String, String)] +prettySolvedPkg SolvedPackage {..} = + (C.formatWith [C.bold, C.yellow] (unPackageName _pkgName), C.formatWith [C.red] " ✘") : + ( fmap + ( \(i :: Int, SolvedDependency {..}) -> + let prefix = if i == length _pkgDeps then " └─" else " ├─" + in case _depProvider of + (Just x) -> ((C.formatWith [C.green] $ (T.unpack prefix) <> unPackageName _depName <> " " <> show _depType), ((C.formatWith [C.green] "✔ ") <> (C.formatWith [C.cyan] $ "[" <> show x <> "]"))) + _ -> (C.formatWith [C.bold, C.yellow] $ (T.unpack prefix) <> unPackageName _depName <> " " <> show _depType, C.formatWith [C.red] " ✘") + ) + (zip [1 ..] _pkgDeps) + ) +prettySolvedPkg ProvidedPackage {..} = [((C.formatWith [C.green] $ unPackageName _pkgName), ((C.formatWith [C.green] "✔ ") <> (C.formatWith [C.cyan] $ "[" <> show _pkgProvider <> "]")))] + +con :: [(String, String)] -> String +con l = mconcat complemented + where + maxL = maximum $ fmap (length . fst) l + complemented = fmap (\(x, y) -> (x <> (replicate (maxL - length x) ' ') <> y <> "\n")) l diff --git a/src/Distribution/ArchHs/PkgBuild.hs b/src/Distribution/ArchHs/PkgBuild.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/ArchHs/PkgBuild.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Copyright: (c) 2020 berberman +-- SPDX-License-Identifier: MIT +-- Maintainer: berberman <1793913507@qq.com> +-- Template of PKGBUILD file. +module Distribution.ArchHs.PkgBuild + ( PkgBuild (..), + ArchLicense, + mapLicense, + applyTemplate, + felixTemplate, + ) +where + +import Data.Text (Text, pack, unpack) +import Distribution.SPDX.LicenseId +import NeatInterpolation (text) + +-- | PkgBuild data type, representing needed informations in filling the 'felixTemplate'. +data PkgBuild = PkgBuild + { -- | Field @_hkgName@. + _hkgName :: String, + -- | Field @pkgname@. + _pkgName :: String, + -- | Field @pkgver@. + _pkgVer :: String, + -- | Field @pkgdesc@. + _pkgDesc :: String, + -- | Field @@url. + _url :: String, + -- | Field @license@. + _license :: String, + -- | Array @depends@, which has been joined into 'String'. + _depends :: String, + -- | Array @makedepends@, which has been joined into 'String'. + _makeDepends :: String, + -- | Whether generate @check()@ bash function in PKGBUILD. + _enableCheck :: Bool + } + +-- | Licenses available in . +data ArchLicense + = AGPL3 + | Apache + | Artistic2_0 + | CDDL + | CPL + | EPL + | FDL1_2 + | FDL1_3 + | GPL2 + | GPL3 + | LGPL2_1 + | LGPL3 + | LPPL + | MPL + | MPL2 + | PHP + | PSF + | PerlArtistic + | RUBY + | Unlicense + | W3C + | ZPL + | Custom String + +instance Show ArchLicense where + show AGPL3 = "AGPL" + show Apache = "Apache" + show Artistic2_0 = "Artistic2.0" + show CDDL = "CDDL" + show CPL = "CPL" + show EPL = "EPL" + show FDL1_2 = "FDL1.2" + show FDL1_3 = "FDL1.3" + show GPL2 = "GPL2" + show GPL3 = "GPL3" + show LGPL2_1 = "LGPL2.1" + show LGPL3 = "LGPL3" + show LPPL = "LPPL" + show MPL = "MPL" + show MPL2 = "MPL2" + show PHP = "PHP" + show PSF = "PSF" + show PerlArtistic = "PerlArtistic" + show RUBY = "RUBY" + show Distribution.ArchHs.PkgBuild.Unlicense = "Unlicense" + show Distribution.ArchHs.PkgBuild.W3C = "W3C" + show ZPL = "ZPL" + show (Custom x) = "custom:" <> x + +-- | Map 'LicenseId' to 'ArchLicense'. License not provided by system will be mapped to @custom:...@. +mapLicense :: LicenseId -> ArchLicense +mapLicense AGPL_3_0_only = AGPL3 +mapLicense Apache_2_0 = Apache +mapLicense Artistic_2_0 = Artistic2_0 +mapLicense CDDL_1_0 = CDDL +mapLicense CPL_1_0 = CPL +mapLicense EPL_1_0 = EPL +mapLicense GFDL_1_2_only = FDL1_2 +mapLicense GFDL_1_3_only = FDL1_3 +mapLicense GPL_2_0_only = GPL2 +mapLicense GPL_3_0_only = GPL3 +mapLicense LGPL_2_1_only = LGPL2_1 +mapLicense LGPL_3_0_only = LGPL3 +mapLicense LPPL_1_3c = LPPL +mapLicense MPL_1_0 = MPL +mapLicense MPL_2_0 = MPL2 +mapLicense PHP_3_01 = PHP +mapLicense Python_2_0 = PSF +mapLicense Artistic_1_0_Perl = PerlArtistic +mapLicense Ruby = RUBY +mapLicense ZPL_2_1 = ZPL +mapLicense Distribution.SPDX.LicenseId.Unlicense = Distribution.ArchHs.PkgBuild.Unlicense +mapLicense Distribution.SPDX.LicenseId.W3C = Distribution.ArchHs.PkgBuild.W3C +mapLicense BSD_3_Clause = Custom "BSD3" +mapLicense x = Custom $ show x + +-- | Apply 'PkgBuild' to 'felixTemplate'. +applyTemplate :: PkgBuild -> String +applyTemplate PkgBuild {..} = + unpack $ + felixTemplate + (pack _hkgName) + (pack _pkgName) + (pack _pkgVer) + (pack _pkgDesc) + (pack _url) + (pack _license) + (pack _depends) + (pack _makeDepends) + (if _enableCheck then check else "\n") + +-- | Text of @check()@ function. +check :: Text +check = + [text| + check() { + cd $$_hkgname-$$pkgver + runhaskell Setup test + } +|] + +-- | A fixed template of haskell package in archlinux. See . +felixTemplate :: Text -> Text -> Text -> Text -> Text -> Text -> Text -> Text -> Text -> Text +felixTemplate hkgname pkgname pkgver pkgdesc url license depends makedepends checkF = + [text| + # This file was generated by arch-hs, please check it manually. + # Maintainer: Your Name + + _hkgname=$hkgname + pkgname=haskell-$pkgname + pkgver=$pkgver + pkgrel=1 + pkgdesc="$pkgdesc" + url="$url" + license=("$license") + arch=('x86_64') + depends=('ghc-libs' $depends) + makedepends=('ghc' $makedepends) + source=("https://hackage.haskell.org/packages/archive/$$_hkgname/$$pkgver/$$_hkgname-$$pkgver.tar.gz") + sha256sums=('SKIP') + + prepare(){ + cd $$_hkgname-$$pkgver + } + + build() { + cd $$_hkgname-$$pkgver + + runhaskell Setup configure -O --enable-shared --enable-executable-dynamic --disable-library-vanilla \ + --prefix=/usr --docdir=/usr/share/doc/$$pkgname --enable-tests \ + --dynlibdir=/usr/lib --libsubdir=\$$compiler/site-local/\$$pkgid \ + --ghc-option=-optl-Wl\,-z\,relro\,-z\,now \ + --ghc-option='-pie' + + runhaskell Setup build + runhaskell Setup register --gen-script + runhaskell Setup unregister --gen-script + sed -i -r -e "s|ghc-pkg.*update[^ ]* |&'--force' |" register.sh + sed -i -r -e "s|ghc-pkg.*unregister[^ ]* |&'--force' |" unregister.sh + } + + $checkF + + package() { + cd $$_hkgname-$$pkgver + + install -D -m744 register.sh "$$pkgdir"/usr/share/haskell/register/$$pkgname.sh + install -D -m744 unregister.sh "$$pkgdir"/usr/share/haskell/unregister/$$pkgname.sh + runhaskell Setup copy --destdir="$$pkgdir" + install -D -m644 "LICENSE" "$${pkgdir}/usr/share/licenses/$${pkgname}/LICENSE" + rm -f "$${pkgdir}/usr/share/doc/$${pkgname}/LICENSE" + } +|] diff --git a/src/Distribution/ArchHs/PkgDesc.hs b/src/Distribution/ArchHs/PkgDesc.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/ArchHs/PkgDesc.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | Copyright: (c) 2020 berberman +-- SPDX-License-Identifier: MIT +-- Maintainer: berberman <1793913507@qq.com> +-- This module provides parser of @desc@ file in pacman db. +module Distribution.ArchHs.PkgDesc + ( PkgDesc (..), + DescParser, + descParser, + descFieldsParser, + runDescParser, + ) +where + +import qualified Data.Map.Strict as Map +import Data.Void (Void) +import Text.Megaparsec +import Text.Megaparsec.Char + +-- | A parser takes 'String' as input, without user state. +type DescParser = Parsec Void String + +-- | Package description file of a installed system package, +-- which lies in @repo.db@ file. +data PkgDesc = PkgDesc + { name :: String, + version :: String, + desc :: String, + url :: String, + license :: String, + depends :: [String], + makeDepends :: [String] + } + +-- Common fields +{- fieldList = + [ "FILENAME", + "NAME", + "BASE", + "VERSION", + "DESC", + "CSIZE", + "ISIZE", + "URL", + "LICENSE", + "ARCH", + "BUILDDATE", + "PACKAGER", + "DEPENDS", + "MAKEDEPENDS", + "PROVIDES", + "OPTDEPENDS", + "REPLACES", + "CONFLICTS" + ] -} + +-- | Parse fields of @desc@. +descFieldsParser :: DescParser (Map.Map String [String]) +descFieldsParser = + Map.fromList + <$> ( do + sep + field <- many (upperChar <|> digitChar) + sep + _ <- newline + content <- manyTill line (lookAhead sep <|> () <$ eol <|> eof) + return (field, content) + ) + `manyTill` eof + where + sep = () <$ char '%' + line = manyTill anySingle newline + +-- | Parse a desc file. +descParser :: DescParser PkgDesc +descParser = + descFieldsParser + >>= ( \fields -> do + name <- lookupSingle fields "NAME" + version <- lookupSingle fields "VERSION" + desc <- lookupSingle fields "DESC" + url <- lookupSingle fields "URL" + license <- lookupSingle fields "LICENSE" + depends <- lookupList fields "DEPENDS" + makeDepends <- lookupList fields "MAKEDEPENDS" + return PkgDesc {..} + ) + where + lookupSingle fields f = case Map.lookup f fields of + (Just x) -> case x of + (e : _) -> return e + _ -> fail $ "Expect a singleton " <> f + _ -> fail $ "Unable to find field " <> f + lookupList fields f = return $ case Map.lookup f fields of + (Just x) -> x + _ -> [] + +-- | Run the desc parser. +runDescParser :: String -> Either (ParseErrorBundle String Void) PkgDesc +runDescParser = parse descParser "Desc" diff --git a/src/Distribution/ArchHs/Types.hs b/src/Distribution/ArchHs/Types.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/ArchHs/Types.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_HADDOCK ignore-exports #-} + +-- | Copyright: (c) 2020 berberman +-- SPDX-License-Identifier: MIT +-- Maintainer: berberman <1793913507@qq.com> +-- Types used in this project. +module Distribution.ArchHs.Types + ( PkgList, + ComponentPkgList, + CommunityDB, + HackageEnv, + CommunityEnv, + FlagAssignmentsEnv, + WithMyErr, + MyException (..), + DependencyType (..), + DependencyKind (..), + DependencyProvider (..), + SolvedPackage (..), + SolvedDependency (..), + FlagAssignments, + depProvider, + pkgProvider, + pkgName, + pkgDeps, + depName, + depType, + DependencyRecord, + module Polysemy, + module Polysemy.Error, + module Polysemy.Reader, + module Polysemy.State, + module Lens.Micro, + ) +where + +import Control.DeepSeq (NFData) +import Data.Map.Strict (Map) +import Data.Set (Set) +import Distribution.Hackage.DB (HackageDB) +import Distribution.PackageDescription (FlagAssignment) +import Distribution.Pretty (prettyShow) +import Distribution.Types.PackageName (PackageName, unPackageName) +import Distribution.Types.UnqualComponentName (UnqualComponentName, unUnqualComponentName) +import Distribution.Types.Version (Version) +import Distribution.Version (VersionRange) +import GHC.Generics (Generic) +import Lens.Micro +import Lens.Micro.TH (makeLenses) +import Polysemy +import Polysemy.Error +import Polysemy.Reader +import Polysemy.State + +-- | A list of 'PackageName'. +type PkgList = [PackageName] + +-- | A list of component represented by 'UnqualComponentName' and its dependencies collected in a 'PkgList'. +type ComponentPkgList = [(UnqualComponentName, PkgList)] + +-- | Representation of @cummunity.db@. +type CommunityDB = Set String + +-- | Reader effect of 'HackageDB'. +type HackageEnv = Reader HackageDB + +-- | Reader effect of 'CommunityDB'. +type CommunityEnv = Reader CommunityDB + +-- | A map of packages with their 'FlagAssignment'. +type FlagAssignments = Map PackageName FlagAssignment + +-- | Reader effect of a map, associating 'PackageName' with its 'FlagAssignment'. +type FlagAssignmentsEnv = Reader FlagAssignments + +-- | Unused state effect. +type DependencyRecord = State (Map PackageName [(PackageName, VersionRange)]) + +-- | Error effect of 'MyException'. +type WithMyErr = Error MyException + +-- | Custom exception used in this project. +data MyException + = PkgNotFound PackageName + | VersionError PackageName Version + | TargetExist PackageName DependencyProvider + | LicenseError PackageName + deriving stock (Eq) + +instance Show MyException where + show (PkgNotFound name) = "Unable to find [" <> unPackageName name <> "]" + show (VersionError name version) = "Unable to find [" <> unPackageName name <> "-" <> prettyShow version <> "]" + show (TargetExist name provider) = "Target [" <> unPackageName name <> "] has been provided by " <> show provider + show (LicenseError name) = "Unable to find the license of [" <> unPackageName name <> "]" + +-- | The type of a dependency. Who requires this? +data DependencyType + = -- | By a /executable/. + CExe UnqualComponentName + | -- | By the /build tools/ of a /executable/. + CExeBuildTools UnqualComponentName + | -- | By a /library/. + CLib + | -- | By a /test suit/. + CTest UnqualComponentName + | -- | By a /benchmark/. + CBenchmark UnqualComponentName + | -- | By the /build tools/ of a /library/. + CLibBuildTools + | -- | By the /build tools/ of a /test suit/. + CTestBuildTools UnqualComponentName + | -- | By the /build tools/ of a /benchmark/. + CBenchmarkBuildTools UnqualComponentName + deriving stock (Eq, Ord, Generic) + deriving anyclass (NFData) + +-- | Tags of data constructors of 'DependencyType'. +data DependencyKind + = Exe + | ExeBuildTools + | Lib + | Test + | Benchmark + | LibBuildTools + | TestBuildTools + | BenchmarkBuildTools + deriving stock (Eq) + +instance Show DependencyType where + show (CExe x) = unUnqualComponentName x <> " :: Exe" + show (CExeBuildTools x) = unUnqualComponentName x <> " :: ExeBuildTools" + show (CTest x) = unUnqualComponentName x <> " :: Test" + show (CBenchmark x) = unUnqualComponentName x <> " :: Benchmark" + show (CTestBuildTools x) = unUnqualComponentName x <> " :: TestBuildTools" + show (CBenchmarkBuildTools x) = unUnqualComponentName x <> " :: BenchmarkBuildTools" + show CLib = "Lib" + show CLibBuildTools = "LibBuildTools" + +-- | Provider of a dependency. +data DependencyProvider = ByCommunity | ByAur + deriving stock (Eq, Generic) + deriving anyclass (NFData) + +instance Show DependencyProvider where + show ByCommunity = "community" + show ByAur = "aur" + +-- | A solved dependency, holden by 'SolvedPackage'. +data SolvedDependency = SolvedDependency + { -- | Provider of this dependency. + _depProvider :: Maybe DependencyProvider, + -- | Name of the dependency. + _depName :: PackageName, + -- | Types of the dependency. + _depType :: [DependencyType] + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + +-- | A solved package collected from dgraph. This data type is not designed to be recursively, +-- thus the element type of '_pkgDeps' is 'SolvedDependency', rather than another 'SolvedPackage'. +data SolvedPackage + = -- | A package which has been provided by somebody, so there is no need to expand its dependencies. + ProvidedPackage + { -- | Package name. + _pkgName :: PackageName, + -- | Package provider. (The name of 'DependencyProvider' may be confusing...) + _pkgProvider :: DependencyProvider + } + | -- | A package with its dependencies. + SolvedPackage + { -- | Package name. + _pkgName :: PackageName, + -- | Package dependencies. + _pkgDeps :: [SolvedDependency] + } + deriving stock (Show, Eq, Generic) + deriving anyclass (NFData) + +makeLenses ''SolvedDependency +makeLenses ''SolvedPackage diff --git a/src/Distribution/ArchHs/Utils.hs b/src/Distribution/ArchHs/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/ArchHs/Utils.hs @@ -0,0 +1,120 @@ +-- | Copyright: (c) 2020 berberman +-- SPDX-License-Identifier: MIT +-- Maintainer: berberman <1793913507@qq.com> +-- Miscellaneous functions used crossing modules. +module Distribution.ArchHs.Utils + ( getPkgName, + getPkgName', + getPkgVersion, + toLower', + dependencyTypeToKind, + unExe, + unExeV, + unDepV, + fixName, + getUrl, + getTwo, + buildDependsIfBuild, + buildToolDependsIfBuild, + ) +where + +import Control.Applicative (Alternative ((<|>))) +import Control.Monad ((<=<)) +import Data.Char (toLower) +import Data.List.Split (splitOn) +import Distribution.ArchHs.Types +import Distribution.PackageDescription + ( GenericPackageDescription, + PackageDescription, + homepage, + package, + packageDescription, + repoLocation, + sourceRepos, + ) +import Distribution.Types.BuildInfo +import Distribution.Types.Dependency +import Distribution.Types.ExeDependency (ExeDependency (..)) +import qualified Distribution.Types.PackageId as I +import Distribution.Types.PackageName (PackageName, unPackageName) +import Distribution.Utils.ShortText (fromShortText) +import Distribution.Version (Version, VersionRange) + +-- | Extract the 'PackageName' of a 'ExeDependency'. +unExe :: ExeDependency -> PackageName +unExe (ExeDependency name _ _) = name + +-- | Extract the 'PackageName' and 'VersionRange' of a 'ExeDependency'. +unExeV :: ExeDependency -> (PackageName, VersionRange) +unExeV (ExeDependency name _ v) = (name, v) + +-- | Extract the 'PackageName' and 'VersionRange' of a 'Dependency'. +unDepV :: Dependency -> (PackageName, VersionRange) +unDepV dep = (depPkgName dep, depVerRange dep) + +-- | Extract the package name from 'PackageDescription'. +getPkgName :: PackageDescription -> PackageName +getPkgName = I.pkgName . package + +-- | Extract the package from 'GenericPackageDescription'. +getPkgName' :: GenericPackageDescription -> PackageName +getPkgName' = I.pkgName . package . packageDescription + +-- | Extract the package version from 'PackageDescription'. +getPkgVersion :: PackageDescription -> Version +getPkgVersion = I.pkgVersion . package + +-- | Extract the url from 'PackageDescription'. +-- It tries 'homepage', the head of 'sourceRepos', and finally fallback into hackage website. +getUrl :: PackageDescription -> String +getUrl cabal = fromJust $ home <|> vcs <|> fallback + where + f "" = Nothing + f x = Just x + fromJust (Just x) = x + fromJust _ = fail "Impossible." + safeHead [] = Nothing + safeHead (x : _) = Just x + home = f . fromShortText . homepage $ cabal + vcs = repoLocation <=< safeHead . sourceRepos $ cabal + fallback = Just $ "https://hackage.haskell.org/package/" <> (unPackageName $ getPkgName cabal) + +-- | Convert the hackage name into archlinux package name follow the convention. +-- +-- >>> fixName "haskell-A" +-- "haskell-a" +-- +-- >>> fixName "QuickCheck" +-- "haskell-quickcheck" +fixName :: String -> String +fixName s = case splitOn "-" s of + ("haskell" : _) -> toLower' s + _ -> "haskell-" <> toLower' s + +-- | Lower each 'Char's in 'String'. +toLower' :: String -> String +toLower' = fmap toLower + +-- | Map 'DependencyType' with its data constructor tag 'DependencyKind'. +dependencyTypeToKind :: DependencyType -> DependencyKind +dependencyTypeToKind (CExe _) = Exe +dependencyTypeToKind (CExeBuildTools _) = ExeBuildTools +dependencyTypeToKind (CLib) = Lib +dependencyTypeToKind (CTest _) = Test +dependencyTypeToKind (CBenchmark _) = Benchmark +dependencyTypeToKind (CLibBuildTools) = LibBuildTools +dependencyTypeToKind (CTestBuildTools _) = TestBuildTools +dependencyTypeToKind (CBenchmarkBuildTools _) = BenchmarkBuildTools + +-- | Apply a @Getting@ to two values respectively, and get the result as a pair. +getTwo :: Getting b s b -> s -> s -> (b, b) +getTwo l a b = (a, b) & both %~ (^. l) + +-- | Same as 'targetBuildDepends', but check if this is 'buildable'. +buildDependsIfBuild :: BuildInfo -> [Dependency] +buildDependsIfBuild info = if buildable info then targetBuildDepends info else [] + +-- | Same as 'buildToolDepends', but check if this is 'buildable'. +buildToolDependsIfBuild :: BuildInfo -> [ExeDependency] +buildToolDependsIfBuild info = if buildable info then buildToolDepends info else [] diff --git a/src/OptionParse.hs b/src/OptionParse.hs new file mode 100644 --- /dev/null +++ b/src/OptionParse.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_HADDOCK hide #-} + +module OptionParse + ( readFlag, + optFlagReader, + optFlagParser, + optSkippedReader, + optExtraCabalReader, + optVersionReader, + optPackageNameReader, + module Options.Applicative, + ) +where + +import Data.List (groupBy, intercalate) +import Data.List.Split (splitOn) +import qualified Data.Map.Strict as Map +import Data.Void (Void) +import Distribution.ArchHs.Types +import Distribution.ArchHs.Utils +import Distribution.Parsec (simpleParsec) +import Distribution.Types.Flag (FlagAssignment, insertFlagAssignment, mkFlagAssignment, mkFlagName) +import Distribution.Types.PackageName (PackageName, mkPackageName) +import Distribution.Version (Version) +import Options.Applicative +import System.FilePath (takeExtension) +import qualified Text.Megaparsec as M +import qualified Text.Megaparsec.Char as M + +readFlag :: [(String, String, Bool)] -> Map.Map PackageName FlagAssignment +readFlag [] = Map.empty +readFlag list = + Map.fromList + . fmap (\l -> (mkPackageName . (^. _1) . head $ l, foldr (\(_, f, v) acc -> insertFlagAssignment (mkFlagName f) v acc) (mkFlagAssignment []) l)) + . groupBy (\a b -> uncurry (==) (getTwo _1 a b)) + $ list + +optFlagReader :: ReadM (Map.Map PackageName FlagAssignment) +optFlagReader = + eitherReader + ( \s -> case M.parse optFlagParser "" s of + Right x -> Right x + Left err -> Left $ M.errorBundlePretty err + ) + +optFlagParser :: M.Parsec Void String (Map.Map PackageName FlagAssignment) +optFlagParser = + readFlag + <$> ( do + pkg <- M.manyTill M.anySingle $ M.single ':' + flg <- M.manyTill M.anySingle $ M.single ':' + b <- bool + return (pkg, flg, b) + ) + `M.sepBy` "," + where + bool = do + s <- M.string "true" <|> M.string "false" + case s of + "true" -> return True + "false" -> return False + _ -> fail $ "unknown bool: " <> s + +optSkippedReader :: ReadM [String] +optSkippedReader = eitherReader $ Right . splitOn "," + +optExtraCabalReader :: ReadM [FilePath] +optExtraCabalReader = eitherReader $ \x -> + let splitted = splitOn "," x + check = map (\e -> if takeExtension x == ".cabal" then (e, True) else (e, False)) splitted + failed = map fst . filter (not . snd) $ check + successful = map fst . filter snd $ check + in if failed /= [] then Left ("Unexpected file name: " <> intercalate ", " failed) else Right successful + +optVersionReader :: ReadM Version +optVersionReader = + eitherReader + ( \s -> case simpleParsec s of + Just v -> Right v + _ -> Left $ "Failed to parse version: " <> s + ) + +optPackageNameReader :: ReadM PackageName +optPackageNameReader = eitherReader $ Right . mkPackageName diff --git a/src/Polysemy/Req.hs b/src/Polysemy/Req.hs new file mode 100644 --- /dev/null +++ b/src/Polysemy/Req.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_HADDOCK hide #-} + +module Polysemy.Req + ( reqToIO, + ) +where + +import Network.HTTP.Req +import Polysemy + +reqToIO :: forall a r. Member (Embed IO) r => Req a -> Sem r a +reqToIO r = embed @IO $ runReq defaultHttpConfig r diff --git a/uusi/Main.hs b/uusi/Main.hs new file mode 100644 --- /dev/null +++ b/uusi/Main.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Main (main) where + +import qualified Colourista as C +import qualified Control.Exception as CE +import qualified Data.Text as T +import Distribution.ArchHs.Hackage (parseCabalFile) +import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) +import Distribution.Types.CondTree + ( CondTree, + mapTreeConstrs, + mapTreeData, + ) +import Distribution.Types.Dependency (Dependency (..)) +import Distribution.Types.ExeDependency (ExeDependency (..)) +import Distribution.Types.Lens + ( BuildInfo, + ConfVar, + GenericPackageDescription, + HasBuildInfo (buildInfo, buildToolDepends, targetBuildDepends), + condBenchmarks, + condExecutables, + condLibrary, + condTestSuites, + ) +import Distribution.Types.VersionRange (anyVersion) +import Lens.Micro +import Options.Applicative +import System.Directory +import System.IO (hClose, hFlush, hPutStr, openTempFile) +import System.Process (readCreateProcessWithExitCode, shell) + +data Options = Options + { optPath :: FilePath + } + +cmdOptions :: Parser Options +cmdOptions = Options <$> strArgument (metavar "TARGET") + +runArgsParser :: IO Options +runArgsParser = + execParser $ + info + (cmdOptions <**> helper) + ( fullDesc + <> progDesc "Try to reach the TARGET QAQ." + <> header "arch-hs-uusi - a program removing all version constraints of a .cabal file, and creating a diff between it and the origin one." + ) + +----------------------------------------------------------------------------- + +main :: IO () +main = CE.catch @CE.IOException + ( do + Options {..} <- runArgsParser + C.infoMessage "Start running..." + uusiCabal optPath >>= putStrLn + ) + $ \e -> C.errorMessage $ "IOException: " <> (T.pack . show $ e) + +genPatch :: FilePath -> FilePath -> IO String +genPatch a b = (^. _2) <$> readCreateProcessWithExitCode (shell $ "diff -u " <> a <> " " <> b) "" + +uusiCabal :: FilePath -> IO String +uusiCabal originPath = do + C.infoMessage $ "Parsing cabal file from " <> T.pack originPath <> "..." + + cabal <- parseCabalFile originPath + temp <- getTemporaryDirectory + (oldPath, oldHandle) <- openTempFile temp "arch-hs-uusi" + + let old = showGenericPackageDescription cabal + uusied = showGenericPackageDescription $ uusiGenericPackageDescription cabal + + hPutStr oldHandle old + writeFile originPath uusied + + C.infoMessage $ "Write file: " <> T.pack originPath + + hFlush oldHandle + hClose oldHandle + + result <- genPatch oldPath originPath + removeFile oldPath + + return result + +----------------------------------------------------------------------------- + +type Uusi a = a -> a + +uusiDependency :: Uusi Dependency +uusiDependency (Dependency name _ lib) = Dependency name anyVersion lib + +uusiExeDependency :: Uusi ExeDependency +uusiExeDependency (ExeDependency name component _) = ExeDependency name component anyVersion + +uusiBuildInfo :: Uusi BuildInfo +uusiBuildInfo i = + i + & (targetBuildDepends %~ fmap uusiDependency) + & (buildToolDepends %~ fmap uusiExeDependency) + +uusiCondTree :: (HasBuildInfo a) => Uusi (CondTree ConfVar [Dependency] a) +uusiCondTree cond = + mapTreeData (\a -> a & buildInfo %~ uusiBuildInfo) + . mapTreeConstrs (fmap uusiDependency) + $ cond + +uusiGenericPackageDescription :: Uusi GenericPackageDescription +uusiGenericPackageDescription cabal = + cabal + & (condExecutables %~ uusiTrees) + & (condTestSuites %~ uusiTrees) + & (condBenchmarks %~ uusiTrees) + & (condLibrary . mapped %~ uusiCondTree) + where + uusiTrees trees = trees & mapped . _2 %~ uusiCondTree