{-# LANGUAGE UndecidableInstances #-}
module Data.Repa.Convert.Format.Object
        ( Object        (..)
        , ObjectFormat
        , ObjectFields
        , Field         (..)
        , mkObject)
where
import Data.Repa.Convert.Internal.Format
import Data.Repa.Convert.Internal.Packable
import Data.Repa.Convert.Internal.Packer
import Data.Repa.Convert.Format.String
import Data.Repa.Convert.Format.Binary
import Data.Repa.Scalar.Product
import Data.Word
import Data.Char
import GHC.Exts
import Data.Text                        (Text)
import qualified Data.Text              as T


-- | Format of a simple object format with labeled fields.
data Object fields where
        Object
         :: ObjectFields fields
         -> Object fields


-- | Resents the fields of a JSON object.
data ObjectFields fields where

        ObjectFieldsNil
         :: ObjectFields ()

        ObjectFieldsCons
         :: {-# UNPACK #-} !ObjectMeta  -- Meta data about this format.
         -> !Text                       -- Name of head field
         -> !f                          -- Format of head field.
         -> Maybe (Value f -> Bool)     -- Predicate to determine whether to emit value.
         -> ObjectFields fs             -- Spec for rest of fields.
         -> ObjectFields (f :*: fs)


-- | Precomputed information about this format.
data ObjectMeta
        = ObjectMeta
        { -- | Length of this format, in fields.
          ObjectMeta -> Int
omFieldCount          :: !Int

          -- | Minimum length of this format, in bytes.
        , ObjectMeta -> Int
omMinSize             :: !Int

          -- | Fixed size of this format.
        , ObjectMeta -> Maybe Int
omFixedSize           :: !(Maybe Int) }


---------------------------------------------------------------------------------------------------
-- | Make an object format with the given labeled fields. For example:
--
-- @> let fmt =   mkObject
--          $   Field "index"   IntAsc                      Nothing
--          :*: Field "message" (VarCharString \'-\')         Nothing
--          :*: Field "value"   (MaybeChars "NULL" DoubleAsc) (Just isJust)
--          :*: ()
-- @
--
-- Packing this produces:
--
-- @
-- > let Just str = packToString fmt (27 :*: "foo" :*: Nothing :*: ())
-- > putStrLn str
-- > {"index":27,"message":"foo"}
-- @
--
-- Note that the encodings that this format can generate are a superset of
-- the JavaScript Object Notation (JSON). With the Repa format, the fields
-- of an object can directly encode dates and other values, wheras in JSON
-- these values must be represented by strings.
--
mkObject :: ObjectFormat f
         => f -> Object (ObjectFormat' f)

mkObject :: forall f. ObjectFormat f => f -> Object (ObjectFormat' f)
mkObject f
f = ObjectFields (ObjectFormat' f) -> Object (ObjectFormat' f)
forall fields. ObjectFields fields -> Object fields
Object (f -> ObjectFields (ObjectFormat' f)
forall f. ObjectFormat f => f -> ObjectFields (ObjectFormat' f)
mkObjectFields f
f)


class ObjectFormat f where
 type ObjectFormat' f
 mkObjectFields :: f -> ObjectFields (ObjectFormat' f)


instance ObjectFormat () where
 type ObjectFormat' () = ()
 mkObjectFields :: () -> ObjectFields (ObjectFormat' ())
mkObjectFields ()     = ObjectFields ()
ObjectFields (ObjectFormat' ())
ObjectFieldsNil
 {-# INLINE mkObjectFields #-}


-- | A single field in an object.
data Field f
        = Field
        { forall f. Field f -> String
fieldName     :: String
        , forall f. Field f -> f
fieldFormat   :: f
        , forall f. Field f -> Maybe (Value f -> Bool)
fieldInclude  :: Maybe (Value f -> Bool) }


instance ( Format f1
         , ObjectFormat fs)
      => ObjectFormat  (Field f1 :*: fs) where

 type    ObjectFormat' (Field f1 :*: fs)
        = f1 :*: ObjectFormat' fs

 mkObjectFields :: (Field f1 :*: fs) -> ObjectFields (ObjectFormat' (Field f1 :*: fs))
mkObjectFields (Field String
label f1
f1 Maybe (Value f1 -> Bool)
mKeep :*: fs
fs)
  = case fs -> ObjectFields (ObjectFormat' fs)
forall f. ObjectFormat f => f -> ObjectFields (ObjectFormat' f)
mkObjectFields fs
fs of
        ObjectFields (ObjectFormat' fs)
ObjectFieldsNil
         -> ObjectMeta
-> Text
-> f1
-> Maybe (Value f1 -> Bool)
-> ObjectFields ()
-> ObjectFields (f1 :*: ())
forall f fs.
ObjectMeta
-> Text
-> f
-> Maybe (Value f -> Bool)
-> ObjectFields fs
-> ObjectFields (f :*: fs)
ObjectFieldsCons
                (ObjectMeta
                        { omFieldCount :: Int
omFieldCount  = Int
1

                          -- Smallest JSON object looks like:
                          --   {"LABEL":VALUE}, so there are 5 extra characters.
                        , omMinSize :: Int
omMinSize     = Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
label Int -> Int -> Int
forall a. Num a => a -> a -> a
+ f1 -> Int
forall f. Format f => f -> Int
minSize f1
f1

                        , omFixedSize :: Maybe Int
omFixedSize   = (Int -> Int) -> Maybe Int -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
label)) (Maybe Int -> Maybe Int) -> Maybe Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ f1 -> Maybe Int
forall f. Format f => f -> Maybe Int
fixedSize f1
f1 })
                (String -> Text
T.pack String
label) f1
f1 Maybe (Value f1 -> Bool)
mKeep ObjectFields ()
ObjectFieldsNil

        cc :: ObjectFields (ObjectFormat' fs)
cc@(ObjectFieldsCons ObjectMeta
jm Text
_ f
_ Maybe (Value f -> Bool)
_ ObjectFields fs
_)
         -> ObjectMeta
-> Text
-> f1
-> Maybe (Value f1 -> Bool)
-> ObjectFields (f :*: fs)
-> ObjectFields (f1 :*: (f :*: fs))
forall f fs.
ObjectMeta
-> Text
-> f
-> Maybe (Value f -> Bool)
-> ObjectFields fs
-> ObjectFields (f :*: fs)
ObjectFieldsCons
                (ObjectMeta
                        { omFieldCount :: Int
omFieldCount  = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ObjectMeta -> Int
omFieldCount ObjectMeta
jm

                          -- Adding a new field makes the object look like:
                          --   {"LABEL1":VALUE1,"LABEL2":VALUE2}, so there are 4 extra
                          --   characters for addiitonal field,  1x',' + 2x'"' + 1x':'
                        , omMinSize :: Int
omMinSize     = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ f1 -> Int
forall f. Format f => f -> Int
minSize f1
f1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ObjectMeta -> Int
omMinSize ObjectMeta
jm

                        , omFixedSize :: Maybe Int
omFixedSize
                             = do Int
s1    <- f1 -> Maybe Int
forall f. Format f => f -> Maybe Int
fixedSize f1
f1
                                  Int
ss    <- ObjectMeta -> Maybe Int
omFixedSize ObjectMeta
jm
                                  Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
s1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ss })
                (String -> Text
T.pack String
label) f1
f1 Maybe (Value f1 -> Bool)
mKeep ObjectFields (f :*: fs)
ObjectFields (ObjectFormat' fs)
cc
 {-# INLINE mkObjectFields #-}


---------------------------------------------------------------------------------------------------
instance ( Format (ObjectFields fs)
         , Value  (ObjectFields fs) ~ Value fs)
      => Format (Object fs) where
 type Value (Object fs)
        = Value fs

 fieldCount :: Object fs -> Int
fieldCount (Object ObjectFields fs
_)
  = Int
1
 {-# INLINE fieldCount #-}

 minSize :: Object fs -> Int
minSize    (Object ObjectFields fs
fs)
  = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ObjectFields fs -> Int
forall f. Format f => f -> Int
minSize ObjectFields fs
fs
 {-# INLINE minSize #-}

 fixedSize :: Object fs -> Maybe Int
fixedSize  (Object ObjectFields fs
fs)
  = do  Int
sz      <- ObjectFields fs -> Maybe Int
forall f. Format f => f -> Maybe Int
fixedSize ObjectFields fs
fs
        Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return  (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sz)
 {-# INLINE fixedSize #-}

 packedSize :: Object fs -> Value (Object fs) -> Maybe Int
packedSize (Object ObjectFields fs
fs) Value (Object fs)
xs
  = do  Int
ps      <- ObjectFields fs -> Value (ObjectFields fs) -> Maybe Int
forall f. Format f => f -> Value f -> Maybe Int
packedSize ObjectFields fs
fs Value (ObjectFields fs)
Value (Object fs)
xs
        Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return  (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ps
 {-# INLINE packedSize #-}


---------------------------------------------------------------------------------------------------
instance Format (ObjectFields ()) where
 type Value (ObjectFields ())   = ()
 fieldCount :: ObjectFields () -> Int
fieldCount ObjectFields ()
ObjectFieldsNil     = Int
0
 minSize :: ObjectFields () -> Int
minSize    ObjectFields ()
ObjectFieldsNil     = Int
0
 fixedSize :: ObjectFields () -> Maybe Int
fixedSize  ObjectFields ()
ObjectFieldsNil     = Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
 packedSize :: ObjectFields () -> Value (ObjectFields ()) -> Maybe Int
packedSize ObjectFields ()
ObjectFieldsNil Value (ObjectFields ())
_   = Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
 {-# INLINE fieldCount #-}
 {-# INLINE minSize    #-}
 {-# INLINE fixedSize  #-}
 {-# INLINE packedSize #-}


instance Packable (ObjectFields ()) where
 packer :: ObjectFields ()
-> Value (ObjectFields ())
-> Addr#
-> IO ()
-> (Addr# -> IO ())
-> IO ()
packer   ObjectFields ()
_fmt Value (ObjectFields ())
_val Addr#
dst IO ()
_fails Addr# -> IO ()
k
  = Addr# -> IO ()
k Addr#
dst
 {-# INLINE packer #-}


instance Unpackable (ObjectFields ()) where
 unpacker :: ObjectFields ()
-> Addr#
-> Addr#
-> (Word8 -> Bool)
-> IO ()
-> (Addr# -> Value (ObjectFields ()) -> IO ())
-> IO ()
unpacker ObjectFields ()
_fmt Addr#
start Addr#
_end Word8 -> Bool
_stop IO ()
_fail Addr# -> Value (ObjectFields ()) -> IO ()
eat
  = Addr# -> Value (ObjectFields ()) -> IO ()
eat Addr#
start ()
 {-# INLINE unpacker #-}


instance ( Format f1, Format (ObjectFields fs)
         , Value  (ObjectFields fs)  ~ Value fs)
        => Format (ObjectFields (f1 :*: fs)) where

 type Value (ObjectFields (f1 :*: fs))
        = Value f1 :*: Value fs

 fieldCount :: ObjectFields (f1 :*: fs) -> Int
fieldCount (ObjectFieldsCons ObjectMeta
jm Text
_l1 f
_f1 Maybe (Value f -> Bool)
_keep ObjectFields fs
_jfs)
  = ObjectMeta -> Int
omFieldCount ObjectMeta
jm
 {-# INLINE fieldCount #-}

 minSize :: ObjectFields (f1 :*: fs) -> Int
minSize    (ObjectFieldsCons ObjectMeta
jm Text
_l1 f
_f1 Maybe (Value f -> Bool)
_keep ObjectFields fs
_jfs)
  = ObjectMeta -> Int
omMinSize ObjectMeta
jm
 {-# INLINE minSize #-}

 fixedSize :: ObjectFields (f1 :*: fs) -> Maybe Int
fixedSize  (ObjectFieldsCons ObjectMeta
jm Text
_l1 f
_f1 Maybe (Value f -> Bool)
_keep ObjectFields fs
_jfs)
  = ObjectMeta -> Maybe Int
omFixedSize ObjectMeta
jm
 {-# INLINE fixedSize #-}

 packedSize :: ObjectFields (f1 :*: fs)
-> Value (ObjectFields (f1 :*: fs)) -> Maybe Int
packedSize (ObjectFieldsCons ObjectMeta
_jm Text
l1 f
f1 Maybe (Value f -> Bool)
_keep ObjectFields fs
jfs) (Value f1
x1 :*: Value fs
xs)
  = do  Int
sl      <- VarCharString -> Value VarCharString -> Maybe Int
forall f. Format f => f -> Value f -> Maybe Int
packedSize VarCharString
VarCharString (Text -> String
T.unpack Text
l1)
        Int
s1      <- f -> Value f -> Maybe Int
forall f. Format f => f -> Value f -> Maybe Int
packedSize f
f1  Value f1
Value f
x1
        Int
ss      <- ObjectFields fs -> Value (ObjectFields fs) -> Maybe Int
forall f. Format f => f -> Value f -> Maybe Int
packedSize ObjectFields fs
jfs Value fs
Value (ObjectFields fs)
xs
        let sSep :: Int
sSep = Int -> Int
zeroOrOne (ObjectFields fs -> Int
forall f. Format f => f -> Int
fieldCount ObjectFields fs
jfs)
        Int -> Maybe Int
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return  (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int
sl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
s1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
sSep Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ss
 {-# INLINE packedSize #-}


---------------------------------------------------------------------------------------------------
instance ( Format   (Object f)
         , Value    (ObjectFields f) ~ Value f
         , Packable (ObjectFields f))
        => Packable (Object f) where

 pack :: Object f -> Value (Object f) -> Packer
pack (Object ObjectFields f
fs) Value (Object f)
xs
        =  Word8be -> Value Word8be -> Packer
forall format. Packable format => format -> Value format -> Packer
pack Word8be
Word8be (Int -> Word8
forall a. Integral a => a -> Word8
w8 (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
'{')
        Packer -> Packer -> Packer
forall a. Semigroup a => a -> a -> a
<> ObjectFields f -> Value (ObjectFields f) -> Packer
forall format. Packable format => format -> Value format -> Packer
pack ObjectFields f
fs Value (ObjectFields f)
Value (Object f)
xs
        Packer -> Packer -> Packer
forall a. Semigroup a => a -> a -> a
<> Word8be -> Value Word8be -> Packer
forall format. Packable format => format -> Value format -> Packer
pack Word8be
Word8be (Int -> Word8
forall a. Integral a => a -> Word8
w8 (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
'}')
 {-# INLINE pack #-}

 packer :: Object f
-> Value (Object f) -> Addr# -> IO () -> (Addr# -> IO ()) -> IO ()
packer Object f
f Value (Object f)
v
        = Packer -> Addr# -> IO () -> (Addr# -> IO ()) -> IO ()
fromPacker (Packer -> Addr# -> IO () -> (Addr# -> IO ()) -> IO ())
-> Packer -> Addr# -> IO () -> (Addr# -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Object f -> Value (Object f) -> Packer
forall format. Packable format => format -> Value format -> Packer
pack Object f
f Value (Object f)
v
 {-# INLINE packer #-}


---------------------------------------------------------------------------------------------------
instance ( Packable f1
         , Value    (ObjectFields ()) ~ Value ())
        => Packable (ObjectFields (f1 :*: ())) where

 pack :: ObjectFields (f1 :*: ())
-> Value (ObjectFields (f1 :*: ())) -> Packer
pack   (ObjectFieldsCons ObjectMeta
_jm Text
l1 f
f1 Maybe (Value f -> Bool)
_keep ObjectFields fs
_jfs) (Value f1
x1 :*: ()
_)
        =  VarCharString -> Value VarCharString -> Packer
forall format. Packable format => format -> Value format -> Packer
pack VarCharString
VarCharString (Text -> String
T.unpack Text
l1)
        Packer -> Packer -> Packer
forall a. Semigroup a => a -> a -> a
<> Word8be -> Value Word8be -> Packer
forall format. Packable format => format -> Value format -> Packer
pack Word8be
Word8be (Int -> Word8
forall a. Integral a => a -> Word8
w8 (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
':')
        Packer -> Packer -> Packer
forall a. Semigroup a => a -> a -> a
<> f -> Value f -> Packer
forall format. Packable format => format -> Value format -> Packer
pack f
f1 Value f1
Value f
x1
 {-# INLINE pack #-}

 packer :: ObjectFields (f1 :*: ())
-> Value (ObjectFields (f1 :*: ()))
-> Addr#
-> IO ()
-> (Addr# -> IO ())
-> IO ()
packer ObjectFields (f1 :*: ())
f Value (ObjectFields (f1 :*: ()))
v
        = Packer -> Addr# -> IO () -> (Addr# -> IO ()) -> IO ()
fromPacker (Packer -> Addr# -> IO () -> (Addr# -> IO ()) -> IO ())
-> Packer -> Addr# -> IO () -> (Addr# -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ ObjectFields (f1 :*: ())
-> Value (ObjectFields (f1 :*: ())) -> Packer
forall format. Packable format => format -> Value format -> Packer
pack ObjectFields (f1 :*: ())
f Value (ObjectFields (f1 :*: ()))
v
 {-# INLINE packer #-}


instance ( Packable f1
         , Packable (ObjectFields (f2 :*: fs))
         , Value    (ObjectFields (f2 :*: fs)) ~ Value (f2 :*: fs)
         , Value    (ObjectFields fs)          ~ Value fs)
        => Packable (ObjectFields (f1 :*: f2 :*: fs)) where

 -- Pack a field into the object,
 -- only keeping it if the keep flag is true.
 pack :: ObjectFields (f1 :*: (f2 :*: fs))
-> Value (ObjectFields (f1 :*: (f2 :*: fs))) -> Packer
pack (ObjectFieldsCons ObjectMeta
_jm Text
l1 f
f1 Maybe (Value f -> Bool)
mKeep ObjectFields fs
jfs) (Value f1
x1 :*: Value f2 :*: Value fs
xs)
  = if (case Maybe (Value f -> Bool)
mKeep of
         Just Value f -> Bool
keep -> Value f -> Bool
keep Value f1
Value f
x1
         Maybe (Value f -> Bool)
_         -> Bool
True)
     then Packer
here
     else Packer
rest
  where
   here :: Packer
here =   VarCharString -> Value VarCharString -> Packer
forall format. Packable format => format -> Value format -> Packer
pack VarCharString
VarCharString (Text -> String
T.unpack Text
l1)
        Packer -> Packer -> Packer
forall a. Semigroup a => a -> a -> a
<>  Word8be -> Value Word8be -> Packer
forall format. Packable format => format -> Value format -> Packer
pack Word8be
Word8be (Int -> Word8
forall a. Integral a => a -> Word8
w8 (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
':')
        Packer -> Packer -> Packer
forall a. Semigroup a => a -> a -> a
<>  f -> Value f -> Packer
forall format. Packable format => format -> Value format -> Packer
pack f
f1 Value f1
Value f
x1
        Packer -> Packer -> Packer
forall a. Semigroup a => a -> a -> a
<>  Word8be -> Value Word8be -> Packer
forall format. Packable format => format -> Value format -> Packer
pack Word8be
Word8be (Int -> Word8
forall a. Integral a => a -> Word8
w8 (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
ord Char
',')
        Packer -> Packer -> Packer
forall a. Semigroup a => a -> a -> a
<>  Packer
rest

   rest :: Packer
rest =   ObjectFields fs -> Value (ObjectFields fs) -> Packer
forall format. Packable format => format -> Value format -> Packer
pack ObjectFields fs
jfs Value f2 :*: Value fs
Value (ObjectFields fs)
xs
 {-# INLINE pack #-}

 packer :: ObjectFields (f1 :*: (f2 :*: fs))
-> Value (ObjectFields (f1 :*: (f2 :*: fs)))
-> Addr#
-> IO ()
-> (Addr# -> IO ())
-> IO ()
packer ObjectFields (f1 :*: (f2 :*: fs))
f Value (ObjectFields (f1 :*: (f2 :*: fs)))
v
        = Packer -> Addr# -> IO () -> (Addr# -> IO ()) -> IO ()
fromPacker (Packer -> Addr# -> IO () -> (Addr# -> IO ()) -> IO ())
-> Packer -> Addr# -> IO () -> (Addr# -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ ObjectFields (f1 :*: (f2 :*: fs))
-> Value (ObjectFields (f1 :*: (f2 :*: fs))) -> Packer
forall format. Packable format => format -> Value format -> Packer
pack ObjectFields (f1 :*: (f2 :*: fs))
f Value (ObjectFields (f1 :*: (f2 :*: fs)))
v
 {-# INLINE packer #-}


---------------------------------------------------------------------------------------------------
w8  :: Integral a => a -> Word8
w8 :: forall a. Integral a => a -> Word8
w8 = a -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE w8  #-}


-- | Branchless equality used to avoid compile-time explosion in size of core code.
zeroOrOne :: Int -> Int
zeroOrOne :: Int -> Int
zeroOrOne (I# Int#
i) = Int# -> Int
I# (Int#
1# Int# -> Int# -> Int#
-# (Int#
0# Int# -> Int# -> Int#
==# Int#
i))
{-# INLINE zeroOrOne #-}