{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Database.Bolt.Value.Type where

import           Control.Monad.Fail        as Fail (MonadFail (..))
import           Control.Monad.State       (MonadState (..), StateT (..), evalStateT)
import           Control.Monad.Except      (MonadError (..), ExceptT, runExceptT)
import           Data.ByteString           (ByteString)
import           Data.Map.Strict           (Map, fromList)
import           Data.Monoid               ((<>))
import           Data.Text                 (Text)
import qualified Data.Text                 as T (unpack, pack)
import           Data.Word                 (Word8)

-- |Error during unpack process
data UnpackError = NotNull
                 | NotInt
                 | NotFloat
                 | NotString
                 | NotBool
                 | NotList
                 | NotDict
                 | NotStructure
                 | NotValue
                 | Not Text
  deriving (UnpackError -> UnpackError -> Bool
(UnpackError -> UnpackError -> Bool)
-> (UnpackError -> UnpackError -> Bool) -> Eq UnpackError
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
Eq UnpackError
-> (UnpackError -> UnpackError -> Ordering)
-> (UnpackError -> UnpackError -> Bool)
-> (UnpackError -> UnpackError -> Bool)
-> (UnpackError -> UnpackError -> Bool)
-> (UnpackError -> UnpackError -> Bool)
-> (UnpackError -> UnpackError -> UnpackError)
-> (UnpackError -> UnpackError -> UnpackError)
-> Ord 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
$cp1Ord :: Eq UnpackError
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 (Not Text
what)   = String
"Not a " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
what String -> ShowS
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 { UnpackT m a -> ExceptT UnpackError (StateT ByteString m) a
runUnpackT :: ExceptT UnpackError (StateT ByteString m) a }
  deriving (a -> UnpackT m b -> UnpackT m a
(a -> b) -> UnpackT m a -> UnpackT m b
(forall a b. (a -> b) -> UnpackT m a -> UnpackT m b)
-> (forall a b. a -> UnpackT m b -> UnpackT m a)
-> Functor (UnpackT m)
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
<$ :: a -> UnpackT m b -> UnpackT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> UnpackT m b -> UnpackT m a
fmap :: (a -> b) -> UnpackT m a -> UnpackT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> UnpackT m a -> UnpackT m b
Functor, Functor (UnpackT m)
a -> UnpackT m a
Functor (UnpackT m)
-> (forall a. a -> UnpackT m a)
-> (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 a b. UnpackT m a -> UnpackT m b -> UnpackT m b)
-> (forall a b. UnpackT m a -> UnpackT m b -> UnpackT m a)
-> Applicative (UnpackT m)
UnpackT m a -> UnpackT m b -> UnpackT m b
UnpackT m a -> UnpackT m b -> UnpackT m a
UnpackT m (a -> b) -> UnpackT m a -> UnpackT m b
(a -> b -> c) -> UnpackT m a -> UnpackT m b -> UnpackT m c
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
<* :: 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
*> :: 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 :: (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
<*> :: 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 :: a -> UnpackT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> UnpackT m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (UnpackT m)
Applicative, Applicative (UnpackT m)
a -> UnpackT m a
Applicative (UnpackT m)
-> (forall a b. UnpackT m a -> (a -> UnpackT m b) -> UnpackT m b)
-> (forall a b. UnpackT m a -> UnpackT m b -> UnpackT m b)
-> (forall a. a -> UnpackT m a)
-> Monad (UnpackT m)
UnpackT m a -> (a -> UnpackT m b) -> UnpackT m b
UnpackT m a -> UnpackT m b -> UnpackT m b
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 :: a -> UnpackT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> UnpackT m a
>> :: 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
>>= :: 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
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (UnpackT m)
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 (Int -> Structure -> ShowS
[Structure] -> ShowS
Structure -> String
(Int -> Structure -> ShowS)
-> (Structure -> String)
-> ([Structure] -> ShowS)
-> Show Structure
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
(Structure -> Structure -> Bool)
-> (Structure -> Structure -> Bool) -> Eq Structure
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)

-- |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 -> ByteString
  -- |Unpacks in a State monad to get values from single 'ByteString'
  unpackT :: Monad m => UnpackT m a

-- |Unpacks a 'ByteString' to selected value
unpack :: (Monad m, BoltValue a)  => ByteString -> m (Either UnpackError a)
unpack :: ByteString -> m (Either UnpackError a)
unpack = UnpackT m a -> ByteString -> m (Either UnpackError a)
forall (m :: * -> *) a.
Monad m =>
UnpackT m a -> ByteString -> m (Either UnpackError a)
unpackAction UnpackT m a
forall a (m :: * -> *). (BoltValue a, Monad m) => UnpackT m a
unpackT

-- |Old-style unpack that runs 'fail' on error
unpackF :: (MonadFail m, BoltValue a) => ByteString -> m a
unpackF :: ByteString -> m a
unpackF ByteString
bs = do Either UnpackError a
result <- ByteString -> m (Either UnpackError a)
forall (m :: * -> *) a.
(Monad m, BoltValue a) =>
ByteString -> m (Either UnpackError a)
unpack ByteString
bs
                case Either UnpackError a
result of
                  Right a
x -> a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
                  Left  UnpackError
e -> String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ UnpackError -> String
forall a. Show a => a -> String
show UnpackError
e

-- |Unpacks a 'ByteString' to selected value by some custom action
unpackAction :: Monad m => UnpackT m a -> ByteString -> m (Either UnpackError a)
unpackAction :: UnpackT m a -> ByteString -> m (Either UnpackError a)
unpackAction UnpackT m a
action = StateT ByteString m (Either UnpackError a)
-> ByteString -> m (Either UnpackError a)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (ExceptT UnpackError (StateT ByteString m) a
-> StateT ByteString m (Either UnpackError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT UnpackError (StateT ByteString m) a
 -> StateT ByteString m (Either UnpackError a))
-> ExceptT UnpackError (StateT ByteString m) a
-> StateT ByteString m (Either UnpackError a)
forall a b. (a -> b) -> a -> b
$ UnpackT m a -> ExceptT UnpackError (StateT ByteString m) a
forall (m :: * -> *) a.
UnpackT m a -> ExceptT UnpackError (StateT ByteString m) a
runUnpackT UnpackT m a
action) 

-- |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 (Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
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
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
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)

-- |Every datatype that can be represented as BOLT protocol value
class IsValue a where
  -- |Wraps value with 'Value' constructor
  toValue :: a -> Value
  -- |How to represent a list of values
  toValueList :: [a] -> Value
  toValueList = [Value] -> Value
L ([Value] -> Value) -> ([a] -> [Value]) -> [a] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Value) -> [a] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Value
forall a. IsValue a => a -> Value
toValue

instance IsValue () where
  toValue :: () -> Value
toValue = () -> Value
N

instance IsValue Bool where
  toValue :: Bool -> Value
toValue = Bool -> Value
B

instance IsValue Int where
  toValue :: Int -> Value
toValue = Int -> Value
I

instance IsValue Integer where
  toValue :: Integer -> Value
toValue = Int -> Value
I (Int -> Value) -> (Integer -> Int) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

instance IsValue Double where
  toValue :: Double -> Value
toValue = Double -> Value
F

instance IsValue Float where
  toValue :: Float -> Value
toValue = Double -> Value
F (Double -> Value) -> (Float -> Double) -> Float -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac

instance IsValue Text where
  toValue :: Text -> Value
toValue = Text -> Value
T

instance IsValue Char where
  toValue :: Char -> Value
toValue = String -> Value
forall a. IsValue a => [a] -> Value
toValueList (String -> Value) -> (Char -> String) -> Char -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  toValueList :: String -> Value
toValueList = Text -> Value
T (Text -> Value) -> (String -> Text) -> String -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

instance IsValue a => IsValue [a] where
  toValue :: [a] -> Value
toValue = [a] -> Value
forall a. IsValue a => [a] -> Value
toValueList

instance IsValue (Map Text Value) where
  toValue :: Map Text Value -> Value
toValue = Map Text Value -> Value
M

-- |Wrap key-value pair with 'Value' datatype
(=:) :: IsValue a => Text -> a -> (Text, Value)
=: :: Text -> a -> (Text, Value)
(=:) Text
key a
val = (Text
key, a -> Value
forall a. IsValue a => a -> Value
toValue a
val)

-- |Construct properties map from list
props :: [(Text, Value)] -> Map Text Value
props :: [(Text, Value)] -> Map Text Value
props = [(Text, Value)] -> Map Text Value
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
(Int -> Node -> ShowS)
-> (Node -> String) -> ([Node] -> ShowS) -> Show Node
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
(Node -> Node -> Bool) -> (Node -> Node -> Bool) -> Eq Node
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
(Int -> Relationship -> ShowS)
-> (Relationship -> String)
-> ([Relationship] -> ShowS)
-> Show Relationship
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
(Relationship -> Relationship -> Bool)
-> (Relationship -> Relationship -> Bool) -> Eq Relationship
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
(Int -> URelationship -> ShowS)
-> (URelationship -> String)
-> ([URelationship] -> ShowS)
-> Show URelationship
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
(URelationship -> URelationship -> Bool)
-> (URelationship -> URelationship -> Bool) -> Eq URelationship
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
(Int -> Path -> ShowS)
-> (Path -> String) -> ([Path] -> ShowS) -> Show Path
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
(Path -> Path -> Bool) -> (Path -> Path -> Bool) -> Eq Path
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)