------------------------------------------------------------------------------- |-- Module : Data.Json.Builder.Implementation-- Copyright : (c) 2011-2012 Leon P Smith-- License : BSD3---- Maintainer : Leon P Smith <leon@melding-monads.com>---- This module contains all definitions for the library. Different-- subsets are exported by Data.Json.Builder and Data.Json.Builder.Internal.-------------------------------------------------------------------------------{-# LANGUAGE BangPatterns #-}{-# LANGUAGE ViewPatterns #-}{-# LANGUAGE OverloadedStrings #-}{-# LANGUAGE FlexibleInstances #-}{-# LANGUAGE IncoherentInstances #-}{-# LANGUAGE GeneralizedNewtypeDeriving #-}moduleData.Json.Builder.ImplementationwhereimportPreludehiding((++))importBlaze.ByteString.BuilderasBlaze(Write,Builder,copyByteString,fromByteString,fromLazyByteString,writeByteString,fromWrite,fromWriteList,writeWord8,toByteString,toLazyByteString)importBlaze.ByteString.Builder.Char.Utf8(fromChar,writeChar,fromText,fromLazyText)importqualifiedBlaze.ByteString.Builder.Char.Utf8asBuilder(fromString)importBlaze.Text(float,double,integral)importData.Bits(Bits((.&.),shiftR))importqualifiedData.MapasMapimportData.Monoid(Monoid(mempty,mappend,mconcat))importData.Int(Int8,Int16,Int32,Int64)importData.Word(Word,Word8,Word16,Word32,Word64)importqualifiedData.ByteStringasBSimportqualifiedData.ByteString.LazyasBLimportqualifiedData.ByteString.UTF8asBUimportqualifiedData.ByteString.Lazy.UTF8asBLUimportData.ByteString.Internal(c2w)importData.String(fromString)importqualifiedData.TextasTimportqualifiedData.Text.LazyasTLimportqualifiedData.HashMap.LazyasHashMapimportqualifiedData.VectorasVector(++)::Monoida=>a->a->a(++)=mappendinfixr5++-- | The 'Value' typeclass represents types that can be rendered-- into valid json syntax.classValueawheretoJson::a->Json-- | The 'Json' type represents valid json syntax. It cannot be directly-- analyzed, however it can be turned into a 'Builder' via 'toBuilder',-- a (lazy) 'BS.ByteString' via 'toJsonBS' or 'toJsonLBS', or used as a-- component of a json 'Array' or json 'Object' using 'element' or 'row'.newtypeJson=JsonBuilderinstanceValueJsonwheretoJson=id-- | The 'Escaped' type represents json string syntax. The purpose of this-- type is so that json strings can be efficiently constructed from multiple-- Haskell strings without superfluous conversions or concatinations.---- Internally, it is just a 'Builder' value which must produce a UTF-8 encoded-- bytestring with backslashes, quotes, and control characters appropriately-- escaped. It also must not render the opening or closing quote, which-- are instead rendered by 'toJson'.newtypeEscaped=EscapedBuilderderiving(Monoid)instanceValueEscapedwheretoJson(Escapedstr)=Json(fromChar'"'++str++fromChar'"')-- | The 'JsString' typeclass represents types that can be render into json-- string syntax. They are special because only strings can appear as field-- names of json objects.classValuea=>JsStringawhereescape::a->EscapedinstanceJsStringEscapedwhereescape=id-- | The 'Object' type represents syntax for a json object. It has a singleton-- constructor 'row', and an instance of 'Monoid', so that 'mempty' represents-- the empty object and 'mappend' concatinates two objects. Arbitrary objects-- can be constructed using these operators.---- Note that duplicate field names will appear in the output, so it is up-- to the user of this interface to avoid duplicate field names.newtypeObject=ObjectCommaMonoidderiving(Monoid)instanceValueObjectwheretoJson(Objectxs)=casexsofEmpty->Json(copyByteString"{}")Commays->Json(fromChar'{'++ys++fromChar'}')classJsObjectawheretoObject::a->ObjectinstanceJsObjectObjectwheretoObject=id-- | The 'row' function constructs a json object consisting of exactly-- one field. These objects can be concatinated using 'mappend'.row::(JsStringk,Valuea)=>k->a->Objectrowka=Object(Comma(toBuilderk++fromChar':'++toBuildera))-- | The 'Array' type represents syntax for a json array. It has been given-- a singleton constructor 'element' and an instance of 'Monoid', so that-- 'mempty' represents the empty array and 'mappend' concatinates two arrays.-- Arbitrary arrays can be constructed using these operators.newtypeArray=ArrayCommaMonoidderiving(Monoid)instanceValueArraywheretoJson(Arrayxs)=casexsofEmpty->Json(copyByteString"[]")Commays->Json(fromChar'['++ys++fromChar']')classJsArrayawheretoArray::a->ArrayinstanceJsArrayArraywheretoArray=id-- | The 'element' function constructs a json array consisting of exactly-- one value. These arrays can be concatinated using 'mappend'.element::Valuea=>a->Arrayelementa=Array(Comma(toBuildera))-- | A 'CommaMonoid' inserts commas between builders. In order to-- satisify the 'Monoid' identity laws, 'Empty' must be distinguished-- from @'Comma' 'mempty'@. To demonstrate the difference:---- @-- mconcat [\"foo\", \"\" , \"bar\"] == \"foo,,bar\"-- mconcat [\"foo\", Empty , \"bar\"] == \"foo,bar\"-- @---- The strings in this example denote @CommaMonoids@ via-- @'fromString' = Comma . 'Builder.fromString'@. Thus @\"\"@ is equivalent-- to @Comma mempty@.dataCommaMonoid=Empty|Comma!BuilderinstanceMonoidCommaMonoidwheremempty=EmptymappendEmptyx=xmappend(Commaa)x=Comma(a++casexofEmpty->memptyCommab->fromChar','++b)toBuilder::Valuea=>a->BuildertoBuilderx=casetoJsonxofJsony->y{-# SPECIALIZE toBuilder :: Json -> Builder #-}{-# INLINE toBuilder #-}toJsonBS::Valuea=>a->BS.ByteStringtoJsonBS=toByteString.toBuildertoJsonLBS::Valuea=>a->BL.ByteStringtoJsonLBS=toLazyByteString.toBuilder-- A primitive to render -- | this renders as Json's @null@ value.jsNull::JsonjsNull=Json(copyByteString"null")-- Primitive instances for json-builderinstanceValueIntwheretoJson=Json.integralinstanceValueInt8wheretoJson=Json.integralinstanceValueInt16wheretoJson=Json.integralinstanceValueInt32wheretoJson=Json.integralinstanceValueInt64wheretoJson=Json.integralinstanceValueIntegerwheretoJson=Json.integralinstanceValueWordwheretoJson=Json.integralinstanceValueWord8wheretoJson=Json.integralinstanceValueWord16wheretoJson=Json.integralinstanceValueWord32wheretoJson=Json.integralinstanceValueWord64wheretoJson=Json.integralinstanceValueDoublewheretoJson=Json.doubleinstanceValueFloatwheretoJson=Json.float-- | renders as @true@ or @false@instanceValueBoolwheretoJsonx=Json(fromByteString$!ifxthen"true"else"false")-- | must be UTF-8 encodedinstanceJsStringBS.ByteStringwhereescapex=Escaped(loopx)whereloop(BU.breakquoteNeeded->(a,b))=fromByteStringa++caseBU.decodebofNothing->memptyJust(c,n)->quoteCharc++loop(BS.dropnb)instanceValueBS.ByteStringwheretoJson=toJson.escape-- | must be UTF-8 encodedinstanceJsStringBL.ByteStringwhereescapex=Escaped(loopx)whereloop(BLU.breakquoteNeeded->(a,b))=fromLazyByteStringa++caseBLU.decodebofNothing->memptyJust(c,n)->quoteCharc++loop(BL.dropnb)instanceValueBL.ByteStringwheretoJson=toJson.escapeinstanceJsStringT.Textwhereescapex=Escaped(loopx)whereloop(T.breakquoteNeeded->(a,b))=fromTexta++caseT.unconsbofNothing->memptyJust(c,b')->quoteCharc++loopb'instanceValueT.TextwheretoJson=toJson.escapeinstanceJsStringTL.Textwhereescapex=Escaped(loopx)whereloop(TL.breakquoteNeeded->(a,b))=fromLazyTexta++caseTL.unconsbofNothing->memptyJust(c,b')->quoteCharc++loopb'instanceValueTL.TextwheretoJson=toJson.escapeinstanceJsString[Char]whereescapestr=Escaped(fromWriteListwriteEscapedCharstr)wherewriteEscapedCharc|quoteNeededc=quoteCharWc|otherwise=writeCharcinstanceValue[Char]wheretoJson=toJson.escape-- | renders as an 'Array'instanceValuea=>Value[a]wheretoJson=toJson.toArrayinstanceValuea=>JsArray[a]wheretoArray=foldr(\aas->elementa++as)mempty-- | renders as an 'Array'instanceValuea=>Value(Vector.Vectora)wheretoJson=toJson.toArrayinstanceValuea=>JsArray(Vector.Vectora)wheretoArray=Vector.foldr(\aas->elementa++as)mempty-- | renders as an 'Object'instance(JsStringk,Valuea)=>Value(Map.Mapka)wheretoJson=toJson.toObjectinstance(JsStringk,Valuea)=>JsObject(Map.Mapka)wheretoObject=Map.foldrWithKey(\kab->rowka++b)mempty-- | renders as an 'Object'instance(JsStringk,Valuea)=>Value(HashMap.HashMapka)wheretoJson=toJson.toObjectinstance(JsStringk,Valuea)=>JsObject(HashMap.HashMapka)wheretoObject=HashMap.foldrWithKey(\kab->rowka++b)memptyinstance(Valuea,Valueb)=>JsArray(a,b)wheretoArray(a,b)=elementa++elementb-- | renders as an 'Array'instanceValue()wheretoJson=toJson.toArrayinstanceJsArray()wheretoArray_=mempty-- | renders as an 'Array'instance(Valuea,Valueb)=>Value(a,b)wheretoJson=toJson.toArrayinstance(Valuea,Valueb,Valuec)=>JsArray(a,b,c)wheretoArray(a,b,c)=elementa++elementb++elementc-- | renders as an 'Array'instance(Valuea,Valueb,Valuec)=>Value(a,b,c)wheretoJson=toJson.toArrayinstance(Valuea,Valueb,Valuec,Valued)=>JsArray(a,b,c,d)wheretoArray(a,b,c,d)=elementa++elementb++elementc++elementd-- | renders as an 'Array'instance(Valuea,Valueb,Valuec,Valued)=>Value(a,b,c,d)wheretoJson=toJson.toArray------------------------------------------------------------------------------quoteNeeded::Char->BoolquoteNeededc=c=='\\'||c=='"'||c<'\x20'{-# INLINE quoteNeeded #-}quoteChar::Char->BuilderquoteCharc=casecof'\\'->copyByteString"\\\\"'"'->copyByteString"\\\""'\b'->copyByteString"\\b"'\f'->copyByteString"\\f"'\n'->copyByteString"\\n"'\r'->copyByteString"\\r"'\t'->copyByteString"\\t"_->fromWrite(hexEscapec)quoteCharW::Char->WritequoteCharWc=casecof'\\'->writeByteString"\\\\"'"'->writeByteString"\\\""'\b'->writeByteString"\\b"'\f'->writeByteString"\\f"'\n'->writeByteString"\\n"'\r'->writeByteString"\\r"'\t'->writeByteString"\\t"_->hexEscapechexEscape::Char->WritehexEscape(c2w->c)=writeByteString"\\u00"++writeWord8(char((c`shiftR`4).&.0xF))++writeWord8(char(c.&.0xF)){-# INLINE hexEscape #-}char::Word8->Word8chari|i<10=i+48|otherwise=i+87{-# INLINE char #-}