Hello community, here is the log from the commit of package ghc-aeson-extra for openSUSE:Factory checked in at 2016-02-09 13:31:51 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-aeson-extra (Old) and /work/SRC/openSUSE:Factory/.ghc-aeson-extra.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-aeson-extra" Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-aeson-extra/ghc-aeson-extra.changes 2016-01-28 17:25:05.000000000 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-aeson-extra.new/ghc-aeson-extra.changes 2016-02-09 13:31:53.000000000 +0100 @@ -1,0 +2,9 @@ +Fri Jan 29 12:11:32 UTC 2016 - [email protected] + +- update to 0.3.1.0 +* Support quickcheck-instances >=0.3.12 +* Add Data.Aeson.Extra.TH +* Add Data.Aeson.Extra.Foldable +* Add Data.Aeson.Extra.Merge + +------------------------------------------------------------------- Old: ---- aeson-extra-0.3.0.0.tar.gz New: ---- aeson-extra-0.3.1.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-aeson-extra.spec ++++++ --- /var/tmp/diff_new_pack.HX4JOn/_old 2016-02-09 13:31:53.000000000 +0100 +++ /var/tmp/diff_new_pack.HX4JOn/_new 2016-02-09 13:31:53.000000000 +0100 @@ -21,7 +21,7 @@ %bcond_with tests Name: ghc-aeson-extra -Version: 0.3.0.0 +Version: 0.3.1.0 Release: 0 Summary: Extra goodies for aeson License: BSD-3-Clause @@ -42,6 +42,7 @@ BuildRequires: ghc-exceptions-devel BuildRequires: ghc-hashable-devel BuildRequires: ghc-parsec-devel +BuildRequires: ghc-recursion-schemes-devel BuildRequires: ghc-scientific-devel BuildRequires: ghc-template-haskell-devel BuildRequires: ghc-text-devel @@ -79,7 +80,6 @@ %prep %setup -q -n %{pkg_name}-%{version} -cabal-tweak-dep-ver base-compat '<0.9' '<0.10' %build %ghc_lib_build ++++++ aeson-extra-0.3.0.0.tar.gz -> aeson-extra-0.3.1.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/aeson-extra-0.3.0.0/CHANGELOG.md new/aeson-extra-0.3.1.0/CHANGELOG.md --- old/aeson-extra-0.3.0.0/CHANGELOG.md 2015-12-25 18:51:00.000000000 +0100 +++ new/aeson-extra-0.3.1.0/CHANGELOG.md 2016-01-27 19:08:46.000000000 +0100 @@ -1,3 +1,13 @@ +# 0.3.1.0 (2015-12-27) + +- Add `Data.Aeson.Extra.TH` +- Add `Data.Aeson.Extra.Foldable` +- Add `Data.Aeson.Extra.Merge` + +# 0.3.0.1 (2016-01-26) + +- Support `quickcheck-instances >=0.3.12` + # 0.3.0.0 (2015-12-25) - `Data.Time.TH` moved to [`time-parsers`](http://hackage.haskell.org/package/time-parsers) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/aeson-extra-0.3.0.0/aeson-extra.cabal new/aeson-extra-0.3.1.0/aeson-extra.cabal --- old/aeson-extra-0.3.0.0/aeson-extra.cabal 2015-12-25 18:57:25.000000000 +0100 +++ new/aeson-extra-0.3.1.0/aeson-extra.cabal 2016-01-27 19:10:36.000000000 +0100 @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: aeson-extra -version: 0.3.0.0 +version: 0.3.1.0 synopsis: Extra goodies for aeson description: Package provides extra funcitonality on top of @aeson@ and @aeson-compat@ category: Web @@ -31,14 +31,15 @@ ghc-options: -Wall build-depends: base >=4.6 && <4.9 - , base-compat >=0.6.0 && <0.9 , aeson >=0.7.0.6 && <0.11 , aeson-compat >=0.3.0.0 && <0.4 + , base-compat >=0.6.0 && <0.10 , bytestring >=0.10 && <0.11 , containers >=0.5 && <0.6 , exceptions >=0.8 && <0.9 , hashable >=1.2 && <1.3 , parsec >=3.1.9 && <3.2 + , recursion-schemes >=4.1.2 && <4.2 , scientific >=0.3 && <0.4 , template-haskell >=2.8 && <2.11 , text >=1.2 && <1.3 @@ -46,8 +47,21 @@ , time-parsers >=0.1.0.0 && <0.2 , unordered-containers >=0.2 && <0.3 , vector >=0.10 && <0.12 + , transformers >=0.3 && <0.6 exposed-modules: Data.Aeson.Extra + Data.Aeson.Extra.CollapsedList + Data.Aeson.Extra.Foldable + Data.Aeson.Extra.Map + Data.Aeson.Extra.Merge + Data.Aeson.Extra.Time + Data.Aeson.Extra.TH + + if impl(ghc >= 7.8) + exposed-modules: + Data.Aeson.Extra.SingObject + Data.Aeson.Extra.SymTag + default-language: Haskell2010 test-suite aeson-extra-test @@ -58,9 +72,9 @@ ghc-options: -Wall build-depends: base >=4.6 && <4.9 - , base-compat >=0.6.0 && <0.9 , aeson >=0.7.0.6 && <0.11 , aeson-compat >=0.3.0.0 && <0.4 + , base-compat >=0.6.0 && <0.10 , bytestring >=0.10 && <0.11 , containers >=0.5 && <0.6 , exceptions >=0.8 && <0.9 @@ -69,6 +83,7 @@ , scientific >=0.3 && <0.4 , template-haskell >=2.8 && <2.11 , text >=1.2 && <1.3 + , these >=0.6.2.0 && <0.7 , time >=1.4.2 && <1.7 , time-parsers >=0.1.0.0 && <0.2 , unordered-containers >=0.2 && <0.3 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/aeson-extra-0.3.0.0/src/Data/Aeson/Extra/CollapsedList.hs new/aeson-extra-0.3.1.0/src/Data/Aeson/Extra/CollapsedList.hs --- old/aeson-extra-0.3.0.0/src/Data/Aeson/Extra/CollapsedList.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/aeson-extra-0.3.1.0/src/Data/Aeson/Extra/CollapsedList.hs 2016-01-27 19:08:46.000000000 +0100 @@ -0,0 +1,107 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Aeson.Extra.CollapsedList +-- Copyright : (C) 2015-2016 Oleg Grenrus +-- License : BSD3 +-- Maintainer : Oleg Grenrus <[email protected]> +-- +module Data.Aeson.Extra.CollapsedList ( + CollapsedList(..), + getCollapsedList, + parseCollapsedList, + )where + +import Prelude () +import Prelude.Compat + +import Control.Applicative (Alternative(..)) +import Data.Aeson.Compat +import Data.Aeson.Types hiding ((.:?)) +import Data.Text (Text) + +#if __GLASGOW_HASKELL__ >= 708 +import Data.Typeable (Typeable) +#endif + +import qualified Data.Foldable as Foldable +import qualified Data.HashMap.Strict as H + +#if MIN_VERSION_aeson(0,10,0) +import qualified Data.Text as T +#endif + +-- | 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]" +-- +-- Documentation rely on @f@ 'Alternative' instance behaving like lists'. +newtype CollapsedList f a = CollapsedList (f a) + deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable +#if __GLASGOW_HASKELL__ >= 708 + , Typeable +#endif + ) + +getCollapsedList :: CollapsedList f a -> f a +getCollapsedList (CollapsedList l) = l + +instance (FromJSON a, FromJSON (f a), Alternative f) => FromJSON (CollapsedList f a) where + parseJSON Null = pure (CollapsedList Control.Applicative.empty) + parseJSON v@(Array _) = CollapsedList <$> parseJSON v + parseJSON v = CollapsedList . pure <$> parseJSON v + +instance (ToJSON a, ToJSON (f a), Foldable f) => ToJSON (CollapsedList f a) where +#if MIN_VERSION_aeson (0,10,0) + toEncoding (CollapsedList l) = + case Foldable.toList l of + [] -> toEncoding Null + [x] -> toEncoding x + _ -> toEncoding l +#endif + toJSON (CollapsedList l) = + case Foldable.toList l of + [] -> toJSON Null + [x] -> toJSON x + _ -> 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 <$> parseCollapsedList 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 a, FromJSON (f a), Alternative f) => Object -> Text -> Parser (f a) +parseCollapsedList obj key = + case H.lookup key obj of + Nothing -> pure Control.Applicative.empty +#if MIN_VERSION_aeson(0,10,0) + Just v -> modifyFailure addKeyName $ (getCollapsedList <$> parseJSON v) -- <?> Key key + where + addKeyName = (mappend ("failed to parse field " `mappend` T.unpack key `mappend`": ")) +#else + Just v -> getCollapsedList <$> parseJSON v +#endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/aeson-extra-0.3.0.0/src/Data/Aeson/Extra/Foldable.hs new/aeson-extra-0.3.1.0/src/Data/Aeson/Extra/Foldable.hs --- old/aeson-extra-0.3.0.0/src/Data/Aeson/Extra/Foldable.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/aeson-extra-0.3.1.0/src/Data/Aeson/Extra/Foldable.hs 2016-01-27 19:08:46.000000000 +0100 @@ -0,0 +1,77 @@ +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, TypeFamilies, DeriveFoldable, DeriveTraversable #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Aeson.Extra.Foldable +-- Copyright : (C) 2015-2016 Oleg Grenrus +-- License : BSD3 +-- Maintainer : Oleg Grenrus <[email protected]> +-- +-- Helps writing recursive algorithms on 'Value', for example: +-- +-- @ +-- stripNulls :: Value -> Value +-- stripNulls = 'cata' ('embed' . f) +-- where +-- f (ObjectF a) = ObjectF $ HM.filter (== Null) a +-- f x = x +-- @ +module Data.Aeson.Extra.Foldable ( + ValueF(..), + ObjectF, + ArrayF, + ) where + +import Prelude () +import Prelude.Compat + +import Data.Aeson.Compat +import Data.Functor.Foldable +import Data.HashMap.Strict (HashMap) +import Data.Data (Data) +import Data.Text (Text) +import Data.Scientific (Scientific) +import Data.Typeable (Typeable) +import Data.Vector (Vector) + +import qualified Data.Functor.Foldable as F + +-- | A JSON \"object\" (key\/value map). +-- +-- /Since: aeson-extra-0.3.1.0/ +type ObjectF a = HashMap Text a + +-- | A JSON \"array\" (sequence). +-- +-- /Since: aeson-extra-0.3.1.0/ +type ArrayF a = Vector a + +-- | An algebra of 'Value' +-- +-- /Since: aeson-extra-0.3.1.0/ +data ValueF a + = ObjectF (ObjectF a) + | ArrayF !(ArrayF a) + | StringF !Text + | NumberF !Scientific + | BoolF !Bool + | NullF + deriving (Eq, Read, Show, Typeable, Data, Functor, Prelude.Compat.Foldable, Traversable) + +type instance Base Value = ValueF + +instance F.Foldable Value where + project (Object o) = ObjectF o + project (Array a) = ArrayF a + project (String s) = StringF s + project (Number n) = NumberF n + project (Bool b) = BoolF b + project Null = NullF + +instance F.Unfoldable Value where + embed (ObjectF o) = Object o + embed (ArrayF a) = Array a + embed (StringF s) = String s + embed (NumberF n) = Number n + embed (BoolF b) = Bool b + embed NullF = Null diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/aeson-extra-0.3.0.0/src/Data/Aeson/Extra/Map.hs new/aeson-extra-0.3.1.0/src/Data/Aeson/Extra/Map.hs --- old/aeson-extra-0.3.0.0/src/Data/Aeson/Extra/Map.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/aeson-extra-0.3.1.0/src/Data/Aeson/Extra/Map.hs 2016-01-27 19:08:46.000000000 +0100 @@ -0,0 +1,99 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Aeson.Extra.Map +-- Copyright : (C) 2015-2016 Oleg Grenrus +-- License : BSD3 +-- Maintainer : Oleg Grenrus <[email protected]> +-- +-- More or less useful newtypes for writing 'FromJSON' & 'ToJSON' instances +module Data.Aeson.Extra.Map ( + M(..), + FromJSONKey(..), + parseIntegralJSONKey, + FromJSONMap(..), + ToJSONKey(..), + ToJSONMap(..), + ) where + +import Prelude () +import Prelude.Compat + +import Data.Aeson.Compat +import Data.Aeson.Types hiding ((.:?)) +import Data.Hashable (Hashable) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Typeable (Typeable) + +import qualified Data.HashMap.Strict as H +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Read as T + +-- | 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, Typeable) + +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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/aeson-extra-0.3.0.0/src/Data/Aeson/Extra/Merge.hs new/aeson-extra-0.3.1.0/src/Data/Aeson/Extra/Merge.hs --- old/aeson-extra-0.3.0.0/src/Data/Aeson/Extra/Merge.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/aeson-extra-0.3.1.0/src/Data/Aeson/Extra/Merge.hs 2016-01-27 19:08:46.000000000 +0100 @@ -0,0 +1,53 @@ +{-# LANGUAGE RankNTypes #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Aeson.Extra.Merge +-- Copyright : (C) 2015-2016 Oleg Grenrus +-- License : BSD3 +-- Maintainer : Oleg Grenrus <[email protected]> +-- +module Data.Aeson.Extra.Merge ( + merge, + mergeA, + ValueF(..), + ObjectF, + ArrayF, + ) where + +import Prelude () +import Prelude.Compat + +import Data.Aeson.Compat +import Data.Aeson.Extra.Foldable +import Data.Functor.Foldable (project, embed) + +-- | Generic merge. +-- +-- For example <https://lodash.com/docs#merge>: +-- +-- @ +-- lodashMerge :: Value -> Value -> Value +-- lodashMerge x y = merge lodashMergeAlg x y +-- +-- lodashMergeAlg :: (a -> a -> a) -> ValueF a -> ValueF a -> ValueF a +-- lodashMergeAlg r a' b' = case (a', b') of +-- (ObjectF a, ObjectF b) -> ObjectF $ alignWith f a b +-- (ArrayF a, ArrayF b) -> ArrayF $ alignWith f a b +-- (_, b) -> b +-- where f (These x y) = r x y +-- f (This x) = x +-- f (That x) = x +-- @ +-- +-- /Since: aeson-extra-0.3.1.0/ +merge :: (forall a. (a -> a -> a) -> ValueF a -> ValueF a -> ValueF a) + -> Value -> Value -> Value +merge f a b = embed $ f (merge f) (project a) (project b) + +-- | Generic merge, in arbitrary context. +-- +-- /Since: aeson-extra-0.3.1.0/ +mergeA :: Functor f + => (forall a. (a -> a -> f a) -> ValueF a -> ValueF a -> f (ValueF a)) + -> Value -> Value -> f Value +mergeA f a b = embed <$> f (mergeA f) (project a) (project b) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/aeson-extra-0.3.0.0/src/Data/Aeson/Extra/SingObject.hs new/aeson-extra-0.3.1.0/src/Data/Aeson/Extra/SingObject.hs --- old/aeson-extra-0.3.0.0/src/Data/Aeson/Extra/SingObject.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/aeson-extra-0.3.1.0/src/Data/Aeson/Extra/SingObject.hs 2016-01-27 19:08:46.000000000 +0100 @@ -0,0 +1,62 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Aeson.Extra.SymTag +-- Copyright : (C) 2015-2016 Oleg Grenrus +-- License : BSD3 +-- Maintainer : Oleg Grenrus <[email protected]> +-- +module Data.Aeson.Extra.SingObject ( + SingObject(..), + mkSingObject, + getSingObject, + ) where + +import Prelude () +import Prelude.Compat + +import Data.Aeson.Compat +import Data.Monoid ((<>)) +import Data.Proxy +import Data.Typeable (Typeable) +import GHC.TypeLits + +import qualified Data.Text as T + +-- | Singleton value object +-- +-- > λ > decode "{\"value\": 42 }" :: Maybe (SingObject "value" Int) +-- > Just (SingObject 42) +-- +-- > λ > encode (SingObject 42 :: SingObject "value" Int) +-- > "{\"value\":42}" +-- +-- /Available with: base >=4.7/ +newtype SingObject (s ::Symbol) a = SingObject a + deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable, Typeable) + +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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/aeson-extra-0.3.0.0/src/Data/Aeson/Extra/SymTag.hs new/aeson-extra-0.3.1.0/src/Data/Aeson/Extra/SymTag.hs --- old/aeson-extra-0.3.0.0/src/Data/Aeson/Extra/SymTag.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/aeson-extra-0.3.1.0/src/Data/Aeson/Extra/SymTag.hs 2016-01-27 19:08:46.000000000 +0100 @@ -0,0 +1,50 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Aeson.Extra.SymTag +-- Copyright : (C) 2015-2016 Oleg Grenrus +-- License : BSD3 +-- Maintainer : Oleg Grenrus <[email protected]> +-- +module Data.Aeson.Extra.SymTag ( + SymTag(..), + ) where + +import Prelude () +import Prelude.Compat + +import Data.Aeson.Compat +import Data.Aeson.Types hiding ((.:?)) +import Data.Proxy +import GHC.TypeLits + +import qualified Data.Text as T + +-- | Singleton string encoded and decoded as ifself. +-- +-- > λ> encode (SymTag :: SymTag "foobar") +-- > "\"foobar\"" +-- +-- > decode "\"foobar\"" :: Maybe (SymTag "foobar") +-- > Just SymTag +-- +-- > decode "\"foobar\"" :: Maybe (SymTag "barfoo") +-- > Nothing +-- +-- /Available with: base >=4.7/ +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 ("SymTag " ++ 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)) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/aeson-extra-0.3.0.0/src/Data/Aeson/Extra/TH.hs new/aeson-extra-0.3.1.0/src/Data/Aeson/Extra/TH.hs --- old/aeson-extra-0.3.0.0/src/Data/Aeson/Extra/TH.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/aeson-extra-0.3.1.0/src/Data/Aeson/Extra/TH.hs 2016-01-27 19:08:46.000000000 +0100 @@ -0,0 +1,65 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Aeson.Extra.TH +-- Copyright : (C) 2015-2016 Oleg Grenrus +-- License : BSD3 +-- Maintainer : Oleg Grenrus <[email protected]> +-- +-- In addition to 'mkValue' and 'mkValue'' helpers, +-- this module exports 'Lift' 'Value' orphan instance +module Data.Aeson.Extra.TH ( + mkValue, + mkValue', + ) where + +import Control.Arrow (first) +import Data.Aeson.Compat +import Data.Scientific (scientific, coefficient, base10Exponent) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (Lift(..)) + +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Vector as V +import qualified Data.HashMap.Strict as HM + +-- | Create a 'Value' from string representation. +-- +-- This is useful in tests. +-- +-- /Since: aeson-extra-0.3.1.0/ +mkValue :: String -> Q Exp +mkValue s = case eitherDecodeStrict' bs :: Either String Value of + Left err -> fail $ "mkValue: " ++ err + Right v -> [| v |] + where bs = TE.encodeUtf8 $ T.pack s + +-- | Like 'mkValue', but replace single quotes with double quotes before. +-- +-- > > $(mkValue' "{'a': 2 }") +-- > Object (fromList [("a",Number 2.0)]) +-- +-- /Since: aeson-extra-0.3.1.0/ +mkValue' :: String -> Q Exp +mkValue' = mkValue . map f + where f '\'' = '"' + f x = x + +-- | From 'aeson-extra' +-- +-- /Since: aeson-extra-0.3.1.0/ +instance Lift Value where + lift Null = [| Null |] + lift (Bool b) = [| Bool b |] + lift (Number n) = [| Number (scientific c e) |] + where + c = coefficient n + e = base10Exponent n + lift (String t) = [| String (T.pack s) |] + where s = T.unpack t + lift (Array a) = [| Array (V.fromList a') |] + where a' = V.toList a + lift (Object o) = [| Object (HM.fromList . map (first T.pack) $ o') |] + where o' = map (first T.unpack) . HM.toList $ o diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/aeson-extra-0.3.0.0/src/Data/Aeson/Extra/Time.hs new/aeson-extra-0.3.1.0/src/Data/Aeson/Extra/Time.hs --- old/aeson-extra-0.3.0.0/src/Data/Aeson/Extra/Time.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/aeson-extra-0.3.1.0/src/Data/Aeson/Extra/Time.hs 2016-01-27 19:08:46.000000000 +0100 @@ -0,0 +1,85 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Aeson.Extra.Time +-- Copyright : (C) 2015-2016 Oleg Grenrus +-- License : BSD3 +-- Maintainer : Oleg Grenrus <[email protected]> +-- +-- Time tools +module Data.Aeson.Extra.Time ( + U(..), + Z(..), + )where + +import Prelude () +import Prelude.Compat + +import Data.Aeson.Compat +import Data.Aeson.Types hiding ((.:?)) +import Data.Text (Text) +import Data.Time (UTCTime, ZonedTime) +import Data.Typeable (Typeable) + +#if !MIN_VERSION_aeson (0,10,0) +import qualified Data.Time.Parsers as TimeParsers +import qualified Text.Parsec as Parsec +#endif + +-- | A type to parse 'UTCTime' +-- +-- 'FromJSON' instance accepts for example: +-- +-- @ +-- 2015-09-07T08:16:40.807Z +-- 2015-09-07 11:16:40.807 +03:00 +-- @ +-- +-- Latter format is accepted by @aeson@ staring from version @0.10.0.0@. +-- +-- See <https://github.com/bos/aeson/blob/4667ef1029a373cf4510f7deca147c357c6d8947/Data/Aeson/Parser/Time.hs#L150> +-- +-- /Since: aeson-extra-0.2.2.0/ +newtype U = U { getU :: UTCTime } + deriving (Eq, Ord, Show, Read, Typeable) + +instance ToJSON U where + toJSON = toJSON . getU +#if MIN_VERSION_aeson (0,10,0) + toEncoding = toEncoding . getU +#endif + +instance FromJSON U where +#if MIN_VERSION_aeson (0,10,0) + parseJSON = fmap U . parseJSON +#else + parseJSON = withText "UTCTime" (fmap U . run TimeParsers.utcTime) +#endif + +-- | A type to parse 'ZonedTime' +-- +-- /Since: aeson-extra-0.2.2.0/ +newtype Z = Z { getZ :: ZonedTime } + deriving (Show, Read, Typeable) + +instance ToJSON Z where + toJSON = toJSON . getZ +#if MIN_VERSION_aeson (0,10,0) + toEncoding = toEncoding . getZ +#endif + +instance FromJSON Z where +#if MIN_VERSION_aeson (0,10,0) + parseJSON = fmap Z . parseJSON +#else + parseJSON = withText "ZonedTime" (fmap Z . run TimeParsers.zonedTime) +#endif + +#if !MIN_VERSION_aeson (0,10,0) +-- | Run a 'parsers' parser as an aeson parser. +run :: Parsec.Parsec Text () a -> Text -> Parser a +run p t = case Parsec.parse (p <* Parsec.eof) "" t of + Left err -> fail $ "could not parse date: " ++ show err + Right r -> return r +#endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/aeson-extra-0.3.0.0/src/Data/Aeson/Extra.hs new/aeson-extra-0.3.1.0/src/Data/Aeson/Extra.hs --- old/aeson-extra-0.3.0.0/src/Data/Aeson/Extra.hs 2015-12-25 18:51:00.000000000 +0100 +++ new/aeson-extra-0.3.1.0/src/Data/Aeson/Extra.hs 2016-01-27 19:08:46.000000000 +0100 @@ -1,18 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Aeson.Extra --- Copyright : (C) 2015 Oleg Grenrus +-- Copyright : (C) 2015-2016 Oleg Grenrus -- License : BSD3 -- Maintainer : Oleg Grenrus <[email protected]> -- @@ -42,6 +32,15 @@ -- * UTCTime U(..), Z(..), + -- * Algebra + ValueF(..), + ObjectF, + ArrayF, + -- * Merge + merge, + -- * Template Haskell + mkValue, + mkValue', -- * Re-exports module Data.Aeson.Compat, ) where @@ -49,31 +48,21 @@ import Prelude () import Prelude.Compat -import Control.Applicative (Alternative(..)) import Data.Aeson.Compat -import Data.Aeson.Types hiding ((.:?)) -import Data.Hashable (Hashable) -import Data.Monoid -import Data.Text (Text) -import Data.Time (UTCTime, ZonedTime) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS -import qualified Data.Foldable as Foldable -import qualified Data.HashMap.Strict as H -import qualified Data.Map as Map -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Read as T -#if MIN_VERSION_base(4,7,0) -import Data.Proxy -import GHC.TypeLits -#endif +import Data.Aeson.Extra.CollapsedList +import Data.Aeson.Extra.Foldable +import Data.Aeson.Extra.Map +import Data.Aeson.Extra.Merge +import Data.Aeson.Extra.Time +import Data.Aeson.Extra.TH -#if !MIN_VERSION_aeson (0,10,0) -import qualified Text.Parsec as Parsec -import qualified Data.Time.Parsers as TimeParsers +#if MIN_VERSION_base(4,7,0) +import Data.Aeson.Extra.SingObject +import Data.Aeson.Extra.SymTag #endif -- | Like 'encode', but produces strict 'BS.ByteString'. @@ -81,247 +70,3 @@ -- /Since: 0.2.3.0/ encodeStrict :: ToJSON a => a -> BS.ByteString encodeStrict = LBS.toStrict . encode - --- | 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) - -#if MIN_VERSION_base(4,7,0) --- | Singleton string encoded and decoded as ifself. --- --- > λ> encode (SymTag :: SymTag "foobar") --- > "\"foobar\"" --- --- > decode "\"foobar\"" :: Maybe (SymTag "foobar") --- > Just SymTag --- --- > decode "\"foobar\"" :: Maybe (SymTag "barfoo") --- > Nothing --- --- /Available with: base >=4.7/ -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 ("SymTag " ++ 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}" --- --- /Available with: base >=4.7/ -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) -#endif - - --- | 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]" --- --- Documentation rely on @f@ 'Alternative' instance behaving like lists'. -newtype CollapsedList f a = CollapsedList (f a) - deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable) - -getCollapsedList :: CollapsedList f a -> f a -getCollapsedList (CollapsedList l) = l - -instance (FromJSON a, FromJSON (f a), Alternative f) => FromJSON (CollapsedList f a) where - parseJSON Null = pure (CollapsedList Control.Applicative.empty) - parseJSON v@(Array _) = CollapsedList <$> parseJSON v - parseJSON v = CollapsedList . pure <$> parseJSON v - -instance (ToJSON a, ToJSON (f a), Foldable f) => ToJSON (CollapsedList f a) where -#if MIN_VERSION_aeson (0,10,0) - toEncoding (CollapsedList l) = - case Foldable.toList l of - [] -> toEncoding Null - [x] -> toEncoding x - _ -> toEncoding l -#endif - toJSON (CollapsedList l) = - case Foldable.toList l of - [] -> toJSON Null - [x] -> toJSON x - _ -> 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 <$> parseCollapsedList 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 a, FromJSON (f a), Alternative f) => Object -> Text -> Parser (f a) -parseCollapsedList obj key = - case H.lookup key obj of - Nothing -> pure Control.Applicative.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 - --- | A type to parse 'UTCTime' --- --- 'FromJSON' instance accepts for example: --- --- @ --- 2015-09-07T08:16:40.807Z --- 2015-09-07 11:16:40.807 +03:00 --- @ --- --- Latter format is accepted by @aeson@ staring from version @0.10.0.0@. --- --- See <https://github.com/bos/aeson/blob/4667ef1029a373cf4510f7deca147c357c6d8947/Data/Aeson/Parser/Time.hs#L150> --- --- /Since: aeson-extra-0.2.2.0/ -newtype U = U { getU :: UTCTime } - deriving (Eq, Ord, Show, Read) - -instance ToJSON U where - toJSON = toJSON . getU -#if MIN_VERSION_aeson (0,10,0) - toEncoding = toEncoding . getU -#endif - -instance FromJSON U where -#if MIN_VERSION_aeson (0,10,0) - parseJSON = fmap U . parseJSON -#else - parseJSON = withText "UTCTime" (fmap U . run TimeParsers.utcTime) -#endif - --- | A type to parse 'ZonedTime' --- --- /Since: aeson-extra-0.2.2.0/ -newtype Z = Z { getZ :: ZonedTime } - deriving (Show, Read) - -instance ToJSON Z where - toJSON = toJSON . getZ -#if MIN_VERSION_aeson (0,10,0) - toEncoding = toEncoding . getZ -#endif - -instance FromJSON Z where -#if MIN_VERSION_aeson (0,10,0) - parseJSON = fmap Z . parseJSON -#else - parseJSON = withText "ZonedTime" (fmap Z . run TimeParsers.zonedTime) -#endif - -#if !MIN_VERSION_aeson (0,10,0) --- | Run a 'parsers' parser as an aeson parser. -run :: Parsec.Parsec Text () a -> Text -> Parser a -run p t = case Parsec.parse (p <* Parsec.eof) "" t of - Left err -> fail $ "could not parse date: " ++ show err - Right r -> return r -#endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/aeson-extra-0.3.0.0/test/Orphans.hs new/aeson-extra-0.3.1.0/test/Orphans.hs --- old/aeson-extra-0.3.0.0/test/Orphans.hs 2015-09-29 19:42:53.000000000 +0200 +++ new/aeson-extra-0.3.1.0/test/Orphans.hs 2016-01-27 18:48:34.000000000 +0100 @@ -9,6 +9,8 @@ import Data.Vector as V import Test.Tasty.QuickCheck +#if !MIN_VERSION_quickcheck_instances(0,3,12) instance Arbitrary a => Arbitrary (Vector a) where arbitrary = V.fromList <$> arbitrary shrink = fmap V.fromList . shrink . V.toList +#endif diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/aeson-extra-0.3.0.0/test/Tests.hs new/aeson-extra-0.3.1.0/test/Tests.hs --- old/aeson-extra-0.3.0.0/test/Tests.hs 2015-12-08 12:18:32.000000000 +0100 +++ new/aeson-extra-0.3.1.0/test/Tests.hs 2016-01-27 19:08:46.000000000 +0100 @@ -9,7 +9,8 @@ import Control.Applicative #endif -import qualified Data.HashMap.Lazy as H + + import Data.Map (Map) import Data.Maybe (isJust) import Data.String (fromString) @@ -19,6 +20,10 @@ import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck +import Data.These (These (..)) +import Data.Align (alignWith) + +import qualified Data.HashMap.Lazy as H #if MIN_VERSION_base(4,7,0) import Data.Proxy @@ -42,6 +47,7 @@ , utctimeTests , zonedtimeTests , timeTHTests + , mergeTests ] ------------------------------------------------------------------------------ @@ -208,14 +214,37 @@ , "2015-09-07 05:16:40.807 -03:00" ] ------------------------------------------------------------------------------- --- Time Template Haskell ------------------------------------------------------------------------------- - timeTHTests :: TestTree timeTHTests = testCase "time TH example" $ assertBool "should be equal" $ lhs == rhs where lhs = UTCTime (ModifiedJulianDay 56789) 123.456 rhs = $(mkUTCTime "2014-05-12 00:02:03.456000Z") - \ No newline at end of file +------------------------------------------------------------------------------ +-- Merge tests +------------------------------------------------------------------------------ + +lodashMerge :: Value -> Value -> Value +lodashMerge x y = merge lodashMergeAlg x y + +lodashMergeAlg :: (a -> a -> a) -> ValueF a -> ValueF a -> ValueF a +lodashMergeAlg r a' b' = case (a', b') of + (ObjectF a, ObjectF b) -> ObjectF $ alignWith f a b + (ArrayF a, ArrayF b) -> ArrayF $ alignWith f a b + (_, b) -> b + where f (These x y) = r x y + f (This x) = x + f (That x) = x + +mergeTests :: TestTree +mergeTests = testGroup "Lodash merge examples" $ map f examples + where + f (x, y, z) = testCase "-" $ assertBool "should be equal" $ lodashMerge x y == z + examples = + [ (,,) $(mkValue "[1, 2, 3]") $(mkValue "[4, 5, 6, 7, 8]") $(mkValue "[4, 5, 6, 7, 8]") + , (,,) $(mkValue' "{'a': 1}") $(mkValue' "{'b': 2}") $(mkValue' "{'a': 1, 'b': 2}") + , (,,) + $(mkValue' "{ 'data': [{ 'user': 'barney' }, { 'user': 'fred' }] }") + $(mkValue' "{ 'data': [{ 'age': 36 }, { 'age': 40 }] }") + $(mkValue' "{ 'data': [{ 'user': 'barney', 'age': 36 }, { 'user': 'fred', 'age': 40 }] }") + ]
