arch-hs 0.1.1.0 → 0.2.0.0

raw patch · 28 files changed

+1186/−425 lines, 28 filesnew-component:exe:arch-hs-submitPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• README.md +20/−8
• app/Args.hs +3/−3
• app/Main.hs +46/−54
• arch-hs.cabal +20/−6
• data/NAME_PRESET.json +92/−0
• diff/Diff.hs +114/−56
• diff/Main.hs +26/−18
• src/Data/Aeson/Ext.hs +0/−0
• src/Distribution/ArchHs/Aur.hs +10/−11
• src/Distribution/ArchHs/Community.hs +45/−34
• src/Distribution/ArchHs/Core.hs +19/−11
• src/Distribution/ArchHs/Exception.hs +65/−0
• src/Distribution/ArchHs/Hackage.hs +22/−12
• src/Distribution/ArchHs/Internal/NamePresetLoader.hs +51/−0
• src/Distribution/ArchHs/Internal/Prelude.hs +80/−0
• src/Distribution/ArchHs/Local.hs +1/−1
• src/Distribution/ArchHs/Name.hs +171/−0
• src/Distribution/ArchHs/OptionReader.hs +115/−0
• src/Distribution/ArchHs/PP.hs +8/−13
• src/Distribution/ArchHs/PkgBuild.hs +1/−1
• src/Distribution/ArchHs/PkgDesc.hs +43/−20
• src/Distribution/ArchHs/Types.hs +15/−44
• src/Distribution/ArchHs/Utils.hs +7/−36
• src/OptionParse.hs +0/−85
• src/Polysemy/Req.hs +0/−12
• submit/Main.hs +43/−0
• submit/Submit.hs +157/−0

@@ -3,6 +3,18 @@ `arch-hs` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +## 0.2.0.0++* More accurate naming conversion between hackage representation and archlinux representation, according to [NAME_PRESET.json](https://github.com/berberman/arch-hs/blob/master/data/NAME_PRESET.json)++* Clearer project structure++* More reasonable exceptions++* Provide versions of haskell packages in archlinux community++* Add `arch-hs-submit` executable+ ## 0.1.1.0  * Add uusi option

@@ -91,7 +91,7 @@ ```  This message tells us that in order to package `accelerate`, we must package `unique`-and `tasty-kat` first sequentially, because `accelerate` dependens on them to build or test,+and `tasty-kat` first sequentially, because `accelerate` dependents on them to build or test, whereas they are not present in archlinux community repo.  ```@@ -111,9 +111,6 @@ # This file was generated by arch-hs, please check it manually. # Maintainer: Your Name <youremail@domain.com> -# This file was generated by arch-hs, please check it manually.-# Maintainer: Your Name <youremail@domain.com>- _hkgname=accelerate pkgname=haskell-accelerate pkgver=1.3.0.0@@ -279,6 +276,21 @@  For all available options, have a look at the help message. ++## [Name preset](https://github.com/berberman/arch-hs/blob/master/data/NAME_PRESET.json)++To distribute a haskell package to archlinux, the name of package should be changed according to the naming convention:++* for haskell libraries, their names must have `haskell-` prefix++* for programs, it depends on circumstances++* names should always be in lower case++However, it's not enough to prefix the string with `haskell-` and transform to lower case; in some special situations, the hackage name+may have `haskell-` prefix already, or the case is irregular, thus we have to a name preset manually. Once a package distributed to archlinux,+whose name conform to above-mentioned situation, the name preset should be upgraded correspondingly.+ ## Diff  `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.@@ -355,6 +367,10 @@  `arch-hs-diff` does not require hackage db, it downloads cabal files from hackage server instead.  +## Submit++For hackage distribution maintainers only.+ ## Limitations  * The dependency solver will **ONLY** expand the dependencies of *executables* , *libraries* and *sub-libraries* recursively, because@@ -368,11 +384,7 @@  - [ ] **Standardized pretty printing**. -- [ ] StructuralPKGBUILD template.- - [x] AUR support.--- [ ] A watchdog during dependency calculation.  - [x] Working with given `.cabal` files which haven't been released to hackage. 

@@ -8,9 +8,9 @@ where  import qualified Data.Map.Strict as Map-import Distribution.ArchHs.Types (FlagAssignments)-import Distribution.Types.PackageName (PackageName)-import OptionParse+import Distribution.ArchHs.Internal.Prelude+import Distribution.ArchHs.OptionReader+import Distribution.ArchHs.Types  data Options = Options   { optHackagePath :: FilePath,

@@ -10,10 +10,8 @@ import Args import qualified Colourista as C import Conduit-import qualified Control.Exception as CE-import Control.Monad (filterM, when)+import Control.Monad (filterM) 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@@ -28,6 +26,7 @@   ( cabalToPkgBuild,     getDependencies,   )+import Distribution.ArchHs.Exception import Distribution.ArchHs.Hackage   ( getPackageFlag,     insertDB,@@ -35,6 +34,7 @@     lookupHackagePath,     parseCabalFile,   )+import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.Local import Distribution.ArchHs.PP   ( prettyDeps,@@ -47,14 +47,11 @@ 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 System.Directory+  ( createDirectoryIfMissing,+    doesFileExist,   )-import Distribution.Types.UnqualComponentName (mkUnqualComponentName)-import System.Directory (createDirectoryIfMissing, doesFileExist, removeFile)-import System.FilePath (takeFileName, (</>))+import System.FilePath (takeFileName)  app ::   Members '[Embed IO, State (Set.Set PackageName), CommunityEnv, HackageEnv, FlagAssignmentsEnv, DependencyRecord, Trace, Aur, WithMyErr] r =>@@ -62,9 +59,9 @@   FilePath ->   Bool ->   [String] ->-  Bool->+  Bool ->   Sem r ()-app target path aurSupport skip uusi= do+app target path aurSupport skip uusi = do   (deps, ignored) <- getDependencies (fmap mkUnqualComponentName skip) Nothing target   inCommunity <- isInCommunity target   when inCommunity $ throw $ TargetExist target ByCommunity@@ -114,7 +111,7 @@       removeSelfCycle g = foldr (\n acc -> GL.removeEdge n n acc) g $ toBePacked2 ^.. each . pkgName       newGraph = GL.induce (`notElem` vertexesToBeRemoved) deps   flattened <- case G.topSort . GL.skeleton $ removeSelfCycle $ newGraph of-    Left c -> throw . CyclicError $ toList c+    Left c -> throw . CyclicExist $ toList c     Right x -> return x   embed $ putStrLn . prettyDeps . reverse $ flattened   flags <- filter (\(_, l) -> length l /= 0) <$> mapM (\n -> (n,) <$> getPackageFlag n) flattened@@ -172,64 +169,59 @@ -----------------------------------------------------------------------------  main :: IO ()-main = CE.catch @CE.IOException-  ( do-      Options {..} <- runArgsParser+main = printHandledIOException $+  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 traceToFile = not $ null optFileTrace+    when (traceToFile) $ do+      C.infoMessage $ "Trace will be dumped to " <> (T.pack optFileTrace) <> "."+      exist <- doesFileExist optFileTrace+      when exist $+        C.warningMessage $ "File " <> (T.pack optFileTrace) <> " already existed, overwrite it." -      let useDefaultHackage = isInfixOf "YOUR_HACKAGE_MIRROR" $ optHackagePath-          useDefaultCommunity = "/var/lib/pacman/sync/community.db" == optCommunityPath+    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 path."-      when useDefaultCommunity $ C.skipMessage "You didn't pass -c, use community db file from default path."+    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 == []+    let isFlagEmpty = optFlags == Map.empty+        isSkipEmpty = optSkip == [] -      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+    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 -      when (not isSkipEmpty) $ do-        C.infoMessage "You chose to skip:"-        putStrLn $ prettySkip optSkip+    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."+    when optAur $ C.infoMessage "You passed -a, searching AUR may takes a long time." -      when optUusi $ C.infoMessage "You passed --uusi, uusi will become makedepends of each package."+    when optUusi $ C.infoMessage "You passed --uusi, uusi will become makedepends of each package." -      hackage <- loadHackageDB =<< if useDefaultHackage then lookupHackagePath else return optHackagePath-      C.infoMessage "Loading hackage..."+    hackage <- loadHackageDB =<< if useDefaultHackage then lookupHackagePath else return optHackagePath+    C.infoMessage "Loading hackage..." -      let isExtraEmpty = optExtraCabalPath == []+    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."+    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+    parsedExtra <- mapM parseCabalFile optExtraCabalPath -      let newHackage = foldr (\x acc -> x `insertDB` acc) hackage parsedExtra+    let newHackage = foldr (\x acc -> x `insertDB` acc) hackage parsedExtra -      community <- loadProcessedCommunity $ if useDefaultCommunity then defaultCommunityPath else optCommunityPath-      C.infoMessage "Loading community.db..."+    community <- loadProcessedCommunity $ if useDefaultCommunity then defaultCommunityPath else optCommunityPath+    C.infoMessage "Loading community.db..." -      C.infoMessage "Start running..."+    C.infoMessage "Start running..." -      empty <- newIORef Set.empty+    empty <- newIORef Set.empty -      runApp newHackage community optFlags optStdoutTrace optFileTrace empty (app optTarget optOutputDir optAur optSkip optUusi) >>= \case-        Left x -> C.errorMessage $ "Runtime Error: " <> (T.pack . show $ x)-        _ -> C.successMessage "Success!"-  )-  $ \e -> C.errorMessage $ "IOException: " <> (T.pack . show $ e)+    runApp newHackage community optFlags optStdoutTrace optFileTrace empty (app optTarget optOutputDir optAur optSkip optUusi) & printAppResult  ----------------------------------------------------------------------------- 

@@ -1,7 +1,7 @@ cabal-version:       2.4 name:                arch-hs-version:             0.1.1.0-synopsis:            A program generating PKGBUILD for hackage packages+version:             0.2.0.0+synopsis:            Distribute hackage packages to archlinux description:              @arch-hs@ is a command-line program, which simplifies the process of producing     and maintaining haskell packages for archlinux distribution by automating the@@ -17,6 +17,7 @@ copyright:           2020 berberman category:            Distribution build-type:          Simple+extra-source-files:  data/NAME_PRESET.json extra-doc-files:     README.md                      CHANGELOG.md tested-with:         GHC == 8.10.2@@ -72,7 +73,6 @@                        PolyKinds                        RankNTypes                        ScopedTypeVariables-                       TypeApplications                        TypeOperators                        TypeFamilies library@@ -88,9 +88,13 @@                        Distribution.ArchHs.Types,                        Distribution.ArchHs.Utils,                        Distribution.ArchHs.PP,-                       OptionParse,-                       Data.Aeson.Ext,-                       Polysemy.Req+                       Distribution.ArchHs.Name,+                       Distribution.ArchHs.Exception,+                       Distribution.ArchHs.Internal.Prelude+                       Distribution.ArchHs.OptionReader+  other-modules:       Data.Aeson.Ext+                       Distribution.ArchHs.Internal.NamePresetLoader+                         executable arch-hs   import:              common-options@@ -107,6 +111,16 @@   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-submit+  import:              common-options+  hs-source-dirs:      submit+  main-is:             Main.hs+  other-modules:       Submit   build-depends:       arch-hs   ghc-options:         -threaded                        -rtsopts

@@ -0,0 +1,92 @@+{+  "falseList": [+    "haskell-network2.8",+    "haskell-sbv8.7"+  ],+  "preset": {+    "agda": "Agda",+    "alex": "alex",+    "arch-hs": "arch-hs",+    "c2hs": "c2hs",+    "haskell-cabal": "Cabal",+    "cabal-install": "cabal-install",+    "cgrep": "cgrep",+    "cryptol": "cryptol",+    "darcs": "darcs",+    "dhall": "dhall",+    "dhall-bash": "dhall-bash",+    "dhall-json": "dhall-json",+    "dhall-lsp-server": "dhall-lsp-server",+    "dhall-yaml": "dhall-yaml",+    "git-annex": "git-annex",+    "git-repair": "git-repair",+    "happy": "happy",+    "haskell-chasingbottoms": "ChasingBottoms",+    "haskell-ci": "haskell-ci",+    "haskell-configfile": "ConfigFile",+    "haskell-cracknum": "crackNum",+    "haskell-dav": "DAV",+    "haskell-decimal": "Decimal",+    "haskell-diff": "Diff",+    "haskell-edisonapi": "EdisonAPI",+    "haskell-edisoncore": "EdisonCore",+    "haskell-findbin": "FindBin",+    "haskell-floatinghex": "FloatingHex",+    "haskell-gi": "haskell-gi",+    "haskell-glob": "Glob",+    "haskell-gtk": "gtk3",+    "haskell-graphscc": "GraphSCC",+    "haskell-hopenpgp": "hOpenPGP",+    "haskell-http": "HTTP",+    "haskell-hunit": "HUnit",+    "haskell-ifelse": "IfElse",+    "haskell-juicypixels": "JuicyPixels",+    "haskell-lexer": "haskell-lexer",+    "haskell-listlike": "ListLike",+    "haskell-missingh": "MissingH",+    "haskell-monadlib": "monadLib",+    "haskell-monadrandom": "MonadRandom",+    "haskell-only": "Only",+    "haskell-puremd5": "pureMD5",+    "haskell-quickcheck": "QuickCheck",+    "haskell-ranged-sets": "Ranged-sets",+    "haskell-safesemaphore": "SafeSemaphore",+    "haskell-sbv8.7": "haskell-sbv8.7",+    "haskell-sha": "SHA",+    "haskell-smtlib": "smtLib",+    "haskell-src-exts": "haskell-src-exts",+    "haskell-src-exts-util": "haskell-src-exts-util",+    "haskell-src-meta": "haskell-src-meta",+    "haskell-statevar": "StateVar",+    "haskell-stmonadtrans": "STMonadTrans",+    "haskell-unixutils": "Unixutils",+    "haskell-x11": "X11",+    "haskell-x11-xft": "X11-xft",+    "hasktags": "hasktags",+    "hledger": "hledger",+    "hledger-api": "hledger-api",+    "hledger-ui": "hledger-ui",+    "hledger-web": "hledger-web",+    "hlint": "hlint",+    "hoogle": "hoogle",+    "hopenpgp-tools": "hopenpgp-tools",+    "idris": "idris",+    "misfortune": "misfortune",+    "pandoc": "pandoc",+    "pandoc-citeproc": "pandoc-citeproc",+    "pandoc-crossref": "pandoc-crossref",+    "postgrest": "postgrest",+    "shellcheck": "ShellCheck",+    "stack": "stack",+    "stylish-haskell": "stylish-haskell",+    "tamarin-prover": "tamarin-prover",+    "taskell": "taskell",+    "tidalcycles": "tidal",+    "unlambda": "unlambda",+    "uusi": "uusi",+    "xmobar": "xmobar",+    "xmonad": "xmonad",+    "xmonad-contrib": "xmonad-contrib",+    "xmonad-utils": "xmonad-utils"+  }+}

@@ -1,4 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}  module Diff   ( diffCabal,@@ -8,28 +10,27 @@ where  import qualified Colourista as C-import qualified Control.Exception as CE-import Data.List (intercalate, nub, sort, (\\)) import qualified Data.Map.Strict as Map+import Data.Maybe (fromJust) import qualified Data.Text as T-import Distribution.ArchHs.Core+import Distribution.ArchHs.Community (versionInCommunity)+import Distribution.ArchHs.Core (evalConditionTree)+import Distribution.ArchHs.Exception+import Distribution.ArchHs.Internal.Prelude+import Distribution.ArchHs.OptionReader import Distribution.ArchHs.PP (prettyFlags) import Distribution.ArchHs.Types import Distribution.ArchHs.Utils-import Distribution.PackageDescription+import Distribution.PackageDescription (CondTree, ConfVar) 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.Types.Dependency (Dependency) import Distribution.Utils.ShortText (fromShortText)-import Distribution.Version import Network.HTTP.Req hiding (header)-import OptionParse  data Options = Options-  { optFlags :: FlagAssignments,+  { optCommunityPath :: FilePath,+    optFlags :: FlagAssignments,     optPackageName :: PackageName,     optVersionA :: Version,     optVersionB :: Version@@ -38,7 +39,15 @@ cmdOptions :: Parser Options cmdOptions =   Options-    <$> option+    <$> strOption+      ( long "community"+          <> metavar "PATH"+          <> short 'c'+          <> help "Path to community.db"+          <> showDefault+          <> value "/var/lib/pacman/sync/community.db"+      )+    <*> option       optFlagReader       ( long "flags"           <> metavar "package_name:flag_name:true|false,..."@@ -68,18 +77,20 @@  type VersionedComponentList = [(UnqualComponentName, VersionedList)] -collectLibDeps :: Members [FlagAssignmentsEnv, Trace] r => GenericPackageDescription -> Sem r (VersionedList, VersionedList)+collectLibDeps :: Members [FlagAssignmentsEnv, Trace, DependencyRecord] 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+      mapM_ (uncurry updateDependencyRecord) libDeps+      mapM_ (uncurry updateDependencyRecord) toolDeps       return (libDeps, toolDeps)     Nothing -> return ([], [])  collectRunnableDeps ::-  (Semigroup k, L.HasBuildInfo k, Members [FlagAssignmentsEnv, Trace] r) =>+  (Semigroup k, L.HasBuildInfo k, Members [FlagAssignmentsEnv, Trace, DependencyRecord] r) =>   (GenericPackageDescription -> [(UnqualComponentName, CondTree ConfVar [Dependency] k)]) ->   GenericPackageDescription ->   [UnqualComponentName] ->@@ -87,33 +98,58 @@ 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)+  let deps = bInfo <&> ((_2 %~) $ fmap unDepV . buildDependsIfBuild)       toolDeps = bInfo <&> ((_2 %~) $ fmap unExeV . buildToolDependsIfBuild)-  return (runnableDeps, toolDeps)+  mapM_ (uncurry updateDependencyRecord) $ deps ^.. each . _2 ^. each+  mapM_ (uncurry updateDependencyRecord) $ toolDeps ^.. each . _2 ^. each+  return (deps, toolDeps) -collectExeDeps :: Members [FlagAssignmentsEnv, Trace] r => GenericPackageDescription -> [UnqualComponentName] -> Sem r (VersionedComponentList, VersionedComponentList)+collectExeDeps :: Members [FlagAssignmentsEnv, Trace, DependencyRecord] r => GenericPackageDescription -> [UnqualComponentName] -> Sem r (VersionedComponentList, VersionedComponentList) collectExeDeps = collectRunnableDeps condExecutables -collectTestDeps :: Members [FlagAssignmentsEnv, Trace] r => GenericPackageDescription -> [UnqualComponentName] -> Sem r (VersionedComponentList, VersionedComponentList)+collectTestDeps :: Members [FlagAssignmentsEnv, Trace, DependencyRecord] r => GenericPackageDescription -> [UnqualComponentName] -> Sem r (VersionedComponentList, VersionedComponentList) collectTestDeps = collectRunnableDeps condTestSuites +updateDependencyRecord :: Member DependencyRecord r => PackageName -> VersionRange -> Sem r ()+updateDependencyRecord name range = modify' $ Map.insertWith (<>) name [range]++-----------------------------------------------------------------------------+ 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+  response <- interceptHttpException (runReq defaultHttpConfig r)+  case parseGenericPackageDescriptionMaybe $ responseBody response of     Just x -> return x-    _ -> embed @IO $ fail $ "Failed to parse .cabal file from " <> show api+    _ -> error $ "Failed to parse .cabal file from " <> show api +directDependencies ::+  Members [FlagAssignmentsEnv, Trace, DependencyRecord] r =>+  GenericPackageDescription ->+  Sem r (VersionedList, VersionedList)+directDependencies cabal = do+  (libDeps, libToolsDeps) <- collectLibDeps cabal+  (exeDeps, exeToolsDeps) <- collectExeDeps cabal []+  (testDeps, testToolsDeps) <- collectTestDeps cabal []+  let 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 (depends, makedepends)+ ----------------------------------------------------------------------------- -diffCabal :: Members [FlagAssignmentsEnv, WithMyErr, Trace, Embed IO] r => PackageName -> Version -> Version -> Sem r String+diffCabal :: Members [CommunityEnv, FlagAssignmentsEnv, WithMyErr, Trace, DependencyRecord, Embed IO] r => PackageName -> Version -> Version -> Sem r String diffCabal name a b = do   ga <- getCabalFromHackage name a   gb <- getCabalFromHackage name b@@ -123,6 +159,8 @@       fb = genPackageFlags ga   (ba, ma) <- directDependencies ga   (bb, mb) <- directDependencies gb+  queryb <- lookupDiffCommunity ba bb+  querym <- lookupDiffCommunity ma mb   return $     unlines       [ C.formatWith [C.magenta] "Package: " <> unPackageName name,@@ -130,35 +168,18 @@         desc pa pb,         url pa pb,         dep "Depends: \n" ba bb,+        "",+        queryb,         dep "MakeDepends: \n" ma mb,+        "",+        querym,         flags name fa fb       ] -directDependencies ::-  Members [FlagAssignmentsEnv, Trace] 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)+  let f' = T.unpack . T.strip . T.pack . f+      (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)) @@ -171,22 +192,61 @@ url :: PackageDescription -> PackageDescription -> String url = diffTerm "URL: " getUrl -dep :: String -> [String] -> [String] -> String-dep s a b =+splitLine :: String+splitLine = "\n" <> replicate 38 '-' <> "\n"++inRange :: Members [CommunityEnv, WithMyErr] r => (PackageName, VersionRange) -> Sem r (Either (PackageName, VersionRange) (PackageName, VersionRange, Version, Bool))+inRange (name, hRange) =+  (try @MyException (versionInCommunity name))+    >>= \case+      Right y -> let version = fromJust . simpleParsec $ y in return . Right $ (name, hRange, version, withinRange version hRange)+      Left _ -> return . Left $ (name, hRange)++lookupDiffCommunity :: Members [CommunityEnv, WithMyErr] r => VersionedList -> VersionedList -> Sem r String+lookupDiffCommunity va vb = do+  let diffNew = vb \\ va+      diffOld = va \\ vb+      color b = C.formatWith [if b then C.green else C.red]+      pp b (Right (name, range, v, False)) =+        "["+          <> color b (unPackageName name)+          <> "] is required to be in range ("+          <> color b (prettyShow range)+          <> "), "+          <> "but community provides ("+          <> color b (prettyShow v)+          <> ")."+      pp _ (Right _) = ""+      pp b (Left (name, range)) =+        "["+          <> color b (unPackageName name)+          <> "] is required to be in range ("+          <> color b (prettyShow range)+          <> "), "+          <> "but community does not provide this package."++  new <- fmap (pp True) <$> mapM inRange diffNew+  old <- fmap (pp False) <$> mapM inRange diffOld+  let join = unlines . filter (not . null)+  return $ join old <> join new++dep :: String -> VersionedList -> VersionedList -> String+dep s va vb =   (C.formatWith [C.magenta] s) <> "    " <> case (diffOld <> diffNew) of     [] -> joinToString a     _ ->       (joinToString $ fmap (\x -> red (x `elem` diffOld) x) a)-        <> "\n"-        <> replicate 38 '-'-        <> "\n"+        <> splitLine         <> "    "         <> (joinToString $ fmap (\x -> green (x `elem` diffNew) x) b)   where+    a = joinVersionWithName <$> va+    b = joinVersionWithName <$> vb     diffNew = b \\ a     diffOld = a \\ b     joinToString [] = "[]"     joinToString xs = intercalate "\n    " $ sort xs+    joinVersionWithName (n, range) = unPackageName n <> "  " <> prettyShow range     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 @@ -196,9 +256,7 @@     [] -> joinToString a     _ ->       (joinToString a)-        <> "\n"-        <> replicate 38 '-'-        <> "\n"+        <> splitLine         <> "    "         <> (joinToString b)   where

@@ -4,31 +4,39 @@ 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.Community+  ( defaultCommunityPath,+    loadProcessedCommunity,+  )+import Distribution.ArchHs.Exception+import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.PP (prettyFlagAssignments) import Distribution.ArchHs.Types  main :: IO ()-main = CE.catch @CE.IOException-  ( do-      Options {..} <- runArgsParser+main = printHandledIOException $+  do+    Options {..} <- runArgsParser+    let useDefaultCommunity = "/var/lib/pacman/sync/community.db" == optCommunityPath+        isFlagEmpty = Map.null optFlags -      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+    when useDefaultCommunity $ C.skipMessage "You didn't pass -c, use community db file from default path." -      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)+    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 -runDiff :: FlagAssignments -> Sem '[FlagAssignmentsEnv, Trace, WithMyErr, Embed IO, Final IO] a -> IO (Either MyException a)-runDiff flags = runFinal . embedToFinal . errorToIOFinal . ignoreTrace . (runReader flags)+    community <- loadProcessedCommunity $ if useDefaultCommunity then defaultCommunityPath else optCommunityPath+    C.infoMessage "Loading community.db..."++    C.infoMessage "Start running..."+    runDiff community optFlags (diffCabal optPackageName optVersionA optVersionB) >>= \case+      Left x -> C.errorMessage $ "Runtime Error: " <> (T.pack . show $ x)+      Right r -> putStrLn r >> C.successMessage "Success!"++runDiff :: CommunityDB -> FlagAssignments -> Sem '[CommunityEnv, FlagAssignmentsEnv, Trace, DependencyRecord, WithMyErr, Embed IO, Final IO] a -> IO (Either MyException a)+runDiff community flags = runFinal . embedToFinal . errorToIOFinal . evalState (Map.empty) . ignoreTrace . (runReader flags) . (runReader community)

@@ -24,12 +24,11 @@ import Data.Aeson import Data.Aeson.Ext (generateJSONInstance) import Data.Text (Text, pack)-import Distribution.ArchHs.Utils (fixName)-import Distribution.Types.PackageName (PackageName, unPackageName)-import GHC.Generics (Generic)+import Distribution.ArchHs.Exception+import Distribution.ArchHs.Internal.Prelude+import Distribution.ArchHs.Name+import Distribution.ArchHs.Types import Network.HTTP.Req-import Polysemy-import Polysemy.Req (reqToIO)  -- | AUR response data AurReply a = AurReply@@ -106,7 +105,7 @@ data Aur m a where   SearchByName :: String -> Aur m (Maybe AurSearch)   InfoByName :: String -> Aur m (Maybe AurInfo)-  IsInAur :: PackageName -> Aur m Bool+  IsInAur :: HasMyName n => n -> Aur m Bool  -- searchByName @@ -119,12 +118,12 @@ 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+isInAur :: (HasMyName n, Member Aur r) => n -> Sem r Bool 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 :: Members [WithMyErr, Embed IO] r => Sem (Aur ': r) a -> Sem r a aurToIO = interpret $ \case   (SearchByName name) -> do     let parms =@@ -133,7 +132,7 @@             <> "by" =: ("name" :: Text)             <> "arg" =: (pack name)         r = req GET baseURL NoReqBody jsonResponse parms-    response <- reqToIO r+    response <- interceptHttpException $ runReq defaultHttpConfig r     let body :: AurReply AurSearch = responseBody response     return $ case r_resultcount body of       1 -> Just . head $ r_results body@@ -145,13 +144,13 @@             <> "by" =: ("name" :: Text)             <> "arg[]" =: (pack name)         r = req GET baseURL NoReqBody jsonResponse parms-    response <- reqToIO r+    response <- interceptHttpException $ runReq defaultHttpConfig 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+    result <- aurToIO . searchByName . unCommunityName . toCommunityName $ name     return $ case result of       Just _ -> True       _ -> False

@@ -1,29 +1,31 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}  -- | 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.+-- This module provides functions operating with @community.db@ of pacman. module Distribution.ArchHs.Community   ( defaultCommunityPath,     loadProcessedCommunity,     isInCommunity,+    versionInCommunity,   ) 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 qualified Data.Map.Strict as Map+import qualified Data.Text as T+import Distribution.ArchHs.Exception+import Distribution.ArchHs.Internal.Prelude+import Distribution.ArchHs.Name+import Distribution.ArchHs.PkgDesc import Distribution.ArchHs.Types-import Distribution.ArchHs.Utils (toLower')-import Distribution.Types.PackageName (PackageName, unPackageName)-import System.FilePath ((</>))  -- | Default path to @community.db@. defaultCommunityPath :: FilePath@@ -32,37 +34,46 @@ loadCommunity ::   (MonadResource m, PrimMonad m, MonadThrow m) =>   FilePath ->-  ConduitT i FilePath m ()+  ConduitT i (CommunityName, CommunityVersion) 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+      when (Tar.headerFileType header == Tar.FTNormal) $ do+        x <- mconcat <$> sinkList+        let txt = T.unpack . decodeUtf8 $ x+            result =+              let provided r = r Map.! "PROVIDES"+                  parseProvidedTerm t = let s = splitOn "=" t in (s ^. ix 0, s ^. ix 1)+               in case runDescFieldsParser (Tar.headerFilePath header) txt of+                    Right r -> case head $ r Map.! "NAME" of+                      "ghc" -> parseProvidedTerm <$> provided r+                      "ghc-libs" -> parseProvidedTerm <$> provided r+                      _ -> [(head $ r Map.! "NAME", extractVer . head $ r Map.! "VERSION")]+                    -- TODO: Drop it+                    Left _ -> []+            extractVer ver = head $+              splitOn "-" $ case splitOn ":" ver of+                (_ : v : []) -> v+                v : [] -> v+                _ -> fail "err" -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+        yieldMany $ result & each . _1 %~ CommunityName --- | Load @community.db@ from @path@, removing @haskell-@ prefix.+-- | Load @community.db@ from @path@.+-- @desc@ files in the db will be parsed by @descParser@. loadProcessedCommunity :: (MonadUnliftIO m, PrimMonad m, MonadThrow m) => FilePath -> m CommunityDB-loadProcessedCommunity path = fmap Set.fromList $ runConduitRes $ loadCommunity path .| cookCommunity .| sinkList+loadProcessedCommunity path = Map.fromList <$> (runConduitRes $ loadCommunity path .| sinkList) --- | Check if a package from hackage exists in archlinux community repo.--- The following name conversion occurs during the checking to work with '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+-- | Check if a package exists in archlinux community repo.+-- See 'HasMyName'.+isInCommunity :: (HasMyName n, Member CommunityEnv r) => n -> Sem r Bool+isInCommunity name = ask @CommunityDB >>= \db -> return $ (toCommunityName name) `Map.member` db++-- | Get the version of a package in archlinux community repo.+-- If the package does not exist, 'PkgNotFound' will be thrown.+versionInCommunity :: (HasMyName n, Members [CommunityEnv, WithMyErr] r) => n -> Sem r CommunityVersion+versionInCommunity name =+  ask @CommunityDB >>= \db -> case db Map.!? (toCommunityName name) of+    Just x -> return x+    _ -> throw $ PkgNotFound name

@@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}  -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT@@ -14,27 +15,34 @@ where  import qualified Algebra.Graph.Labelled.AdjacencyMap as G-import Data.List (stripPrefix)+import Data.Char (toLower) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set-import Distribution.ArchHs.Hackage (getLatestCabal, getLatestSHA256)+import Distribution.ArchHs.Exception+import Distribution.ArchHs.Hackage+  ( getLatestCabal,+    getLatestSHA256,+  )+import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.Local (ghcLibList, ignoreList)-import Distribution.ArchHs.PkgBuild (PkgBuild (..), mapLicense)+import Distribution.ArchHs.Name+import Distribution.ArchHs.PkgBuild+  ( PkgBuild (..),+    mapLicense,+  ) 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 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, unqualComponentNameToPackageName)-import Distribution.Types.Version (mkVersion)-import Distribution.Types.VersionRange (VersionRange, withinRange) import Distribution.Utils.ShortText (fromShortText)  archEnv :: FlagAssignment -> ConfVar -> Either ConfVar Bool@@ -232,7 +240,7 @@   cabal <- packageDescription <$> (getLatestCabal name)   _sha256sums <- (\s -> "'" <> s <> "'") <$> getLatestSHA256 name   let _hkgName = pkg ^. pkgName & unPackageName-      rawName = toLower' _hkgName+      rawName = toLower <$> _hkgName       _pkgName = maybe rawName id $ stripPrefix "haskell-" rawName       _pkgVer = prettyShow $ getPkgVersion cabal       _pkgDesc = fromShortText $ synopsis cabal@@ -274,7 +282,7 @@                        )                     && notIgnore x               )-      depsToString deps = deps <&> (wrap . fixName . unPackageName . _depName) & mconcat+      depsToString deps = deps <&> (wrap . unCommunityName . toCommunityName . _depName) & mconcat       _depends = depsToString depends       _makeDepends = (if uusi then " 'uusi'" else "") <> depsToString makeDepends       _url = getUrl cabal

@@ -0,0 +1,65 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++-- | Copyright: (c) 2020 berberman+-- SPDX-License-Identifier: MIT+-- Maintainer: berberman <1793913507@qq.com>+-- Stability: experimental+-- Portability: portable+-- Exceptions used in this project.+module Distribution.ArchHs.Exception+  ( WithMyErr,+    MyException (..),+    printHandledIOException,+    printAppResult,+    interceptHttpException,+  )+where++import qualified Colourista as C+import qualified Control.Exception as CE+import qualified Data.Text as T+import Distribution.ArchHs.Internal.Prelude+import Distribution.ArchHs.Name+import Distribution.ArchHs.Types+import Network.HTTP.Req (HttpException (..))++-- | Error effect of 'MyException'+type WithMyErr = Error MyException++-- | Custom exception used in this project+data MyException+  = forall n. (HasMyName n) => PkgNotFound n+  | VersionNotFound PackageName Version+  | TargetExist PackageName DependencyProvider+  | CyclicExist [PackageName]+  | NetworkException HttpException++instance Show MyException where+  show (PkgNotFound name) = "Unable to find [" <> (unPackageName $ toHackageName name) <> "] (hackage name) / [" <> (unCommunityName $ toCommunityName name) <> "] (community name)"+  show (VersionNotFound name version) = "Unable to find [" <> (unPackageName $ toHackageName name) <> "] (hackage name) / [" <> (unCommunityName $ toCommunityName name) <> "] (community name)" <> " " <> prettyShow version+  show (TargetExist name provider) = "Target [" <> unPackageName name <> "] has been provided by " <> show provider+  show (CyclicExist c) = "Graph contains a cycle " <> (show $ fmap unPackageName c)+  show (NetworkException (JsonHttpException s)) = "Failed to parse response " <> s+  show (NetworkException (VanillaHttpException e)) = show e++-- | Catch 'CE.IOException' and print it.+printHandledIOException :: IO () -> IO ()+printHandledIOException = CE.handle @CE.IOException (\e -> C.errorMessage $ "IOException: " <> (T.pack . show $ e))++-- | Print the result of 'errorToIOFinal'.+printAppResult :: IO (Either MyException ()) -> IO ()+printAppResult io =+  io >>= \case+    Left x -> C.errorMessage $ "Runtime Exception: " <> (T.pack . show $ x)+    _ -> C.successMessage "Success!"++-- | Catch the 'HttpException' thrown in 'IO' monad, then re-throw it with 'NetworkException'.+interceptHttpException :: Members [WithMyErr, Embed IO] r => IO a -> Sem r a+interceptHttpException io = do+  x <- embed $ CE.try io+  case x of+    Left err -> throw $ NetworkException err+    Right x' -> return x'

@@ -1,3 +1,5 @@+{-# LANGUAGE TypeApplications #-}+ -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT -- Maintainer: berberman <1793913507@qq.com>@@ -17,20 +19,28 @@   ) where -import Control.Applicative (Alternative ((<|>))) import qualified Data.ByteString as BS import qualified Data.Map as Map import Data.Maybe (fromJust)+import Distribution.ArchHs.Exception+import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.Types-import Distribution.ArchHs.Utils (getPkgName, getPkgVersion)-import Distribution.Hackage.DB (HackageDB, VersionData (VersionData, cabalFile), readTarball, tarballHashes)+import Distribution.ArchHs.Utils+  ( getPkgName,+    getPkgVersion,+  )+import Distribution.Hackage.DB+  ( HackageDB,+    VersionData (VersionData, cabalFile),+    readTarball,+    tarballHashes,+  ) 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 (findFile, getHomeDirectory, listDirectory)-import System.FilePath ((</>))+import System.Directory+  ( findFile,+    getHomeDirectory,+    listDirectory,+  )  -- | Look up hackage tarball path from @~/.cabal@. -- Arbitrary hackage mirror is potential to be selected.@@ -72,14 +82,14 @@   case Map.lookup name db of     (Just m) -> case Map.lookupMax m of       Just (_, vdata) -> return $ f vdata-      Nothing -> throw $ VersionError name nullVersion+      Nothing -> throw $ VersionNotFound name nullVersion     Nothing -> throw $ PkgNotFound name  -- | Get the latest 'GenericPackageDescription'. getLatestCabal :: Members [HackageEnv, WithMyErr] r => PackageName -> Sem r GenericPackageDescription getLatestCabal = withLatestVersion cabalFile --- | Get the latest SHA256 sum of the tarball . +-- | Get the latest SHA256 sum of the tarball . getLatestSHA256 :: Members [HackageEnv, WithMyErr] r => PackageName -> Sem r String getLatestSHA256 = withLatestVersion (\vdata -> tarballHashes vdata Map.! "sha256") @@ -90,7 +100,7 @@   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 $ VersionNotFound name version     Nothing -> throw $ PkgNotFound name  -- | Get flags of a package.

@@ -0,0 +1,51 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Distribution.ArchHs.Internal.NamePresetLoader (loadNamePreset) where++import Data.Aeson+import qualified Data.ByteString as BS+import Data.Map.Strict (Map, fromList, keys, toList)+import Data.Tuple (swap)+import GHC.Generics (Generic)+import Language.Haskell.TH+import System.Directory (getCurrentDirectory)+import System.FilePath ((</>))++data NamePreset = NamePreset+  { falseList :: [String],+    preset :: Map String String+  }+  deriving stock (Generic)++instance FromJSON NamePreset++loadNamePreset :: DecsQ+loadNamePreset = do+  txt <- runIO $ getCurrentDirectory >>= \dot -> BS.readFile $ dot </> "data" </> "NAME_PRESET.json"+  let NamePreset {..} = case decodeStrict txt of+        Just x -> x+        _ -> error "Failed to parse json"+  a <- genFunc "communityToHackageP" preset+  b <- genFunc "hackageToCommunityP" $ fromList . fmap swap . toList $ preset+  c <- genArray "falseListP" falseList+  d <- genArray "communityListP" $ keys preset+  return [a, b, c, d]++genFunc :: String -> Map String String -> DecQ+genFunc name src = do+  let temp = genClause <$> toList src+  funD (mkName name) $ temp <> [nothingClause]+  where+    genClause (from, to) =+      clause+        [litP $ stringL from]+        (normalB $ [|Just|] `appE` (litE . stringL $ to))+        []++    nothingClause = clause [wildP] (normalB [|Nothing|]) []++genArray :: String -> [String] -> DecQ+genArray name src = funD (mkName name) [clause [] (normalB [|src|]) []]

@@ -0,0 +1,80 @@+-- | Copyright: (c) 2020 berberman+-- SPDX-License-Identifier: MIT+-- Maintainer: berberman <1793913507@qq.com>+-- Stability: experimental+-- Portability: portable+-- A re-export list.+module Distribution.ArchHs.Internal.Prelude+  ( NFData,+    Generic,+    HasCallStack,+    when,+    (<|>),+    splitOn,+    stripPrefix,+    isPrefixOf,+    isInfixOf,+    groupBy,+    intercalate,+    nub,+    sort,+    sortBy,+    (\\),+    encodeUtf8,+    decodeUtf8,+    prettyShow,+    simpleParsec,+    (</>),+    module Lens.Micro,+    module Polysemy,+    module Polysemy.Error,+    module Polysemy.Reader,+    module Polysemy.State,+    module Polysemy.Trace,+    module Distribution.Types.PackageDescription,+    module Distribution.Types.GenericPackageDescription,+    module Distribution.Types.Version,+    module Distribution.Types.VersionRange,+    module Distribution.Types.PackageName,+    module Distribution.Types.UnqualComponentName,+    module Distribution.Types.Flag,+  )+where++import Control.Applicative ((<|>))+import Control.DeepSeq (NFData)+import Control.Monad (when)+import Data.List+  ( groupBy,+    intercalate,+    isInfixOf,+    isPrefixOf,+    nub,+    sort,+    sortBy,+    stripPrefix,+    (\\),+  )+import Data.List.Split (splitOn)+import Data.Text.Encoding+  ( decodeUtf8,+    encodeUtf8,+  )+import Distribution.Parsec (simpleParsec)+import Distribution.Pretty (prettyShow)+import Distribution.Types.Flag+import Distribution.Types.GenericPackageDescription+import Distribution.Types.PackageDescription+import Distribution.Types.PackageName+import Distribution.Types.UnqualComponentName+import Distribution.Types.Version+import Distribution.Types.VersionRange+import GHC.Generics (Generic)+import GHC.Stack (HasCallStack)+import Lens.Micro+import Polysemy+import Polysemy.Error+import Polysemy.Reader+import Polysemy.State+import Polysemy.Trace+import System.FilePath ((</>))

@@ -11,7 +11,7 @@ where  import Distribution.ArchHs.Types-import Distribution.Types.PackageName (mkPackageName)+import Distribution.Types.PackageName  -- | Packages should be dropped in dependency resolving. ignoreList :: PkgList

@@ -0,0 +1,171 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Copyright: (c) 2020 berberman+-- SPDX-License-Identifier: MIT+-- Maintainer: berberman <1793913507@qq.com>+-- Stability: experimental+-- Portability: portable+--+-- Naming conversion between haskell package in hackage and archlinux community repo.+--+-- To distribute a haskell package to archlinux, the name of package should be changed according to the naming convention:+--+--   (1) for haskell libraries, their names must have @haskell-@ prefix+--+--   (2) for programs, it depends on circumstances+--+--   (3) names should always be in lower case+--+-- However, it's not enough to prefix the string with @haskell-@ and trasform to lower case; in some special situations, the hackage name+-- may have @haskell-@ prefix already, or the case is irregular, thus we have to a name preset, @NAME_PRESET.json@, manually.+-- Once a package distributed to archlinux, whose name conform to above-mentioned situation, the name preset should be upgraded correspondingly.+--+-- @NAME_PRESET.json@ will be loaded during the compilation, generating haskell code to be called in runtime.+--+-- Converting a community name to hackage name following these steps:+--+--   (1) Find if the name preset contains this rule+--   (2) If it contains, then use it; or remove the @haskell-@ prefix+--+-- Converting a hackage name to community name following these steps:+--+--   (1) Find if the name preset contains this rule+--   (2) If it contains, then use it; or add the @haskell-@ prefix+--+-- For details, see the type 'MyName' and type class 'HasMyName' with its instances.+module Distribution.ArchHs.Name+  ( MyName,+    unMyName,+    HasMyName (..),+    NameRep (..),+    mToCommunityName,+    mToHackageName,+    toCommunityName,+    toHackageName,+    isHaskellPackage,+  )+where++import Data.Char (toLower)+import Data.String+  ( IsString,+    fromString,+  )+import Distribution.ArchHs.Internal.NamePresetLoader+import Distribution.ArchHs.Internal.Prelude+import Distribution.ArchHs.Types++-- | The representation of a package name.+data NameRep+  = -- |  archlinx community style+    CommunityRep+  | -- | hackage style+    HackageRep++$(loadNamePreset)++-- | Convert a name from community representation to hackage representation, according to the name preset.+-- If the preset doesn't contain this mapping rule, the function will return 'Nothing'.+-- This function is generated from @NAME_PRESET.json@+communityToHackageP :: MyName 'CommunityRep -> Maybe (MyName 'HackageRep)++-- | Convert a name from hackage representation to community representation, according to the name preset.+-- If the preset doesn't contain this mapping rule, the function will return 'Nothing'.+--+-- This function is generated from @NAME_PRESET.json@+hackageToCommunityP :: MyName 'HackageRep -> Maybe (MyName 'CommunityRep)++-- | Special haskell packages in community reop, which should be ignored in the process.+--+-- This function is generated from @NAME_PRESET.json@+falseListP :: [MyName 'CommunityRep]++-- | Community haskell packages of in the name preset.+--+-- This function is generated from @NAME_PRESET.json@+communityListP :: [MyName 'CommunityRep]++-- | A general package name representation.+-- It has a phantom @a@, which indexes this name.+-- Normally, the index should be the data kinds of 'NameRep'.+--+-- In Cabal API, packages' names are represented by the type 'PackageName';+-- in arch-hs, names parsed from @community.db@ are represented by the type 'CommunityName'.+-- It would be tedious to use two converting functions everywhere, so here comes a intermediate data type+-- to unify them, with type level constraints as bonus.+newtype MyName a = MyName+  { -- | Unwrap the value.+    unMyName :: String+  }+  deriving stock (Show, Read, Eq, Ord, Generic)+  deriving anyclass (NFData)++instance IsString (MyName a) where+  fromString = MyName++-- | 'HasMyName' indicates that the type @a@ can be converted to 'MyName'.+-- This is where the actually conversion occurs.+class HasMyName a where+  -- | To 'MyName' in hackage style.+  toHackageRep :: a -> MyName 'HackageRep++  -- | To 'MyName' in community style.+  toCommunityRep :: a -> MyName 'CommunityRep++instance HasMyName (MyName 'CommunityRep) where+  toHackageRep = toHackageRep . CommunityName . unMyName+  toCommunityRep = id++instance HasMyName (MyName 'HackageRep) where+  toHackageRep = id+  toCommunityRep = toCommunityRep . mkPackageName . unMyName++instance HasMyName PackageName where+  toHackageRep = MyName . unPackageName+  toCommunityRep = go . unPackageName+    where+      go s = case hackageToCommunityP (MyName s) of+        Just x -> x+        _ ->+          MyName . fmap toLower $+            ( if "haskell-" `isPrefixOf` s+                then s+                else "haskell-" <> s+            )++instance HasMyName CommunityName where+  toHackageRep = go . unCommunityName+    where+      go s = case communityToHackageP (MyName s) of+        Just x -> x+        _ -> MyName $ drop 8 s+  toCommunityRep = MyName . unCommunityName++-- | Back to 'CommunityName'.+mToCommunityName :: MyName 'CommunityRep -> CommunityName+mToCommunityName = CommunityName . unMyName++-- | Back to 'PackageName'.+mToHackageName :: MyName 'HackageRep -> PackageName+mToHackageName = mkPackageName . unMyName++-- | Convert @n@ to 'CommunityName'.+toCommunityName :: HasMyName n => n -> CommunityName+toCommunityName = mToCommunityName . toCommunityRep++-- | Convert @n@ to 'PackageName'.+toHackageName :: HasMyName n => n -> PackageName+toHackageName = mToHackageName . toHackageRep++-- | Judge if a package in archlinux community repo is haskell package.+--+-- i.e. it is in @preset@ or have @haskell-@ prefix, and is not present in @falseList@ of @NAME_PRESET.json@.+isHaskellPackage :: CommunityName -> Bool+isHaskellPackage name =+  let rep = toCommunityRep name+   in (rep `elem` communityListP || "haskell-" `isPrefixOf` (unMyName rep)) && rep `notElem` falseListP

@@ -0,0 +1,115 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Copyright: (c) 2020 berberman+-- SPDX-License-Identifier: MIT+-- Maintainer: berberman <1793913507@qq.com>+-- Stability: experimental+-- Portability: portable+-- This module defines input patterns used in executables' cli.+-- "Options.Applicative" is re-exported.+module Distribution.ArchHs.OptionReader+  ( optFlagReader,+    optSkippedReader,+    optExtraCabalReader,+    optVersionReader,+    optPackageNameReader,+    module Options.Applicative,+  )+where++import qualified Data.Map.Strict as Map+import Data.Void (Void)+import Distribution.ArchHs.Internal.Prelude+import Distribution.ArchHs.Utils+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++-- | Read a set of package name with flag assignments.+--+-- >>> f ""+-- Right (fromList [])+-- >>> f "package_name:flag_name:true"+-- Right (fromList [(PackageName "package_name",fromList [(FlagName "flag_name",(1,True))])])+-- >>> f "package_name:flag_name_1:true,package_name:flag_name_2:false"+-- Right (fromList [(PackageName "package_name",fromList [(FlagName "flag_name_1",(1,True)),(FlagName "flag_name_2",(1,False))])])+-- >>> f "package_name_1:flag_name_1:false,package_name_2:flag_name_2:true"+-- Right (fromList [(PackageName "package_name_1",fromList [(FlagName "flag_name_1",(1,False))]),(PackageName "package_name_2",fromList [(FlagName "flag_name_2",(1,True))])])+-- >>> f "zzz"+-- Left "1:4:\n  |\n1 | zzz\n  |    ^\nunexpected end of input\nexpecting ':'\n"+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++-- | Read skipped components.+-- This never fails, i.e. the return value will be 'Right'.+-- >>> f ""+-- Right [""]+-- >>> f "component_1,component_2"+-- Right ["component_1","component_2"]+optSkippedReader :: ReadM [String]+optSkippedReader = eitherReader $ Right . splitOn ","++-- | Read extra cabal files.+--+-- >>> f ""+-- Left "Unexpected file name: "+-- >>> f "a.cabal"+-- Right ["a.cabal"]+-- >>> f "a.cabal,b.cabal"+-- Right ["a.cabal","b.cabal"]+-- >>> f "a.what,b.cabal"+-- Left "Unexpected file name: a.what"+optExtraCabalReader :: ReadM [FilePath]+optExtraCabalReader = eitherReader $ \x ->+  let split = splitOn "," x+      check = map (\e -> if takeExtension e == ".cabal" then (e, True) else (e, False)) split+      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++-- | Read a 'Version'+-- This function calls 'simpleParsec'.+optVersionReader :: ReadM Version+optVersionReader =+  eitherReader+    ( \s -> case simpleParsec s of+        Just v -> Right v+        _ -> Left $ "Failed to parse version: " <> s+    )++-- | Read a 'PackageName'+-- This function never fails, because it just wraps the input string with 'mkPackageName'.+optPackageNameReader :: ReadM PackageName+optPackageNameReader = eitherReader $ Right . mkPackageName

@@ -1,7 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_HADDOCK hide #-} +-- | Copyright: (c) 2020 berberman+-- SPDX-License-Identifier: MIT+-- Maintainer: berberman <1793913507@qq.com>+-- Stability: experimental+-- Portability: portable+-- This module provides simple pretty-printing functions work with the cli program. module Distribution.ArchHs.PP   ( prettySkip,     prettyFlagAssignments,@@ -12,20 +17,10 @@ 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.Internal.Prelude import Distribution.ArchHs.Types-import Distribution.PackageDescription-  ( Flag (..),-    FlagAssignment,-    unFlagAssignment,-    unFlagName,-  )-import Distribution.Types.PackageName-  ( PackageName,-    unPackageName,-  )  prettySkip :: [String] -> String prettySkip = C.formatWith [C.magenta] . intercalate ", "@@ -39,7 +34,7 @@ prettyDeps :: [PackageName] -> String prettyDeps =   mconcat-    . fmap (\(i, n) -> show @Int i <> ". " <> unPackageName n <> "\n")+    . fmap (\(i, n) -> show (i :: Int) <> ". " <> unPackageName n <> "\n")     . zip [1 ..]  prettyFlags :: [(PackageName, [Flag])] -> String

@@ -216,5 +216,5 @@     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"$licenseF-  } +  } |]

@@ -1,3 +1,6 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE RecordWildCards #-}  -- | Copyright: (c) 2020 berberman@@ -11,12 +14,14 @@     DescParser,     descParser,     descFieldsParser,+    runDescFieldsParser,     runDescParser,   ) where  import qualified Data.Map.Strict as Map import Data.Void (Void)+import Distribution.ArchHs.Internal.Prelude import Text.Megaparsec import Text.Megaparsec.Char @@ -26,14 +31,20 @@ -- | 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]+  { _name :: String,+    _version :: String,+    _desc :: String,+    _url :: Maybe String,+    _license :: Maybe String,+    _provides :: [String],+    _optDepends :: [String],+    _replaces :: [String],+    _conflicts :: [String],+    _depends :: [String],+    _makeDepends :: [String]   }+  deriving stock (Show, Eq, Generic)+  deriving anyclass (NFData)  -- Common fields {- fieldList =@@ -63,11 +74,10 @@   Map.fromList     <$> ( do             sep-            field <- many (upperChar <|> digitChar)-            sep+            field <- manyTill anySingle sep             _ <- newline-            content <- manyTill line (lookAhead sep <|> () <$ eol <|> eof)-            return (field, content)+            content <- manyTill line (lookAhead sep <|> eof)+            return (field, filter (/= "") content)         )     `manyTill` eof   where@@ -79,13 +89,17 @@ 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"+            _name <- lookupSingle fields "NAME"+            _version <- lookupSingle fields "VERSION"+            _desc <- lookupSingle fields "DESC"+            _url <- lookupSingleMaybe fields "URL"+            _license <- lookupSingleMaybe fields "LICENSE"+            _depends <- lookupList fields "DEPENDS"+            _makeDepends <- lookupList fields "MAKEDEPENDS"+            _provides <- lookupList fields "PROVIDES"+            _optDepends <- lookupList fields "OPTDEPENDS"+            _replaces <- lookupList fields "REPLACES"+            _conflicts <- lookupList fields "CONFLICTS"             return PkgDesc {..}         )   where@@ -94,10 +108,19 @@         (e : _) -> return e         _ -> fail $ "Expect a singleton " <> f       _ -> fail $ "Unable to find field " <> f+    lookupSingleMaybe fields f = return $ case Map.lookup f fields of+      (Just x) -> case x of+        (e : _) -> Just e+        _ -> Nothing+      _ -> Nothing     lookupList fields f = return $ case Map.lookup f fields of       (Just x) -> x       _ -> [] +-- | Run the desc fields parser.+runDescFieldsParser :: String -> String -> Either (ParseErrorBundle String Void) (Map.Map String [String])+runDescFieldsParser = parse descFieldsParser+ -- | Run the desc parser.-runDescParser :: String -> Either (ParseErrorBundle String Void) PkgDesc-runDescParser = parse descParser "Desc"+runDescParser :: String -> String -> Either (ParseErrorBundle String Void) PkgDesc+runDescParser = parse descParser

@@ -5,7 +5,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_HADDOCK ignore-exports #-}  -- | Copyright: (c) 2020 berberman -- SPDX-License-Identifier: MIT@@ -16,12 +15,12 @@ module Distribution.ArchHs.Types   ( PkgList,     ComponentPkgList,+    CommunityName (..),+    CommunityVersion,     CommunityDB,     HackageEnv,     CommunityEnv,     FlagAssignmentsEnv,-    WithMyErr,-    MyException (..),     DependencyType (..),     DependencyKind (..),     DependencyProvider (..),@@ -35,35 +34,13 @@     depName,     depType,     DependencyRecord,-    HasCallStack,-    module Polysemy,-    module Polysemy.Error,-    module Polysemy.Reader,-    module Polysemy.State,-    module Polysemy.Trace,-    module Lens.Micro,   ) where -import Control.DeepSeq (NFData) import Data.Map.Strict (Map)-import Data.Set (Set)+import Distribution.ArchHs.Internal.Prelude 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 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' type PkgList = [PackageName]@@ -71,8 +48,19 @@ -- | A list of component represented by 'UnqualComponentName' and its dependencies collected in a 'PkgList' type ComponentPkgList = [(UnqualComponentName, PkgList)] +-- | Name of packages in archlinux community repo, a wrapper of 'String'.+newtype CommunityName = CommunityName+  { -- | Unwrap the value+    unCommunityName :: String+  }+  deriving stock (Show, Read, Eq, Ord, Generic)+  deriving anyclass (NFData)++-- | Version of packages in archlinux community repo+type CommunityVersion = String+ -- | Representation of @cummunity.db@-type CommunityDB = Set String+type CommunityDB = Map CommunityName CommunityVersion  -- | Reader effect of 'HackageDB' type HackageEnv = Reader HackageDB@@ -88,23 +76,6 @@  -- | Unused state effect type DependencyRecord = State (Map 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-  | 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 (CyclicError c) = "Graph contains a cycle " <> (show $ fmap unPackageName c)  -- | The type of a dependency. Who requires this? data DependencyType

@@ -8,12 +8,10 @@   ( getPkgName,     getPkgName',     getPkgVersion,-    toLower',     dependencyTypeToKind,     unExe,     unExeV,     unDepV,-    fixName,     getUrl,     getTwo,     buildDependsIfBuild,@@ -23,20 +21,10 @@   ) where -import Control.Applicative (Alternative ((<|>))) import Control.Monad ((<=<))-import Data.Char (toLower)-import Data.List.Split (splitOn)+import Distribution.ArchHs.Internal.Prelude import Distribution.ArchHs.Types-import Distribution.PackageDescription-  ( GenericPackageDescription,-    PackageDescription,-    homepage,-    package,-    packageDescription,-    repoLocation,-    sourceRepos,-  )+import Distribution.PackageDescription (repoLocation) import Distribution.Types.BuildInfo (BuildInfo (..)) import Distribution.Types.Dependency   ( Dependency,@@ -45,10 +33,11 @@   ) 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)+import GHC.Stack+  ( callStack,+    prettyCallStack,+  )  -- | Extract the package name from a 'ExeDependency'. unExe :: ExeDependency -> PackageName@@ -83,27 +72,9 @@     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+    vcs = repoLocation <=< (^? ix 0) . 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

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

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

@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Main (main) where++import qualified Colourista as C+import qualified Data.Text as T+import Distribution.ArchHs.Community+import Distribution.ArchHs.Exception+import Distribution.ArchHs.Internal.Prelude+import Distribution.ArchHs.Types+import Submit+import System.Directory (doesFileExist)+import System.Environment (lookupEnv)++main :: IO ()+main = printHandledIOException $+  do+    Options {..} <- runArgsParser+    let useDefaultCommunity = "/var/lib/pacman/sync/community.db" == optCommunityPath++    when useDefaultCommunity $ C.skipMessage "You didn't pass -c, use community db file from default path."++    community <- loadProcessedCommunity $ if useDefaultCommunity then defaultCommunityPath else optCommunityPath+    C.infoMessage "Loading community.db..."++    token <- lookupEnv "HACKAGE_API_TOKEN"++    when (token == Nothing) $ C.warningMessage "You didn't set HACKAGE_API_TOKEN, dry run only."++    let hasOutput = not $ null optOutput+    when (hasOutput) $ do+      C.infoMessage $ "Output will be dumped to " <> (T.pack optOutput) <> "."+      exist <- doesFileExist optOutput+      when exist $+        C.warningMessage $ "File " <> (T.pack optOutput) <> " already existed, overwrite it."+    C.infoMessage "Start running..."+    when (not $ optUpload || hasOutput) $+      C.warningMessage "Run diff only."+    runSubmit community (submit token optOutput optUpload) & printAppResult++runSubmit :: CommunityDB -> Sem '[CommunityEnv, WithMyErr, Embed IO, Final IO] a -> IO (Either MyException a)+runSubmit community = runFinal . embedToFinal . errorToIOFinal . (runReader community)

@@ -0,0 +1,157 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Submit+  ( Options (..),+    runArgsParser,+    submit,+  )+where++import qualified Colourista as C+import qualified Data.ByteString.Char8 as BS+import qualified Data.Map.Strict as Map+import Data.Maybe (fromJust)+import qualified Data.Text as T+import Data.Void (Void)+import Distribution.ArchHs.Exception+import Distribution.ArchHs.Internal.Prelude+import Distribution.ArchHs.Local+import Distribution.ArchHs.Name+import Distribution.ArchHs.Types+import Network.HTTP.Req+import Options.Applicative hiding (header)+import qualified Options.Applicative+import qualified Text.Megaparsec as M+import Text.Megaparsec.Char as M++data Options = Options+  { optCommunityPath :: FilePath,+    optOutput :: FilePath,+    optUpload :: Bool+  }++cmdOptions :: Parser Options+cmdOptions =+  Options+    <$> strOption+      ( long "community"+          <> metavar "PATH"+          <> short 'c'+          <> help "Path to community.db"+          <> showDefault+          <> value "/var/lib/pacman/sync/community.db"+      )+    <*> Options.Applicative.option+      str+      ( long "output"+          <> metavar "PATH"+          <> short 'o'+          <> help "Output path of generated .csv file"+          <> value ""+      )+    <*> switch+      ( long "upload"+          <> short 'u'+          <> help "Upload to hackage"+      )++runArgsParser :: IO Options+runArgsParser =+  execParser $+    info+      (cmdOptions <**> helper)+      ( fullDesc+          <> progDesc "Try to reach the TARGET QAQ."+          <> Options.Applicative.header "arch-hs-submit - a program submitting haskell packages in community to hackage arch distro."+      )++type DistroRecord = (String, String, String)++type DistroCSV = [DistroRecord]++renderDistroCSV :: DistroCSV -> String+renderDistroCSV = init . unlines . fmap (\(a, b, c) -> wrap a <> "," <> wrap b <> "," <> wrap c)+  where+    wrap x = "\"" <> x <> "\""++distroCSVParser :: M.Parsec Void String DistroCSV+distroCSVParser = M.sepBy distroRecordParser newline++distroRecordParser :: M.Parsec Void String DistroRecord+distroRecordParser =+  (M.between (M.char '"') (M.char '"') (M.many $ M.noneOf (",\"\n" :: String)) `M.sepBy` (M.char ',')) >>= \case+    (a : b : c : []) -> return (a, b, c)+    _ -> fail "Failed to parse record"++parseDistroCSV :: String -> DistroCSV+parseDistroCSV s = case M.parse distroCSVParser "DistroCSV" s of+  Left err -> fail $ M.errorBundlePretty err+  Right x -> x++genCSV :: Member CommunityEnv r => Sem r DistroCSV+genCSV = do+  db <- ask @CommunityDB+  let communityPackages = Map.toList db+      fields =+        communityPackages+          ^.. each+            . filtered (\(name, _) -> isHaskellPackage name)+            & mapped+            %~ _1+            <<%~ toHackageName+            & sortBy (\x y -> (x ^. _2 . _1) `compare` (y ^. _2 . _1))++      prefix = "https://www.archlinux.org/packages/community/x86_64/"+      processField (communityName, (hackageName, version)) =+        let communityName' =+              if (hackageName `elem` ghcLibList || hackageName == "ghc")+                then "ghc"+                else unCommunityName communityName+         in (unPackageName hackageName, version, prefix <> communityName')+  return $ processField <$> fields++submit :: Members [CommunityEnv, WithMyErr, Embed IO] r => Maybe String -> FilePath -> Bool -> Sem r ()+submit token output upload = do+  csv <- genCSV+  let v = renderDistroCSV csv+  embed $+    when (not . null $ output) $ do+      C.infoMessage $ "Write file: " <> T.pack output+      writeFile output v+  check csv+  interceptHttpException $+    when (token /= Nothing && upload) $ do+      C.infoMessage "Uploading..."+      let api = https "hackage.haskell.org" /: "distro" /: "Arch" /: "packages"+          r =+            req PUT api (ReqBodyBs . BS.pack $ v) bsResponse $+              header "Authorization" (BS.pack $ "X-ApiKey " <> fromJust token) <> header "Content-Type" "text/csv"+      result <- runReq defaultHttpConfig r+      C.infoMessage $ "StatusCode: " <> (T.pack . show $ responseStatusCode result)+      C.infoMessage $ "ResponseMessage: " <> (decodeUtf8 $ responseStatusMessage result)+      C.infoMessage "ResponseBody:"+      putStrLn . BS.unpack $ responseBody result++check :: Members [WithMyErr, Embed IO] r => DistroCSV -> Sem r ()+check community = do+  let api = https "hackage.haskell.org" /: "distro" /: "Arch" /: "packages.csv"+      r = req GET api NoReqBody bsResponse mempty+  embed $ C.infoMessage "Downloading csv from hackage..."+  result <- interceptHttpException $ runReq defaultHttpConfig r+  let bs = responseBody result+      hackage = parseDistroCSV . T.unpack $ decodeUtf8 bs++  let diffOld = hackage \\ community+      diffNew = community \\ hackage+      ppRecord b (name, version, url) = (if b then C.formatWith [C.green] else C.formatWith [C.red]) $ "(" <> name <> ", " <> version <> ", " <> url <> ")"++  embed $ case (diffNew <> diffOld) of+    [] -> return ()+    _ -> do+      putStrLn $ C.formatWith [C.magenta] "Diff:"+      putStr . unlines $ fmap (ppRecord False) diffOld+      putStrLn $ replicate 68 '-'+      putStr . unlines $ fmap (ppRecord True) diffNew++  embed . putStrLn $ "Found " <> show (length hackage) <> " packages with submitted distribution information in hackage, and " <> show (length community) <> " haskell packages in community."