diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,1 @@ +# 0.1.0.0 (2015-09-29) Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +# aeson-extra + +[![Build Status](https://travis-ci.org/phadej/aeson-extra.svg?branch=master)](https://travis-ci.org/phadej/aeson-extra) +[![Hackage](https://img.shields.io/hackage/v/aeson-extra.svg)](http://hackage.haskell.org/package/aeson-extra) + +The package motivation is twofold: + +- provide compatibility layer for [`aeson`](http://hackage.haskell.org/package/aeson) +- provide extra combinators diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/aeson-extra.cabal b/aeson-extra.cabal new file mode 100644 --- /dev/null +++ b/aeson-extra.cabal @@ -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-extra +version: 0.1.0.0 +synopsis: Extra goodies for aeson +description: The package motivation is twofold: + . + * provide compatibility layer for @aeson@ + * provide extra combinators +category: Web +homepage: https://github.com/phadej/aeson-extra#readme +bug-reports: https://github.com/phadej/aeson-extra/issues +author: Oleg Grenrus +maintainer: Oleg Grenrus +license: BSD3 +license-file: LICENSE +tested-with: GHC==7.8.4, GHC==7.10.2 +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-extra + +library + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >=4.7 && <4.9 + , ListLike >=4.2 && <4.3 + , aeson >=0.8 && <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 + , unordered-containers >=0.2 && <0.3 + , vector >=0.10 && <0.12 + exposed-modules: + Data.Aeson.Compat + Data.Aeson.Extra + default-language: Haskell2010 + +test-suite aeson-extra-test + type: exitcode-stdio-1.0 + main-is: Tests.hs + hs-source-dirs: + test + ghc-options: -Wall + build-depends: + base >=4.7 && <4.9 + , ListLike >=4.2 && <4.3 + , aeson >=0.8 && <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 + , unordered-containers >=0.2 && <0.3 + , vector >=0.10 && <0.12 + , aeson-extra + , tasty >=0.10 && <0.12 + , tasty-hunit >=0.9 && <0.10 + , tasty-quickcheck >=0.8 && <0.9 + , quickcheck-instances >=0.3 && <0.4 + default-language: Haskell2010 diff --git a/src/Data/Aeson/Compat.hs b/src/Data/Aeson/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Compat.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Aeson.Compat +-- Copyright : (C) 2015 Oleg Grenrus +-- License : BSD3 +-- Maintainer : Oleg Grenrus +-- +-- 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@ +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) + +-- | Exception thrown by 'throwDecode' - family of functions. +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.8 && <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 diff --git a/src/Data/Aeson/Extra.hs b/src/Data/Aeson/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Extra.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Aeson.Extra +-- Copyright : (C) 2015 Oleg Grenrus +-- License : BSD3 +-- Maintainer : Oleg Grenrus +-- +-- More or less useful newtypes for writing 'FromJSON' & 'ToJSON' instances +module Data.Aeson.Extra ( + -- * Generic maps + M(..), + FromJSONKey(..), + parseIntegralJSONKey, + FromJSONMap(..), + ToJSONKey(..), + ToJSONMap(..), + -- * Symbol tag + SymTag(..), + -- * Singleton object + SingObject(..), + mkSingObject, + getSingObject, + -- * CollapsedList + CollapsedList(..), + getCollapsedList, + parseCollapsedList, + -- * Re-exports + module Data.Aeson.Compat, + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +import Data.Foldable (Foldable) +import Data.Traversable (Traversable, traverse) +#endif + +import Data.Monoid +import Data.Aeson.Compat +import Data.Aeson.Types hiding ((.:?)) +import qualified Data.HashMap.Strict as H +import Data.Hashable (Hashable) +import Data.ListLike (ListLike) +import qualified Data.ListLike as ListLike +import qualified Data.Map as Map +import Data.Proxy +import Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Read as T +import GHC.TypeLits + +-- | A wrapper type to parse arbitrary maps +-- +-- > λ > decode "{\"1\": 1, \"2\": 2}" :: Maybe (M (H.HashMap Int Int)) +-- > Just (M {getMap = fromList [(1,1),(2,2)]}) +newtype M a = M { getMap :: a } + deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable) + +class FromJSONKey a where + parseJSONKey :: Text -> Parser a + +instance FromJSONKey Text where parseJSONKey = pure +instance FromJSONKey TL.Text where parseJSONKey = pure . TL.fromStrict +instance FromJSONKey String where parseJSONKey = pure . T.unpack +instance FromJSONKey Int where parseJSONKey = parseIntegralJSONKey +instance FromJSONKey Integer where parseJSONKey = parseIntegralJSONKey + +parseIntegralJSONKey :: Integral a => Text -> Parser a +parseIntegralJSONKey t = case (T.signed T.decimal) t of + Right (v, left) | T.null left -> pure v + | otherwise -> fail $ "Garbage left: " <> T.unpack left + Left err -> fail err + +class FromJSONMap m k v | m -> k v where + parseJSONMap :: H.HashMap Text Value -> Parser m + +instance (Eq k, Hashable k, FromJSONKey k, FromJSON v) => FromJSONMap (H.HashMap k v) k v where + parseJSONMap = fmap H.fromList . traverse f . H.toList + where f (k, v) = (,) <$> parseJSONKey k <*> parseJSON v + +instance (Ord k, FromJSONKey k, FromJSON v) => FromJSONMap (Map.Map k v) k v where + parseJSONMap = fmap Map.fromList . traverse f . H.toList + where f (k, v) = (,) <$> parseJSONKey k <*> parseJSON v + +instance (FromJSONMap m k v) => FromJSON (M m) where + parseJSON v = M <$> withObject "Map" parseJSONMap v + + +class ToJSONKey a where + toJSONKey :: a -> Text + +instance ToJSONKey Text where toJSONKey = id +instance ToJSONKey TL.Text where toJSONKey = TL.toStrict +instance ToJSONKey String where toJSONKey = T.pack +instance ToJSONKey Int where toJSONKey = T.pack . show +instance ToJSONKey Integer where toJSONKey = T.pack . show + +class ToJSONMap m k v | m -> k v where + toJSONMap :: m -> H.HashMap Text Value + +instance (ToJSONKey k, ToJSON v) => ToJSONMap (H.HashMap k v) k v where + toJSONMap = H.fromList . fmap f . H.toList + where f (k, v) = (toJSONKey k, toJSON v) + +instance (ToJSONKey k, ToJSON v) => ToJSONMap (Map.Map k v) k v where + toJSONMap = H.fromList . fmap f . Map.toList + where f (k, v) = (toJSONKey k, toJSON v) + +instance (ToJSONMap m k v) => ToJSON (M m) where + toJSON (M m) = Object (toJSONMap m) + +-- | Singleton string encoded and decoded as ifself. +-- +-- > λ> encode (Sym :: Sym "foobar") +-- > "\"foobar\"" +-- +-- > decode "\"foobar\"" :: Maybe (Sym "foobar") +-- > Just Sym +-- +-- > decode "\"foobar\"" :: Maybe (Sym "barfoo") +-- > Nothing +data SymTag (s :: Symbol) = SymTag + deriving (Eq, Ord, Show, Read, Enum, Bounded) + +instance KnownSymbol s => FromJSON (SymTag s) where + parseJSON (String t) + | T.unpack t == symbolVal (Proxy :: Proxy s) = pure SymTag + parseJSON v = typeMismatch ("Sym " ++ show (symbolVal (Proxy :: Proxy s))) v + +instance KnownSymbol s => ToJSON (SymTag s) where +#if MIN_VERSION_aeson (0,10,0) + toEncoding _ = toEncoding (symbolVal (Proxy :: Proxy s)) +#endif + toJSON _ = toJSON (symbolVal (Proxy :: Proxy s)) + + +-- | Singleton value object +-- +-- > λ > decode "{\"value\": 42 }" :: Maybe (SingObject "value" Int) +-- > Just (SingObject 42) +-- +-- > λ > encode (SingObject 42 :: SingObject "value" Int) +-- > "{\"value\":42}" +newtype SingObject (s ::Symbol) a = SingObject a + deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable) + +mkSingObject :: Proxy s -> a -> SingObject s a +mkSingObject _ = SingObject + +getSingObject :: Proxy s -> SingObject s a -> a +getSingObject _ (SingObject x) = x + +instance (KnownSymbol s, FromJSON a) => FromJSON (SingObject s a) where + parseJSON = withObject ("SingObject "<> show key) $ \obj -> + SingObject <$> obj .: T.pack key + where key = symbolVal (Proxy :: Proxy s) + +instance (KnownSymbol s, ToJSON a) => ToJSON (SingObject s a) where +#if MIN_VERSION_aeson(0,10,0) + toEncoding (SingObject x) = pairs (T.pack key .= x) + where key = symbolVal (Proxy :: Proxy s) +#endif + toJSON (SingObject x) = object [T.pack key .= x] + where key = symbolVal (Proxy :: Proxy s) + + +-- | Collapsed list, singleton is represented as the value itself in JSON encoding. +-- +-- > λ > decode "null" :: Maybe (CollapsedList [Int] Int) +-- > Just (CollapsedList []) +-- > λ > decode "42" :: Maybe (CollapsedList [Int] Int) +-- > Just (CollapsedList [42]) +-- > λ > decode "[1, 2, 3]" :: Maybe (CollapsedList [Int] Int) +-- > Just (CollapsedList [1,2,3]) +-- +-- > λ > encode (CollapsedList ([] :: [Int])) +-- > "null" +-- > λ > encode (CollapsedList ([42] :: [Int])) +-- > "42" +-- > λ > encode (CollapsedList ([1, 2, 3] :: [Int])) +-- > "[1,2,3]" +newtype CollapsedList full elem = CollapsedList full + deriving (Eq, Ord, Show, Read) + +getCollapsedList :: CollapsedList full elem -> full +getCollapsedList (CollapsedList l) = l + +instance (FromJSON elem, FromJSON full, ListLike full elem) => FromJSON (CollapsedList full elem) where + parseJSON Null = pure (CollapsedList ListLike.empty) + parseJSON v@(Array _) = CollapsedList <$> parseJSON v + parseJSON v = CollapsedList . ListLike.singleton <$> parseJSON v + +instance (ToJSON elem, ToJSON full, ListLike full elem) => ToJSON (CollapsedList full elem) where +#if MIN_VERSION_aeson (0,10,0) + toEncoding (CollapsedList l) + | ListLike.null l = toEncoding Null + | ListLike.null (ListLike.tail l) = toEncoding (ListLike.head l) + | otherwise = toEncoding l +#endif + toJSON (CollapsedList l) + | ListLike.null l = Null + | ListLike.null (ListLike.tail l) = toJSON (ListLike.head l) + | otherwise = toJSON l + +-- | Parses possibly collapsed array value from the object's field. +-- +-- > λ > newtype V = V [Int] deriving (Show) +-- > λ > instance FromJSON V where parseJSON = withObject "V" $ \obj -> V <$> collapsedList obj "value" +-- > λ > decode "{}" :: Maybe V +-- > Just (V []) +-- > λ > decode "{\"value\": null}" :: Maybe V +-- > Just (V []) +-- > λ > decode "{\"value\": 42}" :: Maybe V +-- > Just (V [42]) +-- > λ > decode "{\"value\": [1, 2, 3, 4]}" :: Maybe V +-- > Just (V [1,2,3,4]) +parseCollapsedList :: (FromJSON elem, FromJSON full, ListLike full elem) => Object -> Text -> Parser full +parseCollapsedList obj key = + case H.lookup key obj of + Nothing -> pure ListLike.empty +#if MIN_VERSION_aeson(0,10,0) + Just v -> modifyFailure addKeyName $ (getCollapsedList <$> parseJSON v) -- Key key + where + addKeyName = (("failed to parse field " <> T.unpack key <> ": ") <>) +#else + Just v -> getCollapsedList <$> parseJSON v +#endif diff --git a/test/Tests.hs b/test/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Tests.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +module Main (main) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative +#endif + +import Data.Aeson.Extra +import qualified Data.HashMap.Lazy as H +import Data.Map (Map) +import Data.Proxy +import Test.QuickCheck.Instances () +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +main :: IO () +main = defaultMain $ testGroup "Tests" + [ dotColonMark + , mTests + , symTests + , singObjectTests + , collapsedListTests + ] + +------------------------------------------------------------------------------ +-- M +------------------------------------------------------------------------------ + +mTests :: TestTree +mTests = testGroup "M" + [ testCase "decode" $ let lhs = decode "{\"1\": 1, \"2\": 2}" :: Maybe (M (H.HashMap Int Int)) + rhs = Just result + in lhs @?= rhs + , testProperty "decode . encode" $ + let prop :: Map Int Int -> Property + prop m = let lhs = fmap getMap . decode . encode . M $ m + rhs = Just m + in lhs === rhs + in prop + ] + where result = M $ H.fromList [(1,1),(2,2)] + +------------------------------------------------------------------------------ +-- SymTag +------------------------------------------------------------------------------ + +symTests :: TestTree +symTests = testGroup "SymTag" + [ testCase "encode" $ encode (SymTag :: SymTag "foobar") @?= "\"foobar\"" + , testCase "decode success" $ (decode "\"foobar\"" :: Maybe (SymTag "foobar")) @?= Just SymTag + , testCase "decode failure" $ (decode "\"foobar\"" :: Maybe (SymTag "barfoo")) @?= Nothing + ] + +------------------------------------------------------------------------------ +-- SingObject +------------------------------------------------------------------------------ + +-- > λ > decode "{\"value\": 42 }" :: Maybe (SingObject "value" Int) +-- > Just (SingObject 42) + +singObjectTests :: TestTree +singObjectTests = testGroup "SingObject" + [ testCase "decode success" $ (decode "{\"value\": 42 }" :: Maybe (SingObject "value" Int)) @?= Just (SingObject 42) + , testCase "decode failure" $ (decode "{\"value\": 42 }" :: Maybe (SingObject "key" Int)) @?= Nothing + , testProperty "decode . encode" $ + let prop :: Int -> Property + prop n = let rhs = fmap (getSingObject p) . decode . encode . mkSingObject p $ n + lhs = Just n + in lhs === rhs + p :: Proxy "value" + p = Proxy + in prop + ] + +------------------------------------------------------------------------------ +-- parseCollapsedList +------------------------------------------------------------------------------ + +newtype V = V [Int] deriving (Show, Eq) +instance FromJSON V where parseJSON = withObject "V" $ \obj -> V <$> parseCollapsedList obj "value" + +collapsedListTests :: TestTree +collapsedListTests = testGroup "collapsedList" + [ testCase "empty" $ (decode "{}" :: Maybe V) @?= Just (V []) + , testCase "null" $ (decode "{\"value\": null}" :: Maybe V) @?= Just (V []) + , testCase "singleton" $ (decode "{\"value\": 42}" :: Maybe V) @?= Just (V [42]) + , testCase "array" $ (decode "{\"value\": [1, 2, 3, 4]}" :: Maybe V) @?= Just (V [1,2,3,4]) + , testProperty "decode .encode " $ + let prop :: [Int] -> Property + prop l = let rhs = fmap getCollapsedList . decode . encode . CollapsedList $ l + lhs = Just l + in lhs === rhs + in prop + ] + +------------------------------------------------------------------------------ +-- 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 "-"