diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 --git a/generic-deriving.cabal b/generic-deriving.cabal --- a/generic-deriving.cabal +++ b/generic-deriving.cabal @@ -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 --git a/src/Generics/Deriving.hs b/src/Generics/Deriving.hs --- a/src/Generics/Deriving.hs +++ b/src/Generics/Deriving.hs @@ -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 --git a/src/Generics/Deriving/Default.hs b/src/Generics/Deriving/Default.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Deriving/Default.hs @@ -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 +-- @@ +-- 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 +-- @@ +-- extension. However, only one default can be provided! With +-- @@ +-- 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 +-- @@ +-- 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 --git a/src/Generics/Deriving/Show.hs b/src/Generics/Deriving/Show.hs --- a/src/Generics/Deriving/Show.hs +++ b/src/Generics/Deriving/Show.hs @@ -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 diff --git a/src/Generics/Deriving/TH.hs b/src/Generics/Deriving/TH.hs --- a/src/Generics/Deriving/TH.hs +++ b/src/Generics/Deriving/TH.hs @@ -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 --git a/src/Generics/Deriving/TH/Internal.hs b/src/Generics/Deriving/TH/Internal.hs --- a/src/Generics/Deriving/TH/Internal.hs +++ b/src/Generics/Deriving/TH/Internal.hs @@ -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 --git a/src/Generics/Deriving/Uniplate.hs b/src/Generics/Deriving/Uniplate.hs --- a/src/Generics/Deriving/Uniplate.hs +++ b/src/Generics/Deriving/Uniplate.hs @@ -54,6 +54,9 @@ -- * Internal Uniplate class , Uniplate'(..) + + -- * Internal Context class + , Context'(..) ) where diff --git a/tests/DefaultSpec.hs b/tests/DefaultSpec.hs new file mode 100644 --- /dev/null +++ b/tests/DefaultSpec.hs @@ -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