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.

Author: phadej

Cabal/Cabal.cabal

@@ -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,

Cabal/Distribution/Backpack.hs

@@ -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

Cabal/Distribution/Backpack/ModuleShape.hs

@@ -1,3 +1,4 @@
+{-# 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)

Cabal/Distribution/Compat/Graph.hs

@@ -1,9 +1,10 @@
-{-# 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
 

Cabal/Distribution/Compat/Prelude.hs

@@ -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
 

Cabal/Distribution/Compat/Semigroup.hs

@@ -1,4 +1,5 @@
 {-# 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))

Cabal/Distribution/Compat/Time.hs

@@ -1,4 +1,6 @@
 {-# 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

Cabal/Distribution/Compat/Typeable.hs

@@ -0,0 +1,18 @@
+{-# 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

Cabal/Distribution/Compiler.hs

@@ -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

Cabal/Distribution/License.hs

@@ -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.

Cabal/Distribution/ModuleName.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveGeneric      #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -23,24 +23,24 @@ 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.
 --
 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

Cabal/Distribution/SPDX/License.hs

@@ -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        = ()

Cabal/Distribution/SPDX/LicenseExceptionId.hs

@@ -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
 

Cabal/Distribution/SPDX/LicenseExpression.hs

@@ -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

Cabal/Distribution/SPDX/LicenseId.hs

@@ -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
 

Cabal/Distribution/SPDX/LicenseReference.hs

@@ -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