generic-deriving 1.12.2 → 1.12.3

raw patch · 9 files changed

+519/−141 lines, 9 filesdep ~th-abstractionPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: th-abstraction

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−0
• generic-deriving.cabal +10/−7
• src/Generics/Deriving.hs +2/−0
• src/Generics/Deriving/Default.hs +277/−0
• src/Generics/Deriving/Show.hs +16/−25
• src/Generics/Deriving/TH.hs +30/−42
• src/Generics/Deriving/TH/Internal.hs +7/−67
• src/Generics/Deriving/Uniplate.hs +3/−0
• tests/DefaultSpec.hs +161/−0

@@ -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`,

@@ -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

@@ -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

@@ -0,0 +1,277 @@+-- |+-- Module      : Generics.Deriving.Default+-- Description : Default implementations of generic classes+-- License     : BSD-3-Clause+--+-- Maintainer  : generics@haskell.org+-- 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

@@ -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@@ -568,13 +566,6 @@   gshowsPrec = gshowsPrecdefault  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

@@ -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

@@ -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]

@@ -54,6 +54,9 @@    -- * Internal Uniplate class   , Uniplate'(..)++  -- * Internal Context class+  , Context'(..)   ) where  

@@ -0,0 +1,161 @@+-- |+-- Module      : DefaultSpec+-- Description : Ensure that deriving via (Default a) newtype works+-- License     : BSD-3-Clause+--+-- Maintainer  : generics@haskell.org+-- 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