arch-hs (empty) → 0.0.0.0
raw patch · 23 files changed
+2608/−0 lines, 23 filesdep +Cabaldep +aesondep +algebraic-graphssetup-changed
Dependencies added: Cabal, aeson, algebraic-graphs, arch-hs, base, bytestring, colourista, conduit, conduit-extra, containers, deepseq, directory, filepath, hackage-db, megaparsec, microlens, microlens-th, neat-interpolation, optparse-applicative, polysemy, process, req, split, tar-conduit, template-haskell, text
Files
- CHANGELOG.md +11/−0
- LICENSE +21/−0
- README.md +341/−0
- Setup.hs +2/−0
- app/Args.hs +92/−0
- app/Main.hs +189/−0
- arch-hs.cabal +121/−0
- diff/Diff.hs +208/−0
- diff/Main.hs +34/−0
- src/Data/Aeson/Ext.hs +72/−0
- src/Distribution/ArchHs/Aur.hs +148/−0
- src/Distribution/ArchHs/Community.hs +67/−0
- src/Distribution/ArchHs/Core.hs +225/−0
- src/Distribution/ArchHs/Hackage.hs +101/−0
- src/Distribution/ArchHs/Local.hs +74/−0
- src/Distribution/ArchHs/PP.hs +78/−0
- src/Distribution/ArchHs/PkgBuild.hs +198/−0
- src/Distribution/ArchHs/PkgDesc.hs +101/−0
- src/Distribution/ArchHs/Types.hs +188/−0
- src/Distribution/ArchHs/Utils.hs +120/−0
- src/OptionParse.hs +85/−0
- src/Polysemy/Req.hs +12/−0
- uusi/Main.hs +120/−0
+ CHANGELOG.md view
@@ -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
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,341 @@+# arch-hs++[](https://github.com/berberman/arch-hs/actions)+[](https://travis-ci.com/berberman/arch-hs)+[](https://hackage.haskell.org/package/arch-hs)+[](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 <youremail@domain.com>++_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. **\_(:з」∠)\_**
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Args.hs view
@@ -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."+ )
+ app/Main.hs view
@@ -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
+ arch-hs.cabal view
@@ -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+ <https://wiki.archlinux.org/index.php/Haskell_package_guidelines Haskell package guidelines>.+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/Diff.hs view
@@ -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/Main.hs view
@@ -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)
+ src/Data/Aeson/Ext.hs view
@@ -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}
+ src/Distribution/ArchHs/Aur.hs view
@@ -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 <https://aur.archlinux.org/ AUR> 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
+ src/Distribution/ArchHs/Community.hs view
@@ -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
+ src/Distribution/ArchHs/Core.hs view
@@ -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 {..}
+ src/Distribution/ArchHs/Hackage.hs view
@@ -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
+ src/Distribution/ArchHs/Local.hs view
@@ -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 <https://www.archlinux.org/packages/community/x86_64/ghc-libs/ ghc-libs>.+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"+ ]
+ src/Distribution/ArchHs/PP.hs view
@@ -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
+ src/Distribution/ArchHs/PkgBuild.hs view
@@ -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 <https://www.archlinux.org/packages/core/any/licenses/ licenses>.+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 <https://wiki.archlinux.org/index.php/Haskell_package_guidelines Haskell package guidelines> .+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 <youremail@domain.com>++ _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"+ } +|]
+ src/Distribution/ArchHs/PkgDesc.hs view
@@ -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"
+ src/Distribution/ArchHs/Types.hs view
@@ -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
+ src/Distribution/ArchHs/Utils.hs view
@@ -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 []
+ src/OptionParse.hs view
@@ -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
+ src/Polysemy/Req.hs view
@@ -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
+ uusi/Main.hs view
@@ -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