{-# LANGUAGE DeriveDataTypeable #-}

{-# LANGUAGE EmptyDataDecls #-}

{-# LANGUAGE OverloadedStrings #-}

{-# LANGUAGE RankNTypes #-}

module Data.Aeson.Encoding.Internal

    (

    -- * Encoding

      Encoding' (..)

    , Encoding

    , encodingToLazyByteString

    , unsafeToEncoding

    , retagEncoding

    , Series (..)

    , pairs

    , pair

    , pairStr

    , pair'

    -- * Predicates

    , nullEncoding

    -- * Encoding constructors

    , emptyArray_

    , emptyObject_

    , wrapObject

    , wrapArray

    , null_

    , bool

    , text

    , lazyText

    , string

    , list

    , dict

    , tuple

    , (>*<)

    , InArray

    , empty

    , (><)

    , econcat

    -- ** Decimal numbers

    , int8, int16, int32, int64, int

    , word8, word16, word32, word64, word

    , integer, float, double, scientific

    -- ** Decimal numbers as Text

    , int8Text, int16Text, int32Text, int64Text, intText

    , word8Text, word16Text, word32Text, word64Text, wordText

    , integerText, floatText, doubleText, scientificText

    -- ** Time

    , day

    , localTime

    , utcTime

    , timeOfDay

    , zonedTime

    -- ** value

    , value

    -- ** JSON tokens

    , comma, colon, openBracket, closeBracket, openCurly, closeCurly

    ) where

import Prelude ()

import Prelude.Compat

import Data.Aeson.Types.Internal (Value)

import Data.ByteString.Builder (Builder, char7, toLazyByteString)

import Data.Int

import Data.Scientific (Scientific)

import Data.Semigroup (Semigroup ((<>)))

import Data.Text (Text)

import Data.Time (Day, LocalTime, TimeOfDay, UTCTime, ZonedTime)

import Data.Typeable (Typeable)

import Data.Word

import qualified Data.Aeson.Encoding.Builder as EB

import qualified Data.ByteString.Builder as B

import qualified Data.ByteString.Lazy as BSL

import qualified Data.Text.Lazy as LT

-- | An encoding of a JSON value.

--

-- @tag@ represents which kind of JSON the Encoding is encoding to,

-- we reuse 'Text' and 'Value' as tags here.

newtype Encoding' tag = Encoding {

      fromEncoding :: Builder

      -- ^ Acquire the underlying bytestring builder.

    } deriving (Typeable)

-- | Often used synonym for 'Encoding''.

type Encoding = Encoding' Value

-- | Make Encoding from Builder.

--

-- Use with care! You have to make sure that the passed Builder

-- is a valid JSON Encoding!

unsafeToEncoding :: Builder -> Encoding' a

unsafeToEncoding = Encoding

encodingToLazyByteString :: Encoding' a -> BSL.ByteString

encodingToLazyByteString = toLazyByteString . fromEncoding

{-# INLINE encodingToLazyByteString #-}

retagEncoding :: Encoding' a -> Encoding' b

retagEncoding = Encoding . fromEncoding

-------------------------------------------------------------------------------

-- Encoding instances

-------------------------------------------------------------------------------

instance Show (Encoding' a) where

    show (Encoding e) = show (toLazyByteString e)

instance Eq (Encoding' a) where

    Encoding a == Encoding b = toLazyByteString a == toLazyByteString b

instance Ord (Encoding' a) where

    compare (Encoding a) (Encoding b) =

      compare (toLazyByteString a) (toLazyByteString b)

-- | A series of values that, when encoded, should be separated by

-- commas. Since 0.11.0.0, the '.=' operator is overloaded to create

-- either @(Text, Value)@ or 'Series'. You can use Series when

-- encoding directly to a bytestring builder as in the following

-- example:

--

-- > toEncoding (Person name age) = pairs ("name" .= name <> "age" .= age)

data Series = Empty

            | Value (Encoding' Series)

            deriving (Typeable)

pair :: Text -> Encoding -> Series

pair name val = pair' (text name) val

{-# INLINE pair #-}

pairStr :: String -> Encoding -> Series

pairStr name val = pair' (string name) val

{-# INLINE pairStr #-}

pair' :: Encoding' Text -> Encoding -> Series

pair' name val = Value $ retagEncoding $ retagEncoding name >< colon >< val

instance Semigroup Series where

    Empty   <> a       = a

    a       <> Empty   = a

    Value a <> Value b = Value (a >< comma >< b)

instance Monoid Series where

    mempty  = Empty

    mappend = (<>)

nullEncoding :: Encoding' a -> Bool

nullEncoding = BSL.null . toLazyByteString . fromEncoding

emptyArray_ :: Encoding

emptyArray_ = Encoding EB.emptyArray_

emptyObject_ :: Encoding

emptyObject_ = Encoding EB.emptyObject_

wrapArray :: Encoding' a -> Encoding

wrapArray e = retagEncoding $ openBracket >< e >< closeBracket

wrapObject :: Encoding' a -> Encoding

wrapObject e = retagEncoding $ openCurly >< e >< closeCurly

null_ :: Encoding

null_ = Encoding EB.null_

bool :: Bool -> Encoding

bool True = Encoding "true"

bool False = Encoding "false"

-- | Encode a series of key/value pairs, separated by commas.

pairs :: Series -> Encoding

pairs (Value v) = openCurly >< retagEncoding v >< closeCurly

pairs Empty     = emptyObject_

{-# INLINE pairs #-}

list :: (a -> Encoding) -> [a] -> Encoding

list _  []     = emptyArray_

list to' (x:xs) = openBracket >< to' x >< commas xs >< closeBracket

  where

    commas = foldr (\v vs -> comma >< to' v >< vs) empty

{-# INLINE list #-}

-- | Encode as JSON object

dict

    :: (k -> Encoding' Text)                     -- ^ key encoding

    -> (v -> Encoding)                                -- ^ value encoding

    -> (forall a. (k -> v -> a -> a) -> a -> m -> a)  -- ^ @foldrWithKey@ - indexed fold

    -> m                                              -- ^ container

    -> Encoding

dict encodeKey encodeVal foldrWithKey = pairs . foldrWithKey go mempty

  where

    go k v c = Value (encodeKV k v) <> c

    encodeKV k v = retagEncoding (encodeKey k) >< colon >< retagEncoding (encodeVal v)

{-# INLINE dict #-}

-- | Type tag for tuples contents, see 'tuple'.

data InArray

infixr 6 >*<

-- | See 'tuple'.

(>*<) :: Encoding' a -> Encoding' b -> Encoding' InArray

a >*< b = retagEncoding a >< comma >< retagEncoding b

{-# INLINE (>*<) #-}

empty :: Encoding' a

empty = Encoding mempty

econcat :: [Encoding' a] -> Encoding' a

econcat = foldr (><) empty

infixr 6 ><

(><) :: Encoding' a -> Encoding' a -> Encoding' a

Encoding a >< Encoding b = Encoding (a <> b)

{-# INLINE (><) #-}

-- | Encode as a tuple.

--

-- @

-- toEncoding (X a b c) = tuple $

--     toEncoding a >*<

--     toEncoding b >*<

--     toEncoding c

tuple :: Encoding' InArray -> Encoding

tuple b = retagEncoding $ openBracket >< b >< closeBracket

{-# INLINE tuple #-}

text :: Text -> Encoding' a

text = Encoding . EB.text

lazyText :: LT.Text -> Encoding' a

lazyText t = Encoding $

    B.char7 '"' <>

    LT.foldrChunks (\x xs -> EB.unquoted x <> xs) (B.char7 '"') t

string :: String -> Encoding' a

string = Encoding . EB.string

-------------------------------------------------------------------------------

-- chars

-------------------------------------------------------------------------------

comma, colon, openBracket, closeBracket, openCurly, closeCurly :: Encoding' a

comma        = Encoding $ char7 ','

colon        = Encoding $ char7 ':'

openBracket  = Encoding $ char7 '['

closeBracket = Encoding $ char7 ']'

openCurly    = Encoding $ char7 '{'

closeCurly   = Encoding $ char7 '}'

-------------------------------------------------------------------------------

-- Decimal numbers

-------------------------------------------------------------------------------

int8 :: Int8 -> Encoding

int8 = Encoding . B.int8Dec

int16 :: Int16 -> Encoding

int16 = Encoding . B.int16Dec

int32 :: Int32 -> Encoding

int32 = Encoding . B.int32Dec

int64 :: Int64 -> Encoding

int64 = Encoding . B.int64Dec

int :: Int -> Encoding

int = Encoding . B.intDec

word8 :: Word8 -> Encoding

word8 = Encoding . B.word8Dec

word16 :: Word16 -> Encoding

word16 = Encoding . B.word16Dec

word32 :: Word32 -> Encoding

word32 = Encoding . B.word32Dec

word64 :: Word64 -> Encoding

word64 = Encoding . B.word64Dec

word :: Word -> Encoding

word = Encoding . B.wordDec

integer :: Integer -> Encoding

integer = Encoding . B.integerDec

float :: Float -> Encoding

float = realFloatToEncoding $ Encoding . B.floatDec

double :: Double -> Encoding

double = realFloatToEncoding $ Encoding . B.doubleDec

scientific :: Scientific -> Encoding

scientific = Encoding . EB.scientific

realFloatToEncoding :: RealFloat a => (a -> Encoding) -> a -> Encoding

realFloatToEncoding e d

    | isNaN d || isInfinite d = null_

    | otherwise               = e d

{-# INLINE realFloatToEncoding #-}

-------------------------------------------------------------------------------

-- Decimal numbers as Text

-------------------------------------------------------------------------------

int8Text :: Int8 -> Encoding' a

int8Text = Encoding . EB.quote . B.int8Dec

int16Text :: Int16 -> Encoding' a

int16Text = Encoding . EB.quote . B.int16Dec

int32Text :: Int32 -> Encoding' a

int32Text = Encoding . EB.quote . B.int32Dec

int64Text :: Int64 -> Encoding' a

int64Text = Encoding . EB.quote . B.int64Dec

intText :: Int -> Encoding' a

intText = Encoding . EB.quote . B.intDec

word8Text :: Word8 -> Encoding' a

word8Text = Encoding . EB.quote . B.word8Dec

word16Text :: Word16 -> Encoding' a

word16Text = Encoding . EB.quote . B.word16Dec

word32Text :: Word32 -> Encoding' a

word32Text = Encoding . EB.quote . B.word32Dec

word64Text :: Word64 -> Encoding' a

word64Text = Encoding . EB.quote . B.word64Dec

wordText :: Word -> Encoding' a

wordText = Encoding . EB.quote . B.wordDec

integerText :: Integer -> Encoding' a

integerText = Encoding . EB.quote . B.integerDec

floatText :: Float -> Encoding' a

floatText = Encoding . EB.quote . B.floatDec

doubleText :: Double -> Encoding' a

doubleText = Encoding . EB.quote . B.doubleDec

scientificText :: Scientific -> Encoding' a

scientificText = Encoding . EB.quote . EB.scientific

-------------------------------------------------------------------------------

-- time

-------------------------------------------------------------------------------

day :: Day -> Encoding' a

day = Encoding . EB.quote . EB.day

localTime :: LocalTime -> Encoding' a

localTime = Encoding . EB.quote . EB.localTime

utcTime :: UTCTime -> Encoding' a

utcTime = Encoding . EB.quote . EB.utcTime

timeOfDay :: TimeOfDay -> Encoding' a

timeOfDay = Encoding . EB.quote . EB.timeOfDay

zonedTime :: ZonedTime -> Encoding' a

zonedTime = Encoding . EB.quote . EB.zonedTime

-------------------------------------------------------------------------------

-- Value

-------------------------------------------------------------------------------

value :: Value -> Encoding

value = Encoding . EB.encodeToBuilder