git.iko.soy/stackage
on master help sign in
Track which components have which dependencies
4ede5f0Michael Snoyman
Stackage2/CheckBuildPlan.hs+5−1
compare with master
unifiedsplit
@@ -3,6 +3,7 @@
3{-# LANGUAGE NoImplicitPrelude #-}
3{-# LANGUAGE NoImplicitPrelude #-}
4{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE RecordWildCards #-}
5{-# LANGUAGE RecordWildCards #-}
6+{-# LANGUAGE ViewPatterns #-}
6-- | Confirm that a build plan has a consistent set of dependencies.
7-- | Confirm that a build plan has a consistent set of dependencies.
7module Stackage2.CheckBuildPlan
8module Stackage2.CheckBuildPlan
8 ( checkBuildPlan
9 ( checkBuildPlan
@@ -14,6 +15,9 @@ import Stackage2.BuildPlan
14import Stackage2.PackageDescription
15import Stackage2.PackageDescription
15import Stackage2.Prelude
16import Stackage2.Prelude
16
17
18+-- FIXME check cycles in dependencies, only looking at libraries and
19+-- executables
20+
17checkBuildPlan :: MonadThrow m => BuildPlan -> m ()
21checkBuildPlan :: MonadThrow m => BuildPlan -> m ()
18checkBuildPlan BuildPlan {..}
22checkBuildPlan BuildPlan {..}
19 | null errs' = return ()
23 | null errs' = return ()
@@ -29,7 +33,7 @@ checkDeps :: Map PackageName Version
29checkDeps allPackages (user, pb) =
33checkDeps allPackages (user, pb) =
30 mapM_ go $ mapToList $ sdPackages $ ppDesc pb
34 mapM_ go $ mapToList $ sdPackages $ ppDesc pb
31 where
35 where
32− go (dep, range) =
36+ go (dep, diRange -> range) =
33 case lookup dep allPackages of
37 case lookup dep allPackages of
34 Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap
38 Nothing -> tell $ BadBuildPlan $ singletonMap (dep, Nothing) errMap
35 Just version
39 Just version
Stackage2/PackageDescription.hs+71−25
@@ -13,6 +13,8 @@ module Stackage2.PackageDescription
13 ( SimpleDesc (..)
13 ( SimpleDesc (..)
14 , toSimpleDesc
14 , toSimpleDesc
15 , CheckCond (..)
15 , CheckCond (..)
16+ , Component (..)
17+ , DepInfo (..)
16 ) where
18 ) where
17
19
18import Control.Monad.Writer.Strict (MonadWriter, execWriterT,
20import Control.Monad.Writer.Strict (MonadWriter, execWriterT,
@@ -25,6 +27,49 @@ import Distribution.PackageDescription
25import Distribution.System (Arch, OS)
27import Distribution.System (Arch, OS)
26import Stackage2.Prelude
28import Stackage2.Prelude
27
29
30+data Component = CompLibrary
31+ | CompExecutable
32+ | CompTestSuite
33+ | CompBenchmark
34+ deriving (Show, Read, Eq, Ord, Enum, Bounded)
35+
36+compToText :: Component -> Text
37+compToText CompLibrary = "library"
38+compToText CompExecutable = "executable"
39+compToText CompTestSuite = "test-suite"
40+compToText CompBenchmark = "benchmark"
41+
42+instance ToJSON Component where
43+ toJSON = toJSON . compToText
44+instance FromJSON Component where
45+ parseJSON = withText "Component" $ \t -> maybe
46+ (fail $ "Invalid component: " ++ unpack t)
47+ return
48+ (lookup t comps)
49+ where
50+ comps = asHashMap $ mapFromList $ map (compToText &&& id) [minBound..maxBound]
51+
52+data DepInfo = DepInfo
53+ { diComponents :: Set Component
54+ , diRange :: VersionRange
55+ }
56+ deriving (Show, Eq)
57+
58+instance Semigroup DepInfo where
59+ DepInfo a x <> DepInfo b y = DepInfo
60+ (a <> b)
61+ (intersectVersionRanges x y)
62+instance ToJSON DepInfo where
63+ toJSON DepInfo {..} = object
64+ [ "components" .= diComponents
65+ , "range" .= display diRange
66+ ]
67+instance FromJSON DepInfo where
68+ parseJSON = withObject "DepInfo" $ \o -> do
69+ diComponents <- o .: "components"
70+ diRange <- o .: "range" >>= either (fail . show) return . simpleParse
71+ return DepInfo {..}
72+
28-- | A simplified package description that tracks:
73-- | A simplified package description that tracks:
29--
74--
30-- * Package dependencies
75-- * Package dependencies
@@ -35,33 +80,27 @@ import Stackage2.Prelude
35--
80--
36-- It has fully resolved all conditionals
81-- It has fully resolved all conditionals
37data SimpleDesc = SimpleDesc
82data SimpleDesc = SimpleDesc
38− { sdPackages :: Map PackageName VersionRange
83+ { sdPackages :: Map PackageName DepInfo
39− , sdTools :: Map ExeName VersionRange
84+ , sdTools :: Map ExeName DepInfo
40 , sdProvidedExes :: Set ExeName
85 , sdProvidedExes :: Set ExeName
41 }
86 }
42 deriving (Show, Eq)
87 deriving (Show, Eq)
43instance Monoid SimpleDesc where
88instance Monoid SimpleDesc where
44 mempty = SimpleDesc mempty mempty mempty
89 mempty = SimpleDesc mempty mempty mempty
45 mappend (SimpleDesc a b c) (SimpleDesc x y z) = SimpleDesc
90 mappend (SimpleDesc a b c) (SimpleDesc x y z) = SimpleDesc
46− (unionWith intersectVersionRanges a x)
91+ (unionWith (<>) a x)
47− (unionWith intersectVersionRanges b y)
92+ (unionWith (<>) b y)
48 (c ++ z)
93 (c ++ z)
49instance ToJSON SimpleDesc where
94instance ToJSON SimpleDesc where
50 toJSON SimpleDesc {..} = object
95 toJSON SimpleDesc {..} = object
51− [ "packages" .= Map.mapKeysWith const unPackageName (map display sdPackages)
96+ [ "packages" .= Map.mapKeysWith const unPackageName sdPackages
52− , "tools" .= Map.mapKeysWith const unExeName (map display sdTools)
97+ , "tools" .= Map.mapKeysWith const unExeName sdTools
53 , "provided-exes" .= sdProvidedExes
98 , "provided-exes" .= sdProvidedExes
54 ]
99 ]
55instance FromJSON SimpleDesc where
100instance FromJSON SimpleDesc where
56 parseJSON = withObject "SimpleDesc" $ \o -> do
101 parseJSON = withObject "SimpleDesc" $ \o -> do
57− sdPackages <- (o .: "packages") >>=
102+ sdPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages")
58− either (fail . show) return .
59− mapM simpleParse .
60− Map.mapKeysWith const mkPackageName
61− sdTools <- (o .: "tools") >>=
103+ sdTools <- Map.mapKeysWith const ExeName <$> (o .: "tools")
62− either (fail . show) return .
63− mapM simpleParse .
64− Map.mapKeysWith const ExeName
65 sdProvidedExes <- o .: "provided-exes"
104 sdProvidedExes <- o .: "provided-exes"
66 return SimpleDesc {..}
105 return SimpleDesc {..}
67
106
@@ -72,39 +111,46 @@ toSimpleDesc :: MonadThrow m
72 -> GenericPackageDescription
111 -> GenericPackageDescription
73 -> m SimpleDesc
112 -> m SimpleDesc
74toSimpleDesc cc gpd = execWriterT $ do
113toSimpleDesc cc gpd = execWriterT $ do
75− forM_ (condLibrary gpd) $ tellTree cc libBuildInfo
114+ forM_ (condLibrary gpd) $ tellTree cc CompLibrary libBuildInfo
76− forM_ (condExecutables gpd) $ tellTree cc buildInfo . snd
115+ forM_ (condExecutables gpd) $ tellTree cc CompExecutable buildInfo . snd
77 tell mempty { sdProvidedExes = setFromList
116 tell mempty { sdProvidedExes = setFromList
78 $ map (fromString . fst)
117 $ map (fromString . fst)
79 $ condExecutables gpd
118 $ condExecutables gpd
80 }
119 }
81 when (ccIncludeTests cc) $ forM_ (condTestSuites gpd)
120 when (ccIncludeTests cc) $ forM_ (condTestSuites gpd)
82− $ tellTree cc testBuildInfo . snd
121+ $ tellTree cc CompTestSuite testBuildInfo . snd
83 when (ccIncludeBenchmarks cc) $ forM_ (condBenchmarks gpd)
122 when (ccIncludeBenchmarks cc) $ forM_ (condBenchmarks gpd)
84− $ tellTree cc benchmarkBuildInfo . snd
123+ $ tellTree cc CompBenchmark benchmarkBuildInfo . snd
85
124
86-- | Convert a single CondTree to a 'SimpleDesc'.
125-- | Convert a single CondTree to a 'SimpleDesc'.
87tellTree :: (MonadWriter SimpleDesc m, MonadThrow m)
126tellTree :: (MonadWriter SimpleDesc m, MonadThrow m)
88 => CheckCond
127 => CheckCond
128+ -> Component
89 -> (a -> BuildInfo)
129 -> (a -> BuildInfo)
90 -> CondTree ConfVar [Dependency] a
130 -> CondTree ConfVar [Dependency] a
91 -> m ()
131 -> m ()
92−tellTree cc getBI (CondNode dat deps comps) = do
132+tellTree cc component getBI (CondNode dat deps comps) = do
93 tell mempty
133 tell mempty
94− { sdPackages = unionsWith intersectVersionRanges $ flip map deps
134+ { sdPackages = unionsWith (<>) $ flip map deps
95− $ \(Dependency x y) -> singletonMap x $ simplifyVersionRange y
135+ $ \(Dependency x y) -> singletonMap x DepInfo
136+ { diComponents = singletonSet component
137+ , diRange = simplifyVersionRange y
138+ }
96− , sdTools = unionsWith intersectVersionRanges $ flip map (buildTools $ getBI dat)
139+ , sdTools = unionsWith (<>) $ flip map (buildTools $ getBI dat)
97 $ \(Dependency name range) -> singletonMap
140 $ \(Dependency name range) -> singletonMap
98 -- In practice, cabal files refer to the exe name, not the
141 -- In practice, cabal files refer to the exe name, not the
99 -- package name.
142 -- package name.
100 (ExeName $ unPackageName name)
143 (ExeName $ unPackageName name)
144+ DepInfo
145+ { diComponents = singletonSet component
101− (simplifyVersionRange range)
146+ , diRange = simplifyVersionRange range
147+ }
102 }
148 }
103 forM_ comps $ \(cond, ontrue, onfalse) -> do
149 forM_ comps $ \(cond, ontrue, onfalse) -> do
104 b <- checkCond cc cond
150 b <- checkCond cc cond
105 if b
151 if b
106− then tellTree cc getBI ontrue
152+ then tellTree cc component getBI ontrue
107− else maybe (return ()) (tellTree cc getBI) onfalse
153+ else maybe (return ()) (tellTree cc component getBI) onfalse
108
154
109-- | Resolve a condition to a boolean based on the provided 'CheckCond'.
155-- | Resolve a condition to a boolean based on the provided 'CheckCond'.
110checkCond :: MonadThrow m => CheckCond -> Condition ConfVar -> m Bool
156checkCond :: MonadThrow m => CheckCond -> Condition ConfVar -> m Bool