Commit ae33fcf9 authored by Oleg Grenrus's avatar Oleg Grenrus

Add Distribution.Utils.Structured

It defines `Structured` type class, which we use to prepend
a hash to cached `Binary` blobs. Thus we can catch early, if
format is changed, avoiding corrupt cache making cabal
behave weirdly.

Plenty types got Typeable instances, as it's a superclass of Structured

This commit also introduces new compat modules:

- Distribution.Compat.Typeable with typeRep
- Distribution.Client.Compat.Orphans,
  to collect at least some orphans into central place.
parent 228260d6
......@@ -322,6 +322,7 @@ library
Distribution.Utils.IOData
Distribution.Utils.LogProgress
Distribution.Utils.MapAccum
Distribution.Utils.Structured
Distribution.Compat.CreatePipe
Distribution.Compat.Directory
Distribution.Compat.Environment
......@@ -335,6 +336,7 @@ library
Distribution.Compat.Semigroup
Distribution.Compat.Stack
Distribution.Compat.Time
Distribution.Compat.Typeable
Distribution.Compat.DList
Distribution.Compiler
Distribution.InstalledPackageInfo
......@@ -619,8 +621,10 @@ test-suite unit-tests
UnitTests.Distribution.Utils.Generic
UnitTests.Distribution.Utils.NubList
UnitTests.Distribution.Utils.ShortText
UnitTests.Distribution.Utils.Structured
UnitTests.Distribution.Version
UnitTests.Distribution.PkgconfigVersion
UnitTests.Orphans
main-is: UnitTests.hs
build-depends:
array,
......
......@@ -98,7 +98,7 @@ data OpenUnitId
-- TODO: cache holes?
instance Binary OpenUnitId
instance Structured OpenUnitId
instance NFData OpenUnitId where
rnf (IndefFullUnitId cid subst) = rnf cid `seq` rnf subst
rnf (DefiniteUnitId uid) = rnf uid
......@@ -165,6 +165,7 @@ data OpenModule
deriving (Generic, Read, Show, Eq, Ord, Typeable, Data)
instance Binary OpenModule
instance Structured OpenModule
instance NFData OpenModule where
rnf (OpenModule uid mod_name) = rnf uid `seq` rnf mod_name
......
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
-- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
module Distribution.Backpack.ModuleShape (
......@@ -29,9 +30,10 @@ data ModuleShape = ModuleShape {
modShapeProvides :: OpenModuleSubst,
modShapeRequires :: Set ModuleName
}
deriving (Eq, Show, Generic)
deriving (Eq, Show, Generic, Typeable)
instance Binary ModuleShape
instance Structured ModuleShape
instance ModSubst ModuleShape where
modSubst subst (ModuleShape provs reqs)
......
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE BangPatterns #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.Compat.Graph
......@@ -83,20 +84,21 @@ module Distribution.Compat.Graph (
nodeValue,
) where
import Distribution.Compat.Prelude hiding (empty, lookup, null, toList)
import Prelude ()
import qualified Distribution.Compat.Prelude as Prelude
import Distribution.Compat.Prelude hiding (lookup, null, empty, toList)
import Data.Graph (SCC(..))
import qualified Data.Graph as G
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Array as Array
import Data.Array ((!))
import qualified Data.Tree as Tree
import Data.Either (partitionEithers)
import qualified Data.Foldable as Foldable
import Data.Array ((!))
import Data.Either (partitionEithers)
import Data.Graph (SCC (..))
import Distribution.Utils.Structured (Structure (..), Structured (..))
import qualified Data.Array as Array
import qualified Data.Foldable as Foldable
import qualified Data.Graph as G
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Tree as Tree
import qualified Distribution.Compat.Prelude as Prelude
-- | A graph of nodes @a@. The nodes are expected to have instance
-- of class 'IsNode'.
......@@ -129,6 +131,9 @@ instance (IsNode a, Binary a, Show (Key a)) => Binary (Graph a) where
put x = put (toList x)
get = fmap fromDistinctList get
instance Structured a => Structured (Graph a) where
structure p = Nominal (typeRep p) 0 "Graph" [structure (Proxy :: Proxy a)]
instance (Eq (Key a), Eq a) => Eq (Graph a) where
g1 == g2 = graphMap g1 == graphMap g2
......
......@@ -33,11 +33,12 @@ module Distribution.Compat.Prelude (
-- * Common type-classes
Semigroup (..),
gmappend, gmempty,
Typeable,
Typeable, TypeRep, typeRep,
Data,
Generic,
NFData (..), genericRnf,
Binary (..),
Structured,
Alternative (..),
MonadPlus (..),
IsString (..),
......@@ -137,7 +138,7 @@ import qualified Data.Foldable
import Control.Applicative (Alternative (..))
import Control.DeepSeq (NFData (..))
import Data.Data (Data)
import Data.Typeable (Typeable)
import Distribution.Compat.Typeable (Typeable, TypeRep, typeRep)
import Distribution.Compat.Binary (Binary (..))
import Distribution.Compat.Semigroup (Semigroup (..), gmappend, gmempty)
import GHC.Generics (Generic, Rep(..),
......@@ -167,6 +168,8 @@ import qualified Text.PrettyPrint as Disp
import qualified Prelude as OrigPrelude
import Distribution.Compat.Stack
import Distribution.Utils.Structured (Structured)
type IO a = WithCallStack (OrigPrelude.IO a)
type NoCallStackIO a = OrigPrelude.IO a
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
......@@ -21,6 +22,8 @@ module Distribution.Compat.Semigroup
) where
import Distribution.Compat.Binary (Binary)
import Distribution.Utils.Structured (Structured)
import Data.Typeable (Typeable)
import GHC.Generics
-- Data.Semigroup is available since GHC 8.0/base-4.9 in `base`
......@@ -38,7 +41,9 @@ instance Semigroup (First' a) where
-- | A copy of 'Data.Semigroup.Last'.
newtype Last' a = Last' { getLast' :: a }
deriving (Eq, Ord, Read, Show, Binary)
deriving (Eq, Ord, Read, Show, Generic, Binary, Typeable)
instance Structured a => Structured (Last' a)
instance Semigroup (Last' a) where
_ <> b = b
......@@ -49,7 +54,9 @@ instance Functor Last' where
-- | A wrapper around 'Maybe', providing the 'Semigroup' and 'Monoid' instances
-- implemented for 'Maybe' since @base-4.11@.
newtype Option' a = Option' { getOption' :: Maybe a }
deriving (Eq, Ord, Read, Show, Binary, Functor)
deriving (Eq, Ord, Read, Show, Binary, Generic, Functor, Typeable)
instance Structured a => Structured (Option' a)
instance Semigroup a => Semigroup (Option' a) where
Option' (Just a) <> Option' (Just b) = Option' (Just (a <> b))
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
......@@ -55,7 +57,9 @@ import System.Posix.Files ( modificationTime )
-- | An opaque type representing a file's modification time, represented
-- internally as a 64-bit unsigned integer in the Windows UTC format.
newtype ModTime = ModTime Word64
deriving (Binary, Bounded, Eq, Ord)
deriving (Binary, Generic, Bounded, Eq, Ord, Typeable)
instance Structured ModTime
instance Show ModTime where
show (ModTime x) = show x
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.Compat.Typeable (
Typeable,
TypeRep,
typeRep,
) where
#if MIN_VERSION_base(4,7,0)
import Data.Typeable (Typeable, TypeRep, typeRep)
#else
import Data.Typeable (Typeable, TypeRep, typeOf)
#endif
#if !MIN_VERSION_base(4,7,0)
typeRep :: forall a proxy. Typeable a => proxy a -> TypeRep
typeRep _ = typeOf (undefined :: a)
#endif
......@@ -66,7 +66,7 @@ data CompilerFlavor =
deriving (Generic, Show, Read, Eq, Ord, Typeable, Data)
instance Binary CompilerFlavor
instance Structured CompilerFlavor
instance NFData CompilerFlavor where rnf = genericRnf
knownCompilerFlavors :: [CompilerFlavor]
......@@ -125,6 +125,7 @@ data PerCompilerFlavor v = PerCompilerFlavor v v
deriving (Generic, Show, Read, Eq, Typeable, Data)
instance Binary a => Binary (PerCompilerFlavor a)
instance Structured a => Structured (PerCompilerFlavor a)
instance NFData a => NFData (PerCompilerFlavor a)
perCompilerFlavorToList :: PerCompilerFlavor v -> [(CompilerFlavor, v)]
......@@ -143,10 +144,10 @@ instance (Semigroup a, Monoid a) => Monoid (PerCompilerFlavor a) where
-- ------------------------------------------------------------
data CompilerId = CompilerId CompilerFlavor Version
deriving (Eq, Generic, Ord, Read, Show)
deriving (Eq, Generic, Ord, Read, Show, Typeable)
instance Binary CompilerId
instance Structured CompilerId
instance NFData CompilerId where rnf = genericRnf
instance Pretty CompilerId where
......@@ -192,9 +193,10 @@ instance Binary CompilerInfo
data AbiTag
= NoAbiTag
| AbiTag String
deriving (Eq, Generic, Show, Read)
deriving (Eq, Generic, Show, Read, Typeable)
instance Binary AbiTag
instance Structured AbiTag
instance Pretty AbiTag where
pretty NoAbiTag = Disp.empty
......
......@@ -128,7 +128,7 @@ data License =
deriving (Generic, Read, Show, Eq, Typeable, Data)
instance Binary License
instance Structured License
instance NFData License where rnf = genericRnf
-- | The list of all currently recognised licenses.
......
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveGeneric #-}
-----------------------------------------------------------------------------
-- |
......@@ -23,17 +23,16 @@ module Distribution.ModuleName (
validModuleComponent,
) where
import Prelude ()
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.Utils.ShortText
import System.FilePath ( pathSeparator )
import Distribution.Pretty
import Distribution.Parsec
import Distribution.Pretty
import Distribution.Utils.ShortText
import System.FilePath (pathSeparator)
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint as Disp
import qualified Text.PrettyPrint as Disp
-- | A valid Haskell module name.
--
......@@ -41,6 +40,7 @@ newtype ModuleName = ModuleName ShortTextLst
deriving (Eq, Generic, Ord, Read, Show, Typeable, Data)
instance Binary ModuleName
instance Structured ModuleName
instance NFData ModuleName where
rnf (ModuleName ms) = rnf ms
......@@ -131,6 +131,8 @@ instance Binary ShortTextLst where
put = put . stlToList
get = stlFromList <$> get
instance Structured ShortTextLst
stlToList :: ShortTextLst -> [ShortText]
stlToList STLNil = []
stlToList (STLCons st next) = st : stlToList next
......
......@@ -44,6 +44,7 @@ data License
deriving (Show, Read, Eq, Ord, Typeable, Data, Generic)
instance Binary License
instance Structured License
instance NFData License where
rnf NONE = ()
......
......@@ -12,9 +12,11 @@ module Distribution.SPDX.LicenseExceptionId (
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.Compat.Lens (set)
import Distribution.Pretty
import Distribution.Parsec
import Distribution.Utils.Generic (isAsciiAlphaNum)
import Distribution.Utils.Structured (Structured (..), nominalStructure, typeVersion)
import Distribution.SPDX.LicenseListVersion
import qualified Data.Binary.Get as Binary
......@@ -75,6 +77,10 @@ instance Binary LicenseExceptionId where
then fail "Too large LicenseExceptionId tag"
else return (toEnum (fromIntegral i))
-- note: remember to bump version each time the definition changes
instance Structured LicenseExceptionId where
structure p = set typeVersion 306 $ nominalStructure p
instance Pretty LicenseExceptionId where
pretty = Disp.text . licenseExceptionId
......
......@@ -60,6 +60,8 @@ simpleLicenseExpression i = ELicense (ELicenseId i) Nothing
instance Binary LicenseExpression
instance Binary SimpleLicenseExpression
instance Structured SimpleLicenseExpression
instance Structured LicenseExpression
instance Pretty LicenseExpression where
pretty = go 0
......
......@@ -15,9 +15,11 @@ module Distribution.SPDX.LicenseId (
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.Compat.Lens (set)
import Distribution.Pretty
import Distribution.Parsec
import Distribution.Utils.Generic (isAsciiAlphaNum)
import Distribution.Utils.Structured (Structured (..), nominalStructure, typeVersion)
import Distribution.SPDX.LicenseListVersion
import qualified Data.Binary.Get as Binary
......@@ -413,6 +415,10 @@ instance Binary LicenseId where
then fail "Too large LicenseId tag"
else return (toEnum (fromIntegral i))
-- note: remember to bump version each time the definition changes
instance Structured LicenseId where
structure p = set typeVersion 306 $ nominalStructure p
instance Pretty LicenseId where
pretty = Disp.text . licenseId
......
......@@ -34,6 +34,7 @@ licenseDocumentRef :: LicenseRef -> Maybe String
licenseDocumentRef = _lrDocument
instance Binary LicenseRef
instance Structured LicenseRef
instance NFData LicenseRef where
rnf (LicenseRef d l) = rnf d `seq` rnf l
......
......@@ -104,6 +104,7 @@ data Compiler = Compiler {
deriving (Eq, Generic, Typeable, Show, Read)
instance Binary Compiler
instance Structured Compiler
showCompilerId :: Compiler -> String
showCompilerId = prettyShow . compilerId
......@@ -172,9 +173,10 @@ compilerInfo c = CompilerInfo (compilerId c)
data PackageDB = GlobalPackageDB
| UserPackageDB
| SpecificPackageDB FilePath
deriving (Eq, Generic, Ord, Show, Read)
deriving (Eq, Generic, Ord, Show, Read, Typeable)
instance Binary PackageDB
instance Structured PackageDB
-- | We typically get packages from several databases, and stack them
-- together. This type lets us be explicit about that stacking. For example
......@@ -225,9 +227,10 @@ absolutePackageDBPath (SpecificPackageDB db) =
data OptimisationLevel = NoOptimisation
| NormalOptimisation
| MaximumOptimisation
deriving (Bounded, Enum, Eq, Generic, Read, Show)
deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable)
instance Binary OptimisationLevel
instance Structured OptimisationLevel
flagToOptimisationLevel :: Maybe String -> OptimisationLevel
flagToOptimisationLevel Nothing = NormalOptimisation
......@@ -252,9 +255,10 @@ data DebugInfoLevel = NoDebugInfo
| MinimalDebugInfo
| NormalDebugInfo
| MaximalDebugInfo
deriving (Bounded, Enum, Eq, Generic, Read, Show)
deriving (Bounded, Enum, Eq, Generic, Read, Show, Typeable)
instance Binary DebugInfoLevel
instance Structured DebugInfoLevel
flagToDebugInfoLevel :: Maybe String -> DebugInfoLevel
flagToDebugInfoLevel Nothing = NormalDebugInfo
......@@ -407,9 +411,10 @@ data ProfDetailLevel = ProfDetailNone
| ProfDetailToplevelFunctions
| ProfDetailAllFunctions
| ProfDetailOther String
deriving (Eq, Generic, Read, Show)
deriving (Eq, Generic, Read, Show, Typeable)
instance Binary ProfDetailLevel
instance Structured ProfDetailLevel
flagToProfDetailLevel :: String -> ProfDetailLevel
flagToProfDetailLevel "" = ProfDetailDefault
......
......@@ -114,7 +114,7 @@ import Control.Exception
( ErrorCall, Exception, evaluate, throw, throwIO, try )
import Control.Monad ( forM, forM_ )
import Data.List.NonEmpty ( nonEmpty )
import Distribution.Compat.Binary ( decodeOrFailIO, encode )
import Distribution.Utils.Structured ( structuredDecodeOrFailIO, structuredEncode )
import Distribution.Compat.Directory ( listDirectory )
import Data.ByteString.Lazy ( ByteString )
import qualified Data.ByteString as BS
......@@ -212,7 +212,7 @@ getConfigStateFile filename = do
Right x -> x
let getStoredValue = do
result <- decodeOrFailIO (BLC8.tail body)
result <- structuredDecodeOrFailIO (BLC8.tail body)
case result of
Left _ -> throw ConfigStateFileNoParse
Right x -> return x
......@@ -257,7 +257,7 @@ writePersistBuildConfig :: FilePath -- ^ The @dist@ directory path.
writePersistBuildConfig distPref lbi = do
createDirectoryIfMissing False distPref
writeFileAtomic (localBuildInfoFile distPref) $
BLC8.unlines [showHeader pkgId, encode lbi]
BLC8.unlines [showHeader pkgId, structuredEncode lbi]
where
pkgId = localPackage lbi
......
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
......@@ -51,9 +52,10 @@ import Distribution.Compat.Stack
-- Its monoid instance gives us the behaviour where it starts out as
-- 'NoFlag' and later flags override earlier ones.
--
data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read)
data Flag a = Flag a | NoFlag deriving (Eq, Generic, Show, Read, Typeable)
instance Binary a => Binary (Flag a)
instance Structured a => Structured (Flag a)
instance Functor Flag where
fmap f (Flag x) = Flag (f x)
......
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
......@@ -98,9 +99,10 @@ data InstallDirs dir = InstallDirs {
htmldir :: dir,
haddockdir :: dir,
sysconfdir :: dir
} deriving (Eq, Read, Show, Functor, Generic)
} deriving (Eq, Read, Show, Functor, Generic, Typeable)
instance Binary dir => Binary (InstallDirs dir)
instance Structured dir => Structured (InstallDirs dir)
instance (Semigroup dir, Monoid dir) => Monoid (InstallDirs dir) where
mempty = gmempty
......@@ -352,9 +354,10 @@ prefixRelativeInstallDirs pkgId libname compilerId platform dirs =
-- substituted for to get a real 'FilePath'.
--
newtype PathTemplate = PathTemplate [PathComponent]
deriving (Eq, Ord, Generic)
deriving (Eq, Ord, Generic, Typeable)
instance Binary PathTemplate
instance Structured PathTemplate
type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)]
......
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
module Distribution.Simple.InstallDirs.Internal
( PathComponent(..)
......@@ -10,9 +11,10 @@ import Distribution.Compat.Prelude
data PathComponent =
Ordinary FilePath
| Variable PathTemplateVariable
deriving (Eq, Ord, Generic)
deriving (Eq, Ord, Generic, Typeable)
instance Binary PathComponent
instance Structured PathComponent
data PathTemplateVariable =
PrefixVar -- ^ The @$prefix@ path variable
......@@ -39,9 +41,10 @@ data PathTemplateVariable =
| TestSuiteResultVar -- ^ The result of the test suite being run, eg
-- @pass@, @fail@, or @error@.
| BenchmarkNameVar -- ^ The name of the benchmark being run
deriving (Eq, Ord, Generic)
deriving (Eq, Ord, Generic, Typeable)
instance Binary PathTemplateVariable
instance Structured PathTemplateVariable
instance Show PathTemplateVariable where
show PrefixVar = "prefix"
......
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
......@@ -144,9 +145,10 @@ data PackageIndex a = PackageIndex {
-- preserved. See #1463 for discussion.
packageIdIndex :: !(Map (PackageName, LibraryName) (Map Version [a]))
} deriving (Eq, Generic, Show, Read)
} deriving (Eq, Generic, Show, Read, Typeable)
instance Binary a => Binary (PackageIndex a)
instance Structured a => Structured (PackageIndex a)
-- | The default package index which contains 'InstalledPackageInfo'. Normally
-- use this.
......
</
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
-----------------------------------------------------------------------------
-- |
......@@ -61,19 +61,21 @@ module Distribution.Simple.Program.Db (
) where
import Prelude ()
import Distribution.Compat.Prelude
import Prelude ()
import Distribution.Simple.Program.Types
import Distribution.Simple.Program.Find
import Distribution.Pretty
import Distribution.Simple.Program.Builtin
import Distribution.Simple.Program.Find
import Distribution.Simple.Program.Types
import Distribution.Simple.Utils
import Distribution.Version
import Distribution.Pretty
import Distribution.Utils.Structured (Structure (..), Structured (..))
import Distribution.Verbosity
import Distribution.Version