Type.hs

-- | Bolt value types: the Haskell representation of Neo4j values returned by queries.
--
-- The Aeson interop helpers ('parsePs', 'psToAeson', 'propsToAeson',
-- 'propsFromAeson') are part of the stable public API; everything else
-- is the internal value-type machinery surfaced via 'Database.Bolty'.
module Database.Bolty.Value.Type
  ( Bolt(..)
    -- * Bolt value extractors
  , asNull, asBool, asInt, asFloat, asBytes, asText
  , asList, asDict, asNode, asRelationship, asPath
    -- * Graph types
  , Node(..)
  , Relationship(..)
  , UnboundRelationship(..)
  , Path(..)
    -- * Temporal types
  , Date(..)
  , Time(..)
  , LocalTime(..)
  , DateTime(..)
  , DateTimeZoneId(..)
  , LocalDateTime(..)
  , Duration(..)
    -- * Spatial types
  , Point2D(..)
  , Point3D(..)
    -- * Aeson interop
    --
    -- $aesonInterop
  , parsePs
  , psToAeson
  , propsToAeson
  , propsFromAeson
  ) where

import           Control.Applicative    ((<|>), empty)
import           Data.Int              (Int64)
import           Data.Kind             (Type)
import           GHC.Generics          (Generic)
import qualified Data.ByteString       as BS
import qualified Data.HashMap.Lazy     as H
import qualified Data.Text             as T
import qualified Data.Vector           as V

import           Data.PackStream.Ps hiding ((.=), (.:))
import           Data.PackStream.Result  (Result(..))
import           Data.PackStream.Integer (PSInteger, fromIntegerTry)
import           Database.Bolty.Value.Helpers (sigNode, sigRel, sigURel, sigPath
                                              , sigDate, sigTime, sigLocalTime, sigDateTime
                                              , sigDateTimeZoneId, sigLocalDateTime, sigDuration
                                              , sigPoint2D, sigPoint3D)
import           Numeric                (showHex)

import qualified Data.Aeson              as Aeson
import qualified Data.Aeson.Key          as Key
import qualified Data.Aeson.KeyMap       as KM
import           Data.Aeson              (ToJSON(..), FromJSON(..), (.=), (.:))
import           Data.Aeson.Types        (Parser)
import qualified Data.ByteString.Base64  as B64
import qualified Data.Text.Encoding      as TE
import           Data.Scientific         (Scientific, fromFloatDigits, floatingOrInteger, toRealFloat)


-- | A typed Neo4j value. Every field in a query result record is a 'Bolt'.
type Bolt :: Type
data Bolt
  = BoltNull
  | BoltBoolean !Bool
  | BoltInteger !PSInteger
  | BoltFloat !Double
  | BoltBytes !BS.ByteString
  | BoltString !T.Text
  | BoltList !(V.Vector Bolt)
  | BoltDictionary !(H.HashMap T.Text Bolt)
  | BoltNode Node
  | BoltRelationship Relationship
  | BoltUnboundRelationship UnboundRelationship
  | BoltPath Path
  | BoltDate Date
  | BoltTime Time
  | BoltLocalTime LocalTime
  | BoltDateTime DateTime
  | BoltDateTimeZoneId DateTimeZoneId
  | BoltLocalDateTime LocalDateTime
  | BoltDuration Duration
  | BoltPoint2D Point2D
  | BoltPoint3D Point3D
  deriving stock (Show, Eq, Generic)

instance PackStream Bolt where
  toPs BoltNull                    = PsNull
  toPs (BoltBoolean b)             = PsBoolean b
  toPs (BoltInteger n)             = PsInteger n
  toPs (BoltFloat d)               = PsFloat d
  toPs (BoltBytes b)               = PsBytes b
  toPs (BoltString t)              = PsString t
  toPs (BoltList v)                = PsList (V.map toPs v)
  toPs (BoltDictionary m)          = PsDictionary (H.map toPs m)
  toPs (BoltNode n)                = toPs n
  toPs (BoltRelationship r)        = toPs r
  toPs (BoltUnboundRelationship r) = toPs r
  toPs (BoltPath p)                = toPs p
  toPs (BoltDate d)                = toPs d
  toPs (BoltTime t)                = toPs t
  toPs (BoltLocalTime t)           = toPs t
  toPs (BoltDateTime dt)           = toPs dt
  toPs (BoltDateTimeZoneId dt)     = toPs dt
  toPs (BoltLocalDateTime dt)      = toPs dt
  toPs (BoltDuration d)            = toPs d
  toPs (BoltPoint2D p)             = toPs p
  toPs (BoltPoint3D p)             = toPs p

  fromPs PsNull         = Success BoltNull
  fromPs (PsBoolean b)  = Success (BoltBoolean b)
  fromPs (PsInteger n)  = Success (BoltInteger n)
  fromPs (PsFloat d)    = Success (BoltFloat d)
  fromPs (PsBytes b)    = Success (BoltBytes b)
  fromPs (PsString t)   = Success (BoltString t)
  fromPs (PsList v)     = BoltList <$> traverse fromPs v
  fromPs (PsDictionary m) = BoltDictionary <$> traverse fromPs m
  fromPs ps@(PsStructure t _) = case t of
    _ | t == sigNode    -> BoltNode <$> fromPs ps
      | t == sigRel     -> BoltRelationship <$> fromPs ps
      | t == sigURel    -> BoltUnboundRelationship <$> fromPs ps
      | t == sigPath    -> BoltPath <$> fromPs ps
      | t == sigDate    -> BoltDate <$> fromPs ps
      | t == sigTime    -> BoltTime <$> fromPs ps
      | t == sigLocalTime    -> BoltLocalTime <$> fromPs ps
      | t == sigDateTime     -> BoltDateTime <$> fromPs ps
      | t == sigDateTimeZoneId -> BoltDateTimeZoneId <$> fromPs ps
      | t == sigLocalDateTime  -> BoltLocalDateTime <$> fromPs ps
      | t == sigDuration -> BoltDuration <$> fromPs ps
      | t == sigPoint2D  -> BoltPoint2D <$> fromPs ps
      | t == sigPoint3D  -> BoltPoint3D <$> fromPs ps
      | otherwise -> Error $ "unknown structure tag: 0x" <> T.pack (showHex t "")


-- | A graph node.
type Node :: Type
data Node = Node
  { id         :: !Int64
  -- ^ Legacy numeric ID (use 'element_id' for BOLT 5+).
  , labels     :: !(V.Vector T.Text)
  -- ^ Node labels.
  , properties :: !(H.HashMap T.Text Ps)
  -- ^ Node properties.
  , element_id :: !T.Text
  -- ^ Element ID string (empty on BOLT 4.x).
  }
  deriving stock (Show, Eq, Generic)
instance PackStream Node where
  toPs Node{id, labels, properties, element_id} =
    PsStructure sigNode $ V.fromList [toPs id, toPs labels, toPs properties, toPs element_id]
  -- BOLT 5+: 4 fields (id, labels, properties, element_id)
  fromPs (PsStructure t fs) | t == sigNode, V.length fs == 4 =
    Node <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2) <*> fromPs (fs V.! 3)
  -- BOLT 4.x: 3 fields (id, labels, properties) — no element_id
  fromPs (PsStructure t fs) | t == sigNode, V.length fs == 3 =
    Node <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2) <*> pure ""
  fromPs other = typeMismatch "Node" other

-- | A graph relationship (edge).
type Relationship :: Type
data Relationship = Relationship
  { id                     :: !Int64
  -- ^ Legacy numeric ID.
  , startNodeId            :: !Int64
  -- ^ Legacy numeric ID of the start node.
  , endNodeId              :: !Int64
  -- ^ Legacy numeric ID of the end node.
  , type_                  :: !T.Text
  -- ^ Relationship type name.
  , properties             :: !(H.HashMap T.Text Ps)
  -- ^ Relationship properties.
  , element_id             :: !T.Text
  -- ^ Element ID string (empty on BOLT 4.x).
  , start_node_element_id  :: !T.Text
  -- ^ Start node element ID (empty on BOLT 4.x).
  , end_node_element_id    :: !T.Text
  -- ^ End node element ID (empty on BOLT 4.x).
  }
  deriving stock (Show, Eq, Generic)
instance PackStream Relationship where
  toPs Relationship{id, startNodeId, endNodeId, type_, properties, element_id, start_node_element_id, end_node_element_id} =
    PsStructure sigRel $ V.fromList
      [toPs id, toPs startNodeId, toPs endNodeId, toPs type_, toPs properties
      , toPs element_id, toPs start_node_element_id, toPs end_node_element_id]
  -- BOLT 5+: 8 fields (id, startNodeId, endNodeId, type_, properties, element_id, start_node_element_id, end_node_element_id)
  fromPs (PsStructure t fs) | t == sigRel, V.length fs == 8 =
    Relationship <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2)
                 <*> fromPs (fs V.! 3) <*> fromPs (fs V.! 4) <*> fromPs (fs V.! 5)
                 <*> fromPs (fs V.! 6) <*> fromPs (fs V.! 7)
  -- BOLT 4.x: 5 fields (id, startNodeId, endNodeId, type_, properties) — no element_id fields
  fromPs (PsStructure t fs) | t == sigRel, V.length fs == 5 =
    Relationship <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2)
                 <*> fromPs (fs V.! 3) <*> fromPs (fs V.! 4) <*> pure "" <*> pure "" <*> pure ""
  fromPs other = typeMismatch "Relationship" other


-- | A relationship without start\/end node information (used in paths).
type UnboundRelationship :: Type
data UnboundRelationship = UnboundRelationship
  { id         :: !Int64
  , type_      :: !T.Text
  -- ^ Relationship type name.
  , properties :: !(H.HashMap T.Text Ps)
  , element_id :: !T.Text
  -- ^ Element ID string (empty on BOLT 4.x).
  }
  deriving stock (Show, Eq, Generic)
instance PackStream UnboundRelationship where
  toPs UnboundRelationship{id, type_, properties, element_id} =
    PsStructure sigURel $ V.fromList [toPs id, toPs type_, toPs properties, toPs element_id]
  -- BOLT 5+: 4 fields (id, type_, properties, element_id)
  fromPs (PsStructure t fs) | t == sigURel, V.length fs == 4 =
    UnboundRelationship <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2) <*> fromPs (fs V.! 3)
  -- BOLT 4.x: 3 fields (id, type_, properties) — no element_id
  fromPs (PsStructure t fs) | t == sigURel, V.length fs == 3 =
    UnboundRelationship <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2) <*> pure ""
  fromPs other = typeMismatch "UnboundRelationship" other


-- | A graph path: an alternating sequence of nodes and relationships.
type Path :: Type
data Path = Path
  { nodes   :: !(V.Vector Node)
  -- ^ Unique nodes in the path.
  , rels    :: !(V.Vector UnboundRelationship)
  -- ^ Unique relationships in the path.
  , indices :: !(V.Vector Int64)
  -- ^ Indices into 'nodes' and 'rels' describing the traversal order.
  }
  deriving stock (Show, Eq, Generic)
instance PackStream Path where
  toPs Path{nodes, rels, indices} =
    PsStructure sigPath $ V.fromList [toPs nodes, toPs rels, toPs indices]
  fromPs (PsStructure t fs) | t == sigPath, V.length fs == 3 =
    Path <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2)
  fromPs other = typeMismatch "Path" other


-- | A date (days since Unix epoch).
type Date :: Type
data Date = Date
  { days :: !Int64
  }
  deriving stock (Show, Eq, Generic)
instance PackStream Date where
  toPs Date{days} =
    PsStructure sigDate $ V.singleton (toPs days)
  fromPs (PsStructure t fs) | t == sigDate, V.length fs == 1 =
    Date <$> fromPs (fs V.! 0)
  fromPs other = typeMismatch "Date" other


-- | A time with timezone offset.
type Time :: Type
data Time = Time
  { nanoseconds       :: !Int64
  -- ^ Nanoseconds since midnight.
  , tz_offset_seconds :: !Int64
  -- ^ Timezone offset in seconds from UTC.
  }
  deriving stock (Show, Eq, Generic)
instance PackStream Time where
  toPs Time{nanoseconds, tz_offset_seconds} =
    PsStructure sigTime $ V.fromList [toPs nanoseconds, toPs tz_offset_seconds]
  fromPs (PsStructure t fs) | t == sigTime, V.length fs == 2 =
    Time <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1)
  fromPs other = typeMismatch "Time" other


-- | A local time (no timezone).
type LocalTime :: Type
data LocalTime = LocalTime
  { nanoseconds :: !Int64
  -- ^ Nanoseconds since midnight.
  }
  deriving stock (Show, Eq, Generic)
instance PackStream LocalTime where
  toPs LocalTime{nanoseconds} =
    PsStructure sigLocalTime $ V.singleton (toPs nanoseconds)
  fromPs (PsStructure t fs) | t == sigLocalTime, V.length fs == 1 =
    LocalTime <$> fromPs (fs V.! 0)
  fromPs other = typeMismatch "LocalTime" other


-- | A date-time with timezone offset.
type DateTime :: Type
data DateTime = DateTime
  { seconds           :: !Int64
  -- ^ Seconds since Unix epoch.
  , nanoseconds       :: !Int64
  -- ^ Nanosecond adjustment.
  , tz_offset_seconds :: !Int64
  -- ^ Timezone offset in seconds from UTC.
  }
  deriving stock (Show, Eq, Generic)
instance PackStream DateTime where
  toPs DateTime{seconds, nanoseconds, tz_offset_seconds} =
    PsStructure sigDateTime $ V.fromList [toPs seconds, toPs nanoseconds, toPs tz_offset_seconds]
  fromPs (PsStructure t fs) | t == sigDateTime, V.length fs == 3 =
    DateTime <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2)
  fromPs other = typeMismatch "DateTime" other


-- | A date-time with named timezone (e.g. @\"Europe\/Paris\"@).
type DateTimeZoneId :: Type
data DateTimeZoneId = DateTimeZoneId
  { seconds     :: !Int64
  -- ^ Seconds since Unix epoch.
  , nanoseconds :: !Int64
  -- ^ Nanosecond adjustment.
  , tz_id       :: !T.Text
  -- ^ IANA timezone identifier.
  }
  deriving stock (Show, Eq, Generic)
instance PackStream DateTimeZoneId where
  toPs DateTimeZoneId{seconds, nanoseconds, tz_id} =
    PsStructure sigDateTimeZoneId $ V.fromList [toPs seconds, toPs nanoseconds, toPs tz_id]
  fromPs (PsStructure t fs) | t == sigDateTimeZoneId, V.length fs == 3 =
    DateTimeZoneId <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2)
  fromPs other = typeMismatch "DateTimeZoneId" other


-- | A local date-time (no timezone).
type LocalDateTime :: Type
data LocalDateTime = LocalDateTime
  { seconds     :: !Int64
  -- ^ Seconds since Unix epoch.
  , nanoseconds :: !Int64
  -- ^ Nanosecond adjustment.
  }
  deriving stock (Show, Eq, Generic)
instance PackStream LocalDateTime where
  toPs LocalDateTime{seconds, nanoseconds} =
    PsStructure sigLocalDateTime $ V.fromList [toPs seconds, toPs nanoseconds]
  fromPs (PsStructure t fs) | t == sigLocalDateTime, V.length fs == 2 =
    LocalDateTime <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1)
  fromPs other = typeMismatch "LocalDateTime" other


-- | A temporal duration (months, days, seconds, nanoseconds).
type Duration :: Type
data Duration = Duration
  { months      :: !Int64
  , days        :: !Int64
  , seconds     :: !Int64
  , nanoseconds :: !Int64
  }
  deriving stock (Show, Eq, Generic)
instance PackStream Duration where
  toPs Duration{months, days, seconds, nanoseconds} =
    PsStructure sigDuration $ V.fromList [toPs months, toPs days, toPs seconds, toPs nanoseconds]
  fromPs (PsStructure t fs) | t == sigDuration, V.length fs == 4 =
    Duration <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2) <*> fromPs (fs V.! 3)
  fromPs other = typeMismatch "Duration" other


-- | A 2D spatial point.
type Point2D :: Type
data Point2D = Point2D
  { srid :: !Int64
  -- ^ Spatial Reference Identifier (e.g. 4326 for WGS-84).
  , x    :: !Double
  , y    :: !Double
  }
  deriving stock (Show, Eq, Generic)
instance PackStream Point2D where
  toPs Point2D{srid, x, y} =
    PsStructure sigPoint2D $ V.fromList [toPs srid, toPs x, toPs y]
  fromPs (PsStructure t fs) | t == sigPoint2D, V.length fs == 3 =
    Point2D <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2)
  fromPs other = typeMismatch "Point2D" other


-- | A 3D spatial point.
type Point3D :: Type
data Point3D = Point3D
  { srid :: !Int64
  -- ^ Spatial Reference Identifier (e.g. 4979 for WGS-84-3D).
  , x    :: !Double
  , y    :: !Double
  , z    :: !Double
  }
  deriving stock (Show, Eq, Generic)
instance PackStream Point3D where
  toPs Point3D{srid, x, y, z} =
    PsStructure sigPoint3D $ V.fromList [toPs srid, toPs x, toPs y, toPs z]
  fromPs (PsStructure t fs) | t == sigPoint3D, V.length fs == 4 =
    Point3D <$> fromPs (fs V.! 0) <*> fromPs (fs V.! 1) <*> fromPs (fs V.! 2) <*> fromPs (fs V.! 3)
  fromPs other = typeMismatch "Point3D" other


-- = Aeson (ToJSON / FromJSON) instances
--
-- $aesonInterop
--
-- Helpers for moving values between PackStream's 'Ps' and Aeson's 'Aeson.Value'.
-- Useful when binding query parameters from JSON input (e.g. a CLI) or when
-- rendering query results as JSON.
--
-- 'parsePs' handles the @{"bytes": "<base64>"}@ shape so binary values can
-- round-trip through JSON. Both functions use 'scientificToPs', which falls
-- back to 'PsFloat' when an integer literal exceeds the @[-2^63, 2^64-1]@
-- range supported by 'PSInteger' rather than silently truncating.

-- | Convert a PackStream property value to JSON.
psToAeson :: Ps -> Aeson.Value
psToAeson PsNull           = Aeson.Null
psToAeson (PsBoolean b)    = Aeson.Bool b
psToAeson (PsInteger n)    = Aeson.Number (fromIntegral n)
psToAeson (PsFloat d)
  | isNaN d || isInfinite d = Aeson.Null
  | otherwise               = Aeson.Number (fromFloatDigits d)
psToAeson (PsString t)     = Aeson.String t
psToAeson (PsBytes bs)     = Aeson.object ["bytes" .= TE.decodeLatin1 (B64.encode bs)]
psToAeson (PsList v)       = Aeson.Array (V.map psToAeson v)
psToAeson (PsDictionary m) = Aeson.Object $ KM.fromList
  [(Key.fromText k, psToAeson v) | (k, v) <- H.toList m]
psToAeson (PsStructure _ _) = Aeson.Null  -- structures never appear in Neo4j properties

-- | Parse a JSON value as a PackStream property value.
parsePs :: Aeson.Value -> Parser Ps
parsePs Aeson.Null       = pure PsNull
parsePs (Aeson.Bool b)   = pure (PsBoolean b)
parsePs (Aeson.Number n) = pure (scientificToPs n)
parsePs (Aeson.String t) = pure (PsString t)
parsePs (Aeson.Array v)  = PsList <$> traverse parsePs v
parsePs (Aeson.Object obj) = case KM.toList obj of
  [(k, Aeson.String b64)] | Key.toText k == "bytes" ->
    case B64.decode (TE.encodeUtf8 b64) of
      Right bs -> pure (PsBytes bs)
      Left _   -> parsePsDictionary  -- not valid base64, treat as regular dictionary
  _ -> parsePsDictionary
  where
    parsePsDictionary = PsDictionary . H.fromList <$>
      traverse (\(k, v) -> (,) (Key.toText k) <$> parsePs v) (KM.toList obj)

-- | Convert a Scientific to a PackStream value.
scientificToPs :: Scientific -> Ps
scientificToPs n = case floatingOrInteger n :: Either Double Integer of
  Right i -> case fromIntegerTry i of
    Right psi -> PsInteger psi
    Left _    -> PsFloat (toRealFloat n)
  Left d    -> PsFloat d

-- | Convert a Scientific to a Bolt value.
scientificToBolt :: Scientific -> Bolt
scientificToBolt n = case floatingOrInteger n :: Either Double Integer of
  Right i -> case fromIntegerTry i of
    Right psi -> BoltInteger psi
    Left _    -> BoltFloat (toRealFloat n)
  Left d    -> BoltFloat d

-- | Encode a property map to JSON.
propsToAeson :: H.HashMap T.Text Ps -> Aeson.Value
propsToAeson m = Aeson.Object $ KM.fromList
  [(Key.fromText k, psToAeson v) | (k, v) <- H.toList m]

-- | Parse a JSON object as a property map.
propsFromAeson :: Aeson.Value -> Parser (H.HashMap T.Text Ps)
propsFromAeson = Aeson.withObject "properties" $ \obj ->
  H.fromList <$> traverse (\(k, v) -> (,) (Key.toText k) <$> parsePs v) (KM.toList obj)


instance ToJSON Node where
  toJSON Node{..} = Aeson.object
    [ "id"         .= id
    , "labels"     .= labels
    , "properties" .= propsToAeson properties
    , "element_id" .= element_id
    ]

instance FromJSON Node where
  parseJSON = Aeson.withObject "Node" $ \o ->
    Node <$> o .: "id"
         <*> o .: "labels"
         <*> (propsFromAeson =<< o .: "properties")
         <*> o .: "element_id"


instance ToJSON Relationship where
  toJSON Relationship{..} = Aeson.object
    [ "id"                    .= id
    , "startNodeId"           .= startNodeId
    , "endNodeId"             .= endNodeId
    , "type"                  .= type_
    , "properties"            .= propsToAeson properties
    , "element_id"            .= element_id
    , "start_node_element_id" .= start_node_element_id
    , "end_node_element_id"   .= end_node_element_id
    ]

instance FromJSON Relationship where
  parseJSON = Aeson.withObject "Relationship" $ \o ->
    Relationship <$> o .: "id"
                 <*> o .: "startNodeId"
                 <*> o .: "endNodeId"
                 <*> o .: "type"
                 <*> (propsFromAeson =<< o .: "properties")
                 <*> o .: "element_id"
                 <*> o .: "start_node_element_id"
                 <*> o .: "end_node_element_id"


instance ToJSON UnboundRelationship where
  toJSON UnboundRelationship{..} = Aeson.object
    [ "id"         .= id
    , "type"       .= type_
    , "properties" .= propsToAeson properties
    , "element_id" .= element_id
    ]

instance FromJSON UnboundRelationship where
  parseJSON = Aeson.withObject "UnboundRelationship" $ \o ->
    UnboundRelationship <$> o .: "id"
                        <*> o .: "type"
                        <*> (propsFromAeson =<< o .: "properties")
                        <*> o .: "element_id"


instance ToJSON Path where
  toJSON Path{..} = Aeson.object
    [ "nodes"         .= nodes
    , "relationships" .= rels
    , "indices"       .= indices
    ]

instance FromJSON Path where
  parseJSON = Aeson.withObject "Path" $ \o ->
    Path <$> o .: "nodes"
         <*> o .: "relationships"
         <*> o .: "indices"


instance ToJSON Date where
  toJSON Date{..} = Aeson.object ["days" .= days]

instance FromJSON Date where
  parseJSON = Aeson.withObject "Date" $ \o ->
    Date <$> o .: "days"


instance ToJSON Time where
  toJSON Time{..} = Aeson.object
    [ "nanoseconds"       .= nanoseconds
    , "tz_offset_seconds" .= tz_offset_seconds
    ]

instance FromJSON Time where
  parseJSON = Aeson.withObject "Time" $ \o ->
    Time <$> o .: "nanoseconds"
         <*> o .: "tz_offset_seconds"


instance ToJSON LocalTime where
  toJSON LocalTime{..} = Aeson.object ["nanoseconds" .= nanoseconds]

instance FromJSON LocalTime where
  parseJSON = Aeson.withObject "LocalTime" $ \o ->
    LocalTime <$> o .: "nanoseconds"


instance ToJSON DateTime where
  toJSON DateTime{..} = Aeson.object
    [ "seconds"           .= seconds
    , "nanoseconds"       .= nanoseconds
    , "tz_offset_seconds" .= tz_offset_seconds
    ]

instance FromJSON DateTime where
  parseJSON = Aeson.withObject "DateTime" $ \o ->
    DateTime <$> o .: "seconds"
             <*> o .: "nanoseconds"
             <*> o .: "tz_offset_seconds"


instance ToJSON DateTimeZoneId where
  toJSON DateTimeZoneId{..} = Aeson.object
    [ "seconds"     .= seconds
    , "nanoseconds" .= nanoseconds
    , "tz_id"       .= tz_id
    ]

instance FromJSON DateTimeZoneId where
  parseJSON = Aeson.withObject "DateTimeZoneId" $ \o ->
    DateTimeZoneId <$> o .: "seconds"
                   <*> o .: "nanoseconds"
                   <*> o .: "tz_id"


instance ToJSON LocalDateTime where
  toJSON LocalDateTime{..} = Aeson.object
    [ "seconds"     .= seconds
    , "nanoseconds" .= nanoseconds
    ]

instance FromJSON LocalDateTime where
  parseJSON = Aeson.withObject "LocalDateTime" $ \o ->
    LocalDateTime <$> o .: "seconds"
                  <*> o .: "nanoseconds"


instance ToJSON Duration where
  toJSON Duration{..} = Aeson.object
    [ "months"      .= months
    , "days"        .= days
    , "seconds"     .= seconds
    , "nanoseconds" .= nanoseconds
    ]

instance FromJSON Duration where
  parseJSON = Aeson.withObject "Duration" $ \o ->
    Duration <$> o .: "months"
             <*> o .: "days"
             <*> o .: "seconds"
             <*> o .: "nanoseconds"


instance ToJSON Point2D where
  toJSON Point2D{..} = Aeson.object
    [ "srid" .= srid
    , "x"    .= x
    , "y"    .= y
    ]

instance FromJSON Point2D where
  parseJSON = Aeson.withObject "Point2D" $ \o ->
    Point2D <$> o .: "srid"
            <*> o .: "x"
            <*> o .: "y"


instance ToJSON Point3D where
  toJSON Point3D{..} = Aeson.object
    [ "srid" .= srid
    , "x"    .= x
    , "y"    .= y
    , "z"    .= z
    ]

instance FromJSON Point3D where
  parseJSON = Aeson.withObject "Point3D" $ \o ->
    Point3D <$> o .: "srid"
            <*> o .: "x"
            <*> o .: "y"
            <*> o .: "z"


instance ToJSON Bolt where
  toJSON BoltNull             = Aeson.Null
  toJSON (BoltBoolean b)      = Aeson.Bool b
  toJSON (BoltInteger n)      = Aeson.Number (fromIntegral n)
  toJSON (BoltFloat d)
    | isNaN d || isInfinite d = Aeson.Null
    | otherwise               = Aeson.Number (fromFloatDigits d)
  toJSON (BoltBytes bs)       = Aeson.object ["bytes" .= TE.decodeLatin1 (B64.encode bs)]
  toJSON (BoltString t)       = Aeson.String t
  toJSON (BoltList v)         = toJSON v
  toJSON (BoltDictionary m)   = toJSON m
  toJSON (BoltNode n)                = Aeson.object ["node" .= n]
  toJSON (BoltRelationship r)        = Aeson.object ["relationship" .= r]
  toJSON (BoltUnboundRelationship r) = Aeson.object ["unboundRelationship" .= r]
  toJSON (BoltPath p)                = Aeson.object ["path" .= p]
  toJSON (BoltDate d)                = Aeson.object ["date" .= d]
  toJSON (BoltTime t)                = Aeson.object ["time" .= t]
  toJSON (BoltLocalTime t)           = Aeson.object ["localTime" .= t]
  toJSON (BoltDateTime dt)           = Aeson.object ["dateTime" .= dt]
  toJSON (BoltDateTimeZoneId dt)     = Aeson.object ["dateTimeZoneId" .= dt]
  toJSON (BoltLocalDateTime dt)      = Aeson.object ["localDateTime" .= dt]
  toJSON (BoltDuration d)            = Aeson.object ["duration" .= d]
  toJSON (BoltPoint2D p)             = Aeson.object ["point2d" .= p]
  toJSON (BoltPoint3D p)             = Aeson.object ["point3d" .= p]

-- | Note: JSON cannot distinguish @BoltFloat 1.0@ from @BoltInteger 1@.
-- Whole-number floats will round-trip as 'BoltInteger'. For lossless
-- serialization use the PackStream wire format instead.
instance FromJSON Bolt where
  parseJSON Aeson.Null     = pure BoltNull
  parseJSON (Aeson.Bool b) = pure (BoltBoolean b)
  parseJSON (Aeson.Number n) = pure (scientificToBolt n)
  parseJSON (Aeson.String t) = pure (BoltString t)
  parseJSON (Aeson.Array v)  = BoltList <$> traverse parseJSON v
  parseJSON (Aeson.Object obj) = case KM.toList obj of
    -- Single-key objects are tried as typed Bolt values first.
    -- On parse failure the object is treated as a plain BoltDictionary
    -- so that e.g. {"node": 42} does not reject — it round-trips as a
    -- dictionary rather than erroring out.
    [(key, val)] -> tryTyped (Key.toText key) val <|> parseBoltDictionary obj
    _            -> parseBoltDictionary obj
    where
      tryTyped "bytes"                v = parseBoltBytes v
      tryTyped "node"                 v = BoltNode <$> parseJSON v
      tryTyped "relationship"         v = BoltRelationship <$> parseJSON v
      tryTyped "unboundRelationship"  v = BoltUnboundRelationship <$> parseJSON v
      tryTyped "path"                 v = BoltPath <$> parseJSON v
      tryTyped "date"                 v = BoltDate <$> parseJSON v
      tryTyped "time"                 v = BoltTime <$> parseJSON v
      tryTyped "localTime"            v = BoltLocalTime <$> parseJSON v
      tryTyped "dateTime"             v = BoltDateTime <$> parseJSON v
      tryTyped "dateTimeZoneId"       v = BoltDateTimeZoneId <$> parseJSON v
      tryTyped "localDateTime"        v = BoltLocalDateTime <$> parseJSON v
      tryTyped "duration"             v = BoltDuration <$> parseJSON v
      tryTyped "point2d"              v = BoltPoint2D <$> parseJSON v
      tryTyped "point3d"              v = BoltPoint3D <$> parseJSON v
      tryTyped _                      _ = empty  -- unknown key, fall through to <|>

-- | Parse a base64-encoded bytes value.
parseBoltBytes :: Aeson.Value -> Parser Bolt
parseBoltBytes (Aeson.String b64) = case B64.decode (TE.encodeUtf8 b64) of
  Right bs -> pure (BoltBytes bs)
  Left _   -> fail "invalid base64 in bytes"
parseBoltBytes _ = fail "expected base64 string for bytes"

-- | Parse a JSON object as a BoltDictionary.
parseBoltDictionary :: KM.KeyMap Aeson.Value -> Parser Bolt
parseBoltDictionary obj = BoltDictionary . H.fromList <$>
  traverse (\(k, v) -> (,) (Key.toText k) <$> parseJSON v) (KM.toList obj)


-- = Bolt value extractors

-- | Extract a null value.
asNull :: Bolt -> Maybe ()
asNull BoltNull = Just ()
asNull _        = Nothing

-- | Extract a boolean value.
asBool :: Bolt -> Maybe Bool
asBool (BoltBoolean b) = Just b
asBool _               = Nothing

-- | Extract an integer value.
asInt :: Bolt -> Maybe PSInteger
asInt (BoltInteger i) = Just i
asInt _               = Nothing

-- | Extract a floating-point value.
asFloat :: Bolt -> Maybe Double
asFloat (BoltFloat d) = Just d
asFloat _             = Nothing

-- | Extract a byte string value.
asBytes :: Bolt -> Maybe BS.ByteString
asBytes (BoltBytes b) = Just b
asBytes _             = Nothing

-- | Extract a text value.
asText :: Bolt -> Maybe T.Text
asText (BoltString t) = Just t
asText _              = Nothing

-- | Extract a list value.
asList :: Bolt -> Maybe (V.Vector Bolt)
asList (BoltList v) = Just v
asList _            = Nothing

-- | Extract a dictionary value.
asDict :: Bolt -> Maybe (H.HashMap T.Text Bolt)
asDict (BoltDictionary m) = Just m
asDict _                  = Nothing

-- | Extract a node value.
asNode :: Bolt -> Maybe Node
asNode (BoltNode n) = Just n
asNode _            = Nothing

-- | Extract a relationship value.
asRelationship :: Bolt -> Maybe Relationship
asRelationship (BoltRelationship r) = Just r
asRelationship _                    = Nothing

-- | Extract a path value.
asPath :: Bolt -> Maybe Path
asPath (BoltPath p) = Just p
asPath _            = Nothing