{-# 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 synonnym 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