{-# options_haddock prune #-}

-- |Encoding values to MessagePack format
module Ribosome.Host.Class.Msgpack.Encode where

import qualified Data.List.NonEmpty as NonEmpty (toList)
import qualified Data.Map.Strict as Map (fromList, toList)
import Data.MessagePack (Object (..))
import GHC.Generics (
  C1,
  Constructor,
  D1,
  K1 (..),
  M1 (..),
  Rep,
  S1,
  Selector,
  conIsRecord,
  from,
  selName,
  (:*:) (..),
  (:+:) (..),
  )
import Path (Path, toFilePath)
import Time (MicroSeconds, MilliSeconds (unMilliSeconds), NanoSeconds (unNanoSeconds), Seconds, unMicroSeconds, unSeconds)

import qualified Ribosome.Host.Class.Msgpack.Util as Util (assembleMap, string, text)

-- |Class of values that can be encoded to MessagePack 'Object's.
class MsgpackEncode a where
  -- |Convert a value to MessagePack.
  --
  -- The default implementation uses generic derivation.
  toMsgpack :: a -> Object
  default toMsgpack :: (Generic a, GMsgpackEncode (Rep a)) => a -> Object
  toMsgpack = Rep a Any -> Object
forall {k} (f :: k -> *) (a :: k).
GMsgpackEncode f =>
f a -> Object
gMsgpackEncode (Rep a Any -> Object) -> (a -> Rep a Any) -> a -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from

class GMsgpackEncode f where
  gMsgpackEncode :: f a -> Object

class MsgpackEncodeProd f where
  msgpackEncodeRecord :: f a -> [(String, Object)]
  msgpackEncodeProd :: f a -> [Object]

instance GMsgpackEncode f => GMsgpackEncode (D1 c f) where
  gMsgpackEncode :: forall (a :: k). D1 c f a -> Object
gMsgpackEncode = f a -> Object
forall {k} (f :: k -> *) (a :: k).
GMsgpackEncode f =>
f a -> Object
gMsgpackEncode (f a -> Object) -> (M1 D c f a -> f a) -> M1 D c f a -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 D c f a -> f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1

prodOrNewtype :: MsgpackEncodeProd f => f a -> Object
prodOrNewtype :: forall {k} (f :: k -> *) (a :: k).
MsgpackEncodeProd f =>
f a -> Object
prodOrNewtype =
  [Object] -> Object
wrap ([Object] -> Object) -> (f a -> [Object]) -> f a -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> [Object]
forall {k} (f :: k -> *) (a :: k).
MsgpackEncodeProd f =>
f a -> [Object]
msgpackEncodeProd
  where
    wrap :: [Object] -> Item [Object]
wrap [Item [Object]
a] = Item [Object]
a
    wrap [Object]
as = [Object] -> Object
ObjectArray [Object]
as

instance (Constructor c, MsgpackEncodeProd f) => GMsgpackEncode (C1 c f) where
  gMsgpackEncode :: forall (a :: k). C1 c f a -> Object
gMsgpackEncode C1 c f a
c =
    f a -> Object
f (f a -> Object) -> f a -> Object
forall a b. (a -> b) -> a -> b
$ C1 c f a -> f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). M1 i c f p -> f p
unM1 C1 c f a
c
    where
      f :: f a -> Object
f = if C1 c f a -> Bool
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
conIsRecord C1 c f a
c then [(String, Object)] -> Object
Util.assembleMap ([(String, Object)] -> Object)
-> (f a -> [(String, Object)]) -> f a -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> [(String, Object)]
forall {k} (f :: k -> *) (a :: k).
MsgpackEncodeProd f =>
f a -> [(String, Object)]
msgpackEncodeRecord else f a -> Object
forall {k} (f :: k -> *) (a :: k).
MsgpackEncodeProd f =>
f a -> Object
prodOrNewtype

instance (MsgpackEncodeProd f, MsgpackEncodeProd g) => MsgpackEncodeProd (f :*: g) where
  msgpackEncodeRecord :: forall (a :: k). (:*:) f g a -> [(String, Object)]
msgpackEncodeRecord (f a
f :*: g a
g) = f a -> [(String, Object)]
forall {k} (f :: k -> *) (a :: k).
MsgpackEncodeProd f =>
f a -> [(String, Object)]
msgpackEncodeRecord f a
f [(String, Object)] -> [(String, Object)] -> [(String, Object)]
forall a. Semigroup a => a -> a -> a
<> g a -> [(String, Object)]
forall {k} (f :: k -> *) (a :: k).
MsgpackEncodeProd f =>
f a -> [(String, Object)]
msgpackEncodeRecord g a
g
  msgpackEncodeProd :: forall (a :: k). (:*:) f g a -> [Object]
msgpackEncodeProd (f a
f :*: g a
g) = f a -> [Object]
forall {k} (f :: k -> *) (a :: k).
MsgpackEncodeProd f =>
f a -> [Object]
msgpackEncodeProd f a
f [Object] -> [Object] -> [Object]
forall a. Semigroup a => a -> a -> a
<> g a -> [Object]
forall {k} (f :: k -> *) (a :: k).
MsgpackEncodeProd f =>
f a -> [Object]
msgpackEncodeProd g a
g

instance (GMsgpackEncode f, GMsgpackEncode g) => GMsgpackEncode (f :+: g) where
  gMsgpackEncode :: forall (a :: k). (:+:) f g a -> Object
gMsgpackEncode (L1 f a
a) = f a -> Object
forall {k} (f :: k -> *) (a :: k).
GMsgpackEncode f =>
f a -> Object
gMsgpackEncode f a
a
  gMsgpackEncode (R1 g a
a) = g a -> Object
forall {k} (f :: k -> *) (a :: k).
GMsgpackEncode f =>
f a -> Object
gMsgpackEncode g a
a

instance (Selector s, GMsgpackEncode f) => MsgpackEncodeProd (S1 s f) where
  msgpackEncodeRecord :: forall (a :: k). S1 s f a -> [(String, Object)]
msgpackEncodeRecord s :: S1 s f a
s@(M1 f a
f) =
    [((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char
'_' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) (S1 s f a -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName S1 s f a
s), f a -> Object
forall {k} (f :: k -> *) (a :: k).
GMsgpackEncode f =>
f a -> Object
gMsgpackEncode f a
f), (S1 s f a -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName S1 s f a
s, f a -> Object
forall {k} (f :: k -> *) (a :: k).
GMsgpackEncode f =>
f a -> Object
gMsgpackEncode f a
f)]
  msgpackEncodeProd :: forall (a :: k). S1 s f a -> [Object]
msgpackEncodeProd (M1 f a
f) = [f a -> Object
forall {k} (f :: k -> *) (a :: k).
GMsgpackEncode f =>
f a -> Object
gMsgpackEncode f a
f]

instance MsgpackEncode a => GMsgpackEncode (K1 i a) where
  gMsgpackEncode :: forall (a :: k). K1 i a a -> Object
gMsgpackEncode = a -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack (a -> Object) -> (K1 i a a -> a) -> K1 i a a -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K1 i a a -> a
forall k i c (p :: k). K1 i c p -> c
unK1

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
Util.string

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 a. NonEmpty a -> [a]
NonEmpty.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
Util.text

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