Cabal-syntax/src/Distribution/Utils/Structured.hs

   1 {-# LANGUAGE CPP #-}
   2 {-# LANGUAGE DefaultSignatures #-}
   3 {-# LANGUAGE DeriveGeneric #-}
   4 {-# LANGUAGE FlexibleContexts #-}
   5 {-# LANGUAGE PolyKinds #-}
   6 {-# LANGUAGE ScopedTypeVariables #-}
   7 {-# LANGUAGE TypeApplications #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9 {-# LANGUAGE TypeOperators #-}
  10
  11 -- |
  12 --
  13 -- Copyright: (c) 2019 Oleg Grenrus
  14 --
  15 -- Structurally tag binary serialisation stream.
  16 -- Useful when most 'Binary' instances are 'Generic' derived.
  17 --
  18 -- Say you have a data type
  19 --
  20 -- @
  21 -- data Record = Record
  22 --   { _recordFields  :: HM.HashMap Text (Integer, ByteString)
  23 --   , _recordEnabled :: Bool
  24 --   }
  25 --   deriving (Eq, Show, Generic)
  26 --
  27 -- instance 'Binary' Record
  28 -- instance 'Structured' Record
  29 -- @
  30 --
  31 -- then you can serialise and deserialise @Record@ values with a structure tag by simply
  32 --
  33 -- @
  34 -- 'structuredEncode' record :: 'LBS.ByteString'
  35 -- 'structuredDecode' lbs :: IO Record
  36 -- @
  37 --
  38 -- If structure of @Record@ changes in between, deserialisation will fail early.
  39 --
  40 -- Technically, 'Structured' is not related to 'Binary', and may
  41 -- be useful in other uses.
  42 module Distribution.Utils.Structured
  43   ( -- * Encoding and decoding
  44
  45     -- | These functions operate like @binary@'s counterparts,
  46     -- but the serialised version has a structure hash in front.
  47     structuredEncode
  48   , structuredEncodeFile
  49   , structuredDecode
  50   , structuredDecodeOrFailIO
  51   , structuredDecodeFileOrFail
  52
  53     -- * Structured class
  54   , Structured (structure)
  55   , MD5
  56   , structureHash
  57   , structureBuilder
  58   , genericStructure
  59   , GStructured
  60   , nominalStructure
  61   , containerStructure
  62
  63     -- * Structure type
  64   , Structure (..)
  65   , Tag (..)
  66   , TypeName
  67   , ConstructorName
  68   , TypeVersion
  69   , SopStructure
  70   , hashStructure
  71   , typeVersion
  72   , typeName
  73   ) where
  74
  75 import Data.Int (Int16, Int32, Int64, Int8)
  76 import Data.List.NonEmpty (NonEmpty)
  77 import Data.Proxy (Proxy (..))
  78 import Data.Ratio (Ratio)
  79 import Data.Word (Word, Word16, Word32, Word64, Word8)
  80
  81 import qualified Control.Monad.Trans.State.Strict as State
  82
  83 import Control.Exception (ErrorCall (..), catch, evaluate)
  84
  85 import GHC.Generics
  86
  87 import qualified Data.ByteString as BS
  88 import qualified Data.ByteString.Lazy as LBS
  89 #if MIN_VERSION_bytestring(0,10,4)
  90 import qualified Data.ByteString.Builder      as Builder
  91 #else
  92 import qualified Data.ByteString.Lazy.Builder as Builder
  93 #endif
  94 import qualified Data.IntMap as IM
  95 import qualified Data.IntSet as IS
  96 import qualified Data.Map as Map
  97 import qualified Data.Sequence as Seq
  98 import qualified Data.Set as Set
  99 import qualified Data.Text as T
 100 import qualified Data.Text.Lazy as LT
 101 import qualified Data.Time as Time
 102 import qualified Distribution.Compat.Binary as Binary
 103
 104 #ifdef MIN_VERSION_aeson
 105 import qualified Data.Aeson as Aeson
 106 #endif
 107
 108 import Data.Kind (Type)
 109 import Data.Typeable (TypeRep, Typeable, typeRep)
 110
 111 import Distribution.Utils.MD5
 112
 113 import Data.Monoid (mconcat)
 114
 115 import qualified Data.Foldable
 116 import qualified Data.Semigroup
 117
 118 -------------------------------------------------------------------------------
 119 -- Types
 120 -------------------------------------------------------------------------------
 121
 122 type TypeName = String
 123 type ConstructorName = String
 124
 125 -- | A semantic version of a data type. Usually 0.
 126 type TypeVersion = Word32
 127
 128 -- | Structure of a datatype.
 129 --
 130 -- It can be infinite, as far as 'TypeRep's involved are finite.
 131 -- (e.g. polymorphic recursion might cause troubles).
 132 data Structure
 133   = -- | nominal, yet can be parametrised by other structures.
 134     Nominal !TypeRep !TypeVersion TypeName [Structure]
 135   | -- | a newtype wrapper
 136     Newtype !TypeRep !TypeVersion TypeName Structure
 137   | -- | sum-of-products structure
 138     Structure !TypeRep !TypeVersion TypeName SopStructure
 139   deriving (Eq, Ord, Show, Generic)
 140
 141 type SopStructure = [(ConstructorName, [Structure])]
 142
 143 -- | A MD5 hash digest of 'Structure'.
 144 hashStructure :: Structure -> MD5
 145 hashStructure = md5 . LBS.toStrict . Builder.toLazyByteString . structureBuilder
 146
 147 -- | A van-Laarhoven lens into 'TypeVersion' of 'Structure'
 148 --
 149 -- @
 150 -- 'typeVersion' :: Lens' 'Structure' 'TypeVersion'
 151 -- @
 152 typeVersion :: Functor f => (TypeVersion -> f TypeVersion) -> Structure -> f Structure
 153 typeVersion f (Nominal t v n s) = fmap (\v' -> Nominal t v' n s) (f v)
 154 typeVersion f (Newtype t v n s) = fmap (\v' -> Newtype t v' n s) (f v)
 155 typeVersion f (Structure t v n s) = fmap (\v' -> Structure t v' n s) (f v)
 156
 157 -- | A van-Laarhoven lens into 'TypeName' of 'Structure'
 158 --
 159 -- @
 160 -- 'typeName' :: Lens' 'Structure' 'TypeName'
 161 -- @
 162 typeName :: Functor f => (TypeName -> f TypeName) -> Structure -> f Structure
 163 typeName f (Nominal t v n s) = fmap (\n' -> Nominal t v n' s) (f n)
 164 typeName f (Newtype t v n s) = fmap (\n' -> Newtype t v n' s) (f n)
 165 typeName f (Structure t v n s) = fmap (\n' -> Structure t v n' s) (f n)
 166
 167 -------------------------------------------------------------------------------
 168 -- Builder
 169 -------------------------------------------------------------------------------
 170
 171 -- | Flatten 'Structure' into something we can calculate hash of.
 172 --
 173 -- As 'Structure' can be potentially infinite. For mutually recursive types,
 174 -- we keep track of 'TypeRep's, and put just 'TypeRep' name when it's occurred
 175 -- another time.
 176 structureBuilder :: Structure -> Builder.Builder
 177 structureBuilder s0 = State.evalState (go s0) Map.empty
 178   where
 179     go :: Structure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder
 180     go (Nominal t v n s) = withTypeRep t $ do
 181       s' <- traverse go s
 182       return $ mconcat $ Builder.word8 1 : Builder.word32LE v : Builder.stringUtf8 n : s'
 183     go (Newtype t v n s) = withTypeRep t $ do
 184       s' <- go s
 185       return $ mconcat [Builder.word8 2, Builder.word32LE v, Builder.stringUtf8 n, s']
 186     go (Structure t v n s) = withTypeRep t $ do
 187       s' <- goSop s
 188       return $ mconcat [Builder.word8 3, Builder.word32LE v, Builder.stringUtf8 n, s']
 189
 190     withTypeRep t k = do
 191       acc <- State.get
 192       case insert t acc of
 193         Nothing -> return $ mconcat [Builder.word8 0, Builder.stringUtf8 (show t)]
 194         Just acc' -> do
 195           State.put acc'
 196           k
 197
 198     goSop :: SopStructure -> State.State (Map.Map String (NonEmpty TypeRep)) Builder.Builder
 199     goSop sop = do
 200       parts <- traverse part sop
 201       return $ mconcat parts
 202
 203     part (cn, s) = do
 204       s' <- traverse go s
 205       return $ Data.Monoid.mconcat [Builder.stringUtf8 cn, mconcat s']
 206
 207     insert :: TypeRep -> Map.Map String (NonEmpty TypeRep) -> Maybe (Map.Map String (NonEmpty TypeRep))
 208     insert tr m = case Map.lookup trShown m of
 209       Nothing -> inserted
 210       Just ne
 211         | tr `Data.Foldable.elem` ne -> Nothing
 212         | otherwise -> inserted
 213       where
 214         inserted = Just (Map.insertWith (Data.Semigroup.<>) trShown (pure tr) m)
 215         trShown = show tr
 216
 217 -------------------------------------------------------------------------------
 218 -- Classes
 219 -------------------------------------------------------------------------------
 220
 221 -- | Class of types with a known 'Structure'.
 222 --
 223 -- For regular data types 'Structured' can be derived generically.
 224 --
 225 -- @
 226 -- data Record = Record { a :: Int, b :: Bool, c :: [Char] } deriving ('Generic')
 227 -- instance 'Structured' Record
 228 -- @
 229 --
 230 -- @since 3.2.0.0
 231 class Typeable a => Structured a where
 232   structure :: Proxy a -> Structure
 233   default structure :: (Generic a, GStructured (Rep a)) => Proxy a -> Structure
 234   structure = genericStructure
 235
 236   -- This member is hidden. It's there to precalc
 237   structureHash' :: Tagged a MD5
 238   structureHash' = Tagged (hashStructure (structure (Proxy :: Proxy a)))
 239
 240 -- private Tagged
 241 newtype Tagged a b = Tagged {untag :: b}
 242
 243 -- | Semantically @'hashStructure' . 'structure'@.
 244 structureHash :: forall a. Structured a => Proxy a -> MD5
 245 structureHash _ = untag (structureHash' :: Tagged a MD5)
 246
 247 -------------------------------------------------------------------------------
 248 -- Functions
 249 -------------------------------------------------------------------------------
 250
 251 -- | Structured 'Binary.encode'.
 252 -- Encode a value to using binary serialisation to a lazy 'LBS.ByteString'.
 253 -- Encoding starts with 16 byte large structure hash.
 254 structuredEncode
 255   :: forall a
 256    . (Binary.Binary a, Structured a)
 257   => a
 258   -> LBS.ByteString
 259 structuredEncode x = Binary.encode (Tag :: Tag a, x)
 260
 261 -- | Lazily serialise a value to a file
 262 structuredEncodeFile :: (Binary.Binary a, Structured a) => FilePath -> a -> IO ()
 263 structuredEncodeFile f = LBS.writeFile f . structuredEncode
 264
 265 -- | Structured 'Binary.decode'.
 266 -- Decode a value from a lazy 'LBS.ByteString', reconstructing the original structure.
 267 -- Throws pure exception on invalid inputs.
 268 structuredDecode
 269   :: forall a
 270    . (Binary.Binary a, Structured a)
 271   => LBS.ByteString
 272   -> a
 273 structuredDecode lbs = snd (Binary.decode lbs :: (Tag a, a))
 274
 275 structuredDecodeOrFailIO :: (Binary.Binary a, Structured a) => LBS.ByteString -> IO (Either String a)
 276 structuredDecodeOrFailIO bs =
 277   catch (evaluate (structuredDecode bs) >>= return . Right) handler
 278   where
 279     handler (ErrorCall str) = return $ Left str
 280
 281 -- | Lazily reconstruct a value previously written to a file.
 282 structuredDecodeFileOrFail :: (Binary.Binary a, Structured a) => FilePath -> IO (Either String a)
 283 structuredDecodeFileOrFail f = structuredDecodeOrFailIO =<< LBS.readFile f
 284
 285 -------------------------------------------------------------------------------
 286 -- Helper data
 287 -------------------------------------------------------------------------------
 288
 289 data Tag a = Tag
 290
 291 instance Structured a => Binary.Binary (Tag a) where
 292   get = do
 293     actual <- binaryGetMD5
 294     if actual == expected
 295       then return Tag
 296       else
 297         fail $
 298           concat
 299             [ "Non-matching structured hashes: "
 300             , showMD5 actual
 301             , "; expected: "
 302             , showMD5 expected
 303             ]
 304     where
 305       expected = untag (structureHash' :: Tagged a MD5)
 306
 307   put _ = binaryPutMD5 expected
 308     where
 309       expected = untag (structureHash' :: Tagged a MD5)
 310
 311 -------------------------------------------------------------------------------
 312 -- Smart constructors
 313 -------------------------------------------------------------------------------
 314
 315 -- | Use 'Typeable' to infer name
 316 nominalStructure :: Typeable a => Proxy a -> Structure
 317 nominalStructure p = Nominal tr 0 (show tr) []
 318   where
 319     tr = typeRep p
 320
 321 containerStructure :: forall f a. (Typeable f, Structured a) => Proxy (f a) -> Structure
 322 containerStructure _ =
 323   Nominal
 324     faTypeRep
 325     0
 326     (show fTypeRep)
 327     [ structure (Proxy :: Proxy a)
 328     ]
 329   where
 330     fTypeRep = typeRep (Proxy :: Proxy f)
 331     faTypeRep = typeRep (Proxy :: Proxy (f a))
 332
 333 -------------------------------------------------------------------------------
 334 -- Generic
 335 -------------------------------------------------------------------------------
 336
 337 -- | Derive 'structure' generically.
 338 genericStructure :: forall a. (Typeable a, Generic a, GStructured (Rep a)) => Proxy a -> Structure
 339 genericStructure _ = gstructured (typeRep (Proxy :: Proxy a)) (Proxy :: Proxy (Rep a)) 0
 340
 341 -- | Used to implement 'genericStructure'.
 342 class GStructured (f :: Type -> Type) where
 343   gstructured :: TypeRep -> Proxy f -> TypeVersion -> Structure
 344
 345 instance (i ~ D, Datatype c, GStructuredSum f) => GStructured (M1 i c f) where
 346   gstructured tr _ v = case sop of
 347     [(_, [s])] | isNewtype p -> Newtype tr v name s
 348     _ -> Structure tr v name sop
 349     where
 350       p = undefined :: M1 i c f ()
 351       name = datatypeName p
 352       sop = gstructuredSum (Proxy :: Proxy f) []
 353
 354 class GStructuredSum (f :: Type -> Type) where
 355   gstructuredSum :: Proxy f -> SopStructure -> SopStructure
 356
 357 instance (i ~ C, Constructor c, GStructuredProd f) => GStructuredSum (M1 i c f) where
 358   gstructuredSum _ xs = (name, prod) : xs
 359     where
 360       name = conName (undefined :: M1 i c f ())
 361       prod = gstructuredProd (Proxy :: Proxy f) []
 362
 363 instance (GStructuredSum f, GStructuredSum g) => GStructuredSum (f :+: g) where
 364   gstructuredSum _ xs =
 365     gstructuredSum (Proxy :: Proxy f) $
 366       gstructuredSum (Proxy :: Proxy g) xs
 367
 368 instance GStructuredSum V1 where
 369   gstructuredSum _ = id
 370
 371 class GStructuredProd (f :: Type -> Type) where
 372   gstructuredProd :: Proxy f -> [Structure] -> [Structure]
 373
 374 instance (i ~ S, GStructuredProd f) => GStructuredProd (M1 i c f) where
 375   gstructuredProd _ = gstructuredProd (Proxy :: Proxy f)
 376
 377 instance Structured c => GStructuredProd (K1 i c) where
 378   gstructuredProd _ xs = structure (Proxy :: Proxy c) : xs
 379
 380 instance GStructuredProd U1 where
 381   gstructuredProd _ = id
 382
 383 instance (GStructuredProd f, GStructuredProd g) => GStructuredProd (f :*: g) where
 384   gstructuredProd _ xs =
 385     gstructuredProd (Proxy :: Proxy f) $
 386       gstructuredProd (Proxy :: Proxy g) xs
 387
 388 -------------------------------------------------------------------------------
 389 -- instances
 390 -------------------------------------------------------------------------------
 391
 392 instance Structured ()
 393 instance Structured Bool
 394 instance Structured Ordering
 395
 396 instance Structured Char where structure = nominalStructure
 397 instance Structured Int where structure = nominalStructure
 398 instance Structured Integer where structure = nominalStructure
 399
 400 instance Structured Data.Word.Word where structure = nominalStructure
 401
 402 instance Structured Int8 where structure = nominalStructure
 403 instance Structured Int16 where structure = nominalStructure
 404 instance Structured Int32 where structure = nominalStructure
 405 instance Structured Int64 where structure = nominalStructure
 406
 407 instance Structured Word8 where structure = nominalStructure
 408 instance Structured Word16 where structure = nominalStructure
 409 instance Structured Word32 where structure = nominalStructure
 410 instance Structured Word64 where structure = nominalStructure
 411
 412 instance Structured Float where structure = nominalStructure
 413 instance Structured Double where structure = nominalStructure
 414
 415 instance Structured a => Structured (Maybe a)
 416 instance (Structured a, Structured b) => Structured (Either a b)
 417 instance Structured a => Structured (Ratio a) where structure = containerStructure
 418 instance Structured a => Structured [a] where structure = containerStructure
 419 instance Structured a => Structured (NonEmpty a) where structure = containerStructure
 420
 421 -- These instances are defined directly because the generic names for tuples changed
 422 -- in 9.6 (https://gitlab.haskell.org/ghc/ghc/-/issues/24291).
 423 --
 424 -- By defining our own instances the STuple2 identifier will be used in the hash and
 425 -- hence the same on all GHC versions.
 426
 427 data STuple2 a b = STuple2 a b deriving (Generic)
 428 data STuple3 a b c = STuple3 a b c deriving (Generic)
 429 data STuple4 a b c d = STuple4 a b c d deriving (Generic)
 430 data STuple5 a b c d e = STuple5 a b c d e deriving (Generic)
 431 data STuple6 a b c d e f = STuple6 a b c d e f deriving (Generic)
 432 data STuple7 a b c d e f g = STuple7 a b c d e f g deriving (Generic)
 433
 434 instance (Structured a1, Structured a2) => Structured (STuple2 a1 a2)
 435 instance (Structured a1, Structured a2) => Structured (a1, a2) where
 436   structure Proxy = structure @(STuple2 a1 a2) Proxy
 437
 438 instance (Structured a1, Structured a2, Structured a3) => Structured (STuple3 a1 a2 a3)
 439 instance (Structured a1, Structured a2, Structured a3) => Structured (a1, a2, a3) where
 440   structure Proxy = structure @(STuple3 a1 a2 a3) Proxy
 441
 442 instance (Structured a1, Structured a2, Structured a3, Structured a4) => Structured (STuple4 a1 a2 a3 a4)
 443 instance (Structured a1, Structured a2, Structured a3, Structured a4) => Structured (a1, a2, a3, a4) where
 444   structure Proxy = structure @(STuple4 a1 a2 a3 a4) Proxy
 445
 446 instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5) => Structured (STuple5 a1 a2 a3 a4 a5)
 447 instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5) => Structured (a1, a2, a3, a4, a5) where
 448   structure Proxy = structure @(STuple5 a1 a2 a3 a4 a5) Proxy
 449
 450 instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5, Structured a6) => Structured (STuple6 a1 a2 a3 a4 a5 a6)
 451 instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5, Structured a6) => Structured (a1, a2, a3, a4, a5, a6) where
 452   structure Proxy = structure @(STuple6 a1 a2 a3 a4 a5 a6) Proxy
 453
 454 instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5, Structured a6, Structured a7) => Structured (STuple7 a1 a2 a3 a4 a5 a6 a7)
 455 instance (Structured a1, Structured a2, Structured a3, Structured a4, Structured a5, Structured a6, Structured a7) => Structured (a1, a2, a3, a4, a5, a6, a7) where
 456   structure Proxy = structure @(STuple7 a1 a2 a3 a4 a5 a6 a7) Proxy
 457
 458 instance Structured BS.ByteString where structure = nominalStructure
 459 instance Structured LBS.ByteString where structure = nominalStructure
 460
 461 instance Structured T.Text where structure = nominalStructure
 462 instance Structured LT.Text where structure = nominalStructure
 463
 464 instance (Structured k, Structured v) => Structured (Map.Map k v) where structure _ = Nominal (typeRep (Proxy :: Proxy (Map.Map k v))) 0 "Map" [structure (Proxy :: Proxy k), structure (Proxy :: Proxy v)]
 465 instance Structured k => Structured (Set.Set k) where structure = containerStructure
 466 instance Structured v => Structured (IM.IntMap v) where structure = containerStructure
 467 instance Structured IS.IntSet where structure = nominalStructure
 468 instance Structured v => Structured (Seq.Seq v) where structure = containerStructure
 469
 470 instance Structured Time.UTCTime where structure = nominalStructure
 471 instance Structured Time.DiffTime where structure = nominalStructure
 472 instance Structured Time.UniversalTime where structure = nominalStructure
 473 instance Structured Time.NominalDiffTime where structure = nominalStructure
 474 instance Structured Time.Day where structure = nominalStructure
 475 instance Structured Time.TimeZone where structure = nominalStructure
 476 instance Structured Time.TimeOfDay where structure = nominalStructure
 477 instance Structured Time.LocalTime where structure = nominalStructure