mirror of
https://github.com/commercialhaskell/stackage.git
synced 2026-01-11 23:08:30 +01:00
Horribly messy BuildPlan
This commit is contained in:
Michael Snoyman
parent
e360a857cd
commit
bf47ded0b0
302
Stackage2/BuildPlan.hs
Normal file
302
Stackage2/BuildPlan.hs
Normal file
@ -0,0 +1,302 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
-- | Representation of a concrete build plan, and how to generate a new one
|
||||
-- based on constraints.
|
||||
module Stackage2.BuildPlan
|
||||
( BuildPlan (..)
|
||||
, PackageBuild (..)
|
||||
, newBuildPlan
|
||||
) where
|
||||
|
||||
import Distribution.Package (Dependency (..))
|
||||
import Distribution.PackageDescription
|
||||
import Distribution.Version (withinRange, intersectVersionRanges)
|
||||
import Stackage2.CorePackages
|
||||
import Stackage2.PackageConstraints
|
||||
import Stackage2.PackageIndex
|
||||
import Stackage2.Prelude
|
||||
import Control.Monad.State.Strict (execState, get, put)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import Data.Aeson
|
||||
|
||||
data BuildPlan desc = BuildPlan
|
||||
{ bpCore :: Map PackageName Version
|
||||
, bpTools :: Vector (PackageName, Version)
|
||||
, bpExtra :: Map PackageName (PackageBuild desc)
|
||||
, bpGlobalFlags :: Map FlagName Bool
|
||||
}
|
||||
deriving (Functor, Foldable, Traversable, Show, Eq)
|
||||
type instance Element (BuildPlan desc) = desc
|
||||
instance MonoFunctor (BuildPlan desc)
|
||||
instance MonoFoldable (BuildPlan desc)
|
||||
instance MonoTraversable (BuildPlan desc)
|
||||
|
||||
instance ToJSON (BuildPlan desc) where
|
||||
toJSON BuildPlan {..} = object
|
||||
[ "core" .= asMap (mapFromList $ map toCore $ mapToList bpCore)
|
||||
, "tools" .= map goTool bpTools
|
||||
, "extra" .= Map.mapKeysWith const (unPackageName) bpExtra
|
||||
, "global-flags" .= Map.mapKeysWith const (\(FlagName f) -> f) bpGlobalFlags
|
||||
]
|
||||
where
|
||||
toCore (x, y) = (asText $ display x, asText $ display y)
|
||||
goTool (name, version) = object
|
||||
[ "name" .= asText (display name)
|
||||
, "version" .= asText (display version)
|
||||
]
|
||||
instance desc ~ () => FromJSON (BuildPlan desc) where
|
||||
parseJSON = withObject "BuildPlan" $ \o -> BuildPlan
|
||||
<$> ((o .: "core") >>= goCore)
|
||||
<*> ((o .: "tools") >>= mapM goTool)
|
||||
<*> (goExtra <$> (o .: "extra"))
|
||||
<*> (goFlags <$> (o .: "global-flags"))
|
||||
where
|
||||
goCore =
|
||||
fmap mapFromList . mapM goCore' . mapToList . asHashMap
|
||||
where
|
||||
goCore' (k, v) = do
|
||||
k' <- either (fail . show) return $ simpleParse $ asText k
|
||||
v' <- either (fail . show) return $ simpleParse $ asText v
|
||||
return (k', v')
|
||||
|
||||
goTool = withObject "Tool" $ \o -> (,)
|
||||
<$> ((o .: "name") >>=
|
||||
either (fail . show) return . simpleParse . asText)
|
||||
<*> ((o .: "version") >>=
|
||||
either (fail . show) return . simpleParse . asText)
|
||||
|
||||
goExtra = Map.mapKeysWith const PackageName
|
||||
goFlags = Map.mapKeysWith const FlagName
|
||||
|
||||
data PackageBuild desc = PackageBuild
|
||||
{ pbVersion :: Version
|
||||
, pbMaintainer :: Maybe Maintainer
|
||||
, pbUsers :: Set PackageName
|
||||
, pbFlags :: Map FlagName Bool
|
||||
, pbTestState :: TestState
|
||||
, pbHaddockState :: TestState
|
||||
, pbTryBuildBenchmark :: Bool
|
||||
, pbDesc :: desc
|
||||
}
|
||||
deriving (Functor, Foldable, Traversable, Show, Eq)
|
||||
type instance Element (PackageBuild desc) = desc
|
||||
instance MonoFunctor (PackageBuild desc)
|
||||
instance MonoFoldable (PackageBuild desc)
|
||||
instance MonoTraversable (PackageBuild desc)
|
||||
|
||||
instance ToJSON (PackageBuild desc) where
|
||||
toJSON PackageBuild {..} = object $ concat
|
||||
[ maybe [] (\m -> ["maintainer" .= m]) pbMaintainer
|
||||
,
|
||||
[ "version" .= asText (display pbVersion)
|
||||
, "users" .= map unPackageName (unpack pbUsers)
|
||||
, "flags" .= Map.mapKeysWith const (\(FlagName f) -> asText $ pack f) pbFlags
|
||||
, "test-state" .= pbTestState
|
||||
, "haddock-state" .= pbHaddockState
|
||||
, "build-benchmark" .= pbTryBuildBenchmark
|
||||
]
|
||||
]
|
||||
instance desc ~ () => FromJSON (PackageBuild desc) where
|
||||
parseJSON = withObject "PackageBuild" $ \o -> PackageBuild
|
||||
<$> (o .: "version" >>= efail . simpleParse . asText)
|
||||
<*> o .:? "maintainer"
|
||||
<*> (Set.map PackageName <$> (o .:? "users" .!= mempty))
|
||||
<*> (toFlags <$> (o .:? "flags" .!= mempty))
|
||||
<*> o .: "test-state"
|
||||
<*> o .: "haddock-state"
|
||||
<*> o .: "build-benchmark"
|
||||
<*> pure ()
|
||||
where
|
||||
toFlags = Map.mapKeysWith const (FlagName . unpack . asText)
|
||||
|
||||
efail = either (fail . show) return
|
||||
|
||||
data TestState = ExpectSuccess
|
||||
| ExpectFailure
|
||||
| Don'tBuild -- ^ when the test suite will pull in things we don't want
|
||||
deriving (Show, Eq, Ord, Bounded, Enum)
|
||||
|
||||
testStateToText :: TestState -> Text
|
||||
testStateToText ExpectSuccess = "expect-success"
|
||||
testStateToText ExpectFailure = "expect-failure"
|
||||
testStateToText Don'tBuild = "do-not-build"
|
||||
|
||||
instance ToJSON TestState where
|
||||
toJSON = toJSON . testStateToText
|
||||
instance FromJSON TestState where
|
||||
parseJSON = withText "TestState" $ \t ->
|
||||
case lookup t states of
|
||||
Nothing -> fail $ "Invalid state: " ++ unpack t
|
||||
Just v -> return v
|
||||
where
|
||||
states = asHashMap $ mapFromList
|
||||
$ map (\x -> (testStateToText x, x)) [minBound..maxBound]
|
||||
|
||||
newBuildPlan :: MonadIO m => m (BuildPlan FlatComponent)
|
||||
newBuildPlan = liftIO $ do
|
||||
core <- getCorePackages
|
||||
extraOrig <- getLatestDescriptions (isAllowed core) simplifyDesc
|
||||
let toolNames = concatMap (seTools . fcExtra . pbDesc) extraOrig
|
||||
extra = populateUsers $ removeUnincluded (Map.keysSet toolNames) extraOrig
|
||||
return BuildPlan
|
||||
{ bpCore = core
|
||||
, bpTools = topologicalSort
|
||||
$ filter (\(x, _) -> x `member` toolNames)
|
||||
$ mapToList extra
|
||||
, bpExtra = extra
|
||||
, bpGlobalFlags = defaultGlobalFlags
|
||||
}
|
||||
|
||||
topologicalSort :: [(PackageName, PackageBuild FlatComponent)]
|
||||
-> Vector (PackageName, Version)
|
||||
topologicalSort = fromList . fmap (fmap pbVersion) -- FIXME
|
||||
|
||||
removeUnincluded :: Set PackageName -- ^ tool names
|
||||
-> Map PackageName (PackageBuild FlatComponent)
|
||||
-> Map PackageName (PackageBuild FlatComponent)
|
||||
removeUnincluded toolNames orig =
|
||||
mapFromList $ filter (\(x, _) -> x `member` included) $ mapToList orig
|
||||
where
|
||||
included :: Set PackageName
|
||||
included = flip execState mempty $ do
|
||||
mapM_ (add . fst) $ mapToList $ pcPackages defaultPackageConstraints
|
||||
mapM_ add toolNames
|
||||
|
||||
add name = do
|
||||
inc <- get
|
||||
when (name `notMember` inc) $ do
|
||||
put $ insertSet name inc
|
||||
case lookup name orig of
|
||||
Nothing -> return ()
|
||||
Just pb -> mapM_ (add . fst) $ mapToList $ fcDeps $ pbDesc pb
|
||||
|
||||
populateUsers :: Map PackageName (PackageBuild FlatComponent)
|
||||
-> Map PackageName (PackageBuild FlatComponent)
|
||||
populateUsers orig =
|
||||
mapWithKey go orig
|
||||
where
|
||||
go name pb = pb { pbUsers = foldMap (go2 name) (mapToList orig) }
|
||||
|
||||
go2 dep (user, pb)
|
||||
| dep `member` fcDeps (pbDesc pb) = singletonSet user
|
||||
| otherwise = mempty
|
||||
|
||||
data SimpleTree = SimpleTree
|
||||
{ stDeps :: Map PackageName VersionRange
|
||||
, stConds :: [(Condition ConfVar, SimpleTree, Maybe SimpleTree)]
|
||||
, stExtra :: SimpleExtra
|
||||
}
|
||||
deriving Show
|
||||
instance Monoid SimpleTree where
|
||||
mempty = SimpleTree mempty mempty mempty
|
||||
mappend (SimpleTree a b c) (SimpleTree x y z) = SimpleTree
|
||||
(unionWith intersectVersionRanges a x)
|
||||
(b ++ y)
|
||||
(c ++ z)
|
||||
|
||||
data SimpleExtra = SimpleExtra
|
||||
{ seTools :: Map PackageName VersionRange
|
||||
}
|
||||
deriving Show
|
||||
instance Monoid SimpleExtra where
|
||||
mempty = SimpleExtra mempty
|
||||
mappend (SimpleExtra a) (SimpleExtra x) = SimpleExtra
|
||||
(unionWith intersectVersionRanges a x)
|
||||
|
||||
getSimpleTrees :: Bool -- ^ include test suites?
|
||||
-> Bool -- ^ include benchmarks?
|
||||
-> GenericPackageDescription
|
||||
-> [SimpleTree]
|
||||
getSimpleTrees includeTests includeBench gpd = concat
|
||||
[ maybe [] (return . go libBuildInfo) $ condLibrary gpd
|
||||
, map (go buildInfo . snd) $ condExecutables gpd
|
||||
, if includeTests
|
||||
then map (go testBuildInfo . snd) $ condTestSuites gpd
|
||||
else []
|
||||
, if includeBench
|
||||
then map (go benchmarkBuildInfo . snd) $ condBenchmarks gpd
|
||||
else []
|
||||
]
|
||||
where
|
||||
go getExtra (CondNode dat deps comps) = SimpleTree
|
||||
{ stDeps = unionsWith intersectVersionRanges
|
||||
$ map (\(Dependency x y) -> singletonMap x y) deps
|
||||
, stConds = map (goComp getExtra) comps
|
||||
, stExtra = toSimpleExtra $ getExtra dat
|
||||
}
|
||||
|
||||
goComp getExtra (cond, tree1, mtree2) =
|
||||
(cond, go getExtra tree1, go getExtra <$> mtree2)
|
||||
|
||||
toSimpleExtra bi = SimpleExtra
|
||||
{ seTools = unionsWith intersectVersionRanges $ flip map (buildTools bi)
|
||||
$ \(Dependency name range) -> singletonMap name range
|
||||
}
|
||||
|
||||
data FlatComponent = FlatComponent
|
||||
{ fcDeps :: Map PackageName VersionRange
|
||||
, fcExtra :: SimpleExtra
|
||||
}
|
||||
deriving Show
|
||||
instance Monoid FlatComponent where
|
||||
mempty = FlatComponent mempty mempty
|
||||
mappend (FlatComponent a b) (FlatComponent x y) = FlatComponent
|
||||
(unionWith intersectVersionRanges a x)
|
||||
(b ++ y)
|
||||
|
||||
flattenComponent :: SimpleTree -> FlatComponent
|
||||
flattenComponent (SimpleTree deps conds extra) =
|
||||
mconcat $ here : map goCond conds
|
||||
where
|
||||
here = FlatComponent { fcDeps = deps, fcExtra = extra }
|
||||
goCond (cond, tree1, mtree2)
|
||||
| checkCond cond = flattenComponent tree1
|
||||
| otherwise = maybe mempty flattenComponent mtree2
|
||||
|
||||
checkCond :: Condition ConfVar -> Bool
|
||||
checkCond _ = False -- FIXME
|
||||
|
||||
simplifyDesc :: GenericPackageDescription -> IO (PackageBuild FlatComponent)
|
||||
simplifyDesc gpd = do
|
||||
return PackageBuild
|
||||
{ pbVersion = version
|
||||
, pbMaintainer = fmap snd $ lookup name $ pcPackages defaultPackageConstraints
|
||||
, pbUsers = mempty -- must be filled in later
|
||||
, pbFlags = packageFlags name
|
||||
, pbTestState =
|
||||
case () of
|
||||
()
|
||||
| not $ tryBuildTest name -> Don'tBuild
|
||||
| name `member` pcExpectedFailures defaultPackageConstraints
|
||||
-> ExpectFailure
|
||||
| otherwise -> ExpectSuccess
|
||||
, pbHaddockState =
|
||||
case () of
|
||||
()
|
||||
| name `member` pcExpectedFailures defaultPackageConstraints
|
||||
-> ExpectFailure
|
||||
| otherwise -> ExpectSuccess
|
||||
, pbTryBuildBenchmark = tryBuildBenchmark name
|
||||
, pbDesc = foldMap flattenComponent $ getSimpleTrees
|
||||
(tryBuildTest name)
|
||||
(tryBuildBenchmark name)
|
||||
gpd
|
||||
}
|
||||
where
|
||||
PackageIdentifier name version = package $ packageDescription gpd
|
||||
|
||||
isAllowed :: Map PackageName Version -- ^ core
|
||||
-> PackageName -> Version -> Bool
|
||||
isAllowed core = \name version ->
|
||||
case lookup name core of
|
||||
Just _ -> False -- never reinstall a core package
|
||||
Nothing ->
|
||||
case lookup name $ pcPackages defaultPackageConstraints of
|
||||
Nothing -> True -- no constraints
|
||||
Just (range, _) -> withinRange version range
|
||||
@ -1,14 +1,23 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
-- | The constraints on package selection for a new build plan.
|
||||
module Stackage2.PackageConstraints
|
||||
( PackageConstraints (..)
|
||||
, defaultPackageConstraints
|
||||
, defaultGlobalFlags
|
||||
, packageFlags
|
||||
, tryBuildTest
|
||||
, tryBuildBenchmark
|
||||
) where
|
||||
|
||||
import Stackage2.Prelude
|
||||
import qualified Stackage.Config as Old
|
||||
import qualified Stackage.Types as Old
|
||||
import qualified Stackage.Select as Old
|
||||
|
||||
-- FIXME have the defaults here live in IO to make sure we don't have any
|
||||
-- global state floating around. Will make it easier to test.
|
||||
|
||||
data PackageConstraints = PackageConstraints
|
||||
{ pcPackages :: Map PackageName (VersionRange, Maintainer)
|
||||
@ -26,5 +35,23 @@ defaultPackageConstraints = PackageConstraints
|
||||
<$> Old.defaultStablePackages ghcVer False
|
||||
, pcExpectedFailures = Old.defaultExpectedFailures ghcVer False
|
||||
}
|
||||
where
|
||||
ghcVer = Old.GhcMajorVersion 7 8
|
||||
|
||||
ghcVer :: Old.GhcMajorVersion
|
||||
ghcVer = Old.GhcMajorVersion 7 8
|
||||
|
||||
oldSettings :: Old.SelectSettings
|
||||
oldSettings = Old.defaultSelectSettings ghcVer False
|
||||
|
||||
defaultGlobalFlags :: Map FlagName Bool
|
||||
defaultGlobalFlags = mapFromList $
|
||||
map (, True) (map FlagName $ setToList $ Old.flags oldSettings mempty) ++
|
||||
map (, False) (map FlagName $ setToList $ Old.disabledFlags oldSettings)
|
||||
|
||||
packageFlags :: PackageName -> Map FlagName Bool
|
||||
packageFlags _ = mempty
|
||||
|
||||
tryBuildTest :: PackageName -> Bool
|
||||
tryBuildTest = (`member` Old.skippedTests oldSettings)
|
||||
|
||||
tryBuildBenchmark :: PackageName -> Bool
|
||||
tryBuildBenchmark _ = True
|
||||
|
||||
@ -112,12 +112,11 @@ instance Exception CabalParseException
|
||||
-- given criterion.
|
||||
getLatestDescriptions :: MonadIO m
|
||||
=> (PackageName -> Version -> Bool)
|
||||
-> m (Map PackageName (Version, GenericPackageDescription))
|
||||
getLatestDescriptions f = liftIO $ do
|
||||
-> (GenericPackageDescription -> IO desc)
|
||||
-> m (Map PackageName desc)
|
||||
getLatestDescriptions f parseDesc = liftIO $ do
|
||||
m <- runResourceT $ sourcePackageIndex $$ filterC f' =$ foldlC add mempty
|
||||
forM m $ \ucf -> do
|
||||
gpd <- ucfParse ucf
|
||||
return (ucfVersion ucf, gpd)
|
||||
forM m $ \ucf -> liftIO $ ucfParse ucf >>= parseDesc
|
||||
where
|
||||
f' ucf = f (ucfName ucf) (ucfVersion ucf)
|
||||
add m ucf =
|
||||
|
||||
@ -2,6 +2,7 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
module Stackage2.Prelude
|
||||
( module X
|
||||
, module Stackage2.Prelude
|
||||
@ -12,9 +13,11 @@ import Data.Conduit.Process as X
|
||||
import Data.Typeable (TypeRep, typeOf)
|
||||
import Distribution.Package as X (PackageIdentifier (..),
|
||||
PackageName (PackageName))
|
||||
import Distribution.PackageDescription as X (FlagName (..), GenericPackageDescription)
|
||||
import qualified Distribution.Text as DT
|
||||
import Distribution.Version as X (Version (..), VersionRange)
|
||||
import System.Exit (ExitCode (ExitSuccess))
|
||||
import Data.Aeson (ToJSON, FromJSON)
|
||||
|
||||
unPackageName :: PackageName -> Text
|
||||
unPackageName (PackageName str) = pack str
|
||||
@ -74,3 +77,4 @@ withCheckedProcess cp f = do
|
||||
return res
|
||||
|
||||
newtype Maintainer = Maintainer { unMaintainer :: Text }
|
||||
deriving (Show, Eq, Ord, Hashable, ToJSON, FromJSON)
|
||||
|
||||
@ -35,6 +35,7 @@ library
|
||||
Stackage2.PackageConstraints
|
||||
Stackage2.CorePackages
|
||||
Stackage2.PackageIndex
|
||||
Stackage2.BuildPlan
|
||||
build-depends: base >= 4 && < 5
|
||||
, containers
|
||||
, Cabal >= 1.14
|
||||
@ -53,6 +54,8 @@ library
|
||||
, classy-prelude-conduit
|
||||
, text
|
||||
, system-fileio
|
||||
, mtl
|
||||
, aeson
|
||||
|
||||
executable stackage
|
||||
default-language: Haskell2010
|
||||
@ -69,12 +72,15 @@ test-suite spec
|
||||
main-is: Spec.hs
|
||||
other-modules: Stackage2.CorePackagesSpec
|
||||
Stackage2.PackageIndexSpec
|
||||
Stackage2.BuildPlanSpec
|
||||
build-depends: base
|
||||
, stackage
|
||||
, hspec
|
||||
, QuickCheck
|
||||
, text
|
||||
, classy-prelude-conduit
|
||||
, Cabal
|
||||
, yaml
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
|
||||
15
test/Stackage2/BuildPlanSpec.hs
Normal file
15
test/Stackage2/BuildPlanSpec.hs
Normal file
@ -0,0 +1,15 @@
|
||||
{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}
|
||||
module Stackage2.BuildPlanSpec (spec) where
|
||||
|
||||
import Stackage2.BuildPlan
|
||||
import Stackage2.Prelude
|
||||
import Test.Hspec
|
||||
import qualified Data.Yaml as Y
|
||||
import Control.Exception (evaluate)
|
||||
|
||||
spec :: Spec
|
||||
spec = it "works" $ do
|
||||
bp <- newBuildPlan
|
||||
let bs = Y.encode bp
|
||||
mbp' = Y.decode bs
|
||||
mbp' `shouldBe` Just (() <$ bp)
|
||||
@ -4,6 +4,7 @@ module Stackage2.PackageIndexSpec (spec) where
|
||||
import Stackage2.PackageIndex
|
||||
import Stackage2.Prelude
|
||||
import Test.Hspec
|
||||
import Distribution.Package (packageId, pkgVersion)
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
@ -13,8 +14,8 @@ spec = do
|
||||
[ (asText "base", asText "4.5.0.0")
|
||||
, ("does-not-exist", "9999999999999999999")
|
||||
])
|
||||
m <- getLatestDescriptions f
|
||||
m <- getLatestDescriptions f return
|
||||
length m `shouldBe` 1
|
||||
p <- simpleParse $ asText "base"
|
||||
v <- simpleParse $ asText "4.5.0.0"
|
||||
(fst <$> m) `shouldBe` singletonMap p v
|
||||
(pkgVersion . packageId <$> m) `shouldBe` singletonMap p v
|
||||
|
||||
Loading…
Reference in New Issue
Block a user