aeson-compat (empty) → 0.3.0.0
raw patch · 9 files changed
+539/−0 lines, 9 filesdep +aesondep +aeson-compatdep +attoparsecsetup-changed
Dependencies added: aeson, aeson-compat, attoparsec, base, bytestring, containers, exceptions, hashable, quickcheck-instances, scientific, tasty, tasty-hunit, tasty-quickcheck, text, time, unordered-containers, vector
Files
- CHANGELOG.md +3/−0
- LICENSE +30/−0
- README.md +8/−0
- Setup.hs +2/−0
- aeson-compat.cabal +77/−0
- src/Data/Aeson/Compat.hs +194/−0
- src/Data/Aeson/Compat/Time.hs +159/−0
- test/Orphans.hs +14/−0
- test/Tests.hs +52/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# 0.3.0.0++Split out `aeson-extra`
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Oleg Grenrus++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Oleg Grenrus nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT+OWNER 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.
+ README.md view
@@ -0,0 +1,8 @@+# aeson-compat++[](https://travis-ci.org/phadej/aeson-compat)+[](http://hackage.haskell.org/package/aeson-compat)+[](http://stackage.org/lts-3/package/aeson-compat)+[](http://stackage.org/nightly/package/aeson-compat)++The package provides compatibility layer for [`aeson`](http://hackage.haskell.org/package/aeson)
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ aeson-compat.cabal view
@@ -0,0 +1,77 @@+-- This file has been generated from package.yaml by hpack version 0.8.0.+--+-- see: https://github.com/sol/hpack++name: aeson-compat+version: 0.3.0.0+synopsis: Compatibility layer for aeson+description: Compatibility layer for @aeson@+category: Web+homepage: https://github.com/phadej/aeson-compat#readme+bug-reports: https://github.com/phadej/aeson-compat/issues+author: Oleg Grenrus <oleg.grenrus@iki.fi>+maintainer: Oleg Grenrus <oleg.grenrus@iki.fi>+license: BSD3+license-file: LICENSE+tested-with: GHC==7.6.3, GHC==7.8.4, GHC==7.10.3+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ CHANGELOG.md+ README.md++source-repository head+ type: git+ location: https://github.com/phadej/aeson-compat++library+ hs-source-dirs:+ src+ ghc-options: -Wall+ build-depends:+ base >=4.6 && <4.9+ , aeson >=0.7.0.6 && <0.11+ , attoparsec >=0.12 && <0.14+ , bytestring >=0.10 && <0.11+ , containers >=0.5 && <0.6+ , exceptions >=0.8 && <0.9+ , hashable >=1.2 && <1.3+ , scientific >=0.3 && <0.4+ , text >=1.2 && <1.3+ , time >=1.4.2 && <1.7+ , unordered-containers >=0.2 && <0.3+ , vector >=0.10 && <0.12+ exposed-modules:+ Data.Aeson.Compat+ other-modules:+ Data.Aeson.Compat.Time+ default-language: Haskell2010++test-suite aeson-compat-test+ type: exitcode-stdio-1.0+ main-is: Tests.hs+ hs-source-dirs:+ test+ ghc-options: -Wall+ build-depends:+ base >=4.6 && <4.9+ , aeson >=0.7.0.6 && <0.11+ , attoparsec >=0.12 && <0.14+ , bytestring >=0.10 && <0.11+ , containers >=0.5 && <0.6+ , exceptions >=0.8 && <0.9+ , hashable >=1.2 && <1.3+ , scientific >=0.3 && <0.4+ , text >=1.2 && <1.3+ , time >=1.4.2 && <1.7+ , unordered-containers >=0.2 && <0.3+ , vector >=0.10 && <0.12+ , aeson-compat+ , tasty >=0.10 && <0.12+ , tasty-hunit >=0.9 && <0.10+ , tasty-quickcheck >=0.8 && <0.9+ , quickcheck-instances >=0.3 && <0.4+ other-modules:+ Orphans+ default-language: Haskell2010
+ src/Data/Aeson/Compat.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-----------------------------------------------------------------------------+-- |+-- Module : Data.Aeson.Compat+-- Copyright : (C) 2015 Oleg Grenrus+-- License : BSD3+-- Maintainer : Oleg Grenrus <oleg.grenrus@iki.fi>+--+-- Compatibility notices+--+-- * 'decode' etc. work as in @aeson >=0.9@+-- * but it is generalised to work in any 'MonadThrow' (that is extra)+-- * '.:?' works as in @aeson <0.10@+-- * '.:!' works as '.:?' in @aeson ==0.10@+-- * Orphan instances 'FromJSON' 'Day' and 'FromJSON' 'LocalTime' for @aeson <0.10@+--+module Data.Aeson.Compat (+ -- * Generic decoding functions+ decode,+ decode',+ decodeStrict,+ decodeStrict',+ AesonException(..),+ -- * Either decoding functions+ eitherDecode, eitherDecode', eitherDecodeStrict, eitherDecodeStrict',+ -- * Operators+ (.:?), (.:!),+ -- * Re-exports+ -- | Original 'Data.Aeson..:?' operator is not re-exported+ module Data.Aeson,+ ) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++#if MIN_VERSION_aeson(0,10,0)+import Data.Monoid+#endif++import Data.Aeson hiding+ ((.:?), decode, decode', decodeStrict, decodeStrict'+#if !MIN_VERSION_aeson (0,9,0)+ , eitherDecode, eitherDecode', eitherDecodeStrict, eitherDecodeStrict'+#endif+ )++#if !MIN_VERSION_aeson (0,9,0)+import Data.Aeson.Parser (value, value')+import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.ByteString.Char8 as A (skipSpace)+import qualified Data.Attoparsec.Lazy as L+#endif++import Control.Monad.Catch+import Data.Aeson.Types hiding ((.:?))+import Data.ByteString as B+import Data.ByteString.Lazy as L+import qualified Data.HashMap.Strict as H+import Data.Text as T+import Data.Typeable (Typeable)++#if !MIN_VERSION_aeson(0,10,0)+import Data.Time (Day, LocalTime)+import qualified Data.Aeson.Compat.Time as CompatTime+#endif++-- | Exception thrown by 'decode' - family of functions in this module.+newtype AesonException = AesonException String+ deriving (Show, Typeable)++instance Exception AesonException++eitherAesonExc :: (MonadThrow m) => Either String a -> m a+eitherAesonExc (Left err) = throwM (AesonException err)+eitherAesonExc (Right x) = return x++-- | Like original 'Data.Aeson.decode' but in arbitrary 'MonadThrow'.+--+-- Parse a top-level JSON value, i.e. also strings, numbers etc.+decode :: (FromJSON a, MonadThrow m) => L.ByteString -> m a+decode = eitherAesonExc . eitherDecode++-- | Like original 'Data.Aeson.decode'' but in arbitrary 'MonadThrow'.+decode' :: (FromJSON a, MonadThrow m) => L.ByteString -> m a+decode' = eitherAesonExc . eitherDecode'++-- | Like original 'Data.Aeson.decodeStrict' but in arbitrary 'MonadThrow'.+decodeStrict :: (FromJSON a, MonadThrow m) => B.ByteString -> m a+decodeStrict = eitherAesonExc . eitherDecodeStrict++-- | Like original 'Data.Aeson.decodeStrict'' but in arbitrary 'MonadThrow'.+decodeStrict' :: (FromJSON a, MonadThrow m) => B.ByteString -> m a+decodeStrict' = eitherAesonExc . eitherDecodeStrict'++-- | Retrieve the value associated with the given key of an 'Object'.+-- The result is 'Nothing' if the key is not present, or 'empty' if+-- the value cannot be converted to the desired type.+--+-- This accessor is most useful if the key and value can be absent+-- from an object without affecting its validity. If the key and+-- value are mandatory, use '.:' instead.+--+-- This operator is consistent in @aeson >=0.7 && <0.11@+(.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)+obj .:? key = case H.lookup key obj of+ Nothing -> pure Nothing+ Just v ->+#if MIN_VERSION_aeson(0,10,0)+ modifyFailure addKeyName $ parseJSON v -- <?> Key key+ where+ addKeyName = (("failed to parse field " <> T.unpack key <> ": ") <>)+#else+ parseJSON v+#endif+{-# INLINE (.:?) #-}++-- | Like '.:?', but the resulting parser will fail,+-- if the key is present but is 'Null'.+(.:!) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)+obj .:! key = case H.lookup key obj of+ Nothing -> pure Nothing+ Just v ->+#if MIN_VERSION_aeson(0,10,0)+ modifyFailure addKeyName $ Just <$> parseJSON v -- <?> Key key+ where+ addKeyName = (("failed to parse field " <> T.unpack key <> ": ") <>)+#else+ Just <$> parseJSON v+#endif+{-# INLINE (.:!) #-}++#if !MIN_VERSION_aeson(0,9,0)+-- From Parser.Internal++-- | Parse a top-level JSON value followed by optional whitespace and+-- end-of-input. See also: 'json'.+jsonEOF :: A.Parser Value+jsonEOF = value <* A.skipSpace <* A.endOfInput++-- | Parse a top-level JSON value followed by optional whitespace and+-- end-of-input. See also: 'json''.+jsonEOF' :: A.Parser Value+jsonEOF' = value' <* A.skipSpace <* A.endOfInput++-- | Like 'decode' but returns an error message when decoding fails.+eitherDecode :: (FromJSON a) => L.ByteString -> Either String a+eitherDecode = eitherDecodeWith jsonEOF fromJSON+{-# INLINE eitherDecode #-}++-- | Like 'decodeStrict' but returns an error message when decoding fails.+eitherDecodeStrict :: (FromJSON a) => B.ByteString -> Either String a+eitherDecodeStrict = eitherDecodeStrictWith jsonEOF fromJSON+{-# INLINE eitherDecodeStrict #-}++-- | Like 'decode'' but returns an error message when decoding fails.+eitherDecode' :: (FromJSON a) => L.ByteString -> Either String a+eitherDecode' = eitherDecodeWith jsonEOF' fromJSON+{-# INLINE eitherDecode' #-}++-- | Like 'decodeStrict'' but returns an error message when decoding fails.+eitherDecodeStrict' :: (FromJSON a) => B.ByteString -> Either String a+eitherDecodeStrict' = eitherDecodeStrictWith jsonEOF' fromJSON+{-# INLINE eitherDecodeStrict' #-}++eitherDecodeWith :: L.Parser Value -> (Value -> Result a) -> L.ByteString+ -> Either String a+eitherDecodeWith p to s =+ case L.parse p s of+ L.Done _ v -> case to v of+ Success a -> Right a+ Error msg -> Left msg+ L.Fail _ _ msg -> Left msg+{-# INLINE eitherDecodeWith #-}++eitherDecodeStrictWith :: A.Parser Value -> (Value -> Result a) -> B.ByteString+ -> Either String a+eitherDecodeStrictWith p to s =+ case either Error to (A.parseOnly p s) of+ Success a -> Right a+ Error msg -> Left msg+{-# INLINE eitherDecodeStrictWith #-}++#endif++#if !MIN_VERSION_aeson(0,10,0)+instance FromJSON Day where+ parseJSON = withText "Day" (CompatTime.run CompatTime.day)++instance FromJSON LocalTime where+ parseJSON = withText "LocalTime" (CompatTime.run CompatTime.localTime)+#endif
+ src/Data/Aeson/Compat/Time.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}++-- |+-- Module: Data.Aeson.Compat.Time (Data.Aeson.Parser.Time)+-- Copyright: (c) 2015 Bryan O'Sullivan+-- License: Apache+-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>+-- Stability: experimental+-- Portability: portable+--+-- Parsers for parsing dates and times.++module Data.Aeson.Compat.Time+ (+ run+ , day+ , localTime+ , timeOfDay+ , timeZone+ , utcTime+ , zonedTime+ ) where++import Control.Monad (when, void)+import Data.Attoparsec.Text as A+import Data.Bits ((.&.))+import Data.Char (isDigit, ord)+import Data.Fixed (Pico)+import Data.Int (Int64)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Time.Calendar (Day, fromGregorianValid)+import Data.Time.Clock (UTCTime(..))+import qualified Data.Aeson.Types as Aeson+import qualified Data.Text as T+import qualified Data.Time.LocalTime as Local++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*>), (<*), (*>))+#endif++-- from Data.Aeson.Internal.Time+import Unsafe.Coerce (unsafeCoerce)++toPico :: Integer -> Pico+toPico = unsafeCoerce++-- | Run an attoparsec parser as an aeson parser.+run :: Parser a -> Text -> Aeson.Parser a+run p t = case A.parseOnly (p <* endOfInput) t of+ Left err -> fail $ "could not parse date: " ++ err+ Right r -> return r++-- | Parse a date of the form @YYYY-MM-DD@.+day :: Parser Day+day = do+ y <- decimal <* char '-'+ m <- twoDigits <* char '-'+ d <- twoDigits+ maybe (fail "invalid date") return (fromGregorianValid y m d)++-- | Parse a two-digit integer (e.g. day of month, hour).+twoDigits :: Parser Int+twoDigits = do+ a <- digit+ b <- digit+ let c2d c = ord c .&. 15+ return $! c2d a * 10 + c2d b++-- | Parse a time of the form @HH:MM:SS[.SSS]@.+timeOfDay :: Parser Local.TimeOfDay+timeOfDay = do+ h <- twoDigits <* char ':'+ m <- twoDigits <* char ':'+ s <- seconds+ if h < 24 && m < 60 && s < 61+ then return (Local.TimeOfDay h m s)+ else fail "invalid time"++data T = T {-# UNPACK #-} !Int {-# UNPACK #-} !Int64++-- | Parse a count of seconds, with the integer part being two digits+-- long.+seconds :: Parser Pico+seconds = do+ real <- twoDigits+ mc <- peekChar+ case mc of+ Just '.' -> do+ t <- anyChar *> takeWhile1 isDigit+ return $! parsePicos real t+ _ -> return $! fromIntegral real+ where+ parsePicos a0 t = toPico (fromIntegral (t' * 10^n))+ where T n t' = T.foldl' step (T 12 (fromIntegral a0)) t+ step ma@(T m a) c+ | m <= 0 = ma+ | otherwise = T (m-1) (10 * a + fromIntegral (ord c) .&. 15)++-- | Parse a time zone, and return 'Nothing' if the offset from UTC is+-- zero. (This makes some speedups possible.)+timeZone :: Parser (Maybe Local.TimeZone)+timeZone = do+ let maybeSkip c = do ch <- peekChar'; when (ch == c) (void anyChar)+ maybeSkip ' '+ ch <- satisfy $ \c -> c == 'Z' || c == '+' || c == '-'+ if ch == 'Z'+ then return Nothing+ else do+ h <- twoDigits+ mm <- peekChar+ m <- case mm of+ Just ':' -> anyChar *> twoDigits+ Just d | isDigit d -> twoDigits+ _ -> return 0+ let off | ch == '-' = negate off0+ | otherwise = off0+ off0 = h * 60 + m+ case undefined of+ _ | off == 0 ->+ return Nothing+ | off < -720 || off > 840 || m > 59 ->+ fail "invalid time zone offset"+ | otherwise ->+ let !tz = Local.minutesToTimeZone off+ in return (Just tz)++-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@.+-- The space may be replaced with a @T@. The number of seconds may be+-- followed by a fractional component.+localTime :: Parser Local.LocalTime+localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay+ where daySep = satisfy (\c -> c == 'T' || c == ' ')++-- | Behaves as 'zonedTime', but converts any time zone offset into a+-- UTC time.+utcTime :: Parser UTCTime+utcTime = do+ lt@(Local.LocalTime d t) <- localTime+ mtz <- timeZone+ case mtz of+ Nothing -> let !tt = Local.timeOfDayToTime t+ in return (UTCTime d tt)+ Just tz -> return $! Local.localTimeToUTC tz lt++-- | Parse a date with time zone info. Acceptable formats:+--+-- @YYYY-MM-DD HH:MM:SS Z@+--+-- The first space may instead be a @T@, and the second space is+-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a+-- time zone offset of the form @+0000@ or @-08:00@, where the first+-- two digits are hours, the @:@ is optional and the second two digits+-- (also optional) are minutes.+zonedTime :: Parser Local.ZonedTime+zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)++utc :: Local.TimeZone+utc = Local.TimeZone 0 False ""
+ test/Orphans.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Orphans where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++import Data.Vector as V+import Test.Tasty.QuickCheck++instance Arbitrary a => Arbitrary (Vector a) where+ arbitrary = V.fromList <$> arbitrary+ shrink = fmap V.fromList . shrink . V.toList
+ test/Tests.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++import Test.QuickCheck.Instances ()+import Test.Tasty+import Test.Tasty.HUnit++import Data.Aeson.Compat++import Orphans ()++main :: IO ()+main = defaultMain $ testGroup "Tests"+ [ dotColonMark+ ]++------------------------------------------------------------------------------+-- Comparison (.:?) and (.:!)+------------------------------------------------------------------------------++newtype T1 = T1 (Maybe Int) deriving (Eq, Show)+newtype T2 = T2 (Maybe Int) deriving (Eq, Show)+newtype T3 = T3 (Maybe Int) deriving (Eq, Show)++instance FromJSON T1 where parseJSON = fmap T1 . withObject "T1" (.: "value")+instance FromJSON T2 where parseJSON = fmap T2 . withObject "T2" (.:? "value")+instance FromJSON T3 where parseJSON = fmap T3 . withObject "T3" (.:! "value")++dotColonMark :: TestTree+dotColonMark = testGroup "Operators" $ fmap t [+ assertEqual ".: not-present" Nothing (decode ex1 :: Maybe T1)+ , assertEqual ".: 42" (Just (T1 (Just 42))) (decode ex2 :: Maybe T1)+ , assertEqual ".: null" (Just (T1 Nothing)) (decode ex3 :: Maybe T1)++ , assertEqual ".:? not-present" (Just (T2 (Nothing))) (decode ex1 :: Maybe T2)+ , assertEqual ".:? 42" (Just (T2 (Just 42))) (decode ex2 :: Maybe T2)+ , assertEqual ".:? null" (Just (T2 Nothing)) (decode ex3 :: Maybe T2)++ , assertEqual ".:! not-present" (Just (T3 (Nothing))) (decode ex1 :: Maybe T3)+ , assertEqual ".:! 42" (Just (T3 (Just 42))) (decode ex2 :: Maybe T3)+ , assertEqual ".:! null" Nothing (decode ex3 :: Maybe T3)+ ]+ where ex1 = "{}"+ ex2 = "{\"value\": 42 }"+ ex3 = "{\"value\": null }"+ t = testCase "-"+