Fixed up some bad terms

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)
+    deriving (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
+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
+data PackagePlan = PackagePlan
-    { pbVersion           :: Version
+    { ppVersion           :: Version
-    , pbGithubPings       :: Set Text
+    , ppGithubPings       :: Set Text
-    , pbUsers             :: Set PackageName
+    , ppUsers             :: Set PackageName
-    , pbPackageConstraints :: PackageConstraints
+    , ppConstraints  :: PackageConstraints
-    , pbDesc              :: desc
+    , ppDesc              :: SimpleDesc
     }
-    deriving (Functor, Foldable, Traversable, Show, Eq)
+    deriving (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
+instance ToJSON PackagePlan where
-    toJSON PackageBuild {..} = object
+    toJSON PackagePlan {..} = object
-        [ "version" .= asText (display pbVersion)
+        [ "version"      .= asText (display ppVersion)
-        , "github-pings" .= pbGithubPings
+        , "github-pings" .= ppGithubPings
-        , "users" .= map unPackageName (unpack pbUsers)
+        , "users"        .= map unPackageName (unpack ppUsers)
-        , "constraints" .= pbPackageConstraints
+        , "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
+        ppVersion <- o .: "version" >>= efail . simpleParse . asText
-        pbGithubPings <- o .:? "github-pings" .!= mempty
+        ppGithubPings <- o .:? "github-pings" .!= mempty
-        pbUsers <- Set.map PackageName <$> (o .:? "users" .!= mempty)
+        ppUsers <- Set.map PackageName <$> (o .:? "users" .!= mempty)
-        pbPackageConstraints <- o .: "constraints"
+        ppConstraints <- o .: "constraints"
-        return PackageBuild {..}
+        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)
+    packagesOrig <- getLatestDescriptions (isAllowed bc) (mkPackagePlan bc)
-    let toolMap = makeToolMap extraOrig
+    let toolMap = makeToolMap packagesOrig
-        extra = populateUsers $ removeUnincluded bc toolMap extraOrig
+        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
+        packagePlan <- maybeToList $ lookup packageName packagesOrig
-        return (packageName, packageBuild)
+        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) =
+    go (packageName, pp) =
-        foldMap go' $ seProvidedExes $ fcExtra $ pbDesc pb
+        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
+    ppVersion
-    (concatMap (fromMaybe mempty . flip lookup toolMap) . Map.keys . seTools . fcExtra . pbDesc)
+    (concatMap (fromMaybe mempty . flip lookup toolMap) . Map.keys . sdTools . ppDesc)
-
-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)
 
 -- | 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 PackagePlan
-                 -> Map PackageName (PackageBuild FlatComponent)
+                 -> 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
+                    mapM_ add $ Map.keys $ sdPackages $ ppDesc pb
-                    forM_ (map fst $ mapToList $ seTools $ fcExtra $ pbDesc pb) $
+                    forM_ (Map.keys $ sdTools $ ppDesc pb) $
                         \exeName -> when (exeName `notMember` siCoreExecutables)
                             $ mapM_ add $ fromMaybe mempty $ lookup exeName toolMap
 
-populateUsers :: Map PackageName (PackageBuild FlatComponent)
+populateUsers :: Map PackageName PackagePlan
-              -> Map PackageName (PackageBuild FlatComponent)
+              -> 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
+mkPackagePlan :: MonadThrow m
-               => BuildConstraints
+              => BuildConstraints
-               -> GenericPackageDescription
+              -> GenericPackageDescription
-               -> m (PackageBuild FlatComponent)
+              -> m PackagePlan
-mkPackageBuild bc gpd = do
+mkPackagePlan bc gpd = do
-    pbDesc <- getFlattenedComponent CheckCond {..} gpd
+    ppDesc <- toSimpleDesc CheckCond {..} gpd
-    return PackageBuild {..}
+    return PackagePlan {..}
   where
-    PackageIdentifier name pbVersion = package $ packageDescription gpd
+    PackageIdentifier name ppVersion = package $ packageDescription gpd
-    pbGithubPings = getGithubPings gpd
+    ppGithubPings = getGithubPings gpd
-    pbPackageConstraints = bcPackageConstraints bc name
+    ppConstraints = bcPackageConstraints bc name
-    pbUsers = mempty -- must be filled in later
+    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
+    ccIncludeTests = pcTests ppConstraints /= Don'tBuild
-    ccIncludeBenchmarks = pcBuildBenchmarks pbPackageConstraints
+    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

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
+            , puVersion = ppVersion pb
-            , puMaintainer = pcMaintainer $ pbPackageConstraints pb
+            , puMaintainer = pcMaintainer $ ppConstraints pb
-            , puGithubPings = pbGithubPings pb
+            , puGithubPings = ppGithubPings pb
             }
 
 data PkgUser = PkgUser

Stackage2/PackageDescription.hs

@@ -1,127 +1,118 @@
-{-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DeriveFoldable     #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveFunctor      #-}
-{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable  #-}
-{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE FlexibleContexts   #-}
-{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE NoImplicitPrelude  #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE TypeFamilies       #-}
 -- | Manipulate @GenericPackageDescription@ from Cabal into something more
 -- useful for us.
 module Stackage2.PackageDescription
-    ( FlatComponent (..)
+    ( SimpleDesc (..)
-    , getFlattenedComponent
+    , toSimpleDesc
-    , SimpleExtra (..)
     , CheckCond (..)
     ) where
 
-import Distribution.Package            (Dependency (..))
+import           Control.Monad.State.Strict      (execState, get, put)
-import Distribution.PackageDescription
+import           Control.Monad.Writer.Strict     (MonadWriter, execWriterT,
-import Stackage2.CorePackages
+                                                  tell)
-import Stackage2.PackageIndex
+import           Data.Aeson
-import Stackage2.Prelude
+import qualified Data.Map                        as Map
-import Stackage2.GithubPings
+import qualified Data.Set                        as Set
-import Control.Monad.State.Strict (execState, get, put)
+import           Distribution.Compiler           (CompilerFlavor)
-import qualified Data.Map as Map
+import           Distribution.Package            (Dependency (..))
-import qualified Data.Set as Set
+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
+-- | A simplified package description that tracks:
-    { stDeps :: Map PackageName VersionRange
+--
-    , stConds :: [(Condition ConfVar, SimpleTree, Maybe SimpleTree)]
+-- * Package dependencies
-    , stExtra :: SimpleExtra
+--
+-- * 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
+    deriving (Show, Eq)
-instance Monoid SimpleTree where
+instance Monoid SimpleDesc where
-    mempty = SimpleTree mempty mempty mempty
+    mempty = SimpleDesc mempty mempty mempty
-    mappend (SimpleTree a b c) (SimpleTree x y z) = SimpleTree
+    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?
+-- | Convert a 'GenericPackageDescription' into a 'SimpleDesc' by following the
-    { seTools :: Map ExeName VersionRange
+-- constraints in the provided 'CheckCond'.
-    , seProvidedExes :: Set ExeName
+toSimpleDesc :: MonadThrow m
-    }
+             => CheckCond
-    deriving (Show, Eq)
+             -> GenericPackageDescription
-instance Monoid SimpleExtra where
+             -> m SimpleDesc
-    mempty = SimpleExtra mempty mempty
+toSimpleDesc cc gpd = execWriterT $ do
-    mappend (SimpleExtra a b) (SimpleExtra x y) = SimpleExtra
+    forM_ (condLibrary gpd) $ tellTree cc libBuildInfo
-        (unionWith intersectVersionRanges a x)
+    forM_ (condExecutables gpd) $ tellTree cc buildInfo . snd
-        (b ++ y)
+    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
+-- | Convert a single CondTree to a 'SimpleDesc'.
-    :: MonadThrow m
+tellTree :: (MonadWriter SimpleDesc m, MonadThrow m)
-    => CheckCond
+         => CheckCond
-    -> GenericPackageDescription
+         -> (a -> BuildInfo)
-    -> m FlatComponent
+         -> CondTree ConfVar [Dependency] a
-getFlattenedComponent checkCond' gpd =
+         -> m ()
-    liftM fold
+tellTree cc getBI (CondNode dat deps comps) = do
-        $ mapM (flattenComponent checkCond')
+    tell mempty
-        $ getSimpleTrees
+        { sdPackages = unionsWith intersectVersionRanges $ flip map deps
-            (ccIncludeTests checkCond')
+            $ \(Dependency x y) -> singletonMap x $ simplifyVersionRange y
-            (ccIncludeBenchmarks checkCond')
+        , sdTools = unionsWith intersectVersionRanges $ flip map (buildTools $ getBI dat)
-            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)
             $ \(Dependency name range) -> singletonMap
+                -- In practice, cabal files refer to the exe name, not the
+                -- package name.
                 (ExeName $ unPackageName name)
-                range
+                (simplifyVersionRange range)
-        , seProvidedExes = exes
         }
-
+    forM_ comps $ \(cond, ontrue, onfalse) -> do
-data FlatComponent = FlatComponent
+        b <- checkCond cc cond
-    { 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
         if b
-            then flattenComponent checkCond' tree1
+            then tellTree cc getBI ontrue
-            else maybe (return mempty) (flattenComponent checkCond') mtree2
+            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
+    { ccPackageName       :: PackageName -- for debugging only
-    , ccOS :: OS
+    , ccOS                :: OS
-    , ccArch :: Arch
+    , ccArch              :: Arch
-    , ccFlags :: Map FlagName Bool
+    , ccFlags             :: Map FlagName Bool
-    , ccCompilerFlavor :: CompilerFlavor
+    , ccCompilerFlavor    :: CompilerFlavor
-    , ccCompilerVersion :: Version
+    , ccCompilerVersion   :: Version
-    , ccIncludeTests :: Bool
+    , ccIncludeTests      :: Bool
     , ccIncludeBenchmarks :: Bool
     }

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)

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)

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 }