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

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