Hello community,
here is the log from the commit of package ghc-generic-deriving for
openSUSE:Factory checked in at 2019-02-17 12:20:07
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-generic-deriving (Old)
and /work/SRC/openSUSE:Factory/.ghc-generic-deriving.new.28833 (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-generic-deriving"
Sun Feb 17 12:20:07 2019 rev:11 rq:674299 version:1.12.3
Changes:
--------
---
/work/SRC/openSUSE:Factory/ghc-generic-deriving/ghc-generic-deriving.changes
2018-10-25 08:25:53.955814372 +0200
+++
/work/SRC/openSUSE:Factory/.ghc-generic-deriving.new.28833/ghc-generic-deriving.changes
2019-02-17 12:20:08.276220406 +0100
@@ -1,0 +2,17 @@
+Sun Feb 10 03:02:15 UTC 2019 - [email protected]
+
+- Update generic-deriving to version 1.12.3.
+ # 1.12.3 [2019.02.09]
+ * Support `template-haskell-2.15`.
+ * Add a `gshowList` method to `GShow`, which lets us avoid the need for
+ `OverlappingInstances` in `Generics.Deriving.TH`. As a consequence, the
+ `GShow String` instance has been removed, as it is now fully subsumed by
+ the `GShow [a]` instance (with which it previously overlapped).
+ * Functions in `Generics.Deriving.TH` now balance groups of `(:*:)` and
`(:+:)`
+ as much as possible (`deriving Generic` was already performing this
+ optimization, and now `generic-deriving` does too).
+ * Add a `Generics.Deriving.Default` module demonstrating and explaining
+ how and why to use `DerivingVia`. There is also a test suite with
+ further examples.
+
+-------------------------------------------------------------------
Old:
----
generic-deriving-1.12.2.tar.gz
generic-deriving.cabal
New:
----
generic-deriving-1.12.3.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-generic-deriving.spec ++++++
--- /var/tmp/diff_new_pack.BJ7g56/_old 2019-02-17 12:20:08.760220273 +0100
+++ /var/tmp/diff_new_pack.BJ7g56/_new 2019-02-17 12:20:08.764220272 +0100
@@ -1,7 +1,7 @@
#
# spec file for package ghc-generic-deriving
#
-# Copyright (c) 2018 SUSE LINUX GmbH, Nuernberg, Germany.
+# Copyright (c) 2019 SUSE LINUX GmbH, Nuernberg, Germany.
#
# All modifications and additions to the file contributed by third parties
# remain the property of their copyright owners, unless otherwise agreed
@@ -19,14 +19,13 @@
%global pkg_name generic-deriving
%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 1.12.2
+Version: 1.12.3
Release: 0
Summary: Generic programming library for generalised deriving
License: BSD-3-Clause
Group: Development/Libraries/Haskell
URL: https://hackage.haskell.org/package/%{pkg_name}
Source0:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz
-Source1:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/revision/1.cabal#/%{pkg_name}.cabal
BuildRequires: ghc-Cabal-devel
BuildRequires: ghc-containers-devel
BuildRequires: ghc-rpm-macros
@@ -61,7 +60,6 @@
%prep
%setup -q -n %{pkg_name}-%{version}
-cp -p %{SOURCE1} %{pkg_name}.cabal
%build
%ghc_lib_build
++++++ generic-deriving-1.12.2.tar.gz -> generic-deriving-1.12.3.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/generic-deriving-1.12.2/CHANGELOG.md
new/generic-deriving-1.12.3/CHANGELOG.md
--- old/generic-deriving-1.12.2/CHANGELOG.md 2018-06-28 16:44:14.000000000
+0200
+++ new/generic-deriving-1.12.3/CHANGELOG.md 2001-09-09 03:46:40.000000000
+0200
@@ -1,3 +1,16 @@
+# 1.12.3 [2019.02.09]
+* Support `template-haskell-2.15`.
+* Add a `gshowList` method to `GShow`, which lets us avoid the need for
+ `OverlappingInstances` in `Generics.Deriving.TH`. As a consequence, the
+ `GShow String` instance has been removed, as it is now fully subsumed by
+ the `GShow [a]` instance (with which it previously overlapped).
+* Functions in `Generics.Deriving.TH` now balance groups of `(:*:)` and `(:+:)`
+ as much as possible (`deriving Generic` was already performing this
+ optimization, and now `generic-deriving` does too).
+* Add a `Generics.Deriving.Default` module demonstrating and explaining
+ how and why to use `DerivingVia`. There is also a test suite with
+ further examples.
+
# 1.12.2 [2018.06.28]
* Backport the `Generic(1)` instances for `Data.Ord.Down`, introduced in
`base-4.12`. Add `GEq`, `GShow`, `GSemigroup`, `GMonoid`, `GFunctor`,
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/generic-deriving-1.12.2/generic-deriving.cabal
new/generic-deriving-1.12.3/generic-deriving.cabal
--- old/generic-deriving-1.12.2/generic-deriving.cabal 2018-06-28
16:44:14.000000000 +0200
+++ new/generic-deriving-1.12.3/generic-deriving.cabal 2001-09-09
03:46:40.000000000 +0200
@@ -1,5 +1,5 @@
name: generic-deriving
-version: 1.12.2
+version: 1.12.3
synopsis: Generic programming library for generalised deriving.
description:
@@ -33,7 +33,8 @@
, GHC == 7.10.3
, GHC == 8.0.2
, GHC == 8.2.2
- , GHC == 8.4.3
+ , GHC == 8.4.4
+ , GHC == 8.6.3
extra-source-files: CHANGELOG.md
, README.md
@@ -53,6 +54,7 @@
Generics.Deriving.Instances
Generics.Deriving.Copoint
Generics.Deriving.ConNames
+ Generics.Deriving.Default
Generics.Deriving.Enum
Generics.Deriving.Eq
Generics.Deriving.Foldable
@@ -75,10 +77,10 @@
build-depends: base >= 4.3 && < 4.9
other-modules: Generics.Deriving.TH.Pre4_9
- build-depends: containers >= 0.1 && < 0.6
+ build-depends: containers >= 0.1 && < 0.7
, ghc-prim < 1
- , template-haskell >= 2.4 && < 2.14
- , th-abstraction >= 0.2.7 && < 0.3
+ , template-haskell >= 2.4 && < 2.15
+ , th-abstraction >= 0.2.9 && < 0.3
default-language: Haskell2010
ghc-options: -Wall
@@ -86,13 +88,14 @@
test-suite spec
type: exitcode-stdio-1.0
main-is: Spec.hs
- other-modules: EmptyCaseSpec
+ other-modules: DefaultSpec
+ EmptyCaseSpec
ExampleSpec
TypeInTypeSpec
build-depends: base >= 4.3 && < 5
, generic-deriving
, hspec >= 2 && < 3
- , template-haskell >= 2.4 && < 2.14
+ , template-haskell >= 2.4 && < 2.15
build-tool-depends: hspec-discover:hspec-discover
hs-source-dirs: tests
default-language: Haskell2010
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/generic-deriving-1.12.2/src/Generics/Deriving/Default.hs
new/generic-deriving-1.12.3/src/Generics/Deriving/Default.hs
--- old/generic-deriving-1.12.2/src/Generics/Deriving/Default.hs
1970-01-01 01:00:00.000000000 +0100
+++ new/generic-deriving-1.12.3/src/Generics/Deriving/Default.hs
2001-09-09 03:46:40.000000000 +0200
@@ -0,0 +1,277 @@
+-- |
+-- Module : Generics.Deriving.Default
+-- Description : Default implementations of generic classes
+-- License : BSD-3-Clause
+--
+-- Maintainer : [email protected]
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- GHC 8.6 introduced the
+--
@<https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/glasgow_exts.html?highlight=derivingvia#extension-DerivingVia
DerivingVia>@
+-- language extension, which means a typeclass instance can be derived from
+-- an existing instance for an isomorphic type. Any newtype is isomorphic
+-- to the underlying type. By implementing a typeclass once for the newtype,
+-- it is possible to derive any typeclass for any type with a 'Generic'
instance.
+--
+-- For a number of classes, there are sensible default instantiations. In
+-- older GHCs, these can be supplied in the class definition, using the
+--
@<https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/glasgow_exts.html?highlight=defaultsignatures#extension-DefaultSignatures
DefaultSignatures>@
+-- extension. However, only one default can be provided! With
+--
@<https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/glasgow_exts.html?highlight=derivingvia#extension-DerivingVia
DerivingVia>@
+-- it is now possible to choose from many
+-- default instantiations.
+--
+-- This package contains a number of such classes. This module demonstrates
+-- how one might create a family of newtypes ('Default', 'Default1') for
+-- which such instances are defined.
+--
+-- One might then use
+--
@<https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/glasgow_exts.html?highlight=derivingvia#extension-DerivingVia
DerivingVia>@
+-- as follows. The implementations of the data types are elided here (they
+-- are irrelevant). For most cases, either the deriving clause with the
+-- data type definition or the standalone clause will work (for some types
+-- it is necessary to supply the context explicitly using the latter form).
+-- See the source of this module for the implementations of instances for
+-- the 'Default' family of newtypes and the source of the test suite for
+-- some types which derive instances via these wrappers.
+
+{-# LANGUAGE CPP #-}
+#if __GLASGOW_HASKELL__ >= 701
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE Safe #-}
+#endif
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Generics.Deriving.Default
+ ( -- * Kind @*@ (aka @Type@)
+
+ -- $default
+
+ Default(..)
+
+ , -- * Kind @* -> *@ (aka @Type -> Type@)
+
+ -- $default1
+
+ Default1(..)
+
+ -- * Other kinds
+
+ -- $other-kinds
+ ) where
+
+#if !(MIN_VERSION_base(4,8,0))
+import Control.Applicative ((<$>))
+#endif
+import Control.Monad (liftM)
+
+import Generics.Deriving.Base
+import Generics.Deriving.Copoint
+import Generics.Deriving.Enum
+import Generics.Deriving.Eq
+import Generics.Deriving.Foldable
+import Generics.Deriving.Functor
+import Generics.Deriving.Monoid
+import Generics.Deriving.Semigroup
+import Generics.Deriving.Show
+import Generics.Deriving.Traversable
+import Generics.Deriving.Uniplate
+
+-- $default
+--
+-- For classes which take an argument of kind 'Data.Kind.Type', use
+-- 'Default'. An example of this class from @base@ would be 'Eq', or
+-- 'Generic'.
+--
+-- These examples use 'GShow' and 'GEq'; they are interchangeable.
+--
+-- @
+-- data MyType = …
+-- deriving ('Generic')
+-- deriving ('GEq') via ('Default' MyType)
+--
+-- deriving via ('Default' MyType) instance 'GShow' MyType
+-- @
+--
+-- Instances may be parameterized by type variables.
+--
+-- @
+-- data MyType1 a = …
+-- deriving ('Generic')
+-- deriving ('GShow') via ('Default' (MyType1 a))
+--
+-- deriving via 'Default' (MyType1 a) instance 'GEq' a => 'GEq' (MyType1 a)
+-- @
+--
+-- These types both require instances for 'Generic'. This is because the
+-- implementations of 'geq' and 'gshowsPrec' for @'Default' b@ have a
@'Generic'
+-- b@ constraint, i.e. the type corresponding to @b@ require a 'Generic'
+-- instance. For these two types, that means instances for @'Generic' MyType@
+-- and @'Generic' (MyType1 a)@ respectively.
+--
+-- It also means the 'Generic' instance is not needed when there is already
+-- a generic instance for the type used to derive the relevant instances.
+-- For an example, see the documentation of the 'GShow' instance for
+-- 'Default', below.
+
+-- | This newtype wrapper can be used to derive default instances for
+-- classes taking an argument of kind 'Data.Kind.Type'.
+newtype Default a = Default { unDefault :: a }
+
+-- $default1
+--
+-- For classes which take an argument of kind @'Data.Kind.Type' ->
+-- 'Data.Kind.Type'@, use 'Default1'. An example of this class from @base@
+-- would be 'Data.Functor.Classes.Eq1', or 'Generic1'.
+--
+-- Unlike for @MyType1@, there can be no implementation of these classes for
@MyType :: 'Data.Kind.Type'@.
+--
+-- @
+-- data MyType1 a = …
+-- deriving ('Generic1')
+-- deriving ('GFunctor') via ('Default1' MyType1)
+--
+-- deriving via ('Default1' MyType1) instance 'GFoldable' MyType1
+-- @
+--
+-- Note that these instances require a @'Generic1' MyType1@ constraint as
+-- 'gmap' and 'gfoldMap' have @'Generic1' a@ constraints on the
+-- implementations for @'Default1' a@.
+
+-- | This newtype wrapper can be used to derive default instances for
+-- classes taking an argument of kind @'Data.Kind.Type' -> 'Data.Kind.Type'@.
+newtype Default1 f a = Default1 { unDefault1 :: f a }
+
+-- $other-kinds
+--
+-- These principles extend to classes taking arguments of other kinds.
+
+--------------------------------------------------------------------------------
+-- Eq
+--------------------------------------------------------------------------------
+
+instance (Generic a, GEq' (Rep a)) => GEq (Default a) where
+ -- geq :: Default a -> Default a -> Bool
+ Default x `geq` Default y = x `geqdefault` y
+
+--------------------------------------------------------------------------------
+-- Enum
+--------------------------------------------------------------------------------
+
+-- | The 'Enum' class in @base@ is slightly different; it comprises 'toEnum'
and
+-- 'fromEnum'. "Generics.Deriving.Enum" provides functions 'toEnumDefault'
+-- and 'fromEnumDefault'.
+instance (Generic a, GEq a, Enum' (Rep a)) => GEnum (Default a) where
+ -- genum :: [Default a]
+ genum = Default . to <$> enum'
+
+--------------------------------------------------------------------------------
+-- Show
+--------------------------------------------------------------------------------
+
+-- | For example, with this type:
+--
+-- @
+-- newtype TestShow = TestShow 'Bool'
+-- deriving ('GShow') via ('Default' 'Bool')
+-- @
+--
+-- 'gshow' for @TestShow@ would produce the same string as `gshow` for
+-- 'Bool'.
+--
+-- In this example, @TestShow@ requires no 'Generic' instance, as the
+-- constraint on 'gshowsPrec' from @'Default' 'Bool'@ is @'Generic' 'Bool'@.
+--
+-- In general, when using a newtype wrapper, the instance can be derived
+-- via the wrapped type, as here (via @'Default' 'Bool'@ rather than @'Default'
+-- TestShow@).
+instance (Generic a, GShow' (Rep a)) => GShow (Default a) where
+ -- gshowsPrec :: Int -> Default a -> ShowS
+ gshowsPrec n (Default x) = gshowsPrecdefault n x
+
+--------------------------------------------------------------------------------
+-- Semigroup
+--------------------------------------------------------------------------------
+
+-- | Semigroups often have many sensible implementations of
+-- 'Data.Semigroup.<>' / 'gsappend', and therefore no sensible default.
+-- Indeed, there is no 'GSemigroup'' instance for representations of sum
+-- types.
+--
+-- In other cases, one may wish to use the existing wrapper newtypes in
+-- @base@, such as the following (using 'Data.Semigroup.First'):
+--
+-- @
+-- newtype FirstSemigroup = FirstSemigroup 'Bool'
+-- deriving stock ('Eq', 'Show')
+-- deriving ('GSemigroup') via ('Data.Semigroup.First' 'Bool')
+-- @
+--
+instance (Generic a, GSemigroup' (Rep a)) => GSemigroup (Default a) where
+ -- gsappend :: Default a -> Default a -> Default a
+ Default x `gsappend` Default y = Default $ x `gsappenddefault` y
+
+--------------------------------------------------------------------------------
+-- Monoid
+--------------------------------------------------------------------------------
+
+instance (Generic a, GMonoid' (Rep a)) => GMonoid (Default a) where
+ -- gmempty :: Default a
+ gmempty = Default gmemptydefault
+
+ -- gmappend :: Default a -> Default a -> Default a
+ Default x `gmappend` Default y = Default $ x `gmappenddefault` y
+
+--------------------------------------------------------------------------------
+-- Uniplate
+--------------------------------------------------------------------------------
+
+instance (Generic a, Uniplate' (Rep a) a, Context' (Rep a) a) => Uniplate
(Default a) where
+
+ -- children :: Default a ->
[Default a]
+ -- context :: Default a -> [Default a] ->
Default a
+ -- descend :: (Default a -> Default a) -> Default a ->
Default a
+ -- descendM :: Monad m => (Default a -> m (Default a)) -> Default a -> m
(Default a)
+ -- transform :: (Default a -> Default a) -> Default a ->
Default a
+ -- transformM :: Monad m => (Default a -> m (Default a)) -> Default a -> m
(Default a)
+
+ children (Default x) = Default <$> childrendefault x
+ context (Default x) ys = Default $ contextdefault x
(unDefault <$> ys)
+ descend f (Default x) = Default $ descenddefault
(unDefault . f . Default) x
+ descendM f (Default x) = liftM Default $ descendMdefault (liftM
unDefault . f . Default) x
+ transform f (Default x) = Default $ transformdefault
(unDefault . f . Default) x
+ transformM f (Default x) = liftM Default $ transformMdefault (liftM
unDefault . f . Default) x
+
+--------------------------------------------------------------------------------
+-- Functor
+--------------------------------------------------------------------------------
+
+instance (Generic1 f, GFunctor' (Rep1 f)) => GFunctor (Default1 f) where
+ -- gmap :: (a -> b) -> (Default1 f) a -> (Default1 f) b
+ gmap f (Default1 fx) = Default1 $ gmapdefault f fx
+
+--------------------------------------------------
+-- Copoint
+--------------------------------------------------
+
+instance (Generic1 f, GCopoint' (Rep1 f)) => GCopoint (Default1 f) where
+ -- gcopoint :: Default1 f a -> a
+ gcopoint = gcopointdefault . unDefault1
+
+--------------------------------------------------
+-- Foldable
+--------------------------------------------------
+
+instance (Generic1 t, GFoldable' (Rep1 t)) => GFoldable (Default1 t) where
+ -- gfoldMap :: Monoid m => (a -> m) -> Default1 t a -> m
+ gfoldMap f (Default1 tx) = gfoldMapdefault f tx
+
+--------------------------------------------------
+-- Traversable
+--------------------------------------------------
+
+instance (Generic1 t, GFunctor' (Rep1 t), GFoldable' (Rep1 t), GTraversable'
(Rep1 t)) => GTraversable (Default1 t) where
+ -- gtraverse :: Applicative f => (a -> f b) -> Default1 t a -> f (Default1 t
b)
+ gtraverse f (Default1 fx) = Default1 <$> gtraversedefault f fx
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/generic-deriving-1.12.2/src/Generics/Deriving/Show.hs
new/generic-deriving-1.12.3/src/Generics/Deriving/Show.hs
--- old/generic-deriving-1.12.2/src/Generics/Deriving/Show.hs 2018-06-28
16:44:14.000000000 +0200
+++ new/generic-deriving-1.12.3/src/Generics/Deriving/Show.hs 2001-09-09
03:46:40.000000000 +0200
@@ -16,10 +16,6 @@
{-# LANGUAGE EmptyCase #-}
#endif
-#if __GLASGOW_HASKELL__ < 709
-{-# LANGUAGE OverlappingInstances #-}
-#endif
-
module Generics.Deriving.Show (
-- * Generic show class
GShow(..)
@@ -32,7 +28,7 @@
) where
-import Control.Applicative (Const, ZipList)
+import Control.Applicative (Const, ZipList)
import Data.Char (GeneralCategory)
import Data.Int
@@ -181,16 +177,24 @@
class GShow a where
gshowsPrec :: Int -> a -> ShowS
- gshows :: a -> ShowS
- gshows = gshowsPrec 0
- gshow :: a -> String
- gshow x = gshows x ""
#if __GLASGOW_HASKELL__ >= 701
default gshowsPrec :: (Generic a, GShow' (Rep a))
=> Int -> a -> ShowS
gshowsPrec = gshowsPrecdefault
#endif
+ gshows :: a -> ShowS
+ gshows = gshowsPrec 0
+
+ gshow :: a -> String
+ gshow x = gshows x ""
+
+ gshowList :: [a] -> ShowS
+ gshowList l = showChar '['
+ . foldr (.) id
+ (intersperse (showChar ',') (map (gshowsPrec 0) l))
+ . showChar ']'
+
gshowsPrecdefault :: (Generic a, GShow' (Rep a))
=> Int -> a -> ShowS
gshowsPrecdefault n = gshowsPrec' Pref n . from
@@ -221,15 +225,8 @@
=> GShow (a, b, c, d, e, f, g) where
gshowsPrec = gshowsPrecdefault
-instance
-#if __GLASGOW_HASKELL__ >= 709
- {-# OVERLAPPABLE #-}
-#endif
- (GShow a) => GShow [a] where
- gshowsPrec _ l = showChar '['
- . foldr (.) id
- (intersperse (showChar ',') (map (gshowsPrec 0) l))
- . showChar ']'
+instance GShow a => GShow [a] where
+ gshowsPrec _ = gshowList
instance (GShow (f p), GShow (g p)) => GShow ((f :+: g) p) where
gshowsPrec = gshowsPrecdefault
@@ -299,6 +296,7 @@
instance GShow Char where
gshowsPrec = showsPrec
+ gshowList = showList
#if defined(HTYPE_INO_T)
instance GShow CIno where
@@ -570,13 +568,6 @@
instance GShow SeekMode where
gshowsPrec = showsPrec
-instance
-#if __GLASGOW_HASKELL__ >= 709
- {-# OVERLAPPING #-}
-#endif
- GShow String where
- gshowsPrec = showsPrec
-
instance GShow a => GShow (Sum a) where
gshowsPrec = gshowsPrecdefault
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/generic-deriving-1.12.2/src/Generics/Deriving/TH/Internal.hs
new/generic-deriving-1.12.3/src/Generics/Deriving/TH/Internal.hs
--- old/generic-deriving-1.12.2/src/Generics/Deriving/TH/Internal.hs
2018-06-28 16:44:14.000000000 +0200
+++ new/generic-deriving-1.12.3/src/Generics/Deriving/TH/Internal.hs
2001-09-09 03:46:40.000000000 +0200
@@ -30,11 +30,6 @@
import Language.Haskell.TH.Ppr (pprint)
import Language.Haskell.TH.Syntax
-#if !(MIN_VERSION_base(4,8,0))
-import Data.Foldable (Foldable(foldMap))
-import Data.Monoid (Monoid(..))
-#endif
-
#ifndef CURRENT_PACKAGE_KEY
import Data.Version (showVersion)
import Paths_generic_deriving (version)
@@ -104,45 +99,6 @@
#endif
hasKindStar _ = False
--- | Gets all of the required type/kind variable binders mentioned in a Type.
--- This does not add separate items for kind variable binders (in contrast with
--- the behavior of 'freeVariables').
-requiredTyVarsOfTypes :: [Type] -> [TyVarBndr]
-requiredTyVarsOfTypes tys =
- let fvs :: [Name]
- fvs = nub $ concatMap freeVariables tys
-
- varKindSigs :: Map Name Kind
- varKindSigs = foldMap go tys
- where
- go :: Type -> Map Name Kind
- go (ForallT {}) = error "`forall` type used in type family pattern"
- go (AppT t1 t2) = go t1 `mappend` go t2
- go (SigT t k) =
- let kSigs =
-#if MIN_VERSION_template_haskell(2,8,0)
- go k
-#else
- mempty
-#endif
- in case t of
- VarT n -> Map.insert n k kSigs
- _ -> go t `mappend` kSigs
- go _ = mempty
-
- ascribeWithKind n
- | Just k <- Map.lookup n varKindSigs
- = KindedTV n k
- | otherwise
- = PlainTV n
-
- isKindBinder = (`Set.member` kindVars)
- where
- kindVars = Set.fromList $ concatMap freeVariables $ Map.elems
varKindSigs
-
- in map ascribeWithKind $
- filter (not . isKindBinder) fvs
-
-- | Converts a VarT or a SigT into Just the corresponding TyVarBndr.
-- Converts other Types to Nothing.
typeToTyVarBndr :: Type -> Maybe TyVarBndr
@@ -379,11 +335,11 @@
shrink :: (a, b, c) -> (b, c)
shrink (_, b, c) = (b, c)
--- | Variant of foldr1 which returns a special element for empty lists
-foldr1' :: (a -> a -> a) -> a -> [a] -> a
-foldr1' _ x [] = x
-foldr1' _ _ [x] = x
-foldr1' f x (h:t) = f h (foldr1' f x t)
+foldBal :: (a -> a -> a) -> a -> [a] -> a
+foldBal _ x [] = x
+foldBal _ _ [y] = y
+foldBal op x l = let (a,b) = splitAt (length l `div` 2) l
+ in foldBal op x a `op` foldBal op x b
isNewtypeVariant :: DatatypeVariant_ -> Bool
isNewtypeVariant Datatype_ = False
@@ -391,22 +347,6 @@
isNewtypeVariant (DataInstance_ {}) = False
isNewtypeVariant (NewtypeInstance_ {}) = True
-#if MIN_VERSION_template_haskell(2,7,0)
--- | Extracts the constructors of a data or newtype declaration.
-dataDecCons :: Dec -> [Con]
-dataDecCons (DataInstD _ _ _
-# if MIN_VERSION_template_haskell(2,11,0)
- _
-# endif
- cons _) = cons
-dataDecCons (NewtypeInstD _ _ _
-# if MIN_VERSION_template_haskell(2,11,0)
- _
-# endif
- con _) = [con]
-dataDecCons _ = error "Must be a data or newtype declaration."
-#endif
-
-- | Indicates whether Generic or Generic1 is being derived.
data GenericClass = Generic | Generic1 deriving Enum
@@ -424,8 +364,8 @@
genericKind :: GenericClass -> [Type] -> ([TyVarBndr], GenericKind)
genericKind gClass tySynVars =
case gClass of
- Generic -> (requiredTyVarsOfTypes tySynVars, Gen0)
- Generic1 -> (requiredTyVarsOfTypes initArgs, Gen1 (varTToName lastArg)
mbLastArgKindName)
+ Generic -> (freeVariablesWellScoped tySynVars, Gen0)
+ Generic1 -> (freeVariablesWellScoped initArgs, Gen1 (varTToName lastArg)
mbLastArgKindName)
where
-- Everything below is only used for Generic1.
initArgs :: [Type]
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/generic-deriving-1.12.2/src/Generics/Deriving/TH.hs
new/generic-deriving-1.12.3/src/Generics/Deriving/TH.hs
--- old/generic-deriving-1.12.2/src/Generics/Deriving/TH.hs 2018-06-28
16:44:14.000000000 +0200
+++ new/generic-deriving-1.12.3/src/Generics/Deriving/TH.hs 2001-09-09
03:46:40.000000000 +0200
@@ -345,13 +345,8 @@
let origSigTy = if useKindSigs
then SigT origTy origKind
else origTy
- tyIns = TySynInstD repName
-#if MIN_VERSION_template_haskell(2,9,0)
- (TySynEqn [origSigTy] tyInsRHS)
-#else
- [origSigTy] tyInsRHS
-#endif
- ecOptions = emptyCaseOptions opts
+ tyIns <- tySynInstDCompat repName [return origSigTy] (return tyInsRHS)
+ let ecOptions = emptyCaseOptions opts
mkBody maker = [clause [] (normalB $
mkCaseExp gClass ecOptions name instTys cons maker) []]
fcs = mkBody mkFrom
@@ -570,7 +565,7 @@
-> Type
-> Q Type
makeRepInline gClass dv name instTys cons ty = do
- let instVars = requiredTyVarsOfTypes [ty]
+ let instVars = freeVariablesWellScoped [ty]
(tySynVars, gk) = genericKind gClass instTys
typeSubst :: TypeSubst
@@ -587,7 +582,7 @@
-- of the LHS of the Rep(1) instance. We call unKindedTV because the kind
-- inferencer can figure out the kinds perfectly well, so we don't need to
-- give anything here explicit kind signatures.
- let instTvbs = map unKindedTV $ requiredTyVarsOfTypes [ty]
+ let instTvbs = map unKindedTV $ freeVariablesWellScoped [ty]
in return $ applyTyToTvbs (genRepName gClass dv name) instTvbs
-- | A backwards-compatible synonym for 'makeFrom0'.
@@ -659,8 +654,7 @@
-> Q Type
repType gk dv dt typeSubst cs =
conT d1TypeName `appT` mkMetaDataType dv dt `appT`
- foldr1' sum' (conT v1TypeName)
- (map (repCon gk dv dt typeSubst) cs)
+ foldBal sum' (conT v1TypeName) (map (repCon gk dv dt typeSubst) cs)
where
sum' :: Q Type -> Q Type -> Q Type
sum' a b = conT sumTypeName `appT` a `appT` b
@@ -708,9 +702,7 @@
-> Q Type
repConWith gk dv dt n typeSubst mbSelNames ssis ts isRecord isInfix = do
let structureType :: Q Type
- structureType = case ssis of
- [] -> conT u1TypeName
- _ -> foldr1 prodT f
+ structureType = foldBal prodT (conT u1TypeName) f
f :: [Q Type]
f = case mbSelNames of
@@ -795,7 +787,7 @@
-> Q Exp
mkCaseExp gClass ecOptions dt instTys cs matchmaker = do
val <- newName "val"
- lam1E (varP val) $ caseE (varE val) [matchmaker gClass ecOptions 1 0 dt
instTys cs]
+ lam1E (varP val) $ caseE (varE val) [matchmaker gClass ecOptions 1 1 dt
instTys cs]
mkFrom :: GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]
-> [ConstructorInfo] -> Q Match
@@ -807,8 +799,8 @@
where
cases = case cs of
[] -> errorFrom ecOptions dt
- _ -> zipWith (fromCon gk wrapE (length cs)) [0..] cs
- wrapE e = lrE m i e
+ _ -> zipWith (fromCon gk wrapE (length cs)) [1..] cs
+ wrapE e = lrE i m e
(_, gk) = genericKind gClass instTys
errorFrom :: EmptyCaseOptions -> Name -> [Q Match]
@@ -836,8 +828,8 @@
where
cases = case cs of
[] -> errorTo ecOptions dt
- _ -> zipWith (toCon gk wrapP (length cs)) [0..] cs
- wrapP p = lrP m i p
+ _ -> zipWith (toCon gk wrapP (length cs)) [1..] cs
+ wrapP p = lrP i m p
(_, gk) = genericKind gClass instTys
errorTo :: EmptyCaseOptions -> Name -> [Q Match]
@@ -870,15 +862,10 @@
, constructorFields = ts
}) = do
checkExistentialContext cn vars ctxt
- case ts of
- [] -> match (conP cn [])
- (normalB $ wrap $ lrE m i $ conE m1DataName `appE` (conE
u1DataName)) []
- _ -> do
- fNames <- newNameList "f" $ length ts
- match
- (conP cn (map varP fNames))
- (normalB $ wrap $ lrE m i $ conE m1DataName `appE`
- foldr1 prodE (zipWith (fromField gk) fNames ts)) []
+ fNames <- newNameList "f" $ length ts
+ match (conP cn (map varP fNames))
+ (normalB $ wrap $ lrE i m $ conE m1DataName `appE`
+ foldBal prodE (conE u1DataName) (zipWith (fromField gk) fNames ts))
[]
prodE :: Q Exp -> Q Exp -> Q Exp
prodE x y = conE productDataName `appE` x `appE` y
@@ -931,14 +918,9 @@
, constructorFields = ts
}) = do
checkExistentialContext cn vars ctxt
- case ts of
- [] -> match (wrap $ lrP m i $ conP m1DataName [conP u1DataName []])
- (normalB $ conE cn) []
- _ -> do
- fNames <- newNameList "f" $ length ts
- match
- (wrap $ lrP m i $ conP m1DataName
- [foldr1 prod (zipWith (toField gk) fNames ts)])
+ fNames <- newNameList "f" $ length ts
+ match (wrap $ lrP i m $ conP m1DataName
+ [foldBal prod (conP u1DataName []) (zipWith (toField gk) fNames ts)])
(normalB $ foldl appE (conE cn)
(zipWith (\nr -> resolveTypeSynonyms >=> toConUnwC gk
nr)
fNames ts)) []
@@ -987,14 +969,20 @@
unboxRepName = maybe unK1ValName trd3 . unboxedRepNames
lrP :: Int -> Int -> (Q Pat -> Q Pat)
-lrP 1 0 p = p
-lrP _ 0 p = conP l1DataName [p]
-lrP m i p = conP r1DataName [lrP (m-1) (i-1) p]
+lrP i n p
+ | n == 0 = fail "lrP: impossible"
+ | n == 1 = p
+ | i <= div n 2 = conP l1DataName [lrP i (div n 2) p]
+ | otherwise = conP r1DataName [lrP (i-m) (n-m) p]
+ where m = div n 2
lrE :: Int -> Int -> (Q Exp -> Q Exp)
-lrE 1 0 e = e
-lrE _ 0 e = conE l1DataName `appE` e
-lrE m i e = conE r1DataName `appE` lrE (m-1) (i-1) e
+lrE i n e
+ | n == 0 = fail "lrE: impossible"
+ | n == 1 = e
+ | i <= div n 2 = conE l1DataName `appE` lrE i (div n 2) e
+ | otherwise = conE r1DataName `appE` lrE (i-m) (n-m) e
+ where m = div n 2
unboxedRepNames :: Type -> Maybe (Name, Name, Name)
unboxedRepNames ty
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore'
old/generic-deriving-1.12.2/src/Generics/Deriving/Uniplate.hs
new/generic-deriving-1.12.3/src/Generics/Deriving/Uniplate.hs
--- old/generic-deriving-1.12.2/src/Generics/Deriving/Uniplate.hs
2018-06-28 16:44:14.000000000 +0200
+++ new/generic-deriving-1.12.3/src/Generics/Deriving/Uniplate.hs
2001-09-09 03:46:40.000000000 +0200
@@ -54,6 +54,9 @@
-- * Internal Uniplate class
, Uniplate'(..)
+
+ -- * Internal Context class
+ , Context'(..)
) where
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/generic-deriving-1.12.2/src/Generics/Deriving.hs
new/generic-deriving-1.12.3/src/Generics/Deriving.hs
--- old/generic-deriving-1.12.2/src/Generics/Deriving.hs 2018-06-28
16:44:14.000000000 +0200
+++ new/generic-deriving-1.12.3/src/Generics/Deriving.hs 2001-09-09
03:46:40.000000000 +0200
@@ -4,6 +4,7 @@
module Generics.Deriving.Base,
module Generics.Deriving.Copoint,
module Generics.Deriving.ConNames,
+ module Generics.Deriving.Default,
module Generics.Deriving.Enum,
module Generics.Deriving.Eq,
module Generics.Deriving.Functor,
@@ -15,6 +16,7 @@
import Generics.Deriving.Base
import Generics.Deriving.Copoint
import Generics.Deriving.ConNames
+import Generics.Deriving.Default
import Generics.Deriving.Enum
import Generics.Deriving.Eq
import Generics.Deriving.Functor
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/generic-deriving-1.12.2/tests/DefaultSpec.hs
new/generic-deriving-1.12.3/tests/DefaultSpec.hs
--- old/generic-deriving-1.12.2/tests/DefaultSpec.hs 1970-01-01
01:00:00.000000000 +0100
+++ new/generic-deriving-1.12.3/tests/DefaultSpec.hs 2001-09-09
03:46:40.000000000 +0200
@@ -0,0 +1,161 @@
+-- |
+-- Module : DefaultSpec
+-- Description : Ensure that deriving via (Default a) newtype works
+-- License : BSD-3-Clause
+--
+-- Maintainer : [email protected]
+-- Stability : experimental
+-- Portability : non-portable
+--
+-- Tests DerivingVia on GHC versions 8.6 and above. There are no tests on
+-- versions below.
+--
+-- The test check a miscellany of properties of the derived type classes.
+-- (Testing all the required properties is beyond the scope of this module.)
+{-# LANGUAGE CPP #-}
+#if __GLASGOW_HASKELL__ >= 806
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+#endif
+
+module DefaultSpec where
+
+import Test.Hspec
+
+#if __GLASGOW_HASKELL__ >= 806
+import Test.Hspec.QuickCheck
+
+import Data.Semigroup (First(..), Option(..))
+import Data.Foldable (sequenceA_)
+import Generics.Deriving hiding (universe)
+import Generics.Deriving.Default ()
+import Generics.Deriving.Foldable (GFoldable(..))
+import Generics.Deriving.Semigroup (GSemigroup(..))
+#endif
+
+spec :: Spec
+spec = do
+ describe "DerivingVia Default" $ do
+
+#if __GLASGOW_HASKELL__ >= 806
+ it "GEq is commutative for derivingVia (Default MyType)" . sequenceA_ $
+ let commutative :: GEq a => a -> a -> Expectation
+ commutative x y = x `geq` y `shouldBe` y `geq` x
+
+ universe :: [MyType]
+ universe = MyType <$> [False, True]
+
+ in commutative <$> universe <*> universe
+
+ it "GShow for MyType is like Show for Bool with derivingVia (Default
MyType) but prefixed with 'MyType '" $ do
+ gshowsPrec 0 (MyType False) "" `shouldBe` "MyType " <> showsPrec 0 False
""
+ gshowsPrec 0 (MyType True) "" `shouldBe` "MyType " <> showsPrec 0 True ""
+
+ it "GEq is commutative for parameterized derivingVia (Default (MyType1
Bool))" . sequenceA_ $
+ let commutative :: GEq a => a -> a -> Expectation
+ commutative x y = x `geq` y `shouldBe` y `geq` x
+
+ universe :: [MyType1 Bool]
+ universe = MyType1 <$> [False, True]
+
+ in commutative <$> universe <*> universe
+
+ it "GShow for MyType1 Bool is like Show for Bool with derivingVia (Default
(MyType1 Bool)) but prefixed with 'MyType1 '" $ do
+ gshowsPrec 0 (MyType1 False) "" `shouldBe` "MyType1 " <> showsPrec 0
False ""
+ gshowsPrec 0 (MyType1 True) "" `shouldBe` "MyType1 " <> showsPrec 0 True
""
+
+ it "GEq is commutative for derivingVia (Default Bool)" . sequenceA_ $
+ let commutative :: GEq a => a -> a -> Expectation
+ commutative x y = x `geq` y `shouldBe` y `geq` x
+
+ universe :: [TestEq]
+ universe = TestEq <$> [False, True]
+
+ in commutative <$> universe <*> universe
+
+ it "GENum is correct for derivingVia (Default Bool)" $
+ genum `shouldBe` [TestEnum False, TestEnum True]
+
+ it "GShow for TestShow is the same as Show for Bool with derivingVia
(Default Bool)" $ do
+ gshowsPrec 0 (TestShow False) "" `shouldBe` showsPrec 0 False ""
+ gshowsPrec 0 (TestShow True) "" `shouldBe` showsPrec 0 True ""
+
+ it "GSemigroup is like First when instantiated with derivingVia (First
Bool)" . sequenceA_ $
+ let first' :: (Eq a, Show a, GSemigroup a) => a -> a -> Expectation
+ first' x y = x `gsappend` y `shouldBe` x
+
+ universe :: [FirstSemigroup]
+ universe = FirstSemigroup <$> [False, True]
+
+ in first' <$> universe <*> universe
+
+ prop "GFoldable with derivingVia (Default1 Option) acts like mconcat with
Maybe (First Bool)" $ \(xs :: [Maybe Bool]) ->
+ let ys :: [Maybe (First Bool)]
+ -- Note that there is no Arbitrary instance for this type
+ ys = fmap First <$> xs
+
+ unTestFoldable :: TestFoldable a -> Maybe a
+ unTestFoldable (TestFoldable x) = x
+
+ in gfoldMap unTestFoldable (TestFoldable <$> ys) `shouldBe` mconcat ys
+
+ it "GFunctor for TestFunctor Bool is as Functor for Maybe Bool" .
sequenceA_ $
+ let universe :: [Maybe Bool]
+ universe = [Nothing, Just False, Just True]
+
+ functor_prop :: Maybe Bool -> Expectation
+ functor_prop x = gmap not (TestFunctor x) `shouldBe` TestFunctor
(not <$> x)
+
+ in functor_prop <$> universe
+
+#endif
+ return ()
+
+#if __GLASGOW_HASKELL__ >= 806
+
+-- These types all implement instances using `DerivingVia`: most via
+-- `Default` (one uses `First`).
+
+newtype TestEq = TestEq Bool
+ deriving (GEq) via (Default Bool)
+newtype TestEnum = TestEnum Bool
+ deriving stock (Eq, Show)
+ deriving (GEnum) via (Default Bool)
+newtype TestShow = TestShow Bool
+ deriving (GShow) via (Default Bool)
+
+newtype FirstSemigroup = FirstSemigroup Bool
+ deriving stock (Eq, Show)
+ deriving (GSemigroup) via (First Bool)
+
+newtype TestFoldable a = TestFoldable (Maybe a)
+ deriving (GFoldable) via (Default1 Option)
+
+newtype TestFunctor a = TestFunctor (Maybe a)
+ deriving stock (Eq, Show, Functor)
+ deriving (GFunctor) via (Default1 Maybe)
+
+newtype TestHigherEq a = TestHigherEq (Maybe a)
+ deriving stock (Generic)
+ deriving (GEq) via (Default (TestHigherEq a))
+
+-- These types correspond to the hypothetical examples in the module
+-- documentation.
+
+data MyType = MyType Bool
+ deriving (Generic)
+ deriving (GEq) via (Default MyType)
+
+deriving via (Default MyType) instance GShow MyType
+
+data MyType1 a = MyType1 a
+ deriving (Generic, Generic1)
+ deriving (GEq) via (Default (MyType1 a))
+ deriving (GFunctor) via (Default1 MyType1)
+
+deriving via Default (MyType1 a) instance GShow a => GShow (MyType1 a)
+deriving via (Default1 MyType1) instance GFoldable MyType1
+#endif
