{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}

module Database.Bolt.Value.Instances where

import           Database.Bolt.Value.Helpers
import           Database.Bolt.Value.Type

import           Control.Monad                (forM, replicateM)
import           Control.Monad.Except         (MonadError (..))
import           Data.Binary                  (Binary (..), Put, decode, encode)
import           Data.Binary.Get
import           Data.Binary.IEEE754          (doubleToWord, wordToDouble)
import           Data.Binary.Put              (putByteString, putWord16be, putWord32be, putWord64be,
                                               putWord8)
import           Data.ByteString              (ByteString)
import qualified Data.ByteString              as B
import           Data.ByteString.Lazy         (fromStrict, toStrict)
import           Data.Int
import           Data.Map.Strict              (Map)
import qualified Data.Map.Strict              as M
import           Data.Text                    (Text)
import           Data.Text.Encoding           (decodeUtf8, encodeUtf8)
import           Data.Word

instance BoltValue () where
  pack :: () -> Put
pack () = Word8 -> Put
putWord8 Word8
nullCode

  unpackT :: Get ()
unpackT = Get Word8
getWord8 Get Word8 -> (Word8 -> Get ()) -> Get ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get ()
forall (f :: * -> *). MonadFail f => Word8 -> f ()
unpackByMarker
    where unpackByMarker :: Word8 -> f ()
unpackByMarker Word8
m | Word8
m Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
nullCode = () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                           | Bool
otherwise     = String -> f ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected null"

instance BoltValue Bool where
  pack :: Bool -> Put
pack Bool
True  = Word8 -> Put
putWord8 Word8
trueCode
  pack Bool
False = Word8 -> Put
putWord8 Word8
falseCode

  unpackT :: Get Bool
unpackT = Get Word8
getWord8 Get Word8 -> (Word8 -> Get Bool) -> Get Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get Bool
forall (f :: * -> *). MonadFail f => Word8 -> f Bool
unpackByMarker
    where unpackByMarker :: Word8 -> f Bool
unpackByMarker Word8
m | Word8
m Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
trueCode  = Bool -> f Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
                           | Word8
m Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
falseCode = Bool -> f Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
                           | Bool
otherwise      = String -> f Bool
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected bool"

instance BoltValue Int where
  pack :: Int -> Put
pack Int
int | Int -> Bool
forall a. Integral a => a -> Bool
isTinyInt Int
int = Word8 -> Put
putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
int
           | Int -> Int -> Bool
forall x. Integral x => x -> x -> Bool
isIntX  Int
8 Int
int = Word8 -> Put
putWord8 Word8
int8Code Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
putWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
int)
           | Int -> Int -> Bool
forall x. Integral x => x -> x -> Bool
isIntX Int
16 Int
int = Word8 -> Put
putWord8 Word8
int16Code Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
int :: Word16)
           | Int -> Int -> Bool
forall x. Integral x => x -> x -> Bool
isIntX Int
32 Int
int = Word8 -> Put
putWord8 Word8
int32Code Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Put
putWord32be (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
int :: Word32)
           | Int -> Int -> Bool
forall x. Integral x => x -> x -> Bool
isIntX Int
64 Int
int = Word8 -> Put
putWord8 Word8
int64Code Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word64 -> Put
putWord64be (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
int :: Word64)
           | Bool
otherwise     = String -> Put
forall a. HasCallStack => String -> a
error String
"Cannot pack so large integer"

  unpackT :: Get Int
unpackT = Get Word8
getWord8 Get Word8 -> (Word8 -> Get Int) -> Get Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get Int
unpackByMarker
    where unpackByMarker :: Word8 -> Get Int
unpackByMarker Word8
m | Word8 -> Bool
isTinyWord Word8
m   = Int -> Get Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Get Int) -> (Int8 -> Int) -> Int8 -> Get Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int8 -> Int
forall a. Integral a => a -> Int
toInt (Int8 -> Get Int) -> Int8 -> Get Int
forall a b. (a -> b) -> a -> b
$ (Word8 -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
m :: Int8)
                           | Word8
m Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
int8Code  = Int8 -> Int
forall a. Integral a => a -> Int
toInt (Int8 -> Int) -> Get Int8 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int8
getInt8
                           | Word8
m Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
int16Code = Int16 -> Int
forall a. Integral a => a -> Int
toInt (Int16 -> Int) -> Get Int16 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int16
getInt16be
                           | Word8
m Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
int32Code = Int32 -> Int
forall a. Integral a => a -> Int
toInt (Int32 -> Int) -> Get Int32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int32
getInt32be
                           | Word8
m Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
int64Code = Int64 -> Int
forall a. Integral a => a -> Int
toInt (Int64 -> Int) -> Get Int64 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int64
getInt64be
                           | Bool
otherwise      = String -> Get Int
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected int"

instance BoltValue Double where
  pack :: Double -> Put
pack Double
dbl = Word8 -> Put
putWord8 Word8
doubleCode Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word64 -> Put
putWord64be (Double -> Word64
doubleToWord Double
dbl)

  unpackT :: Get Double
unpackT = Get Word8
getWord8 Get Word8 -> (Word8 -> Get Double) -> Get Double
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get Double
unpackByMarker
    where unpackByMarker :: Word8 -> Get Double
unpackByMarker Word8
m | Word8
m Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
doubleCode = Word64 -> Double
wordToDouble (Word64 -> Double) -> Get Word64 -> Get Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord64be
                           | Bool
otherwise       = String -> Get Double
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected double"

instance BoltValue Text where
  pack :: Text -> Put
pack Text
txt = Int -> Put -> (Word8, Word8, Word8, Word8) -> Put
mkPackedCollection (ByteString -> Int
B.length ByteString
bs) Put
pbs (Word8
textConst, Word8
text8Code, Word8
text16Code, Word8
text32Code)
    where bs :: ByteString
bs = Text -> ByteString
encodeUtf8 Text
txt
          pbs :: Put
pbs = ByteString -> Put
putByteString ByteString
bs

  unpackT :: Get Text
unpackT = Get Word8
getWord8 Get Word8 -> (Word8 -> Get Text) -> Get Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get Text
unpackByMarker
    where unpackByMarker :: Word8 -> Get Text
unpackByMarker Word8
m | Word8 -> Bool
isTinyText Word8
m    = Int -> Get Text
unpackTextBySize (Word8 -> Int
getSize Word8
m)
                           | Word8
m Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
text8Code  = Int8 -> Int
forall a. Integral a => a -> Int
toInt (Int8 -> Int) -> Get Int8 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int8
getInt8 Get Int -> (Int -> Get Text) -> Get Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get Text
unpackTextBySize
                           | Word8
m Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
text16Code = Int16 -> Int
forall a. Integral a => a -> Int
toInt (Int16 -> Int) -> Get Int16 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int16
getInt16be Get Int -> (Int -> Get Text) -> Get Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get Text
unpackTextBySize
                           | Word8
m Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
text32Code = Int32 -> Int
forall a. Integral a => a -> Int
toInt (Int32 -> Int) -> Get Int32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int32
getInt32be Get Int -> (Int -> Get Text) -> Get Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get Text
unpackTextBySize
                           | Bool
otherwise       = String -> Get Text
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected text"
          unpackTextBySize :: Int -> Get Text
unpackTextBySize Int
size = do ByteString
str <- Int -> Get ByteString
getByteString Int
size
                                     Text -> Get Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Get Text) -> Text -> Get Text
forall a b. (a -> b) -> a -> b
$! ByteString -> Text
decodeUtf8 ByteString
str

instance BoltValue a => BoltValue [a] where
  pack :: [a] -> Put
pack [a]
lst = Int -> Put -> (Word8, Word8, Word8, Word8) -> Put
mkPackedCollection ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
lst) Put
pbs (Word8
listConst, Word8
list8Code, Word8
list16Code, Word8
list32Code)
    where pbs :: Put
pbs = (a -> Put) -> [a] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> Put
forall a. BoltValue a => a -> Put
pack [a]
lst

  unpackT :: Get [a]
unpackT = Get Word8
getWord8 Get Word8 -> (Word8 -> Get [a]) -> Get [a]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get [a]
forall b. BoltValue b => Word8 -> Get [b]
unpackByMarker
    where unpackByMarker :: Word8 -> Get [b]
unpackByMarker Word8
m | Word8 -> Bool
isTinyList Word8
m    = Int -> Get [b]
forall b b. (Num b, Enum b, BoltValue b) => b -> Get [b]
unpackListBySize (Word8 -> Int
getSize Word8
m)
                           | Word8
m Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
list8Code  = Int8 -> Int
forall a. Integral a => a -> Int
toInt (Int8 -> Int) -> Get Int8 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int8
getInt8 Get Int -> (Int -> Get [b]) -> Get [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get [b]
forall b b. (Num b, Enum b, BoltValue b) => b -> Get [b]
unpackListBySize
                           | Word8
m Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
list16Code = Int16 -> Int
forall a. Integral a => a -> Int
toInt (Int16 -> Int) -> Get Int16 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int16
getInt16be Get Int -> (Int -> Get [b]) -> Get [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get [b]
forall b b. (Num b, Enum b, BoltValue b) => b -> Get [b]
unpackListBySize
                           | Word8
m Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
list32Code = Int32 -> Int
forall a. Integral a => a -> Int
toInt (Int32 -> Int) -> Get Int32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int32
getInt32be Get Int -> (Int -> Get [b]) -> Get [b]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get [b]
forall b b. (Num b, Enum b, BoltValue b) => b -> Get [b]
unpackListBySize
                           | Bool
otherwise       = String -> Get [b]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected list"
          unpackListBySize :: b -> Get [b]
unpackListBySize b
size = [b] -> (b -> Get b) -> Get [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [b
1..b
size] ((b -> Get b) -> Get [b]) -> (b -> Get b) -> Get [b]
forall a b. (a -> b) -> a -> b
$ Get b -> b -> Get b
forall a b. a -> b -> a
const Get b
forall a. BoltValue a => Get a
unpackT

instance BoltValue a => BoltValue (Map Text a) where
  pack :: Map Text a -> Put
pack Map Text a
dict = Int -> Put -> (Word8, Word8, Word8, Word8) -> Put
mkPackedCollection (Map Text a -> Int
forall k a. Map k a -> Int
M.size Map Text a
dict) Put
pbs (Word8
dictConst, Word8
dict8Code, Word8
dict16Code, Word8
dict32Code)
    where pbs :: Put
pbs = ((Text, a) -> Put) -> [(Text, a)] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Text, a) -> Put
forall a a. (BoltValue a, BoltValue a) => (a, a) -> Put
mkPairPack ([(Text, a)] -> Put) -> [(Text, a)] -> Put
forall a b. (a -> b) -> a -> b
$ Map Text a -> [(Text, a)]
forall k a. Map k a -> [(k, a)]
M.assocs Map Text a
dict
          mkPairPack :: (a, a) -> Put
mkPairPack (a
key, a
val) = a -> Put
forall a. BoltValue a => a -> Put
pack a
key Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> Put
forall a. BoltValue a => a -> Put
pack a
val

  unpackT :: Get (Map Text a)
unpackT = Get Word8
getWord8 Get Word8 -> (Word8 -> Get (Map Text a)) -> Get (Map Text a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get (Map Text a)
unpackByMarker
    where unpackByMarker :: Word8 -> Get (Map Text a)
unpackByMarker Word8
m | Word8 -> Bool
isTinyDict Word8
m    = Int -> Get (Map Text a)
unpackDictBySize (Word8 -> Int
getSize Word8
m)
                           | Word8
m Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
dict8Code  = Int16 -> Int
forall a. Integral a => a -> Int
toInt (Int16 -> Int) -> Get Int16 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int16
getInt16be Get Int -> (Int -> Get (Map Text a)) -> Get (Map Text a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get (Map Text a)
unpackDictBySize
                           | Word8
m Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
dict16Code = Int16 -> Int
forall a. Integral a => a -> Int
toInt (Int16 -> Int) -> Get Int16 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int16
getInt16be Get Int -> (Int -> Get (Map Text a)) -> Get (Map Text a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get (Map Text a)
unpackDictBySize
                           | Word8
m Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
dict32Code = Int32 -> Int
forall a. Integral a => a -> Int
toInt (Int32 -> Int) -> Get Int32 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int32
getInt32be Get Int -> (Int -> Get (Map Text a)) -> Get (Map Text a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get (Map Text a)
unpackDictBySize
                           | Bool
otherwise       = String -> Get (Map Text a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected dict"
          unpackDictBySize :: Int -> Get (Map Text a)
unpackDictBySize = ([(Text, a)] -> Map Text a
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, a)] -> Map Text a) -> Get [(Text, a)] -> Get (Map Text a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Get [(Text, a)] -> Get (Map Text a))
-> (Int -> Get [(Text, a)]) -> Int -> Get (Map Text a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Get [(Text, a)]
forall b a b.
(Num b, Enum b, BoltValue a, BoltValue b) =>
b -> Get [(a, b)]
unpackPairsBySize
          unpackPairsBySize :: b -> Get [(a, b)]
unpackPairsBySize b
size = [b] -> (b -> Get (a, b)) -> Get [(a, b)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [b
1..b
size] ((b -> Get (a, b)) -> Get [(a, b)])
-> (b -> Get (a, b)) -> Get [(a, b)]
forall a b. (a -> b) -> a -> b
$ Get (a, b) -> b -> Get (a, b)
forall a b. a -> b -> a
const (Get (a, b) -> b -> Get (a, b)) -> Get (a, b) -> b -> Get (a, b)
forall a b. (a -> b) -> a -> b
$ do
                                     !a
key <- Get a
forall a. BoltValue a => Get a
unpackT
                                     !b
value <- Get b
forall a. BoltValue a => Get a
unpackT
                                     (a, b) -> Get (a, b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
key, b
value)

instance BoltValue Structure where
  pack :: Structure -> Put
pack (Structure Word8
sig [Value]
lst) | Word16
size Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
< Word16
forall a. Integral a => a
size4  = Word8 -> Put
putWord8 (Word8
structConst Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
size) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Put
pData
                           | Word16
size Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
< Word16
forall a. Integral a => a
size8  = Word8 -> Put
putWord8 Word8
struct8Code Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
putWord8 (Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
size) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Put
pData
                           | Word16
size Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
< Word16
forall a. Integral a => a
size16 = Word8 -> Put
putWord8 Word8
struct16Code Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be Word16
size Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Put
pData
                           | Bool
otherwise     = String -> Put
forall a. HasCallStack => String -> a
error String
"Cannot pack so large structure"
    where size :: Word16
size = Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ [Value] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
lst :: Word16
          pData :: Put
pData = Word8 -> Put
putWord8 Word8
sig Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Value -> Put) -> [Value] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Value -> Put
forall a. BoltValue a => a -> Put
pack [Value]
lst

  unpackT :: Get Structure
unpackT = Get Word8
getWord8 Get Word8 -> (Word8 -> Get Structure) -> Get Structure
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get Structure
unpackByMarker
    where unpackByMarker :: Word8 -> Get Structure
unpackByMarker Word8
m | Word8 -> Bool
isTinyStruct Word8
m    = Int -> Get Structure
unpackStructureBySize (Word8 -> Int
getSize Word8
m)
                           | Word8
m Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
struct8Code  = Int8 -> Int
forall a. Integral a => a -> Int
toInt (Int8 -> Int) -> Get Int8 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int8
getInt8 Get Int -> (Int -> Get Structure) -> Get Structure
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get Structure
unpackStructureBySize
                           | Word8
m Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
struct16Code = Int16 -> Int
forall a. Integral a => a -> Int
toInt (Int16 -> Int) -> Get Int16 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int16
getInt16be Get Int -> (Int -> Get Structure) -> Get Structure
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get Structure
unpackStructureBySize
                           | Bool
otherwise         = String -> Get Structure
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"expected structure"
          unpackStructureBySize :: Int -> Get Structure
unpackStructureBySize Int
size = Word8 -> [Value] -> Structure
Structure (Word8 -> [Value] -> Structure)
-> Get Word8 -> Get ([Value] -> Structure)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8 Get ([Value] -> Structure) -> Get [Value] -> Get Structure
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> Get Value -> Get [Value]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
size Get Value
forall a. BoltValue a => Get a
unpackT

instance BoltValue Value where
  pack :: Value -> Put
pack (N ()
n) = () -> Put
forall a. BoltValue a => a -> Put
pack ()
n
  pack (B Bool
b) = Bool -> Put
forall a. BoltValue a => a -> Put
pack Bool
b
  pack (I Int
i) = Int -> Put
forall a. BoltValue a => a -> Put
pack Int
i
  pack (F Double
d) = Double -> Put
forall a. BoltValue a => a -> Put
pack Double
d
  pack (T Text
t) = Text -> Put
forall a. BoltValue a => a -> Put
pack Text
t
  pack (L [Value]
l) = [Value] -> Put
forall a. BoltValue a => a -> Put
pack [Value]
l
  pack (M Map Text Value
m) = Map Text Value -> Put
forall a. BoltValue a => a -> Put
pack Map Text Value
m
  pack (S Structure
s) = Structure -> Put
forall a. BoltValue a => a -> Put
pack Structure
s

  unpackT :: Get Value
unpackT = Get Word8 -> Get Word8
forall a. Get a -> Get a
lookAhead Get Word8
getWord8 Get Word8 -> (Word8 -> Get Value) -> Get Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Word8 -> Get Value
unpackByMarker
    where unpackByMarker :: Word8 -> Get Value
unpackByMarker Word8
m | Word8 -> Bool
isNull   Word8
m = () -> Value
N (() -> Value) -> Get () -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ()
forall a. BoltValue a => Get a
unpackT
                           | Word8 -> Bool
isBool   Word8
m = Bool -> Value
B (Bool -> Value) -> Get Bool -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Bool
forall a. BoltValue a => Get a
unpackT
                           | Word8 -> Bool
isInt    Word8
m = Int -> Value
I (Int -> Value) -> Get Int -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int
forall a. BoltValue a => Get a
unpackT
                           | Word8 -> Bool
isDouble Word8
m = Double -> Value
F (Double -> Value) -> Get Double -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Double
forall a. BoltValue a => Get a
unpackT
                           | Word8 -> Bool
isText   Word8
m = Text -> Value
T (Text -> Value) -> Get Text -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Text
forall a. BoltValue a => Get a
unpackT
                           | Word8 -> Bool
isList   Word8
m = [Value] -> Value
L ([Value] -> Value) -> Get [Value] -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get [Value]
forall a. BoltValue a => Get a
unpackT
                           | Word8 -> Bool
isDict   Word8
m = Map Text Value -> Value
M (Map Text Value -> Value) -> Get (Map Text Value) -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (Map Text Value)
forall a. BoltValue a => Get a
unpackT
                           | Word8 -> Bool
isStruct Word8
m = Structure -> Value
S (Structure -> Value) -> Get Structure -> Get Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Structure
forall a. BoltValue a => Get a
unpackT
                           | Bool
otherwise  = String -> Get Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"not value"

-- = Structure instances for Neo4j structures

instance FromStructure Node where
  fromStructure :: Structure -> m Node
fromStructure Structure
struct =
    case Structure
struct of
      (Structure Word8
sig [I Int
nid, L [Value]
vlbls, M Map Text Value
prps]) | Word8
sig Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
sigNode -> ([Text] -> Map Text Value -> Node)
-> Map Text Value -> [Text] -> Node
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> [Text] -> Map Text Value -> Node
Node Int
nid) Map Text Value
prps ([Text] -> Node) -> m [Text] -> m Node
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value] -> m [Text]
forall (f :: * -> *).
MonadError UnpackError f =>
[Value] -> f [Text]
cnvT [Value]
vlbls
      Structure
_                                                         -> UnpackError -> m Node
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (UnpackError -> m Node) -> UnpackError -> m Node
forall a b. (a -> b) -> a -> b
$ Text -> UnpackError
Not Text
"Node"
    where
      cnvT :: [Value] -> f [Text]
cnvT []       = [Text] -> f [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      cnvT (T Text
x:[Value]
xs) = (Text
xText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) ([Text] -> [Text]) -> f [Text] -> f [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value] -> f [Text]
cnvT [Value]
xs
      cnvT [Value]
_        = UnpackError -> f [Text]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError UnpackError
NotString

instance FromStructure Relationship where
  fromStructure :: Structure -> m Relationship
fromStructure Structure
struct =
    case Structure
struct of
      (Structure Word8
sig [I Int
rid, I Int
sni, I Int
eni, T Text
rt, M Map Text Value
rp]) | Word8
sig Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
sigRel -> Relationship -> m Relationship
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Relationship -> m Relationship) -> Relationship -> m Relationship
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> Text -> Map Text Value -> Relationship
Relationship Int
rid Int
sni Int
eni Text
rt Map Text Value
rp
      Structure
_                                                                 -> UnpackError -> m Relationship
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (UnpackError -> m Relationship) -> UnpackError -> m Relationship
forall a b. (a -> b) -> a -> b
$ Text -> UnpackError
Not Text
"Relationship"

instance FromStructure URelationship where
  fromStructure :: Structure -> m URelationship
fromStructure Structure
struct =
    case Structure
struct of
      (Structure Word8
sig [I Int
rid, T Text
rt, M Map Text Value
rp]) | Word8
sig Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
sigURel -> URelationship -> m URelationship
forall (f :: * -> *) a. Applicative f => a -> f a
pure (URelationship -> m URelationship)
-> URelationship -> m URelationship
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Map Text Value -> URelationship
URelationship Int
rid Text
rt Map Text Value
rp
      Structure
_                                                    -> UnpackError -> m URelationship
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (UnpackError -> m URelationship) -> UnpackError -> m URelationship
forall a b. (a -> b) -> a -> b
$ Text -> UnpackError
Not Text
"URelationship"

instance FromStructure Path where
  fromStructure :: Structure -> m Path
fromStructure Structure
struct =
    case Structure
struct of
      (Structure Word8
sig [L [Value]
vnp, L [Value]
vrp, L [Value]
vip]) | Word8
sig Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
sigPath -> [Node] -> [URelationship] -> [Int] -> Path
Path ([Node] -> [URelationship] -> [Int] -> Path)
-> m [Node] -> m ([URelationship] -> [Int] -> Path)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value] -> m [Node]
forall (f :: * -> *) a.
(FromStructure a, MonadError UnpackError f) =>
[Value] -> f [a]
cnvN [Value]
vnp m ([URelationship] -> [Int] -> Path)
-> m [URelationship] -> m ([Int] -> Path)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Value] -> m [URelationship]
forall (f :: * -> *) a.
(FromStructure a, MonadError UnpackError f) =>
[Value] -> f [a]
cnvR [Value]
vrp m ([Int] -> Path) -> m [Int] -> m Path
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Value] -> m [Int]
forall (f :: * -> *).
MonadError UnpackError f =>
[Value] -> f [Int]
cnvI [Value]
vip
      Structure
_                                                      -> UnpackError -> m Path
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (UnpackError -> m Path) -> UnpackError -> m Path
forall a b. (a -> b) -> a -> b
$ Text -> UnpackError
Not Text
"Path"
    where
      cnvN :: [Value] -> f [a]
cnvN []       = [a] -> f [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      cnvN (S Structure
x:[Value]
xs) = (:) (a -> [a] -> [a]) -> f a -> f ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Structure -> f a
forall a (m :: * -> *).
(FromStructure a, MonadError UnpackError m) =>
Structure -> m a
fromStructure Structure
x f ([a] -> [a]) -> f [a] -> f [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Value] -> f [a]
cnvN [Value]
xs
      cnvN [Value]
_        = UnpackError -> f [a]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (UnpackError -> f [a]) -> UnpackError -> f [a]
forall a b. (a -> b) -> a -> b
$ Text -> UnpackError
Not Text
"Node"

      cnvR :: [Value] -> f [a]
cnvR []       = [a] -> f [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      cnvR (S Structure
x:[Value]
xs) = (:) (a -> [a] -> [a]) -> f a -> f ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Structure -> f a
forall a (m :: * -> *).
(FromStructure a, MonadError UnpackError m) =>
Structure -> m a
fromStructure Structure
x f ([a] -> [a]) -> f [a] -> f [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Value] -> f [a]
cnvR [Value]
xs
      cnvR [Value]
_        = UnpackError -> f [a]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError UnpackError
NotStructure

      cnvI :: [Value] -> f [Int]
cnvI []       = [Int] -> f [Int]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
      cnvI (I Int
x:[Value]
xs) = (Int
xInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:) ([Int] -> [Int]) -> f [Int] -> f [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value] -> f [Int]
cnvI [Value]
xs
      cnvI [Value]
_        = UnpackError -> f [Int]
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError UnpackError
NotInt


decodeStrict :: Binary a => ByteString -> a
decodeStrict :: ByteString -> a
decodeStrict = ByteString -> a
forall a. Binary a => ByteString -> a
decode (ByteString -> a) -> (ByteString -> ByteString) -> ByteString -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
fromStrict

encodeStrict :: Binary a => a -> ByteString
encodeStrict :: a -> ByteString
encodeStrict = ByteString -> ByteString
toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. Binary a => a -> ByteString
encode

-- |Pack collection using it's size and set of BOLT constants
mkPackedCollection :: Int -> Put -> (Word8, Word8, Word8, Word8) -> Put
mkPackedCollection :: Int -> Put -> (Word8, Word8, Word8, Word8) -> Put
mkPackedCollection Int
size Put
bst (Word8
wt, Word8
w8, Word8
w16, Word8
w32)
  | Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
forall a. Integral a => a
size4  = Word8 -> Put
putWord8 (Word8
wt Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Put
bst
  | Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
forall a. Integral a => a
size8  = Word8 -> Put
putWord8 Word8
w8 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
putWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Put
bst
  | Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
forall a. Integral a => a
size16 = Word8 -> Put
putWord8 Word8
w16 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size :: Word16) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Put
bst
  | Int
size Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
forall a. Integral a => a
size32 = Word8 -> Put
putWord8 Word8
w32 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Put
putWord32be (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size :: Word32) Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Put
bst
  | Bool
otherwise  = String -> Put
forall a. HasCallStack => String -> a
error String
"Cannot pack so large collection"

size4,size8, size16,size32 :: Integral a => a
size4 :: a
size4  = a
2a -> Int -> a
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
4  :: Int)
size8 :: a
size8  = a
2a -> Int -> a
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
8  :: Int)
size16 :: a
size16 = a
2a -> Int -> a
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
16 :: Int)
size32 :: a
size32 = a
2a -> Int -> a
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
32 :: Int)