module Ribosome.Host.Class.Msgpack.Encode where

import qualified Data.Map.Strict as Map
import Data.MessagePack (
  Object (ObjectArray, ObjectBool, ObjectDouble, ObjectFloat, ObjectInt, ObjectMap, ObjectNil, ObjectString),
  )
import Generics.SOP (All, I (I), K (K), NP (Nil, (:*)), NS (S, Z), SOP (SOP), hcmap, hcollapse, unI, unSOP)
import Generics.SOP.GGP (GCode, GDatatypeInfoOf, gfrom)
import Generics.SOP.Type.Metadata (
  ConstructorInfo (Constructor, Record),
  DatatypeInfo (ADT, Newtype),
  FieldInfo (FieldInfo),
  )
import Path (Path, toFilePath)
import Time (
  MicroSeconds (unMicroSeconds),
  MilliSeconds (unMilliSeconds),
  NanoSeconds (unNanoSeconds),
  Seconds (unSeconds),
  )

import Ribosome.Host.Class.Msgpack.Util (ConstructSOP, ValidUtf8, encodeString, unValidUtf8)
import Ribosome.Host.Class.Msgpack.Error (DecodeError, FieldError)

class EncodeRecord (fields :: [FieldInfo]) (as :: [Type]) where
  encodeRecord :: NP I as -> [(Object, Object)]

instance EncodeRecord '[] '[] where
  encodeRecord :: NP I '[] -> [(Object, Object)]
encodeRecord NP I '[]
Nil =
    []

instance (
    KnownSymbol name,
    MsgpackEncode a,
    EncodeRecord fields as
  ) => EncodeRecord ('FieldInfo name : fields) (a : as) where
    encodeRecord :: NP I (a : as) -> [(Object, Object)]
encodeRecord (I x
a :* NP I xs
fields) =
      (ByteString -> Object
ObjectString (String -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (Proxy name -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @name))), x -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack x
a) (Object, Object) -> [(Object, Object)] -> [(Object, Object)]
forall a. a -> [a] -> [a]
: forall (fields :: [FieldInfo]) (as :: [*]).
EncodeRecord fields as =>
NP I as -> [(Object, Object)]
encodeRecord @fields NP I xs
fields

class EncodeCtor (ctor :: ConstructorInfo) (as :: [Type]) where
  encodeCtor :: NP I as -> Object

instance (
    All MsgpackEncode as
  ) => EncodeCtor ('Constructor name) as where
    encodeCtor :: NP I as -> Object
encodeCtor NP I as
ctor =
      [Object] -> Object
ObjectArray (NP (K Object) as -> CollapseTo NP Object
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (Proxy MsgpackEncode
-> (forall a. MsgpackEncode a => I a -> K Object a)
-> NP I as
-> NP (K Object) as
forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcmap (forall {k} (t :: k). Proxy t
forall {t :: * -> Constraint}. Proxy t
Proxy @MsgpackEncode) (Object -> K Object a
forall k a (b :: k). a -> K a b
K (Object -> K Object a) -> (I a -> Object) -> I a -> K Object a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack (a -> Object) -> (I a -> a) -> I a -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. I a -> a
forall a. I a -> a
unI) NP I as
ctor))

instance (
    EncodeRecord fields as
  ) => EncodeCtor ('Record name fields) as where
    encodeCtor :: NP I as -> Object
encodeCtor NP I as
ctor =
      Map Object Object -> Object
ObjectMap ([(Object, Object)] -> Map Object Object
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall (fields :: [FieldInfo]) (as :: [*]).
EncodeRecord fields as =>
NP I as -> [(Object, Object)]
encodeRecord @fields NP I as
ctor))

class EncodeCtors (ctors :: [ConstructorInfo]) (ass :: [[Type]]) where
  encodeCtors :: NS (NP I) ass -> Object

instance (
    EncodeCtor ctor as
  ) => EncodeCtors '[ctor] '[as] where
    encodeCtors :: NS (NP I) '[as] -> Object
encodeCtors = \case
      Z NP I x
ctor -> forall (ctor :: ConstructorInfo) (as :: [*]).
EncodeCtor ctor as =>
NP I as -> Object
encodeCtor @ctor NP I x
ctor
      S NS (NP I) xs
ctors -> case NS (NP I) xs
ctors of

instance (
    EncodeCtor ctor as,
    EncodeCtors (ctor1 : ctors) ass
  ) => EncodeCtors (ctor : ctor1 : ctors) (as : ass) where
    encodeCtors :: NS (NP I) (as : ass) -> Object
encodeCtors = \case
      Z NP I x
ctor -> forall (ctor :: ConstructorInfo) (as :: [*]).
EncodeCtor ctor as =>
NP I as -> Object
encodeCtor @ctor NP I x
ctor
      S NS (NP I) xs
ctors -> forall (ctors :: [ConstructorInfo]) (ass :: [[*]]).
EncodeCtors ctors ass =>
NS (NP I) ass -> Object
encodeCtors @(ctor1 : ctors) NS (NP I) xs
ctors

class GMsgpackEncode (dt :: DatatypeInfo) (ass :: [[Type]]) where
  gtoMsgpack :: SOP I ass -> Object

instance (
    EncodeCtors ctors ass
  ) => GMsgpackEncode ('ADT mod name ctors strictness) ass where
  gtoMsgpack :: SOP I ass -> Object
gtoMsgpack =
      forall (ctors :: [ConstructorInfo]) (ass :: [[*]]).
EncodeCtors ctors ass =>
NS (NP I) ass -> Object
encodeCtors @ctors @ass (NS (NP I) ass -> Object)
-> (SOP I ass -> NS (NP I) ass) -> SOP I ass -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SOP I ass -> NS (NP I) ass
forall {k} (f :: k -> *) (xss :: [[k]]). SOP f xss -> NS (NP f) xss
unSOP

instance (
    MsgpackEncode a
  ) => GMsgpackEncode ('Newtype mod name ctor) '[ '[a]] where
    gtoMsgpack :: SOP I '[ '[a]] -> Object
gtoMsgpack (SOP (Z (I x
a :* NP I xs
Nil))) =
      x -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack x
a
    gtoMsgpack (SOP (S NS (NP I) xs
ns)) =
      case NS (NP I) xs
ns of

-- |Class of values that can be encoded to MessagePack 'Object's.
class MsgpackEncode a where
  -- |Encode a value to MessagePack.
    --
  -- The default implementation uses generic derivation.
  toMsgpack :: a -> Object

  default toMsgpack ::
    ConstructSOP a ass =>
    GMsgpackEncode (GDatatypeInfoOf a) (GCode a) =>
    a ->
    Object
  toMsgpack =
    forall (dt :: DatatypeInfo) (ass :: [[*]]).
GMsgpackEncode dt ass =>
SOP I ass -> Object
gtoMsgpack @(GDatatypeInfoOf a) (SOP I ass -> Object) -> (a -> SOP I ass) -> a -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SOP I ass
forall a. (GFrom a, Generic a) => a -> SOP I (GCode a)
gfrom

instance (
    MsgpackEncode k,
    MsgpackEncode v
  ) => MsgpackEncode (Map k v) where
  toMsgpack :: Map k v -> Object
toMsgpack = Map Object Object -> Object
ObjectMap (Map Object Object -> Object)
-> (Map k v -> Map Object Object) -> Map k v -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Object, Object)] -> Map Object Object
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Object, Object)] -> Map Object Object)
-> (Map k v -> [(Object, Object)]) -> Map k v -> Map Object Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((k, v) -> (Object, Object)) -> [(k, v)] -> [(Object, Object)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((k -> Object) -> (v -> Object) -> (k, v) -> (Object, Object)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap k -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack v -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack) ([(k, v)] -> [(Object, Object)])
-> (Map k v -> [(k, v)]) -> Map k v -> [(Object, Object)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k v -> [(k, v)]
forall k a. Map k a -> [(k, a)]
Map.toList

instance MsgpackEncode Integer where
  toMsgpack :: Integer -> Object
toMsgpack =
    Int64 -> Object
ObjectInt (Int64 -> Object) -> (Integer -> Int64) -> Integer -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int64
forall a. Num a => Integer -> a
fromInteger

instance MsgpackEncode Int where
  toMsgpack :: Int -> Object
toMsgpack =
    Int64 -> Object
ObjectInt (Int64 -> Object) -> (Int -> Int64) -> Int -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance MsgpackEncode Int64 where
  toMsgpack :: Int64 -> Object
toMsgpack =
    Int64 -> Object
ObjectInt

instance MsgpackEncode Float where
  toMsgpack :: Float -> Object
toMsgpack =
    Float -> Object
ObjectFloat

instance MsgpackEncode Double where
  toMsgpack :: Double -> Object
toMsgpack =
    Double -> Object
ObjectDouble

instance {-# overlapping #-} MsgpackEncode String where
  toMsgpack :: String -> Object
toMsgpack =
    String -> Object
forall a. ConvertUtf8 a ByteString => a -> Object
encodeString

instance {-# overlappable #-} MsgpackEncode a => MsgpackEncode [a] where
  toMsgpack :: [a] -> Object
toMsgpack =
    [Object] -> Object
ObjectArray ([Object] -> Object) -> ([a] -> [Object]) -> [a] -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Object) -> [a] -> [Object]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack

instance MsgpackEncode a => MsgpackEncode (NonEmpty a) where
  toMsgpack :: NonEmpty a -> Object
toMsgpack =
    [a] -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack ([a] -> Object) -> (NonEmpty a -> [a]) -> NonEmpty a -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

instance MsgpackEncode a => MsgpackEncode (Seq a) where
  toMsgpack :: Seq a -> Object
toMsgpack =
    [a] -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack ([a] -> Object) -> (Seq a -> [a]) -> Seq a -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

instance MsgpackEncode Text where
  toMsgpack :: Text -> Object
toMsgpack =
    Text -> Object
forall a. ConvertUtf8 a ByteString => a -> Object
encodeString

instance MsgpackEncode ValidUtf8 where
  toMsgpack :: ValidUtf8 -> Object
toMsgpack =
    Text -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack (Text -> Object) -> (ValidUtf8 -> Text) -> ValidUtf8 -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidUtf8 -> Text
unValidUtf8

instance MsgpackEncode a => MsgpackEncode (Maybe a) where
  toMsgpack :: Maybe a -> Object
toMsgpack =
    Object -> (a -> Object) -> Maybe a -> Object
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Object
ObjectNil a -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack

instance MsgpackEncode Bool where
  toMsgpack :: Bool -> Object
toMsgpack =
    Bool -> Object
ObjectBool

instance MsgpackEncode () where
  toMsgpack :: () -> Object
toMsgpack ()
_ =
    Object
ObjectNil

instance MsgpackEncode Object where
  toMsgpack :: Object -> Object
toMsgpack =
    Object -> Object
forall a. a -> a
id

instance MsgpackEncode ByteString where
  toMsgpack :: ByteString -> Object
toMsgpack =
    ByteString -> Object
ObjectString

instance (MsgpackEncode a, MsgpackEncode b) => MsgpackEncode (a, b) where
  toMsgpack :: (a, b) -> Object
toMsgpack (a
a, b
b) =
    [Object] -> Object
ObjectArray [a -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack a
a, b -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack b
b]

instance (MsgpackEncode a, MsgpackEncode b, MsgpackEncode c) => MsgpackEncode (a, b, c) where
  toMsgpack :: (a, b, c) -> Object
toMsgpack (a
a, b
b, c
c) =
    [Object] -> Object
ObjectArray [a -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack a
a, b -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack b
b, c -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack c
c]

instance MsgpackEncode (Path b t) where
  toMsgpack :: Path b t -> Object
toMsgpack =
    ByteString -> Object
ObjectString (ByteString -> Object)
-> (Path b t -> ByteString) -> Path b t -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (String -> ByteString)
-> (Path b t -> String) -> Path b t -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path b t -> String
forall b t. Path b t -> String
toFilePath

instance MsgpackEncode NanoSeconds where
  toMsgpack :: NanoSeconds -> Object
toMsgpack =
    Int64 -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack (Int64 -> Object)
-> (NanoSeconds -> Int64) -> NanoSeconds -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NanoSeconds -> Int64
unNanoSeconds

instance MsgpackEncode MicroSeconds where
  toMsgpack :: MicroSeconds -> Object
toMsgpack =
    Int64 -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack (Int64 -> Object)
-> (MicroSeconds -> Int64) -> MicroSeconds -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MicroSeconds -> Int64
unMicroSeconds

instance MsgpackEncode MilliSeconds where
  toMsgpack :: MilliSeconds -> Object
toMsgpack =
    Int64 -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack (Int64 -> Object)
-> (MilliSeconds -> Int64) -> MilliSeconds -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MilliSeconds -> Int64
unMilliSeconds

instance MsgpackEncode Seconds where
  toMsgpack :: Seconds -> Object
toMsgpack =
    Int64 -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack (Int64 -> Object) -> (Seconds -> Int64) -> Seconds -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seconds -> Int64
unSeconds

deriving anyclass instance MsgpackEncode FieldError

deriving anyclass instance MsgpackEncode DecodeError