Skip to content

Commit

Permalink
Merge pull request #1104 from haskell/deriving-via-sm
Browse files Browse the repository at this point in the history 
Use DerivingVia to derive newtype instances
  • Loading branch information
@phadej
phadej authored Jun 9, 2024
2 parents 27517f0 + d247c3e commit 6ae3542
Show file tree
Hide file tree
Showing 3 changed files with 56 additions and 207 deletions.
2 changes: 2 additions & 0 deletions changelog.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,8 @@ For the latest version of this document, please see [https://github.com/haskell/
### 2.2.3.0

* Support `hashable-1.4.6.0`.
* Fix an issue where `Hashable Key` wasn't newtype instance over underlying `Text`,
so with `-ordered-keymap` there were correctness issues.

### 2.2.2.0

Expand Down
132 changes: 28 additions & 104 deletions src/Data/Aeson/Types/FromJSON.hs
View file
Original file line number Diff line number Diff line change
@@ -1,18 +1,20 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

Expand Down Expand Up @@ -86,12 +88,12 @@ module Data.Aeson.Types.FromJSON
import Data.Aeson.Internal.Prelude

import Control.Monad (zipWithM, guard)
import Data.Aeson.Decoding.ByteString.Lazy
import Data.Aeson.Decoding.Conversion (unResult, toResultValue, lbsSpace)
import Data.Aeson.Internal.Functions (mapKey, mapKeyO)
import Data.Aeson.Internal.Scientific
import Data.Aeson.Types.Generic
import Data.Aeson.Types.Internal
import Data.Aeson.Decoding.ByteString.Lazy
import Data.Aeson.Decoding.Conversion (unResult, toResultValue, lbsSpace)
import Data.Bits (unsafeShiftR)
import Data.Fixed (Fixed, HasResolution (resolution), Nano)
import Data.Functor.Compose (Compose(..))
Expand All @@ -100,6 +102,7 @@ import Data.Functor.Product (Product(..))
import Data.Functor.Sum (Sum(..))
import Data.Functor.These (These1 (..))
import Data.Hashable (Hashable(..))
import Data.Kind (Type)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Ord (Down (..))
import Data.Ratio ((%), Ratio)
Expand Down Expand Up @@ -1922,17 +1925,10 @@ instance (FromJSONKey a) => FromJSONKey (Solo a) where

instance FromJSON1 Identity where
liftParseJSON _ p _ a = coerce (p a)

liftParseJSONList _ _ p a = coerce (p a)

liftOmittedField = coerce

instance (FromJSON a) => FromJSON (Identity a) where
parseJSON = parseJSON1

parseJSONList = liftParseJSONList omittedField parseJSON parseJSONList

omittedField = coerce (omittedField @a)
deriving via (a :: Type) instance FromJSON a => FromJSON (Identity a)

instance (FromJSONKey a) => FromJSONKey (Identity a) where
fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction a)
Expand Down Expand Up @@ -2313,114 +2309,42 @@ instance FromJSONKey Month where
-------------------------------------------------------------------------------

-- | @since 2.2.0.0
instance FromJSON1 Down where
liftParseJSON _ p _ = coerce p

liftOmittedField = coerce
deriving via Identity instance FromJSON1 Down

-- | @since 2.2.0.0
instance FromJSON a => FromJSON (Down a) where
parseJSON = parseJSON1
deriving via (a :: Type) instance FromJSON a => FromJSON (Down a)

-------------------------------------------------------------------------------
-- base Monoid/Semigroup
-------------------------------------------------------------------------------

instance FromJSON1 Monoid.Dual where
liftParseJSON _ p _ = coerce p
deriving via Identity instance FromJSON1 Monoid.Dual
deriving via (a :: Type) instance FromJSON a => FromJSON (Monoid.Dual a)

liftOmittedField = coerce
deriving via Maybe instance FromJSON1 Monoid.First
deriving via Maybe a instance FromJSON a => FromJSON (Monoid.First a)

instance FromJSON a => FromJSON (Monoid.Dual a) where
parseJSON = parseJSON1


instance FromJSON1 Monoid.First where
liftParseJSON o = coerce (liftParseJSON @Maybe o)
liftOmittedField _ = Just (Monoid.First Nothing)

instance FromJSON a => FromJSON (Monoid.First a) where
parseJSON = parseJSON1
omittedField = omittedField1

instance FromJSON1 Monoid.Last where
liftParseJSON o = coerce (liftParseJSON @Maybe o)
liftOmittedField _ = Just (Monoid.Last Nothing)

instance FromJSON a => FromJSON (Monoid.Last a) where
parseJSON = parseJSON1
omittedField = omittedField1
deriving via Maybe instance FromJSON1 Monoid.Last
deriving via Maybe a instance FromJSON a => FromJSON (Monoid.Last a)

instance FromJSON1 Semigroup.Min where
liftParseJSON _ p _ a = coerce (p a)

liftParseJSONList _ _ p a = coerce (p a)

liftOmittedField = coerce
deriving via Identity instance FromJSON1 Semigroup.Min
deriving via (a :: Type) instance FromJSON a => FromJSON (Semigroup.Min a)

instance (FromJSON a) => FromJSON (Semigroup.Min a) where
parseJSON = parseJSON1
deriving via Identity instance FromJSON1 Semigroup.Max
deriving via (a :: Type) instance FromJSON a => FromJSON (Semigroup.Max a)

parseJSONList = liftParseJSONList omittedField parseJSON parseJSONList
deriving via Identity instance FromJSON1 Semigroup.First
deriving via (a :: Type) instance FromJSON a => FromJSON (Semigroup.First a)

omittedField = omittedField1
deriving via Identity instance FromJSON1 Semigroup.Last
deriving via (a :: Type) instance FromJSON a => FromJSON (Semigroup.Last a)

instance FromJSON1 Semigroup.Max where
liftParseJSON _ p _ a = coerce (p a)

liftParseJSONList _ _ p a = coerce (p a)
liftOmittedField = coerce

instance (FromJSON a) => FromJSON (Semigroup.Max a) where
parseJSON = parseJSON1

parseJSONList = liftParseJSONList omittedField parseJSON parseJSONList
omittedField = omittedField1

instance FromJSON1 Semigroup.First where
liftParseJSON _ p _ a = coerce (p a)

liftParseJSONList _ _ p a = coerce (p a)
liftOmittedField = coerce

instance (FromJSON a) => FromJSON (Semigroup.First a) where
parseJSON = parseJSON1

parseJSONList = liftParseJSONList omittedField parseJSON parseJSONList


instance FromJSON1 Semigroup.Last where
liftParseJSON _ p _ a = coerce (p a)

liftParseJSONList _ _ p a = coerce (p a)
liftOmittedField = coerce

instance (FromJSON a) => FromJSON (Semigroup.Last a) where
parseJSON = parseJSON1

parseJSONList = liftParseJSONList omittedField parseJSON parseJSONList
omittedField = omittedField1

instance FromJSON1 Semigroup.WrappedMonoid where
liftParseJSON _ p _ a = coerce (p a)

liftParseJSONList _ _ p a = coerce (p a)
liftOmittedField = coerce

instance (FromJSON a) => FromJSON (Semigroup.WrappedMonoid a) where
parseJSON = parseJSON1

parseJSONList = liftParseJSONList omittedField parseJSON parseJSONList
omittedField = omittedField1
deriving via Identity instance FromJSON1 Semigroup.WrappedMonoid
deriving via (a :: Type) instance FromJSON a => FromJSON (Semigroup.WrappedMonoid a)

#if !MIN_VERSION_base(4,16,0)
instance FromJSON1 Semigroup.Option where
liftParseJSON o = coerce (liftParseJSON @Maybe o)
liftOmittedField _ = Just (Semigroup.Option Nothing)

instance FromJSON a => FromJSON (Semigroup.Option a) where
parseJSON = parseJSON1
omittedField = omittedField1
deriving via Maybe instance FromJSON1 Semigroup.Option
deriving via Maybe a instance FromJSON a => FromJSON (Semigroup.Option a)
#endif

-------------------------------------------------------------------------------
Expand Down
129 changes: 26 additions & 103 deletions src/Data/Aeson/Types/ToJSON.hs
View file
Original file line number Diff line number Diff line change
@@ -1,18 +1,20 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Data.Aeson.Types.ToJSON
Expand Down Expand Up @@ -76,6 +78,7 @@ import Data.Functor.Identity (Identity(..))
import Data.Functor.Product (Product(..))
import Data.Functor.Sum (Sum(..))
import Data.Functor.These (These1 (..))
import Data.Kind (Type)
import Data.List (intersperse)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (isNothing)
Expand Down Expand Up @@ -1641,14 +1644,7 @@ instance ToJSON1 Identity where

liftOmitField o (Identity a) = o a

instance (ToJSON a) => ToJSON (Identity a) where
toJSON = toJSON1
toJSONList = liftToJSONList omitField toJSON toJSONList

toEncoding = toEncoding1
toEncodingList = liftToEncodingList omitField toEncoding toEncodingList

omitField (Identity x) = omitField x
deriving via (a :: Type) instance ToJSON a => ToJSON (Identity a)

instance (ToJSONKey a) => ToJSONKey (Identity a) where
toJSONKey = contramapToJSONKeyFunction runIdentity toJSONKey
Expand Down Expand Up @@ -2075,115 +2071,42 @@ instance ToJSONKey QuarterOfYear where
-------------------------------------------------------------------------------

-- | @since 2.2.0.0
instance ToJSON1 Down where
liftToJSON _ t _ = coerce t
liftToEncoding _ t _ = coerce t
liftOmitField = coerce
deriving via Identity instance ToJSON1 Down

-- | @since 2.2.0.0
instance ToJSON a => ToJSON (Down a) where
toJSON = toJSON1
toEncoding = toEncoding1
omitField = omitField1
deriving via (a :: Type) instance ToJSON a => ToJSON (Down a)

-------------------------------------------------------------------------------
-- base Monoid/Semigroup
-------------------------------------------------------------------------------

instance ToJSON1 Monoid.Dual where
liftToJSON _ t _ = t . Monoid.getDual
liftToEncoding _ t _ = t . Monoid.getDual
liftOmitField = coerce

instance ToJSON a => ToJSON (Monoid.Dual a) where
toJSON = toJSON1
toEncoding = toEncoding1
omitField = omitField1

instance ToJSON1 Monoid.First where
liftToJSON o t to' = liftToJSON o t to' . Monoid.getFirst
liftToEncoding o t to' = liftToEncoding o t to' . Monoid.getFirst
liftOmitField :: forall a. (a -> Bool) -> Monoid.First a -> Bool
liftOmitField _ = coerce (isNothing @a)

instance ToJSON a => ToJSON (Monoid.First a) where
toJSON = toJSON1
toEncoding = toEncoding1
omitField = omitField1

instance ToJSON1 Monoid.Last where
liftToJSON o t to' = liftToJSON o t to' . Monoid.getLast
liftToEncoding o t to' = liftToEncoding o t to' . Monoid.getLast

liftOmitField :: forall a. (a -> Bool) -> Monoid.Last a -> Bool
liftOmitField _ = coerce (isNothing @a)

instance ToJSON a => ToJSON (Monoid.Last a) where
toJSON = toJSON1
toEncoding = toEncoding1
omitField = omitField1

instance ToJSON1 Semigroup.Min where
liftToJSON _ t _ (Semigroup.Min x) = t x
liftToEncoding _ t _ (Semigroup.Min x) = t x
liftOmitField = coerce
deriving via Identity instance ToJSON1 Monoid.Dual
deriving via (a :: Type) instance ToJSON a => ToJSON (Monoid.Dual a)

instance ToJSON a => ToJSON (Semigroup.Min a) where
toJSON = toJSON1
toEncoding = toEncoding1
omitField = omitField1
deriving via Maybe instance ToJSON1 Monoid.First
deriving via Maybe a instance ToJSON a => ToJSON (Monoid.First a)

deriving via Maybe instance ToJSON1 Monoid.Last
deriving via Maybe a instance ToJSON a => ToJSON (Monoid.Last a)

instance ToJSON1 Semigroup.Max where
liftToJSON _ t _ (Semigroup.Max x) = t x
liftToEncoding _ t _ (Semigroup.Max x) = t x
liftOmitField = coerce
deriving via Identity instance ToJSON1 Semigroup.Min
deriving via (a :: Type) instance ToJSON a => ToJSON (Semigroup.Min a)

instance ToJSON a => ToJSON (Semigroup.Max a) where
toJSON = toJSON1
toEncoding = toEncoding1
omitField = omitField1
deriving via Identity instance ToJSON1 Semigroup.Max
deriving via (a :: Type) instance ToJSON a => ToJSON (Semigroup.Max a)

instance ToJSON1 Semigroup.First where
liftToJSON _ t _ (Semigroup.First x) = t x
liftToEncoding _ t _ (Semigroup.First x) = t x
liftOmitField = coerce
deriving via Identity instance ToJSON1 Semigroup.First
deriving via (a :: Type) instance ToJSON a => ToJSON (Semigroup.First a)

instance ToJSON a => ToJSON (Semigroup.First a) where
toJSON = toJSON1
toEncoding = toEncoding1
omitField = omitField1
deriving via Identity instance ToJSON1 Semigroup.Last
deriving via (a :: Type) instance ToJSON a => ToJSON (Semigroup.Last a)

instance ToJSON1 Semigroup.Last where
liftToJSON _ t _ (Semigroup.Last x) = t x
liftToEncoding _ t _ (Semigroup.Last x) = t x
liftOmitField = coerce

instance ToJSON a => ToJSON (Semigroup.Last a) where
toJSON = toJSON1
toEncoding = toEncoding1
omitField = omitField1

instance ToJSON1 Semigroup.WrappedMonoid where
liftToJSON _ t _ (Semigroup.WrapMonoid x) = t x
liftToEncoding _ t _ (Semigroup.WrapMonoid x) = t x
liftOmitField = coerce

instance ToJSON a => ToJSON (Semigroup.WrappedMonoid a) where
toJSON = toJSON1
toEncoding = toEncoding1
omitField = omitField1
deriving via Identity instance ToJSON1 Semigroup.WrappedMonoid
deriving via (a :: Type) instance ToJSON a => ToJSON (Semigroup.WrappedMonoid a)

#if !MIN_VERSION_base(4,16,0)
instance ToJSON1 Semigroup.Option where
liftToJSON o t to' = liftToJSON o t to' . Semigroup.getOption
liftToEncoding o t to' = liftToEncoding o t to' . Semigroup.getOption
liftOmitField _ = isNothing . Semigroup.getOption

instance ToJSON a => ToJSON (Semigroup.Option a) where
toJSON = toJSON1
toEncoding = toEncoding1
omitField = omitField1
deriving via Maybe instance ToJSON1 Semigroup.Option
deriving via Maybe a instance ToJSON a => ToJSON (Semigroup.Option a)
#endif

-------------------------------------------------------------------------------
Expand Down

0 comments on commit 6ae3542

Please sign in to comment.