{-# LANGUAGE CPP #-}

module Bio.MMTF.Decode.MessagePack where

import           Data.ByteString.Lazy (ByteString, fromStrict)
import           Data.Map.Strict      (Map, fromList)
import qualified Data.Map.Strict      as M (lookup)
import           Data.MessagePack
import           Data.Text            (Text)
import qualified Data.Text            as T (unpack)

#if !MIN_VERSION_base(4,13,0)
-- Data.MessagePack includes MonadFail constraints only for GHC-8.8+, so we can't use
-- "real" Control.Monad.Fail.MonadFail here on GHC-8.6.
type MonadFail m = Monad m
#endif

transformObjectMap :: MonadFail m => Object -> m (Map Text Object)
transformObjectMap :: Object -> m (Map Text Object)
transformObjectMap (ObjectMap [(Object, Object)]
kv) = let mkPair :: MonadFail m => (Object, Object) -> m (Text, Object)
                                        mkPair :: (Object, Object) -> m (Text, Object)
mkPair (ObjectStr Text
txt, Object
v) = (Text, Object) -> m (Text, Object)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
txt, Object
v)
                                        mkPair (Object, Object)
_ = String -> m (Text, Object)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Non-string key"
                                    in  [(Text, Object)] -> Map Text Object
forall k a. Ord k => [(k, a)] -> Map k a
fromList ([(Text, Object)] -> Map Text Object)
-> m [(Text, Object)] -> m (Map Text Object)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Object, Object) -> m (Text, Object))
-> [(Object, Object)] -> m [(Text, Object)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Object, Object) -> m (Text, Object)
forall (m :: * -> *).
MonadFail m =>
(Object, Object) -> m (Text, Object)
mkPair [(Object, Object)]
kv
transformObjectMap Object
_ = String -> m (Map Text Object)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Wrong MessagePack MMTF format"

atP :: MonadFail m => Map Text Object -> Text -> (Text -> Object -> m a) -> m a
atP :: Map Text Object -> Text -> (Text -> Object -> m a) -> m a
atP Map Text Object
m Text
k Text -> Object -> m a
conv =
  case Text -> Map Text Object -> Maybe Object
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
k Map Text Object
m of
    Just Object
x  -> Text -> Object -> m a
conv Text
k Object
x
    Maybe Object
Nothing -> String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Required field '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
uk String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' was not found"
  where uk :: String
uk = Text -> String
T.unpack Text
k

atPM :: Monad m => Map Text Object -> Text -> (Text -> Object -> m a) -> m (Maybe a)
atPM :: Map Text Object -> Text -> (Text -> Object -> m a) -> m (Maybe a)
atPM Map Text Object
m Text
k Text -> Object -> m a
conv = (Object -> m a) -> Maybe Object -> m (Maybe a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Text -> Object -> m a
conv Text
k) (Maybe Object -> m (Maybe a)) -> Maybe Object -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ Text -> Map Text Object -> Maybe Object
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
k Map Text Object
m

atPMD :: MonadFail m => Map Text Object -> Text -> (Text -> Object -> m a) -> a -> m a
atPMD :: Map Text Object -> Text -> (Text -> Object -> m a) -> a -> m a
atPMD Map Text Object
m Text
k Text -> Object -> m a
conv a
def = do Maybe a
x <- Map Text Object -> Text -> (Text -> Object -> m a) -> m (Maybe a)
forall (m :: * -> *) a.
Monad m =>
Map Text Object -> Text -> (Text -> Object -> m a) -> m (Maybe a)
atPM Map Text Object
m Text
k Text -> Object -> m a
conv
                        case Maybe a
x of
                          Just a
r  -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r
                          Maybe a
Nothing -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
def

asStr :: MonadFail m => Text -> Object -> m Text
asStr :: Text -> Object -> m Text
asStr Text
_ (ObjectStr Text
s) = Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
s
asStr Text
m Object
_             = String -> m Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Text) -> String -> m Text
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
m String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": not a string data"

asChar :: MonadFail m => Text -> Object -> m Char
asChar :: Text -> Object -> m Char
asChar Text
m = (String -> Char
forall a. [a] -> a
head (String -> Char) -> (Text -> String) -> Text -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack (Text -> Char) -> m Text -> m Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (m Text -> m Char) -> (Object -> m Text) -> Object -> m Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Object -> m Text
forall (m :: * -> *). MonadFail m => Text -> Object -> m Text
asStr Text
m

asInt :: (MonadFail m, Integral a) => Text -> Object -> m a
asInt :: Text -> Object -> m a
asInt Text
_ (ObjectInt Int64
i)  = a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
i)
asInt Text
_ (ObjectWord Word64
w) = a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Word64 -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
w)
asInt Text
m Object
_              = String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
m String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": not an int data"

asFloat :: MonadFail m => Text -> Object -> m Float
asFloat :: Text -> Object -> m Float
asFloat Text
_ (ObjectFloat  Float
f) = Float -> m Float
forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
f
asFloat Text
_ (ObjectDouble Double
f) = Float -> m Float
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
f)
asFloat Text
m Object
_                = String -> m Float
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Float) -> String -> m Float
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
m String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": not a float data"

asIntList :: (MonadFail m, Integral a) => Text -> Object -> m [a]
asIntList :: Text -> Object -> m [a]
asIntList Text
m (ObjectArray [Object]
l) = (Object -> m a) -> [Object] -> m [a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Text -> Object -> m a
forall (m :: * -> *) a.
(MonadFail m, Integral a) =>
Text -> Object -> m a
asInt Text
m) [Object]
l
asIntList Text
m Object
_               = String -> m [a]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m [a]) -> String -> m [a]
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
m String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": not an array of ints data"

asStrList :: MonadFail m => Text -> Object -> m [Text]
asStrList :: Text -> Object -> m [Text]
asStrList Text
m (ObjectArray [Object]
l) = (Object -> m Text) -> [Object] -> m [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Text -> Object -> m Text
forall (m :: * -> *). MonadFail m => Text -> Object -> m Text
asStr Text
m) [Object]
l
asStrList Text
m Object
_               = String -> m [Text]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m [Text]) -> String -> m [Text]
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
m String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": not an array of string data"

asFloatList :: MonadFail m => Text -> Object -> m [Float]
asFloatList :: Text -> Object -> m [Float]
asFloatList Text
m (ObjectArray [Object]
l) = (Object -> m Float) -> [Object] -> m [Float]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Text -> Object -> m Float
forall (m :: * -> *). MonadFail m => Text -> Object -> m Float
asFloat Text
m) [Object]
l
asFloatList Text
m Object
_               = String -> m [Float]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m [Float]) -> String -> m [Float]
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
m String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": not an array of float data"

asObjectList :: MonadFail m => Text -> Object -> m [Object]
asObjectList :: Text -> Object -> m [Object]
asObjectList Text
_ (ObjectArray [Object]
l) = [Object] -> m [Object]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Object]
l
asObjectList Text
m Object
_               = String -> m [Object]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m [Object]) -> String -> m [Object]
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
m String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": not an array data"

asBinary :: MonadFail m => Text -> Object -> m ByteString
asBinary :: Text -> Object -> m ByteString
asBinary Text
_ (ObjectBin ByteString
bs) = ByteString -> m ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> ByteString
fromStrict ByteString
bs)
asBinary Text
m Object
_              = String -> m ByteString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ByteString) -> String -> m ByteString
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
m String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": not a binary data"