{-# OPTIONS_GHC -fno-warn-orphans #-} module Ribosome.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 qualified Ribosome.Msgpack.Util as Util (assembleMap, string, text) class MsgpackEncode a where 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 :: D1 c f a -> Object gMsgpackEncode = f a -> Object forall k (f :: k -> *) (a :: k). GMsgpackEncode f => f a -> Object gMsgpackEncode (f a -> Object) -> (D1 c f a -> f a) -> D1 c f a -> Object forall b c a. (b -> c) -> (a -> b) -> a -> c . D1 c f a -> f a forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p unM1 prodOrNewtype :: MsgpackEncodeProd f => f a -> Object prodOrNewtype :: 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] -> Object wrap [Item [Object] a] = Item [Object] Object a wrap [Object] as = [Object] -> Object ObjectArray [Object] as instance (Constructor c, MsgpackEncodeProd f) => GMsgpackEncode (C1 c f) where gMsgpackEncode :: 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 i (c :: Meta) k (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 :: (:*:) 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 :: (:*:) 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 :: (:+:) 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 :: 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 :: 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 :: 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 i c k (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 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 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 (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 IsString Object where fromString :: String -> Object fromString = ByteString -> Object ObjectString (ByteString -> Object) -> (String -> ByteString) -> String -> Object forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> ByteString forall a b. ConvertUtf8 a b => a -> b encodeUtf8