packages feed

packdeps 0.4.3 → 0.4.4

raw patch · 5 files changed

+410/−370 lines, 5 filesdep +optparse-applicativedep +processdep +semigroupsdep ~Cabaldep ~containers

Dependencies added: optparse-applicative, process, semigroups

Dependency ranges changed: Cabal, containers

Files

ChangeLog.md view
@@ -1,3 +1,8 @@+## 0.4.4++* Switch over to Cabal 2.0. (Normally it would be better to keep+  backwards compat, but the API breakage is too high.)+ ## 0.4.3  * Updates (better cabal config parsing) [#30](https://github.com/snoyberg/packdeps/pull/30)
− Distribution/PackDeps.hs 
@@ -1,331 +0,0 @@-module Distribution.PackDeps-    ( -- * Data types-      Newest-    , CheckDepsRes (..)-    , DescInfo-      -- * Read package database-    , loadNewest-    , loadNewestFrom-    , parseNewest-      -- * Check a package-    , checkDeps-    , checkLibDeps-      -- * Get a single package-    , getPackage-    , parsePackage-    , loadPackage-      -- * Get multiple packages-    , filterPackages-    , deepDeps-    , deepLibDeps-      -- * Reverse dependencies-    , Reverses-    , getReverses-      -- * Helpers-    , diName-      -- * Internal-    , PackInfo (..)-    , piRevision-    , DescInfo (..)-    ) where--import Control.Applicative as A ((<$>))-import System.Directory (getAppUserDataDirectory, doesFileExist)-import System.FilePath ((</>))-import qualified Data.Map as Map-import Data.List (foldl', group, sort, isInfixOf)-import Data.Time (UTCTime (UTCTime), addUTCTime)-import Data.Maybe (mapMaybe, fromMaybe)-import Control.Exception (throw)--import Distribution.Package-import Distribution.PackageDescription-import Distribution.PackageDescription.Parse-import Distribution.Version-import Distribution.Text-import qualified Distribution.ParseUtils as PU--import Data.Char (toLower)-import qualified Data.Text.Lazy as T-import qualified Data.Text.Lazy.Encoding as T-import qualified Data.Text.Encoding.Error as T-import qualified Data.ByteString.Lazy as L--import Data.List.Split (splitOn)-import qualified Codec.Archive.Tar as Tar-import qualified Codec.Archive.Tar.Entry as Tar--import Data.Function (on)-import Control.Arrow ((&&&))-import Data.List (groupBy, sortBy)-import Data.Ord (comparing)-import qualified Data.Set as Set-import Text.Read (readMaybe)--- import Data.Monoid ((<>))--loadNewest :: IO Newest-loadNewest = do-    c <- getAppUserDataDirectory "cabal"-    cfg' <- readFile (c </> "config")-    cfg <- parseResult (fail . show) return $ PU.readFields cfg'-    let repos        = reposFromConfig cfg-        repoCache    = case lookupInConfig "remote-repo-cache" cfg of-            []        -> c </> "packages"  -- Default-            (rrc : _) -> rrc               -- User-specified-        tarNames repo = [ pfx </> "01-index.tar", pfx </> "00-index.tar" ]-          where pfx = repoCache </> repo-    fmap (Map.unionsWith maxVersion) . mapM (loadNewestFrom . tarNames) $ repos---- | Takes a list of possible pathes, tries them in order until one exists.-loadNewestFrom :: [FilePath] -> IO Newest-loadNewestFrom []         = fail "loadNewestFrom: no index tarball"-loadNewestFrom (fp : fps) = do-    e <- doesFileExist fp-    if e-        then fmap parseNewest (L.readFile fp)-        else loadNewestFrom fps--parseNewest :: L.ByteString -> Newest-parseNewest = foldl' addPackage Map.empty . entriesToList . Tar.read--entriesToList :: Tar.Entries Tar.FormatError -> [Tar.Entry]-entriesToList Tar.Done = []-entriesToList (Tar.Fail s) = throw s-entriesToList (Tar.Next e es) = e : entriesToList es--addPackage :: Newest -> Tar.Entry -> Newest-addPackage m entry =-    case splitOn "/" $ Tar.fromTarPathToPosixPath (Tar.entryTarPath entry) of-        [package', versionS, _] ->-            case simpleParse versionS of-                Just version ->-                    case Map.lookup package' m of-                        Nothing -> go package' version-                        Just PackInfo { piVersion = oldv } ->-                            -- in 01-index.tar there are entries with the same versions-                            if version >= oldv-                                then go package' version-                                else m-                Nothing -> m-        _ -> m-  where-    go package' version =-        case Tar.entryContent entry of-            Tar.NormalFile bs _ ->-                Map.insertWith maxVersion package' PackInfo-                        { piVersion = version-                        , piDesc = parsePackage bs-                        , piEpoch = Tar.entryTime entry-                        } m-            _ -> m--data PackInfo = PackInfo-    { piVersion  :: Version-    , piDesc     :: Maybe DescInfo-    , piEpoch    :: Tar.EpochTime-    }-    deriving (Show, Read)---- Extract revision from PackInfo, default to 0-piRevision :: PackInfo -> Int-piRevision = fromMaybe 0 . fmap diRevision . piDesc---- We should compare revisions as well,--- but we don't do that, as it would force `piDesc` and make `packdeps`--- executable increadibly slow (parse all cabal files on Hackage)--- Instead we rely on the fact that newer revisions are always later in--- 01-index.tar-maxVersion :: PackInfo -> PackInfo -> PackInfo-maxVersion pi1 pi2 = if piVersion pi1 <= piVersion pi2 then pi2 else pi1---- | The newest version of every package.-type Newest = Map.Map String PackInfo--type Reverses = Map.Map String (Version, [(String, VersionRange)])--getReverses :: Newest -> Reverses-getReverses newest =-    Map.fromList withVersion-  where-    -- dep = dependency, rel = relying package-    toTuples (_, PackInfo { piDesc = Nothing }) = []-    toTuples (rel, PackInfo { piDesc = Just DescInfo { diDeps = deps } }) =-        map (toTuple rel) deps-    toTuple rel (Dependency (PackageName dep) range) = (dep, (rel, range))-    hoist :: Ord a => [(a, b)] -> [(a, [b])]-    hoist = map ((fst . head) &&& map snd)-          . groupBy ((==) `on` fst)-          . sortBy (comparing fst)-    hoisted = hoist $ concatMap toTuples $ Map.toList newest-    withVersion = mapMaybe addVersion hoisted-    addVersion (dep, rels) =-        case Map.lookup dep newest of-            Nothing -> Nothing-            Just PackInfo { piVersion = v} -> Just (dep, (v, rels))---- | Information on a single package.-data DescInfo = DescInfo-    { diHaystack :: String-    , diDeps     :: [Dependency]-    , diLibDeps  :: [Dependency]-    , diPackage  :: PackageIdentifier-    , diRevision :: Int-    , diSynopsis :: String-    }-    deriving (Show, Read)---- | Return revision and DescInfo-getDescInfo :: GenericPackageDescription -> DescInfo-getDescInfo gpd = DescInfo-    { diHaystack = map toLower $ author p ++ maintainer p ++ name-    , diDeps     = getDeps gpd-    , diLibDeps  = getLibDeps gpd-    , diPackage  = pi'-    , diRevision = rev-    , diSynopsis = synopsis p-    }-  where-    p = packageDescription gpd-    pi'@(PackageIdentifier (PackageName name) _) = package p-    rev = fromMaybe 0 $ do-        r <- lookup "x-revision" (customFieldsPD p)-        readMaybe r--getDeps :: GenericPackageDescription -> [Dependency]-getDeps x = getLibDeps x ++ concat-    [ concatMap (condTreeConstraints . snd) (condExecutables x)-    , concatMap (condTreeConstraints . snd) (condTestSuites x)-    , concatMap (condTreeConstraints . snd) (condBenchmarks x)-    ]--getLibDeps :: GenericPackageDescription -> [Dependency]-getLibDeps gpd = maybe [] condTreeConstraints (condLibrary gpd)--checkDeps :: Newest -> DescInfo-          -> (PackageName, Version, CheckDepsRes)-checkDeps = checkDepsImpl diDeps--checkLibDeps :: Newest -> DescInfo-             -> (PackageName, Version, CheckDepsRes)-checkLibDeps = checkDepsImpl diLibDeps--checkDepsImpl :: (DescInfo -> [Dependency]) -> Newest -> DescInfo-              -> (PackageName, Version, CheckDepsRes)-checkDepsImpl deps newest desc =-    case mapMaybe (notNewest newest) $ deps desc of-        [] -> (name, version, AllNewest)-        x -> let y = map head $ group $ sort $ map fst x-                 et = maximum $ map snd x-              in (name, version, WontAccept y $ epochToTime et)-  where-    PackageIdentifier name version = diPackage desc---- | Whether or not a package can accept all of the newest versions of its--- dependencies. If not, it returns a list of packages which are not accepted,--- and a timestamp of the most recently updated package.-data CheckDepsRes = AllNewest-                  | WontAccept [(String, String)] UTCTime-    deriving Show--epochToTime :: Tar.EpochTime -> UTCTime-epochToTime e = addUTCTime (fromIntegral e) $ UTCTime (read "1970-01-01") 0--notNewest :: Newest -> Dependency -> Maybe ((String, String), Tar.EpochTime)-notNewest newest (Dependency (PackageName s) range) =-    case Map.lookup s newest of-        --Nothing -> Just ((s, " no version found"), 0)-        Nothing -> Nothing-        Just PackInfo { piVersion = version, piEpoch = e } ->-            if withinRange version range-                then Nothing-                else Just ((s, display version), e)---- | Loads up the newest version of a package from the 'Newest' list, if--- available.-getPackage :: String -> Newest -> Maybe DescInfo-getPackage s n = Map.lookup s n >>= piDesc---- | Parse information on a package from the contents of a cabal file.-parsePackage :: L.ByteString -> Maybe DescInfo-parsePackage lbs =-    case parsePackageDescription $ T.unpack-       $ T.decodeUtf8With T.lenientDecode lbs of-        ParseOk _ x -> Just $ getDescInfo x-        _ -> Nothing---- | Load a single package from a cabal file.-loadPackage :: FilePath -> IO (Maybe DescInfo)-loadPackage = fmap parsePackage . L.readFile---- | Find all of the packages matching a given search string.-filterPackages :: String -> Newest -> [DescInfo]-filterPackages needle =-    mapMaybe go . Map.elems-  where-    needle' = map toLower needle-    go PackInfo { piDesc = Just desc } =-        if needle' `isInfixOf` diHaystack desc &&-           not ("(deprecated)" `isInfixOf` diSynopsis desc)-            then Just desc-            else Nothing-    go _ = Nothing---- | Find all packages depended upon by the given list of packages.-deepDeps :: Newest -> [DescInfo] -> [DescInfo]-deepDeps = deepDepsImpl diDeps---- | Find all packages depended upon by the given list of packages.-deepLibDeps :: Newest -> [DescInfo] -> [DescInfo]-deepLibDeps = deepDepsImpl diLibDeps--deepDepsImpl :: (DescInfo -> [Dependency]) -> Newest -> [DescInfo] -> [DescInfo]-deepDepsImpl deps newest dis0 =-    go Set.empty dis0-  where-    go _ [] = []-    go viewed (di:dis)-        | name `Set.member` viewed = go viewed dis-        | otherwise = di : go viewed' (newDis ++ dis)-      where-        PackageIdentifier (PackageName name) _ = diPackage di-        viewed' = Set.insert name viewed-        newDis = mapMaybe getDI $ deps di-        getDI :: Dependency -> Maybe DescInfo-        getDI (Dependency (PackageName name') _) = do-            pi' <- Map.lookup name' newest-            piDesc pi'--diName :: DescInfo -> String-diName =-    unPN . pkgName . diPackage-  where-    unPN (PackageName pn) = pn------------------------------------------------------------------------------------ ~/.cabal/config parsing----------------------------------------------------------------------------------reposFromConfig :: [PU.Field] -> [String]-reposFromConfig fields = takeWhile (/= ':') A.<$> mapMaybe f fields-  where-    f (PU.F _lineNo name value)-        | name == "remote-repo"-        = Just value-    f (PU.Section _lineNo secName arg _fields)-        | secName == "repository"-        = Just arg-    f _ = Nothing---- | Looks up the given key in the cabal configuration file-lookupInConfig :: String -> [PU.Field] -> [String]-lookupInConfig key = mapMaybe f-  where-    f (PU.F _lineNo name value)-        | name == key-        = Just value-    f _ = Nothing---- | Like 'either', but for 'ParseResult'-parseResult :: (PU.PError -> r) -> (a -> r) -> ParseResult a -> r-parseResult l _ (PU.ParseFailed e)    = l e-parseResult _ r (PU.ParseOk _warns x) = r x
packdeps.cabal view
@@ -1,5 +1,5 @@ name:            packdeps-version:         0.4.3+version:         0.4.4 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>@@ -17,12 +17,13 @@ extra-source-files: README.md ChangeLog.md  library+    hs-source-dirs: src     build-depends:   base                      >= 4.6      && < 5                    , tar                       >= 0.4      && < 0.6                    , split                     >= 0.1.2.3                    , bytestring                >= 0.9                    , text                      >= 0.7-                   , Cabal                     >= 1.14     && <1.25+                   , Cabal                     >= 2.0      && < 2.1                    , time                      >= 1.1.4                    , containers                >= 0.2                    , directory                 >= 1.0@@ -38,6 +39,10 @@      build-depends:   base                      >= 4        && < 5                    , Cabal+                   , optparse-applicative      >=0.14 && <0.15+                   , containers+                   , semigroups+                   , process                    , packdeps  source-repository head
+ src/Distribution/PackDeps.hs view
@@ -0,0 +1,329 @@+{-# LANGUAGE ViewPatterns #-}+module Distribution.PackDeps+    ( -- * Data types+      Newest+    , CheckDepsRes (..)+    , DescInfo+      -- * Read package database+    , loadNewest+    , loadNewestFrom+    , parseNewest+      -- * Check a package+    , checkDeps+    , checkLibDeps+      -- * Get a single package+    , getPackage+    , parsePackage+    , loadPackage+      -- * Get multiple packages+    , filterPackages+    , deepDeps+    , deepLibDeps+      -- * Reverse dependencies+    , Reverses+    , getReverses+      -- * Helpers+    , diName+      -- * Internal+    , PackInfo (..)+    , piRevision+    , DescInfo (..)+    ) where++import Control.Applicative as A ((<$>))+import System.Directory (getAppUserDataDirectory, doesFileExist)+import System.FilePath ((</>))+import qualified Data.Map as Map+import Data.List (foldl', group, sort, isInfixOf)+import Data.Time (UTCTime (UTCTime), addUTCTime)+import Data.Maybe (mapMaybe, fromMaybe)+import Control.Exception (throw)++import Distribution.Package+import Distribution.PackageDescription+import Distribution.PackageDescription.Parse+import Distribution.Version+import Distribution.Text+import qualified Distribution.ParseUtils as PU++import Data.Char (toLower)+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.Encoding as T+import qualified Data.Text.Encoding.Error as T+import qualified Data.ByteString.Lazy as L++import Data.List.Split (splitOn)+import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Tar.Entry as Tar++import Data.Function (on)+import Control.Arrow ((&&&))+import Data.List (groupBy, sortBy)+import Data.Ord (comparing)+import qualified Data.Set as Set+import Text.Read (readMaybe)+-- import Data.Monoid ((<>))++loadNewest :: IO Newest+loadNewest = do+    c <- getAppUserDataDirectory "cabal"+    cfg' <- readFile (c </> "config")+    cfg <- parseResult (fail . show) return $ PU.readFields cfg'+    let repos        = reposFromConfig cfg+        repoCache    = case lookupInConfig "remote-repo-cache" cfg of+            []        -> c </> "packages"  -- Default+            (rrc : _) -> rrc               -- User-specified+        tarNames repo = [ pfx </> "01-index.tar", pfx </> "00-index.tar" ]+          where pfx = repoCache </> repo+    fmap (Map.unionsWith maxVersion) . mapM (loadNewestFrom . tarNames) $ repos++-- | Takes a list of possible pathes, tries them in order until one exists.+loadNewestFrom :: [FilePath] -> IO Newest+loadNewestFrom []         = fail "loadNewestFrom: no index tarball"+loadNewestFrom (fp : fps) = do+    e <- doesFileExist fp+    if e+        then fmap parseNewest (L.readFile fp)+        else loadNewestFrom fps++parseNewest :: L.ByteString -> Newest+parseNewest = foldl' addPackage Map.empty . entriesToList . Tar.read++entriesToList :: Tar.Entries Tar.FormatError -> [Tar.Entry]+entriesToList Tar.Done = []+entriesToList (Tar.Fail s) = throw s+entriesToList (Tar.Next e es) = e : entriesToList es++addPackage :: Newest -> Tar.Entry -> Newest+addPackage m entry =+    case splitOn "/" $ Tar.fromTarPathToPosixPath (Tar.entryTarPath entry) of+        [package', versionS, _] ->+            case simpleParse versionS of+                Just version ->+                    case Map.lookup package' m of+                        Nothing -> go package' version+                        Just PackInfo { piVersion = oldv } ->+                            -- in 01-index.tar there are entries with the same versions+                            if version >= oldv+                                then go package' version+                                else m+                Nothing -> m+        _ -> m+  where+    go package' version =+        case Tar.entryContent entry of+            Tar.NormalFile bs _ ->+                Map.insertWith maxVersion package' PackInfo+                        { piVersion = version+                        , piDesc = parsePackage bs+                        , piEpoch = Tar.entryTime entry+                        } m+            _ -> m++data PackInfo = PackInfo+    { piVersion  :: Version+    , piDesc     :: Maybe DescInfo+    , piEpoch    :: Tar.EpochTime+    }+    deriving (Show, Read)++-- Extract revision from PackInfo, default to 0+piRevision :: PackInfo -> Int+piRevision = fromMaybe 0 . fmap diRevision . piDesc++-- We should compare revisions as well,+-- but we don't do that, as it would force `piDesc` and make `packdeps`+-- executable increadibly slow (parse all cabal files on Hackage)+-- Instead we rely on the fact that newer revisions are always later in+-- 01-index.tar+maxVersion :: PackInfo -> PackInfo -> PackInfo+maxVersion pi1 pi2 = if piVersion pi1 <= piVersion pi2 then pi2 else pi1++-- | The newest version of every package.+type Newest = Map.Map String PackInfo++type Reverses = Map.Map String (Version, [(String, VersionRange)])++getReverses :: Newest -> Reverses+getReverses newest =+    Map.fromList withVersion+  where+    -- dep = dependency, rel = relying package+    toTuples (_, PackInfo { piDesc = Nothing }) = []+    toTuples (rel, PackInfo { piDesc = Just DescInfo { diDeps = deps } }) =+        map (toTuple rel) deps+    toTuple rel (Dependency (unPackageName -> dep) range) = (dep, (rel, range))+    hoist :: Ord a => [(a, b)] -> [(a, [b])]+    hoist = map ((fst . head) &&& map snd)+          . groupBy ((==) `on` fst)+          . sortBy (comparing fst)+    hoisted = hoist $ concatMap toTuples $ Map.toList newest+    withVersion = mapMaybe addVersion hoisted+    addVersion (dep, rels) =+        case Map.lookup dep newest of+            Nothing -> Nothing+            Just PackInfo { piVersion = v} -> Just (dep, (v, rels))++-- | Information on a single package.+data DescInfo = DescInfo+    { diHaystack :: String+    , diDeps     :: [Dependency]+    , diLibDeps  :: [Dependency]+    , diPackage  :: PackageIdentifier+    , diRevision :: Int+    , diSynopsis :: String+    }+    deriving (Show, Read)++-- | Return revision and DescInfo+getDescInfo :: GenericPackageDescription -> DescInfo+getDescInfo gpd = DescInfo+    { diHaystack = map toLower $ author p ++ maintainer p ++ name+    , diDeps     = getDeps gpd+    , diLibDeps  = getLibDeps gpd+    , diPackage  = pi'+    , diRevision = rev+    , diSynopsis = synopsis p+    }+  where+    p = packageDescription gpd+    pi'@(PackageIdentifier (unPackageName -> name) _) = package p+    rev = fromMaybe 0 $ do+        r <- lookup "x-revision" (customFieldsPD p)+        readMaybe r++getDeps :: GenericPackageDescription -> [Dependency]+getDeps x = getLibDeps x ++ concat+    [ concatMap (condTreeConstraints . snd) (condExecutables x)+    , concatMap (condTreeConstraints . snd) (condTestSuites x)+    , concatMap (condTreeConstraints . snd) (condBenchmarks x)+    ]++getLibDeps :: GenericPackageDescription -> [Dependency]+getLibDeps gpd = maybe [] condTreeConstraints (condLibrary gpd)++checkDeps :: Newest -> DescInfo+          -> (PackageName, Version, CheckDepsRes)+checkDeps = checkDepsImpl diDeps++checkLibDeps :: Newest -> DescInfo+             -> (PackageName, Version, CheckDepsRes)+checkLibDeps = checkDepsImpl diLibDeps++checkDepsImpl :: (DescInfo -> [Dependency]) -> Newest -> DescInfo+              -> (PackageName, Version, CheckDepsRes)+checkDepsImpl deps newest desc =+    case mapMaybe (notNewest newest) $ deps desc of+        [] -> (name, version, AllNewest)+        x -> let y = map head $ group $ sort $ map fst x+                 et = maximum $ map snd x+              in (name, version, WontAccept y $ epochToTime et)+  where+    PackageIdentifier name version = diPackage desc++-- | Whether or not a package can accept all of the newest versions of its+-- dependencies. If not, it returns a list of packages which are not accepted,+-- and a timestamp of the most recently updated package.+data CheckDepsRes = AllNewest+                  | WontAccept [(String, String)] UTCTime+    deriving Show++epochToTime :: Tar.EpochTime -> UTCTime+epochToTime e = addUTCTime (fromIntegral e) $ UTCTime (read "1970-01-01") 0++notNewest :: Newest -> Dependency -> Maybe ((String, String), Tar.EpochTime)+notNewest newest (Dependency (unPackageName -> s) range) =+    case Map.lookup s newest of+        --Nothing -> Just ((s, " no version found"), 0)+        Nothing -> Nothing+        Just PackInfo { piVersion = version, piEpoch = e } ->+            if withinRange version range+                then Nothing+                else Just ((s, display version), e)++-- | Loads up the newest version of a package from the 'Newest' list, if+-- available.+getPackage :: String -> Newest -> Maybe DescInfo+getPackage s n = Map.lookup s n >>= piDesc++-- | Parse information on a package from the contents of a cabal file.+parsePackage :: L.ByteString -> Maybe DescInfo+parsePackage lbs =+    case parseGenericPackageDescription $ T.unpack+       $ T.decodeUtf8With T.lenientDecode lbs of+        ParseOk _ x -> Just $ getDescInfo x+        _ -> Nothing++-- | Load a single package from a cabal file.+loadPackage :: FilePath -> IO (Maybe DescInfo)+loadPackage = fmap parsePackage . L.readFile++-- | Find all of the packages matching a given search string.+filterPackages :: String -> Newest -> [DescInfo]+filterPackages needle =+    mapMaybe go . Map.elems+  where+    needle' = map toLower needle+    go PackInfo { piDesc = Just desc } =+        if needle' `isInfixOf` diHaystack desc &&+           not ("(deprecated)" `isInfixOf` diSynopsis desc)+            then Just desc+            else Nothing+    go _ = Nothing++-- | Find all packages depended upon by the given list of packages.+deepDeps :: Newest -> [DescInfo] -> [DescInfo]+deepDeps = deepDepsImpl diDeps++-- | Find all packages depended upon by the given list of packages.+deepLibDeps :: Newest -> [DescInfo] -> [DescInfo]+deepLibDeps = deepDepsImpl diLibDeps++deepDepsImpl :: (DescInfo -> [Dependency]) -> Newest -> [DescInfo] -> [DescInfo]+deepDepsImpl deps newest dis0 =+    go Set.empty dis0+  where+    go _ [] = []+    go viewed (di:dis)+        | name `Set.member` viewed = go viewed dis+        | otherwise = di : go viewed' (newDis ++ dis)+      where+        PackageIdentifier name _ = diPackage di+        viewed' = Set.insert name viewed+        newDis = mapMaybe getDI $ deps di+        getDI :: Dependency -> Maybe DescInfo+        getDI (Dependency name' _) = do+            pi' <- Map.lookup (unPackageName name') newest+            piDesc pi'++diName :: DescInfo -> String+diName = unPackageName . pkgName . diPackage++-------------------------------------------------------------------------------+-- ~/.cabal/config parsing+-------------------------------------------------------------------------------++reposFromConfig :: [PU.Field] -> [String]+reposFromConfig fields = takeWhile (/= ':') A.<$> mapMaybe f fields+  where+    f (PU.F _lineNo name value)+        | name == "remote-repo"+        = Just value+    f (PU.Section _lineNo secName arg _fields)+        | secName == "repository"+        = Just arg+    f _ = Nothing++-- | Looks up the given key in the cabal configuration file+lookupInConfig :: String -> [PU.Field] -> [String]+lookupInConfig key = mapMaybe f+  where+    f (PU.F _lineNo name value)+        | name == key+        = Just value+    f _ = Nothing++-- | Like 'either', but for 'ParseResult'+parseResult :: (PU.PError -> r) -> (a -> r) -> ParseResult a -> r+parseResult l _ (PU.ParseFailed e)    = l e+parseResult _ r (PU.ParseOk _warns x) = r x
tools/packdeps-cli.hs view
@@ -1,28 +1,46 @@-import Distribution.PackDeps+{-# LANGUAGE ViewPatterns #-}+import Control.Applicative (many, some) import Control.Monad (forM_, foldM, when)-import System.Environment (getArgs, getProgName)-import System.Exit (exitFailure, exitSuccess)-import Distribution.Text (display)-import Distribution.Package (PackageName (PackageName))-import Distribution.Version (Version) import Control.Monad (liftM)+import Data.List (foldl')+import Data.Maybe (mapMaybe)+import Data.Semigroup ((<>))+import Distribution.Compat.ReadP (readP_to_S)+import Distribution.PackDeps+import Distribution.Package (PackageIdentifier (PackageIdentifier), PackageName, unPackageName)+import Distribution.Text (display, parse)+import Distribution.Version (Version)+import System.Exit (exitFailure, exitSuccess)+import System.Process (readProcess) +import qualified Data.Map as Map+import qualified Options.Applicative as O+ main :: IO () main = do-    args <- getArgs-    case args of-        [] -> usageExit-        ["help"] -> usageExit-        _ | "-h" `elem` args || "--help" `elem` args -> usageExit-        _ -> do-            isGood <- run ("--recursive" `elem` args) ("--quiet" `elem` args) (filter (\arg -> arg /= "--recursive" && arg /= "--quiet") args)-            if isGood then exitSuccess else exitFailure+    run' <- O.execParser $ O.info (O.helper <*> opts) $ mconcat+        [ O.fullDesc+        , O.progDesc $ unwords+            [ "Check the given cabal file's dependency list to make sure that it does not exclude"+            , "the newest package available. It's probably worth running the 'cabal update' command"+            , "immediately before running this program."+            ]+        ]+    isGood <- run'+    if isGood then exitSuccess else exitFailure+  where+    opts = run+        <$> O.switch (O.short 'r' <> O.long "recursive" <> O.help "Check transitive dependencies as well.")+        <*> O.switch (O.short 'q' <> O.long "quiet" <> O.help "Suppress output for .cabal files which can accept the newest packages available.")+        <*> O.switch (O.short 'g' <> O.long "ghc-pkg" <> O.help "Use ghc-pkg list to additionally populate the newest packages database.")+        <*> many (O.strOption (O.short 'e' <> O.long "exclude" <> O.metavar "pkgname" <> O.help "Exclude the package from the output."))+        <*> some (O.strArgument (O.metavar "pkgname.cabal"))  type CheckDeps = Newest -> DescInfo -> (PackageName, Version, CheckDepsRes) -checkDepsCli :: Bool -> CheckDeps -> Newest -> DescInfo -> IO Bool-checkDepsCli quiet cd newest di =-    case cd newest di of+checkDepsCli :: Bool -> [String] -> CheckDeps -> Newest -> DescInfo -> IO Bool+checkDepsCli quiet excludes cd newest di =+    case overTrd filterExcludes $ cd newest di of         (pn, v, AllNewest)           | quiet -> return True           | otherwise -> do@@ -42,13 +60,43 @@                 ]             forM_ p $ \(x, y) -> putStrLn $ x ++ " " ++ y             return False+  where+    overTrd :: (a -> b) -> (x, y, a) -> (x, y, b)+    overTrd f (x, y, a) = (x, y, f a) +    filterExcludes :: CheckDepsRes -> CheckDepsRes+    filterExcludes AllNewest = AllNewest+    filterExcludes (WontAccept p t) =+        case filter (\(n, _) -> n `notElem` excludes) p of+            [] -> AllNewest+            p' -> WontAccept p' t++-- TODO+updateWithGhcPkg :: Newest -> IO Newest+updateWithGhcPkg newest = do+    output <- readProcess "ghc-pkg" ["list", "--simple-output"] ""+    let pkgs = mapMaybe parseSimplePackInfo (words output)+    return $ foldl' apply newest pkgs+  where+    apply :: Newest -> (String, PackInfo) -> Newest+    apply m (k, v) = Map.insert k v m++    parseSimplePackInfo :: String -> Maybe (String, PackInfo)+    parseSimplePackInfo str =+        case filter ((== "") . snd) $ readP_to_S parse str of+            ((PackageIdentifier (unPackageName -> name) ver, _) : _) ->+                Just (name, PackInfo ver Nothing 0)+            _ -> Nothing+ run :: Bool        -- ^ Check transitive dependencies     -> Bool        -- ^ Quiet -- only report packages that are not up to date+    -> Bool        -- ^ ghc-pkg -- use ghc-pkg list to see whether there are even newer packages.+    -> [String]    -- ^ packages to exclude     -> [FilePath]  -- ^ .cabal filenames     -> IO Bool-run deep quiet args = do-    newest <- loadNewest+run deep quiet ghcpkg excludes args = do+    newest' <- loadNewest+    newest <- if ghcpkg then updateWithGhcPkg newest' else return newest'     foldM (go newest) True args   where     go newest wasAllGood fp = do@@ -56,29 +104,13 @@         di <- case mdi of              Just di -> return di              Nothing -> error $ "Could not parse cabal file: " ++ fp-        allGood <- checkDepsCli quiet checkDeps newest di+        allGood <- checkDepsCli quiet excludes checkDeps newest di         depsGood <- if deep                        then do putStrLn $ "\nTransitive dependencies:"-                               allM (checkDepsCli quiet checkLibDeps newest) (deepLibDeps newest [di])+                               allM (checkDepsCli quiet excludes checkLibDeps newest) (deepLibDeps newest [di])                        else return True         when (not (allGood && depsGood)) $ putStrLn ""         return $ wasAllGood && allGood && depsGood--unPackageName :: PackageName -> String-unPackageName (PackageName n) = n---usageExit :: IO a-usageExit = do-    pname <- getProgName-    putStrLn $ "\n"-        ++ "Usage: " ++ pname ++ " [--recursive] [--quiet] pkgname.cabal pkgname2.cabal...\n\n"-        ++ "Check the given cabal file's dependency list to make sure that it does not exclude\n"-        ++ "the newest package available. Its probably worth running the 'cabal update' command\n"-        ++ "immediately before running this program.\n\n"-        ++ "  --quiet\n"-        ++ "      Suppress output for .cabal files which can accept the newest packages available.\n"-    exitSuccess  -- | Non short-circuiting monadic version of 'all' -- Duh, pre-AMP code.