packages feed

blaze-json (empty) → 0.1.0

raw patch · 8 files changed

+659/−0 lines, 8 filesdep +QuickCheckdep +aesondep +basesetup-changed

Dependencies added: QuickCheck, aeson, base, blaze-json, bytestring, bytestring-builder, containers, data-default-class, doctest, scientific, tasty, tasty-quickcheck, text, unordered-containers, vector

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Hirotomo Moriwaki++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ blaze-json.cabal view
@@ -0,0 +1,53 @@+name:                blaze-json+version:             0.1.0+synopsis:            tiny library for encoding json+license:             MIT+license-file:        LICENSE+author:              HirotomoMoriwaki<philopon.dependence@gmail.com>+maintainer:          HirotomoMoriwaki<philopon.dependence@gmail.com>+Homepage:            https://github.com/philopon/blaze-json+Bug-reports:         https://github.com/philopon/blaze-json/issues+copyright:           (c) 2015 Hirotomo Moriwaki+category:            Text, JSON+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:     Text.Blaze.JSON+                     , Text.Blaze.JSON.Class+                     , Text.Blaze.JSON.Internal+  build-depends:       base               >=4.6  && <4.9+                     , text               >=1.1  && <1.3+                     , bytestring         >=0.9  && <0.11+                     , containers         >=0.5  && <0.6+                     , data-default-class >=0.0  && <0.1+                     , bytestring-builder >=0.10 && <0.11+  ghc-options:         -Wall -O2+  hs-source-dirs:      src+  default-language:    Haskell2010++test-suite tasty+  main-is:             tasty.hs+  type:                exitcode-stdio-1.0+  build-depends:       base+                     , text+                     , blaze-json+                     , tasty                >=0.10 && <0.11+                     , tasty-quickcheck     >=0.8  && <0.9+                     , QuickCheck           >=2.7  && <2.9+                     , aeson                >=0.7  && <0.9+                     , scientific           >=0.3  && <0.4+                     , vector               >=0.10 && <0.11+                     , unordered-containers >=0.2  && <0.3+  hs-source-dirs:      tests+  ghc-options:         -Wall+  default-language:    Haskell2010++test-suite doctest+  main-is:             doctest.hs+  type:                exitcode-stdio-1.0+  build-depends:       base+                     , doctest              >=0.9  && <0.10+  hs-source-dirs:      tests+  ghc-options:         -Wall+  default-language:    Haskell2010
+ src/Text/Blaze/JSON.hs view
@@ -0,0 +1,34 @@+module Text.Blaze.JSON+    ( JSON+      -- * configuration+    , EncodeConfig(..)+    , def++      -- * convert+    , toBuilder+    , encodeWith+    , encode++      -- * constructors+      -- ** null+    , null+      -- ** bool+    , bool+      -- ** number+    , integral, double+      -- ** string+    , text, lazyText+      -- ** array+    , array+      -- ** object+    , object++      -- * reexports+    , module Text.Blaze.JSON.Class+    ) where++import Prelude hiding (null)++import Text.Blaze.JSON.Internal+import Text.Blaze.JSON.Class+import Data.Default.Class
+ src/Text/Blaze/JSON/Class.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ < 710+{-# LANGUAGE OverlappingInstances #-}+#endif++module Text.Blaze.JSON.Class where++import Prelude hiding(null)++import Text.Blaze.JSON.Internal++import qualified Data.Text as T+import qualified Data.Text.Lazy as L++import Data.Monoid+import Data.Int+import Data.Word+import qualified Data.Foldable as F++import qualified Data.Map as Map+import qualified Data.IntMap as IntMap+import qualified Data.Set as Set+import qualified Data.IntSet as IntSet+import qualified Data.Tree as Tree++class ToJSON a where+    toJSON :: a -> JSON++instance ToJSON a => ToJSON (Maybe a) where+    toJSON = maybe null toJSON+    {-# INLINE toJSON #-}++instance (ToJSON a, ToJSON b) => ToJSON (Either a b) where+    toJSON = object' id id . either left right+      where+        left  l = [("Left",  toJSON l)]+        right r = [("Right", toJSON r)]+    {-# INLINE toJSON #-}++instance ToJSON Bool where+    toJSON = bool+    {-# INLINE toJSON #-}++instance ToJSON () where+    toJSON _ = array' id []+    {-# INLINE toJSON #-}++instance ToJSON [Char] where+    toJSON = text . T.pack+    {-# INLINE toJSON #-}++instance ToJSON Char where+    toJSON = text . T.singleton+    {-# INLINE toJSON #-}++instance ToJSON Double where+    toJSON = double+    {-# INLINE toJSON #-}++instance ToJSON Float where+    toJSON = float+    {-# INLINE toJSON #-}++instance ToJSON Int where+    toJSON = integral+    {-# INLINE toJSON #-}++instance ToJSON Integer where+    toJSON = integral+    {-# INLINE toJSON #-}++instance ToJSON Int8 where+    toJSON = integral+    {-# INLINE toJSON #-}++instance ToJSON Int16 where+    toJSON = integral+    {-# INLINE toJSON #-}++instance ToJSON Int32 where+    toJSON = integral+    {-# INLINE toJSON #-}++instance ToJSON Int64 where+    toJSON = integral+    {-# INLINE toJSON #-}++instance ToJSON Word where+    toJSON = integral+    {-# INLINE toJSON #-}++instance ToJSON Word8 where+    toJSON = integral+    {-# INLINE toJSON #-}++instance ToJSON Word16 where+    toJSON = integral+    {-# INLINE toJSON #-}++instance ToJSON Word32 where+    toJSON = integral+    {-# INLINE toJSON #-}++instance ToJSON Word64 where+    toJSON = integral+    {-# INLINE toJSON #-}++instance ToJSON T.Text where+    toJSON = text+    {-# INLINE toJSON #-}++instance ToJSON L.Text where+    toJSON = lazyText+    {-# INLINE toJSON #-}++#if __GLASGOW_HASKELL__ >= 710+instance {-# OVERLAPPABLE #-} (F.Foldable f, ToJSON a) => ToJSON (f a) where+#else+instance (F.Foldable f, ToJSON a) => ToJSON (f a) where+#endif+    toJSON = array' toJSON+    {-# INLINE toJSON #-}++instance ToJSON a => ToJSON (Set.Set a) where+    toJSON = toJSON . Set.toList+    {-# INLINE toJSON #-}++instance ToJSON IntSet.IntSet where+    toJSON = toJSON . IntSet.toList+    {-# INLINE toJSON #-}++instance ToJSON a => ToJSON (IntMap.IntMap a) where+    toJSON = toJSON . IntMap.toList+    {-# INLINE toJSON #-}++instance ToJSON v => ToJSON (Map.Map T.Text v) where+    toJSON = unsafeObject' id toJSON . Map.toList+    {-# INLINE toJSON #-}++instance ToJSON v => ToJSON (Map.Map L.Text v) where+    toJSON = unsafeObject' L.toStrict toJSON . Map.toList+    {-# INLINE toJSON #-}++instance ToJSON v => ToJSON (Map.Map String v) where+    toJSON = unsafeObject' T.pack toJSON . Map.toList+    {-# INLINE toJSON #-}++instance ToJSON a => ToJSON (Tree.Tree a) where+    toJSON (Tree.Node r b) = toJSON (r,b)+    {-# INLINE toJSON #-}++instance ToJSON JSON where+    toJSON = id+    {-# INLINE toJSON #-}++instance (ToJSON a, ToJSON b) => ToJSON (a, b) where+    toJSON (a,b) = array' id [toJSON a, toJSON b]+    {-# INLINE toJSON #-}++instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a, b, c) where+    toJSON (a,b,c) = array' id [toJSON a, toJSON b, toJSON c]+    {-# INLINE toJSON #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a, b, c, d) where+    toJSON (a,b,c,d) = array' id [toJSON a, toJSON b, toJSON c, toJSON d]+    {-# INLINE toJSON #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e) => ToJSON (a, b, c, d, e) where+    toJSON (a,b,c,d,e) = array' id [toJSON a, toJSON b, toJSON c, toJSON d, toJSON e]+    {-# INLINE toJSON #-}++instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f) => ToJSON (a, b, c, d, e, f) where+    toJSON (a,b,c,d,e,f) = array' id [toJSON a, toJSON b, toJSON c, toJSON d, toJSON e, toJSON f]+    {-# INLINE toJSON #-}++instance ToJSON a => ToJSON (Dual a) where+    toJSON = toJSON . getDual+    {-# INLINE toJSON #-}++instance ToJSON a => ToJSON (First a) where+    toJSON = toJSON . getFirst+    {-# INLINE toJSON #-}++instance ToJSON a => ToJSON (Last a) where+    toJSON = toJSON . getLast+    {-# INLINE toJSON #-}
+ src/Text/Blaze/JSON/Internal.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP #-}++module Text.Blaze.JSON.Internal+    ( JSON(..), toBuilder, encodeWith, encode+    , EncodeConfig(..)+    , unsafeToJSON+    , bool+    , null+    , integral+    , double, float+    , text+    , lazyText+    , array', array+    , object', object+    , unsafeObject', unsafeObject+    ) where++import Prelude hiding (null)++#if !MIN_VERSION_bytestring(0,10,4)+#define COMPATIBILITY 1+#endif++#if COMPATIBILITY+import qualified Data.ByteString as S+#endif+import qualified Data.ByteString.Lazy as L++import qualified Data.ByteString.Builder as B+import qualified Data.ByteString.Builder.Prim as BP++import qualified Data.Foldable as F+import Data.Typeable(Typeable)+import Data.Monoid++import Data.Word+import Data.Char(ord)+import Data.Default.Class++import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Encoding as TL++import qualified Data.Set as Set++-- $setup+-- >>> :set -XOverloadedStrings++-- | JSON encoding data type+newtype JSON = JSON { unJSON :: EncodeConfig -> B.Builder }+    deriving(Typeable)++-- | >>> def :: EncodeConfig+-- EncodeConfig {escapeHtml = False}+newtype EncodeConfig = EncodeConfig+    { escapeHtml :: Bool -- ^ escape &lt; and &gt; to \\uXXXX.+    } deriving Show++instance Default EncodeConfig where+    def = EncodeConfig False+    {-# INLINABLE def #-}++-- | convert JSON to bytestring Builder.+toBuilder :: EncodeConfig -> JSON -> B.Builder+toBuilder = flip unJSON+{-# INLINABLE toBuilder #-}++-- | encode JSON using given config+encodeWith :: EncodeConfig -> JSON -> L.ByteString+encodeWith cfg = B.toLazyByteString . toBuilder cfg++-- | @+-- encode = encodeWith def+-- @+encode :: JSON -> L.ByteString+encode = encodeWith def+{-# INLINABLE encode #-}++instance Eq JSON where+    a == b = encode a == encode b+    {-# INLINABLE (==) #-}++instance Ord JSON where+    a `compare` b = encode a `compare` encode b+    {-# INLINABLE compare #-}++instance Show JSON where+    show = show . TL.decodeUtf8 . encode+    {-# INLINABLE show #-}++ascii2 :: (Char, Char) -> BP.BoundedPrim a+ascii2 cs = BP.liftFixedToBounded $ (const cs) BP.>$< BP.char7 BP.>*< BP.char7+{-# INLINE ascii2 #-}++ascii4 :: (Char, (Char, (Char, Char))) -> BP.BoundedPrim a+ascii4 cs = BP.liftFixedToBounded $ (const cs) BP.>$<+    BP.char7 BP.>*< BP.char7 BP.>*< BP.char7 BP.>*< BP.char7+{-# INLINE ascii4 #-}++ascii5 :: (Char, (Char, (Char, (Char, Char)))) -> BP.BoundedPrim a+ascii5 cs = BP.liftFixedToBounded $ (const cs) BP.>$<+    BP.char7 BP.>*< BP.char7 BP.>*< BP.char7 BP.>*< BP.char7 BP.>*< BP.char7+{-# INLINE ascii5 #-}++unsafeToJSON :: B.Builder -> JSON+unsafeToJSON = JSON . const+{-# INLINE unsafeToJSON #-}++-- | json null value+--+-- >>> null+-- "null"+null :: JSON+null = unsafeToJSON $ BP.primBounded (ascii4 ('n', ('u', ('l', 'l')))) ()+{-# INLINABLE null #-}++-- | json boolean value from Bool+--+-- >>> bool True+-- "true"+bool :: Bool -> JSON+bool = unsafeToJSON . BP.primBounded+    (BP.condB id+        (ascii4 ('t', ('r', ('u', 'e'))))+        (ascii5 ('f', ('a', ('l', ('s', 'e'))))))+{-# INLINABLE bool #-}++-- | json number value from Integral+--+-- >>> integral 32+-- "32"+integral :: Integral i => i -> JSON+integral = unsafeToJSON . B.integerDec . fromIntegral+{-# INLINABLE integral #-}++-- | json number value from float+--+-- >>> float 235.12+-- "235.12"+float :: Float -> JSON+float = unsafeToJSON . B.floatDec+{-# INLINABLE float #-}++-- | json number value from double+--+-- >>> double 235.12+-- "235.12"+double :: Double -> JSON+double = unsafeToJSON . B.doubleDec+{-# INLINABLE double #-}++escapeAscii :: Bool -> BP.BoundedPrim Word8+escapeAscii html =+    BP.condB (\w -> html && w == c2w '<') (BP.liftFixedToBounded hexEscape) $+    BP.condB (\w -> html && w == c2w '>') (BP.liftFixedToBounded hexEscape) $+    BP.condB (== c2w '\\' ) (ascii2 ('\\','\\')) $+    BP.condB (== c2w '\"' ) (ascii2 ('\\','"' )) $+    BP.condB (>= c2w '\x20') (BP.liftFixedToBounded BP.word8) $+    BP.condB (== c2w '\n' ) (ascii2 ('\\','n' )) $+    BP.condB (== c2w '\r' ) (ascii2 ('\\','r' )) $+    BP.condB (== c2w '\t' ) (ascii2 ('\\','t' )) $+    (BP.liftFixedToBounded hexEscape) -- fallback for chars < 0x20+  where++    c2w = fromIntegral . ord++    hexEscape :: BP.FixedPrim Word8+    hexEscape = (\c -> ('\\', ('u', fromIntegral c))) BP.>$<+        BP.char8 BP.>*< BP.char8 BP.>*< BP.word16HexFixed+{-# INLINABLE escapeAscii #-}++-- | json text value from Text+--+-- >>> print $ text "foo\n"+-- "\"foo\\n\""+text :: T.Text -> JSON+{-# INLINABLE text #-}++-- | json text value from LazyText+--+-- >>> print $ lazyText "bar\0"+-- "\"bar\\u0000\""+lazyText :: TL.Text -> JSON+{-# INLINABLE lazyText #-}++#if COMPATIBILITY++appendWord8 :: EncodeConfig -> Word8 -> B.Builder -> B.Builder+appendWord8 cfg = \w b -> BP.primBounded (escapeAscii $ escapeHtml cfg) w <> b+{-# INLINE appendWord8 #-}++text t = JSON $ \cfg -> surround "\"" "\"" $+    S.foldr (appendWord8 cfg) mempty $ T.encodeUtf8 t++lazyText t = JSON $ \cfg -> surround "\"" "\"" $+    L.foldr (appendWord8 cfg) mempty $ TL.encodeUtf8 t+#else++encodeString :: (BP.BoundedPrim Word8 -> a -> B.Builder) -> Bool -> a -> B.Builder+encodeString encodeUtf8BuilderEscaped html = \t ->+    B.char8 '"' <> encodeUtf8BuilderEscaped (escapeAscii html) t <> B.char8 '"'+{-# INLINABLE encodeString #-}+text t = JSON $ \cfg ->+    encodeString T.encodeUtf8BuilderEscaped (escapeHtml cfg) t++lazyText t = JSON $ \cfg ->+    encodeString TL.encodeUtf8BuilderEscaped (escapeHtml cfg) t+#endif++intersperse :: (F.Foldable f, Monoid m) => (a -> m) -> m -> f a -> m+intersperse f s a = F.foldr go (\n _ -> n) a mempty id+  where+    go i g = \_ j -> g (j $ f i) (\b -> j $ f i <> s <> b)+{-# INLINABLE intersperse #-}++surround :: B.Builder -> B.Builder -> B.Builder -> B.Builder+surround pre suf bdy = pre <> bdy <> suf+{-# INLINABLE surround #-}++unsafeObject' :: F.Foldable f => (k -> T.Text) -> (a -> JSON) -> f (k, a) -> JSON+unsafeObject' kf vf a = JSON $ \cfg ->+    surround curly brace $ intersperse (keyValue cfg) (B.char8 ',') a+  where+    curly = B.char8 '{'+    brace = B.char8 '}'+    colon = B.char8 ':'+    keyValue cfg (k, v) =+        unJSON (text $ kf k) cfg <> colon <> unJSON (vf v) cfg+{-# INLINABLE unsafeObject' #-}++object' :: F.Foldable f => (k -> T.Text) -> (a -> JSON) -> f (k, a) -> JSON+object' kf vf a = unsafeObject' id vf $+    F.foldr go (\_ out -> out) a Set.empty id []+  where+    go (k, v) g = \dict l ->+        if Set.member (kf k) dict+        then g dict l+        else g (Set.insert (kf k) dict) (l . ((kf k,v):))+{-# INLINABLE object' #-}++array' :: F.Foldable f => (a -> JSON) -> f a -> JSON+array' f a = JSON $ \cfg -> surround bra ket $+    intersperse (toBuilder cfg . f) (B.char8 ',') a+  where+    bra = B.char8 '['+    ket = B.char8 ']'+{-# INLINABLE array' #-}++-- | convert to json array+--+-- >>> array [integral 4, bool True]+-- "[4,true]"+array :: F.Foldable f => f JSON -> JSON+array = array' id+{-# INLINABLE array #-}++-- | O(nlogn) convert to object+--+-- prior value is prevailed.+--+-- You could use 'unsafeObject' when could ensure unique key.+--+-- >>> object [("foo", integral 12), ("bar", bool True), ("foo", text "ignored")]+-- "{\"foo\":12,\"bar\":true}"+object :: F.Foldable f => f (T.Text, JSON) -> JSON+object = object' id id+{-# INLINABLE object #-}++-- | O(n) unique key list to object+--+-- >>> unsafeObject [("foo", integral 12), ("bar", bool True), ("foo", text "INVALID")]+-- "{\"foo\":12,\"bar\":true,\"foo\":\"INVALID\"}"+unsafeObject :: F.Foldable f => f (T.Text, JSON) -> JSON+unsafeObject = unsafeObject' id id+{-# INLINABLE unsafeObject #-}
+ tests/doctest.hs view
@@ -0,0 +1,8 @@+import Test.DocTest+main :: IO ()+main = doctest+    [ "-isrc"+    , "-optP-include"+    , "-optPdist/build/autogen/cabal_macros.h"+    , "src/Text/Blaze/JSON.hs"+    ]
+ tests/tasty.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}++import Control.Monad++import Test.QuickCheck+import Test.Tasty+import Test.Tasty.QuickCheck++import qualified Data.Aeson as A+import Data.Scientific+import qualified Data.Text as T+import qualified Data.Vector as V+import qualified Data.HashMap.Strict as H++import qualified Text.Blaze.JSON as B++config :: B.EncodeConfig+#if MIN_VERSION_aeson(0,8,0)+config = B.def+#else+config = B.def { B.escapeHtml = True }+#endif+++fromAeson :: A.Value -> B.JSON+fromAeson (A.Object o) = B.object . map (fmap fromAeson) $ H.toList o+fromAeson (A.Array  a) = B.array $ fmap fromAeson a+fromAeson (A.String t) = B.text t+fromAeson (A.Number n) = either B.double B.integral (floatingOrInteger n :: Either Double Int)+fromAeson (A.Bool   b) = B.bool b+fromAeson A.Null       = B.null++text :: Gen T.Text+text = sized $ \n -> do+    k <- choose (0, n)+    s <- sequence+        [ oneof+            [ oneof $ map return "\\\""+            , oneof $ map return ['\0' .. '\x20']+            , toEnum `fmap` choose (0, 0xffff)+            ]+        | _ <- [1 .. k]+        ]+    return $ T.pack s++scolar :: Gen A.Value+scolar = oneof+     [ return A.Null+     , A.Bool `fmap` arbitrary+     , (A.Number . normalize . fromIntegral) `fmap` (arbitrary :: Gen Int)+     , (A.Number . normalize . fromFloatDigits) `fmap` (arbitrary :: Gen Double)+     , fmap A.String text+     ]++arbit :: Int -> Gen A.Value+arbit 0 = scolar+arbit d = oneof+    [ scolar+    , sized $ \l ->+        fmap (A.Array . V.fromList) $ vectorOf l (arbit $ d-1)+    , sized $ \l ->+        fmap (A.Object . H.fromList) $ vectorOf l ((,) `fmap` text `ap` arbit (d-1))+    ]++newtype Aeson = Aeson A.Value deriving Show++instance Arbitrary Aeson where+    arbitrary = Aeson `fmap` arbit 2++main :: IO ()+main = defaultMain $ testGroup ""+    [ testProperty "same to aeson" $ \(Aeson value) ->+        A.encode value === B.encodeWith config (fromAeson value)+    ]