mirror of
https://github.com/commercialhaskell/stackage.git
synced 2026-01-11 23:08:30 +01:00
Fixed up some bad terms
This commit is contained in:
Michael Snoyman
parent
ed6e673a1a
commit
bc26fc565c
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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 }
|
||||
|
||||
Loading…
Reference in New Issue
Block a user