diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,9 @@ +# ChangeLog for packdeps + +## 0.5.0.0 + +* Switch to Cabal 3.0 + ## 0.4.5 * Switch to Cabal 2.2 diff --git a/packdeps.cabal b/packdeps.cabal --- a/packdeps.cabal +++ b/packdeps.cabal @@ -1,5 +1,5 @@ name: packdeps -version: 0.4.5 +version: 0.5.0.0 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -11,19 +11,20 @@ The command line tool has an incredibly simple interface: simply pass it a list of cabal files, and it will tell you what dependencies- if any- are restricted. category: Distribution stability: Stable -cabal-version: >= 1.8 +cabal-version: >= 1.10 build-type: Simple homepage: http://packdeps.haskellers.com/ extra-source-files: README.md ChangeLog.md library + default-language: Haskell2010 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 >= 2.2 && < 2.3 + , Cabal >= 3.0 && < 3.1 , time >= 1.1.4 , containers >= 0.2 , directory >= 1.0 @@ -32,6 +33,7 @@ ghc-options: -Wall executable packdeps + default-language: Haskell2010 main-is: packdeps-cli.hs hs-source-dirs: tools @@ -39,7 +41,7 @@ build-depends: base >= 4 && < 5 , Cabal - , optparse-applicative >=0.14 && <0.15 + , optparse-applicative >=0.14 && <0.16 , containers , semigroups , process diff --git a/src/Distribution/PackDeps.hs b/src/Distribution/PackDeps.hs --- a/src/Distribution/PackDeps.hs +++ b/src/Distribution/PackDeps.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} module Distribution.PackDeps ( -- * Data types Newest @@ -43,10 +44,13 @@ import Distribution.Package import Distribution.PackageDescription import Distribution.PackageDescription.Parsec -import Distribution.Parsec.Class (Parsec, lexemeParsec, runParsecParser, simpleParsec) +import Distribution.Parsec (Parsec, lexemeParsec, runParsecParser, simpleParsec) import Distribution.Parsec.FieldLineStream (fieldLineStreamFromBS) +import Distribution.Types.CondTree import Distribution.Version -import qualified Distribution.ParseUtils as PU +import qualified Distribution.Fields as F +import qualified Distribution.Fields.Field as F +import qualified Distribution.Simple.Utils as U import Data.Char (toLower) import qualified Data.ByteString as S @@ -62,13 +66,16 @@ import Data.Ord (comparing) import qualified Data.Set as Set import Text.Read (readMaybe) +import System.Environment (lookupEnv) -- import Data.Monoid ((<>)) loadNewest :: Bool -> IO Newest loadNewest preferred = do c <- getAppUserDataDirectory "cabal" - cfg' <- readFile (c "config") - cfg <- parseResult (fail . show) return $ PU.readFields cfg' + location <- fmap (fromMaybe (c "config")) (lookupEnv "CABAL_CONFIG") + + cfg' <- S.readFile location + cfg <- either (fail . show) return $ F.readFields cfg' let repos = reposFromConfig cfg repoCache = case lookupInConfig "remote-repo-cache" cfg of [] -> c "packages" -- Default @@ -136,7 +143,7 @@ [_packageS, "preferred-versions"] -> case Tar.entryContent entry of Tar.NormalFile bs _ -> case simpleParsecLBS bs of - Just (Dependency dep range) -> Map.insert dep range m + Just (Dependency dep range _) -> Map.insert dep range m Nothing -> m _ -> m _ -> m @@ -183,7 +190,7 @@ toTuples (_, PackInfo { piDesc = Nothing }) = [] toTuples (rel, PackInfo { piDesc = Just DescInfo { diDeps = deps } }) = map (toTuple rel) deps - toTuple rel (Dependency dep range) = (dep, (rel, range)) + toTuple rel (Dependency dep range _) = (dep, (rel, range)) hoist :: Ord a => [(a, b)] -> [(a, [b])] hoist = map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) @@ -225,14 +232,41 @@ getDeps :: GenericPackageDescription -> [Dependency] getDeps x = getLibDeps x ++ concat - [ concatMap (condTreeConstraints . snd) (condExecutables x) - , concatMap (condTreeConstraints . snd) (condTestSuites x) - , concatMap (condTreeConstraints . snd) (condBenchmarks x) + [ concatMap (condTreeConstraints' . snd) (condExecutables x) + , concatMap (condTreeConstraints' . snd) (condTestSuites x) + , concatMap (condTreeConstraints' . snd) (condBenchmarks x) ] getLibDeps :: GenericPackageDescription -> [Dependency] -getLibDeps gpd = maybe [] condTreeConstraints (condLibrary gpd) +getLibDeps gpd = maybe [] condTreeConstraints' (condLibrary gpd) ++ customDeps + where + pd = packageDescription gpd + customDeps + | buildType pd == Custom = maybe defSetupDeps setupDepends (setupBuildInfo pd) + | otherwise = [] + -- we only interested in Cabal default upper bound + -- See cabal-install Distribution.Client.ProjectPlanning defaultSetupDeps + defSetupDeps = [Dependency (mkPackageName "Cabal") (earlierVersion $ mkVersion [1,25]) mempty] + +condTreeConstraints' :: Monoid c => CondTree ConfVar c a -> c +condTreeConstraints' = go where + go (CondNode _ c bs) = mappend c (foldMap branch bs) + + branch (CondBranch c' x y) + | notFlagCondition c' = mappend (go x) (foldMap go y) + | otherwise = mempty + +notFlagCondition :: Condition ConfVar -> Bool +notFlagCondition (Var (OS _)) = True +notFlagCondition (Var (Arch _)) = True +notFlagCondition (Var (Flag _)) = False +notFlagCondition (Var (Impl _ _)) = True +notFlagCondition (Lit _) = True +notFlagCondition (CNot a) = notFlagCondition a +notFlagCondition (COr a b) = notFlagCondition a && notFlagCondition b +notFlagCondition (CAnd a b) = notFlagCondition a && notFlagCondition b + checkDeps :: Newest -> DescInfo -> (PackageName, Version, CheckDepsRes) checkDeps = checkDepsImpl diDeps @@ -263,7 +297,7 @@ epochToTime e = addUTCTime (fromIntegral e) $ UTCTime (read "1970-01-01") 0 notNewest :: Newest -> Dependency -> Maybe ((PackageName, Version), Tar.EpochTime) -notNewest newest (Dependency s range) = +notNewest newest (Dependency s range _public) = case Map.lookup s newest of --Nothing -> Just ((s, " no version found"), 0) Nothing -> Nothing @@ -322,7 +356,7 @@ viewed' = Set.insert name viewed newDis = mapMaybe getDI $ deps di getDI :: Dependency -> Maybe DescInfo - getDI (Dependency name' _) = do + getDI (Dependency name' _ _) = do pi' <- Map.lookup name' newest piDesc pi' @@ -333,27 +367,29 @@ -- ~/.cabal/config parsing ------------------------------------------------------------------------------- -reposFromConfig :: [PU.Field] -> [String] +reposFromConfig :: [F.Field ann] -> [String] reposFromConfig fields = takeWhile (/= ':') A.<$> mapMaybe f fields where - f (PU.F _lineNo name value) + f (F.Field (F.Name _pos name) fls) | name == "remote-repo" - = Just value - f (PU.Section _lineNo secName arg _fields) + = Just $ U.fromUTF8BS $ S.intercalate "\n" (map F.fieldLineBS fls) + f (F.Section (F.Name _pos secName) (F.SecArgName _ arg : _) _fields) | secName == "repository" - = Just arg + = Just $ U.fromUTF8BS arg f _ = Nothing -- | Looks up the given key in the cabal configuration file -lookupInConfig :: String -> [PU.Field] -> [String] +lookupInConfig :: S.ByteString -> [F.Field ann] -> [String] lookupInConfig key = mapMaybe f where - f (PU.F _lineNo name value) + f (F.Field (F.Name _pos name) fls) | name == key - = Just value + = Just $ U.fromUTF8BS $ S.intercalate "\n" (map F.fieldLineBS fls) f _ = Nothing +{- -- | Like 'either', but for 'ParseResult' -parseResult :: (PU.PError -> r) -> (a -> r) -> PU.ParseResult a -> r -parseResult l _ (PU.ParseFailed e) = l e -parseResult _ r (PU.ParseOk _warns x) = r x +parseResult :: (F.PError -> r) -> (a -> r) -> F.ParseResult a -> r +parseResult l _ (F.ParseFailed e) = l e +parseResult _ r (F.ParseOk _warns x) = r x +-} diff --git a/tools/packdeps-cli.hs b/tools/packdeps-cli.hs --- a/tools/packdeps-cli.hs +++ b/tools/packdeps-cli.hs @@ -2,14 +2,14 @@ import Control.Applicative (many, some) import Control.Monad (forM_, foldM, when) import Control.Monad (liftM) +import Data.Char (isSpace) 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.Package (PackageIdentifier (pkgName, pkgVersion), PackageName, unPackageName) +import Distribution.Text (display) import Distribution.Version (Version) +import qualified Distribution.InstalledPackageInfo as IPI import System.Exit (exitFailure, exitSuccess) import System.Process (readProcess) @@ -75,19 +75,35 @@ -- 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 + output <- readProcess "ghc-pkg" ["dump"] "" + ipis <- either (fail . show) (return . map snd) $ + traverse IPI.parseInstalledPackageInfo $ splitPkgs output + return $ foldl' apply newest $ map toPackInfo ipis where apply :: Newest -> (PackageName, PackInfo) -> Newest apply m (k, v) = Map.insert k v m - parseSimplePackInfo :: String -> Maybe (PackageName, PackInfo) - parseSimplePackInfo str = - case filter ((== "") . snd) $ readP_to_S parse str of - ((PackageIdentifier name ver, _) : _) -> - Just (name, PackInfo ver Nothing 0) - _ -> Nothing + toPackInfo :: IPI.InstalledPackageInfo -> (PackageName, PackInfo) + toPackInfo ipi = (pkgName $ IPI.sourcePackageId ipi, pinfo) where + pinfo = PackInfo + { piVersion = pkgVersion $ IPI.sourcePackageId ipi + , piEpoch = 0 + , piDesc = Nothing + } + + -- copied from from Cabal + splitPkgs :: String -> [String] + splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines + where + -- Handle the case of there being no packages at all. + checkEmpty [s] | all isSpace s = [] + checkEmpty ss = ss + + splitWith :: (a -> Bool) -> [a] -> [[a]] + splitWith p xs = ys : case zs of + [] -> [] + _:ws -> splitWith p ws + where (ys,zs) = break p xs run :: Bool -- ^ Check transitive dependencies -> Bool -- ^ Quiet -- only report packages that are not up to date