{-# LANGUAGE DataKinds #-}

-- | Generic derivation of 'ToCBOR' / 'FromCBOR' instances in the
-- constructor-name-tagged format used for hydra-node persistence and API
-- messages.
--
-- The encoding of a value is the constructor name as a CBOR text string,
-- followed by the encodings of the constructor fields in declaration order,
-- concatenated without any list framing:
--
-- @
-- toCBOR ("ConstructorName" :: Text) <> toCBOR field1 <> toCBOR field2 <> ...
-- @
--
-- Every constructor is tagged, including the single constructor of records
-- and newtypes. Tagging by name (instead of by declaration index like the
-- @serialise@ package) means adding or reordering constructors does not
-- change the encoding of existing data; removing or renaming a constructor,
-- or changing the order or type of its fields, does and requires a migration
-- of persisted data.
--
-- Since the field encodings come from the data type declaration, the
-- declaration itself becomes the wire format: reordering record fields is a
-- format change that the type checker will not flag. Golden tests (see
-- 'Hydra.CBORSpec' in hydra-node) are the guard against that.
--
-- Decoding fails with @"\<tag\>" is not a proper CBOR-encoded \<TypeName\>@
-- when the decoded tag matches no constructor.
module Hydra.CBOR.Generic (
  genericToCBOR,
  genericFromCBOR,
) where

import Relude

import Cardano.Binary (Decoder, Encoding, FromCBOR (..), ToCBOR (..))
import GHC.Generics
import GHC.TypeLits (KnownSymbol, symbolVal)

-- | Encode a value in the constructor-name-tagged CBOR format:
--
-- @
-- instance ToCBOR MyType where
--   toCBOR = genericToCBOR
-- @
genericToCBOR :: (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR :: forall a. (Generic a, GToCBOR (Rep a)) => a -> Encoding
genericToCBOR = Rep a Any -> Encoding
forall p. Rep a p -> Encoding
forall {k} (f :: k -> *) (p :: k). GToCBOR f => f p -> Encoding
gToCBOR (Rep a Any -> Encoding) -> (a -> Rep a Any) -> a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from

-- | Decode a value from the constructor-name-tagged CBOR format produced by
-- 'genericToCBOR':
--
-- @
-- instance FromCBOR MyType where
--   fromCBOR = genericFromCBOR
-- @
genericFromCBOR :: (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR :: forall a s. (Generic a, GFromCBOR (Rep a)) => Decoder s a
genericFromCBOR = Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to (Rep a Any -> a) -> Decoder s (Rep a Any) -> Decoder s a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (Rep a Any)
forall s p. Decoder s (Rep a p)
forall {k} (f :: k -> *) s (p :: k). GFromCBOR f => Decoder s (f p)
gFromCBOR

-- * Encoding

class GToCBOR f where
  gToCBOR :: f p -> Encoding

instance GToCBOR f => GToCBOR (D1 meta f) where
  gToCBOR :: forall (p :: k). D1 meta f p -> Encoding
gToCBOR (M1 f p
x) = f p -> Encoding
forall (p :: k). f p -> Encoding
forall {k} (f :: k -> *) (p :: k). GToCBOR f => f p -> Encoding
gToCBOR f p
x

instance (GToCBOR f, GToCBOR g) => GToCBOR (f :+: g) where
  gToCBOR :: forall (p :: k). (:+:) f g p -> Encoding
gToCBOR = \case
    L1 f p
x -> f p -> Encoding
forall (p :: k). f p -> Encoding
forall {k} (f :: k -> *) (p :: k). GToCBOR f => f p -> Encoding
gToCBOR f p
x
    R1 g p
x -> g p -> Encoding
forall (p :: k). g p -> Encoding
forall {k} (f :: k -> *) (p :: k). GToCBOR f => f p -> Encoding
gToCBOR g p
x

instance (KnownSymbol name, GFieldsToCBOR f) => GToCBOR (C1 ('MetaCons name fixity hasSelectors) f) where
  gToCBOR :: forall (p :: k).
C1 ('MetaCons name fixity hasSelectors) f p -> Encoding
gToCBOR (M1 f p
x) = Text -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (Proxy name -> Text
forall (name :: Symbol). KnownSymbol name => Proxy name -> Text
conNameText (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name)) Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> f p -> Encoding
forall (p :: k). f p -> Encoding
forall {k} (f :: k -> *) (p :: k).
GFieldsToCBOR f =>
f p -> Encoding
gFieldsToCBOR f p
x

class GFieldsToCBOR f where
  gFieldsToCBOR :: f p -> Encoding

instance GFieldsToCBOR U1 where
  gFieldsToCBOR :: forall (p :: k). U1 p -> Encoding
gFieldsToCBOR U1 p
U1 = Encoding
forall a. Monoid a => a
mempty

instance (GFieldsToCBOR f, GFieldsToCBOR g) => GFieldsToCBOR (f :*: g) where
  gFieldsToCBOR :: forall (p :: k). (:*:) f g p -> Encoding
gFieldsToCBOR (f p
x :*: g p
y) = f p -> Encoding
forall (p :: k). f p -> Encoding
forall {k} (f :: k -> *) (p :: k).
GFieldsToCBOR f =>
f p -> Encoding
gFieldsToCBOR f p
x Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> g p -> Encoding
forall (p :: k). g p -> Encoding
forall {k} (f :: k -> *) (p :: k).
GFieldsToCBOR f =>
f p -> Encoding
gFieldsToCBOR g p
y

instance GFieldsToCBOR f => GFieldsToCBOR (S1 meta f) where
  gFieldsToCBOR :: forall (p :: k). S1 meta f p -> Encoding
gFieldsToCBOR (M1 f p
x) = f p -> Encoding
forall (p :: k). f p -> Encoding
forall {k} (f :: k -> *) (p :: k).
GFieldsToCBOR f =>
f p -> Encoding
gFieldsToCBOR f p
x

instance ToCBOR a => GFieldsToCBOR (K1 i a) where
  gFieldsToCBOR :: forall (p :: k). K1 i a p -> Encoding
gFieldsToCBOR (K1 a
a) = a -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR a
a

-- * Decoding

class GFromCBOR f where
  gFromCBOR :: Decoder s (f p)

instance (KnownSymbol typeName, GConsFromCBOR f) => GFromCBOR (D1 ('MetaData typeName moduleName package isNewtype) f) where
  gFromCBOR :: forall s (p :: k).
Decoder
  s (D1 ('MetaData typeName moduleName package isNewtype) f p)
gFromCBOR = do
    Text
tag <- Decoder s Text
forall s. Decoder s Text
forall a s. FromCBOR a => Decoder s a
fromCBOR
    case Text -> Maybe (Decoder s (f p))
forall s (p :: k). Text -> Maybe (Decoder s (f p))
forall {k} (f :: k -> *) s (p :: k).
GConsFromCBOR f =>
Text -> Maybe (Decoder s (f p))
gConsFromCBOR Text
tag of
      Just Decoder s (f p)
decodeFields -> f p -> D1 ('MetaData typeName moduleName package isNewtype) f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> D1 ('MetaData typeName moduleName package isNewtype) f p)
-> Decoder s (f p)
-> Decoder
     s (D1 ('MetaData typeName moduleName package isNewtype) f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (f p)
decodeFields
      Maybe (Decoder s (f p))
Nothing ->
        String
-> Decoder
     s (D1 ('MetaData typeName moduleName package isNewtype) f p)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
 -> Decoder
      s (D1 ('MetaData typeName moduleName package isNewtype) f p))
-> String
-> Decoder
     s (D1 ('MetaData typeName moduleName package isNewtype) f p)
forall a b. (a -> b) -> a -> b
$ Text -> String
forall b a. (Show a, IsString b) => a -> b
show Text
tag String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" is not a proper CBOR-encoded " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Proxy typeName -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @typeName)

class GConsFromCBOR f where
  -- | The field decoder of the constructor matching the given tag, if any.
  gConsFromCBOR :: Text -> Maybe (Decoder s (f p))

instance (GConsFromCBOR f, GConsFromCBOR g) => GConsFromCBOR (f :+: g) where
  gConsFromCBOR :: forall s (p :: k). Text -> Maybe (Decoder s ((:+:) f g p))
gConsFromCBOR Text
tag =
    ((f p -> (:+:) f g p) -> Decoder s (f p) -> Decoder s ((:+:) f g p)
forall a b. (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (Decoder s (f p) -> Decoder s ((:+:) f g p))
-> Maybe (Decoder s (f p)) -> Maybe (Decoder s ((:+:) f g p))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe (Decoder s (f p))
forall s (p :: k). Text -> Maybe (Decoder s (f p))
forall {k} (f :: k -> *) s (p :: k).
GConsFromCBOR f =>
Text -> Maybe (Decoder s (f p))
gConsFromCBOR Text
tag) Maybe (Decoder s ((:+:) f g p))
-> Maybe (Decoder s ((:+:) f g p))
-> Maybe (Decoder s ((:+:) f g p))
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((g p -> (:+:) f g p) -> Decoder s (g p) -> Decoder s ((:+:) f g p)
forall a b. (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap g p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (Decoder s (g p) -> Decoder s ((:+:) f g p))
-> Maybe (Decoder s (g p)) -> Maybe (Decoder s ((:+:) f g p))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe (Decoder s (g p))
forall s (p :: k). Text -> Maybe (Decoder s (g p))
forall {k} (f :: k -> *) s (p :: k).
GConsFromCBOR f =>
Text -> Maybe (Decoder s (f p))
gConsFromCBOR Text
tag)

instance (KnownSymbol name, GFieldsFromCBOR f) => GConsFromCBOR (C1 ('MetaCons name fixity hasSelectors) f) where
  gConsFromCBOR :: forall s (p :: k).
Text
-> Maybe (Decoder s (C1 ('MetaCons name fixity hasSelectors) f p))
gConsFromCBOR Text
tag
    | Text
tag Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy name -> Text
forall (name :: Symbol). KnownSymbol name => Proxy name -> Text
conNameText (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @name) = Decoder s (C1 ('MetaCons name fixity hasSelectors) f p)
-> Maybe (Decoder s (C1 ('MetaCons name fixity hasSelectors) f p))
forall a. a -> Maybe a
Just (f p -> C1 ('MetaCons name fixity hasSelectors) f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> C1 ('MetaCons name fixity hasSelectors) f p)
-> Decoder s (f p)
-> Decoder s (C1 ('MetaCons name fixity hasSelectors) f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (f p)
forall s (p :: k). Decoder s (f p)
forall {k} (f :: k -> *) s (p :: k).
GFieldsFromCBOR f =>
Decoder s (f p)
gFieldsFromCBOR)
    | Bool
otherwise = Maybe (Decoder s (C1 ('MetaCons name fixity hasSelectors) f p))
forall a. Maybe a
Nothing

class GFieldsFromCBOR f where
  gFieldsFromCBOR :: Decoder s (f p)

instance GFieldsFromCBOR U1 where
  gFieldsFromCBOR :: forall s (p :: k). Decoder s (U1 p)
gFieldsFromCBOR = U1 p -> Decoder s (U1 p)
forall a. a -> Decoder s a
forall (f :: * -> *) a. Applicative f => a -> f a
pure U1 p
forall k (p :: k). U1 p
U1

instance (GFieldsFromCBOR f, GFieldsFromCBOR g) => GFieldsFromCBOR (f :*: g) where
  gFieldsFromCBOR :: forall s (p :: k). Decoder s ((:*:) f g p)
gFieldsFromCBOR = f p -> g p -> (:*:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
(:*:) (f p -> g p -> (:*:) f g p)
-> Decoder s (f p) -> Decoder s (g p -> (:*:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (f p)
forall s (p :: k). Decoder s (f p)
forall {k} (f :: k -> *) s (p :: k).
GFieldsFromCBOR f =>
Decoder s (f p)
gFieldsFromCBOR Decoder s (g p -> (:*:) f g p)
-> Decoder s (g p) -> Decoder s ((:*:) f g p)
forall a b. Decoder s (a -> b) -> Decoder s a -> Decoder s b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Decoder s (g p)
forall s (p :: k). Decoder s (g p)
forall {k} (f :: k -> *) s (p :: k).
GFieldsFromCBOR f =>
Decoder s (f p)
gFieldsFromCBOR

instance GFieldsFromCBOR f => GFieldsFromCBOR (S1 meta f) where
  gFieldsFromCBOR :: forall s (p :: k). Decoder s (S1 meta f p)
gFieldsFromCBOR = f p -> M1 S meta f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f p -> M1 S meta f p)
-> Decoder s (f p) -> Decoder s (M1 S meta f p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s (f p)
forall s (p :: k). Decoder s (f p)
forall {k} (f :: k -> *) s (p :: k).
GFieldsFromCBOR f =>
Decoder s (f p)
gFieldsFromCBOR

instance FromCBOR a => GFieldsFromCBOR (K1 i a) where
  gFieldsFromCBOR :: forall s (p :: k). Decoder s (K1 i a p)
gFieldsFromCBOR = a -> K1 i a p
forall k i c (p :: k). c -> K1 i c p
K1 (a -> K1 i a p) -> Decoder s a -> Decoder s (K1 i a p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s a
forall s. Decoder s a
forall a s. FromCBOR a => Decoder s a
fromCBOR

-- | The constructor name from generic metadata, as 'Text'.
conNameText :: KnownSymbol name => Proxy name -> Text
conNameText :: forall (name :: Symbol). KnownSymbol name => Proxy name -> Text
conNameText = String -> Text
forall a. ToText a => a -> Text
toText (String -> Text) -> (Proxy name -> String) -> Proxy name -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal