@@ -13,6 +13,8 @@ module Stackage2.PackageDescription
1313 ( SimpleDesc (..)
1414 , toSimpleDesc
1515 , CheckCond (..)
16+ , Component (..)
17+ , DepInfo (..)
1618 ) where
1719
1820import Control.Monad.Writer.Strict (MonadWriter, execWriterT,
@@ -25,6 +27,49 @@ import Distribution.PackageDescription
2527import Distribution.System (Arch, OS)
2628import Stackage2.Prelude
2729
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+
2873-- | A simplified package description that tracks:
2974--
3075-- * Package dependencies
@@ -35,33 +80,27 @@ import Stackage2.Prelude
3580--
3681-- It has fully resolved all conditionals
3782data SimpleDesc = SimpleDesc
38− { sdPackages :: Map PackageName VersionRange
39− , sdTools :: Map ExeName VersionRange
83+ { sdPackages :: Map PackageName DepInfo
84+ , sdTools :: Map ExeName DepInfo
4085 , sdProvidedExes :: Set ExeName
4186 }
4287 deriving (Show, Eq)
4388instance Monoid SimpleDesc where
4489 mempty = SimpleDesc mempty mempty mempty
4590 mappend (SimpleDesc a b c) (SimpleDesc x y z) = SimpleDesc
46− (unionWith intersectVersionRanges a x)
47− (unionWith intersectVersionRanges b y)
91+ (unionWith (<>) a x)
92+ (unionWith (<>) b y)
4893 (c ++ z)
4994instance ToJSON SimpleDesc where
5095 toJSON SimpleDesc {..} = object
51− [ "packages" .= Map.mapKeysWith const unPackageName (map display sdPackages)
52− , "tools" .= Map.mapKeysWith const unExeName (map display sdTools)
96+ [ "packages" .= Map.mapKeysWith const unPackageName sdPackages
97+ , "tools" .= Map.mapKeysWith const unExeName sdTools
5398 , "provided-exes" .= sdProvidedExes
5499 ]
55100instance FromJSON SimpleDesc where
56101 parseJSON = withObject "SimpleDesc" $ \o -> do
57− sdPackages <- (o .: "packages") >>=
58− either (fail . show) return .
59− mapM simpleParse .
60− Map.mapKeysWith const mkPackageName
61− sdTools <- (o .: "tools") >>=
62− either (fail . show) return .
63− mapM simpleParse .
64− Map.mapKeysWith const ExeName
102+ sdPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages")
103+ sdTools <- Map.mapKeysWith const ExeName <$> (o .: "tools")
65104 sdProvidedExes <- o .: "provided-exes"
66105 return SimpleDesc {..}
67106
@@ -72,39 +111,46 @@ toSimpleDesc :: MonadThrow m
72111 -> GenericPackageDescription
73112 -> m SimpleDesc
74113toSimpleDesc cc gpd = execWriterT $ do
75− forM_ (condLibrary gpd) $ tellTree cc libBuildInfo
76− forM_ (condExecutables gpd) $ tellTree cc buildInfo . snd
114+ forM_ (condLibrary gpd) $ tellTree cc CompLibrary libBuildInfo
115+ forM_ (condExecutables gpd) $ tellTree cc CompExecutable buildInfo . snd
77116 tell mempty { sdProvidedExes = setFromList
78117 $ map (fromString . fst)
79118 $ condExecutables gpd
80119 }
81120 when (ccIncludeTests cc) $ forM_ (condTestSuites gpd)
82− $ tellTree cc testBuildInfo . snd
121+ $ tellTree cc CompTestSuite testBuildInfo . snd
83122 when (ccIncludeBenchmarks cc) $ forM_ (condBenchmarks gpd)
84− $ tellTree cc benchmarkBuildInfo . snd
123+ $ tellTree cc CompBenchmark benchmarkBuildInfo . snd
85124
86125-- | Convert a single CondTree to a 'SimpleDesc'.
87126tellTree :: (MonadWriter SimpleDesc m, MonadThrow m)
88127 => CheckCond
128+ -> Component
89129 -> (a -> BuildInfo)
90130 -> CondTree ConfVar [Dependency] a
91131 -> m ()
92−tellTree cc getBI (CondNode dat deps comps) = do
132+tellTree cc component getBI (CondNode dat deps comps) = do
93133 tell mempty
94− { sdPackages = unionsWith intersectVersionRanges $ flip map deps
95− $ \(Dependency x y) -> singletonMap x $ simplifyVersionRange y
96− , sdTools = unionsWith intersectVersionRanges $ flip map (buildTools $ getBI dat)
134+ { sdPackages = unionsWith (<>) $ flip map deps
135+ $ \(Dependency x y) -> singletonMap x DepInfo
136+ { diComponents = singletonSet component
137+ , diRange = simplifyVersionRange y
138+ }
139+ , sdTools = unionsWith (<>) $ flip map (buildTools $ getBI dat)
97140 $ \(Dependency name range) -> singletonMap
98141 -- In practice, cabal files refer to the exe name, not the
99142 -- package name.
100143 (ExeName $ unPackageName name)
101− (simplifyVersionRange range)
144+ DepInfo
145+ { diComponents = singletonSet component
146+ , diRange = simplifyVersionRange range
147+ }
102148 }
103149 forM_ comps $ \(cond, ontrue, onfalse) -> do
104150 b <- checkCond cc cond
105151 if b
106− then tellTree cc getBI ontrue
107− else maybe (return ()) (tellTree cc getBI) onfalse
152+ then tellTree cc component getBI ontrue
153+ else maybe (return ()) (tellTree cc component getBI) onfalse
108154
109155-- | Resolve a condition to a boolean based on the provided 'CheckCond'.
110156checkCond :: MonadThrow m => CheckCond -> Condition ConfVar -> m Bool