From 4ede5f0d9a8e3f6443341c1610585ec93f542a8d Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 11 Dec 2014 11:08:49 +0200 Subject: [PATCH] Track which components have which dependencies --- Stackage2/CheckBuildPlan.hs | 6 ++- Stackage2/PackageDescription.hs | 96 ++++++++++++++++++++++++--------- 2 files changed, 76 insertions(+), 26 deletions(-) diff --git a/Stackage2/CheckBuildPlan.hs b/Stackage2/CheckBuildPlan.hs index 54722d9f..0846ff80 100644 --- a/Stackage2/CheckBuildPlan.hs +++ b/Stackage2/CheckBuildPlan.hs @@ -3,6 +3,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} -- | Confirm that a build plan has a consistent set of dependencies. module Stackage2.CheckBuildPlan ( checkBuildPlan @@ -14,6 +15,9 @@ import Stackage2.BuildPlan import Stackage2.PackageDescription import Stackage2.Prelude +-- FIXME check cycles in dependencies, only looking at libraries and +-- executables + checkBuildPlan :: MonadThrow m => BuildPlan -> m () checkBuildPlan BuildPlan {..} | null errs' = return () @@ -29,7 +33,7 @@ checkDeps :: Map PackageName Version checkDeps allPackages (user, pb) = mapM_ go $ mapToList $ sdPackages $ ppDesc pb where - go (dep, range) = + go (dep, diRange -> range) = case lookup dep allPackages of Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap Just version diff --git a/Stackage2/PackageDescription.hs b/Stackage2/PackageDescription.hs index 11ecf824..ee820c34 100644 --- a/Stackage2/PackageDescription.hs +++ b/Stackage2/PackageDescription.hs @@ -13,6 +13,8 @@ module Stackage2.PackageDescription ( SimpleDesc (..) , toSimpleDesc , CheckCond (..) + , Component (..) + , DepInfo (..) ) where import Control.Monad.Writer.Strict (MonadWriter, execWriterT, @@ -25,6 +27,49 @@ import Distribution.PackageDescription import Distribution.System (Arch, OS) import Stackage2.Prelude +data Component = CompLibrary + | CompExecutable + | CompTestSuite + | CompBenchmark + deriving (Show, Read, Eq, Ord, Enum, Bounded) + +compToText :: Component -> Text +compToText CompLibrary = "library" +compToText CompExecutable = "executable" +compToText CompTestSuite = "test-suite" +compToText CompBenchmark = "benchmark" + +instance ToJSON Component where + toJSON = toJSON . compToText +instance FromJSON Component where + parseJSON = withText "Component" $ \t -> maybe + (fail $ "Invalid component: " ++ unpack t) + return + (lookup t comps) + where + comps = asHashMap $ mapFromList $ map (compToText &&& id) [minBound..maxBound] + +data DepInfo = DepInfo + { diComponents :: Set Component + , diRange :: VersionRange + } + deriving (Show, Eq) + +instance Semigroup DepInfo where + DepInfo a x <> DepInfo b y = DepInfo + (a <> b) + (intersectVersionRanges x y) +instance ToJSON DepInfo where + toJSON DepInfo {..} = object + [ "components" .= diComponents + , "range" .= display diRange + ] +instance FromJSON DepInfo where + parseJSON = withObject "DepInfo" $ \o -> do + diComponents <- o .: "components" + diRange <- o .: "range" >>= either (fail . show) return . simpleParse + return DepInfo {..} + -- | A simplified package description that tracks: -- -- * Package dependencies @@ -35,33 +80,27 @@ import Stackage2.Prelude -- -- It has fully resolved all conditionals data SimpleDesc = SimpleDesc - { sdPackages :: Map PackageName VersionRange - , sdTools :: Map ExeName VersionRange + { sdPackages :: Map PackageName DepInfo + , sdTools :: Map ExeName DepInfo , sdProvidedExes :: Set ExeName } deriving (Show, Eq) instance Monoid SimpleDesc where mempty = SimpleDesc mempty mempty mempty mappend (SimpleDesc a b c) (SimpleDesc x y z) = SimpleDesc - (unionWith intersectVersionRanges a x) - (unionWith intersectVersionRanges b y) + (unionWith (<>) a x) + (unionWith (<>) b y) (c ++ z) instance ToJSON SimpleDesc where toJSON SimpleDesc {..} = object - [ "packages" .= Map.mapKeysWith const unPackageName (map display sdPackages) - , "tools" .= Map.mapKeysWith const unExeName (map display sdTools) + [ "packages" .= Map.mapKeysWith const unPackageName sdPackages + , "tools" .= Map.mapKeysWith const unExeName sdTools , "provided-exes" .= sdProvidedExes ] instance FromJSON SimpleDesc where parseJSON = withObject "SimpleDesc" $ \o -> do - sdPackages <- (o .: "packages") >>= - either (fail . show) return . - mapM simpleParse . - Map.mapKeysWith const mkPackageName - sdTools <- (o .: "tools") >>= - either (fail . show) return . - mapM simpleParse . - Map.mapKeysWith const ExeName + sdPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages") + sdTools <- Map.mapKeysWith const ExeName <$> (o .: "tools") sdProvidedExes <- o .: "provided-exes" return SimpleDesc {..} @@ -72,39 +111,46 @@ toSimpleDesc :: MonadThrow m -> GenericPackageDescription -> m SimpleDesc toSimpleDesc cc gpd = execWriterT $ do - forM_ (condLibrary gpd) $ tellTree cc libBuildInfo - forM_ (condExecutables gpd) $ tellTree cc buildInfo . snd + forM_ (condLibrary gpd) $ tellTree cc CompLibrary libBuildInfo + forM_ (condExecutables gpd) $ tellTree cc CompExecutable buildInfo . snd tell mempty { sdProvidedExes = setFromList $ map (fromString . fst) $ condExecutables gpd } when (ccIncludeTests cc) $ forM_ (condTestSuites gpd) - $ tellTree cc testBuildInfo . snd + $ tellTree cc CompTestSuite testBuildInfo . snd when (ccIncludeBenchmarks cc) $ forM_ (condBenchmarks gpd) - $ tellTree cc benchmarkBuildInfo . snd + $ tellTree cc CompBenchmark benchmarkBuildInfo . snd -- | Convert a single CondTree to a 'SimpleDesc'. tellTree :: (MonadWriter SimpleDesc m, MonadThrow m) => CheckCond + -> Component -> (a -> BuildInfo) -> CondTree ConfVar [Dependency] a -> m () -tellTree cc getBI (CondNode dat deps comps) = do +tellTree cc component getBI (CondNode dat deps comps) = do tell mempty - { sdPackages = unionsWith intersectVersionRanges $ flip map deps - $ \(Dependency x y) -> singletonMap x $ simplifyVersionRange y - , sdTools = unionsWith intersectVersionRanges $ flip map (buildTools $ getBI dat) + { sdPackages = unionsWith (<>) $ flip map deps + $ \(Dependency x y) -> singletonMap x DepInfo + { diComponents = singletonSet component + , diRange = simplifyVersionRange y + } + , sdTools = unionsWith (<>) $ flip map (buildTools $ getBI dat) $ \(Dependency name range) -> singletonMap -- In practice, cabal files refer to the exe name, not the -- package name. (ExeName $ unPackageName name) - (simplifyVersionRange range) + DepInfo + { diComponents = singletonSet component + , diRange = simplifyVersionRange range + } } forM_ comps $ \(cond, ontrue, onfalse) -> do b <- checkCond cc cond if b - then tellTree cc getBI ontrue - else maybe (return ()) (tellTree cc getBI) onfalse + then tellTree cc component getBI ontrue + else maybe (return ()) (tellTree cc component getBI) onfalse -- | Resolve a condition to a boolean based on the provided 'CheckCond'. checkCond :: MonadThrow m => CheckCond -> Condition ConfVar -> m Bool