diff --git a/Stackage2/BuildPlan.hs b/Stackage2/BuildPlan.hs new file mode 100644 index 00000000..c3a35739 --- /dev/null +++ b/Stackage2/BuildPlan.hs @@ -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 diff --git a/Stackage2/PackageConstraints.hs b/Stackage2/PackageConstraints.hs index 33f7cff0..ca60bfc0 100644 --- a/Stackage2/PackageConstraints.hs +++ b/Stackage2/PackageConstraints.hs @@ -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 diff --git a/Stackage2/PackageIndex.hs b/Stackage2/PackageIndex.hs index d120cc80..bda2e18f 100644 --- a/Stackage2/PackageIndex.hs +++ b/Stackage2/PackageIndex.hs @@ -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 = diff --git a/Stackage2/Prelude.hs b/Stackage2/Prelude.hs index f0790c25..c57be432 100644 --- a/Stackage2/Prelude.hs +++ b/Stackage2/Prelude.hs @@ -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) diff --git a/stackage.cabal b/stackage.cabal index a21720fb..ec1e44ef 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -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 diff --git a/test/Stackage2/BuildPlanSpec.hs b/test/Stackage2/BuildPlanSpec.hs new file mode 100644 index 00000000..be7f31dc --- /dev/null +++ b/test/Stackage2/BuildPlanSpec.hs @@ -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) diff --git a/test/Stackage2/PackageIndexSpec.hs b/test/Stackage2/PackageIndexSpec.hs index c5b17418..b9cf863b 100644 --- a/test/Stackage2/PackageIndexSpec.hs +++ b/test/Stackage2/PackageIndexSpec.hs @@ -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