{-# 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.Text (Text)
import qualified Data.Text as T (unpack, pack)
import Data.Word (Word8)
data UnpackError = NotNull
| NotInt
| NotFloat
| NotString
| NotBool
| NotList
| NotDict
| NotStructure
| NotValue
| Not Text
deriving (Eq, Ord)
instance Show UnpackError where
show NotNull = "Not a Null value"
show NotInt = "Not an Int value"
show NotFloat = "Not a Float value"
show NotString = "Not a String value"
show NotBool = "Not a Bool value"
show NotList = "Not a List value"
show NotDict = "Not a Dict value"
show NotStructure = "Not a Structure value"
show NotValue = "Not a Value value"
show (Not what) = "Not a " <> T.unpack what <> " (Structure) value"
newtype UnpackT m a = UnpackT { runUnpackT :: ExceptT UnpackError (StateT ByteString m) a }
deriving (Functor, Applicative, Monad, MonadError UnpackError, MonadState ByteString)
data Structure = Structure { signature :: Word8
, fields :: [Value]
}
deriving (Show, Eq)
class FromStructure a where
fromStructure :: MonadError UnpackError m => Structure -> m a
class ToStructure a where
toStructure :: a -> Structure
class BoltValue a where
pack :: a -> ByteString
unpackT :: Monad m => UnpackT m a
unpack :: (Monad m, BoltValue a) => ByteString -> m (Either UnpackError a)
unpack = unpackAction unpackT
unpackF :: (MonadFail m, BoltValue a) => ByteString -> m a
unpackF bs = do result <- unpack bs
case result of
Right x -> pure x
Left e -> Fail.fail $ show e
unpackAction :: Monad m => UnpackT m a -> ByteString -> m (Either UnpackError a)
unpackAction action = evalStateT (runExceptT $ runUnpackT action)
data Value = N ()
| B Bool
| I Int
| F Double
| T Text
| L [Value]
| M (Map Text Value)
| S Structure
deriving (Show, Eq)
class IsValue a where
toValue :: a -> Value
toValueList :: [a] -> Value
toValueList = L . fmap toValue
instance IsValue () where
toValue = N
instance IsValue Bool where
toValue = B
instance IsValue Int where
toValue = I
instance IsValue Integer where
toValue = I . fromIntegral
instance IsValue Double where
toValue = F
instance IsValue Float where
toValue = F . realToFrac
instance IsValue Text where
toValue = T
instance IsValue Char where
toValue = toValueList . pure
toValueList = T . T.pack
instance IsValue a => IsValue [a] where
toValue = toValueList
instance IsValue (Map Text Value) where
toValue = M
(=:) :: IsValue a => Text -> a -> (Text, Value)
(=:) key val = (key, toValue val)
props :: [(Text, Value)] -> Map Text Value
props = fromList
data Node = Node { nodeIdentity :: Int
, labels :: [Text]
, nodeProps :: Map Text Value
}
deriving (Show, Eq)
data Relationship = Relationship { relIdentity :: Int
, startNodeId :: Int
, endNodeId :: Int
, relType :: Text
, relProps :: Map Text Value
}
deriving (Show, Eq)
data URelationship = URelationship { urelIdentity :: Int
, urelType :: Text
, urelProps :: Map Text Value
}
deriving (Show, Eq)
data Path = Path { pathNodes :: [Node]
, pathRelationships :: [URelationship]
, pathSequence :: [Int]
}
deriving (Show, Eq)