{-# LANGUAGE OverloadedStrings #-}
module Data.AesonBson (
aesonify, aesonifyValue,
bsonify, bsonifyValue,
bsonifyError, bsonifyBound,
errorRange, bound,
) where
import Data.Bson as BSON
import Data.Aeson.Types as AESON
import Data.Int
import qualified Data.HashMap.Strict as HashMap (fromList, toList)
import qualified Data.Scientific as S
import qualified Data.Text.Encoding as T
import qualified Data.Vector as Vector (fromList, toList)
bsonifyError :: AESON.Object -> BSON.Document
bsonifyError = bsonify errorRange
bsonifyBound :: AESON.Object -> BSON.Document
bsonifyBound = bsonify bound
bsonify :: (S.Scientific -> BSON.Value) -> AESON.Object -> BSON.Document
bsonify f o = map (\(t, v) -> t := bsonifyValue f v) $ HashMap.toList o
aesonify :: BSON.Document -> AESON.Object
aesonify = HashMap.fromList . map (\(l := v) -> (l, aesonifyValue v))
bsonifyValue :: (S.Scientific -> BSON.Value) -> AESON.Value -> BSON.Value
bsonifyValue f (Object obj) = Doc $ bsonify f obj
bsonifyValue f (AESON.Array array) = BSON.Array . map (bsonifyValue f) . Vector.toList $ array
bsonifyValue _ (AESON.String str) = BSON.String str
bsonifyValue _ (AESON.Bool b) = BSON.Bool b
bsonifyValue _ (AESON.Null) = BSON.Null
bsonifyValue f (AESON.Number n) = f n
aesonifyValue :: BSON.Value -> AESON.Value
aesonifyValue (Float f) = toJSON f
aesonifyValue (BSON.String s) = toJSON s
aesonifyValue (Doc doc) = Object $ aesonify doc
aesonifyValue (BSON.Array list) = AESON.Array . Vector.fromList $ map aesonifyValue list
aesonifyValue (Bin (Binary binary)) = toJSON $ T.decodeUtf8 binary
aesonifyValue (Fun (Function function)) = toJSON $ T.decodeUtf8 function
aesonifyValue (Uuid (UUID uuid)) = toJSON $ T.decodeUtf8 uuid
aesonifyValue (Md5 (MD5 md5)) = toJSON $ T.decodeUtf8 md5
aesonifyValue (UserDef (UserDefined userdef)) = toJSON $ T.decodeUtf8 userdef
aesonifyValue (ObjId oid) = toJSON $ show oid
aesonifyValue (BSON.Bool bool) = toJSON bool
aesonifyValue (UTC utc) = toJSON utc
aesonifyValue (BSON.Null) = AESON.Null
aesonifyValue (RegEx (Regex pattern mods)) = toJSON $ mconcat ["/", pattern, "/", mods]
aesonifyValue (JavaScr (Javascript env code)) = object [ "environment" .= aesonify env, "code" .= code ]
aesonifyValue (Sym (Symbol sym)) = toJSON sym
aesonifyValue (Int32 int32) = toJSON int32
aesonifyValue (Int64 int64) = toJSON int64
aesonifyValue (Stamp (MongoStamp int64)) = toJSON int64
aesonifyValue (MinMax mm) = case mm of { MinKey -> toJSON (-1 :: Int)
; MaxKey -> toJSON (1 :: Int)}
int64MaxBound, int32MaxBound, int64MinBound, int32MinBound :: S.Scientific
int64MaxBound = toScientific (maxBound :: Int64)
int32MaxBound = toScientific (maxBound :: Int32)
int64MinBound = toScientific (minBound :: Int64)
int32MinBound = toScientific (minBound :: Int32)
toScientific :: Integral i => i -> S.Scientific
toScientific i = S.scientific (fromIntegral i :: Integer ) 0
expo :: S.Scientific -> Int
expo n = S.base10Exponent n
coef :: S.Scientific -> Integer
coef n = S.coefficient n
errorRange :: S.Scientific -> BSON.Value
errorRange n | n < int64MinBound = error $ "Number out of min range: " ++ (show n)
errorRange n | n > int64MaxBound = error $ "Number out of max range: " ++ (show n)
errorRange n = bsonifyNumberInRange n
bound :: S.Scientific -> BSON.Value
bound n | n < int64MinBound = Int64 minBound
bound n | n > int64MaxBound = Int64 maxBound
bound n = bsonifyNumberInRange n
bsonifyNumberInRange :: S.Scientific -> BSON.Value
bsonifyNumberInRange n | (expo n) < 0 = Float (S.toRealFloat n :: Double)
bsonifyNumberInRange n | int64MinBound <= n && n < int32MinBound = Int64 $ fromIntegral (coef n) * 10 ^ (expo n)
bsonifyNumberInRange n | int32MinBound <= n && n <= int32MaxBound = Int32 $ fromIntegral (coef n) * 10 ^ (expo n)
bsonifyNumberInRange n | int32MaxBound < n && n <= int64MaxBound = Int64 $ fromIntegral (coef n) * 10 ^ (expo n)
bsonifyNumberInRange _ = error "bsonifyiNumberInRange should be invoked only with n | int64MinBound < n < int64MaxBound"