{-# 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 :: forall (m :: * -> *). MonadFail m => Object -> m (Map Text Object)
transformObjectMap (ObjectMap [(Object, Object)]
kv) = let mkPair :: MonadFail m => (Object, Object) -> m (Text, Object)
                                        mkPair :: forall (m :: * -> *).
MonadFail m =>
(Object, Object) -> m (Text, Object)
mkPair (ObjectStr Text
txt, Object
v) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
txt, Object
v)
                                        mkPair (Object, Object)
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Non-string key"
                                    in  forall k a. Ord k => [(k, a)] -> Map k a
fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *).
MonadFail m =>
(Object, Object) -> m (Text, Object)
mkPair [(Object, Object)]
kv
transformObjectMap 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 :: forall (m :: * -> *) a.
MonadFail m =>
Map Text Object -> Text -> (Text -> Object -> m a) -> m a
atP Map Text Object
m Text
k Text -> Object -> m a
conv =
  case 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 -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Required field '" forall a. [a] -> [a] -> [a]
++ String
uk 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 :: 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 = 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) forall a b. (a -> b) -> a -> b
$ 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 :: forall (m :: * -> *) a.
MonadFail m =>
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 <- 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  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
r
                          Maybe a
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
def

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

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

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

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

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

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

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

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

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