{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Michelson.Typed.Haskell.LooseSum
( ComposeResult (..)
, fromTaggedVal
, toTaggedVal
, LooseSumC
) where
import qualified Data.Kind as Kind
import Data.Singletons (SingI)
import Data.Typeable (TypeRep, Typeable, cast, typeRep)
import GHC.Generics ((:*:), (:+:))
import qualified GHC.Generics as G
import Michelson.Typed.Aliases
import Michelson.Typed.Haskell.Value
import Michelson.Typed.T
import Michelson.Typed.Value
import Util.TypeLits
data ComposeResult a
= ComposeOk a
| ComposeCtorNotFound
| ComposeFieldTypeMismatch TypeRep TypeRep
deriving stock (Functor)
instance Semigroup (ComposeResult a) where
r@(ComposeOk _) <> _ = r
_ <> r@(ComposeOk _) = r
r@(ComposeFieldTypeMismatch _ _) <> _ = r
_ <> r@(ComposeFieldTypeMismatch _ _) = r
r@ComposeCtorNotFound <> ComposeCtorNotFound = r
instance Monoid (ComposeResult a) where
mempty = ComposeCtorNotFound
mappend = (<>)
type LooseSumC dt =
( Generic dt, GLooseSum (G.Rep dt)
)
toTaggedVal :: LooseSumC dt => dt -> (Text, SomeValue)
toTaggedVal = gToTaggedVal . G.from
fromTaggedVal :: LooseSumC dt => (Text, SomeValue) -> ComposeResult dt
fromTaggedVal = fmap G.to . gFromTaggedVal
class GLooseSum (x :: Kind.Type -> Kind.Type) where
gToTaggedVal :: x p -> (Text, SomeValue)
gFromTaggedVal :: (Text, SomeValue) -> ComposeResult (x p)
instance GLooseSum x => GLooseSum (G.D1 i x) where
gToTaggedVal = gToTaggedVal . G.unM1
gFromTaggedVal = fmap G.M1 . gFromTaggedVal
instance (GLooseSum x, GLooseSum y) => GLooseSum (x :+: y) where
gToTaggedVal = \case
G.L1 x -> gToTaggedVal x
G.R1 y -> gToTaggedVal y
gFromTaggedVal v = mconcat
[ G.L1 <$> gFromTaggedVal v
, G.R1 <$> gFromTaggedVal v
]
instance (GAccessField x, KnownSymbol ctor) =>
GLooseSum (G.C1 ('G.MetaCons ctor f o) x) where
gToTaggedVal = (symbolValT' @ctor, ) . gExtractField @x . G.unM1
gFromTaggedVal (ctor, val)
| symbolValT' @ctor == ctor = G.M1 <$> gMakeField @x val
| otherwise = ComposeCtorNotFound
instance GLooseSum G.V1 where
gToTaggedVal = \case{}
gFromTaggedVal _ = mempty
class GAccessField (x :: Kind.Type -> Kind.Type) where
gExtractField :: x p -> SomeValue
gMakeField :: SomeValue -> ComposeResult (x p)
instance GAccessField x => GAccessField (G.S1 i x) where
gExtractField = gExtractField . G.unM1
gMakeField v = G.M1 <$> gMakeField @x v
instance (Typeable a, IsoValue a, Typeable (ToT a), SingI (ToT a)) =>
GAccessField (G.Rec0 a) where
gExtractField = SomeValue . toVal . G.unK1
gMakeField (SomeValue v) = G.K1 . fromVal <$> composeCast v
instance GAccessField G.U1 where
gExtractField G.U1 = SomeValue $ toVal ()
gMakeField (SomeValue v) = G.U1 <$ composeCast @_ @'TUnit v
composeCast :: forall a b. (Typeable a, Typeable b) => Value a -> ComposeResult (Value b)
composeCast a =
case cast a of
Nothing -> ComposeFieldTypeMismatch (typeRep (Proxy @a)) (typeRep (Proxy @b))
Just b -> ComposeOk b
instance
TypeError ('Text "Cannot compose/decompose constructors with more \
\than one field" ':$$:
'Text "Consider using tuple instead") =>
GAccessField (x :*: y) where
gExtractField = error "impossible"
gMakeField = error "impossible"