{-# options_haddock prune #-}

-- |Decoding values from MessagePack format
module Ribosome.Host.Class.Msgpack.Decode where

import qualified Data.Map.Strict as Map (empty, fromList, toList)
import Data.MessagePack (Object (..))
import Exon (exon)
import GHC.Float (double2Float, float2Double)
import GHC.Generics (
  C1,
  Constructor,
  D1,
  K1 (..),
  M1 (..),
  Rep,
  S1,
  Selector,
  conIsRecord,
  selName,
  to,
  (:*:) (..),
  (:+:) (..),
  )
import Path (Abs, Dir, File, Path, Rel, parseAbsDir, parseAbsFile, parseRelDir, parseRelFile)
import Prelude hiding (to)
import Time (MicroSeconds, MilliSeconds, NanoSeconds, Seconds (Seconds))

import qualified Ribosome.Host.Class.Msgpack.Util as Util (illegalType, invalid, lookupObjectMap, missingRecordKey)

-- |Class of values that can be decoded from MessagePack 'Object's.
class MsgpackDecode a where
  -- |Attempt to decode an 'Object', returning an error message in a 'Left' if the data is incompatible.
  --
  -- The default implementation uses generic derivation.
  fromMsgpack :: Object -> Either Text a
  default fromMsgpack :: (Generic a, GMsgpackDecode (Rep a)) => Object -> Either Text a
  fromMsgpack = (Rep a Any -> a) -> Either Text (Rep a Any) -> Either Text a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Either Text (Rep a Any) -> Either Text a)
-> (Object -> Either Text (Rep a Any)) -> Object -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Either Text (Rep a Any)
forall {k} (f :: k -> *) (a :: k).
GMsgpackDecode f =>
Object -> Either Text (f a)
gMsgpackDecode

  -- |Utility method called by the generic machinery when a record key is missing.
  missingKey :: String -> Object -> Either Text a
  missingKey = String -> Object -> Either Text a
forall a. String -> Object -> Either Text a
Util.missingRecordKey

-- |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)

class GMsgpackDecode f where
  gMsgpackDecode :: Object -> Either Text (f a)

  gMissingKey :: String -> Object -> Either Text (f a)
  gMissingKey = String -> Object -> Either Text (f a)
forall a. String -> Object -> Either Text a
Util.missingRecordKey

class MsgpackDecodeProd f where
  msgpackDecodeRecord :: Map Object Object -> Either Text (f a)
  msgpackDecodeProd :: [Object] -> Either Text ([Object], f a)

instance (GMsgpackDecode f) => GMsgpackDecode (D1 c f) where
  gMsgpackDecode :: forall (a :: k). Object -> Either Text (D1 c f a)
gMsgpackDecode =
    (f a -> M1 D c f a)
-> Either Text (f a) -> Either Text (M1 D c f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f a -> M1 D c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Either Text (f a) -> Either Text (M1 D c f a))
-> (Object -> Either Text (f a))
-> Object
-> Either Text (M1 D c f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (f :: k -> *) (a :: k).
GMsgpackDecode f =>
Object -> Either Text (f a)
forall (f :: k -> *) (a :: k).
GMsgpackDecode f =>
Object -> Either Text (f a)
gMsgpackDecode @f

instance (Constructor c, MsgpackDecodeProd f) => GMsgpackDecode (C1 c f) where
  gMsgpackDecode :: forall (a :: k). Object -> Either Text (C1 c f a)
gMsgpackDecode =
    (f a -> M1 C c f a)
-> Either Text (f a) -> Either Text (M1 C c f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f a -> M1 C c f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (Either Text (f a) -> Either Text (M1 C c f a))
-> (Object -> Either Text (f a))
-> Object
-> Either Text (M1 C c f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Either Text (f a)
decode
    where
      isRec :: Bool
isRec = Any c f Any -> Bool
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
conIsRecord (forall {k} {t :: Meta -> (k -> *) -> k -> *} {p :: k}. t c f p
forall a. HasCallStack => a
undefined :: t c f p)
      decode :: Object -> Either Text (f a)
decode o :: Object
o@(ObjectMap Map Object Object
om) =
        if Bool
isRec then Map Object Object -> Either Text (f a)
forall {k} (f :: k -> *) (a :: k).
MsgpackDecodeProd f =>
Map Object Object -> Either Text (f a)
msgpackDecodeRecord Map Object Object
om else Text -> Object -> Either Text (f a)
forall a. Text -> Object -> Either Text a
Util.invalid Text
"illegal ObjectMap for product" Object
o
      decode Object
o | Bool
isRec =
        Text -> Object -> Either Text (f a)
forall a. Text -> Object -> Either Text a
Util.invalid Text
"illegal non-ObjectMap for record" Object
o
      decode Object
o =
        [Object] -> Either Text ([Object], f a)
forall {k} (f :: k -> *) (a :: k).
MsgpackDecodeProd f =>
[Object] -> Either Text ([Object], f a)
msgpackDecodeProd (Object -> [Object]
prod Object
o) Either Text ([Object], f a)
-> (([Object], f a) -> Either Text (f a)) -> Either Text (f a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([Object], f a) -> Either Text (f a)
check
        where
          check :: ([Object], f a) -> Either Text (f a)
check ([], f a
a) = f a -> Either Text (f a)
forall a b. b -> Either a b
Right f a
a
          check ([Object], f a)
_ = Text -> Object -> Either Text (f a)
forall a. Text -> Object -> Either Text a
Util.invalid Text
"too many values for product" Object
o
          prod :: Object -> [Object]
prod (ObjectArray [Object]
oa) = [Object]
oa
          prod Object
ob = [Item [Object]
Object
ob]

instance (MsgpackDecodeProd f, MsgpackDecodeProd g) => MsgpackDecodeProd (f :*: g) where
  msgpackDecodeRecord :: forall (a :: k). Map Object Object -> Either Text ((:*:) f g a)
msgpackDecodeRecord Map Object Object
o = do
    f a
left <- Map Object Object -> Either Text (f a)
forall {k} (f :: k -> *) (a :: k).
MsgpackDecodeProd f =>
Map Object Object -> Either Text (f a)
msgpackDecodeRecord Map Object Object
o
    g a
right <- Map Object Object -> Either Text (g a)
forall {k} (f :: k -> *) (a :: k).
MsgpackDecodeProd f =>
Map Object Object -> Either Text (f a)
msgpackDecodeRecord Map Object Object
o
    pure $ f a
left f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g a
right
  msgpackDecodeProd :: forall (a :: k). [Object] -> Either Text ([Object], (:*:) f g a)
msgpackDecodeProd [Object]
o = do
    ([Object]
rest, f a
left) <- [Object] -> Either Text ([Object], f a)
forall {k} (f :: k -> *) (a :: k).
MsgpackDecodeProd f =>
[Object] -> Either Text ([Object], f a)
msgpackDecodeProd [Object]
o
    ([Object]
rest1, g a
right) <- [Object] -> Either Text ([Object], g a)
forall {k} (f :: k -> *) (a :: k).
MsgpackDecodeProd f =>
[Object] -> Either Text ([Object], f a)
msgpackDecodeProd [Object]
rest
    ([Object], (:*:) f g a) -> Either Text ([Object], (:*:) f g a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Object]
rest1, f a
left f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g a
right)

instance (GMsgpackDecode f, GMsgpackDecode g) => GMsgpackDecode (f :+: g) where
  gMsgpackDecode :: forall (a :: k). Object -> Either Text ((:+:) f g a)
gMsgpackDecode Object
o = Either Text ((:+:) f g a)
-> Either Text (Either Text ((:+:) f g a))
-> Either Text ((:+:) f g a)
forall b a. b -> Either a b -> b
fromRight (f a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (f a -> (:+:) f g a)
-> Either Text (f a) -> Either Text ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (f :: k -> *) (a :: k).
GMsgpackDecode f =>
Object -> Either Text (f a)
forall (f :: k -> *) (a :: k).
GMsgpackDecode f =>
Object -> Either Text (f a)
gMsgpackDecode @f Object
o) ((:+:) f g a -> Either Text ((:+:) f g a)
forall a b. b -> Either a b
Right ((:+:) f g a -> Either Text ((:+:) f g a))
-> (g a -> (:+:) f g a) -> g a -> Either Text ((:+:) f g a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. g a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (g a -> Either Text ((:+:) f g a))
-> Either Text (g a) -> Either Text (Either Text ((:+:) f g a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (f :: k -> *) (a :: k).
GMsgpackDecode f =>
Object -> Either Text (f a)
forall (f :: k -> *) (a :: k).
GMsgpackDecode f =>
Object -> Either Text (f a)
gMsgpackDecode @g Object
o)

-- TODO use Proxy instead of undefined
instance (Selector s, GMsgpackDecode f) => MsgpackDecodeProd (S1 s f) where
  msgpackDecodeRecord :: forall (a :: k). Map Object Object -> Either Text (S1 s f a)
msgpackDecodeRecord Map Object Object
o =
    f a -> M1 S s f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 (f a -> M1 S s f a)
-> Either Text (f a) -> Either Text (M1 S s f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text (f a)
-> (Object -> Either Text (f a))
-> Maybe Object
-> Either Text (f a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Object -> Either Text (f a)
forall {k} (f :: k -> *) (a :: k).
GMsgpackDecode f =>
String -> Object -> Either Text (f a)
gMissingKey String
key (Map Object Object -> Object
ObjectMap Map Object Object
o)) Object -> Either Text (f a)
forall {k} (f :: k -> *) (a :: k).
GMsgpackDecode f =>
Object -> Either Text (f a)
gMsgpackDecode Maybe Object
lookup
    where
      lookup :: Maybe Object
lookup =
        String -> Map Object Object -> Maybe Object
forall a.
ConvertUtf8 a ByteString =>
a -> Map Object Object -> Maybe Object
Util.lookupObjectMap String
key Map Object Object
o Maybe Object -> Maybe Object -> Maybe Object
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Object
lookupUnderscore
      lookupUnderscore :: Maybe Object
lookupUnderscore =
        if Bool
hasUnderscore
        then String -> Map Object Object -> Maybe Object
forall a.
ConvertUtf8 a ByteString =>
a -> Map Object Object -> Maybe Object
Util.lookupObjectMap ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char
'_' Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==) String
key) Map Object Object
o
        else Maybe Object
forall a. Maybe a
Nothing
      hasUnderscore :: Bool
hasUnderscore =
        Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
1 String
key String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"_"
      key :: String
key =
        Any s f Any -> String
forall {k} (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName (forall {k} {t :: Meta -> (k -> *) -> k -> *} {p :: k}. t s f p
forall a. HasCallStack => a
undefined :: t s f p)
  msgpackDecodeProd :: forall (a :: k). [Object] -> Either Text ([Object], S1 s f a)
msgpackDecodeProd (Object
cur:[Object]
rest) = do
    f a
a <- Object -> Either Text (f a)
forall {k} (f :: k -> *) (a :: k).
GMsgpackDecode f =>
Object -> Either Text (f a)
gMsgpackDecode Object
cur
    pure ([Object]
rest, f a -> S1 s f a
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 f a
a)
  msgpackDecodeProd [] = Text -> Object -> Either Text ([Object], S1 s f a)
forall a. Text -> Object -> Either Text a
Util.invalid Text
"too few values for product" Object
ObjectNil

instance MsgpackDecode a => GMsgpackDecode (K1 i a) where
  gMsgpackDecode :: forall (a :: k). Object -> Either Text (K1 i a a)
gMsgpackDecode = (a -> K1 i a a) -> Either Text a -> Either Text (K1 i a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (Either Text a -> Either Text (K1 i a a))
-> (Object -> Either Text a) -> Object -> Either Text (K1 i a a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Either Text a
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpack

  gMissingKey :: forall (a :: k). String -> Object -> Either Text (K1 i a a)
gMissingKey String
key =
    (a -> K1 i a a) -> Either Text a -> Either Text (K1 i a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> K1 i a a
forall k i c (p :: k). c -> K1 i c p
K1 (Either Text a -> Either Text (K1 i a a))
-> (Object -> Either Text a) -> Object -> Either Text (K1 i a a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Object -> Either Text a
forall a. MsgpackDecode a => String -> Object -> Either Text a
missingKey String
key

instance (Ord k, MsgpackDecode k, MsgpackDecode v) => MsgpackDecode (Map k v) where
  fromMsgpack :: Object -> Either Text (Map k v)
fromMsgpack (ObjectMap Map Object Object
om) = do
    [(k, v)]
m <- ((Object, Object) -> Either Text (k, v))
-> [(Object, Object)] -> Either Text [(k, v)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Object, Object) -> Either Text (k, v)
forall {a} {b}.
(MsgpackDecode a, MsgpackDecode b) =>
(Object, Object) -> Either Text (a, b)
decodePair ([(Object, Object)] -> Either Text [(k, v)])
-> [(Object, Object)] -> Either Text [(k, v)]
forall a b. (a -> b) -> a -> b
$ Map Object Object -> [(Object, Object)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Object Object
om
    Map k v -> Either Text (Map k v)
forall a b. b -> Either a b
Right (Map k v -> Either Text (Map k v))
-> Map k v -> Either Text (Map k v)
forall a b. (a -> b) -> a -> b
$ [(k, v)] -> Map k v
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(k, v)]
m
    where
      decodePair :: (Object, Object) -> Either Text (a, b)
decodePair (Object
k, Object
v) = do
        a
k1 <- Object -> Either Text a
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpack Object
k
        b
v1 <- Object -> Either Text b
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpack Object
v
        pure (a
k1, b
v1)
  fromMsgpack Object
o = Text -> Object -> Either Text (Map k v)
forall a. Text -> Object -> Either Text a
Util.illegalType Text
"Map" Object
o
  missingKey :: String -> Object -> Either Text (Map k v)
missingKey String
_ Object
_ = Map k v -> Either Text (Map k v)
forall a b. b -> Either a b
Right Map k v
forall k a. Map k a
Map.empty

integralFromString ::
  Read a =>
  ByteString ->
  Either Text a
integralFromString :: forall a. Read a => ByteString -> Either Text a
integralFromString =
  String -> Either Text a
forall a. Read a => String -> Either Text a
readEither (String -> Either Text a)
-> (ByteString -> String) -> ByteString -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8

msgpackIntegral ::
  Integral a =>
  Read a =>
  Object ->
  Either Text a
msgpackIntegral :: forall a. (Integral a, Read a) => Object -> Either Text a
msgpackIntegral (ObjectInt Int64
i) = a -> Either Text a
forall a b. b -> Either a b
Right (a -> Either Text a) -> a -> Either Text a
forall a b. (a -> b) -> a -> b
$ Int64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i
msgpackIntegral (ObjectUInt Word64
i) = a -> Either Text a
forall a b. b -> Either a b
Right (a -> Either Text a) -> a -> Either Text a
forall a b. (a -> b) -> a -> b
$ Word64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i
msgpackIntegral (ObjectString ByteString
s) = ByteString -> Either Text a
forall a. Read a => ByteString -> Either Text a
integralFromString ByteString
s
msgpackIntegral (ObjectBinary ByteString
s) = ByteString -> Either Text a
forall a. Read a => ByteString -> Either Text a
integralFromString ByteString
s
msgpackIntegral Object
o = Text -> Object -> Either Text a
forall a. Text -> Object -> Either Text a
Util.illegalType Text
"Integral" Object
o

msgpackText :: ConvertUtf8 t ByteString => Text -> (t -> Either Text a) -> Object -> Either Text a
msgpackText :: forall t a.
ConvertUtf8 t ByteString =>
Text -> (t -> Either Text a) -> Object -> Either Text a
msgpackText Text
typeName t -> Either Text a
decode =
  Object -> Either Text a
run
  where
    run :: Object -> Either Text a
run (ObjectString ByteString
os) = t -> Either Text a
decode (t -> Either Text a) -> t -> Either Text a
forall a b. (a -> b) -> a -> b
$ ByteString -> t
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
os
    run (ObjectBinary ByteString
os) = t -> Either Text a
decode (t -> Either Text a) -> t -> Either Text a
forall a b. (a -> b) -> a -> b
$ ByteString -> t
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
os
    run Object
o = Text -> Object -> Either Text a
forall a. Text -> Object -> Either Text a
Util.illegalType Text
typeName Object
o

instance MsgpackDecode Integer where
  fromMsgpack :: Object -> Either Text Integer
fromMsgpack = Object -> Either Text Integer
forall a. (Integral a, Read a) => Object -> Either Text a
msgpackIntegral

instance MsgpackDecode Int where
  fromMsgpack :: Object -> Either Text Int
fromMsgpack = Object -> Either Text Int
forall a. (Integral a, Read a) => Object -> Either Text a
msgpackIntegral

instance MsgpackDecode Int64 where
  fromMsgpack :: Object -> Either Text Int64
fromMsgpack = Object -> Either Text Int64
forall a. (Integral a, Read a) => Object -> Either Text a
msgpackIntegral

instance MsgpackDecode Float where
  fromMsgpack :: Object -> Either Text Float
fromMsgpack (ObjectFloat Float
a) = Float -> Either Text Float
forall a b. b -> Either a b
Right Float
a
  fromMsgpack (ObjectDouble Double
a) = Float -> Either Text Float
forall a b. b -> Either a b
Right (Double -> Float
double2Float Double
a)
  fromMsgpack (ObjectInt Int64
a) = Float -> Either Text Float
forall a b. b -> Either a b
Right (Int64 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
a)
  fromMsgpack (ObjectUInt Word64
a) = Float -> Either Text Float
forall a b. b -> Either a b
Right (Word64 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
a)
  fromMsgpack Object
o = Text -> Object -> Either Text Float
forall a. Text -> Object -> Either Text a
Util.illegalType Text
"Float" Object
o

instance MsgpackDecode Double where
  fromMsgpack :: Object -> Either Text Double
fromMsgpack (ObjectFloat Float
a) = Double -> Either Text Double
forall a b. b -> Either a b
Right (Float -> Double
float2Double Float
a)
  fromMsgpack (ObjectDouble Double
a) = Double -> Either Text Double
forall a b. b -> Either a b
Right Double
a
  fromMsgpack (ObjectInt Int64
a) = Double -> Either Text Double
forall a b. b -> Either a b
Right (Int64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
a)
  fromMsgpack (ObjectUInt Word64
a) = Double -> Either Text Double
forall a b. b -> Either a b
Right (Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
a)
  fromMsgpack Object
o = Text -> Object -> Either Text Double
forall a. Text -> Object -> Either Text a
Util.illegalType Text
"Double" Object
o

instance {-# OVERLAPPING #-} MsgpackDecode String where
  fromMsgpack :: Object -> Either Text String
fromMsgpack = Text
-> (String -> Either Text String) -> Object -> Either Text String
forall t a.
ConvertUtf8 t ByteString =>
Text -> (t -> Either Text a) -> Object -> Either Text a
msgpackText Text
"String" String -> Either Text String
forall a b. b -> Either a b
Right

instance {-# OVERLAPPABLE #-} MsgpackDecode a => MsgpackDecode [a] where
  fromMsgpack :: Object -> Either Text [a]
fromMsgpack (ObjectArray [Object]
oa) = (Object -> Either Text a) -> [Object] -> Either Text [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Object -> Either Text a
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpack [Object]
oa
  fromMsgpack Object
o = Text -> Object -> Either Text [a]
forall a. Text -> Object -> Either Text a
Util.illegalType Text
"List" Object
o
  missingKey :: String -> Object -> Either Text [a]
missingKey String
_ Object
_ = [a] -> Either Text [a]
forall a b. b -> Either a b
Right []

instance MsgpackDecode Text where
  fromMsgpack :: Object -> Either Text Text
fromMsgpack =
    Text -> (Text -> Either Text Text) -> Object -> Either Text Text
forall t a.
ConvertUtf8 t ByteString =>
Text -> (t -> Either Text a) -> Object -> Either Text a
msgpackText Text
"Text" Text -> Either Text Text
forall a b. b -> Either a b
Right

instance MsgpackDecode ByteString where
  fromMsgpack :: Object -> Either Text ByteString
fromMsgpack (ObjectString ByteString
os) = ByteString -> Either Text ByteString
forall a b. b -> Either a b
Right ByteString
os
  fromMsgpack (ObjectBinary ByteString
os) = ByteString -> Either Text ByteString
forall a b. b -> Either a b
Right ByteString
os
  fromMsgpack Object
o = Text -> Object -> Either Text ByteString
forall a. Text -> Object -> Either Text a
Util.illegalType Text
"ByteString" Object
o

instance MsgpackDecode Char where
  fromMsgpack :: Object -> Either Text Char
fromMsgpack Object
o =
    Text -> (String -> Either Text Char) -> Object -> Either Text Char
forall t a.
ConvertUtf8 t ByteString =>
Text -> (t -> Either Text a) -> Object -> Either Text a
msgpackText Text
"Char" String -> Either Text Char
check Object
o
    where
      check :: [Char] -> Either Text Char
      check :: String -> Either Text Char
check [Item String
c] = Char -> Either Text Char
forall a b. b -> Either a b
Right Char
Item String
c
      check String
_ = Text -> Object -> Either Text Char
forall a. Text -> Object -> Either Text a
Util.invalid Text
"multiple characters when decoding Char" Object
o

instance MsgpackDecode a => MsgpackDecode (Maybe a) where
  fromMsgpack :: Object -> Either Text (Maybe a)
fromMsgpack Object
ObjectNil = Maybe a -> Either Text (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
  fromMsgpack Object
o = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Either Text a -> Either Text (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Either Text a
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpack Object
o
  missingKey :: String -> Object -> Either Text (Maybe a)
missingKey String
_ Object
_ = Maybe a -> Either Text (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing

instance (MsgpackDecode a, MsgpackDecode b) => MsgpackDecode (Either a b) where
  fromMsgpack :: Object -> Either Text (Either a b)
fromMsgpack Object
o =
    Either Text (Either a b)
-> Either Text (Either Text (Either a b))
-> Either Text (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 Text a -> Either Text (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Either Text a
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpack Object
o) (Either a b -> Either Text (Either a b)
forall a b. b -> Either a b
Right (Either a b -> Either Text (Either a b))
-> (b -> Either a b) -> b -> Either Text (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 Text (Either a b))
-> Either Text b -> Either Text (Either Text (Either a b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Either Text b
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpack Object
o)

instance MsgpackDecode Bool where
  fromMsgpack :: Object -> Either Text Bool
fromMsgpack (ObjectBool Bool
a) = Bool -> Either Text Bool
forall a b. b -> Either a b
Right Bool
a
  fromMsgpack (ObjectInt Int64
0) = Bool -> Either Text Bool
forall a b. b -> Either a b
Right Bool
False
  fromMsgpack (ObjectInt Int64
1) = Bool -> Either Text Bool
forall a b. b -> Either a b
Right Bool
True
  fromMsgpack Object
o = Text -> Object -> Either Text Bool
forall a. Text -> Object -> Either Text a
Util.illegalType Text
"Bool" Object
o

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

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

decodeTuple :: Int -> ([Object] -> Either (Maybe Text) a) -> Object -> Either Text a
decodeTuple :: forall a.
Int
-> ([Object] -> Either (Maybe Text) a) -> Object -> Either Text a
decodeTuple Int
i [Object] -> Either (Maybe Text) a
f = \case
  o :: Object
o@(ObjectArray [Object]
oa) ->
    case [Object] -> Either (Maybe Text) a
f [Object]
oa of
      Right a
a -> a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
      Left Maybe Text
Nothing -> Text -> Object -> Either Text a
forall a. Text -> Object -> Either Text a
Util.invalid [exon|invalid array length for #{show i}-tuple|] Object
o
      Left (Just Text
err) -> Text -> Either Text a
forall a b. a -> Either a b
Left Text
err
  Object
o ->
    Text -> Object -> Either Text a
forall a. Text -> Object -> Either Text a
Util.illegalType [exon|#{show i}-tuple|] Object
o

instance (MsgpackDecode a, MsgpackDecode b) => MsgpackDecode (a, b) where
  fromMsgpack :: Object -> Either Text (a, b)
fromMsgpack =
    Int
-> ([Object] -> Either (Maybe Text) (a, b))
-> Object
-> Either Text (a, b)
forall a.
Int
-> ([Object] -> Either (Maybe Text) a) -> Object -> Either Text a
decodeTuple Int
2 \case
      [Item [Object]
a, Item [Object]
b] ->
        (Text -> Maybe Text)
-> Either Text (a, b) -> Either (Maybe Text) (a, b)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Maybe Text
forall a. a -> Maybe a
Just ((,) (a -> b -> (a, b)) -> Either Text a -> Either Text (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Either Text a
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpack Item [Object]
Object
a Either Text (b -> (a, b)) -> Either Text b -> Either Text (a, b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Either Text b
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpack Item [Object]
Object
b)
      [Object]
_ ->
        Maybe Text -> Either (Maybe Text) (a, b)
forall a b. a -> Either a b
Left Maybe Text
forall a. Maybe a
Nothing

instance (MsgpackDecode a, MsgpackDecode b, MsgpackDecode c) => MsgpackDecode (a, b, c) where
  fromMsgpack :: Object -> Either Text (a, b, c)
fromMsgpack =
    Int
-> ([Object] -> Either (Maybe Text) (a, b, c))
-> Object
-> Either Text (a, b, c)
forall a.
Int
-> ([Object] -> Either (Maybe Text) a) -> Object -> Either Text a
decodeTuple Int
3 \case
      [Item [Object]
a, Item [Object]
b, Item [Object]
c] ->
        (Text -> Maybe Text)
-> Either Text (a, b, c) -> Either (Maybe Text) (a, b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Maybe Text
forall a. a -> Maybe a
Just ((,,) (a -> b -> c -> (a, b, c))
-> Either Text a -> Either Text (b -> c -> (a, b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Either Text a
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpack Item [Object]
Object
a Either Text (b -> c -> (a, b, c))
-> Either Text b -> Either Text (c -> (a, b, c))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Either Text b
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpack Item [Object]
Object
b Either Text (c -> (a, b, c))
-> Either Text c -> Either Text (a, b, c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Either Text c
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpack Item [Object]
Object
c)
      [Object]
_ ->
        Maybe Text -> Either (Maybe Text) (a, b, c)
forall a b. a -> Either a b
Left Maybe Text
forall a. Maybe a
Nothing

instance (MsgpackDecode a, MsgpackDecode b, MsgpackDecode c, MsgpackDecode d) => MsgpackDecode (a, b, c, d) where
  fromMsgpack :: Object -> Either Text (a, b, c, d)
fromMsgpack =
    Int
-> ([Object] -> Either (Maybe Text) (a, b, c, d))
-> Object
-> Either Text (a, b, c, d)
forall a.
Int
-> ([Object] -> Either (Maybe Text) a) -> Object -> Either Text a
decodeTuple Int
4 \case
      [Item [Object]
a, Item [Object]
b, Item [Object]
c, Item [Object]
d] ->
        (Text -> Maybe Text)
-> Either Text (a, b, c, d) -> Either (Maybe Text) (a, b, c, d)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Maybe Text
forall a. a -> Maybe a
Just ((,,,) (a -> b -> c -> d -> (a, b, c, d))
-> Either Text a -> Either Text (b -> c -> d -> (a, b, c, d))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Either Text a
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpack Item [Object]
Object
a Either Text (b -> c -> d -> (a, b, c, d))
-> Either Text b -> Either Text (c -> d -> (a, b, c, d))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Either Text b
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpack Item [Object]
Object
b Either Text (c -> d -> (a, b, c, d))
-> Either Text c -> Either Text (d -> (a, b, c, d))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Either Text c
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpack Item [Object]
Object
c Either Text (d -> (a, b, c, d))
-> Either Text d -> Either Text (a, b, c, d)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Either Text d
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpack Item [Object]
Object
d)
      [Object]
_ ->
        Maybe Text -> Either (Maybe Text) (a, b, c, d)
forall a b. a -> Either a b
Left Maybe Text
forall a. Maybe a
Nothing

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 =>
  Text ->
  Either Text (Path b t)
decodePathE :: forall b t. DecodePath b t => Text -> Either Text (Path b t)
decodePathE =
  (SomeException -> Text)
-> Either SomeException (Path b t) -> Either Text (Path b t)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first SomeException -> Text
forall b a. (Show a, IsString b) => a -> b
show (Either SomeException (Path b t) -> Either Text (Path b t))
-> (Text -> Either SomeException (Path b t))
-> Text
-> Either Text (Path b t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either SomeException (Path b t)
forall b t.
DecodePath b t =>
String -> Either SomeException (Path b t)
decodePath (String -> Either SomeException (Path b t))
-> (Text -> String) -> Text -> Either SomeException (Path b t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString

instance DecodePath b t => MsgpackDecode (Path b t) where
  fromMsgpack :: Object -> Either Text (Path b t)
fromMsgpack =
    Text
-> (Text -> Either Text (Path b t))
-> Object
-> Either Text (Path b t)
forall t a.
ConvertUtf8 t ByteString =>
Text -> (t -> Either Text a) -> Object -> Either Text a
msgpackText Text
"Path" Text -> Either Text (Path b t)
forall b t. DecodePath b t => Text -> Either Text (Path b t)
decodePathE

timeUnit ::
  Fractional a =>
  Text ->
  Object ->
  Either Text a
timeUnit :: forall a. Fractional a => Text -> Object -> Either Text a
timeUnit Text
name = \case
  Msgpack Double
d -> a -> Either Text 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 Text a
forall a b. b -> Either a b
Right (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int64 Int64
i)
  Object
o -> Text -> Object -> Either Text a
forall a. Text -> Object -> Either Text a
Util.illegalType Text
name Object
o

instance MsgpackDecode NanoSeconds where
  fromMsgpack :: Object -> Either Text NanoSeconds
fromMsgpack =
    Text -> Object -> Either Text NanoSeconds
forall a. Fractional a => Text -> Object -> Either Text a
timeUnit Text
"NanoSeconds"

instance MsgpackDecode MicroSeconds where
  fromMsgpack :: Object -> Either Text MicroSeconds
fromMsgpack =
    Text -> Object -> Either Text MicroSeconds
forall a. Fractional a => Text -> Object -> Either Text a
timeUnit Text
"MicroSeconds"

instance MsgpackDecode MilliSeconds where
  fromMsgpack :: Object -> Either Text MilliSeconds
fromMsgpack =
    Text -> Object -> Either Text MilliSeconds
forall a. Fractional a => Text -> Object -> Either Text a
timeUnit Text
"MilliSeconds"

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

msgpackFromString :: IsString a => Text -> Object -> Either Text a
msgpackFromString :: forall a. IsString a => Text -> Object -> Either Text a
msgpackFromString Text
name Object
o =
  case Object -> Either Text String
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpack Object
o of
    Right String
a ->
      a -> Either Text a
forall a b. b -> Either a b
Right (String -> a
forall a. IsString a => String -> a
fromString String
a)
    Left Text
_ ->
      Text -> Object -> Either Text a
forall a. Text -> Object -> Either Text a
Util.illegalType Text
name Object
o