{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DerivingStrategies #-}
module Database.Bolt.Value.Type where
import Control.DeepSeq (NFData)
import Control.Monad.Except (ExceptT, MonadError (..))
import Control.Monad.Fail as Fail (MonadFail (..))
import Control.Monad.State (MonadState (..), StateT (..))
import Data.Binary.Get
import Data.Binary.Put
import Data.ByteString (ByteString)
import Data.ByteString.Lazy (fromStrict)
import qualified Data.ByteString.Lazy as BSL
import Data.List.NonEmpty (NonEmpty (..), toList)
import Data.Map.Strict (Map, fromList)
import Data.Text (Text)
import qualified Data.Text as T (pack, unpack)
import Data.Word (Word8)
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
data UnpackError = NotNull
| NotInt
| NotFloat
| NotString
| NotBool
| NotList
| NotDict
| NotStructure
| NotValue
| BinaryError Text
| Not Text
deriving (UnpackError -> UnpackError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnpackError -> UnpackError -> Bool
$c/= :: UnpackError -> UnpackError -> Bool
== :: UnpackError -> UnpackError -> Bool
$c== :: UnpackError -> UnpackError -> Bool
Eq, Eq UnpackError
UnpackError -> UnpackError -> Bool
UnpackError -> UnpackError -> Ordering
UnpackError -> UnpackError -> UnpackError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UnpackError -> UnpackError -> UnpackError
$cmin :: UnpackError -> UnpackError -> UnpackError
max :: UnpackError -> UnpackError -> UnpackError
$cmax :: UnpackError -> UnpackError -> UnpackError
>= :: UnpackError -> UnpackError -> Bool
$c>= :: UnpackError -> UnpackError -> Bool
> :: UnpackError -> UnpackError -> Bool
$c> :: UnpackError -> UnpackError -> Bool
<= :: UnpackError -> UnpackError -> Bool
$c<= :: UnpackError -> UnpackError -> Bool
< :: UnpackError -> UnpackError -> Bool
$c< :: UnpackError -> UnpackError -> Bool
compare :: UnpackError -> UnpackError -> Ordering
$ccompare :: UnpackError -> UnpackError -> Ordering
Ord)
instance Show UnpackError where
show :: UnpackError -> String
show UnpackError
NotNull = String
"Not a Null value"
show UnpackError
NotInt = String
"Not an Int value"
show UnpackError
NotFloat = String
"Not a Float value"
show UnpackError
NotString = String
"Not a String value"
show UnpackError
NotBool = String
"Not a Bool value"
show UnpackError
NotList = String
"Not a List value"
show UnpackError
NotDict = String
"Not a Dict value"
show UnpackError
NotStructure = String
"Not a Structure value"
show UnpackError
NotValue = String
"Not a Value value"
show (BinaryError Text
what) = String
"Error while decoding binary format: " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
what
show (Not Text
what) = String
"Not a " forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
what forall a. Semigroup a => a -> a -> a
<> String
" (Structure) value"
newtype UnpackT m a = UnpackT { forall (m :: * -> *) a.
UnpackT m a -> ExceptT UnpackError (StateT ByteString m) a
runUnpackT :: ExceptT UnpackError (StateT ByteString m) a }
deriving newtype (forall a b. a -> UnpackT m b -> UnpackT m a
forall a b. (a -> b) -> UnpackT m a -> UnpackT m b
forall (m :: * -> *) a b.
Functor m =>
a -> UnpackT m b -> UnpackT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> UnpackT m a -> UnpackT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> UnpackT m b -> UnpackT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> UnpackT m b -> UnpackT m a
fmap :: forall a b. (a -> b) -> UnpackT m a -> UnpackT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> UnpackT m a -> UnpackT m b
Functor, forall a. a -> UnpackT m a
forall a b. UnpackT m a -> UnpackT m b -> UnpackT m a
forall a b. UnpackT m a -> UnpackT m b -> UnpackT m b
forall a b. UnpackT m (a -> b) -> UnpackT m a -> UnpackT m b
forall a b c.
(a -> b -> c) -> UnpackT m a -> UnpackT m b -> UnpackT m c
forall {m :: * -> *}. Monad m => Functor (UnpackT m)
forall (m :: * -> *) a. Monad m => a -> UnpackT m a
forall (m :: * -> *) a b.
Monad m =>
UnpackT m a -> UnpackT m b -> UnpackT m a
forall (m :: * -> *) a b.
Monad m =>
UnpackT m a -> UnpackT m b -> UnpackT m b
forall (m :: * -> *) a b.
Monad m =>
UnpackT m (a -> b) -> UnpackT m a -> UnpackT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> UnpackT m a -> UnpackT m b -> UnpackT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. UnpackT m a -> UnpackT m b -> UnpackT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
UnpackT m a -> UnpackT m b -> UnpackT m a
*> :: forall a b. UnpackT m a -> UnpackT m b -> UnpackT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
UnpackT m a -> UnpackT m b -> UnpackT m b
liftA2 :: forall a b c.
(a -> b -> c) -> UnpackT m a -> UnpackT m b -> UnpackT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> UnpackT m a -> UnpackT m b -> UnpackT m c
<*> :: forall a b. UnpackT m (a -> b) -> UnpackT m a -> UnpackT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
UnpackT m (a -> b) -> UnpackT m a -> UnpackT m b
pure :: forall a. a -> UnpackT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> UnpackT m a
Applicative, forall a. a -> UnpackT m a
forall a b. UnpackT m a -> UnpackT m b -> UnpackT m b
forall a b. UnpackT m a -> (a -> UnpackT m b) -> UnpackT m b
forall (m :: * -> *). Monad m => Applicative (UnpackT m)
forall (m :: * -> *) a. Monad m => a -> UnpackT m a
forall (m :: * -> *) a b.
Monad m =>
UnpackT m a -> UnpackT m b -> UnpackT m b
forall (m :: * -> *) a b.
Monad m =>
UnpackT m a -> (a -> UnpackT m b) -> UnpackT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> UnpackT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> UnpackT m a
>> :: forall a b. UnpackT m a -> UnpackT m b -> UnpackT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
UnpackT m a -> UnpackT m b -> UnpackT m b
>>= :: forall a b. UnpackT m a -> (a -> UnpackT m b) -> UnpackT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
UnpackT m a -> (a -> UnpackT m b) -> UnpackT m b
Monad, MonadError UnpackError, MonadState ByteString)
data Structure = Structure { Structure -> Word8
signature :: Word8
, Structure -> [Value]
fields :: [Value]
}
deriving stock (Int -> Structure -> ShowS
[Structure] -> ShowS
Structure -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Structure] -> ShowS
$cshowList :: [Structure] -> ShowS
show :: Structure -> String
$cshow :: Structure -> String
showsPrec :: Int -> Structure -> ShowS
$cshowsPrec :: Int -> Structure -> ShowS
Show, Structure -> Structure -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Structure -> Structure -> Bool
$c/= :: Structure -> Structure -> Bool
== :: Structure -> Structure -> Bool
$c== :: Structure -> Structure -> Bool
Eq, forall x. Rep Structure x -> Structure
forall x. Structure -> Rep Structure x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Structure x -> Structure
$cfrom :: forall x. Structure -> Rep Structure x
Generic)
deriving anyclass (Structure -> ()
forall a. (a -> ()) -> NFData a
rnf :: Structure -> ()
$crnf :: Structure -> ()
NFData)
class FromStructure a where
fromStructure :: MonadError UnpackError m => Structure -> m a
class ToStructure a where
toStructure :: a -> Structure
class BoltValue a where
pack :: a -> Put
unpackT :: Get a
unpack :: (Monad m, BoltValue a) => ByteString -> m (Either UnpackError a)
unpack :: forall (m :: * -> *) a.
(Monad m, BoltValue a) =>
ByteString -> m (Either UnpackError a)
unpack = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Get a -> ByteString -> Either UnpackError a
unpackAction forall a. BoltValue a => Get a
unpackT forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
fromStrict
unpackF :: (MonadFail m, BoltValue a) => ByteString -> m a
unpackF :: forall (m :: * -> *) a.
(MonadFail m, BoltValue a) =>
ByteString -> m a
unpackF ByteString
bs = do let result :: Either UnpackError a
result = forall a. Get a -> ByteString -> Either UnpackError a
unpackAction forall a. BoltValue a => Get a
unpackT forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
fromStrict ByteString
bs
case Either UnpackError a
result of
Right a
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
Left UnpackError
e -> forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show UnpackError
e
unpackAction :: Get a -> BSL.ByteString -> Either UnpackError a
unpackAction :: forall a. Get a -> ByteString -> Either UnpackError a
unpackAction Get a
action ByteString
bs = case forall a.
Get a
-> ByteString
-> Either
(ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
runGetOrFail Get a
action ByteString
bs of
Left (ByteString
_, ByteOffset
_, String
err) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> UnpackError
BinaryError forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
err
Right (ByteString
_, ByteOffset
_, a
a) -> forall a b. b -> Either a b
Right a
a
data Value = N ()
| B Bool
| I Int
| F Double
| T Text
| L [Value]
| M (Map Text Value)
| S Structure
deriving stock (Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show, Value -> Value -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c== :: Value -> Value -> Bool
Eq, forall x. Rep Value x -> Value
forall x. Value -> Rep Value x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Value x -> Value
$cfrom :: forall x. Value -> Rep Value x
Generic)
deriving anyclass (Value -> ()
forall a. (a -> ()) -> NFData a
rnf :: Value -> ()
$crnf :: Value -> ()
NFData)
class IsValue a where
toValue :: HasCallStack => a -> Value
toValueList :: HasCallStack => [a] -> Value
toValueList = [Value] -> Value
L forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. (IsValue a, HasCallStack) => a -> Value
toValue
instance IsValue () where
toValue :: HasCallStack => () -> Value
toValue = () -> Value
N
instance IsValue Bool where
toValue :: HasCallStack => Bool -> Value
toValue = Bool -> Value
B
instance IsValue Int where
toValue :: HasCallStack => Int -> Value
toValue = Int -> Value
I
instance IsValue Integer where
toValue :: HasCallStack => Integer -> Value
toValue = Int -> Value
I forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
instance IsValue Double where
toValue :: HasCallStack => Double -> Value
toValue = Double -> Value
F
instance IsValue Float where
toValue :: HasCallStack => Float -> Value
toValue = Double -> Value
F forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Real a, Fractional b) => a -> b
realToFrac
instance IsValue Text where
toValue :: HasCallStack => Text -> Value
toValue = Text -> Value
T
instance IsValue Char where
toValue :: HasCallStack => Char -> Value
toValue = forall a. (IsValue a, HasCallStack) => [a] -> Value
toValueList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
toValueList :: HasCallStack => String -> Value
toValueList = Text -> Value
T forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
instance IsValue a => IsValue [a] where
toValue :: HasCallStack => [a] -> Value
toValue = forall a. (IsValue a, HasCallStack) => [a] -> Value
toValueList
instance IsValue a => IsValue (NonEmpty a) where
toValue :: HasCallStack => NonEmpty a -> Value
toValue = forall a. (IsValue a, HasCallStack) => a -> Value
toValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
toList
instance IsValue a => IsValue (Maybe a) where
toValue :: HasCallStack => Maybe a -> Value
toValue (Just a
a) = forall a. (IsValue a, HasCallStack) => a -> Value
toValue a
a
toValue Maybe a
_ = () -> Value
N ()
instance IsValue (Map Text Value) where
toValue :: HasCallStack => Map Text Value -> Value
toValue = Map Text Value -> Value
M
(=:) :: IsValue a => Text -> a -> (Text, Value)
=: :: forall a. IsValue a => Text -> a -> (Text, Value)
(=:) Text
key a
val = (Text
key, forall a. (IsValue a, HasCallStack) => a -> Value
toValue a
val)
props :: [(Text, Value)] -> Map Text Value
props :: [(Text, Value)] -> Map Text Value
props = forall k a. Ord k => [(k, a)] -> Map k a
fromList
data Node = Node { Node -> Int
nodeIdentity :: Int
, Node -> [Text]
labels :: [Text]
, Node -> Map Text Value
nodeProps :: Map Text Value
}
deriving (Int -> Node -> ShowS
[Node] -> ShowS
Node -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Node] -> ShowS
$cshowList :: [Node] -> ShowS
show :: Node -> String
$cshow :: Node -> String
showsPrec :: Int -> Node -> ShowS
$cshowsPrec :: Int -> Node -> ShowS
Show, Node -> Node -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Node -> Node -> Bool
$c/= :: Node -> Node -> Bool
== :: Node -> Node -> Bool
$c== :: Node -> Node -> Bool
Eq)
data Relationship = Relationship { Relationship -> Int
relIdentity :: Int
, Relationship -> Int
startNodeId :: Int
, Relationship -> Int
endNodeId :: Int
, Relationship -> Text
relType :: Text
, Relationship -> Map Text Value
relProps :: Map Text Value
}
deriving (Int -> Relationship -> ShowS
[Relationship] -> ShowS
Relationship -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Relationship] -> ShowS
$cshowList :: [Relationship] -> ShowS
show :: Relationship -> String
$cshow :: Relationship -> String
showsPrec :: Int -> Relationship -> ShowS
$cshowsPrec :: Int -> Relationship -> ShowS
Show, Relationship -> Relationship -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Relationship -> Relationship -> Bool
$c/= :: Relationship -> Relationship -> Bool
== :: Relationship -> Relationship -> Bool
$c== :: Relationship -> Relationship -> Bool
Eq)
data URelationship = URelationship { URelationship -> Int
urelIdentity :: Int
, URelationship -> Text
urelType :: Text
, URelationship -> Map Text Value
urelProps :: Map Text Value
}
deriving (Int -> URelationship -> ShowS
[URelationship] -> ShowS
URelationship -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [URelationship] -> ShowS
$cshowList :: [URelationship] -> ShowS
show :: URelationship -> String
$cshow :: URelationship -> String
showsPrec :: Int -> URelationship -> ShowS
$cshowsPrec :: Int -> URelationship -> ShowS
Show, URelationship -> URelationship -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: URelationship -> URelationship -> Bool
$c/= :: URelationship -> URelationship -> Bool
== :: URelationship -> URelationship -> Bool
$c== :: URelationship -> URelationship -> Bool
Eq)
data Path = Path { Path -> [Node]
pathNodes :: [Node]
, Path -> [URelationship]
pathRelationships :: [URelationship]
, Path -> [Int]
pathSequence :: [Int]
}
deriving (Int -> Path -> ShowS
[Path] -> ShowS
Path -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Path] -> ShowS
$cshowList :: [Path] -> ShowS
show :: Path -> String
$cshow :: Path -> String
showsPrec :: Int -> Path -> ShowS
$cshowsPrec :: Int -> Path -> ShowS
Show, Path -> Path -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Path -> Path -> Bool
$c/= :: Path -> Path -> Bool
== :: Path -> Path -> Bool
$c== :: Path -> Path -> Bool
Eq)