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

-- |Error during unpack process
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"

-- |The 'UnpackT' transformer helps to unpack a set of values from one 'ByteString'
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)

-- |The 'Structure' datatype describes Neo4j structure for BOLT protocol
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)

-- |Generalizes all datatypes that can be deserialized from 'Structure's.
class FromStructure a where
  fromStructure :: MonadError UnpackError m => Structure -> m a

-- |Generalizes all datatypes that can be serialized to 'Structure's.
class ToStructure a where
  toStructure :: a -> Structure

-- |The 'BoltValue' class describes values, that can be packed and unpacked for BOLT protocol.
class BoltValue a where
  -- |Packs a value to 'ByteString'
  pack :: a -> Put
  -- |Unpacks in a State monad to get values from single 'ByteString'
  unpackT :: Get a

-- |Unpacks a 'ByteString' to selected value
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

-- |Old-style unpack that runs 'fail' on error
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

-- |Unpacks a 'ByteString' to selected value by some custom action
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

-- |The 'Value' datatype generalizes all primitive 'BoltValue's
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)

-- |Every datatype that can be represented as BOLT protocol value
class IsValue a where
  -- |Wraps value with 'Value' constructor
  toValue :: HasCallStack => a -> Value
  -- |How to represent a list of values
  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

-- |Wrap key-value pair with 'Value' datatype
(=:) :: 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)

-- |Construct properties map from list
props :: [(Text, Value)] -> Map Text Value
props :: [(Text, Value)] -> Map Text Value
props = forall k a. Ord k => [(k, a)] -> Map k a
fromList

-- = Structure types

-- == Neo4j subjects

data Node = Node { Node -> Int
nodeIdentity :: Int             -- ^Neo4j node identifier
                 , Node -> [Text]
labels       :: [Text]          -- ^Set of node labels (types)
                 , Node -> Map Text Value
nodeProps    :: Map Text Value  -- ^Dict of node properties
                 }
  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            -- ^Neo4j relationship identifier
                                 , Relationship -> Int
startNodeId :: Int            -- ^Identifier of start node
                                 , Relationship -> Int
endNodeId   :: Int            -- ^Identifier of end node
                                 , Relationship -> Text
relType     :: Text           -- ^Relationship type
                                 , Relationship -> Map Text Value
relProps    :: Map Text Value -- ^Dict of relationship properties
                                 }
  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            -- ^Neo4j relationship identifier
                                   , URelationship -> Text
urelType     :: Text           -- ^Relationship type
                                   , URelationship -> Map Text Value
urelProps    :: Map Text Value -- ^Dict of relationship properties
                                   }
  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]          -- ^Chain of 'Node's in path
                 , Path -> [URelationship]
pathRelationships :: [URelationship] -- ^Chain of 'Relationship's in path
                 , Path -> [Int]
pathSequence      :: [Int]           -- ^Path sequence
                 }
  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)