{-# 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 Data.Typeable (Proxy(..))
import Data.Vinyl.Derived (Label)
import Data.Vinyl.TypeLevel (type (++))
import Fmt (Buildable(build), (+||), (|+), (||+))
import GHC.Generics ((:+:)(..))
import qualified GHC.Generics as G
import GHC.TypeLits (AppendSymbol, Nat, Symbol)
import GHC.TypeNats (type (+))
import Lorentz.Base
import Lorentz.Coercions
import Lorentz.Constraints
import Lorentz.Instr
import Lorentz.Pack
import Michelson.Typed
import Util.Markdown
import Util.Type
import Util.TypeLits
newtype Extensible x = Extensible (Natural, ByteString)
deriving stock (Generic, Eq, Show)
deriving anyclass (IsoValue)
instance Wrapped (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 = gToExtVal . G.from
fromExtVal :: ExtVal a => Extensible a -> Either ExtConversionError a
fromExtVal val = fmap G.to $ gFromExtVal val
class WrapExt (cf :: CtorField) where
packForWrap :: AppendCtorField cf s :-> ByteString : s
instance (NicePackedValue param) =>
WrapExt ('OneField param) where
packForWrap = pack
instance WrapExt 'NoFields where
packForWrap = unit # pack
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 _ = packForWrap @field # push (natVal (Proxy @n)) # pair # coerceWrap
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 (Eq, Show)
instance Buildable ExtConversionError where
build =
\case
ConstructorIndexNotFound idx ->
"Could not convert Extensible value into its Haskell representation: \
\constructor #" +|| idx ||+ " 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 { _n :: Nat, _name :: Symbol, _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 :: 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
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 = gToExtVal @t . G.unM1
gFromExtVal val = fmap G.M1 (gFromExtVal @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 (G.M1 G.U1) = Extensible
( natVal (Proxy @n)
, lPackValue ()
)
gFromExtVal (Extensible (idx, _))
| idx == natVal (Proxy @n)
= Right $ G.M1 G.U1
| otherwise = Left $ ConstructorIndexNotFound 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 (G.M1 (G.M1 (G.K1 param))) = Extensible
( natVal (Proxy @n)
, lPackValue param
)
gFromExtVal (Extensible (idx, bs))
| idx == natVal (Proxy @n)
= first (\_ -> ArgumentUnpackFailed) $
fmap (G.M1 . G.M1 . G.K1) $ lUnpackValue @param bs
| otherwise = Left $ ConstructorIndexNotFound idx
instance (GExtVal t x, GExtVal t y) => GExtVal t (x :+: y) where
gToExtVal = \case
G.L1 x -> let Extensible val = gToExtVal @t x in Extensible val
G.R1 y -> let Extensible val = gToExtVal @t y in Extensible val
gFromExtVal val =
let l = fmap G.L1 (gFromExtVal @t val)
r = fmap G.R1 (gFromExtVal @t val)
in l <> r
class Typeable x => ExtensibleHasDoc x where
extensibleDocName :: Proxy x -> Text
extensibleDocDependencies :: Proxy x -> [SomeTypeWithDoc]
default extensibleDocDependencies
:: (Generic x, GTypeHasDoc (G.Rep x))
=> Proxy x -> [SomeTypeWithDoc]
extensibleDocDependencies = 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 _ =
natVal (Proxy @pos) |+ ": " <> mdBold (build $ symbolValT' @name) <>
" " <> typeDocMdReference (Proxy @param) (WithinParens True)
instance ( ExtensibleHasDoc x
, ReifyList DocumentCtor (EnumerateCtors (GetCtors x))
) => TypeHasDoc (Extensible x) where
typeDocName _ = extensibleDocName (Proxy @x)
typeDocMdReference p (WithinParens wp) =
let name = typeDocName p
safeName = case T.find isSpace name of
Nothing -> name
Just _
| wp -> "(" <> name <> ")"
| otherwise -> name
in customTypeDocMdReference (safeName, DType p) [] (WithinParens False)
typeDocDependencies _ = extensibleDocDependencies (Proxy @x)
typeDocHaskellRep = homomorphicTypeDocHaskellRep
typeDocMichelsonRep = homomorphicTypeDocMichelsonRep
typeDocMdDescription = mconcat
[ 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"
, "Value must be one of:\n\n"
, mconcat $
Prelude.map (<> "\n\n") $
reifyList @Ctor @DocumentCtor @(EnumerateCtors (GetCtors x)) documentCtor
]