arch-hs 0.0.0.0 → 0.1.0.0

raw patch · 18 files changed

+460/−354 lines, 18 filesdep −processPVP ok

version bump matches the API change (PVP)

Dependencies removed: process

API changes (from Hackage documentation)

Files

• CHANGELOG.md +16/−0
• README.md +55/−30
• app/Args.hs +12/−0
• app/Main.hs +96/−35
• arch-hs.cabal +3/−11
• diff/Diff.hs +9/−9
• diff/Main.hs +2/−2
• src/Distribution/ArchHs/Aur.hs +16/−7
• src/Distribution/ArchHs/Community.hs +4/−3
• src/Distribution/ArchHs/Core.hs +125/−64
• src/Distribution/ArchHs/Hackage.hs +5/−3
• src/Distribution/ArchHs/Local.hs +5/−3
• src/Distribution/ArchHs/PP.hs +7/−8
• src/Distribution/ArchHs/PkgBuild.hs +31/−23
• src/Distribution/ArchHs/PkgDesc.hs +2/−0
• src/Distribution/ArchHs/Types.hs +45/−31
• src/Distribution/ArchHs/Utils.hs +27/−5
• uusi/Main.hs +0/−120

@@ -3,6 +3,22 @@ `arch-hs` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 0.1.0.0++* Support sub-libraries ([#16](https://github.com/berberman/arch-hs/issues/16))++* Split `arch-hs-uusi` into [`uusi`](https://github.com/berberman/uusi)++* Better performance in dependency resolving++* Fix recommended package order++* Trace for dependency resolving++* More reasonable PKGBUILD template ([#17](https://github.com/berberman/arch-hs/issues/16) [#18](https://github.com/berberman/arch-hs/issues/16) [#19](https://github.com/berberman/arch-hs/issues/16) [#20](https://github.com/berberman/arch-hs/issues/16))++* Fix indentation of flags' pretty printing+ ## 0.0.0.0  * Initially created.

@@ -12,54 +12,58 @@  ## 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. +Given the name of a package in hackage, `arch-hs` can generate PKGBUILD files, not only for the package+whose name is given, but also for all dependencies missing in [community](https://www.archlinux.org/packages/).+`arch-hs` has a naive built-in dependency solver, which can fetch those dependencies and find out which are required to be packaged. 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.+thus there is no guarantee of dependencies' version consistency.  ## 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. +* Pacman database (`community.db`) -* Hackage database tarball (`01-index.tar`, or `00-index.tar` previously), usually provided by `cabal-install`.+* Hackage index tarball (`01-index.tar`, or `00-index.tar` previously) -- usually provided by `cabal-install`  ## Installation +Both `arch-hs` and `arch-hs-diff` are portable, which means that they are not restricted to Arch Linux.+However, if you want to run them in other systems, you have to build them from source.+ ### Install the latest release  ``` # pacman -S arch-hs ``` -Install it directly using `pacman`. +`arch-hs` is available in [community](https://www.archlinux.org/packages/community/x86_64/arch-hs/), so you can install it using `pacman`.  ### Install the development version  ```-$ yay -S arch-hs-git+# pacman -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.+The `-git` version is available in [archlinuxcn](https://github.com/archlinuxcn/repo), following the latest git commit. -### Build from source (for development)+## Build  ``` $ git clone https://github.com/berberman/arch-hs ``` -Then build and install it via stack or cabal.+Then build it via stack or cabal.  #### Stack ```-$ stack install+$ stack build ```  #### Cabal (dynamic) ``` $ cabal configure --disable-library-vanilla --enable-shared --enable-executable-dynamic --ghc-options=-dynamic -$ cabal install+$ cabal build ```  ## Usage@@ -91,7 +95,7 @@  ``` -This message tells that in order to package `dhall-lsp-server`, we must package `haskell-lsp-types`+This message tells us 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.  ```@@ -204,8 +208,22 @@ $ 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. +Using `-e` can include extra `.cabal` files as supplementary. Useful when the target like `arch-hs` hasn't been released to hackage.  +### Trace++```+$ arch-hs --trace termonad+```++Using `--trace` can print the process of dependency resolving into stdout.++```+$ arch-hs --trace-file foo.log termonad+```++Similar to `--trace`, but the log will be written into a file.+ ### Help  ```@@ -215,7 +233,7 @@ 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+               [--trace] [--trace-file PATH] TARGET   Try to reach the TARGET QAQ.  Available options:@@ -234,6 +252,9 @@   -e,--extra PATH_1,...    Extra cabal files' path - e.g.                            /home/berberman/arch-hs/arch-hs.cabal   -a,--aur                 Enable AUR searching+  --trace                  Print trace to stdout+  --trace-file PATH        Path to trace file (empty means do not write trace to+                           file)   -h,--help                Show this help text  ```@@ -242,7 +263,7 @@  ## 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.+`arch-hs` also provides a component called `arch-hs-diff`. `arch-hs-diff` can show the differences of package description between two versions of a package. This is useful in the subsequent maintenance of a package. Example:  ```@@ -255,14 +276,14 @@ Version: 4000.3.14  ⇒  4000.3.15 Synopsis: A library for client-side HTTP URL: https://github.com/haskell/HTTP-Depends: +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+    network-uri  ==2.6.*     parsec  >=2.0 && <3.2 --------------------------------------     base  >=4.3.0.0 && <4.15@@ -270,12 +291,12 @@     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+    network-uri  ==2.6.*     parsec  >=2.0 && <3.2-MakeDepends: -    deepseq  >=1.3.0.0 && <1.5+MakeDepends:     HUnit  >=1.2.0.1 && <1.7+    deepseq  >=1.3.0.0 && <1.5     httpd-shed  >=0.4 && <0.5     mtl  >=1.1.1.0 && <2.3     pureMD5  >=0.2.4 && <2.2@@ -285,23 +306,28 @@ Flags:   HTTP     ⚐ mtl1:-      description: Use the old mtl version 1.+      description:+        Use the old mtl version 1.       default: False       isManual: False     ⚐ warn-as-error:-      description: Build with warnings-as-errors+      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)+      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+      description:+        Test against warp       default: False       isManual: True     ⚐ network-uri:-      description: Get Network.URI from the network-uri package+      description:+        Get Network.URI from the network-uri package       default: True       isManual: False @@ -313,8 +339,9 @@  ## 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*.+* The dependency solver will **ONLY** expand the dependencies of *executables* , *libraries* and *sub-libraries* recursively, because+circular dependency lies ubiquitously involving *test suites* and their *buildTools*. `arch-hs` is not able to handle with complicated situations:+the libraries of a package partially exist in hackage, some libraries include external sources, etc.   * 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.@@ -326,8 +353,6 @@ - [ ] Structuralized PKGBUILD template.  - [x] AUR support.--- [ ] Logging system.  - [ ] A watchdog during dependency calculation. 

@@ -20,6 +20,8 @@     optSkip :: [String],     optExtraCabalPath :: [FilePath],     optAur :: Bool,+    optStdoutTrace :: Bool,+    optFileTrace :: FilePath,     optTarget :: PackageName   }   deriving stock (Show)@@ -78,6 +80,16 @@         ( long "aur"             <> short 'a'             <> help "Enable AUR searching"+        )+      <*> switch+        ( long "trace"+            <> help "Print trace to stdout"+        )+      <*> strOption+        ( long "trace-file"+            <> metavar "PATH"+            <> help "Path to trace file (empty means do not write trace to file)"+            <> value ""         )       <*> argument optPackageNameReader (metavar "TARGET") 

@@ -6,22 +6,43 @@ module Main (main) where  import qualified Algebra.Graph.AdjacencyMap.Algorithm as G-import qualified Algebra.Graph.Labelled.AdjacencyMap as G+import qualified Algebra.Graph.Labelled.AdjacencyMap as GL import Args import qualified Colourista as C import Conduit import qualified Control.Exception as CE import Control.Monad (filterM, when)+import Data.IORef (IORef, newIORef) import Data.List (groupBy, intercalate, isInfixOf, nub)+import Data.List.NonEmpty (toList) 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.Aur (Aur, aurToIO, isInAur) import Distribution.ArchHs.Community+  ( defaultCommunityPath,+    isInCommunity,+    loadProcessedCommunity,+  ) import Distribution.ArchHs.Core+  ( cabalToPkgBuild,+    getDependencies,+  ) import Distribution.ArchHs.Hackage+  ( getPackageFlag,+    insertDB,+    loadHackageDB,+    lookupHackagePath,+    parseCabalFile,+  ) import Distribution.ArchHs.Local import Distribution.ArchHs.PP+  ( prettyDeps,+    prettyFlagAssignments,+    prettyFlags,+    prettySkip,+    prettySolvedPkgs,+  ) import qualified Distribution.ArchHs.PkgBuild as N import Distribution.ArchHs.Types import Distribution.ArchHs.Utils (getTwo)@@ -32,18 +53,18 @@     unPackageName,   ) import Distribution.Types.UnqualComponentName (mkUnqualComponentName)-import System.Directory (createDirectoryIfMissing)+import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile) import System.FilePath (takeFileName, (</>))  app ::-  Members '[Embed IO, CommunityEnv, HackageEnv, FlagAssignmentsEnv, DependencyRecord, Aur, WithMyErr] r =>+  Members '[Embed IO, State (Set.Set PackageName), CommunityEnv, HackageEnv, FlagAssignmentsEnv, DependencyRecord, Trace, Aur, WithMyErr] r =>   PackageName ->   FilePath ->   Bool ->   [String] ->   Sem r () app target path aurSupport skip = do-  deps <- getDependencies Set.empty (fmap mkUnqualComponentName skip) True target+  (deps, ignored) <- getDependencies (fmap mkUnqualComponentName skip) Nothing target   inCommunity <- isInCommunity target   when inCommunity $ throw $ TargetExist target ByCommunity @@ -59,37 +80,42 @@   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 =+      filledByCommunity =         runConduitPure $           yieldMany grouped             .| fillProvidedPkgs communityProvideList ByCommunity             .| fillProvidedDeps communityProvideList ByCommunity             .| sinkList-      toBePacked = cooked ^.. each . filtered (\case ProvidedPackage _ _ -> False; _ -> True)-  (cookedAgain, toBePackedAgain) <- do+      toBePacked1 = filledByCommunity ^.. each . filtered (\case ProvidedPackage _ _ -> False; _ -> True)+  (filledByBoth, toBePacked2) <- 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 =+    aurProvideList <- if aurSupport then filterM (\n -> do embed $ C.infoMessage ("Searching " <> (T.pack $ unPackageName n)); isInAur n) $ toBePacked1 ^.. each . pkgName else return []+    let filledByBoth =           if aurSupport             then               runConduitPure $-                yieldMany cooked+                yieldMany filledByCommunity                   .| fillProvidedPkgs aurProvideList ByAur                   .| fillProvidedDeps aurProvideList ByAur                   .| sinkList-            else cooked-        toBePackedAgain =+            else filledByCommunity+        toBePacked2 =           if aurSupport-            then cookedAgain ^.. each . filtered (\case ProvidedPackage _ _ -> False; _ -> True)-            else toBePacked-    return (cookedAgain, toBePackedAgain)+            then filledByBoth ^.. each . filtered (\case ProvidedPackage _ _ -> False; _ -> True)+            else toBePacked1+    return (filledByBoth, toBePacked2)    embed $ C.infoMessage "Solved target:"-  embed $ putStrLn . prettySolvedPkgs $ cookedAgain+  embed $ putStrLn . prettySolvedPkgs $ filledByBoth -  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+  let vertexsToBeRemoved = filledByBoth ^.. each . filtered (\case ProvidedPackage _ _ -> True; _ -> False) ^.. each . pkgName+      removeSelfCycle g = foldr (\n acc -> GL.removeEdge n n acc) g $ toBePacked2 ^.. each . pkgName+      newGraph = GL.induce (`notElem` vertexsToBeRemoved) deps+  flattened <- case G.topSort . GL.skeleton $ removeSelfCycle $ newGraph of+    Left c -> throw . CyclicError $ toList c+    Right x -> return x+  embed $ putStrLn . prettyDeps . reverse $ flattened   flags <- filter (\(_, l) -> length l /= 0) <$> mapM (\n -> (n,) <$> getPackageFlag n) flattened    embed $@@ -102,7 +128,7 @@   when (not dry) $     mapM_       ( \solved -> do-          pkgBuild <- cabalToPkgBuild solved+          pkgBuild <- cabalToPkgBuild solved $ Set.toList ignored           let pName = "haskell-" <> N._pkgName pkgBuild               dir = path </> pName               fileName = dir </> "PKGBUILD"@@ -111,39 +137,62 @@           embed $ writeFile fileName txt           embed $ C.infoMessage $ "Write file: " <> T.pack fileName       )-      toBePackedAgain+      toBePacked2 +-----------------------------------------------------------------------------+ runApp ::   HackageDB ->   CommunityDB ->   Map.Map PackageName FlagAssignment ->-  Sem '[CommunityEnv, HackageEnv, FlagAssignmentsEnv, DependencyRecord, Aur, WithMyErr, Embed IO, Final IO] a ->+  Bool ->+  FilePath ->+  IORef (Set.Set PackageName) ->+  Sem '[CommunityEnv, HackageEnv, FlagAssignmentsEnv, DependencyRecord, Trace, State (Set.Set PackageName), Aur, WithMyErr, Embed IO, Final IO] a ->   IO (Either MyException a)-runApp hackage community flags =+runApp hackage community flags stdout path ref =   runFinal     . embedToFinal     . errorToIOFinal     . aurToIO+    . runStateIORef ref+    . runTrace stdout path     . evalState Map.empty     . runReader flags     . runReader hackage     . runReader community +runTrace :: Member (Embed IO) r => Bool -> FilePath -> Sem (Trace ': r) a -> Sem r a+runTrace stdout path = interpret $ \case+  Trace m -> do+    when stdout (embed $ putStrLn m)+    when (not $ null path) (embed $ appendFile path (m ++ "\n"))++-----------------------------------------------------------------------------+ main :: IO () main = CE.catch @CE.IOException   ( do       Options {..} <- runArgsParser +      let traceToFile = not $ null optFileTrace+      when (traceToFile) $ do+        C.infoMessage $ "Trace will be write to " <> (T.pack optFileTrace) <> "."+        exist <- doesFileExist optFileTrace+        when exist $ do+          C.warningMessage $ "File " <> (T.pack optFileTrace) <> " already existed, delete it."+          removeFile optFileTrace+       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."+      when useDefaultHackage $ C.skipMessage "You didn't pass -h, use hackage index file from default path."+      when useDefaultCommunity $ C.skipMessage "You didn't pass -c, use community db file from default path."        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 isFlagEmpty $ C.skipMessage "You didn't pass -f, different flag assignments may make difference in dependency resolving."       when (not isFlagEmpty) $ do         C.infoMessage "You assigned flags:"         putStrLn . prettyFlagAssignments $ optFlags@@ -171,7 +220,9 @@        C.infoMessage "Start running..." -      runApp newHackage community optFlags (app optTarget optOutputDir optAur optSkip) >>= \case+      empty <- newIORef Set.empty++      runApp newHackage community optFlags optStdoutTrace optFileTrace empty (app optTarget optOutputDir optAur optSkip) >>= \case         Left x -> C.errorMessage $ "Runtime Error: " <> (T.pack . show $ x)         _ -> C.successMessage "Success!"   )@@ -179,11 +230,21 @@  ----------------------------------------------------------------------------- -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+groupDeps :: GL.AdjacencyMap (Set.Set DependencyType) PackageName -> [SolvedPackage]+groupDeps graph =+  fmap+    ( \(name, deps) ->+        SolvedPackage name $ fmap (uncurry . flip $ SolvedDependency Nothing) deps+    )+    $ result <> aloneChildren+  where+    result =+      fmap ((\(a, b, c) -> (head b, zip a c)) . unzip3)+        . groupBy (\x y -> uncurry (==) (getTwo _2 x y))+        . fmap (_1 %~ Set.toList)+        . GL.edgeList+        $ graph+    parents = fmap fst result+    children = mconcat $ fmap (\(_, ds) -> fmap snd ds) result+    -- Maybe 'G.vertexSet' is a better choice+    aloneChildren = nub $ zip (filter (`notElem` parents) children) (repeat [])

@@ -1,11 +1,12 @@ cabal-version:       2.4 name:                arch-hs-version:             0.0.0.0+version:             0.1.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+    PKGBUILD generation with the dependency resolving and template filling. Currently,+    @arch-hs@ is unstable, so packagers should not trust it 100%, but always 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@@ -107,15 +108,6 @@   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

@@ -9,7 +9,7 @@  import qualified Colourista as C import qualified Control.Exception as CE-import Data.List (intercalate, nub, sortBy, (\\))+import Data.List (intercalate, nub, sort, (\\)) import qualified Data.Map.Strict as Map import qualified Data.Text as T import Distribution.ArchHs.Core@@ -62,13 +62,13 @@  ----------------------------------------------------------------------------- --- This parts are duplicated from Core.hs with modifications.+--  Duplicated from Core.hs with modifications.  type VersionedList = [(PackageName, VersionRange)]  type VersionedComponentList = [(UnqualComponentName, VersionedList)] -collectLibDeps :: Member FlagAssignmentsEnv r => GenericPackageDescription -> Sem r (VersionedList, VersionedList)+collectLibDeps :: Members [FlagAssignmentsEnv, Trace] r => GenericPackageDescription -> Sem r (VersionedList, VersionedList) collectLibDeps cabal = do   case cabal & condLibrary of     Just lib -> do@@ -79,7 +79,7 @@     Nothing -> return ([], [])  collectRunnableDeps ::-  (Semigroup k, L.HasBuildInfo k, Member FlagAssignmentsEnv r) =>+  (Semigroup k, L.HasBuildInfo k, Members [FlagAssignmentsEnv, Trace] r) =>   (GenericPackageDescription -> [(UnqualComponentName, CondTree ConfVar [Dependency] k)]) ->   GenericPackageDescription ->   [UnqualComponentName] ->@@ -91,10 +91,10 @@       toolDeps = bInfo <&> ((_2 %~) $ fmap unExeV . buildToolDependsIfBuild)   return (runnableDeps, toolDeps) -collectExeDeps :: Member FlagAssignmentsEnv r => GenericPackageDescription -> [UnqualComponentName] -> Sem r (VersionedComponentList, VersionedComponentList)+collectExeDeps :: Members [FlagAssignmentsEnv, Trace] r => GenericPackageDescription -> [UnqualComponentName] -> Sem r (VersionedComponentList, VersionedComponentList) collectExeDeps = collectRunnableDeps condExecutables -collectTestDeps :: Member FlagAssignmentsEnv r => GenericPackageDescription -> [UnqualComponentName] -> Sem r (VersionedComponentList, VersionedComponentList)+collectTestDeps :: Members [FlagAssignmentsEnv, Trace] r => GenericPackageDescription -> [UnqualComponentName] -> Sem r (VersionedComponentList, VersionedComponentList) collectTestDeps = collectRunnableDeps condTestSuites  getCabalFromHackage :: Members [Embed IO, WithMyErr] r => PackageName -> Version -> Sem r GenericPackageDescription@@ -113,7 +113,7 @@  ----------------------------------------------------------------------------- -diffCabal :: Members [FlagAssignmentsEnv, WithMyErr, Embed IO] r => PackageName -> Version -> Version -> Sem r String+diffCabal :: Members [FlagAssignmentsEnv, WithMyErr, Trace, Embed IO] r => PackageName -> Version -> Version -> Sem r String diffCabal name a b = do   ga <- getCabalFromHackage name a   gb <- getCabalFromHackage name b@@ -135,7 +135,7 @@       ]  directDependencies ::-  Member FlagAssignmentsEnv r =>+  Members [FlagAssignmentsEnv, Trace] r =>   GenericPackageDescription ->   Sem r ([String], [String]) directDependencies cabal = do@@ -186,7 +186,7 @@     diffNew = b \\ a     diffOld = a \\ b     joinToString [] = "[]"-    joinToString xs = intercalate "\n    " $ sortBy (\x y -> head (toLower' x) `compare` head (toLower' y)) xs+    joinToString xs = intercalate "\n    " $ sort 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 

@@ -30,5 +30,5 @@   )   $ \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)+runDiff :: FlagAssignments -> Sem '[FlagAssignmentsEnv, Trace, WithMyErr, Embed IO, Final IO] a -> IO (Either MyException a)+runDiff flags = runFinal . embedToFinal . errorToIOFinal . ignoreTrace . (runReader flags)

@@ -6,6 +6,8 @@ -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman <1793913507@qq.com>+-- Stability: experimental+-- Portability: portable -- This module supports <https://aur.archlinux.org/ AUR> searching. module Distribution.ArchHs.Aur   ( AurReply (..),@@ -20,14 +22,14 @@ where  import Data.Aeson-import Data.Aeson.Ext+import Data.Aeson.Ext (generateJSONInstance) import Data.Text (Text, pack)-import Distribution.ArchHs.Utils+import Distribution.ArchHs.Utils (fixName) import Distribution.Types.PackageName (PackageName, unPackageName) import GHC.Generics (Generic) import Network.HTTP.Req import Polysemy-import Polysemy.Req+import Polysemy.Req (reqToIO)  -- | AUR response data AurReply a = AurReply@@ -102,15 +104,22 @@  -- | 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+-- searchByName +makeSem_ ''Aur++-- | Serach a package from AUR+searchByName :: Member Aur r => String -> Sem r (Maybe AurSearch)++-- | Get package info from AUR+infoByName :: Member Aur r => String -> Sem r (Maybe AurInfo)++-- | Check whether a __haskell__ package exists in AUR+isInAur :: Member Aur r => PackageName -> Sem r Bool baseURL :: Url 'Https baseURL = https "aur.archlinux.org" /: "rpc" 

@@ -1,9 +1,10 @@ {-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_HADDOCK prune, ignore-exports #-}  -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman <1793913507@qq.com>+-- Stability: experimental+-- Portability: portable -- This module provides functios operating with @community.db@ of pacman. module Distribution.ArchHs.Community   ( defaultCommunityPath,@@ -20,7 +21,7 @@ import Data.List.Split (splitOn) import qualified Data.Set as Set import Distribution.ArchHs.Types-import Distribution.ArchHs.Utils+import Distribution.ArchHs.Utils (toLower') import Distribution.Types.PackageName (PackageName, unPackageName) import System.FilePath ((</>)) @@ -54,7 +55,7 @@ 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'.+-- The following name conversion occurs during the checking to work with 'loadProcessedCommunity'. -- -- >>> "aeson" --> "aeson" -- >>> "Cabal" --> "cabal"

@@ -3,6 +3,8 @@ -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman <1793913507@qq.com>+-- Stability: experimental+-- Portability: portable -- The core functions of @arch-hs@. module Distribution.ArchHs.Core   ( getDependencies,@@ -12,13 +14,13 @@ where  import qualified Algebra.Graph.Labelled.AdjacencyMap as G-import Data.List (intercalate, stripPrefix)+import Data.List (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.Hackage (getLatestCabal)+import Distribution.ArchHs.Local (ghcLibList, ignoreList)+import Distribution.ArchHs.PkgBuild (PkgBuild (..), mapLicense) import Distribution.ArchHs.Types import Distribution.ArchHs.Utils import Distribution.Compiler (CompilerFlavor (..))@@ -30,9 +32,9 @@ import Distribution.Types.CondTree (simplifyCondTree) import Distribution.Types.Dependency (Dependency) import Distribution.Types.PackageName (PackageName, unPackageName)-import Distribution.Types.UnqualComponentName (UnqualComponentName)+import Distribution.Types.UnqualComponentName (UnqualComponentName, unqualComponentNameToPackageName) import Distribution.Types.Version (mkVersion)-import Distribution.Types.VersionRange+import Distribution.Types.VersionRange (VersionRange, withinRange) import Distribution.Utils.ShortText (fromShortText)  archEnv :: FlagAssignment -> ConfVar -> Either ConfVar Bool@@ -49,7 +51,7 @@  -- | Simplify the condition tree from 'GenericPackageDescription' with given flag assignments and archlinux system assumption. evalConditionTree ::-  (Semigroup k, L.HasBuildInfo k, Member FlagAssignmentsEnv r) =>+  (HasCallStack, Semigroup k, L.HasBuildInfo k, Members [FlagAssignmentsEnv, Trace] r) =>   GenericPackageDescription ->   CondTree ConfVar [Dependency] k ->   Sem r BuildInfo@@ -68,6 +70,9 @@           . (<> flagAssignment)           . filter (\(fName, _) -> fName `notElem` flagNames)           $ (unFlagAssignment defaultFlagAssignments)+  trace' $ "Evaluating condition tree of " <> show name+  trace' $ "Flags: " <> show thisFlag+  traceCallStack   return $ (^. L.buildInfo) . snd $ simplifyCondTree (archEnv thisFlag) cond  -----------------------------------------------------------------------------@@ -76,20 +81,24 @@ -- 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 ->+  (HasCallStack, Members [HackageEnv, FlagAssignmentsEnv, WithMyErr, DependencyRecord, State (Set PackageName), Trace] r) =>   -- | Skipped   [UnqualComponentName] ->-  -- | Whether recursive-  Bool ->+  -- | Parent+  Maybe PackageName ->   -- | Target   PackageName ->-  Sem r (G.AdjacencyMap (Set DependencyType) PackageName)-getDependencies resolved skip recursive name = do+  Sem r ((G.AdjacencyMap (Set DependencyType) PackageName), Set PackageName)+getDependencies skip parent name = do+  resolved <- get @(Set PackageName)+  modify' $ Set.insert name+  trace' $ "Getting all dependencies of (" <> show name <> "), parent: (" <> show parent <> ")"+  trace' $ "Already resolved: " <> show resolved+  traceCallStack   cabal <- getLatestCabal name   -- Ignore subLibraries   (libDeps, libToolsDeps) <- collectLibDeps cabal+  (subLibDeps, subLibToolsDeps) <- collectSubLibDeps cabal skip   (exeDeps, exeToolsDeps) <- collectExeDeps cabal skip   (testDeps, testToolsDeps) <- collectTestDeps cabal skip   -- Ignore benchmarks@@ -98,91 +107,127 @@       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+      flatten = mconcat . fmap (\(t, pkgs) -> zip (repeat t) pkgs)        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)+      ignoreSingle x = x `notElem` ignoreList+      ignore = filter ignoreSingle+      ignoreFlatten k = filter (\(_, x) -> ignoreSingle x) . flatten . uname k -      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+      filteredLibDeps = ignore libDeps+      filteredLibToolsDeps = ignore libToolsDeps+      filteredExeDeps = ignoreFlatten CExe $ exeDeps+      filteredExeToolsDeps = ignoreFlatten CExeBuildTools $ exeToolsDeps+      filteredTestDeps = ignoreFlatten CTest $ testDeps+      filteredTestToolsDeps = ignoreFlatten CTest $ testToolsDeps+      filteredSubLibDeps = ignoreFlatten CSubLibs $ subLibDeps+      filteredSubLibToolsDeps = ignoreFlatten CSubLibsBuildTools $ subLibToolsDeps -      runnableEdges k l = G.edges $ fmap (\(x, y, z) -> (Set.singleton x, y, z)) . withThisName . filterNot (\(_, x) -> x `elem` ignoreList) . flatten . uname k $ l+      filteredSubLibDepsNames = fmap unqualComponentNameToPackageName . fmap fst $ subLibDeps+      ignoreSubLibs = filter (`notElem` filteredSubLibDepsNames)+      ignoreResolved = filter (`notElem` resolved) -      currentExe = runnableEdges CExe exeDeps-      currentExeTools = runnableEdges CExeBuildTools exeToolsDeps-      currentTest = runnableEdges CTest testDeps-      currentTestTools = runnableEdges CTestBuildTools testToolsDeps+      currentLib = G.edges $ zip3 (repeat $ Set.singleton CLib) (repeat name) filteredLibDeps+      currentLibDeps = G.edges $ zip3 (repeat $ Set.singleton CLibBuildTools) (repeat name) filteredLibToolsDeps -      -- currentBench = runnableEdges Types.Benchmark benchDeps-      -- currentBenchTools = runnableEdges BenchmarkBuildTools benchToolsDeps+      componentialEdges =+        G.edges+          . fmap (\(x, y, z) -> (Set.singleton x, y, z))+          . withThisName +      currentSubLibs = componentialEdges filteredSubLibDeps+      currentSubLibsTools = componentialEdges filteredSubLibToolsDeps+      currentExe = componentialEdges filteredExeDeps+      currentExeTools = componentialEdges filteredExeToolsDeps+      currentTest = componentialEdges filteredTestDeps+      currentTestTools = componentialEdges filteredTestToolsDeps++      -- currentBench = componentialEdges Types.Benchmark benchDeps+      -- currentBenchTools = componentialEdges 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+  nextLib <- mapM (getDependencies skip (Just name)) . ignoreResolved . ignoreSubLibs $ filteredLibDeps+  nextExe <- mapM (getDependencies skip (Just name)) . ignoreResolved . ignoreSubLibs $ fmap snd filteredExeDeps+  nextSubLibs <- mapM (getDependencies skip (Just name)) $ fmap snd filteredSubLibDeps+  let temp = [nextLib, nextExe, nextSubLibs]+      nexts = G.overlays $ temp ^. each ^.. each . _1+      subsubs = temp ^. each ^.. each . _2 ^. each   return $-    currentLib-      <+> currentLibDeps-      <+> currentExe-      <+> currentExeTools-      <+> currentTest-      <+> currentTestTools-      -- <+> currentBench-      -- <+> currentBenchTools-      <+> if recursive-        then (G.overlays nextLib) <+> (G.overlays nextExe)-        else G.empty+    ( currentLib+        <+> currentLibDeps+        <+> currentExe+        <+> currentExeTools+        <+> currentTest+        <+> currentTestTools+        <+> currentSubLibs+        <+> currentSubLibsTools+        -- <+> currentBench+        -- <+> currentBenchTools+        <+> nexts,+      Set.fromList filteredSubLibDepsNames <> subsubs+    ) -collectLibDeps :: Members [FlagAssignmentsEnv, DependencyRecord] r => GenericPackageDescription -> Sem r (PkgList, PkgList)+collectLibDeps :: Members [FlagAssignmentsEnv, DependencyRecord, Trace] r => GenericPackageDescription -> Sem r (PkgList, PkgList) collectLibDeps cabal = do   case cabal & condLibrary of     Just lib -> do       let name = getPkgName' cabal+      trace' $ "Getting componential dependencies of " <> show name       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)+      mapM_ (uncurry updateDependencyRecord) libDeps+      mapM_ (uncurry updateDependencyRecord) toolDeps+      let result = (fmap fst libDeps, fmap fst toolDeps)+      trace' $ "Found: " <> show result+      traceCallStack+      return result     Nothing -> return ([], []) -collectRunnableDeps ::-  (Semigroup k, L.HasBuildInfo k, Members [FlagAssignmentsEnv, DependencyRecord] r) =>+collectComponentialDeps ::+  (HasCallStack, Semigroup k, L.HasBuildInfo k, Members [FlagAssignmentsEnv, DependencyRecord, Trace] r) =>   (GenericPackageDescription -> [(UnqualComponentName, CondTree ConfVar [Dependency] k)]) ->   GenericPackageDescription ->   [UnqualComponentName] ->   Sem r (ComponentPkgList, ComponentPkgList)-collectRunnableDeps f cabal skip = do-  let exes = cabal & f+collectComponentialDeps f cabal skip = do+  let conds = 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)+  trace' $ "Getting componential dependencies of " <> show name+  info <- filter (not . (`elem` skip) . fst) . zip (conds <&> fst) <$> mapM (evalConditionTree cabal . snd) conds+  let deps = 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)+  mapM_ (uncurry updateDependencyRecord) $ deps ^.. each . _2 ^. each+  mapM_ (uncurry updateDependencyRecord) $ toolDeps ^.. each . _2 ^. each+  let result = (k deps, k toolDeps)+  trace' $ "Found: " <> show result+  traceCallStack+  return result -collectExeDeps :: Members [FlagAssignmentsEnv, DependencyRecord] r => GenericPackageDescription -> [UnqualComponentName] -> Sem r (ComponentPkgList, ComponentPkgList)-collectExeDeps = collectRunnableDeps condExecutables+collectExeDeps :: (HasCallStack, Members [FlagAssignmentsEnv, DependencyRecord, Trace] r) => GenericPackageDescription -> [UnqualComponentName] -> Sem r (ComponentPkgList, ComponentPkgList)+collectExeDeps = collectComponentialDeps condExecutables -collectTestDeps :: Members [FlagAssignmentsEnv, DependencyRecord] r => GenericPackageDescription -> [UnqualComponentName] -> Sem r (ComponentPkgList, ComponentPkgList)-collectTestDeps = collectRunnableDeps condTestSuites+collectTestDeps :: (HasCallStack, Members [FlagAssignmentsEnv, DependencyRecord, Trace] r) => GenericPackageDescription -> [UnqualComponentName] -> Sem r (ComponentPkgList, ComponentPkgList)+collectTestDeps = collectComponentialDeps condTestSuites -updateDependencyRecord :: Member DependencyRecord r => PackageName -> [(PackageName, VersionRange)] -> Sem r ()-updateDependencyRecord parent deps = modify' $ Map.insertWith (<>) parent deps+collectSubLibDeps :: (HasCallStack, Members [FlagAssignmentsEnv, DependencyRecord, Trace] r) => GenericPackageDescription -> [UnqualComponentName] -> Sem r (ComponentPkgList, ComponentPkgList)+collectSubLibDeps = collectComponentialDeps condSubLibraries +updateDependencyRecord :: Member DependencyRecord r => PackageName -> VersionRange -> Sem r ()+updateDependencyRecord name range = modify' $ Map.insertWith (<>) name [range]+ -- collectBenchMarkDeps :: Members [HackageEnv, FlagAssignmentEnv] r => GenericPackageDescription -> [UnqualComponentName] -> Sem r (ComponentPkgList, ComponentPkgList)--- collectBenchMarkDeps = collectRunnableDeps condBenchmarks+-- collectBenchMarkDeps = collectComponentialDeps condBenchmarks  -----------------------------------------------------------------------------  -- | Generate 'PkgBuild' for a 'SolvedPackage'.-cabalToPkgBuild :: Members [HackageEnv, FlagAssignmentsEnv, WithMyErr] r => SolvedPackage -> Sem r PkgBuild-cabalToPkgBuild pkg = do+cabalToPkgBuild :: Members [HackageEnv, FlagAssignmentsEnv, WithMyErr] r => SolvedPackage -> PkgList -> Sem r PkgBuild+cabalToPkgBuild pkg ignored = do   let name = pkg ^. pkgName   cabal <- packageDescription <$> (getLatestCabal name)   let _hkgName = pkg ^. pkgName & unPackageName@@ -200,7 +245,19 @@        _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))+      depends =+        pkg ^. pkgDeps+          ^.. each+            . filtered+              ( \x ->+                  notMyself x+                    && notInGHCLib x+                    && ( selectDepKind Lib x+                           || selectDepKind Exe x+                           || selectDepKind SubLibs x+                       )+                    && notIgnore x+              )       makeDepends =         pkg ^. pkgDeps           ^.. each@@ -212,14 +269,18 @@                     && ( selectDepKind LibBuildTools x                            || selectDepKind Test x                            || selectDepKind TestBuildTools x+                           || selectDepKind SubLibsBuildTools x                        )+                    && notIgnore x               )-      depsToString deps = deps <&> (wrap . fixName . unPackageName . _depName) & intercalate " "+      depsToString deps = deps <&> (wrap . fixName . unPackageName . _depName) & concat       _depends = depsToString depends       _makeDepends = depsToString makeDepends       _url = getUrl cabal-      wrap s = '\'' : s <> "\'"+      wrap s = " \'" <> s <> "\'"       notInGHCLib x = (x ^. depName) `notElem` ghcLibList       notMyself x = x ^. depName /= name+      notIgnore x = x ^. depName `notElem` ignored       selectDepKind k x = k `elem` (x ^. depType & mapped %~ dependencyTypeToKind)+      _licenseFile = licenseFiles cabal ^? ix 0   return PkgBuild {..}

@@ -1,6 +1,8 @@ -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman <1793913507@qq.com>+-- Stability: experimental+-- Portability: portable -- This module provides functions operating with 'HackageDB' and 'GenericPackageDescription'. module Distribution.ArchHs.Hackage   ( lookupHackagePath,@@ -19,14 +21,14 @@ import qualified Data.Map as Map import Data.Maybe (fromJust) import Distribution.ArchHs.Types-import Distribution.ArchHs.Utils-import Distribution.Hackage.DB+import Distribution.ArchHs.Utils (getPkgName, getPkgVersion)+import Distribution.Hackage.DB (HackageDB, VersionData (VersionData, cabalFile), readTarball) 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.Directory (findFile, getHomeDirectory, listDirectory) import System.FilePath ((</>))  -- | Look up hackage tarball path from @~/.cabal@.

@@ -1,6 +1,8 @@ -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman <1793913507@qq.com>+-- Stability: experimental+-- Portability: portable -- This module maintains names of packages which are need special treatments during dependency resolving or PKGBUILD generating. module Distribution.ArchHs.Local   ( ignoreList,@@ -9,7 +11,7 @@ where  import Distribution.ArchHs.Types-import Distribution.Types.PackageName+import Distribution.Types.PackageName (mkPackageName)  -- | Packages should be dropped in dependency resolving. ignoreList :: PkgList@@ -29,10 +31,10 @@           "base",           "ghc",           "ghc-prim",-          "ghcjs-prim",           "ghc-bignum",           "hans",-          "Win32"+          "Win32",+          "ghc-heap"         ]  -- | Packages already provided by <https://www.archlinux.org/packages/community/x86_64/ghc-libs/ ghc-libs>.

@@ -17,7 +17,7 @@ import qualified Data.Text as T import Distribution.ArchHs.Types import Distribution.PackageDescription-  ( Flag (flagDefault, flagDescription, flagManual, flagName),+  ( Flag (..),     FlagAssignment,     unFlagAssignment,     unFlagName,@@ -37,20 +37,19 @@ 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+prettyDeps =+  mconcat+    . fmap (\(i, n) -> show @Int i <> ". " <> unPackageName n <> "\n")+    . zip [1 ..]  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])+prettyFlag f = "⚐ " <> C.formatWith [C.yellow] name <> ":\n" <> mconcat (fmap (C.formatWith [C.indent 6]) $ ["description:\n" <> desc, "default: " <> def <> "\n", "isManual: " <> manual <> "\n"])   where     name = unFlagName . flagName $ f-    desc = flagDescription f+    desc = unlines . fmap (C.formatWith [C.indent 8]) . lines $ flagDescription f     def = show $ flagDefault f     manual = show $ flagManual f 

@@ -5,6 +5,8 @@ -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman <1793913507@qq.com>+-- Stability: experimental+-- Portability: portable -- Template of PKGBUILD file. module Distribution.ArchHs.PkgBuild   ( PkgBuild (..),@@ -23,21 +25,23 @@ data PkgBuild = PkgBuild   { -- | Field @_hkgName@.     _hkgName :: String,-    -- | Field @pkgname@.+    -- | Field @pkgname@     _pkgName :: String,-    -- | Field @pkgver@.+    -- | Field @pkgver@     _pkgVer :: String,-    -- | Field @pkgdesc@.+    -- | Field @pkgdesc@     _pkgDesc :: String,-    -- | Field @@url.+    -- | Field @url@     _url :: String,-    -- | Field @license@.+    -- | Field @license@     _license :: String,-    -- | Array @depends@, which has been joined into 'String'.+    -- | Array @depends@, which has been joined into 'String'     _depends :: String,-    -- | Array @makedepends@, which has been joined into 'String'.+    -- | Array @makedepends@, which has been joined into 'String'     _makeDepends :: String,-    -- | Whether generate @check()@ bash function in PKGBUILD.+    -- | License file name+    _licenseFile :: Maybe String,+    -- | Whether generate @check()@ bash function in PKGBUILD     _enableCheck :: Bool   } @@ -132,7 +136,11 @@       (pack _license)       (pack _depends)       (pack _makeDepends)-      (if _enableCheck then check else "\n")+      ( case _licenseFile of+          Just n -> "\n" <> (installLicense $ pack n)+          _ -> "\n"+      )+      (if _enableCheck then "\n" <> check <> "\n\n" else "\n")  -- | Text of @check()@ function. check :: Text@@ -144,9 +152,17 @@   } |] +-- | Text of statements which install license.+installLicense :: Text -> Text+installLicense licenseFile =+  [text|+    install -D -m644 $licenseFile -t "$$pkgdir"/usr/share/licenses/$$pkgname/+    rm -f "$$pkgdir"/usr/share/doc/$$pkgname/$licenseFile+|]+ -- | 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 =+felixTemplate :: Text -> Text -> Text -> Text -> Text -> Text -> Text -> Text -> Text -> Text -> Text+felixTemplate hkgname pkgname pkgver pkgdesc url license depends makedepends licenseF checkF =   [text|   # This file was generated by arch-hs, please check it manually.   # Maintainer: Your Name <youremail@domain.com>@@ -159,17 +175,13 @@   url="$url"   license=("$license")   arch=('x86_64')-  depends=('ghc-libs' $depends)-  makedepends=('ghc' $makedepends)+  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    +    cd $$_hkgname-$$pkgver      runhaskell Setup configure -O --enable-shared --enable-executable-dynamic --disable-library-vanilla \       --prefix=/usr --docdir=/usr/share/doc/$$pkgname --enable-tests \@@ -183,16 +195,12 @@     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"+    runhaskell Setup copy --destdir="$$pkgdir"$licenseF   }  |]

@@ -3,6 +3,8 @@ -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman <1793913507@qq.com>+-- Stability: experimental+-- Portability: portable -- This module provides parser of @desc@ file in pacman db. module Distribution.ArchHs.PkgDesc   ( PkgDesc (..),

@@ -10,6 +10,8 @@ -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman <1793913507@qq.com>+-- Stability: experimental+-- Portability : portable -- Types used in this project. module Distribution.ArchHs.Types   ( PkgList,@@ -33,10 +35,12 @@     depName,     depType,     DependencyRecord,+    HasCallStack,     module Polysemy,     module Polysemy.Error,     module Polysemy.Reader,     module Polysemy.State,+    module Polysemy.Trace,     module Lens.Micro,   ) where@@ -52,76 +56,82 @@ import Distribution.Types.Version (Version) import Distribution.Version (VersionRange) import GHC.Generics (Generic)+import GHC.Stack (HasCallStack) import Lens.Micro import Lens.Micro.TH (makeLenses) import Polysemy import Polysemy.Error import Polysemy.Reader import Polysemy.State+import Polysemy.Trace --- | A list of 'PackageName'.+-- | A list of 'PackageName' type PkgList = [PackageName] --- | A list of component represented by 'UnqualComponentName' and its dependencies collected in a 'PkgList'.+-- | A list of component represented by 'UnqualComponentName' and its dependencies collected in a 'PkgList' type ComponentPkgList = [(UnqualComponentName, PkgList)] --- | Representation of @cummunity.db@.+-- | Representation of @cummunity.db@ type CommunityDB = Set String --- | Reader effect of 'HackageDB'.+-- | Reader effect of 'HackageDB' type HackageEnv = Reader HackageDB --- | Reader effect of 'CommunityDB'.+-- | Reader effect of 'CommunityDB' type CommunityEnv = Reader CommunityDB --- | A map of packages with their 'FlagAssignment'.+-- | A map of packages with their 'FlagAssignment' type FlagAssignments = Map PackageName FlagAssignment --- | Reader effect of a map, associating 'PackageName' with its '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)])+-- | Unused state effect+type DependencyRecord = State (Map PackageName [VersionRange]) --- | Error effect of 'MyException'.+-- | Error effect of 'MyException' type WithMyErr = Error MyException --- | Custom exception used in this project.+-- | Custom exception used in this project data MyException   = PkgNotFound PackageName   | VersionError PackageName Version   | TargetExist PackageName DependencyProvider-  | LicenseError PackageName+  | CyclicError [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 <> "]"+  show (CyclicError c) = "Graph contains a cycle " <> (show $ fmap unPackageName c)  -- | The type of a dependency. Who requires this? data DependencyType-  = -- | By a /executable/.+  = -- | By a /executable/     CExe UnqualComponentName-  | -- | By the /build tools/ of a /executable/.+  | -- | By the /build tools/ of a /executable/     CExeBuildTools UnqualComponentName-  | -- | By a /library/.+  | -- | By a /library/     CLib-  | -- | By a /test suit/.+  | -- | By a /test suit/     CTest UnqualComponentName-  | -- | By a /benchmark/.+  | -- | By a /benchmark/     CBenchmark UnqualComponentName-  | -- | By the /build tools/ of a /library/.+  | -- | By the /build tools/ of a /library/     CLibBuildTools-  | -- | By the /build tools/ of a /test suit/.+  | -- | By the /build tools/ of a /test suit/     CTestBuildTools UnqualComponentName-  | -- | By the /build tools/ of a /benchmark/.+  | -- | By the /build tools/ of a /benchmark/     CBenchmarkBuildTools UnqualComponentName+  | -- |  By a /sub-library/+    CSubLibs UnqualComponentName+  | -- |  By the /build tools/ of a /sub-library/+    CSubLibsBuildTools UnqualComponentName   deriving stock (Eq, Ord, Generic)   deriving anyclass (NFData) --- | Tags of data constructors of 'DependencyType'.+-- | Tags of data constructors of 'DependencyType' data DependencyKind   = Exe   | ExeBuildTools@@ -131,6 +141,8 @@   | LibBuildTools   | TestBuildTools   | BenchmarkBuildTools+  | SubLibs+  | SubLibsBuildTools   deriving stock (Eq)  instance Show DependencyType where@@ -140,6 +152,8 @@   show (CBenchmark x) = unUnqualComponentName x <> " :: Benchmark"   show (CTestBuildTools x) = unUnqualComponentName x <> " :: TestBuildTools"   show (CBenchmarkBuildTools x) = unUnqualComponentName x <> " :: BenchmarkBuildTools"+  show (CSubLibs x) = unUnqualComponentName x <> " :: SubLibs"+  show (CSubLibsBuildTools x) = unUnqualComponentName x <> " :: SubLibsBuildTools"   show CLib = "Lib"   show CLibBuildTools = "LibBuildTools" @@ -152,13 +166,13 @@   show ByCommunity = "community"   show ByAur = "aur" --- | A solved dependency, holden by 'SolvedPackage'.+-- | A solved dependency, holden by 'SolvedPackage' data SolvedDependency = SolvedDependency-  { -- | Provider of this dependency.+  { -- | Provider of this dependency     _depProvider :: Maybe DependencyProvider,-    -- | Name of the dependency.+    -- | Name of the dependency     _depName :: PackageName,-    -- | Types of the dependency.+    -- | Types of the dependency     _depType :: [DependencyType]   }   deriving stock (Show, Eq, Generic)@@ -167,18 +181,18 @@ -- | 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.+  = -- | A package which has been provided by somebody, so there is no need to expand its dependencies     ProvidedPackage-      { -- | Package name.+      { -- | Package name         _pkgName :: PackageName,         -- | Package provider. (The name of 'DependencyProvider' may be confusing...)         _pkgProvider :: DependencyProvider       }-  | -- | A package with its dependencies.+  | -- | A package with its dependencies     SolvedPackage-      { -- | Package name.+      { -- | Package name         _pkgName :: PackageName,-        -- | Package dependencies.+        -- | Package dependencies         _pkgDeps :: [SolvedDependency]       }   deriving stock (Show, Eq, Generic)

@@ -1,6 +1,8 @@ -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman <1793913507@qq.com>+-- Stability: experimental+-- Portability: portable -- Miscellaneous functions used crossing modules. module Distribution.ArchHs.Utils   ( getPkgName,@@ -16,6 +18,8 @@     getTwo,     buildDependsIfBuild,     buildToolDependsIfBuild,+    traceCallStack,+    trace',   ) where @@ -33,19 +37,24 @@     repoLocation,     sourceRepos,   )-import Distribution.Types.BuildInfo+import Distribution.Types.BuildInfo (BuildInfo (..)) import Distribution.Types.Dependency+  ( Dependency,+    depPkgName,+    depVerRange,+  ) 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)+import GHC.Stack (callStack, prettyCallStack) --- | Extract the 'PackageName' of a 'ExeDependency'.+-- | Extract the package name from a 'ExeDependency'. unExe :: ExeDependency -> PackageName unExe (ExeDependency name _ _) = name --- | Extract the 'PackageName' and 'VersionRange' of a 'ExeDependency'.+-- | Extract the package name and the version range from a 'ExeDependency'. unExeV :: ExeDependency -> (PackageName, VersionRange) unExeV (ExeDependency name _ v) = (name, v) @@ -57,7 +66,7 @@ getPkgName :: PackageDescription -> PackageName getPkgName = I.pkgName . package --- | Extract the package from 'GenericPackageDescription'.+-- | Extract the package name from 'GenericPackageDescription'. getPkgName' :: GenericPackageDescription -> PackageName getPkgName' = I.pkgName . package . packageDescription @@ -106,8 +115,10 @@ dependencyTypeToKind (CLibBuildTools) = LibBuildTools dependencyTypeToKind (CTestBuildTools _) = TestBuildTools dependencyTypeToKind (CBenchmarkBuildTools _) = BenchmarkBuildTools+dependencyTypeToKind (CSubLibs _) = SubLibs+dependencyTypeToKind (CSubLibsBuildTools _) = SubLibsBuildTools --- | Apply a @Getting@ to two values respectively, and get the result as a pair.+-- | 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) @@ -118,3 +129,14 @@ -- | Same as 'buildToolDepends', but check if this is 'buildable'. buildToolDependsIfBuild :: BuildInfo -> [ExeDependency] buildToolDependsIfBuild info = if buildable info then buildToolDepends info else []++-- | Trace with prefix @[TRACE]@.+trace' :: MemberWithError Trace r => String -> Sem r ()+trace' s = trace $ "[TRACE]  " <> s++-- | Trace 'GHC.Stack.CallStack'.+traceCallStack :: (HasCallStack, MemberWithError Trace r) => Sem r ()+traceCallStack = do+  trace . prefix $ prettyCallStack callStack+  where+    prefix = unlines . fmap ("[TRACE]  " ++) . lines

@@ -1,120 +0,0 @@-{-# 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