Commit 46aa019e authored by Duncan Coutts's avatar Duncan Coutts

Add Binary instances for many types

So we can use them in binary cache files.

Also relax version constraints on binary to work with binary-0.5.*,
which requires that we expose Distribution.Compat.Binary from Cabal.

D.Compat.Binary provides the Gerics support that we need to be able to
derive instances when using binary-0.5. It's useful to be able to use
binary-0.5 since that's the version bundled with older ghc versions.
parent 500ccce7
......@@ -268,9 +268,9 @@ library
Distribution.Verbosity
Distribution.Version
Language.Haskell.Extension
Distribution.Compat.Binary
other-modules:
Distribution.Compat.Binary
Distribution.Compat.CopyFile
Distribution.Compat.Semigroup
Distribution.GetOpt
......
{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.BuildReports.Types
......@@ -24,9 +25,14 @@ import qualified Text.PrettyPrint as Disp
import Data.Char as Char
( isAlpha, toLower )
import GHC.Generics (Generic)
import Distribution.Compat.Binary (Binary)
data ReportLevel = NoReports | AnonymousReports | DetailedReports
deriving (Eq, Ord, Show)
deriving (Eq, Ord, Enum, Show, Generic)
instance Binary ReportLevel
instance Text.Text ReportLevel where
disp NoReports = Disp.text "none"
......
......@@ -10,6 +10,7 @@
-- > import qualified Distribution.Client.ComponentDeps as CD
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
module Distribution.Client.ComponentDeps (
-- * Fine-grained package dependencies
Component(..)
......@@ -34,6 +35,8 @@ module Distribution.Client.ComponentDeps (
import Data.Map (Map)
import qualified Data.Map as Map
import Distribution.Compat.Binary (Binary)
import GHC.Generics
import Data.Foldable (fold)
#if !MIN_VERSION_base(4,8,0)
......@@ -53,14 +56,16 @@ data Component =
| ComponentTest String
| ComponentBench String
| ComponentSetup
deriving (Show, Eq, Ord)
deriving (Show, Eq, Ord, Generic)
instance Binary Component
-- | Dependency for a single component
type ComponentDep a = (Component, a)
-- | Fine-grained dependencies for a package
newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a }
deriving (Show, Functor, Eq, Ord)
deriving (Show, Functor, Eq, Ord, Generic)
instance Monoid a => Monoid (ComponentDeps a) where
mempty =
......@@ -74,6 +79,8 @@ instance Foldable ComponentDeps where
instance Traversable ComponentDeps where
traverse f = fmap ComponentDeps . traverse f . unComponentDeps
instance Binary a => Binary (ComponentDeps a)
{-------------------------------------------------------------------------------
Construction
-------------------------------------------------------------------------------}
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Dependency.Types
......@@ -74,17 +75,22 @@ import Distribution.Text
import Text.PrettyPrint
( text )
import GHC.Generics (Generic)
import Distribution.Compat.Binary (Binary(..))
import Prelude hiding (fail)
-- | All the solvers that can be selected.
data PreSolver = AlwaysTopDown | AlwaysModular | Choose
deriving (Eq, Ord, Show, Bounded, Enum)
deriving (Eq, Ord, Show, Bounded, Enum, Generic)
-- | All the solvers that can be used.
data Solver = TopDown | Modular
deriving (Eq, Ord, Show, Bounded, Enum)
deriving (Eq, Ord, Show, Bounded, Enum, Generic)
instance Binary PreSolver
instance Binary Solver
instance Text PreSolver where
disp AlwaysTopDown = text "topdown"
......@@ -134,7 +140,9 @@ data PackageConstraint
| PackageConstraintSource PackageName
| PackageConstraintFlags PackageName FlagAssignment
| PackageConstraintStanzas PackageName [OptionalStanza]
deriving (Show,Eq)
deriving (Eq,Show,Generic)
instance Binary PackageConstraint
-- | Provide a textual representation of a package constraint
-- for debugging purposes.
......@@ -216,6 +224,9 @@ data AllowNewer =
-- | Ignore upper bounds in dependencies on all packages.
| AllowNewerAll
deriving (Eq, Ord, Show, Generic)
instance Binary AllowNewer
-- | Convert 'AllowNewer' to a boolean.
isAllowNewer :: AllowNewer -> Bool
......@@ -300,7 +311,9 @@ data ConstraintSource =
-- | The source of the constraint is not specified.
| ConstraintSourceUnknown
deriving (Eq, Show)
deriving (Eq, Show, Generic)
instance Binary ConstraintSource
-- | Description of a 'ConstraintSource'.
showConstraintSource :: ConstraintSource -> String
......
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.InstallPlan
......@@ -76,6 +77,8 @@ import Data.Maybe
import qualified Data.Graph as Graph
import Data.Graph (Graph)
import qualified Data.Tree as Tree
import Distribution.Compat.Binary (Binary)
import GHC.Generics
import Control.Exception
( assert )
import Data.Maybe (catMaybes)
......@@ -142,6 +145,10 @@ data GenericPlanPackage ipkg srcpkg iresult ifailure
| Processing (GenericReadyPackage srcpkg ipkg)
| Installed (GenericReadyPackage srcpkg ipkg) (Maybe ipkg) iresult
| Failed srcpkg ifailure
deriving (Eq, Show, Generic)
instance (Binary ipkg, Binary srcpkg, Binary iresult, Binary ifailure)
=> Binary (GenericPlanPackage ipkg srcpkg iresult ifailure)
type PlanPackage = GenericPlanPackage
InstalledPackageInfo ConfiguredPackage
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.PackageIndex
......@@ -54,6 +55,8 @@ import Data.List (groupBy, sortBy, isInfixOf)
import Data.Monoid (Monoid(..))
#endif
import Data.Maybe (isJust, fromMaybe)
import GHC.Generics (Generic)
import Distribution.Compat.Binary (Binary)
import Distribution.Package
( PackageName(..), PackageIdentifier(..)
......@@ -78,7 +81,8 @@ newtype PackageIndex pkg = PackageIndex
--
(Map PackageName [pkg])
deriving (Show, Read, Functor)
deriving (Eq, Show, Read, Functor, Generic)
--FIXME: the Functor instance here relies on no package id changes
instance Package pkg => Monoid (PackageIndex pkg) where
mempty = PackageIndex Map.empty
......@@ -87,6 +91,8 @@ instance Package pkg => Monoid (PackageIndex pkg) where
mconcat [] = mempty
mconcat xs = foldr1 mappend xs
instance Binary pkg => Binary (PackageIndex pkg)
invariant :: Package pkg => PackageIndex pkg -> Bool
invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m)
where
......
......@@ -2,6 +2,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Setup
......@@ -113,6 +114,8 @@ import Data.Maybe
import Data.Monoid
( Monoid(..) )
#endif
import GHC.Generics (Generic)
import Distribution.Compat.Binary (Binary)
import Control.Monad
( liftM )
import System.FilePath
......@@ -411,6 +414,7 @@ data ConfigExFlags = ConfigExFlags {
configSolver :: Flag PreSolver,
configAllowNewer :: Flag AllowNewer
}
deriving (Eq, Generic)
defaultConfigExFlags :: ConfigExFlags
defaultConfigExFlags = mempty { configSolver = Flag defaultSolver
......@@ -1178,6 +1182,9 @@ data InstallFlags = InstallFlags {
installRunTests :: Flag Bool,
installOfflineMode :: Flag Bool
}
deriving (Eq, Generic)
instance Binary InstallFlags
defaultInstallFlags :: InstallFlags
defaultInstallFlags = InstallFlags {
......
{-# LANGUAGE CPP, BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Targets
......@@ -109,6 +111,8 @@ import System.Directory
( doesFileExist, doesDirectoryExist )
import Network.URI
( URI(..), URIAuth(..), parseAbsoluteURI )
import GHC.Generics (Generic)
import Distribution.Compat.Binary (Binary)
-- ------------------------------------------------------------
-- * User targets
......@@ -185,7 +189,9 @@ data PackageSpecifier pkg =
-- | A fully specified source package.
--
| SpecificSourcePackage pkg
deriving Show
deriving (Eq, Show, Generic)
instance Binary pkg => Binary (PackageSpecifier pkg)
pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName
pkgSpecifierTarget (NamedPackage name _) = name
......@@ -698,7 +704,9 @@ data UserConstraint =
| UserConstraintSource PackageName
| UserConstraintFlags PackageName FlagAssignment
| UserConstraintStanzas PackageName [OptionalStanza]
deriving (Show,Eq)
deriving (Eq, Show, Generic)
instance Binary UserConstraint
userConstraintPackageName :: UserConstraint -> PackageName
userConstraintPackageName uc = case uc of
......
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Client.Types
......@@ -36,10 +39,13 @@ import Distribution.Version
import Distribution.Text (display)
import Data.Map (Map)
import Network.URI (URI, nullURI)
import Network.URI (URI(..), URIAuth(..), nullURI)
import Data.ByteString.Lazy (ByteString)
import Control.Exception
( SomeException )
import GHC.Generics (Generic)
import Distribution.Compat.Binary (Binary(..))
newtype Username = Username { unUsername :: String }
newtype Password = Password { unPassword :: String }
......@@ -50,6 +56,9 @@ data SourcePackageDb = SourcePackageDb {
packageIndex :: PackageIndex SourcePackage,
packagePreferences :: Map PackageName VersionRange
}
deriving (Eq, Generic)
instance Binary SourcePackageDb
-- ------------------------------------------------------------
-- * Various kinds of information about packages
......@@ -95,7 +104,9 @@ data ConfiguredPackage = ConfiguredPackage
-- These must be consistent with the 'buildDepends'
-- in the 'PackageDescription' that you'd get by
-- applying the flag assignment and optional stanzas.
deriving Show
deriving (Eq, Show, Generic)
instance Binary ConfiguredPackage
-- | A ConfiguredId is a package ID for a configured package.
--
......@@ -113,6 +124,9 @@ data ConfiguredId = ConfiguredId {
confSrcId :: PackageId
, confInstId :: UnitId
}
deriving (Eq, Generic)
instance Binary ConfiguredId
instance Show ConfiguredId where
show = show . confSrcId
......@@ -132,7 +146,7 @@ data GenericReadyPackage srcpkg ipkg
= ReadyPackage
srcpkg -- see 'ConfiguredPackage'.
(ComponentDeps [ipkg]) -- Installed dependencies.
deriving (Eq, Show)
deriving (Eq, Show, Generic)
type ReadyPackage = GenericReadyPackage ConfiguredPackage InstalledPackageInfo
......@@ -147,6 +161,8 @@ instance HasUnitId srcpkg =>
HasUnitId (GenericReadyPackage srcpkg ipkg) where
installedUnitId (ReadyPackage pkg _) = installedUnitId pkg
instance (Binary srcpkg, Binary ipkg) => Binary (GenericReadyPackage srcpkg ipkg)
-- | A package description along with the location of the package sources.
--
......@@ -156,7 +172,9 @@ data SourcePackage = SourcePackage {
packageSource :: PackageLocation (Maybe FilePath),
packageDescrOverride :: PackageDescriptionOverride
}
deriving Show
deriving (Eq, Show, Generic)
instance Binary SourcePackage
-- | We sometimes need to override the .cabal file in the tarball with
-- the newer one from the package index.
......@@ -167,7 +185,9 @@ instance Package SourcePackage where packageId = packageInfoId
data OptionalStanza
= TestStanzas
| BenchStanzas
deriving (Eq, Ord, Show)
deriving (Eq, Ord, Enum, Bounded, Show, Generic)
instance Binary OptionalStanza
enableStanzas
:: [OptionalStanza]
......@@ -207,7 +227,20 @@ data PackageLocation local =
--TODO:
-- * add support for darcs and other SCM style remote repos with a local cache
-- | ScmPackage
deriving (Show, Functor)
deriving (Show, Functor, Eq, Ord, Generic)
instance Binary local => Binary (PackageLocation local)
-- note, network-uri-2.6.0.3+ provide a Generic instance but earlier
-- versions do not, so we use manual Binary instances here
instance Binary URI where
put (URI a b c d e) = do put a; put b; put c; put d; put e
get = do !a <- get; !b <- get; !c <- get; !d <- get; !e <- get
return (URI a b c d e)
instance Binary URIAuth where
put (URIAuth a b c) = do put a; put b; put c
get = do !a <- get; !b <- get; !c <- get; return (URIAuth a b c)
data RemoteRepo =
RemoteRepo {
......@@ -237,7 +270,9 @@ data RemoteRepo =
remoteRepoShouldTryHttps :: Bool
}
deriving (Show,Eq,Ord)
deriving (Show, Eq, Ord, Generic)
instance Binary RemoteRepo
-- | Construct a partial 'RemoteRepo' value to fold the field parser list over.
emptyRemoteRepo :: String -> RemoteRepo
......@@ -270,7 +305,9 @@ data Repo =
repoRemote :: RemoteRepo
, repoLocalDir :: FilePath
}
deriving (Show, Eq, Ord)
deriving (Show, Eq, Ord, Generic)
instance Binary Repo
-- | Check if this is a remote repo
maybeRepoRemote :: Repo -> Maybe RemoteRepo
......@@ -291,8 +328,22 @@ data BuildFailure = PlanningFailed
| BuildFailed SomeException
| TestsFailed SomeException
| InstallFailed SomeException
deriving (Show, Generic)
data BuildSuccess = BuildOk DocsResult TestsResult
(Maybe InstalledPackageInfo)
deriving (Show, Generic)
data DocsResult = DocsNotTried | DocsFailed | DocsOk
deriving (Show, Generic)
data TestsResult = TestsNotTried | TestsOk
deriving (Show, Generic)
instance Binary BuildFailure
instance Binary BuildSuccess
instance Binary DocsResult
instance Binary TestsResult
--FIXME: this is a total cheat
instance Binary SomeException where
put _ = return ()
get = fail "cannot serialise exceptions"
......@@ -164,6 +164,7 @@ executable cabal
build-depends:
array >= 0.4 && < 0.6,
base >= 4.5 && < 5,
binary >= 0.5 && < 0.9,
bytestring >= 0.9 && < 1,
Cabal >= 1.23.1 && < 1.24,
containers >= 0.4 && < 0.6,
......@@ -193,6 +194,10 @@ executable cabal
else
build-depends: network >= 2.4 && < 2.6
-- Needed for GHC.Generics before GHC 7.6
if impl(ghc < 7.6)
build-depends: ghc-prim >= 0.2 && < 0.3
if os(windows)
build-depends: Win32 >= 2 && < 3
cpp-options: -DWIN32
......@@ -239,6 +244,7 @@ Test-Suite unit-tests
time,
HTTP,
zlib,
binary,
random,
hackage-security,
tasty,
......@@ -255,6 +261,9 @@ Test-Suite unit-tests
else
build-depends: network-uri < 2.6, network < 2.6
if impl(ghc < 7.6)
build-depends: ghc-prim >= 0.2 && < 0.3
if os(windows)
build-depends: Win32
cpp-options: -DWIN32
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment