e68ccae · stackage · git.iko.soy

git.iko.soy/stackage

on master help sign in

PackageDescription module, first stab

e68ccaeMichael Snoyman12 years ago

Stackage2/BuildPlan.hs+19−90

compare with master

unifiedsplit

@@ -25,6 +25,7 @@ import Control.Monad.State.Strict (execState, get, put)

25import qualified Data.Map as Map

26import qualified Data.Set as Set

27import Data.Aeson

28+import Stackage2.PackageDescription

29data BuildPlan desc = BuildPlan

30data BuildPlan desc = BuildPlan

30 { bpCore :: Map PackageName Version

31 { bpCore :: Map PackageName Version

@@ -145,8 +146,8 @@ instance FromJSON TestState where

145newBuildPlan :: MonadIO m => m (BuildPlan FlatComponent)

146newBuildPlan :: MonadIO m => m (BuildPlan FlatComponent)

146newBuildPlan = liftIO $ do

147newBuildPlan = liftIO $ do

147 core <- getCorePackages

148 core <- getCorePackages

148− extraOrig <- getLatestDescriptions (isAllowed core) simplifyDesc

149+ extraOrig <- getLatestDescriptions (isAllowed core) mkPackageBuild

149− let toolNames = concatMap (seTools . fcExtra . pbDesc) extraOrig

150+ let toolNames = concatMap (seTools . fcExtra . pbDesc) extraOrig -- FIXME extraOrig ==> extra

150 extra = populateUsers $ removeUnincluded (Map.keysSet toolNames) extraOrig

151 extra = populateUsers $ removeUnincluded (Map.keysSet toolNames) extraOrig

151 return BuildPlan

152 return BuildPlan

152 { bpCore = core

153 { bpCore = core

@@ -170,7 +171,7 @@ removeUnincluded toolNames orig =

170 included :: Set PackageName

171 included :: Set PackageName

171 included = flip execState mempty $ do

172 included = flip execState mempty $ do

172 mapM_ (add . fst) $ mapToList $ pcPackages defaultPackageConstraints

173 mapM_ (add . fst) $ mapToList $ pcPackages defaultPackageConstraints

173− mapM_ add toolNames

174+ mapM_ add toolNames -- FIXME remove this

174

175

175 add name = do

176 add name = do

176 inc <- get

177 inc <- get

@@ -179,6 +180,7 @@ removeUnincluded toolNames orig =

179 case lookup name orig of

180 case lookup name orig of

180 Nothing -> return ()

181 Nothing -> return ()

181 Just pb -> mapM_ (add . fst) $ mapToList $ fcDeps $ pbDesc pb

182 Just pb -> mapM_ (add . fst) $ mapToList $ fcDeps $ pbDesc pb

183+ -- FIXME add tools here

182

184

183populateUsers :: Map PackageName (PackageBuild FlatComponent)

185populateUsers :: Map PackageName (PackageBuild FlatComponent)

184 -> Map PackageName (PackageBuild FlatComponent)

186 -> Map PackageName (PackageBuild FlatComponent)

@@ -191,83 +193,20 @@ populateUsers orig =

191 | dep `member` fcDeps (pbDesc pb) = singletonSet user

193 | dep `member` fcDeps (pbDesc pb) = singletonSet user

192 | otherwise = mempty

194 | otherwise = mempty

193

195

194−data SimpleTree = SimpleTree

195− { stDeps :: Map PackageName VersionRange

196+isAllowed :: Map PackageName Version -- ^ core

196− , stConds :: [(Condition ConfVar, SimpleTree, Maybe SimpleTree)]

197+ -> PackageName -> Version -> Bool

197− , stExtra :: SimpleExtra

198+isAllowed core = \name version ->

198− }

199+ case lookup name core of

199− deriving Show

200+ Just _ -> False -- never reinstall a core package

200−instance Monoid SimpleTree where

201+ Nothing ->

201− mempty = SimpleTree mempty mempty mempty

202+ case lookup name $ pcPackages defaultPackageConstraints of

202− mappend (SimpleTree a b c) (SimpleTree x y z) = SimpleTree

203+ Nothing -> True -- no constraints

203− (unionWith intersectVersionRanges a x)

204+ Just (range, _) -> withinRange version range

204− (b ++ y)

205− (c ++ z)

206−

207−data SimpleExtra = SimpleExtra

208− { seTools :: Map PackageName VersionRange

209− }

210− deriving Show

211−instance Monoid SimpleExtra where

212− mempty = SimpleExtra mempty

213− mappend (SimpleExtra a) (SimpleExtra x) = SimpleExtra

214− (unionWith intersectVersionRanges a x)

215−

216−getSimpleTrees :: Bool -- ^ include test suites?

217− -> Bool -- ^ include benchmarks?

218− -> GenericPackageDescription

219− -> [SimpleTree]

220−getSimpleTrees includeTests includeBench gpd = concat

221− [ maybe [] (return . go libBuildInfo) $ condLibrary gpd

222− , map (go buildInfo . snd) $ condExecutables gpd

223− , if includeTests

224− then map (go testBuildInfo . snd) $ condTestSuites gpd

225− else []

226− , if includeBench

227− then map (go benchmarkBuildInfo . snd) $ condBenchmarks gpd

228− else []

229− ]

230− where

231− go getExtra (CondNode dat deps comps) = SimpleTree

232− { stDeps = unionsWith intersectVersionRanges

233− $ map (\(Dependency x y) -> singletonMap x y) deps

234− , stConds = map (goComp getExtra) comps

235− , stExtra = toSimpleExtra $ getExtra dat

236− }

237−

238− goComp getExtra (cond, tree1, mtree2) =

239− (cond, go getExtra tree1, go getExtra <$> mtree2)

240−

241− toSimpleExtra bi = SimpleExtra

242− { seTools = unionsWith intersectVersionRanges $ flip map (buildTools bi)

243− $ \(Dependency name range) -> singletonMap name range

244− }

245−

246−data FlatComponent = FlatComponent

247− { fcDeps :: Map PackageName VersionRange

248− , fcExtra :: SimpleExtra

249− }

250− deriving Show

251−instance Monoid FlatComponent where

252− mempty = FlatComponent mempty mempty

253− mappend (FlatComponent a b) (FlatComponent x y) = FlatComponent

254− (unionWith intersectVersionRanges a x)

255− (b ++ y)

256−

257−flattenComponent :: SimpleTree -> FlatComponent

258−flattenComponent (SimpleTree deps conds extra) =

259− mconcat $ here : map goCond conds

260− where

261− here = FlatComponent { fcDeps = deps, fcExtra = extra }

262− goCond (cond, tree1, mtree2)

263− | checkCond cond = flattenComponent tree1

264− | otherwise = maybe mempty flattenComponent mtree2

265−

266−checkCond :: Condition ConfVar -> Bool

267−checkCond _ = False -- FIXME

268

205

206+mkPackageBuild :: Monad m

269−simplifyDesc :: GenericPackageDescription -> IO (PackageBuild FlatComponent)

207+ => GenericPackageDescription

270−simplifyDesc gpd = do

208+ -> m (PackageBuild FlatComponent)

209+mkPackageBuild gpd =

271 return PackageBuild

210 return PackageBuild

272 { pbVersion = version

211 { pbVersion = version

273 , pbMaintainer = fmap snd $ lookup name $ pcPackages defaultPackageConstraints

212 , pbMaintainer = fmap snd $ lookup name $ pcPackages defaultPackageConstraints

@@ -288,20 +227,10 @@ simplifyDesc gpd = do

288 -> ExpectFailure

227 -> ExpectFailure

289 | otherwise -> ExpectSuccess

228 | otherwise -> ExpectSuccess

290 , pbTryBuildBenchmark = tryBuildBenchmark name

229 , pbTryBuildBenchmark = tryBuildBenchmark name

291− , pbDesc = foldMap flattenComponent $ getSimpleTrees

230+ , pbDesc = getFlattenedComponent

292 (tryBuildTest name)

231 (tryBuildTest name)

293 (tryBuildBenchmark name)

232 (tryBuildBenchmark name)

294 gpd

233 gpd

295 }

234 }

296 where

235 where

297 PackageIdentifier name version = package $ packageDescription gpd

236 PackageIdentifier name version = package $ packageDescription gpd

298−

299−isAllowed :: Map PackageName Version -- ^ core

300− -> PackageName -> Version -> Bool

301−isAllowed core = \name version ->

302− case lookup name core of

303− Just _ -> False -- never reinstall a core package

304− Nothing ->

305− case lookup name $ pcPackages defaultPackageConstraints of

306− Nothing -> True -- no constraints

307− Just (range, _) -> withinRange version range

Stackage2/PackageDescription.hsnew file+110

@@ -0,0 +1,110 @@

1+{-# LANGUAGE NoImplicitPrelude #-}

2+{-# LANGUAGE RecordWildCards #-}

3+{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE DeriveFunctor #-}

5+{-# LANGUAGE DeriveFoldable #-}

6+{-# LANGUAGE DeriveTraversable #-}

7+{-# LANGUAGE TypeFamilies #-}

8+-- | Manipulate @GenericPackageDescription@ from Cabal into something more

9+-- useful for us.

10+module Stackage2.PackageDescription

11+ ( FlatComponent (..)

12+ , getFlattenedComponent

13+ , SimpleExtra (..)

14+ ) where

15+

16+import Distribution.Package (Dependency (..))

17+import Distribution.PackageDescription

18+import Distribution.Version (withinRange, intersectVersionRanges)

19+import Stackage2.CorePackages

20+import Stackage2.PackageConstraints

21+import Stackage2.PackageIndex

22+import Stackage2.Prelude

23+import Stackage2.GithubPings

24+import Control.Monad.State.Strict (execState, get, put)

25+import qualified Data.Map as Map

26+import qualified Data.Set as Set

27+import Data.Aeson

28+

29+data SimpleTree = SimpleTree

30+ { stDeps :: Map PackageName VersionRange

31+ , stConds :: [(Condition ConfVar, SimpleTree, Maybe SimpleTree)]

32+ , stExtra :: SimpleExtra

33+ }

34+ deriving Show

35+instance Monoid SimpleTree where

36+ mempty = SimpleTree mempty mempty mempty

37+ mappend (SimpleTree a b c) (SimpleTree x y z) = SimpleTree

38+ (unionWith intersectVersionRanges a x)

39+ (b ++ y)

40+ (c ++ z)

41+

42+data SimpleExtra = SimpleExtra

43+ { seTools :: Map PackageName VersionRange

44+ }

45+ deriving Show

46+instance Monoid SimpleExtra where

47+ mempty = SimpleExtra mempty

48+ mappend (SimpleExtra a) (SimpleExtra x) = SimpleExtra

49+ (unionWith intersectVersionRanges a x)

50+

51+getFlattenedComponent

52+ :: Bool -- ^ include test suites?

53+ -> Bool -- ^ include benchmarks?

54+ -> GenericPackageDescription

55+ -> FlatComponent

56+getFlattenedComponent includeTests includeBench gpd =

57+ foldMap flattenComponent $ getSimpleTrees includeTests includeBench gpd

58+

59+getSimpleTrees :: Bool -- ^ include test suites?

60+ -> Bool -- ^ include benchmarks?

61+ -> GenericPackageDescription

62+ -> [SimpleTree]

63+getSimpleTrees includeTests includeBench gpd = concat

64+ [ maybe [] (return . go libBuildInfo) $ condLibrary gpd

65+ , map (go buildInfo . snd) $ condExecutables gpd

66+ , if includeTests

67+ then map (go testBuildInfo . snd) $ condTestSuites gpd

68+ else []

69+ , if includeBench

70+ then map (go benchmarkBuildInfo . snd) $ condBenchmarks gpd

71+ else []

72+ ]

73+ where

74+ go getExtra (CondNode dat deps comps) = SimpleTree

75+ { stDeps = unionsWith intersectVersionRanges

76+ $ map (\(Dependency x y) -> singletonMap x y) deps

77+ , stConds = map (goComp getExtra) comps

78+ , stExtra = toSimpleExtra $ getExtra dat

79+ }

80+

81+ goComp getExtra (cond, tree1, mtree2) =

82+ (cond, go getExtra tree1, go getExtra <$> mtree2)

83+

84+ toSimpleExtra bi = SimpleExtra

85+ { seTools = unionsWith intersectVersionRanges $ flip map (buildTools bi)

86+ $ \(Dependency name range) -> singletonMap name range

87+ }

88+

89+data FlatComponent = FlatComponent

90+ { fcDeps :: Map PackageName VersionRange

91+ , fcExtra :: SimpleExtra

92+ }

93+ deriving Show

94+instance Monoid FlatComponent where

95+ mempty = FlatComponent mempty mempty

96+ mappend (FlatComponent a b) (FlatComponent x y) = FlatComponent

97+ (unionWith intersectVersionRanges a x)

98+ (b ++ y)

99+

100+flattenComponent :: SimpleTree -> FlatComponent

101+flattenComponent (SimpleTree deps conds extra) =

102+ mconcat $ here : map goCond conds

103+ where

104+ here = FlatComponent { fcDeps = deps, fcExtra = extra }

105+ goCond (cond, tree1, mtree2)

106+ | checkCond cond = flattenComponent tree1

107+ | otherwise = maybe mempty flattenComponent mtree2

108+

109+checkCond :: Condition ConfVar -> Bool

110+checkCond _ = False -- FIXME

stackage.cabal+1

@@ -37,6 +37,7 @@ library

37 Stackage2.PackageIndex

38 Stackage2.BuildPlan

39 Stackage2.GithubPings

40+ Stackage2.PackageDescription

40 build-depends: base >= 4 && < 5

41 build-depends: base >= 4 && < 5

41 , containers

42 , containers

42 , Cabal >= 1.14

43 , Cabal >= 1.14

test/Stackage2/BuildPlanSpec.hs+1

@@ -12,4 +12,5 @@ spec = it "works" $ do

12 bp <- newBuildPlan

13 let bs = Y.encode bp

14 mbp' = Y.decode bs

15+ Y.encodeFile "myplan.yaml" bp

15 mbp' `shouldBe` Just (() <$ bp)

16 mbp' `shouldBe` Just (() <$ bp)