diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +### 0.4.1 [2018.02.04] +* Add `Data.Deriving.Via`, which allows emulating the behavior of the + `GeneralizedNewtypeDeriving` and `DerivingVia` extensions. +* Test suite fixes for GHC 8.4. + ## 0.4 [2017.12.07] * Incorporate changes from the `EmptyDataDeriving` proposal (which is in GHC as of 8.4): diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -27,6 +27,8 @@ * `DeriveFoldable` * `DeriveFunctor` * `DeriveTraversable` +* `GeneralizedNewtypeDeriving` (with GHC 8.2 or later) +* `DerivingVia` (with GHC 8.2 or later) See the `Data.Deriving` module for a full list of backported changes. diff --git a/deriving-compat.cabal b/deriving-compat.cabal --- a/deriving-compat.cabal +++ b/deriving-compat.cabal @@ -1,5 +1,5 @@ name: deriving-compat -version: 0.4 +version: 0.4.1 synopsis: Backports of GHC deriving extensions description: Provides Template Haskell functions that mimic deriving extensions that were introduced or modified in recent versions @@ -25,6 +25,10 @@ . * @DeriveTraversable@ . + * @GeneralizedNewtypeDeriving@ (with GHC 8.2 or later) + . + * @DerivingVia@ (with GHC 8.2 or later) + . See the "Data.Deriving" module for a full list of backported changes. . Note that some recent GHC typeclasses/extensions are not covered by this package: @@ -66,6 +70,7 @@ , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2 + , GHC == 8.4.1 cabal-version: >=1.10 source-repository head @@ -91,6 +96,7 @@ exposed-modules: Data.Deriving Data.Bounded.Deriving + Data.Deriving.Via Data.Enum.Deriving Data.Eq.Deriving Data.Foldable.Deriving @@ -104,6 +110,7 @@ other-modules: Data.Deriving.Internal Data.Bounded.Deriving.Internal + Data.Deriving.Via.Internal Data.Enum.Deriving.Internal Data.Eq.Deriving.Internal Data.Functor.Deriving.Internal @@ -111,6 +118,7 @@ Data.Ord.Deriving.Internal Text.Read.Deriving.Internal Text.Show.Deriving.Internal + Paths_deriving_compat build-depends: containers >= 0.1 && < 0.6 , ghc-prim @@ -143,6 +151,7 @@ type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: BoundedEnumIxSpec + DerivingViaSpec EqSpec FunctorSpec OrdSpec @@ -159,6 +168,7 @@ , QuickCheck >= 2 && < 3 , tagged >= 0.7 && < 1 , template-haskell >= 2.5 && < 2.13 + build-tool-depends: hspec-discover:hspec-discover >= 1.8 if flag(base-4-9) build-depends: base >= 4.9 && < 5 diff --git a/src/Data/Deriving.hs b/src/Data/Deriving.hs --- a/src/Data/Deriving.hs +++ b/src/Data/Deriving.hs @@ -5,10 +5,11 @@ Maintainer: Ryan Scott Portability: Template Haskell -This module reexports all of the functionality of the other modules in this library. -It also provides a high-level tutorial on @deriving-compat@'s naming conventions and -best practices. Typeclass-specific information can be found in their respective -modules. +This module reexports all of the functionality of the other modules in this library +(with the exception of "Data.Deriving.Via", which is only available on GHC 8.2 or +later). This module also provides a high-level tutorial on @deriving-compat@'s +naming conventions and best practices. Typeclass-specific information can be found +in their respective modules. -} module Data.Deriving ( -- * Backported changes diff --git a/src/Data/Deriving/Internal.hs b/src/Data/Deriving/Internal.hs --- a/src/Data/Deriving/Internal.hs +++ b/src/Data/Deriving/Internal.hs @@ -92,6 +92,15 @@ substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns ------------------------------------------------------------------------------- +-- Via +------------------------------------------------------------------------------- + +-- | A type-level modifier intended to be used in conjunction with 'deriveVia'. +-- Refer to the documentation for 'deriveVia' for more details. +data a `Via` b +infix 0 `Via` + +------------------------------------------------------------------------------- -- Type-specialized const functions ------------------------------------------------------------------------------- @@ -1124,6 +1133,9 @@ mkDerivingCompatName_v :: String -> Name mkDerivingCompatName_v = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" +mkDerivingCompatName_tc :: String -> Name +mkDerivingCompatName_tc = mkNameG_tc derivingCompatPackageKey "Data.Deriving.Internal" + isTrueHashValName :: Name isTrueHashValName = mkDerivingCompatName_v "isTrue#" @@ -1199,18 +1211,15 @@ liftShowsPrec2ConstValName :: Name liftShowsPrec2ConstValName = mkDerivingCompatName_v "liftShowsPrec2Const" +viaTypeName :: Name +viaTypeName = mkDerivingCompatName_tc "Via" + cHashDataName :: Name cHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "C#" dHashDataName :: Name dHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "D#" -dualDataName :: Name -dualDataName = mkNameG_d "base" "Data.Monoid" "Dual" - -endoDataName :: Name -endoDataName = mkNameG_d "base" "Data.Monoid" "Endo" - fHashDataName :: Name fHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "F#" @@ -1277,9 +1286,6 @@ altValName :: Name altValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "+++" -appEndoValName :: Name -appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo" - appendValName :: Name appendValName = mkNameG_v "base" "GHC.Base" "++" @@ -1358,9 +1364,6 @@ geIntHashValName :: Name geIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">=#" -getDualValName :: Name -getDualValName = mkNameG_v "base" "Data.Monoid" "getDual" - getTagValName :: Name getTagValName = mkNameG_v "base" "GHC.Base" "getTag" @@ -1937,4 +1940,30 @@ showCommaSpaceValName :: Name showCommaSpaceValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "showCommaSpace" +#endif + +#if MIN_VERSION_base(4,11,0) +appEndoValName :: Name +appEndoValName = mkNameG_v "base" "Data.Semigroup.Internal" "appEndo" + +dualDataName :: Name +dualDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Dual" + +endoDataName :: Name +endoDataName = mkNameG_d "base" "Data.Semigroup.Internal" "Endo" + +getDualValName :: Name +getDualValName = mkNameG_v "base" "Data.Semigroup.Internal" "getDual" +#else +appEndoValName :: Name +appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo" + +dualDataName :: Name +dualDataName = mkNameG_d "base" "Data.Monoid" "Dual" + +endoDataName :: Name +endoDataName = mkNameG_d "base" "Data.Monoid" "Endo" + +getDualValName :: Name +getDualValName = mkNameG_v "base" "Data.Monoid" "getDual" #endif diff --git a/src/Data/Deriving/Via.hs b/src/Data/Deriving/Via.hs new file mode 100644 --- /dev/null +++ b/src/Data/Deriving/Via.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE CPP #-} + +{-| +Module: Data.Deriving.Via +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +On @template-haskell-2.12@ or later (i.e., GHC 8.2 or later), this module +exports functionality which emulates the @GeneralizedNewtypeDeriving@ and +@DerivingVia@ GHC extensions. + +On older versions of @template-haskell@/GHC, this module does not export +anything. +-} +module Data.Deriving.Via ( +#if !(MIN_VERSION_template_haskell(2,12,0)) + ) where +#else + -- * @GeneralizedNewtypeDeriving@ + deriveGND + -- * @DerivingVia@ + , deriveVia + , Via + -- * Limitations + -- $constraints + ) where + +import Data.Deriving.Internal (Via) +import Data.Deriving.Via.Internal + +{- $constraints + +Be aware of the following potential gotchas: + +* Unlike every other module in this library, the functions exported by + "Data.Deriving.Via" only support GHC 8.2 and later, as they require + Template Haskell functionality not present in earlier GHCs. + +* Additionally, using the functions in "Data.Deriving.Via" will likely + require you to enable some language extensions (besides @TemplateHaskell@). + These may include: + + * @ImpredicativeTypes@ + + * @KindSignatures@ + + * @RankNTypes@ + + * @ScopedTypeVariables@ + + * @TypeApplications@ + + * @UndecidableInstances@ (if deriving an instance of a type class with + associated type families) + +* The functions in "Data.Deriving.Via" are not terribly robust in the presence + of @PolyKinds@. Alas, Template Haskell does not make this easy to fix. + +* The functions in "Data.Deriving.Via" make a best-effort attempt to derive + instances for classes with associated type families. This is known not to + work in all scenarios, however, especially when the last parameter to a type + class appears as a kind variable in an associated type family. (See + .) +-} +#endif diff --git a/src/Data/Deriving/Via/Internal.hs b/src/Data/Deriving/Via/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Deriving/Via/Internal.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE CPP #-} + +{-| +Module: Data.Deriving.Via.Internal +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +On @template-haskell-2.12@ or later (i.e., GHC 8.2 or later), this module +exports functionality which emulates the @GeneralizedNewtypeDeriving@ and +@DerivingVia@ GHC extensions. + +On older versions of @template-haskell@/GHC, this module does not export +anything. +-} +module Data.Deriving.Via.Internal where + +#if MIN_VERSION_template_haskell(2,12,0) +import Control.Monad ((<=<)) + +import Data.Deriving.Internal +import qualified Data.Map as M +import Data.Map (Map) +import Data.Maybe (catMaybes) + +import Language.Haskell.TH +import Language.Haskell.TH.Datatype + +------------------------------------------------------------------------------- +-- Code generation +------------------------------------------------------------------------------- + +{- | Generates an instance for a type class at a newtype by emulating the +behavior of the @GeneralizedNewtypeDeriving@ extension. For example: + +@ +newtype Foo a = MkFoo a +$('deriveGND' [t| forall a. 'Eq' a => 'Eq' (Foo a) |]) +@ +-} +deriveGND :: Q Type -> Q [Dec] +deriveGND qty = do + ty <- qty + let (instanceCxt, instanceTy) = decomposeType ty + instanceTy' <- (resolveTypeSynonyms <=< resolveInfixT) instanceTy + decs <- deriveViaDecs instanceTy' Nothing + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceTy) + (map return decs) + +{- | Generates an instance for a type class by emulating the behavior of the +@DerivingVia@ extension. For example: + +@ +newtype Foo a = MkFoo a +$('deriveVia' [t| forall a. 'Ord' a => 'Ord' (Foo a) ``Via`` Down a |]) +@ + +As shown in the example above, the syntax is a tad strange. One must specify +the type by which to derive the instance using the 'Via' type. This +requirement is in place to ensure that the type variables are scoped +correctly across all the types being used (e.g., to make sure that the same +@a@ is used in @'Ord' a@, @'Ord' (Foo a)@, and @Down a@). +-} +deriveVia :: Q Type -> Q [Dec] +deriveVia qty = do + ty <- qty + let (instanceCxt, viaApp) = decomposeType ty + viaApp' <- (resolveTypeSynonyms <=< resolveInfixT) viaApp + (instanceTy, viaTy) + <- case unapplyTy viaApp' of + [via,instanceTy,viaTy] + | via == ConT viaTypeName + -> return (instanceTy, viaTy) + _ -> fail $ unlines + [ "Failure to meet ‘deriveVia‘ specification" + , "\tThe ‘Via‘ type must be used, e.g." + , "\t[t| forall a. C (T a) `Via` V a |]" + ] + decs <- deriveViaDecs instanceTy (Just viaTy) + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceTy) + (map return decs) + +deriveViaDecs :: Type -- ^ The instance head (e.g., @Eq (Foo a)@) + -> Maybe Type -- ^ If using 'deriveGND', this is 'Nothing. + -- If using 'deriveVia', this is 'Just' the @via@ type. + -> Q [Dec] +deriveViaDecs instanceTy mbViaTy = do + let (clsTy:clsArgs) = unapplyTy instanceTy + case clsTy of + ConT clsName -> do + clsInfo <- reify clsName + case clsInfo of + ClassI (ClassD _ _ clsTvbs _ clsDecs) _ -> + case (unsnoc clsArgs, unsnoc clsTvbs) of + (Just (_, dataApp), Just (_, clsLastTvb)) -> do + let (dataTy:dataArgs) = unapplyTy dataApp + clsLastTvbKind = tvbKind clsLastTvb + (_, kindList) = uncurryTy clsLastTvbKind + numArgsToEtaReduce = length kindList - 1 + repTy <- + case mbViaTy of + Just viaTy -> return viaTy + Nothing -> + case dataTy of + ConT dataName -> do + DatatypeInfo { datatypeVars = dataVars + , datatypeVariant = dv + , datatypeCons = cons + } <- reifyDatatype dataName + case newtypeRepType dv cons of + Just newtypeRepTy -> + case etaReduce numArgsToEtaReduce newtypeRepTy of + Just etaRepTy -> + let repTySubst = + M.fromList $ + zipWith (\var arg -> (varTToName var, arg)) + dataVars dataArgs + in return $ applySubstitution repTySubst etaRepTy + Nothing -> etaReductionError instanceTy + Nothing -> fail $ "Not a newtype: " ++ nameBase dataName + _ -> fail $ "Not a data type: " ++ pprint dataTy + catMaybes `fmap` traverse (deriveViaDec clsTvbs clsArgs repTy) clsDecs + (_, _) -> fail $ "Cannot derive instance for nullary class " ++ pprint clsTy + _ -> fail $ "Not a type class: " ++ pprint clsTy + _ -> fail $ "Malformed instance: " ++ pprint instanceTy + +deriveViaDec :: [TyVarBndr] -> [Type] -> Type -> Dec -> Q (Maybe Dec) +deriveViaDec clsTvbs clsArgs repTy = go + where + go :: Dec -> Q (Maybe Dec) + + go (OpenTypeFamilyD (TypeFamilyHead tfName tfTvbs _ _)) = + let lhsSubst = zipTvbSubst clsTvbs clsArgs + rhsSubst = zipTvbSubst clsTvbs $ changeLast clsArgs repTy + tfTvbTys = map tvbToType tfTvbs + tfLHSTys = map (applySubstitution lhsSubst) tfTvbTys + tfRHSTys = map (applySubstitution rhsSubst) tfTvbTys + tfRHSTy = applyTy (ConT tfName) tfRHSTys + tfInst = TySynInstD tfName (TySynEqn tfLHSTys tfRHSTy) + in return (Just tfInst) + + go (SigD methName methTy) = + let (fromTy, toTy) = mkCoerceClassMethEqn clsTvbs clsArgs repTy $ + stripOuterForallT methTy + rhsExpr = VarE coerceValName `AppTypeE` fromTy + `AppTypeE` toTy + `AppE` VarE methName + meth = ValD (VarP methName) + (NormalB rhsExpr) + [] + in return (Just meth) + + go _ = return Nothing + +mkCoerceClassMethEqn :: [TyVarBndr] -> [Type] -> Type -> Type -> (Type, Type) +mkCoerceClassMethEqn clsTvbs clsArgs repTy methTy + = ( applySubstitution rhsSubst methTy + , applySubstitution lhsSubst methTy + ) + where + lhsSubst = zipTvbSubst clsTvbs clsArgs + rhsSubst = zipTvbSubst clsTvbs $ changeLast clsArgs repTy + +zipTvbSubst :: [TyVarBndr] -> [Type] -> Map Name Type +zipTvbSubst tvbs = M.fromList . zipWith (\tvb ty -> (tvName tvb, ty)) tvbs + +-- | Replace the last element of a list with another element. +changeLast :: [a] -> a -> [a] +changeLast [] _ = error "changeLast" +changeLast [_] x = [x] +changeLast (x:xs) x' = x : changeLast xs x' + +stripOuterForallT :: Type -> Type +stripOuterForallT (ForallT _ _ ty) = ty +stripOuterForallT ty = ty + +decomposeType :: Type -> (Cxt, Type) +decomposeType (ForallT _ ctxt ty) = (ctxt, ty) +decomposeType ty = ([], ty) + +newtypeRepType :: DatatypeVariant -> [ConstructorInfo] -> Maybe Type +newtypeRepType dv cons = do + checkIfNewtype + case cons of + [ConstructorInfo { constructorVars = [] + , constructorContext = [] + , constructorFields = [repTy] + }] -> Just repTy + _ -> Nothing + where + checkIfNewtype :: Maybe () + checkIfNewtype + | Newtype <- dv = Just () + | NewtypeInstance <- dv = Just () + | otherwise = Nothing + +etaReduce :: Int -> Type -> Maybe Type +etaReduce num ty = + let (tyHead:tyArgs) = unapplyTy ty + (tyArgsRemaining, tyArgsDropped) = splitAt (length tyArgs - num) tyArgs + in if canEtaReduce tyArgsRemaining tyArgsDropped + then Just $ applyTy tyHead tyArgsRemaining + else Nothing +#endif diff --git a/tests/DerivingViaSpec.hs b/tests/DerivingViaSpec.hs new file mode 100644 --- /dev/null +++ b/tests/DerivingViaSpec.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +#if MIN_VERSION_template_haskell(2,12,0) +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE TypeApplications #-} +#endif + +{-| +Module: DerivingViaSpec +Copyright: (C) 2015-2017 Ryan Scott +License: BSD-style (see the file LICENSE) +Maintainer: Ryan Scott +Portability: Template Haskell + +@hspec@ tests for 'deriveGND' and 'deriveVia'. +-} +module DerivingViaSpec where + +import Prelude () +import Prelude.Compat + +import Test.Hspec + +#if MIN_VERSION_template_haskell(2,12,0) +import Data.Deriving.Via + +class Container (f :: * -> *) where + type Inside f a + peekInside :: f a -> Inside f a + +instance Container (Either a) where + type Inside (Either a) b = Maybe b + peekInside (Left{}) = Nothing + peekInside (Right x) = Just x + +newtype Down a = MkDown a deriving Show +$(deriveGND [t| forall a. Eq a => Eq (Down a) |]) + +instance Ord a => Ord (Down a) where + compare (MkDown x) (MkDown y) = y `compare` x + +newtype Id a = MkId a deriving Show +$(deriveGND [t| forall a. Eq a => Eq (Id a) |]) +$(deriveVia [t| forall a. Ord a => Ord (Id a) `Via` Down a |]) + +instance Container Id where + type Inside Id a = a + peekInside (MkId x) = x + +newtype MyEither a b = MkMyEither (Either a b) deriving Show +$(deriveGND [t| forall a. Functor (MyEither a) |]) +$(deriveVia [t| forall a b. (Eq a, Eq b) => Eq (MyEither a b) `Via` Id (Either a b) |]) +$(deriveVia [t| forall a. Applicative (MyEither a) `Via` (Either a) |]) +$(deriveVia [t| forall a. Container (MyEither a) `Via` (Either a) |]) + +newtype Wrap f a = MkWrap (f a) deriving Show +$(deriveGND [t| forall f. Container f => Container (Wrap f) |]) + +class MFunctor (t :: (* -> *) -> * -> *) where + hoist :: (forall a. m a -> n a) -> t m b -> t n b + +newtype TaggedTrans tag trans (m :: * -> *) a = MkTaggedTrans (trans m a) deriving Show +$(deriveGND [t| forall tag trans. MFunctor trans => MFunctor (TaggedTrans tag trans) |]) +#endif + +main :: IO () +main = hspec spec + +spec :: Spec +spec = parallel $ do +#if MIN_VERSION_template_haskell(2,12,0) + describe "Id" $ + it "should compare items in reverse order" $ + compare (MkId "hello") (MkId "world") `shouldBe` GT +#endif + pure ()