{-# options_haddock prune #-}

-- |Utilities for writing messagepack codec instances.
module Ribosome.Host.Class.Msgpack.Util where

import Data.MessagePack (Object (..))
import Exon (exon)
import Generics.SOP (All2, Top)
import Generics.SOP.GGP (GCode, GFrom, GTo)
import Type.Reflection (typeRep)

import Ribosome.Host.Class.Msgpack.Error (
  DecodeError,
  FieldError (FieldError),
  incompatible,
  incompatibleCon,
  toDecodeError,
  )

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

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

newtype ValidUtf8 =
  ValidUtf8 { ValidUtf8 -> Text
unValidUtf8 :: Text }
  deriving stock (ValidUtf8 -> ValidUtf8 -> Bool
(ValidUtf8 -> ValidUtf8 -> Bool)
-> (ValidUtf8 -> ValidUtf8 -> Bool) -> Eq ValidUtf8
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidUtf8 -> ValidUtf8 -> Bool
$c/= :: ValidUtf8 -> ValidUtf8 -> Bool
== :: ValidUtf8 -> ValidUtf8 -> Bool
$c== :: ValidUtf8 -> ValidUtf8 -> Bool
Eq, Int -> ValidUtf8 -> ShowS
[ValidUtf8] -> ShowS
ValidUtf8 -> String
(Int -> ValidUtf8 -> ShowS)
-> (ValidUtf8 -> String)
-> ([ValidUtf8] -> ShowS)
-> Show ValidUtf8
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidUtf8] -> ShowS
$cshowList :: [ValidUtf8] -> ShowS
show :: ValidUtf8 -> String
$cshow :: ValidUtf8 -> String
showsPrec :: Int -> ValidUtf8 -> ShowS
$cshowsPrec :: Int -> ValidUtf8 -> ShowS
Show)
  deriving newtype (String -> ValidUtf8
(String -> ValidUtf8) -> IsString ValidUtf8
forall a. (String -> a) -> IsString a
fromString :: String -> ValidUtf8
$cfromString :: String -> ValidUtf8
IsString, Eq ValidUtf8
Eq ValidUtf8
-> (ValidUtf8 -> ValidUtf8 -> Ordering)
-> (ValidUtf8 -> ValidUtf8 -> Bool)
-> (ValidUtf8 -> ValidUtf8 -> Bool)
-> (ValidUtf8 -> ValidUtf8 -> Bool)
-> (ValidUtf8 -> ValidUtf8 -> Bool)
-> (ValidUtf8 -> ValidUtf8 -> ValidUtf8)
-> (ValidUtf8 -> ValidUtf8 -> ValidUtf8)
-> Ord ValidUtf8
ValidUtf8 -> ValidUtf8 -> Bool
ValidUtf8 -> ValidUtf8 -> Ordering
ValidUtf8 -> ValidUtf8 -> ValidUtf8
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ValidUtf8 -> ValidUtf8 -> ValidUtf8
$cmin :: ValidUtf8 -> ValidUtf8 -> ValidUtf8
max :: ValidUtf8 -> ValidUtf8 -> ValidUtf8
$cmax :: ValidUtf8 -> ValidUtf8 -> ValidUtf8
>= :: ValidUtf8 -> ValidUtf8 -> Bool
$c>= :: ValidUtf8 -> ValidUtf8 -> Bool
> :: ValidUtf8 -> ValidUtf8 -> Bool
$c> :: ValidUtf8 -> ValidUtf8 -> Bool
<= :: ValidUtf8 -> ValidUtf8 -> Bool
$c<= :: ValidUtf8 -> ValidUtf8 -> Bool
< :: ValidUtf8 -> ValidUtf8 -> Bool
$c< :: ValidUtf8 -> ValidUtf8 -> Bool
compare :: ValidUtf8 -> ValidUtf8 -> Ordering
$ccompare :: ValidUtf8 -> ValidUtf8 -> Ordering
Ord)

newtype ValidUtf8String =
  ValidUtf8String { ValidUtf8String -> String
unValidUtf8String :: String }
  deriving stock (ValidUtf8String -> ValidUtf8String -> Bool
(ValidUtf8String -> ValidUtf8String -> Bool)
-> (ValidUtf8String -> ValidUtf8String -> Bool)
-> Eq ValidUtf8String
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValidUtf8String -> ValidUtf8String -> Bool
$c/= :: ValidUtf8String -> ValidUtf8String -> Bool
== :: ValidUtf8String -> ValidUtf8String -> Bool
$c== :: ValidUtf8String -> ValidUtf8String -> Bool
Eq, Int -> ValidUtf8String -> ShowS
[ValidUtf8String] -> ShowS
ValidUtf8String -> String
(Int -> ValidUtf8String -> ShowS)
-> (ValidUtf8String -> String)
-> ([ValidUtf8String] -> ShowS)
-> Show ValidUtf8String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValidUtf8String] -> ShowS
$cshowList :: [ValidUtf8String] -> ShowS
show :: ValidUtf8String -> String
$cshow :: ValidUtf8String -> String
showsPrec :: Int -> ValidUtf8String -> ShowS
$cshowsPrec :: Int -> ValidUtf8String -> ShowS
Show)
  deriving newtype (String -> ValidUtf8String
(String -> ValidUtf8String) -> IsString ValidUtf8String
forall a. (String -> a) -> IsString a
fromString :: String -> ValidUtf8String
$cfromString :: String -> ValidUtf8String
IsString, Eq ValidUtf8String
Eq ValidUtf8String
-> (ValidUtf8String -> ValidUtf8String -> Ordering)
-> (ValidUtf8String -> ValidUtf8String -> Bool)
-> (ValidUtf8String -> ValidUtf8String -> Bool)
-> (ValidUtf8String -> ValidUtf8String -> Bool)
-> (ValidUtf8String -> ValidUtf8String -> Bool)
-> (ValidUtf8String -> ValidUtf8String -> ValidUtf8String)
-> (ValidUtf8String -> ValidUtf8String -> ValidUtf8String)
-> Ord ValidUtf8String
ValidUtf8String -> ValidUtf8String -> Bool
ValidUtf8String -> ValidUtf8String -> Ordering
ValidUtf8String -> ValidUtf8String -> ValidUtf8String
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ValidUtf8String -> ValidUtf8String -> ValidUtf8String
$cmin :: ValidUtf8String -> ValidUtf8String -> ValidUtf8String
max :: ValidUtf8String -> ValidUtf8String -> ValidUtf8String
$cmax :: ValidUtf8String -> ValidUtf8String -> ValidUtf8String
>= :: ValidUtf8String -> ValidUtf8String -> Bool
$c>= :: ValidUtf8String -> ValidUtf8String -> Bool
> :: ValidUtf8String -> ValidUtf8String -> Bool
$c> :: ValidUtf8String -> ValidUtf8String -> Bool
<= :: ValidUtf8String -> ValidUtf8String -> Bool
$c<= :: ValidUtf8String -> ValidUtf8String -> Bool
< :: ValidUtf8String -> ValidUtf8String -> Bool
$c< :: ValidUtf8String -> ValidUtf8String -> Bool
compare :: ValidUtf8String -> ValidUtf8String -> Ordering
$ccompare :: ValidUtf8String -> ValidUtf8String -> Ordering
Ord)

maybeByteString :: Object -> Maybe ByteString
maybeByteString :: Object -> Maybe ByteString
maybeByteString = \case
  ObjectString ByteString
os ->
    ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
os
  ObjectBinary ByteString
os ->
    ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
os
  Object
_ ->
    Maybe ByteString
forall a. Maybe a
Nothing

maybeString :: Object -> Maybe String
maybeString :: Object -> Maybe String
maybeString =
  (ByteString -> String) -> Maybe ByteString -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (Maybe ByteString -> Maybe String)
-> (Object -> Maybe ByteString) -> Object -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Maybe ByteString
maybeByteString

-- |Extract a 'String' from an 'Object'.
pattern MsgpackString :: String -> Object
pattern $mMsgpackString :: forall {r}. Object -> (String -> r) -> (Void# -> r) -> r
MsgpackString s <- (maybeString -> Just s)

-- |Call the continuation if the 'Object' contains a 'ByteString', or an error otherwise.
byteStringField ::
  Typeable a =>
  (ByteString -> Either FieldError a) ->
  Object ->
  Either FieldError a
byteStringField :: forall a.
Typeable a =>
(ByteString -> Either FieldError a)
-> Object -> Either FieldError a
byteStringField ByteString -> Either FieldError a
decode = \case
  ObjectString ByteString
os ->
    ByteString -> Either FieldError a
decode ByteString
os
  ObjectBinary ByteString
os ->
    ByteString -> Either FieldError a
decode ByteString
os
  Object
o ->
    Object -> Either FieldError a
forall a. Typeable a => Object -> Either FieldError a
incompatible Object
o

-- |Decode a 'ByteString' field using 'IsString'.
stringField ::
  Typeable a =>
  IsString a =>
  Object ->
  Either FieldError a
stringField :: forall a. (Typeable a, IsString a) => Object -> Either FieldError a
stringField =
  (ByteString -> Either FieldError a)
-> Object -> Either FieldError a
forall a.
Typeable a =>
(ByteString -> Either FieldError a)
-> Object -> Either FieldError a
byteStringField (a -> Either FieldError a
forall a b. b -> Either a b
Right (a -> Either FieldError a)
-> (ByteString -> a) -> ByteString -> Either FieldError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a
forall a. IsString a => String -> a
fromString (String -> a) -> (ByteString -> String) -> ByteString -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8)

-- |Decode a 'ByteString' type using 'IsString'.
decodeString ::
  Typeable a =>
  IsString a =>
  Object ->
  Either DecodeError a
decodeString :: forall a.
(Typeable a, IsString a) =>
Object -> Either DecodeError a
decodeString =
  Either FieldError a -> Either DecodeError a
forall a. Typeable a => Either FieldError a -> Either DecodeError a
toDecodeError (Either FieldError a -> Either DecodeError a)
-> (Object -> Either FieldError a)
-> Object
-> Either DecodeError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Either FieldError a
forall a. (Typeable a, IsString a) => Object -> Either FieldError a
stringField

-- |Decode a 'ByteString' type using 'IsString'.
decodeByteString ::
  Typeable a =>
  (ByteString -> Either FieldError a) ->
  Object ->
  Either DecodeError a
decodeByteString :: forall a.
Typeable a =>
(ByteString -> Either FieldError a)
-> Object -> Either DecodeError a
decodeByteString ByteString -> Either FieldError a
f =
  Either FieldError a -> Either DecodeError a
forall a. Typeable a => Either FieldError a -> Either DecodeError a
toDecodeError (Either FieldError a -> Either DecodeError a)
-> (Object -> Either FieldError a)
-> Object
-> Either DecodeError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Either FieldError a)
-> Object -> Either FieldError a
forall a.
Typeable a =>
(ByteString -> Either FieldError a)
-> Object -> Either FieldError a
byteStringField ByteString -> Either FieldError a
f

-- |Decode a 'ByteString' type using 'ConvertUtf8'.
decodeUtf8Lenient ::
  Typeable a =>
  ConvertUtf8 a ByteString =>
  Object ->
  Either DecodeError a
decodeUtf8Lenient :: forall a.
(Typeable a, ConvertUtf8 a ByteString) =>
Object -> Either DecodeError a
decodeUtf8Lenient =
  (ByteString -> Either FieldError a)
-> Object -> Either DecodeError a
forall a.
Typeable a =>
(ByteString -> Either FieldError a)
-> Object -> Either DecodeError a
decodeByteString (a -> Either FieldError a
forall a b. b -> Either a b
Right (a -> Either FieldError a)
-> (ByteString -> a) -> ByteString -> Either FieldError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> a
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8)

-- |Decode a 'ByteString' field using 'Read'.
readField ::
  ∀ a .
  Read a =>
  Typeable a =>
  String ->
  Either FieldError a
readField :: forall a. (Read a, Typeable a) => String -> Either FieldError a
readField String
s =
  (Text -> FieldError) -> Either Text a -> Either FieldError a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> FieldError
err (String -> Either Text a
forall a. Read a => String -> Either Text a
readEither String
s)
  where
    err :: Text -> FieldError
err Text
_ =
      Text -> FieldError
FieldError [exon|Got #{toText s} for #{show (typeRep @a)}|]

-- |Decode a numeric or string field using 'Integral' or 'Read'.
integralField ::
  ∀ a .
  Read a =>
  Integral a =>
  Typeable a =>
  Object ->
  Either FieldError a
integralField :: forall a.
(Read a, Integral a, Typeable a) =>
Object -> Either FieldError a
integralField = \case
  ObjectInt Int64
i ->
    a -> Either FieldError a
forall a b. b -> Either a b
Right (Int64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i)
  ObjectUInt Word64
i ->
    a -> Either FieldError a
forall a b. b -> Either a b
Right (Word64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i)
  MsgpackString String
s ->
    String -> Either FieldError a
forall a. (Read a, Typeable a) => String -> Either FieldError a
readField String
s
  Object
o ->
    Object -> Either FieldError a
forall a. Typeable a => Object -> Either FieldError a
incompatible Object
o

-- |Decode a numeric or string type using 'Integral' or 'Read'.
decodeIntegral ::
  ∀ a .
  Read a =>
  Integral a =>
  Typeable a =>
  Object ->
  Either DecodeError a
decodeIntegral :: forall a.
(Read a, Integral a, Typeable a) =>
Object -> Either DecodeError a
decodeIntegral =
  Either FieldError a -> Either DecodeError a
forall a. Typeable a => Either FieldError a -> Either DecodeError a
toDecodeError (Either FieldError a -> Either DecodeError a)
-> (Object -> Either FieldError a)
-> Object
-> Either DecodeError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Either FieldError a
forall a.
(Read a, Integral a, Typeable a) =>
Object -> Either FieldError a
integralField

-- |Decode a numeric or string field using 'Fractional' or 'Read'.
fractionalField ::
  Read a =>
  Typeable a =>
  Fractional a =>
  Object ->
  Either FieldError a
fractionalField :: forall a.
(Read a, Typeable a, Fractional a) =>
Object -> Either FieldError a
fractionalField = \case
  ObjectFloat Float
a ->
    a -> Either FieldError a
forall a b. b -> Either a b
Right (Float -> a
forall a b. (Real a, Fractional b) => a -> b
realToFrac Float
a)
  ObjectDouble Double
a ->
    a -> Either FieldError a
forall a b. b -> Either a b
Right (Double -> a
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
a)
  ObjectInt Int64
i ->
    a -> Either FieldError a
forall a b. b -> Either a b
Right (Int64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i)
  ObjectUInt Word64
i ->
    a -> Either FieldError a
forall a b. b -> Either a b
Right (Word64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i)
  MsgpackString String
s ->
    String -> Either FieldError a
forall a. (Read a, Typeable a) => String -> Either FieldError a
readField String
s
  Object
o ->
    Object -> Either FieldError a
forall a. Typeable a => Object -> Either FieldError a
incompatible Object
o

-- |Decode a numeric or string type using 'Fractional' or 'Read'.
decodeFractional ::
  ∀ a .
  Read a =>
  Fractional a =>
  Typeable a =>
  Object ->
  Either DecodeError a
decodeFractional :: forall a.
(Read a, Fractional a, Typeable a) =>
Object -> Either DecodeError a
decodeFractional =
  Either FieldError a -> Either DecodeError a
forall a. Typeable a => Either FieldError a -> Either DecodeError a
toDecodeError (Either FieldError a -> Either DecodeError a)
-> (Object -> Either FieldError a)
-> Object
-> Either DecodeError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Either FieldError a
forall a.
(Read a, Typeable a, Fractional a) =>
Object -> Either FieldError a
fractionalField

withArray ::
  Text ->
  ([Object] -> Either FieldError a) ->
  Object ->
  Either FieldError a
withArray :: forall a.
Text
-> ([Object] -> Either FieldError a)
-> Object
-> Either FieldError a
withArray Text
target [Object] -> Either FieldError a
f = \case
  ObjectArray [Object]
elems ->
    [Object] -> Either FieldError a
f [Object]
elems
  Object
o ->
    Text -> Object -> Either FieldError a
forall a. Text -> Object -> Either FieldError a
incompatibleCon Text
target Object
o

encodeString ::
  ConvertUtf8 a ByteString =>
  a ->
  Object
encodeString :: forall a. ConvertUtf8 a ByteString => a -> Object
encodeString =
  ByteString -> Object
ObjectString (ByteString -> Object) -> (a -> ByteString) -> a -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8

encodeBinary ::
  ConvertUtf8 a ByteString =>
  a ->
  Object
encodeBinary :: forall a. ConvertUtf8 a ByteString => a -> Object
encodeBinary =
  ByteString -> Object
ObjectBinary (ByteString -> Object) -> (a -> ByteString) -> a -> Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8