{-# options_haddock prune #-}

-- |The class for decoding messagepack.
module Ribosome.Host.Class.Msgpack.Decode where

import qualified Data.Map.Strict as Map
import Data.MessagePack (Object (..))
import Exon (exon)
import Generics.SOP (I (I), NP (Nil, (:*)), NS (S, Z), SOP (SOP))
import Generics.SOP.GGP (GCode, GDatatypeInfoOf, gto)
import Generics.SOP.Type.Metadata (
  ConstructorInfo (Constructor, Infix, Record),
  DatatypeInfo (ADT, Newtype),
  FieldInfo (FieldInfo),
  )
import Path (Abs, Dir, File, Path, Rel, parseAbsDir, parseAbsFile, parseRelDir, parseRelFile)
import Time (MicroSeconds, MilliSeconds, NanoSeconds, Seconds (Seconds))

import Ribosome.Host.Class.Msgpack.Error (
  DecodeError,
  FieldError (FieldError, NestedFieldError),
  decodeIncompatible,
  incompatible,
  incompatibleCon,
  incompatibleShape,
  renderError,
  symbolText,
  toDecodeError,
  utf8Error,
  )
import Ribosome.Host.Class.Msgpack.Util (
  ReifySOP,
  ValidUtf8 (ValidUtf8),
  ValidUtf8String (ValidUtf8String),
  decodeByteString,
  decodeFractional,
  decodeIntegral,
  decodeUtf8Lenient,
  )

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

-- |Class of values that can be decoded from MessagePack 'Object's.
class MsgpackDecode a where
  -- |Decode a value from a MessagePack 'Object'.
    --
  -- The default implementation uses generic derivation.
  fromMsgpack :: Object -> Either DecodeError a
  default fromMsgpack ::
    Typeable a =>
    ReifySOP a ass =>
    GMsgpackDecode (GDatatypeInfoOf a) (GCode a) =>
    Object ->
    Either DecodeError a
  fromMsgpack =
    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
. (SOP I ass -> a)
-> Either FieldError (SOP I ass) -> Either FieldError 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 FieldError (SOP I ass) -> Either FieldError a)
-> (Object -> Either FieldError (SOP I ass))
-> Object
-> Either FieldError a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (dt :: DatatypeInfo) (ass :: [[*]]).
GMsgpackDecode dt ass =>
Object -> Either FieldError (SOP I ass)
gfromMsgpack @(GDatatypeInfoOf a)

nestedDecode ::
  MsgpackDecode a =>
  Object ->
  Either FieldError a
nestedDecode :: forall a. MsgpackDecode a => Object -> Either FieldError a
nestedDecode Object
o =
  (DecodeError -> FieldError)
-> Either DecodeError a -> Either FieldError a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first DecodeError -> FieldError
NestedFieldError (Object -> Either DecodeError a
forall a. MsgpackDecode a => Object -> Either DecodeError a
fromMsgpack Object
o)

class DecodeProd (as :: [Type]) where
  decodeProd :: [Object] -> Either FieldError (NP I as)

instance DecodeProd '[] where
  decodeProd :: [Object] -> Either FieldError (NP I '[])
decodeProd = \case
    [] ->
      NP I '[] -> Either FieldError (NP I '[])
forall a b. b -> Either a b
Right NP I '[]
forall {k} (a :: k -> *). NP a '[]
Nil
    [Object]
o ->
      Text -> Text -> Either FieldError (NP I '[])
forall a. Text -> Text -> Either FieldError a
incompatibleShape Text
"product type" [exon|#{show (length o)} extra elements|]

instance (
    MsgpackDecode a,
    DecodeProd as
  ) => DecodeProd (a : as) where
    decodeProd :: [Object] -> Either FieldError (NP I (a : as))
decodeProd = \case
      Object
o : [Object]
os -> do
        a
a <- Object -> Either FieldError a
forall a. MsgpackDecode a => Object -> Either FieldError a
nestedDecode Object
o
        NP I as
as <- [Object] -> Either FieldError (NP I as)
forall (as :: [*]).
DecodeProd as =>
[Object] -> Either FieldError (NP I as)
decodeProd [Object]
os
        pure (a -> I a
forall a. a -> I a
I a
a I a -> NP I as -> NP I (a : as)
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP I as
as)
      [] ->
        Text -> Text -> Either FieldError (NP I (a : as))
forall a. Text -> Text -> Either FieldError a
incompatibleShape Text
"product type" Text
"too few elements"

-- |This class decides what to return when a key in an 'ObjectMap' is missing for a corresponding record field.
--
-- Primarily used for 'Maybe' fields, since they should decode to 'Nothing' when the key is absent.
class MissingKey a where
  -- |Return a fallback value for a missing key in an 'ObjectMap'.
  missingKey :: String -> Map String Object -> Either FieldError a

instance {-# overlappable #-} MissingKey a where
  missingKey :: String -> Map String Object -> Either FieldError a
missingKey String
name Map String Object
_ =
    FieldError -> Either FieldError a
forall a b. a -> Either a b
Left (Text -> FieldError
FieldError [exon|Missing record field '#{toText name}'|])

instance MissingKey (Maybe a) where
  missingKey :: String -> Map String Object -> Either FieldError (Maybe a)
missingKey String
_ Map String Object
_ =
    Maybe a -> Either FieldError (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing

class DecodeRecord (fields :: [FieldInfo]) (as :: [Type]) where
  decodeRecord :: Map String Object -> Either FieldError (NP I as)

instance DecodeRecord '[] '[] where
  decodeRecord :: Map String Object -> Either FieldError (NP I '[])
decodeRecord Map String Object
_ =
    NP I '[] -> Either FieldError (NP I '[])
forall a b. b -> Either a b
Right NP I '[]
forall {k} (a :: k -> *). NP a '[]
Nil

instance (
    KnownSymbol name,
    MsgpackDecode a,
    MissingKey a,
    DecodeRecord fields as
  ) => DecodeRecord ('FieldInfo name : fields) (a : as) where
  decodeRecord :: Map String Object -> Either FieldError (NP I (a : as))
decodeRecord Map String Object
os = do
    a
a <- Either FieldError a
lookupField
    NP I as
as <- forall (fields :: [FieldInfo]) (as :: [*]).
DecodeRecord fields as =>
Map String Object -> Either FieldError (NP I as)
decodeRecord @fields Map String Object
os
    pure (a -> I a
forall a. a -> I a
I a
a I a -> NP I as -> NP I (a : as)
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* NP I as
as)
    where
      lookupField :: Either FieldError a
lookupField =
        case String -> Map String Object -> Maybe Object
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
name Map String Object
os of
          Just Object
o ->
            Object -> Either FieldError a
forall a. MsgpackDecode a => Object -> Either FieldError a
nestedDecode Object
o
          Maybe Object
Nothing ->
            String -> Map String Object -> Either FieldError a
forall a.
MissingKey a =>
String -> Map String Object -> Either FieldError a
missingKey String
name Map String Object
os
      name :: String
name =
        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)

class DecodeCtor (ctor :: ConstructorInfo) (as :: [Type]) where
  decodeCtor :: Object -> Either FieldError (NP I as)

instance (
    KnownSymbol name,
    DecodeProd as
  ) => DecodeCtor ('Constructor name) as where
    decodeCtor :: Object -> Either FieldError (NP I as)
decodeCtor = \case
      ObjectArray [Object]
os ->
        forall (as :: [*]).
DecodeProd as =>
[Object] -> Either FieldError (NP I as)
decodeProd @as [Object]
os
      Object
o ->
        Text -> Object -> Either FieldError (NP I as)
forall a. Text -> Object -> Either FieldError a
incompatibleCon [exon|product constructor #{symbolText @name}|] Object
o

instance (
    KnownSymbol name,
    MsgpackDecode l,
    MsgpackDecode r
  ) => DecodeCtor ('Infix name assoc fixity) [l, r] where
    decodeCtor :: Object -> Either FieldError (NP I '[l, r])
decodeCtor = \case
      ObjectArray [Item [Object]
obl, Item [Object]
obr] -> do
        l
l <- Object -> Either FieldError l
forall a. MsgpackDecode a => Object -> Either FieldError a
nestedDecode Item [Object]
Object
obl
        r
r <- Object -> Either FieldError r
forall a. MsgpackDecode a => Object -> Either FieldError a
nestedDecode Item [Object]
Object
obr
        pure (l -> I l
forall a. a -> I a
I l
l I l -> NP I '[r] -> NP I '[l, r]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]).
a x -> NP a xs -> NP a (x : xs)
:* r -> I r
forall a. a -> I a
I r
r I r -> NP I '[] -> NP I '[r]
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)
      ObjectArray [Object]
os ->
        Text -> Text -> Either FieldError (NP I '[l, r])
forall a. Text -> Text -> Either FieldError a
incompatibleShape Text
desc [exon|Array with #{show (length os)} elements|]
      Object
o ->
        Text -> Object -> Either FieldError (NP I '[l, r])
forall a. Text -> Object -> Either FieldError a
incompatibleCon Text
desc Object
o
      where
        desc :: Text
desc =
          [exon|infix constructor #{symbolText @name}|]

instance (
    KnownSymbol name,
    DecodeRecord fields as
  ) => DecodeCtor ('Record name fields) as where
    decodeCtor :: Object -> Either FieldError (NP I as)
decodeCtor = \case
      Msgpack Map String Object
fields ->
        forall (fields :: [FieldInfo]) (as :: [*]).
DecodeRecord fields as =>
Map String Object -> Either FieldError (NP I as)
decodeRecord @fields @as Map String Object
fields
      ObjectMap Map Object Object
_ ->
        Text -> Text -> Either FieldError (NP I as)
forall a. Text -> Text -> Either FieldError a
incompatibleShape Text
desc Text
"Map with non-string keys"
      Object
o ->
        Text -> Object -> Either FieldError (NP I as)
forall a. Text -> Object -> Either FieldError a
incompatibleCon Text
desc Object
o
      where
        desc :: Text
desc =
          [exon|record constructor #{symbolText @name}|]

class DecodeCtors (ctors :: [ConstructorInfo]) (ass :: [[Type]]) where
  decodeCtors :: Object -> Either FieldError (NS (NP I) ass)

instance (
    DecodeCtor ctor as
  ) => DecodeCtors '[ctor] '[as] where
  decodeCtors :: Object -> Either FieldError (NS (NP I) '[as])
decodeCtors Object
o =
    NP I as -> NS (NP I) '[as]
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z (NP I as -> NS (NP I) '[as])
-> Either FieldError (NP I as)
-> Either FieldError (NS (NP I) '[as])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (ctor :: ConstructorInfo) (as :: [*]).
DecodeCtor ctor as =>
Object -> Either FieldError (NP I as)
decodeCtor @ctor @as Object
o

instance (
    DecodeCtor ctor as,
    DecodeCtors (ctor1 : ctors) (as1 : ass)
  ) => DecodeCtors (ctor : ctor1 : ctors) (as : as1 : ass) where
    decodeCtors :: Object -> Either FieldError (NS (NP I) (as : as1 : ass))
decodeCtors Object
o =
      (FieldError -> Either FieldError (NS (NP I) (as : as1 : ass)))
-> (NP I as -> Either FieldError (NS (NP I) (as : as1 : ass)))
-> Either FieldError (NP I as)
-> Either FieldError (NS (NP I) (as : as1 : ass))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either FieldError (NS (NP I) (as : as1 : ass))
-> FieldError -> Either FieldError (NS (NP I) (as : as1 : ass))
forall a b. a -> b -> a
const (NS (NP I) (as1 : ass) -> NS (NP I) (as : as1 : ass)
forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S (NS (NP I) (as1 : ass) -> NS (NP I) (as : as1 : ass))
-> Either FieldError (NS (NP I) (as1 : ass))
-> Either FieldError (NS (NP I) (as : as1 : ass))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (ctors :: [ConstructorInfo]) (ass :: [[*]]).
DecodeCtors ctors ass =>
Object -> Either FieldError (NS (NP I) ass)
decodeCtors @(ctor1 : ctors) @(as1 : ass) Object
o)) (NS (NP I) (as : as1 : ass)
-> Either FieldError (NS (NP I) (as : as1 : ass))
forall a b. b -> Either a b
Right (NS (NP I) (as : as1 : ass)
 -> Either FieldError (NS (NP I) (as : as1 : ass)))
-> (NP I as -> NS (NP I) (as : as1 : ass))
-> NP I as
-> Either FieldError (NS (NP I) (as : as1 : ass))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NP I as -> NS (NP I) (as : as1 : ass)
forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z) (forall (ctor :: ConstructorInfo) (as :: [*]).
DecodeCtor ctor as =>
Object -> Either FieldError (NP I as)
decodeCtor @ctor @as Object
o)

instance (
    MsgpackDecode a
  ) => GMsgpackDecode ('Newtype mod name ctor) '[ '[a]] where
    gfromMsgpack :: Object -> Either FieldError (SOP I '[ '[a]])
gfromMsgpack Object
o = do
      a
a <- Object -> Either FieldError a
forall a. MsgpackDecode a => Object -> Either FieldError a
nestedDecode 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 (
    DecodeCtors ctors ass
  ) => GMsgpackDecode ('ADT mod name ctors strictness) ass where
  gfromMsgpack :: Object -> Either FieldError (SOP I ass)
gfromMsgpack =
      (NS (NP I) ass -> SOP I ass)
-> Either FieldError (NS (NP I) ass)
-> Either FieldError (SOP I ass)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NS (NP I) ass -> SOP I ass
forall k (f :: k -> *) (xss :: [[k]]). NS (NP f) xss -> SOP f xss
SOP (Either FieldError (NS (NP I) ass)
 -> Either FieldError (SOP I ass))
-> (Object -> Either FieldError (NS (NP I) ass))
-> Object
-> Either FieldError (SOP I ass)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (ctors :: [ConstructorInfo]) (ass :: [[*]]).
DecodeCtors ctors ass =>
Object -> Either FieldError (NS (NP I) ass)
decodeCtors @ctors @ass

instance (
    Ord k,
    Typeable k,
    Typeable v,
    MsgpackDecode k,
    MsgpackDecode v
  ) => MsgpackDecode (Map k v) where
    fromMsgpack :: Object -> Either DecodeError (Map k v)
fromMsgpack = \case
      ObjectMap Map Object Object
om -> do
        [(k, v)] -> Map k v
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(k, v)] -> Map k v)
-> Either DecodeError [(k, v)] -> Either DecodeError (Map k v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Object, Object) -> Either DecodeError (k, v))
-> [(Object, Object)] -> Either DecodeError [(k, v)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Object, Object) -> Either DecodeError (k, v)
forall {a} {b}.
(MsgpackDecode a, MsgpackDecode b) =>
(Object, Object) -> Either DecodeError (a, b)
decodePair (Map Object Object -> [(Object, Object)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Object Object
om)
        where
          decodePair :: (Object, Object) -> Either DecodeError (a, b)
decodePair (Object
k, Object
v) = do
            a
k1 <- Object -> Either DecodeError a
forall a. MsgpackDecode a => Object -> Either DecodeError a
fromMsgpack Object
k
            b
v1 <- Object -> Either DecodeError b
forall a. MsgpackDecode a => Object -> Either DecodeError a
fromMsgpack Object
v
            pure (a
k1, b
v1)
      Object
o ->
        Either FieldError (Map k v) -> Either DecodeError (Map k v)
forall a. Typeable a => Either FieldError a -> Either DecodeError a
toDecodeError (Object -> Either FieldError (Map k v)
forall a. Typeable a => Object -> Either FieldError a
incompatible Object
o)

instance MsgpackDecode Integer where
  fromMsgpack :: Object -> Either DecodeError Integer
fromMsgpack =
    Object -> Either DecodeError Integer
forall a.
(Read a, Integral a, Typeable a) =>
Object -> Either DecodeError a
decodeIntegral

instance MsgpackDecode Int where
  fromMsgpack :: Object -> Either DecodeError Int
fromMsgpack =
    Object -> Either DecodeError Int
forall a.
(Read a, Integral a, Typeable a) =>
Object -> Either DecodeError a
decodeIntegral

instance MsgpackDecode Int64 where
  fromMsgpack :: Object -> Either DecodeError Int64
fromMsgpack =
    Object -> Either DecodeError Int64
forall a.
(Read a, Integral a, Typeable a) =>
Object -> Either DecodeError a
decodeIntegral

instance MsgpackDecode Float where
  fromMsgpack :: Object -> Either DecodeError Float
fromMsgpack =
    Object -> Either DecodeError Float
forall a.
(Read a, Fractional a, Typeable a) =>
Object -> Either DecodeError a
decodeFractional

instance MsgpackDecode Double where
  fromMsgpack :: Object -> Either DecodeError Double
fromMsgpack =
    Object -> Either DecodeError Double
forall a.
(Read a, Fractional a, Typeable a) =>
Object -> Either DecodeError a
decodeFractional

instance {-# overlapping #-} MsgpackDecode String where
  fromMsgpack :: Object -> Either DecodeError String
fromMsgpack =
    Object -> Either DecodeError String
forall a.
(Typeable a, ConvertUtf8 a ByteString) =>
Object -> Either DecodeError a
decodeUtf8Lenient

instance {-# overlappable #-} (
    Typeable a,
    MsgpackDecode a
  ) => MsgpackDecode [a] where
    fromMsgpack :: Object -> Either DecodeError [a]
fromMsgpack = \case
      ObjectArray [Object]
oa ->
        (Object -> Either DecodeError a)
-> [Object] -> Either DecodeError [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Object -> Either DecodeError a
forall a. MsgpackDecode a => Object -> Either DecodeError a
fromMsgpack [Object]
oa
      Object
o ->
        Object -> Either DecodeError [a]
forall a. Typeable a => Object -> Either DecodeError a
decodeIncompatible Object
o

instance MsgpackDecode Text where
  fromMsgpack :: Object -> Either DecodeError Text
fromMsgpack =
    Object -> Either DecodeError Text
forall a.
(Typeable a, ConvertUtf8 a ByteString) =>
Object -> Either DecodeError a
decodeUtf8Lenient

instance MsgpackDecode ValidUtf8 where
  fromMsgpack :: Object -> Either DecodeError ValidUtf8
fromMsgpack =
    (ByteString -> Either FieldError ValidUtf8)
-> Object -> Either DecodeError ValidUtf8
forall a.
Typeable a =>
(ByteString -> Either FieldError a)
-> Object -> Either DecodeError a
decodeByteString ((UnicodeException -> FieldError)
-> (Text -> ValidUtf8)
-> Either UnicodeException Text
-> Either FieldError ValidUtf8
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap UnicodeException -> FieldError
utf8Error Text -> ValidUtf8
ValidUtf8 (Either UnicodeException Text -> Either FieldError ValidUtf8)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> Either FieldError ValidUtf8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
forall a b. ConvertUtf8 a b => b -> Either UnicodeException a
decodeUtf8Strict)

instance MsgpackDecode ValidUtf8String where
  fromMsgpack :: Object -> Either DecodeError ValidUtf8String
fromMsgpack =
    (ByteString -> Either FieldError ValidUtf8String)
-> Object -> Either DecodeError ValidUtf8String
forall a.
Typeable a =>
(ByteString -> Either FieldError a)
-> Object -> Either DecodeError a
decodeByteString ((UnicodeException -> FieldError)
-> (String -> ValidUtf8String)
-> Either UnicodeException String
-> Either FieldError ValidUtf8String
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap UnicodeException -> FieldError
utf8Error String -> ValidUtf8String
ValidUtf8String (Either UnicodeException String
 -> Either FieldError ValidUtf8String)
-> (ByteString -> Either UnicodeException String)
-> ByteString
-> Either FieldError ValidUtf8String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException String
forall a b. ConvertUtf8 a b => b -> Either UnicodeException a
decodeUtf8Strict)

instance MsgpackDecode ByteString where
  fromMsgpack :: Object -> Either DecodeError ByteString
fromMsgpack =
    (ByteString -> Either FieldError ByteString)
-> Object -> Either DecodeError ByteString
forall a.
Typeable a =>
(ByteString -> Either FieldError a)
-> Object -> Either DecodeError a
decodeByteString ByteString -> Either FieldError ByteString
forall a b. b -> Either a b
Right

instance MsgpackDecode Char where
  fromMsgpack :: Object -> Either DecodeError Char
fromMsgpack Object
o =
    (ByteString -> Either FieldError Char)
-> Object -> Either DecodeError Char
forall a.
Typeable a =>
(ByteString -> Either FieldError a)
-> Object -> Either DecodeError a
decodeByteString (String -> Either FieldError Char
check (String -> Either FieldError Char)
-> (ByteString -> String) -> ByteString -> Either FieldError Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8) Object
o
    where
      check :: [Char] -> Either FieldError Char
      check :: String -> Either FieldError Char
check = \case
        [Item String
c] ->
          Char -> Either FieldError Char
forall a b. b -> Either a b
Right Char
Item String
c
        String
_ ->
          FieldError -> Either FieldError Char
forall a b. a -> Either a b
Left FieldError
"Got multiple characters"

instance MsgpackDecode a => MsgpackDecode (Maybe a) where
  fromMsgpack :: Object -> Either DecodeError (Maybe a)
fromMsgpack = \case
    Object
ObjectNil ->
      Maybe a -> Either DecodeError (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
    Object
o ->
      a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a)
-> Either DecodeError a -> Either DecodeError (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Either DecodeError a
forall a. MsgpackDecode a => Object -> Either DecodeError a
fromMsgpack Object
o

instance (MsgpackDecode a, MsgpackDecode b) => MsgpackDecode (Either a b) where
  fromMsgpack :: Object -> Either DecodeError (Either a b)
fromMsgpack Object
o =
    Either DecodeError (Either a b)
-> Either DecodeError (Either DecodeError (Either a b))
-> Either DecodeError (Either a b)
forall b a. b -> Either a b -> b
fromRight (a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b)
-> Either DecodeError a -> Either DecodeError (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Either DecodeError a
forall a. MsgpackDecode a => Object -> Either DecodeError a
fromMsgpack Object
o) (Either a b -> Either DecodeError (Either a b)
forall a b. b -> Either a b
Right (Either a b -> Either DecodeError (Either a b))
-> (b -> Either a b) -> b -> Either DecodeError (Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either a b
forall a b. b -> Either a b
Right (b -> Either DecodeError (Either a b))
-> Either DecodeError b
-> Either DecodeError (Either DecodeError (Either a b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Either DecodeError b
forall a. MsgpackDecode a => Object -> Either DecodeError a
fromMsgpack Object
o)

instance MsgpackDecode Bool where
  fromMsgpack :: Object -> Either DecodeError Bool
fromMsgpack = \case
    ObjectBool Bool
a ->
      Bool -> Either DecodeError Bool
forall a b. b -> Either a b
Right Bool
a
    ObjectInt Int64
0 ->
      Bool -> Either DecodeError Bool
forall a b. b -> Either a b
Right Bool
False
    ObjectInt Int64
1 ->
      Bool -> Either DecodeError Bool
forall a b. b -> Either a b
Right Bool
True
    Object
o ->
      Object -> Either DecodeError Bool
forall a. Typeable a => Object -> Either DecodeError a
decodeIncompatible Object
o

instance MsgpackDecode () where
  fromMsgpack :: Object -> Either DecodeError ()
fromMsgpack Object
_ =
    () -> Either DecodeError ()
forall a b. b -> Either a b
Right ()

instance MsgpackDecode Object where
  fromMsgpack :: Object -> Either DecodeError Object
fromMsgpack =
    Object -> Either DecodeError Object
forall a b. b -> Either a b
Right

class DecodePath b t where
  decodePath :: FilePath -> Either SomeException (Path b t)

instance DecodePath Abs File where
  decodePath :: String -> Either SomeException (Path Abs File)
decodePath =
    String -> Either SomeException (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile

instance DecodePath Abs Dir where
  decodePath :: String -> Either SomeException (Path Abs Dir)
decodePath =
    String -> Either SomeException (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir

instance DecodePath Rel File where
  decodePath :: String -> Either SomeException (Path Rel File)
decodePath =
    String -> Either SomeException (Path Rel File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel File)
parseRelFile

instance DecodePath Rel Dir where
  decodePath :: String -> Either SomeException (Path Rel Dir)
decodePath =
    String -> Either SomeException (Path Rel Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Rel Dir)
parseRelDir

decodePathE ::
  ∀ b t .
  DecodePath b t =>
  Object ->
  Either FieldError (Path b t)
decodePathE :: forall b t.
DecodePath b t =>
Object -> Either FieldError (Path b t)
decodePathE Object
o = do
  ValidUtf8String String
s <- Object -> Either FieldError ValidUtf8String
forall a. MsgpackDecode a => Object -> Either FieldError a
nestedDecode Object
o
  (SomeException -> FieldError)
-> Either SomeException (Path b t) -> Either FieldError (Path b t)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (FieldError -> SomeException -> FieldError
forall a b. a -> b -> a
const (Text -> FieldError
FieldError Text
"Invalid path")) (String -> Either SomeException (Path b t)
forall b t.
DecodePath b t =>
String -> Either SomeException (Path b t)
decodePath String
s)

instance (
    Typeable b,
    Typeable t,
    DecodePath b t
  ) => MsgpackDecode (Path b t) where
    fromMsgpack :: Object -> Either DecodeError (Path b t)
fromMsgpack =
      Either FieldError (Path b t) -> Either DecodeError (Path b t)
forall a. Typeable a => Either FieldError a -> Either DecodeError a
toDecodeError (Either FieldError (Path b t) -> Either DecodeError (Path b t))
-> (Object -> Either FieldError (Path b t))
-> Object
-> Either DecodeError (Path b t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Either FieldError (Path b t)
forall b t.
DecodePath b t =>
Object -> Either FieldError (Path b t)
decodePathE

timeUnit ::
  Typeable a =>
  Fractional a =>
  Object ->
  Either DecodeError a
timeUnit :: forall a.
(Typeable a, Fractional a) =>
Object -> Either DecodeError a
timeUnit = \case
  Msgpack Double
d ->
    a -> Either DecodeError a
forall a b. b -> Either a b
Right (forall a b. (Real a, Fractional b) => a -> b
realToFrac @Double Double
d)
  Msgpack Int64
i ->
    a -> Either DecodeError a
forall a b. b -> Either a b
Right (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int64 Int64
i)
  Object
o ->
    Object -> Either DecodeError a
forall a. Typeable a => Object -> Either DecodeError a
decodeIncompatible Object
o

instance MsgpackDecode NanoSeconds where
  fromMsgpack :: Object -> Either DecodeError NanoSeconds
fromMsgpack =
    Object -> Either DecodeError NanoSeconds
forall a.
(Typeable a, Fractional a) =>
Object -> Either DecodeError a
timeUnit

instance MsgpackDecode MicroSeconds where
  fromMsgpack :: Object -> Either DecodeError MicroSeconds
fromMsgpack =
    Object -> Either DecodeError MicroSeconds
forall a.
(Typeable a, Fractional a) =>
Object -> Either DecodeError a
timeUnit

instance MsgpackDecode MilliSeconds where
  fromMsgpack :: Object -> Either DecodeError MilliSeconds
fromMsgpack =
    Object -> Either DecodeError MilliSeconds
forall a.
(Typeable a, Fractional a) =>
Object -> Either DecodeError a
timeUnit

instance MsgpackDecode Seconds where
  fromMsgpack :: Object -> Either DecodeError Seconds
fromMsgpack =
    (Int64 -> Seconds)
-> Either DecodeError Int64 -> Either DecodeError Seconds
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int64 -> Seconds
Seconds (Either DecodeError Int64 -> Either DecodeError Seconds)
-> (Object -> Either DecodeError Int64)
-> Object
-> Either DecodeError Seconds
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Either DecodeError Int64
forall a. MsgpackDecode a => Object -> Either DecodeError a
fromMsgpack

fromMsgpackText ::
  MsgpackDecode a =>
  Object ->
  Either Text a
fromMsgpackText :: forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpackText =
  (DecodeError -> Text) -> Either DecodeError a -> Either Text a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first DecodeError -> Text
renderError (Either DecodeError a -> Either Text a)
-> (Object -> Either DecodeError a) -> Object -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Either DecodeError a
forall a. MsgpackDecode a => Object -> Either DecodeError a
fromMsgpack

-- |Pattern synonym for decoding an 'Object'.
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)

deriving anyclass instance MsgpackDecode FieldError

deriving anyclass instance MsgpackDecode DecodeError

instance (
    Typeable a,
    Typeable b,
    MsgpackDecode a,
    MsgpackDecode b
  ) => MsgpackDecode (a, b)

instance (
    Typeable a,
    Typeable b,
    Typeable c,
    MsgpackDecode a,
    MsgpackDecode b,
    MsgpackDecode c
  ) => MsgpackDecode (a, b, c)

instance (
    Typeable a,
    Typeable b,
    Typeable c,
    Typeable d,
    MsgpackDecode a,
    MsgpackDecode b,
    MsgpackDecode c,
    MsgpackDecode d
  ) => MsgpackDecode (a, b, c, d)

instance (
    Typeable a,
    Typeable b,
    Typeable c,
    Typeable d,
    Typeable e,
    MsgpackDecode a,
    MsgpackDecode b,
    MsgpackDecode c,
    MsgpackDecode d,
    MsgpackDecode e
  ) => MsgpackDecode (a, b, c, d, e)

instance (
    Typeable a,
    Typeable b,
    Typeable c,
    Typeable d,
    Typeable e,
    Typeable f,
    MsgpackDecode a,
    MsgpackDecode b,
    MsgpackDecode c,
    MsgpackDecode d,
    MsgpackDecode e,
    MsgpackDecode f
  ) => MsgpackDecode (a, b, c, d, e, f)

instance (
    Typeable a,
    Typeable b,
    Typeable c,
    Typeable d,
    Typeable e,
    Typeable f,
    Typeable g,
    MsgpackDecode a,
    MsgpackDecode b,
    MsgpackDecode c,
    MsgpackDecode d,
    MsgpackDecode e,
    MsgpackDecode f,
    MsgpackDecode g
  ) => MsgpackDecode (a, b, c, d, e, f, g)