diff --git a/Stackage2/BuildPlan.hs b/Stackage2/BuildPlan.hs index dcfb9d33..32834904 100644 --- a/Stackage2/BuildPlan.hs +++ b/Stackage2/BuildPlan.hs @@ -11,7 +11,7 @@ -- based on constraints. module Stackage2.BuildPlan ( BuildPlan (..) - , PackageBuild (..) + , PackagePlan (..) , newBuildPlan ) where @@ -30,18 +30,14 @@ import Stackage2.PackageDescription import qualified Distribution.System import qualified Distribution.Compiler -data BuildPlan desc = BuildPlan +data BuildPlan = BuildPlan { bpSystemInfo :: SystemInfo , bpTools :: Vector (PackageName, Version) - , bpPackages :: Map PackageName (PackageBuild desc) + , bpPackages :: Map PackageName PackagePlan } - deriving (Functor, Foldable, Traversable, Show, Eq) -type instance Element (BuildPlan desc) = desc -instance MonoFunctor (BuildPlan desc) -instance MonoFoldable (BuildPlan desc) -instance MonoTraversable (BuildPlan desc) + deriving (Show, Eq) -instance ToJSON (BuildPlan desc) where +instance ToJSON BuildPlan where toJSON BuildPlan {..} = object [ "system-info" .= bpSystemInfo , "tools" .= map goTool bpTools @@ -52,7 +48,7 @@ instance ToJSON (BuildPlan desc) where [ "name" .= display k , "version" .= display v ] -instance desc ~ () => FromJSON (BuildPlan desc) where +instance FromJSON BuildPlan where parseJSON = withObject "BuildPlan" $ \o -> do bpSystemInfo <- o .: "system-info" bpTools <- (o .: "tools") >>= mapM goTool @@ -65,107 +61,81 @@ instance desc ~ () => FromJSON (BuildPlan desc) where <*> ((o .: "version") >>= either (fail . show) return . simpleParse . asText) -data PackageBuild desc = PackageBuild - { pbVersion :: Version - , pbGithubPings :: Set Text - , pbUsers :: Set PackageName - , pbPackageConstraints :: PackageConstraints - , pbDesc :: desc +data PackagePlan = PackagePlan + { ppVersion :: Version + , ppGithubPings :: Set Text + , ppUsers :: Set PackageName + , ppConstraints :: PackageConstraints + , ppDesc :: SimpleDesc } - deriving (Functor, Foldable, Traversable, Show, Eq) -type instance Element (PackageBuild desc) = desc -instance MonoFunctor (PackageBuild desc) -instance MonoFoldable (PackageBuild desc) -instance MonoTraversable (PackageBuild desc) + deriving (Show, Eq) -instance ToJSON (PackageBuild desc) where - toJSON PackageBuild {..} = object - [ "version" .= asText (display pbVersion) - , "github-pings" .= pbGithubPings - , "users" .= map unPackageName (unpack pbUsers) - , "constraints" .= pbPackageConstraints +instance ToJSON PackagePlan where + toJSON PackagePlan {..} = object + [ "version" .= asText (display ppVersion) + , "github-pings" .= ppGithubPings + , "users" .= map unPackageName (unpack ppUsers) + , "constraints" .= ppConstraints + , "description" .= ppDesc ] -instance desc ~ () => FromJSON (PackageBuild desc) where +instance FromJSON PackagePlan where parseJSON = withObject "PackageBuild" $ \o -> do - pbVersion <- o .: "version" >>= efail . simpleParse . asText - pbGithubPings <- o .:? "github-pings" .!= mempty - pbUsers <- Set.map PackageName <$> (o .:? "users" .!= mempty) - pbPackageConstraints <- o .: "constraints" - return PackageBuild {..} + ppVersion <- o .: "version" >>= efail . simpleParse . asText + ppGithubPings <- o .:? "github-pings" .!= mempty + ppUsers <- Set.map PackageName <$> (o .:? "users" .!= mempty) + ppConstraints <- o .: "constraints" + ppDesc <- o .: "description" + return PackagePlan {..} where pbDesc = () efail = either (fail . show) return -newBuildPlan :: MonadIO m => BuildConstraints -> m (BuildPlan FlatComponent) +newBuildPlan :: MonadIO m => BuildConstraints -> m BuildPlan newBuildPlan bc@BuildConstraints {..} = liftIO $ do - extraOrig <- getLatestDescriptions (isAllowed bc) (mkPackageBuild bc) - let toolMap = makeToolMap extraOrig - extra = populateUsers $ removeUnincluded bc toolMap extraOrig + packagesOrig <- getLatestDescriptions (isAllowed bc) (mkPackagePlan bc) + let toolMap = makeToolMap packagesOrig + packages = populateUsers $ removeUnincluded bc toolMap packagesOrig toolNames :: [ExeName] - toolNames = concatMap (Map.keys . seTools . fcExtra . pbDesc) extra + toolNames = concatMap (Map.keys . sdTools . ppDesc) packages tools <- topologicalSortTools toolMap $ mapFromList $ do exeName <- toolNames guard $ exeName `notMember` siCoreExecutables packageName <- maybe mempty setToList $ lookup exeName toolMap - packageBuild <- maybeToList $ lookup packageName extraOrig - return (packageName, packageBuild) + packagePlan <- maybeToList $ lookup packageName packagesOrig + return (packageName, packagePlan) -- FIXME topologically sort packages? maybe just leave that to the build phase return BuildPlan { bpSystemInfo = bcSystemInfo , bpTools = tools - , bpPackages = extra + , bpPackages = packages } where SystemInfo {..} = bcSystemInfo -makeToolMap :: Map PackageName (PackageBuild FlatComponent) +makeToolMap :: Map PackageName PackagePlan -> Map ExeName (Set PackageName) makeToolMap = unionsWith (++) . map go . mapToList where - go (packageName, pb) = - foldMap go' $ seProvidedExes $ fcExtra $ pbDesc pb + go (packageName, pp) = + foldMap go' $ sdProvidedExes $ ppDesc pp where go' exeName = singletonMap exeName (singletonSet packageName) topologicalSortTools :: MonadThrow m => Map ExeName (Set PackageName) - -> Map PackageName (PackageBuild FlatComponent) + -> Map PackageName PackagePlan -> m (Vector (PackageName, Version)) topologicalSortTools toolMap = topologicalSort - pbVersion - (concatMap (fromMaybe mempty . flip lookup toolMap) . Map.keys . seTools . fcExtra . pbDesc) - -topologicalSort :: (Ord key, Show key, MonadThrow m, Typeable key) - => (value -> finalValue) - -> (value -> Set key) -- ^ deps - -> Map key value - -> m (Vector (key, finalValue)) -topologicalSort toFinal toDeps = - loop id . mapWithKey removeSelfDeps . fmap (toDeps &&& toFinal) - where - removeSelfDeps k (deps, final) = (deleteSet k deps, final) - loop front toProcess | null toProcess = return $ pack $ front [] - loop front toProcess - | null noDeps = throwM $ NoEmptyDeps (map fst toProcess') - | otherwise = loop (front . noDeps') (mapFromList hasDeps) - where - toProcess' = fmap (first removeUnavailable) toProcess - allKeys = Map.keysSet toProcess - removeUnavailable = asSet . setFromList . filter (`member` allKeys) . setToList - (noDeps, hasDeps) = partition (null . fst . snd) $ mapToList toProcess' - noDeps' = (map (second snd) noDeps ++) - -data TopologicalSortException key = NoEmptyDeps (Map key (Set key)) - deriving (Show, Typeable) -instance (Show key, Typeable key) => Exception (TopologicalSortException key) + ppVersion + (concatMap (fromMaybe mempty . flip lookup toolMap) . Map.keys . sdTools . ppDesc) -- | Include only packages which are dependencies of the required packages and -- their build tools. removeUnincluded :: BuildConstraints -> Map ExeName (Set PackageName) - -> Map PackageName (PackageBuild FlatComponent) - -> Map PackageName (PackageBuild FlatComponent) + -> Map PackageName PackagePlan + -> Map PackageName PackagePlan removeUnincluded BuildConstraints {..} toolMap orig = mapFromList $ filter (\(x, _) -> x `member` included) $ mapToList orig where @@ -181,20 +151,20 @@ removeUnincluded BuildConstraints {..} toolMap orig = case lookup name orig of Nothing -> return () Just pb -> do - mapM_ (add . fst) $ mapToList $ fcDeps $ pbDesc pb - forM_ (map fst $ mapToList $ seTools $ fcExtra $ pbDesc pb) $ + mapM_ add $ Map.keys $ sdPackages $ ppDesc pb + forM_ (Map.keys $ sdTools $ ppDesc pb) $ \exeName -> when (exeName `notMember` siCoreExecutables) $ mapM_ add $ fromMaybe mempty $ lookup exeName toolMap -populateUsers :: Map PackageName (PackageBuild FlatComponent) - -> Map PackageName (PackageBuild FlatComponent) +populateUsers :: Map PackageName PackagePlan + -> Map PackageName PackagePlan populateUsers orig = mapWithKey go orig where - go name pb = pb { pbUsers = foldMap (go2 name) (mapToList orig) } + go name pb = pb { ppUsers = foldMap (go2 name) (mapToList orig) } go2 dep (user, pb) - | dep `member` fcDeps (pbDesc pb) = singletonSet user + | dep `member` sdPackages (ppDesc pb) = singletonSet user | otherwise = mempty -- | Check whether the given package/version combo meets the constraints @@ -206,18 +176,18 @@ isAllowed bc = \name version -> Just _ -> False -- never reinstall a core package Nothing -> withinRange version $ pcVersionRange $ bcPackageConstraints bc name -mkPackageBuild :: MonadThrow m - => BuildConstraints - -> GenericPackageDescription - -> m (PackageBuild FlatComponent) -mkPackageBuild bc gpd = do - pbDesc <- getFlattenedComponent CheckCond {..} gpd - return PackageBuild {..} +mkPackagePlan :: MonadThrow m + => BuildConstraints + -> GenericPackageDescription + -> m PackagePlan +mkPackagePlan bc gpd = do + ppDesc <- toSimpleDesc CheckCond {..} gpd + return PackagePlan {..} where - PackageIdentifier name pbVersion = package $ packageDescription gpd - pbGithubPings = getGithubPings gpd - pbPackageConstraints = bcPackageConstraints bc name - pbUsers = mempty -- must be filled in later + PackageIdentifier name ppVersion = package $ packageDescription gpd + ppGithubPings = getGithubPings gpd + ppConstraints = bcPackageConstraints bc name + ppUsers = mempty -- must be filled in later ccPackageName = name ccOS = siOS @@ -225,12 +195,12 @@ mkPackageBuild bc gpd = do ccCompilerFlavor = Distribution.Compiler.GHC ccCompilerVersion = siGhcVersion ccFlags = flags - ccIncludeTests = pcTests pbPackageConstraints /= Don'tBuild - ccIncludeBenchmarks = pcBuildBenchmarks pbPackageConstraints + ccIncludeTests = pcTests ppConstraints /= Don'tBuild + ccIncludeBenchmarks = pcBuildBenchmarks ppConstraints SystemInfo {..} = bcSystemInfo bc - overrides = pcFlagOverrides pbPackageConstraints + overrides = pcFlagOverrides ppConstraints getFlag MkFlag {..} = (flagName, fromMaybe flagDefault $ lookup flagName overrides) flags = mapFromList $ map getFlag $ genPackageFlags gpd diff --git a/Stackage2/CheckBuildPlan.hs b/Stackage2/CheckBuildPlan.hs index b27f6af5..8ac0ecdb 100644 --- a/Stackage2/CheckBuildPlan.hs +++ b/Stackage2/CheckBuildPlan.hs @@ -14,20 +14,20 @@ import Stackage2.BuildConstraints import Stackage2.PackageDescription import Control.Monad.Writer.Strict (execWriter, Writer, tell) -checkBuildPlan :: MonadThrow m => BuildPlan FlatComponent -> m () +checkBuildPlan :: MonadThrow m => BuildPlan -> m () checkBuildPlan BuildPlan {..} | null errs' = return () | otherwise = throwM errs where - allPackages = siCorePackages bpSystemInfo ++ map pbVersion bpPackages + allPackages = siCorePackages bpSystemInfo ++ map ppVersion bpPackages errs@(BadBuildPlan errs') = execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages checkDeps :: Map PackageName Version - -> (PackageName, PackageBuild FlatComponent) + -> (PackageName, PackagePlan) -> Writer BadBuildPlan () checkDeps allPackages (user, pb) = - mapM_ go $ mapToList $ fcDeps $ pbDesc pb + mapM_ go $ mapToList $ sdPackages $ ppDesc pb where go (dep, range) = case lookup dep allPackages of @@ -41,9 +41,9 @@ checkDeps allPackages (user, pb) = errMap = singletonMap pu range pu = PkgUser { puName = user - , puVersion = pbVersion pb - , puMaintainer = pcMaintainer $ pbPackageConstraints pb - , puGithubPings = pbGithubPings pb + , puVersion = ppVersion pb + , puMaintainer = pcMaintainer $ ppConstraints pb + , puGithubPings = ppGithubPings pb } data PkgUser = PkgUser diff --git a/Stackage2/PackageDescription.hs b/Stackage2/PackageDescription.hs index d0f95198..406008ff 100644 --- a/Stackage2/PackageDescription.hs +++ b/Stackage2/PackageDescription.hs @@ -1,127 +1,118 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} -- | Manipulate @GenericPackageDescription@ from Cabal into something more -- useful for us. module Stackage2.PackageDescription - ( FlatComponent (..) - , getFlattenedComponent - , SimpleExtra (..) + ( SimpleDesc (..) + , toSimpleDesc , CheckCond (..) ) where -import Distribution.Package (Dependency (..)) -import Distribution.PackageDescription -import Stackage2.CorePackages -import Stackage2.PackageIndex -import Stackage2.Prelude -import Stackage2.GithubPings -import Control.Monad.State.Strict (execState, get, put) -import qualified Data.Map as Map -import qualified Data.Set as Set +import Control.Monad.State.Strict (execState, get, put) +import Control.Monad.Writer.Strict (MonadWriter, execWriterT, + tell) +import Data.Aeson +import qualified Data.Map as Map +import qualified Data.Set as Set +import Distribution.Compiler (CompilerFlavor) +import Distribution.Package (Dependency (..)) +import Distribution.PackageDescription +import Distribution.System (Arch, OS) +import Stackage2.CorePackages +import Stackage2.GithubPings +import Stackage2.PackageIndex +import Stackage2.Prelude import Data.Aeson -import Distribution.System (OS, Arch) -import Distribution.Compiler (CompilerFlavor) -data SimpleTree = SimpleTree - { stDeps :: Map PackageName VersionRange - , stConds :: [(Condition ConfVar, SimpleTree, Maybe SimpleTree)] - , stExtra :: SimpleExtra +-- | A simplified package description that tracks: +-- +-- * Package dependencies +-- +-- * Build tool dependencies +-- +-- * Provided executables +-- +-- It has fully resolved all conditionals +data SimpleDesc = SimpleDesc + { sdPackages :: Map PackageName VersionRange + , sdTools :: Map ExeName VersionRange + , sdProvidedExes :: Set ExeName } - deriving Show -instance Monoid SimpleTree where - mempty = SimpleTree mempty mempty mempty - mappend (SimpleTree a b c) (SimpleTree x y z) = SimpleTree + deriving (Show, Eq) +instance Monoid SimpleDesc where + mempty = SimpleDesc mempty mempty mempty + mappend (SimpleDesc a b c) (SimpleDesc x y z) = SimpleDesc (unionWith intersectVersionRanges a x) - (b ++ y) + (unionWith intersectVersionRanges b y) (c ++ z) +instance ToJSON SimpleDesc where + toJSON SimpleDesc {..} = object + [ "packages" .= Map.mapKeysWith const unPackageName (map display sdPackages) + , "tools" .= Map.mapKeysWith const unExeName (map display sdTools) + , "provided-exes" .= sdProvidedExes + ] +instance FromJSON SimpleDesc where + parseJSON = withObject "SimpleDesc" $ \o -> do + sdPackages <- (o .: "packages") >>= + either (fail . show) return . + mapM simpleParse . + Map.mapKeysWith const mkPackageName + sdTools <- (o .: "tools") >>= + either (fail . show) return . + mapM simpleParse . + Map.mapKeysWith const ExeName + sdProvidedExes <- o .: "provided-exes" + return SimpleDesc {..} -data SimpleExtra = SimpleExtra -- FIXME fold into FlatComponent? - { seTools :: Map ExeName VersionRange - , seProvidedExes :: Set ExeName - } - deriving (Show, Eq) -instance Monoid SimpleExtra where - mempty = SimpleExtra mempty mempty - mappend (SimpleExtra a b) (SimpleExtra x y) = SimpleExtra - (unionWith intersectVersionRanges a x) - (b ++ y) +-- | Convert a 'GenericPackageDescription' into a 'SimpleDesc' by following the +-- constraints in the provided 'CheckCond'. +toSimpleDesc :: MonadThrow m + => CheckCond + -> GenericPackageDescription + -> m SimpleDesc +toSimpleDesc cc gpd = execWriterT $ do + forM_ (condLibrary gpd) $ tellTree cc libBuildInfo + forM_ (condExecutables gpd) $ tellTree cc buildInfo . snd + tell mempty { sdProvidedExes = setFromList + $ map (fromString . fst) + $ condExecutables gpd + } + when (ccIncludeTests cc) $ forM_ (condTestSuites gpd) + $ tellTree cc testBuildInfo . snd + when (ccIncludeBenchmarks cc) $ forM_ (condBenchmarks gpd) + $ tellTree cc benchmarkBuildInfo . snd -getFlattenedComponent - :: MonadThrow m - => CheckCond - -> GenericPackageDescription - -> m FlatComponent -getFlattenedComponent checkCond' gpd = - liftM fold - $ mapM (flattenComponent checkCond') - $ getSimpleTrees - (ccIncludeTests checkCond') - (ccIncludeBenchmarks checkCond') - gpd - -getSimpleTrees :: Bool -- ^ include test suites? - -> Bool -- ^ include benchmarks? - -> GenericPackageDescription - -> [SimpleTree] -getSimpleTrees includeTests includeBench gpd = concat - [ maybe [] (return . go libBuildInfo mempty) $ condLibrary gpd - , map (\(x, y) -> go buildInfo (singletonSet $ ExeName $ pack x) y) - $ condExecutables gpd - , if includeTests - then map (go testBuildInfo mempty . snd) $ condTestSuites gpd - else [] - , if includeBench - then map (go benchmarkBuildInfo mempty . snd) $ condBenchmarks gpd - else [] - ] - where - go getBI exes (CondNode dat deps comps) = SimpleTree - { stDeps = unionsWith intersectVersionRanges - $ map (\(Dependency x y) -> singletonMap x y) deps - , stConds = map (goComp getBI exes) comps - , stExtra = toSimpleExtra (getBI dat) exes - } - - goComp getBI exes (cond, tree1, mtree2) = - (cond, go getBI exes tree1, go getBI exes <$> mtree2) - - toSimpleExtra bi exes = SimpleExtra - { seTools = unionsWith intersectVersionRanges $ flip map (buildTools bi) +-- | Convert a single CondTree to a 'SimpleDesc'. +tellTree :: (MonadWriter SimpleDesc m, MonadThrow m) + => CheckCond + -> (a -> BuildInfo) + -> CondTree ConfVar [Dependency] a + -> m () +tellTree cc getBI (CondNode dat deps comps) = do + tell mempty + { sdPackages = unionsWith intersectVersionRanges $ flip map deps + $ \(Dependency x y) -> singletonMap x $ simplifyVersionRange y + , sdTools = unionsWith intersectVersionRanges $ flip map (buildTools $ getBI dat) $ \(Dependency name range) -> singletonMap + -- In practice, cabal files refer to the exe name, not the + -- package name. (ExeName $ unPackageName name) - range - , seProvidedExes = exes + (simplifyVersionRange range) } - -data FlatComponent = FlatComponent - { fcDeps :: Map PackageName VersionRange - , fcExtra :: SimpleExtra - } - deriving (Show, Eq) -instance Monoid FlatComponent where - mempty = FlatComponent mempty mempty - mappend (FlatComponent a b) (FlatComponent x y) = FlatComponent - (unionWith intersectVersionRanges a x) - (b ++ y) - -flattenComponent :: MonadThrow m => CheckCond -> SimpleTree -> m FlatComponent -flattenComponent checkCond' (SimpleTree deps conds extra) = do - conds' <- mapM goCond conds - return $ mconcat $ here : conds' - where - here = FlatComponent { fcDeps = deps, fcExtra = extra } - goCond (cond, tree1, mtree2) = do - b <- checkCond checkCond' cond + forM_ comps $ \(cond, ontrue, onfalse) -> do + b <- checkCond cc cond if b - then flattenComponent checkCond' tree1 - else maybe (return mempty) (flattenComponent checkCond') mtree2 + then tellTree cc getBI ontrue + else maybe (return ()) (tellTree cc getBI) onfalse +-- | Resolve a condition to a boolean based on the provided 'CheckCond'. checkCond :: MonadThrow m => CheckCond -> Condition ConfVar -> m Bool checkCond CheckCond {..} cond0 = go cond0 @@ -145,12 +136,12 @@ data CheckCondException = FlagNotDefined PackageName FlagName (Condition ConfVar instance Exception CheckCondException data CheckCond = CheckCond - { ccPackageName :: PackageName -- for debugging only - , ccOS :: OS - , ccArch :: Arch - , ccFlags :: Map FlagName Bool - , ccCompilerFlavor :: CompilerFlavor - , ccCompilerVersion :: Version - , ccIncludeTests :: Bool + { ccPackageName :: PackageName -- for debugging only + , ccOS :: OS + , ccArch :: Arch + , ccFlags :: Map FlagName Bool + , ccCompilerFlavor :: CompilerFlavor + , ccCompilerVersion :: Version + , ccIncludeTests :: Bool , ccIncludeBenchmarks :: Bool } diff --git a/Stackage2/Prelude.hs b/Stackage2/Prelude.hs index d41b6af7..4a4c3227 100644 --- a/Stackage2/Prelude.hs +++ b/Stackage2/Prelude.hs @@ -20,6 +20,7 @@ import System.Exit (ExitCode (ExitSuccess)) import Data.Aeson (ToJSON, FromJSON) import qualified Distribution.Version as C import Distribution.Version as X (withinRange) +import qualified Data.Map as Map unPackageName :: PackageName -> Text unPackageName (PackageName str) = pack str @@ -101,3 +102,29 @@ simplifyVersionRange vr = fromMaybe (assert False vr') $ simpleParse $ display vr' where vr' = C.simplifyVersionRange vr + +-- | Topologically sort so that items with dependencies occur after those +-- dependencies. +topologicalSort :: (Ord key, Show key, MonadThrow m, Typeable key) + => (value -> finalValue) + -> (value -> Set key) -- ^ deps + -> Map key value + -> m (Vector (key, finalValue)) +topologicalSort toFinal toDeps = + loop id . mapWithKey removeSelfDeps . fmap (toDeps &&& toFinal) + where + removeSelfDeps k (deps, final) = (deleteSet k deps, final) + loop front toProcess | null toProcess = return $ pack $ front [] + loop front toProcess + | null noDeps = throwM $ NoEmptyDeps (map fst toProcess') + | otherwise = loop (front . noDeps') (mapFromList hasDeps) + where + toProcess' = fmap (first removeUnavailable) toProcess + allKeys = Map.keysSet toProcess + removeUnavailable = asSet . setFromList . filter (`member` allKeys) . setToList + (noDeps, hasDeps) = partition (null . fst . snd) $ mapToList toProcess' + noDeps' = (map (second snd) noDeps ++) + +data TopologicalSortException key = NoEmptyDeps (Map key (Set key)) + deriving (Show, Typeable) +instance (Show key, Typeable key) => Exception (TopologicalSortException key) diff --git a/Stackage2/UpdateBuildPlan.hs b/Stackage2/UpdateBuildPlan.hs index 51e0b67e..6acadba5 100644 --- a/Stackage2/UpdateBuildPlan.hs +++ b/Stackage2/UpdateBuildPlan.hs @@ -15,10 +15,10 @@ import Stackage2.PackageDescription import Distribution.Version (orLaterVersion, earlierVersion, anyVersion) import qualified Data.Map as Map -updateBuildPlan :: BuildPlan a -> IO (BuildPlan FlatComponent) +updateBuildPlan :: BuildPlan -> IO BuildPlan updateBuildPlan = newBuildPlan . updateBuildConstraints -updateBuildConstraints :: BuildPlan a -> BuildConstraints +updateBuildConstraints :: BuildPlan -> BuildConstraints updateBuildConstraints BuildPlan {..} = BuildConstraints {..} where @@ -35,13 +35,13 @@ updateBuildConstraints BuildPlan {..} = } where moldBP = lookup name bpPackages - moldPC = pbPackageConstraints <$> moldBP + moldPC = ppConstraints <$> moldBP addBumpRange oldRange = case moldBP of Nothing -> oldRange Just bp -> intersectVersionRanges oldRange - $ bumpRange $ pbVersion bp + $ bumpRange $ ppVersion bp bumpRange version = intersectVersionRanges (orLaterVersion version) diff --git a/test/Stackage2/BuildPlanSpec.hs b/test/Stackage2/BuildPlanSpec.hs index 66443d26..4802db35 100644 --- a/test/Stackage2/BuildPlanSpec.hs +++ b/test/Stackage2/BuildPlanSpec.hs @@ -23,14 +23,14 @@ spec = it "works" $ do let allPackages = Map.keysSet (bpPackages bp) ++ Map.keysSet (bpPackages bp') forM_ allPackages $ \name -> (name, lookup name (bpPackages bp')) `shouldBe` - (name, lookup name (bpPackages (() <$ bp))) + (name, lookup name (bpPackages bp)) - bp' `shouldBe` (() <$ bp) + bp' `shouldBe` bp bp2 <- updateBuildPlan bp dropVersionRanges bp2 `shouldBe` dropVersionRanges bp where dropVersionRanges bp = bp { bpPackages = map go $ bpPackages bp } where - go pb = pb { pbPackageConstraints = go' $ pbPackageConstraints pb } + go pb = pb { ppConstraints = go' $ ppConstraints pb } go' pc = pc { pcVersionRange = anyVersion }