Bryan O'Sullivan avatar Bryan O'Sullivan committed 7a5f020

Initial commit

Comments (0)

Files changed (7)

+^dist$
+benchmarks/Arse
+benchmarks/med.txt
+benchmarks/tiny
+
+syntax: glob
+*.aux
+*.hi
+*.hp
+*.o
+*.orig
+*.out
+*.pdf
+*.prof
+*.ps
+*.rej
+*~
+.*.swp
+.\#*
+\#*
+module Data.Aeson
+    (
+      Array
+    , Object
+    , Value(..)
+    , JSON(..)
+    , (.=)
+    , (.:)
+    , object
+    ) where
+
+import Data.Aeson.Types

Data/Aeson/Parser.hs

+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.Aeson.Parser
+    (
+      json
+    ) where
+
+import Control.Applicative as A
+import Data.Attoparsec.Char8
+import Data.Aeson.Types (Value(..))
+import Data.Aeson.Parser.Internal (array, object)
+
+json :: Parser Value
+json = do
+  skipSpace
+  c <- anyChar
+  case c of
+    '{' -> skipSpace *> object
+    '[' -> skipSpace *> array
+    _   -> fail "root value is not an object or array"

Data/Aeson/Parser/Internal.hs

+{-# LANGUAGE OverloadedStrings #-}
+
+module Data.Aeson.Parser.Internal
+    (
+      value
+    , object
+    , array
+    ) where
+
+import Control.Applicative as A
+import Data.Attoparsec.Char8
+import Data.Bits (shiftL)
+import Data.ByteString as B
+import Data.Char (chr)
+import Data.Map as Map
+import Data.Text as T
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import Data.Vector as Vector hiding ((++))
+import Data.Word (Word8)
+import qualified Data.Attoparsec as A
+import Data.Aeson.Types (Value(..))
+
+object :: Parser Value
+object = do
+  let pair = liftA2 (,) (jstring <* skipSpace) (char8 ':' *> skipSpace *> value)
+  vals <- (pair <* skipSpace) `sepBy` (char8 ',' *> skipSpace)
+  _ <- char8 '}'
+  return . Object $ Map.fromList vals
+
+array :: Parser Value
+array = do
+  vals <- (value <* skipSpace) `sepBy` (char8 ',' *> skipSpace)
+  _ <- char8 ']'
+  return . Array $ Vector.fromList vals
+
+value :: Parser Value
+value = most <|> (Number <$> double)
+ where
+  most = do
+    c <- anyChar
+    case c of
+      '{' -> skipSpace *> object
+      '[' -> skipSpace *> array
+      '"' -> String <$> jstring_
+      'f' -> string "alse" *> pure (Bool False)
+      't' -> string "rue" *> pure (Bool True)
+      'n' -> string "ull" *> pure Null
+      _   -> A.empty
+
+doubleQuote :: Word8
+doubleQuote = 34
+
+jstring :: Parser Text
+jstring = A.word8 doubleQuote *> jstring_
+
+-- | Parse a string without a leading quote.
+jstring_ :: Parser Text
+jstring_ = do
+  let backslash = 92
+  s <- A.scan False $ \s c -> if s then Just False
+                                   else if c == doubleQuote
+                                        then Nothing
+                                        else Just (c == backslash)
+  _ <- A.word8 doubleQuote
+  (decodeUtf8 . B.concat) <$> reparse unescape s
+
+reparse :: Parser a -> ByteString -> Parser a
+reparse p s = case (case parse p s of {Partial k -> k ""; r -> r}) of
+                Done "" r    -> return r
+                Fail _ _ msg -> fail msg
+                _            -> fail "unexpected failure"
+
+unescape :: Parser [ByteString]
+unescape = do
+  let backslash = 92
+  h <- A.takeWhile (/=backslash)
+  let rest = do
+        w <- A.word8 backslash *> A.satisfy (`B.elem` "\"\\/ntbrfu")
+        case B.findIndex (==w) "\"\\/ntbrf" of
+          Just i ->
+               ([h,B.singleton $ B.index "\"\\/\n\t\b\r\f" i]++) <$> unescape
+          Nothing -> do
+               a <- reparse hexadecimal =<< A.take 4
+               if a < 0xd800 || a > 0xdfff
+                 then ([h,encodeUtf8 . T.singleton . chr $ a]++) <$> unescape
+                 else do
+                   _ <- string "\\u"
+                   b <- reparse hexadecimal =<< A.take 4
+                   if a <= 0xdbff && b >= 0xdc00 && b <= 0xdfff
+                     then do
+                       let c = ((a - 0xd800) `shiftL` 10) + (b - 0xdc00) +
+                               0x10000
+                       ([h,encodeUtf8 . T.singleton . chr $ c]++) <$> unescape
+                     else fail "invalid UTF-16 surrogates"
+  rest <|> return [h]

Data/Aeson/Types.hs

+module Data.Aeson.Types
+    (
+      Array
+    , Object
+    , (.=)
+    , (.:)
+    , object
+    , Value(..)
+    , JSON(..)
+    ) where
+
+import Control.Applicative
+import Data.ByteString (ByteString)
+import Data.Map (Map)
+import Data.Text (Text, pack, unpack)
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import Data.Time.Clock (UTCTime)
+import Data.Time.Format (formatTime, parseTime)
+import Data.Vector (Vector)
+import System.Locale (defaultTimeLocale)
+import qualified Data.Map as M
+import qualified Data.Vector as V
+
+type Object = Map Text Value
+type Array = Vector Value
+
+data Value = Object Object
+           | Array Array
+           | String Text
+           | Number Double
+           | Bool !Bool
+           | Null
+             deriving (Eq, Show)
+
+(.=) :: JSON a => Text -> a -> Object
+name .= value = M.singleton name (toJSON value)
+{-# INLINE (.=) #-}
+
+(.:) :: (Alternative f, JSON a) => Object -> Text -> f a
+obj .: key = case M.lookup key obj of
+               Nothing -> empty
+               Just v  -> fromJSON v
+{-# INLINE (.:) #-}
+
+object :: [Object] -> Value
+object = Object . M.unions
+{-# INLINE object #-}
+
+class JSON a where
+    toJSON   :: a -> Value
+    fromJSON :: Alternative f => Value -> f a
+
+instance (JSON a) => JSON (Maybe a) where
+    toJSON (Just a) = toJSON a
+    toJSON Nothing  = Null
+    {-# INLINE toJSON #-}
+    
+    fromJSON Null   = pure Nothing
+    fromJSON a      = Just <$> fromJSON a
+    {-# INLINE fromJSON #-}
+
+instance JSON Bool where
+    toJSON = Bool
+    {-# INLINE toJSON #-}
+
+    fromJSON (Bool b) = pure b
+    fromJSON _        = empty
+    {-# INLINE fromJSON #-}
+
+instance JSON Double where
+    toJSON = Number
+    {-# INLINE toJSON #-}
+
+    fromJSON (Number n) = pure n
+    fromJSON _          = empty
+    {-# INLINE fromJSON #-}
+
+instance JSON Int where
+    toJSON = Number . fromIntegral
+    {-# INLINE toJSON #-}
+
+    fromJSON (Number n) = pure (floor n)
+    fromJSON _          = empty
+    {-# INLINE fromJSON #-}
+
+instance JSON Text where
+    toJSON = String
+    {-# INLINE toJSON #-}
+
+    fromJSON (String t) = pure t
+    fromJSON _          = empty
+    {-# INLINE fromJSON #-}
+
+instance JSON ByteString where
+    toJSON = String . decodeUtf8
+
+    fromJSON (String t) = pure (encodeUtf8 t)
+    fromJSON _          = empty
+
+mapA :: (Applicative f) => (t -> f a) -> [t] -> f [a]
+mapA f = go
+  where
+    go (a:as) = (:) <$> f a <*> go as
+    go []     = pure []
+
+instance (JSON a) => JSON [a] where
+    toJSON = Array . V.fromList . map toJSON
+    {-# INLINE toJSON #-}
+    
+    fromJSON (Array a) = mapA fromJSON (V.toList a)
+    fromJSON _         = empty
+    {-# INLINE fromJSON #-}
+
+instance (JSON a) => JSON (Vector a) where
+    toJSON = Array . V.map toJSON
+    {-# INLINE toJSON #-}
+    
+    fromJSON (Array a) = V.fromList <$> mapA fromJSON (V.toList a)
+    fromJSON _         = empty
+    {-# INLINE fromJSON #-}
+
+instance JSON Value where
+    toJSON a = a
+    {-# INLINE toJSON #-}
+
+    fromJSON a = pure a
+    {-# INLINE fromJSON #-}
+
+-- We happen to use the same JSON formatting for a UTCTime as .NET
+-- does for a DateTime. How handy!
+instance JSON UTCTime where
+    toJSON t = String (pack (formatTime defaultTimeLocale "/Date(%s)/" t))
+    {-# INLINE toJSON #-}
+
+    fromJSON (String t) =
+        case parseTime defaultTimeLocale "/Date(%s)/" (unpack t) of
+          Just d -> pure d
+          _      -> empty
+    fromJSON _          = empty
+    {-# INLINE fromJSON #-}
+
+instance (JSON a, JSON b) => JSON (a,b) where
+    toJSON (a,b) = toJSON [toJSON a, toJSON b]
+    {-# INLINE toJSON #-}
+
+    fromJSON (Array ab) = case V.toList ab of
+                            [a,b] -> (,) <$> fromJSON a <*> fromJSON b
+                            _     -> empty
+    fromJSON _          = empty
+    {-# INLINE fromJSON #-}
+
+
+
+
+
+
+
+
+
+
+Copyright (c) 2011, MailRank, Inc.
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+
+3. Neither the name of the author nor the names of his contributors
+   may be used to endorse or promote products derived from this software
+   without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+name:            aeson
+version:         0.0.0.0
+license:         BSD3
+license-file:    LICENSE
+category:        Text, Web, JSON
+copyright:       Copyright 2011 MailRank, Inc.
+author:          Bryan O'Sullivan <bos@mailrank.com>
+maintainer:      Bryan O'Sullivan <bos@mailrank.com>
+stability:       experimental
+tested-with:     GHC == 6.12.3
+synopsis:        Fast JSON parsing and generation
+cabal-version:   >= 1.8
+homepage:        http://github.com/mailrank/aeson
+bug-reports:     http://github.com/mailrank/aeson/issues
+build-type:      Simple
+description:
+    A fast JSON parsing and generation library.
+extra-source-files:
+    README.markdown
+
+flag developer
+  description: operate in developer mode
+  default: False
+
+library
+  exposed-modules:
+    Data.Aeson
+    Data.Aeson.Parser
+    Data.Aeson.Parser.Internal
+    Data.Aeson.Types
+
+  build-depends:
+    attoparsec >= 0.8.4.0,
+    base == 4.*,
+    bytestring,
+    containers == 0.3.*,
+    old-locale,
+    text >= 0.11.0.0,
+    time,
+    vector >= 0.7
+
+  if flag(developer)
+    ghc-options: -Werror
+
+  ghc-options:      -Wall
+  ghc-prof-options: -auto-all
+
+source-repository head
+  type:     git
+  location: http://github.com/mailrank/aeson
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.