-- SPDX-FileCopyrightText: 2020 Tocqueville Group
--
-- SPDX-License-Identifier: LicenseRef-MIT-TQ

{- | This module contains implementation of 'Extensible' values.

@Extensible@ values are an alternative representation of sum-types
for Michelson. Instead of representing them as nested options, we
treat them as (Natural, ByteString) pair, where the first element
of the pair represents the constructor index, while the second is
a packed argument.

With such a representation sum types can be easily upgraded: it is
possible to add new elements to the sum type, and the representation
would not change.

However, such representation essentially limits the applicability of
the values. This module does not provide Michelson-level function to
unwrap the value because it would require traversing all the possible
options in the contract code. While this is possible, it is very
inefficient. Up to this moment, we have not come up with a decent
reason to allow such behavior, so Extensible types are write-only
in Michelson code. They can be unwrapped off-chain with @fromExtVal@.

In order to preserve previous values during migrations, users should
ONLY APPEND items to the underlying sum type. Changing, reordering and
deleting items is not allowed and would lead to compatibility breakage.
Currently, this restriction in not enforced. Only no-argument and
one-argument constructors are supported.

GOOD:
  -- `Extensible GoodSumTypeV1` is backwards compatible
  -- with `Extensible GoodSumTypeV2`
  data GoodSumTypeV1 = A Natural | B
  data GoodSumTypeV2 = A Natural | B | C MText

BAD:
  -- `Extensible BadSumTypeV1` is NOT backwards compatible
  -- with `Extensible BadSumTypeV2`
  data BadSumTypeV1 = A | B
  data BadSumTypeV2 = A Natural | B | C MText
-}

{-# LANGUAGE InstanceSigs #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}

module Lorentz.Extensible
  ( Extensible (..)
  , ExtConversionError (..)
  , ExtVal
  , ExtensibleHasDoc (..)
  , toExtVal
  , fromExtVal
  , wrapExt
  , WrapExtC
  ) where

import Data.Char (isSpace)
import qualified Data.Kind as Kind
import qualified Data.Text as T
import Fmt (Buildable(build), (+||), (|+), (||+))
import GHC.Generics ((:+:)(..))
import qualified GHC.Generics as G
import GHC.TypeLits (Nat)
import GHC.TypeNats (type (+))

import Lorentz.Annotation
import Lorentz.Base
import Lorentz.Coercions
import Lorentz.Constraints
import Lorentz.Doc
import Lorentz.Instr
import Lorentz.Pack
import Michelson.Typed
import Util.Label (Label)
import Util.Markdown
import Util.Type
import Util.TypeLits

newtype Extensible x = Extensible (Natural, ByteString)
  deriving stock ((forall x. Extensible x -> Rep (Extensible x) x)
-> (forall x. Rep (Extensible x) x -> Extensible x)
-> Generic (Extensible x)
forall x. Rep (Extensible x) x -> Extensible x
forall x. Extensible x -> Rep (Extensible x) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (x :: k) x. Rep (Extensible x) x -> Extensible x
forall k (x :: k) x. Extensible x -> Rep (Extensible x) x
$cto :: forall k (x :: k) x. Rep (Extensible x) x -> Extensible x
$cfrom :: forall k (x :: k) x. Extensible x -> Rep (Extensible x) x
Generic, Extensible x -> Extensible x -> Bool
(Extensible x -> Extensible x -> Bool)
-> (Extensible x -> Extensible x -> Bool) -> Eq (Extensible x)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall k (x :: k). Extensible x -> Extensible x -> Bool
/= :: Extensible x -> Extensible x -> Bool
$c/= :: forall k (x :: k). Extensible x -> Extensible x -> Bool
== :: Extensible x -> Extensible x -> Bool
$c== :: forall k (x :: k). Extensible x -> Extensible x -> Bool
Eq, Int -> Extensible x -> ShowS
[Extensible x] -> ShowS
Extensible x -> String
(Int -> Extensible x -> ShowS)
-> (Extensible x -> String)
-> ([Extensible x] -> ShowS)
-> Show (Extensible x)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall k (x :: k). Int -> Extensible x -> ShowS
forall k (x :: k). [Extensible x] -> ShowS
forall k (x :: k). Extensible x -> String
showList :: [Extensible x] -> ShowS
$cshowList :: forall k (x :: k). [Extensible x] -> ShowS
show :: Extensible x -> String
$cshow :: forall k (x :: k). Extensible x -> String
showsPrec :: Int -> Extensible x -> ShowS
$cshowsPrec :: forall k (x :: k). Int -> Extensible x -> ShowS
Show)
  deriving anyclass (WellTypedToT (Extensible x)
WellTypedToT (Extensible x) =>
(Extensible x -> Value (ToT (Extensible x)))
-> (Value (ToT (Extensible x)) -> Extensible x)
-> IsoValue (Extensible x)
Value (ToT (Extensible x)) -> Extensible x
Extensible x -> Value (ToT (Extensible x))
forall a.
WellTypedToT a =>
(a -> Value (ToT a)) -> (Value (ToT a) -> a) -> IsoValue a
forall k (x :: k). WellTypedToT (Extensible x)
forall k (x :: k). Value (ToT (Extensible x)) -> Extensible x
forall k (x :: k). Extensible x -> Value (ToT (Extensible x))
fromVal :: Value (ToT (Extensible x)) -> Extensible x
$cfromVal :: forall k (x :: k). Value (ToT (Extensible x)) -> Extensible x
toVal :: Extensible x -> Value (ToT (Extensible x))
$ctoVal :: forall k (x :: k). Extensible x -> Value (ToT (Extensible x))
$cp1IsoValue :: forall k (x :: k). WellTypedToT (Extensible x)
IsoValue, FollowEntrypointFlag -> Notes (ToT (Extensible x))
(FollowEntrypointFlag -> Notes (ToT (Extensible x)))
-> HasAnnotation (Extensible x)
forall a.
(FollowEntrypointFlag -> Notes (ToT a)) -> HasAnnotation a
forall k (x :: k).
FollowEntrypointFlag -> Notes (ToT (Extensible x))
getAnnotation :: FollowEntrypointFlag -> Notes (ToT (Extensible x))
$cgetAnnotation :: forall k (x :: k).
FollowEntrypointFlag -> Notes (ToT (Extensible x))
HasAnnotation, ToT (Extensible x) ~ ToT (Unwrappable (Extensible x))
(ToT (Extensible x) ~ ToT (Unwrappable (Extensible x))) =>
Wrappable (Extensible x)
forall s. (ToT s ~ ToT (Unwrappable s)) => Wrappable s
forall k (x :: k).
ToT (Extensible x) ~ ToT (Unwrappable (Extensible x))
Wrappable)

type ExtVal x = (Generic x, GExtVal x (G.Rep x))
type GetCtors x = GGetCtors (G.Rep x)

-- | Converts a value from a Haskell representation to its
--   extensible Michelson representation (i.e. (Natural, Bytestring) pair).
toExtVal :: ExtVal a => a -> Extensible a
toExtVal :: a -> Extensible a
toExtVal = Rep a Any -> Extensible a
forall k (t :: k) (x :: * -> *) p.
GExtVal t x =>
x p -> Extensible t
gToExtVal (Rep a Any -> Extensible a)
-> (a -> Rep a Any) -> a -> Extensible a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
G.from

-- | Converts a value from an extensible Michelson representation to its
--   Haskell sum-type representation. Fails if the Michelson representation
--   points to a nun-existent constructor, or if we failed to unpack
--   the argument.
fromExtVal :: ExtVal a => Extensible a -> Either ExtConversionError a
fromExtVal :: Extensible a -> Either ExtConversionError a
fromExtVal val :: Extensible a
val = (Rep a Any -> a)
-> Either ExtConversionError (Rep a Any)
-> Either ExtConversionError a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep a Any -> a
forall a x. Generic a => Rep a x -> a
G.to (Either ExtConversionError (Rep a Any)
 -> Either ExtConversionError a)
-> Either ExtConversionError (Rep a Any)
-> Either ExtConversionError a
forall a b. (a -> b) -> a -> b
$ Extensible a -> Either ExtConversionError (Rep a Any)
forall k (t :: k) (x :: * -> *) p.
GExtVal t x =>
Extensible t -> Either ExtConversionError (x p)
gFromExtVal Extensible a
val

-- | Helper typeclass which allows us to sanely handle cases of no-arg
-- constructor and constructor with one argument.
class WrapExt (cf :: CtorField) where
  -- | Pack argument on top of the stack, if any required.
  packForWrap :: AppendCtorField cf s :-> ByteString : s

instance (NicePackedValue param) =>
         WrapExt ('OneField param) where
  packForWrap :: AppendCtorField ('OneField param) s :-> (ByteString : s)
packForWrap = AppendCtorField ('OneField param) s :-> (ByteString : s)
forall a (s :: [*]).
NicePackedValue a =>
(a & s) :-> (ByteString & s)
pack

instance WrapExt 'NoFields where
  packForWrap :: AppendCtorField 'NoFields s :-> (ByteString : s)
packForWrap = s :-> (() & s)
forall (s :: [*]). s :-> (() & s)
unit (s :-> (() & s))
-> ((() & s) :-> (ByteString : s)) -> s :-> (ByteString : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (() & s) :-> (ByteString : s)
forall a (s :: [*]).
NicePackedValue a =>
(a & s) :-> (ByteString & s)
pack

-- | Wraps an argument on top of the stack into an Extensible representation
wrapExt
  :: forall t (n :: Nat) name field s.
     (WrapExtC t n name field s)
  => Label ("c" `AppendSymbol` name) -> AppendCtorField field s :-> Extensible t ': s
wrapExt :: Label (AppendSymbol "c" name)
-> AppendCtorField field s :-> (Extensible t : s)
wrapExt _ = forall (s :: [*]).
WrapExt field =>
AppendCtorField field s :-> (ByteString : s)
forall (cf :: CtorField) (s :: [*]).
WrapExt cf =>
AppendCtorField cf s :-> (ByteString : s)
packForWrap @field (AppendCtorField field s :-> (ByteString : s))
-> ((ByteString : s) :-> (Natural & (ByteString : s)))
-> AppendCtorField field s :-> (Natural & (ByteString : s))
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# Natural -> (ByteString : s) :-> (Natural & (ByteString : s))
forall t (s :: [*]). NiceConstant t => t -> s :-> (t & s)
push (Proxy n -> Natural
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy @n)) (AppendCtorField field s :-> (Natural & (ByteString : s)))
-> ((Natural & (ByteString : s)) :-> ((Natural, ByteString) & s))
-> AppendCtorField field s :-> ((Natural, ByteString) & s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# (Natural & (ByteString : s)) :-> ((Natural, ByteString) & s)
forall a b (s :: [*]). (a & (b & s)) :-> ((a, b) & s)
pair (AppendCtorField field s :-> ((Natural, ByteString) & s))
-> (((Natural, ByteString) & s) :-> (Extensible t : s))
-> AppendCtorField field s :-> (Extensible t : s)
forall (a :: [*]) (b :: [*]) (c :: [*]).
(a :-> b) -> (b :-> c) -> a :-> c
# ((Natural, ByteString) & s) :-> (Extensible t : s)
forall a (s :: [*]). Wrappable a => (Unwrappable a : s) :-> (a : s)
coerceWrap

type WrapExtC t n name field s =
  ( 'Ctor n name field ~ LookupCtor name (EnumerateCtors (GetCtors t))
  , WrapExt field
  , KnownNat n
  )

-- | Errors related to fromExtVal conversion
data ExtConversionError
  = ConstructorIndexNotFound Natural
  | ArgumentUnpackFailed
  deriving stock (ExtConversionError -> ExtConversionError -> Bool
(ExtConversionError -> ExtConversionError -> Bool)
-> (ExtConversionError -> ExtConversionError -> Bool)
-> Eq ExtConversionError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExtConversionError -> ExtConversionError -> Bool
$c/= :: ExtConversionError -> ExtConversionError -> Bool
== :: ExtConversionError -> ExtConversionError -> Bool
$c== :: ExtConversionError -> ExtConversionError -> Bool
Eq, Int -> ExtConversionError -> ShowS
[ExtConversionError] -> ShowS
ExtConversionError -> String
(Int -> ExtConversionError -> ShowS)
-> (ExtConversionError -> String)
-> ([ExtConversionError] -> ShowS)
-> Show ExtConversionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExtConversionError] -> ShowS
$cshowList :: [ExtConversionError] -> ShowS
show :: ExtConversionError -> String
$cshow :: ExtConversionError -> String
showsPrec :: Int -> ExtConversionError -> ShowS
$cshowsPrec :: Int -> ExtConversionError -> ShowS
Show)

instance Buildable ExtConversionError where
  build :: ExtConversionError -> Builder
build =
    \case
      ConstructorIndexNotFound idx :: Natural
idx ->
        "Could not convert Extensible value into its Haskell representation: \
        \constructor #" Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+|| Natural
idx Natural -> Builder -> Builder
forall a b. (Show a, FromBuilder b) => a -> Builder -> b
||+ " was not found in the sum type \
        \constructors list"
      ArgumentUnpackFailed ->
        "Could not convert Extensible value into its Haskell representation: \
        \failed to unpack constructor argument"

data Position = Position Nat
data Ctor = Ctor { Ctor -> Nat
_n :: Nat, Ctor -> Symbol
_name :: Symbol, Ctor -> CtorField
_param :: CtorField }
type CtorKind = (Symbol, CtorField)

-- | Finds the constructor's position and argument type by its name
type family LookupCtor (name :: Symbol) (entries :: [Ctor])
             :: Ctor where
  LookupCtor name ('Ctor pos name param ': _) = 'Ctor pos name param
  LookupCtor name (_ ': entries) =
    LookupCtor name entries
  LookupCtor name '[] =
    TypeError ('Text "Constructor " ':<>: 'ShowType name ':<>:
               'Text " is not in the sum type constructor list")

-- | Transform list of 'CtorKind's to list of 'Ctor's, assigning numbers
-- to elements starting from 0.
type EnumerateCtors ctors = EnumerateCtorsImpl ('Position 0) ctors

type family EnumerateCtorsImpl (pos :: Position) (ctors :: [CtorKind]) :: [Ctor] where
  EnumerateCtorsImpl _ '[] = '[]
  EnumerateCtorsImpl ('Position i) ('(name, param) ': cs) =
    'Ctor i name param ': EnumerateCtorsImpl ('Position (i + 1)) cs

-- | Having a sum-type, yields a type-level list of its constructors
type family GGetCtors (x :: Kind.Type -> Kind.Type) :: [CtorKind] where
  GGetCtors (G.D1 _ x) = GGetCtors x
  GGetCtors (G.C1 ('G.MetaCons name _1 _2) (G.S1 _3 (G.Rec0 param)))
    = '[ '(name, 'OneField param) ]
  GGetCtors (G.C1 ('G.MetaCons name _1 _2) G.U1)
    = '[ '(name, 'NoFields) ]
  GGetCtors (x :+: y) = GGetCtors x ++ GGetCtors y

-- | Generic implementation of toExtVal and fromExtVal
class GExtVal t (x :: Kind.Type -> Kind.Type) where
  gToExtVal :: x p -> Extensible t
  gFromExtVal :: Extensible t -> Either ExtConversionError (x p)

instance GExtVal t x => GExtVal t (G.D1 i x) where
  gToExtVal :: D1 i x p -> Extensible t
gToExtVal = forall k (t :: k) (x :: * -> *) p.
GExtVal t x =>
x p -> Extensible t
forall (x :: * -> *) p. GExtVal t x => x p -> Extensible t
gToExtVal @t (x p -> Extensible t)
-> (D1 i x p -> x p) -> D1 i x p -> Extensible t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. D1 i x p -> x p
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
G.unM1
  gFromExtVal :: Extensible t -> Either ExtConversionError (D1 i x p)
gFromExtVal val :: Extensible t
val = (x p -> D1 i x p)
-> Either ExtConversionError (x p)
-> Either ExtConversionError (D1 i x p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap x p -> D1 i x p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 (Extensible t -> Either ExtConversionError (x p)
forall k (t :: k) (x :: * -> *) p.
GExtVal t x =>
Extensible t -> Either ExtConversionError (x p)
gFromExtVal @t Extensible t
val)

instance ( 'Ctor n name 'NoFields ~ LookupCtor name (EnumerateCtors (GetCtors t))
         , KnownNat n
         )
         => GExtVal t (G.C1 ('G.MetaCons name _1 _2) G.U1) where
  gToExtVal :: C1 ('MetaCons name _1 _2) U1 p -> Extensible t
gToExtVal (G.M1 G.U1) = (Natural, ByteString) -> Extensible t
forall k (x :: k). (Natural, ByteString) -> Extensible x
Extensible
    ( Proxy n -> Natural
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy @n)
    , () -> ByteString
forall a. NicePackedValue a => a -> ByteString
lPackValue ()
    )
  gFromExtVal :: Extensible t
-> Either ExtConversionError (C1 ('MetaCons name _1 _2) U1 p)
gFromExtVal (Extensible (idx :: Natural
idx, _))
    | Natural
idx Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy n -> Natural
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy @n)
        = C1 ('MetaCons name _1 _2) U1 p
-> Either ExtConversionError (C1 ('MetaCons name _1 _2) U1 p)
forall a b. b -> Either a b
Right (C1 ('MetaCons name _1 _2) U1 p
 -> Either ExtConversionError (C1 ('MetaCons name _1 _2) U1 p))
-> C1 ('MetaCons name _1 _2) U1 p
-> Either ExtConversionError (C1 ('MetaCons name _1 _2) U1 p)
forall a b. (a -> b) -> a -> b
$ U1 p -> C1 ('MetaCons name _1 _2) U1 p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 U1 p
forall k (p :: k). U1 p
G.U1
    | Bool
otherwise = ExtConversionError
-> Either ExtConversionError (C1 ('MetaCons name _1 _2) U1 p)
forall a b. a -> Either a b
Left (ExtConversionError
 -> Either ExtConversionError (C1 ('MetaCons name _1 _2) U1 p))
-> ExtConversionError
-> Either ExtConversionError (C1 ('MetaCons name _1 _2) U1 p)
forall a b. (a -> b) -> a -> b
$ Natural -> ExtConversionError
ConstructorIndexNotFound Natural
idx

instance ( NiceFullPackedValue param
         , 'Ctor n name ('OneField param) ~ LookupCtor name (EnumerateCtors (GetCtors t))
         , KnownNat n
         )
         => GExtVal t (G.C1 ('G.MetaCons name _1 _2) (G.S1 _3 (G.Rec0 param))) where
  gToExtVal :: C1 ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p -> Extensible t
gToExtVal (G.M1 (G.M1 (G.K1 param :: param
param))) = (Natural, ByteString) -> Extensible t
forall k (x :: k). (Natural, ByteString) -> Extensible x
Extensible
    ( Proxy n -> Natural
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy @n)
    , param -> ByteString
forall a. NicePackedValue a => a -> ByteString
lPackValue param
param
    )
  gFromExtVal :: Extensible t
-> Either
     ExtConversionError
     (C1 ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p)
gFromExtVal (Extensible (idx :: Natural
idx, bs :: ByteString
bs))
    | Natural
idx Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy n -> Natural
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy @n)
        = (UnpackError -> ExtConversionError)
-> Either
     UnpackError (C1 ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p)
-> Either
     ExtConversionError
     (C1 ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\_ -> ExtConversionError
ArgumentUnpackFailed) (Either
   UnpackError (C1 ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p)
 -> Either
      ExtConversionError
      (C1 ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p))
-> Either
     UnpackError (C1 ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p)
-> Either
     ExtConversionError
     (C1 ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p)
forall a b. (a -> b) -> a -> b
$
          (param -> C1 ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p)
-> Either UnpackError param
-> Either
     UnpackError (C1 ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (M1 S _3 (Rec0 param) p
-> C1 ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 (M1 S _3 (Rec0 param) p
 -> C1 ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p)
-> (param -> M1 S _3 (Rec0 param) p)
-> param
-> C1 ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 R param p -> M1 S _3 (Rec0 param) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 (K1 R param p -> M1 S _3 (Rec0 param) p)
-> (param -> K1 R param p) -> param -> M1 S _3 (Rec0 param) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. param -> K1 R param p
forall k i c (p :: k). c -> K1 i c p
G.K1) (Either UnpackError param
 -> Either
      UnpackError (C1 ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p))
-> Either UnpackError param
-> Either
     UnpackError (C1 ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnpackError param
forall a. NiceUnpackedValue a => ByteString -> Either UnpackError a
lUnpackValue @param ByteString
bs
    | Bool
otherwise = ExtConversionError
-> Either
     ExtConversionError
     (C1 ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p)
forall a b. a -> Either a b
Left (ExtConversionError
 -> Either
      ExtConversionError
      (C1 ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p))
-> ExtConversionError
-> Either
     ExtConversionError
     (C1 ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p)
forall a b. (a -> b) -> a -> b
$ Natural -> ExtConversionError
ConstructorIndexNotFound Natural
idx

instance (GExtVal t x, GExtVal t y) => GExtVal t (x :+: y) where
  gToExtVal :: (:+:) x y p -> Extensible t
gToExtVal = \case
    G.L1 x :: x p
x -> let Extensible val :: (Natural, ByteString)
val = x p -> Extensible t
forall k (t :: k) (x :: * -> *) p.
GExtVal t x =>
x p -> Extensible t
gToExtVal @t x p
x in (Natural, ByteString) -> Extensible t
forall k (x :: k). (Natural, ByteString) -> Extensible x
Extensible (Natural, ByteString)
val
    G.R1 y :: y p
y -> let Extensible val :: (Natural, ByteString)
val = y p -> Extensible t
forall k (t :: k) (x :: * -> *) p.
GExtVal t x =>
x p -> Extensible t
gToExtVal @t y p
y in (Natural, ByteString) -> Extensible t
forall k (x :: k). (Natural, ByteString) -> Extensible x
Extensible (Natural, ByteString)
val
  gFromExtVal :: Extensible t -> Either ExtConversionError ((:+:) x y p)
gFromExtVal val :: Extensible t
val =
    let l :: Either ExtConversionError ((:+:) x y p)
l = (x p -> (:+:) x y p)
-> Either ExtConversionError (x p)
-> Either ExtConversionError ((:+:) x y p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap x p -> (:+:) x y p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
G.L1 (Extensible t -> Either ExtConversionError (x p)
forall k (t :: k) (x :: * -> *) p.
GExtVal t x =>
Extensible t -> Either ExtConversionError (x p)
gFromExtVal @t Extensible t
val)
        r :: Either ExtConversionError ((:+:) x y p)
r = (y p -> (:+:) x y p)
-> Either ExtConversionError (y p)
-> Either ExtConversionError ((:+:) x y p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap y p -> (:+:) x y p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
G.R1 (Extensible t -> Either ExtConversionError (y p)
forall k (t :: k) (x :: * -> *) p.
GExtVal t x =>
Extensible t -> Either ExtConversionError (x p)
gFromExtVal @t Extensible t
val)
    in Either ExtConversionError ((:+:) x y p)
l Either ExtConversionError ((:+:) x y p)
-> Either ExtConversionError ((:+:) x y p)
-> Either ExtConversionError ((:+:) x y p)
forall a. Semigroup a => a -> a -> a
<> Either ExtConversionError ((:+:) x y p)
r

-- | Information to be provided for documenting some @'Extensible' x@.
class Typeable x => ExtensibleHasDoc x where
  -- | Implementation for 'typeDocName' of the corresponding @Extensible@.
  extensibleDocName :: Proxy x -> Text

  -- | Implementation for 'typeDocDependencies' of the corresponding @Extensible@.
  extensibleDocDependencies :: Proxy x -> [SomeDocDefinitionItem]
  default extensibleDocDependencies
    :: (Generic x, GTypeHasDoc (G.Rep x))
    => Proxy x -> [SomeDocDefinitionItem]
  extensibleDocDependencies = Proxy x -> [SomeDocDefinitionItem]
forall a.
(Generic a, GTypeHasDoc (Rep a)) =>
Proxy a -> [SomeDocDefinitionItem]
genericTypeDocDependencies

  -- | Overall description of this type.
  extensibleDocMdDescription :: Markdown

-- | Helper which documents single constructor.
class DocumentCtor (ctor :: Ctor) where
  documentCtor :: Proxy ctor -> Markdown
instance ( KnownNat pos, KnownSymbol name, TypeHasDoc param
         , param ~ ExtractCtorField field
         ) =>
         DocumentCtor ('Ctor pos name field) where
  documentCtor :: Proxy ('Ctor pos name field) -> Builder
documentCtor _ =
    Proxy pos -> Natural
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal (Proxy pos
forall k (t :: k). Proxy t
Proxy @pos) Natural -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ ": " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
mdBold (Text -> Builder
forall p. Buildable p => p -> Builder
build (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ KnownSymbol name => Text
forall (s :: Symbol). KnownSymbol s => Text
symbolValT' @name) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    " " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Proxy param -> WithinParens -> Builder
forall a. TypeHasDoc a => Proxy a -> WithinParens -> Builder
typeDocMdReference (Proxy param
forall k (t :: k). Proxy t
Proxy @param) (Bool -> WithinParens
WithinParens Bool
True)

instance ( ExtensibleHasDoc x
         , ReifyList DocumentCtor (EnumerateCtors (GetCtors x))
         ) => TypeHasDoc (Extensible x) where
  typeDocName :: Proxy (Extensible x) -> Text
typeDocName _ = Proxy x -> Text
forall x. ExtensibleHasDoc x => Proxy x -> Text
extensibleDocName (Proxy x
forall k (t :: k). Proxy t
Proxy @x)
  typeDocMdReference :: Proxy (Extensible x) -> WithinParens -> Builder
typeDocMdReference p :: Proxy (Extensible x)
p (WithinParens wp :: Bool
wp) =
    let name :: Text
name = Proxy (Extensible x) -> Text
forall a. TypeHasDoc a => Proxy a -> Text
typeDocName Proxy (Extensible x)
p
        safeName :: Text
safeName = case (Char -> Bool) -> Text -> Maybe Char
T.find Char -> Bool
isSpace Text
name of
          Nothing -> Text
name
          Just _
            | Bool
wp -> "(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"
            | Bool
otherwise -> Text
name
    in (Text, DType) -> [DType] -> WithinParens -> Builder
customTypeDocMdReference (Text
safeName, Proxy (Extensible x) -> DType
forall a. TypeHasDoc a => Proxy a -> DType
DType Proxy (Extensible x)
p) [] (Bool -> WithinParens
WithinParens Bool
False)
  typeDocDependencies :: Proxy (Extensible x) -> [SomeDocDefinitionItem]
typeDocDependencies _ = Proxy x -> [SomeDocDefinitionItem]
forall x. ExtensibleHasDoc x => Proxy x -> [SomeDocDefinitionItem]
extensibleDocDependencies (Proxy x
forall k (t :: k). Proxy t
Proxy @x)
  typeDocHaskellRep :: TypeDocHaskellRep (Extensible x)
typeDocHaskellRep = TypeDocHaskellRep (Extensible x)
forall a. (Generic a, GTypeHasDoc (Rep a)) => TypeDocHaskellRep a
homomorphicTypeDocHaskellRep
  typeDocMichelsonRep :: TypeDocMichelsonRep (Extensible x)
typeDocMichelsonRep = TypeDocMichelsonRep (Extensible x)
forall a. SingI (ToT a) => TypeDocMichelsonRep a
homomorphicTypeDocMichelsonRep
  typeDocMdDescription :: Builder
typeDocMdDescription = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
    [ ExtensibleHasDoc x => Builder
forall x. ExtensibleHasDoc x => Builder
extensibleDocMdDescription @x
    , "\n\n"
    , "For extensibility purposes this type is represented as `(idx, pack param)`, \
      \where `idx` is a natural number which designates constructor used to \
      \make up given value, and `param` is the argument carried in that \
      \constructor.\n\n"
    , "To unwrap value from its `Extensible` representation in Haskell, one should use \
      \`fromExtVal` function provided by `Lorentz.Extensible` module. \
      \This function tries to unwrap an event and may fail if the representation is \
      \invalid (i.e. if it fails to find the corresponding constructor or if the \
      \parameter can not be unpacked.\n\n"
    , "Value must be one of:\n\n"
    , [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder) -> [Builder] -> Builder
forall a b. (a -> b) -> a -> b
$
        (Builder -> Builder) -> [Builder] -> [Builder]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Prelude.map (Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> "\n\n") ([Builder] -> [Builder]) -> [Builder] -> [Builder]
forall a b. (a -> b) -> a -> b
$
        (forall (a :: Ctor). DocumentCtor a => Proxy a -> Builder)
-> [Builder]
forall k (c :: k -> Constraint) (l :: [k]) r.
ReifyList c l =>
(forall (a :: k). c a => Proxy a -> r) -> [r]
reifyList @Ctor @DocumentCtor @(EnumerateCtors (GetCtors x)) forall (a :: Ctor). DocumentCtor a => Proxy a -> Builder
documentCtor
    ]