haskell/stackage
1
0
Fork 0
mirror of https://github.com/commercialhaskell/stackage.git synced 2026-01-28 23:20:26 +01:00
Code Issues Actions Packages Projects Releases Wiki Activity

Cleanup

Browse Source
This commit is contained in:
Michael Snoyman 2014-12-08 14:16:30 +02:00
parent 04f71e69e7
commit 17e23a8906
10 changed files with 102 additions and 106 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
Stackage2/BuildConstraints.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
-- | The constraints on package selection for a new build plan. -- | The constraints on package selection for a new build plan.
module Stackage2.BuildConstraints module Stackage2.BuildConstraints
( BuildConstraints (..) ( BuildConstraints (..)
@ -11,16 +11,16 @@ module Stackage2.BuildConstraints
, defaultBuildConstraints , defaultBuildConstraints
) where ) where
import Stackage2.Prelude import Data.Aeson
import Stackage2.CorePackages import qualified Data.Map as Map
import qualified Stackage.Config as Old import Distribution.System (Arch, OS)
import qualified Stackage.Types as Old
import qualified Stackage.Select as Old
import Data.Aeson
import Distribution.System (OS, Arch)
import Distribution.Version (anyVersion)
import qualified Distribution.System import qualified Distribution.System
import qualified Data.Map as Map import Distribution.Version (anyVersion)
import qualified Stackage.Config as Old
import qualified Stackage.Select as Old
import qualified Stackage.Types as Old
import Stackage2.CorePackages
import Stackage2.Prelude
data TestState = ExpectSuccess data TestState = ExpectSuccess
| ExpectFailure | ExpectFailure
@ -44,10 +44,10 @@ instance FromJSON TestState where
$ map (\x -> (testStateToText x, x)) [minBound..maxBound] $ map (\x -> (testStateToText x, x)) [minBound..maxBound]
data SystemInfo = SystemInfo data SystemInfo = SystemInfo
{ siGhcVersion :: Version { siGhcVersion :: Version
, siOS :: OS , siOS :: OS
, siArch :: Arch , siArch :: Arch
, siCorePackages :: Map PackageName Version , siCorePackages :: Map PackageName Version
, siCoreExecutables :: Set ExeName , siCoreExecutables :: Set ExeName
} }
deriving (Show, Eq, Ord) deriving (Show, Eq, Ord)
@ -74,20 +74,20 @@ instance FromJSON SystemInfo where
. Map.mapKeysWith const mkPackageName . Map.mapKeysWith const mkPackageName
data BuildConstraints = BuildConstraints data BuildConstraints = BuildConstraints
{ bcPackages :: Set PackageName { bcPackages :: Set PackageName
-- ^ This does not include core packages. -- ^ This does not include core packages.
, bcPackageConstraints :: PackageName -> PackageConstraints , bcPackageConstraints :: PackageName -> PackageConstraints
, bcSystemInfo :: SystemInfo , bcSystemInfo :: SystemInfo
} }
data PackageConstraints = PackageConstraints data PackageConstraints = PackageConstraints
{ pcVersionRange :: VersionRange { pcVersionRange :: VersionRange
, pcMaintainer :: Maybe Maintainer , pcMaintainer :: Maybe Maintainer
, pcTests :: TestState , pcTests :: TestState
, pcHaddocks :: TestState , pcHaddocks :: TestState
, pcBuildBenchmarks :: Bool , pcBuildBenchmarks :: Bool
, pcFlagOverrides :: Map FlagName Bool , pcFlagOverrides :: Map FlagName Bool
} }
deriving (Show, Eq) deriving (Show, Eq)
instance ToJSON PackageConstraints where instance ToJSON PackageConstraints where
@ -128,8 +128,6 @@ defaultBuildConstraints = do
defaultGlobalFlags = asMap $ mapFromList $ defaultGlobalFlags = asMap $ mapFromList $
map (, True) (map FlagName $ setToList $ Old.flags oldSettings mempty) ++ map (, True) (map FlagName $ setToList $ Old.flags oldSettings mempty) ++
map (, False) (map FlagName $ setToList $ Old.disabledFlags oldSettings) map (, False) (map FlagName $ setToList $ Old.disabledFlags oldSettings)
tryBuildTest (PackageName name) = pack name `notMember` skippedTests
tryBuildBenchmark (PackageName name) = pack name `notMember` skippedBenchs
expectedFailures = Old.defaultExpectedFailures oldGhcVer False expectedFailures = Old.defaultExpectedFailures oldGhcVer False
skippedTests = skippedTests =
old ++ extraSkippedTests old ++ extraSkippedTests
@ -145,7 +143,7 @@ defaultBuildConstraints = do
pcVersionRange = simplifyVersionRange $ maybe anyVersion fst mold pcVersionRange = simplifyVersionRange $ maybe anyVersion fst mold
pcMaintainer = (Maintainer . pack . Old.unMaintainer . snd) <$> mold pcMaintainer = (Maintainer . pack . Old.unMaintainer . snd) <$> mold
pcTests pcTests
| not $ tryBuildTest name = Don'tBuild | unPackageName name `member` skippedTests = Don'tBuild
| name `member` expectedFailures = ExpectFailure | name `member` expectedFailures = ExpectFailure
| otherwise = ExpectSuccess | otherwise = ExpectSuccess

60
Stackage2/BuildPlan.hs
View File

@ -1,12 +1,12 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
-- | Representation of a concrete build plan, and how to generate a new one -- | Representation of a concrete build plan, and how to generate a new one
-- based on constraints. -- based on constraints.
module Stackage2.BuildPlan module Stackage2.BuildPlan
@ -15,25 +15,22 @@ module Stackage2.BuildPlan
, newBuildPlan , newBuildPlan
) where ) where
import Distribution.Package (Dependency (..)) import Control.Monad.State.Strict (execState, get, put)
import Distribution.PackageDescription import Data.Aeson
import Distribution.Version (withinRange, anyVersion, simplifyVersionRange) import qualified Data.Map as Map
import Stackage2.BuildConstraints import qualified Data.Set as Set
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 Data.Aeson
import Stackage2.PackageDescription
import qualified Distribution.System
import qualified Distribution.Compiler import qualified Distribution.Compiler
import Distribution.PackageDescription
import Stackage2.BuildConstraints
import Stackage2.GithubPings
import Stackage2.PackageDescription
import Stackage2.PackageIndex
import Stackage2.Prelude
data BuildPlan = BuildPlan data BuildPlan = BuildPlan
{ bpSystemInfo :: SystemInfo { bpSystemInfo :: SystemInfo
, bpTools :: Vector (PackageName, Version) , bpTools :: Vector (PackageName, Version)
, bpPackages :: Map PackageName PackagePlan , bpPackages :: Map PackageName PackagePlan
} }
deriving (Show, Eq) deriving (Show, Eq)
@ -62,11 +59,11 @@ instance FromJSON BuildPlan where
either (fail . show) return . simpleParse . asText) either (fail . show) return . simpleParse . asText)
data PackagePlan = PackagePlan data PackagePlan = PackagePlan
{ ppVersion :: Version { ppVersion :: Version
, ppGithubPings :: Set Text , ppGithubPings :: Set Text
, ppUsers :: Set PackageName , ppUsers :: Set PackageName
, ppConstraints :: PackageConstraints , ppConstraints :: PackageConstraints
, ppDesc :: SimpleDesc , ppDesc :: SimpleDesc
} }
deriving (Show, Eq) deriving (Show, Eq)
@ -80,15 +77,14 @@ instance ToJSON PackagePlan where
] ]
instance FromJSON PackagePlan where instance FromJSON PackagePlan where
parseJSON = withObject "PackageBuild" $ \o -> do parseJSON = withObject "PackageBuild" $ \o -> do
ppVersion <- o .: "version" >>= efail . simpleParse . asText ppVersion <- o .: "version"
>>= either (fail . show) return
. simpleParse . asText
ppGithubPings <- o .:? "github-pings" .!= mempty ppGithubPings <- o .:? "github-pings" .!= mempty
ppUsers <- Set.map PackageName <$> (o .:? "users" .!= mempty) ppUsers <- Set.map PackageName <$> (o .:? "users" .!= mempty)
ppConstraints <- o .: "constraints" ppConstraints <- o .: "constraints"
ppDesc <- o .: "description" ppDesc <- o .: "description"
return PackagePlan {..} return PackagePlan {..}
where
pbDesc = ()
efail = either (fail . show) return
newBuildPlan :: MonadIO m => BuildConstraints -> m BuildPlan newBuildPlan :: MonadIO m => BuildConstraints -> m BuildPlan
newBuildPlan bc@BuildConstraints {..} = liftIO $ do newBuildPlan bc@BuildConstraints {..} = liftIO $ do

20
Stackage2/CheckBuildPlan.hs
View File

@ -1,18 +1,18 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
-- | Confirm that a build plan has a consistent set of dependencies. -- | Confirm that a build plan has a consistent set of dependencies.
module Stackage2.CheckBuildPlan module Stackage2.CheckBuildPlan
( checkBuildPlan ( checkBuildPlan
) where ) where
import Stackage2.Prelude import Control.Monad.Writer.Strict (Writer, execWriter, tell)
import Stackage2.BuildPlan
import Stackage2.BuildConstraints import Stackage2.BuildConstraints
import Stackage2.BuildPlan
import Stackage2.PackageDescription import Stackage2.PackageDescription
import Control.Monad.Writer.Strict (execWriter, Writer, tell) import Stackage2.Prelude
checkBuildPlan :: MonadThrow m => BuildPlan -> m () checkBuildPlan :: MonadThrow m => BuildPlan -> m ()
checkBuildPlan BuildPlan {..} checkBuildPlan BuildPlan {..}
@ -47,9 +47,9 @@ checkDeps allPackages (user, pb) =
} }
data PkgUser = PkgUser data PkgUser = PkgUser
{ puName :: PackageName { puName :: PackageName
, puVersion :: Version , puVersion :: Version
, puMaintainer :: Maybe Maintainer , puMaintainer :: Maybe Maintainer
, puGithubPings :: Set Text , puGithubPings :: Set Text
} }
deriving (Eq, Ord) deriving (Eq, Ord)

9
Stackage2/GithubPings.hs
View File

@ -1,11 +1,12 @@
{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Stackage2.GithubPings module Stackage2.GithubPings
( getGithubPings ( getGithubPings
) where ) where
import Stackage2.Prelude import Distribution.PackageDescription
import Distribution.PackageDescription import qualified Stackage.Config as Old
import qualified Stackage.Config as Old import Stackage2.Prelude
-- | Determine accounts to be pinged on Github based on various metadata in the -- | Determine accounts to be pinged on Github based on various metadata in the
-- package description. -- package description.

6
Stackage2/PackageDescription.hs
View File

@ -15,21 +15,15 @@ module Stackage2.PackageDescription
, CheckCond (..) , CheckCond (..)
) where ) where
import Control.Monad.State.Strict (execState, get, put)
import Control.Monad.Writer.Strict (MonadWriter, execWriterT, import Control.Monad.Writer.Strict (MonadWriter, execWriterT,
tell) tell)
import Data.Aeson import Data.Aeson
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set
import Distribution.Compiler (CompilerFlavor) import Distribution.Compiler (CompilerFlavor)
import Distribution.Package (Dependency (..)) import Distribution.Package (Dependency (..))
import Distribution.PackageDescription import Distribution.PackageDescription
import Distribution.System (Arch, OS) import Distribution.System (Arch, OS)
import Stackage2.CorePackages
import Stackage2.GithubPings
import Stackage2.PackageIndex
import Stackage2.Prelude import Stackage2.Prelude
import Data.Aeson
-- | A simplified package description that tracks: -- | A simplified package description that tracks:
-- --

4
Stackage2/PackageIndex.hs
View File

@ -12,11 +12,11 @@ module Stackage2.PackageIndex
) where ) where
import qualified Codec.Archive.Tar as Tar import qualified Codec.Archive.Tar as Tar
import qualified Codec.Archive.Tar.Entry as TarEntry
import Data.Conduit.Lazy (MonadActive, import Data.Conduit.Lazy (MonadActive,
lazyConsume) lazyConsume)
import qualified Data.Text as T import qualified Data.Text as T
import Distribution.PackageDescription (GenericPackageDescription, packageDescription, package) import Distribution.PackageDescription (package,
packageDescription)
import Distribution.PackageDescription.Parse (ParseResult (..), import Distribution.PackageDescription.Parse (ParseResult (..),
parsePackageDescription) parsePackageDescription)
import Distribution.ParseUtils (PError) import Distribution.ParseUtils (PError)

44
Stackage2/Prelude.hs
View File

@ -1,26 +1,26 @@
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Stackage2.Prelude module Stackage2.Prelude
( module X ( module X
, module Stackage2.Prelude , module Stackage2.Prelude
) where ) where
import ClassyPrelude.Conduit as X import ClassyPrelude.Conduit as X
import Data.Conduit.Process as X import Data.Aeson (FromJSON, ToJSON)
import Data.Typeable (TypeRep, typeOf) import Data.Conduit.Process as X
import Distribution.Package as X (PackageIdentifier (..), import qualified Data.Map as Map
PackageName (PackageName)) import Data.Typeable (TypeRep, typeOf)
import Distribution.PackageDescription as X (FlagName (..), GenericPackageDescription) import Distribution.Package as X (PackageIdentifier (..), PackageName (PackageName))
import qualified Distribution.Text as DT import Distribution.PackageDescription as X (FlagName (..), GenericPackageDescription)
import Distribution.Version as X (Version (..), VersionRange) import qualified Distribution.Text as DT
import System.Exit (ExitCode (ExitSuccess)) import Distribution.Version as X (Version (..),
import Data.Aeson (ToJSON, FromJSON) VersionRange)
import qualified Distribution.Version as C import Distribution.Version as X (withinRange)
import Distribution.Version as X (withinRange) import qualified Distribution.Version as C
import qualified Data.Map as Map import System.Exit (ExitCode (ExitSuccess))
unPackageName :: PackageName -> Text unPackageName :: PackageName -> Text
unPackageName (PackageName str) = pack str unPackageName (PackageName str) = pack str
@ -77,11 +77,19 @@ checkExitCode _ ExitSuccess = return ()
checkExitCode cp ec = throwM $ ProcessExitedUnsuccessfully cp ec checkExitCode cp ec = throwM $ ProcessExitedUnsuccessfully cp ec
-- FIXME move into streaming-commons? -- FIXME move into streaming-commons?
withCheckedProcess :: ( InputSource stdin
, OutputSink stderr
, OutputSink stdout
, MonadIO m
)
=> CreateProcess
-> (stdin -> stdout -> stderr -> m b)
-> m b
withCheckedProcess cp f = do withCheckedProcess cp f = do
(x, y, z, sph) <- streamingProcess cp (x, y, z, sph) <- streamingProcess cp
res <- f x y z res <- f x y z
ec <- waitForStreamingProcess sph ec <- waitForStreamingProcess sph
checkExitCode cp ec liftIO $ checkExitCode cp ec
return res return res
newtype Maintainer = Maintainer { unMaintainer :: Text } newtype Maintainer = Maintainer { unMaintainer :: Text }

14
Stackage2/UpdateBuildPlan.hs
View File

@ -1,6 +1,6 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
-- | Take an existing build plan and bump all packages to the newest version in -- | Take an existing build plan and bump all packages to the newest version in
-- the same major version number. -- the same major version number.
module Stackage2.UpdateBuildPlan module Stackage2.UpdateBuildPlan
@ -8,12 +8,12 @@ module Stackage2.UpdateBuildPlan
, updateBuildPlan , updateBuildPlan
) where ) where
import Stackage2.Prelude import qualified Data.Map as Map
import Stackage2.BuildPlan import Distribution.Version (anyVersion, earlierVersion,
import Stackage2.BuildConstraints orLaterVersion)
import Stackage2.PackageDescription import Stackage2.BuildConstraints
import Distribution.Version (orLaterVersion, earlierVersion, anyVersion) import Stackage2.BuildPlan
import qualified Data.Map as Map import Stackage2.Prelude
updateBuildPlan :: BuildPlan -> IO BuildPlan updateBuildPlan :: BuildPlan -> IO BuildPlan
updateBuildPlan = newBuildPlan . updateBuildConstraints updateBuildPlan = newBuildPlan . updateBuildConstraints

1
test/Stackage2/BuildPlanSpec.hs
View File

@ -7,7 +7,6 @@ import Stackage2.BuildConstraints
import Stackage2.UpdateBuildPlan import Stackage2.UpdateBuildPlan
import Test.Hspec import Test.Hspec
import qualified Data.Yaml as Y import qualified Data.Yaml as Y
import Control.Exception (evaluate)
import Distribution.Version (anyVersion) import Distribution.Version (anyVersion)
import qualified Data.Map as Map import qualified Data.Map as Map

2
test/Stackage2/PackageIndexSpec.hs
View File

@ -4,7 +4,7 @@ module Stackage2.PackageIndexSpec (spec) where
import Stackage2.PackageIndex import Stackage2.PackageIndex
import Stackage2.Prelude import Stackage2.Prelude
import Test.Hspec import Test.Hspec
import Distribution.Package (packageId, pkgVersion) import Distribution.Package (packageId)
spec :: Spec spec :: Spec
spec = do spec = do