module Ribosome.Host.Class.Msgpack.DecodeSOP where

import Data.MessagePack (Object (..))
import Generics.SOP (All2, I (I), NP (Nil, (:*)), NS (Z), SOP (SOP), Top)
import Generics.SOP.GGP (GCode, GDatatypeInfoOf, GFrom, GTo, gto)
import Generics.SOP.Type.Metadata (ConstructorInfo, DatatypeInfo (ADT, Newtype))

type ReifySOP (d :: Type) (dss :: [[Type]]) =
  (Generic d, GTo d, GCode d ~ dss, All2 Top dss)

type ConstructSOP (d :: Type) (dss :: [[Type]]) =
  (Generic d, GFrom d, GCode d ~ dss, All2 Top dss)

class MsgpackCtor (ctor :: ConstructorInfo) (as :: [Type]) where

class MsgpackCtors (ctors :: [ConstructorInfo]) (ass :: [[Type]]) where
  msgpackCtors :: Object -> Either Text (SOP I ass)

class GMsgpackDecode (dt :: DatatypeInfo) (ass :: [[Type]]) where
  gMsgpackDecode :: Object -> Either Text (SOP I ass)

instance (
    MsgpackDecode a
  ) => GMsgpackDecode ('Newtype mod name ctor) '[ '[a]] where
    gMsgpackDecode :: Object -> Either Text (SOP I '[ '[a]])
gMsgpackDecode Object
o = do
      a
a <- Object -> Either Text a
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpack Object
o
      pure (NS (NP I) '[ '[a]] -> SOP I '[ '[a]]
forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP (NP I '[a] -> NS (NP I) '[ '[a]]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (a -> I a
forall a. a -> I a
I a
a I a -> NP I '[] -> NP I '[a]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP I '[]
forall {k} (a :: k -> *). NP a '[]
Nil)))

instance (
    MsgpackCtors ctors ass
  ) => GMsgpackDecode ('ADT mod name ctors strictness) ass where
  gMsgpackDecode :: Object -> Either Text (SOP I ass)
gMsgpackDecode =
      forall (ctors :: [ConstructorInfo]) (ass :: [[*]]).
MsgpackCtors ctors ass =>
Object -> Either Text (SOP I ass)
msgpackCtors @ctors

class MsgpackDecode a where
  fromMsgpack :: Object -> Either Text a
  default fromMsgpack ::
    ConstructSOP a ass =>
    ReifySOP a ass =>
    GMsgpackDecode (GDatatypeInfoOf a) (GCode a) =>
    Object ->
    Either Text a
  fromMsgpack =
    (SOP I ass -> a) -> Either Text (SOP I ass) -> Either Text a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SOP I ass -> a
forall a. (GTo a, Generic a) => SOP I (GCode a) -> a
gto (Either Text (SOP I ass) -> Either Text a)
-> (Object -> Either Text (SOP I ass)) -> Object -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (dt :: DatatypeInfo) (ass :: [[*]]).
GMsgpackDecode dt ass =>
Object -> Either Text (SOP I ass)
gMsgpackDecode @(GDatatypeInfoOf a)

  -- missingKey :: String -> Object -> Either Text a
  -- missingKey = Util.missingRecordKey

pattern Msgpack :: ∀ a . MsgpackDecode a => a -> Object
pattern $mMsgpack :: forall {r} {a}.
MsgpackDecode a =>
Object -> (a -> r) -> (Void# -> r) -> r
Msgpack a <- (fromMsgpack -> Right a)