{-# 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.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
$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))
IsoValue, AnnOptions
FollowEntrypointFlag -> Notes (ToT (Extensible x))
(FollowEntrypointFlag -> Notes (ToT (Extensible x)))
-> AnnOptions -> HasAnnotation (Extensible x)
forall a.
(FollowEntrypointFlag -> Notes (ToT a))
-> AnnOptions -> HasAnnotation a
forall k (x :: k). AnnOptions
forall k (x :: k).
FollowEntrypointFlag -> Notes (ToT (Extensible x))
annOptions :: AnnOptions
$cannOptions :: forall k (x :: k). AnnOptions
getAnnotation :: FollowEntrypointFlag -> Notes (ToT (Extensible x))
$cgetAnnotation :: forall k (x :: k).
FollowEntrypointFlag -> Notes (ToT (Extensible x))
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 = (Generic x, GExtVal x (G.Rep x))
type GetCtors x = GGetCtors (G.Rep x)
toExtVal :: ExtVal a => a -> Extensible a
toExtVal :: forall a. ExtVal a => 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
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 (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
class WrapExt (cf :: CtorField) where
packForWrap :: AppendCtorField cf s :-> ByteString : s
instance (NicePackedValue param) =>
WrapExt ('OneField param) where
packForWrap :: forall (s :: [*]).
AppendCtorField ('OneField param) s :-> (ByteString : s)
packForWrap = 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
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 :: Nat) (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 :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal (forall {k} (t :: k). Proxy t
forall {t :: Nat}. 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 :: [*]).
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
)
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 Natural
idx ->
Builder
"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. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" was not found in the sum type \
\constructors list"
ExtConversionError
ArgumentUnpackFailed ->
Builder
"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)
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")
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
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
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)
-> (M1 D i x p -> x p) -> M1 D i x p -> Extensible t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 D 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 -> M1 D i x p)
-> Either ExtConversionError (x p)
-> Either ExtConversionError (M1 D i x p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap x p -> M1 D 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 :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal (forall {k} (t :: k). Proxy t
forall {t :: Nat}. 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 :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal (forall {k} (t :: k). Proxy t
forall {t :: Nat}. Proxy t
Proxy @n)
= M1 C ('MetaCons name _1 _2) U1 p
-> Either ExtConversionError (M1 C ('MetaCons name _1 _2) U1 p)
forall a b. b -> Either a b
Right (M1 C ('MetaCons name _1 _2) U1 p
-> Either ExtConversionError (M1 C ('MetaCons name _1 _2) U1 p))
-> M1 C ('MetaCons name _1 _2) U1 p
-> Either ExtConversionError (M1 C ('MetaCons name _1 _2) U1 p)
forall a b. (a -> b) -> a -> b
$ U1 p -> M1 C ('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 (M1 C ('MetaCons name _1 _2) U1 p)
forall a b. a -> Either a b
Left (ExtConversionError
-> Either ExtConversionError (M1 C ('MetaCons name _1 _2) U1 p))
-> ExtConversionError
-> Either ExtConversionError (M1 C ('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 :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal (forall {k} (t :: k). Proxy t
forall {t :: Nat}. 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 :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal (forall {k} (t :: k). Proxy t
forall {t :: Nat}. Proxy t
Proxy @n)
= (UnpackError -> ExtConversionError)
-> Either
UnpackError (M1 C ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p)
-> Either
ExtConversionError
(M1 C ('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 (\UnpackError
_ -> ExtConversionError
ArgumentUnpackFailed) (Either
UnpackError (M1 C ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p)
-> Either
ExtConversionError
(M1 C ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p))
-> Either
UnpackError (M1 C ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p)
-> Either
ExtConversionError
(M1 C ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p)
forall a b. (a -> b) -> a -> b
$
(param -> M1 C ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p)
-> Either UnpackError param
-> Either
UnpackError (M1 C ('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
-> M1 C ('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
-> M1 C ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p)
-> (param -> M1 S _3 (Rec0 param) p)
-> param
-> M1 C ('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 (M1 C ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p))
-> Either UnpackError param
-> Either
UnpackError (M1 C ('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
(M1 C ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p)
forall a b. a -> Either a b
Left (ExtConversionError
-> Either
ExtConversionError
(M1 C ('MetaCons name _1 _2) (S1 _3 (Rec0 param)) p))
-> ExtConversionError
-> Either
ExtConversionError
(M1 C ('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 (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 (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
class Typeable x => ExtensibleHasDoc x where
extensibleDocName :: Proxy x -> Text
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
extensibleDocMdDescription :: Markdown
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 ('Ctor pos name field)
_ =
Proxy pos -> Natural
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal (forall {k} (t :: k). Proxy t
forall {t :: Nat}. Proxy t
Proxy @pos) Natural -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
": " 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
$ forall (s :: Symbol). KnownSymbol s => Text
symbolValT' @name) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Proxy param -> WithinParens -> Builder
forall a. TypeHasDoc a => Proxy a -> WithinParens -> Builder
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 -> Builder
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 -> 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 (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 (Rep a)) => TypeDocHaskellRep a
homomorphicTypeDocHaskellRep
typeDocMichelsonRep :: TypeDocMichelsonRep (Extensible x)
typeDocMichelsonRep = TypeDocMichelsonRep (Extensible x)
forall a. KnownIsoT a => TypeDocMichelsonRep a
homomorphicTypeDocMichelsonRep
typeDocMdDescription :: Builder
typeDocMdDescription = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat
[ forall x. ExtensibleHasDoc x => Builder
extensibleDocMdDescription @x
, Builder
"\n\n"
, Builder
"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"
, Builder
"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"
, Builder
"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
<> Builder
"\n\n") ([Builder] -> [Builder]) -> [Builder] -> [Builder]
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)) forall (a :: Ctor). DocumentCtor a => Proxy a -> Builder
documentCtor
]