-- SPDX-FileCopyrightText: 2021 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{- | 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
-}

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

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

import Data.Char (isSpace)
import Data.Text qualified as T
import Fmt (Buildable(build), (+|), (|+))
import GHC.Generics ((:+:)(..))
import GHC.Generics qualified 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 Morley.AsRPC (HasRPCRepr(..))
import Morley.Michelson.Typed
import Morley.Util.Generic
import Morley.Util.Label (Label)
import Morley.Util.Markdown
import Morley.Util.Type
import Morley.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
$cfrom :: forall k (x :: k) x. Extensible x -> Rep (Extensible x) x
from :: forall x. Extensible x -> Rep (Extensible x) x
$cto :: forall k (x :: k) x. Rep (Extensible x) x -> Extensible x
to :: forall x. Rep (Extensible x) x -> Extensible 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
$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
/= :: 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
$cshowsPrec :: forall k (x :: k). Int -> Extensible x -> ShowS
showsPrec :: Int -> Extensible x -> ShowS
$cshow :: forall k (x :: k). Extensible x -> String
show :: Extensible x -> String
$cshowList :: forall k (x :: k). [Extensible x] -> ShowS
showList :: [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))
$ctoVal :: forall k (x :: k). Extensible x -> Value (ToT (Extensible x))
toVal :: Extensible x -> Value (ToT (Extensible x))
$cfromVal :: forall k (x :: k). Value (ToT (Extensible x)) -> Extensible x
fromVal :: Value (ToT (Extensible x)) -> Extensible x
IsoValue, Maybe AnnOptions
FollowEntrypointFlag -> Notes (ToT (Extensible x))
(FollowEntrypointFlag -> Notes (ToT (Extensible x)))
-> Maybe AnnOptions -> HasAnnotation (Extensible x)
forall a.
(FollowEntrypointFlag -> Notes (ToT a))
-> Maybe AnnOptions -> HasAnnotation a
forall k (x :: k). Maybe AnnOptions
forall k (x :: k).
FollowEntrypointFlag -> Notes (ToT (Extensible x))
$cgetAnnotation :: forall k (x :: k).
FollowEntrypointFlag -> Notes (ToT (Extensible x))
getAnnotation :: FollowEntrypointFlag -> Notes (ToT (Extensible x))
$cannOptions :: forall k (x :: k). Maybe AnnOptions
annOptions :: Maybe AnnOptions
HasAnnotation, ToT (Extensible x) ~ ToT (Unwrappabled (Extensible x))
(ToT (Extensible x) ~ ToT (Unwrappabled (Extensible x)))
-> Unwrappable (Extensible x)
forall s. (ToT s ~ ToT (Unwrappabled s)) -> Unwrappable s
forall {k} {x :: k}.
ToT (Extensible x) ~ ToT (Unwrappabled (Extensible x))
Unwrappable)

instance HasRPCRepr (Extensible x) where
  type AsRPC (Extensible x) = Extensible x

type ExtVal x = (NiceGeneric x, GExtVal x (GRep x))
type GetCtors x = GGetCtors (GRep 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 :: forall a. ExtVal a => a -> Extensible a
toExtVal = Rep a Any -> Extensible a
forall p. Rep a p -> 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 x. a -> Rep a x
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 :: forall a. ExtVal a => Extensible a -> Either ExtConversionError a
fromExtVal Extensible a
val = (Rep a Any -> a)
-> Either ExtConversionError (Rep a Any)
-> Either ExtConversionError a
forall a b.
(a -> b)
-> Either ExtConversionError a -> Either ExtConversionError b
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
forall x. 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 p. Extensible a -> Either ExtConversionError (Rep a p)
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 :: forall (s :: [*]).
AppendCtorField ('OneField param) s :-> (ByteString : s)
packForWrap = (param : s) :-> (ByteString : s)
AppendCtorField ('OneField param) s :-> (ByteString : s)
forall a (s :: [*]).
NicePackedValue a =>
(a : s) :-> (ByteString : s)
packRaw

instance WrapExt 'NoFields where
  packForWrap :: forall (s :: [*]). 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)
packRaw

-- | 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 :: forall t (n :: Natural) (name :: Symbol) (field :: CtorField)
       (s :: [*]).
WrapExtC t n name field s =>
Label (AppendSymbol "c" name)
-> AppendCtorField field s :-> (Extensible t : s)
wrapExt Label (AppendSymbol "c" name)
_ = 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 :: Natural) (proxy :: Natural -> *).
KnownNat n =>
proxy n -> Natural
natVal (forall (t :: Natural). Proxy t
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)
(Unwrappabled (Extensible t) : s) :-> (Extensible t : s)
forall a (s :: [*]).
Unwrappable a =>
(Unwrappabled a : s) :-> (a : s)
unsafeCoerceWrap

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
$c== :: ExtConversionError -> ExtConversionError -> Bool
== :: ExtConversionError -> ExtConversionError -> Bool
$c/= :: ExtConversionError -> ExtConversionError -> Bool
/= :: 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
$cshowsPrec :: Int -> ExtConversionError -> ShowS
showsPrec :: Int -> ExtConversionError -> ShowS
$cshow :: ExtConversionError -> String
show :: ExtConversionError -> String
$cshowList :: [ExtConversionError] -> ShowS
showList :: [ExtConversionError] -> ShowS
Show)

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

data Position = Position Nat
data Ctor = Ctor { Ctor -> Natural
_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 :: Type -> 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 :: Type -> 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 :: forall p. D1 i x p -> Extensible t
gToExtVal = forall (t :: k) (x :: * -> *) p. GExtVal t x => x p -> Extensible t
forall {k} (t :: k) (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 k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
G.unM1
  gFromExtVal :: forall p. Extensible t -> Either ExtConversionError (D1 i x p)
gFromExtVal Extensible t
val = (x p -> D1 i x p)
-> Either ExtConversionError (x p)
-> Either ExtConversionError (D1 i x p)
forall a b.
(a -> b)
-> Either ExtConversionError a -> Either ExtConversionError b
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 (forall (t :: k) (x :: * -> *) p.
GExtVal t x =>
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 :: forall p. C1 ('MetaCons name _1 _2) U1 p -> Extensible t
gToExtVal (G.M1 U1 p
G.U1) = (Natural, ByteString) -> Extensible t
forall {k} (x :: k). (Natural, ByteString) -> Extensible x
Extensible
    ( Proxy n -> Natural
forall (n :: Natural) (proxy :: Natural -> *).
KnownNat n =>
proxy n -> Natural
natVal (forall (t :: Natural). Proxy t
forall {k} (t :: k). Proxy t
Proxy @n)
    , () -> ByteString
forall a. NicePackedValue a => a -> ByteString
lPackValueRaw ()
    )
  gFromExtVal :: forall p.
Extensible t
-> Either ExtConversionError (C1 ('MetaCons name _1 _2) U1 p)
gFromExtVal (Extensible (Natural
idx, ByteString
_))
    | Natural
idx Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy n -> Natural
forall (n :: Natural) (proxy :: Natural -> *).
KnownNat n =>
proxy n -> Natural
natVal (forall (t :: Natural). Proxy t
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 :: forall p.
C1 ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p -> Extensible t
gToExtVal (G.M1 (G.M1 (G.K1 param
param))) = (Natural, ByteString) -> Extensible t
forall {k} (x :: k). (Natural, ByteString) -> Extensible x
Extensible
    ( Proxy n -> Natural
forall (n :: Natural) (proxy :: Natural -> *).
KnownNat n =>
proxy n -> Natural
natVal (forall (t :: Natural). Proxy t
forall {k} (t :: k). Proxy t
Proxy @n)
    , param -> ByteString
forall a. NicePackedValue a => a -> ByteString
lPackValueRaw param
param
    )
  gFromExtVal :: forall p.
Extensible t
-> Either
     ExtConversionError
     (C1 ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p)
gFromExtVal (Extensible (Natural
idx, ByteString
bs))
    | Natural
idx Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Proxy n -> Natural
forall (n :: Natural) (proxy :: Natural -> *).
KnownNat n =>
proxy n -> Natural
natVal (forall (t :: Natural). Proxy t
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 a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\UnpackError
_ -> 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 a b.
(a -> b) -> Either UnpackError a -> Either UnpackError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (S1 _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 (S1 _3 (Rec0 param) p
 -> C1 ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p)
-> (param -> S1 _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
. Rec0 param p -> S1 _3 (Rec0 param) p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
G.M1 (Rec0 param p -> S1 _3 (Rec0 param) p)
-> (param -> Rec0 param p) -> param -> S1 _3 (Rec0 param) p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. param -> Rec0 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
$ forall a. NiceUnpackedValue a => ByteString -> Either UnpackError a
lUnpackValueRaw @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 :: forall p. (:+:) x y p -> Extensible t
gToExtVal = \case
    G.L1 x p
x -> let Extensible (Natural, ByteString)
val = forall (t :: k) (x :: * -> *) p. GExtVal t x => 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 p
y -> let Extensible (Natural, ByteString)
val = forall (t :: k) (x :: * -> *) p. GExtVal t x => x 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 :: forall p. Extensible t -> Either ExtConversionError ((:+:) x y p)
gFromExtVal 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 a b.
(a -> b)
-> Either ExtConversionError a -> Either ExtConversionError b
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 (forall (t :: k) (x :: * -> *) p.
GExtVal t x =>
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 a b.
(a -> b)
-> Either ExtConversionError a -> Either ExtConversionError b
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 (forall (t :: k) (x :: * -> *) p.
GExtVal t x =>
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)
    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 (GRep x))
    => Proxy x -> [SomeDocDefinitionItem]
  extensibleDocDependencies = Proxy x -> [SomeDocDefinitionItem]
forall a.
(Generic a, GTypeHasDoc (GRep 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) -> Doc
documentCtor Proxy ('Ctor pos name field)
_ =
    Proxy pos -> Natural
forall (n :: Natural) (proxy :: Natural -> *).
KnownNat n =>
proxy n -> Natural
natVal (forall (t :: Natural). Proxy t
forall {k} (t :: k). Proxy t
Proxy @pos) Natural -> Doc -> Doc
forall a b. (Buildable a, FromDoc b) => a -> Doc -> b
|+ Doc
": " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> Doc
mdBold (Text -> Doc
forall a. Buildable a => a -> Doc
build (Text -> Doc) -> Text -> Doc
forall a b. (a -> b) -> a -> b
$ forall (s :: Symbol). KnownSymbol s => Text
symbolValT' @name) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
    Doc
" " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Proxy param -> WithinParens -> Doc
forall a. TypeHasDoc a => Proxy a -> WithinParens -> Doc
typeDocMdReference (forall t. Proxy t
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 (Extensible x)
_ = Proxy x -> Text
forall x. ExtensibleHasDoc x => Proxy x -> Text
extensibleDocName (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @x)
  typeDocMdReference :: Proxy (Extensible x) -> WithinParens -> Doc
typeDocMdReference Proxy (Extensible x)
p (WithinParens 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
          Maybe Char
Nothing -> Text
name
          Just Char
_
            | Bool
wp -> Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
            | Bool
otherwise -> Text
name
    in (Text, DType) -> [DType] -> WithinParens -> Doc
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 (Extensible x)
_ = Proxy x -> [SomeDocDefinitionItem]
forall x. ExtensibleHasDoc x => Proxy x -> [SomeDocDefinitionItem]
extensibleDocDependencies (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @x)
  typeDocHaskellRep :: TypeDocHaskellRep (Extensible x)
typeDocHaskellRep = TypeDocHaskellRep (Extensible x)
forall a. (Generic a, GTypeHasDoc (GRep a)) => TypeDocHaskellRep a
homomorphicTypeDocHaskellRep
  typeDocMichelsonRep :: TypeDocMichelsonRep (Extensible x)
typeDocMichelsonRep = TypeDocMichelsonRep (Extensible x)
forall a. KnownIsoT a => TypeDocMichelsonRep a
homomorphicTypeDocMichelsonRep
  typeDocMdDescription :: Doc
typeDocMdDescription = [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat
    [ forall x. ExtensibleHasDoc x => Doc
extensibleDocMdDescription @x
    , Doc
"\n\n"
    , Doc
"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"
    , Doc
"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"
    , Doc
"Value must be one of:\n\n"
    , [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
        (Doc -> Doc) -> [Doc] -> [Doc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Prelude.map (Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
"\n\n") ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$
        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)) Proxy a -> Doc
forall (a :: Ctor). DocumentCtor a => Proxy a -> Doc
documentCtor
    ]