deriving-compat 0.4 → 0.4.1

raw patch · 8 files changed

+421/−17 lines, 8 filesdep ~template-haskellPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: template-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• README.md +2/−0
• deriving-compat.cabal +11/−1
• src/Data/Deriving.hs +5/−4
• src/Data/Deriving/Internal.hs +41/−12
• src/Data/Deriving/Via.hs +67/−0
• src/Data/Deriving/Via/Internal.hs +207/−0
• tests/DerivingViaSpec.hs +83/−0

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

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

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

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

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

@@ -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+  <https://ghc.haskell.org/trac/ghc/ticket/14728 Trac #14728>.)+-}+#endif

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

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