generic-deriving 1.11.2 → 1.12

raw patch · 13 files changed

+270/−66 lines, 13 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +18/−0
• generic-deriving.cabal +4/−3
• src/Generics/Deriving/Base/Internal.hs +34/−7
• src/Generics/Deriving/Copoint.hs +3/−0
• src/Generics/Deriving/Eq.hs +3/−0
• src/Generics/Deriving/Foldable.hs +3/−0
• src/Generics/Deriving/Functor.hs +13/−0
• src/Generics/Deriving/Instances.hs +5/−4
• src/Generics/Deriving/Show.hs +13/−0
• src/Generics/Deriving/TH.hs +128/−52
• src/Generics/Deriving/TH/Internal.hs +6/−0
• src/Generics/Deriving/Traversable.hs +13/−0
• tests/EmptyCaseSpec.hs +27/−0

@@ -1,3 +1,21 @@+# 1.12 [2017.12.07]+* Adapt to the `EmptyDataDeriving` proposal (introduced in GHC 8.4):+  * `Generics.Deriving.TH` now derives `to(1)` and `from(1)` implementations+    for empty data types that are strict in the argument.+  * Introduce an `EmptyCaseOptions` field to `Options` in+    `Generics.Deriving.TH`, which controls whether generated `from(1)`/`to(1)`+    implementations for empty data types should use the `EmptyCase` extension+    or not (as is the case in GHC 8.4).+  * Add `mkFrom0Options`, `mkFrom1Options`, `mkTo0Options`, and `mkTo1Options`+    functions to `Generics.Deriving.TH`, which take `EmptyCaseOptions` as+    arguments.+  * The backported instances for `V1` are now maximally lazy, as per+    `EmptyDataDeriving`. (Previously, some instances would unnecessarily force+    their argument, such as the `Eq` and `Ord` instances.)+  * Add instances for `V1` in `Generics.Deriving.Copoint`, `.Eq`, `.Foldable`,+    `.Functor`, `.Show`, and `.Traversable`.+* Remove the bitrotting `simplInstance` function from `Generics.Deriving.TH`.+ # 1.11.2 [2017.04.10] * Add `GEq`, `GShow`, `GEnum`, and `GIx` instances for the new data types   in `Foreign.C.Types` (`CBool`) and `System.Posix.Types` (`CBlkSize`,

@@ -1,5 +1,5 @@ name:                   generic-deriving-version:                1.11.2+version:                1.12 synopsis:               Generic programming library for generalised deriving. description: @@ -32,7 +32,7 @@                       , GHC == 7.8.4                       , GHC == 7.10.3                       , GHC == 8.0.2-                      , GHC == 8.2.1+                      , GHC == 8.2.2 extra-source-files:     CHANGELOG.md                       , README.md @@ -84,7 +84,8 @@ test-suite spec   type:                 exitcode-stdio-1.0   main-is:              Spec.hs-  other-modules:        ExampleSpec+  other-modules:        EmptyCaseSpec+                        ExampleSpec                         TypeInTypeSpec   build-depends:        base             >= 4.3  && < 5                       , generic-deriving

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-}@@ -627,7 +628,7 @@ import Control.Applicative ( Alternative(..) ) import Control.Monad ( MonadPlus(..) ) import Control.Monad.Fix ( MonadFix(..), fix )-import Data.Data ( Data )+import Data.Data ( Data(..), DataType, constrIndex, mkDataType ) import Data.Ix ( Ix ) import Text.ParserCombinators.ReadPrec (pfail) import Text.Read ( Read(..), parens, readListDefault, readListPrecDefault )@@ -653,13 +654,39 @@ --------------------------------------------------------------------------------  -- | Void: used for datatypes without constructors-data V1 p-  deriving (Functor, Foldable, Traversable, Typeable)+data V1 p deriving Typeable -deriving instance           Eq   (V1 p)-deriving instance Data p => Data (V1 p)-deriving instance           Ord  (V1 p)-deriving instance           Show (V1 p)+-- Implement these instances by hand to get the desired, maximally lazy behavior.+instance Functor V1 where+  fmap _ !_ = error "Void fmap"++instance Foldable V1 where+  foldr _ z _ = z+  foldMap _ _ = mempty++instance Traversable V1 where+  traverse _ x = pure (case x of !_ -> error "Void traverse")++instance Eq (V1 p) where+  _ == _ = True++instance Data p => Data (V1 p) where+  gfoldl _ _ !_ = error "Void gfoldl"+  gunfold _ _ c = case constrIndex c of+                    _ -> error "Void gunfold"+  toConstr !_ = error "Void toConstr"+  dataTypeOf _ = v1DataType+  dataCast1 f = gcast1 f++v1DataType :: DataType+v1DataType = mkDataType "V1" []++instance Ord (V1 p) where+  compare _ _ = EQ++instance Show (V1 p) where+  showsPrec _ !_ = error "Void showsPrec"+ -- Implement Read instance manually to get around an old GHC bug -- (Trac #7931) instance Read (V1 p) where

@@ -50,6 +50,9 @@ class GCopoint' t where     gcopoint' :: t a -> Maybe a +instance GCopoint' V1 where+    gcopoint' _ = Nothing+ instance GCopoint' U1 where     gcopoint' U1 = Nothing 

@@ -82,6 +82,9 @@ class GEq' f where   geq' :: f a -> f a -> Bool +instance GEq' V1 where+  geq' _ _ = True+ instance GEq' U1 where   geq' _ _ = True 

@@ -80,6 +80,9 @@ class GFoldable' t where   gfoldMap' :: Monoid m => (a -> m) -> t a -> m +instance GFoldable' V1 where+  gfoldMap' _ _ = mempty+ instance GFoldable' U1 where   gfoldMap' _ U1 = mempty 

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -13,6 +14,10 @@ {-# LANGUAGE PolyKinds #-} #endif +#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE EmptyCase #-}+#endif+ module Generics.Deriving.Functor (   -- * Generic Functor class     GFunctor(..)@@ -59,6 +64,14 @@  class GFunctor' f where   gmap' :: (a -> b) -> f a -> f b++instance GFunctor' V1 where+  gmap' _ x = case x of+#if __GLASGOW_HASKELL__ >= 708+                {}+#else+                !_ -> error "Void gmap"+#endif  instance GFunctor' U1 where   gmap' _ U1 = U1

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-}@@ -422,13 +423,13 @@  instance Generic (V1 p) where     type Rep (V1 p) = Rep0V1 p-    from _ = M1 (error "No generic representation for empty datatype V1")-    to (M1 _) = error "No values for empty datatype V1"+    from x = M1 (case x of !_ -> error "No generic representation for empty datatype V1")+    to (M1 !_) = error "No values for empty datatype V1"  instance Generic1 V1 where     type Rep1 V1 = Rep1V1-    from1 _ = M1 (error "No generic representation for empty datatype V1")-    to1 (M1 _) = error "No values for empty datatype V1"+    from1 x = M1 (case x of !_ -> error "No generic representation for empty datatype V1")+    to1 (M1 !_) = error "No values for empty datatype V1"  data D1V1 

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -11,6 +12,10 @@ {-# LANGUAGE Trustworthy #-} #endif +#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE EmptyCase #-}+#endif+ #if __GLASGOW_HASKELL__ < 709 {-# LANGUAGE OverlappingInstances #-} #endif@@ -88,6 +93,14 @@   gshowsPrec' :: Type -> Int -> f a -> ShowS   isNullary   :: f a -> Bool   isNullary = error "generic show (isNullary): unnecessary case"++instance GShow' V1 where+  gshowsPrec' _ _ x = case x of+#if __GLASGOW_HASKELL__ >= 708+                        {}+#else+                        !_ -> error "Void gshowsPrec"+#endif  instance GShow' U1 where   gshowsPrec' _ _ U1 = id

@@ -57,7 +57,6 @@     , deriveRepresentable1     , deriveRep0     , deriveRep1-    , simplInstance       -- * @make@- functions      -- $make@@ -83,6 +82,8 @@     , defaultRepOptions     , KindSigOptions     , defaultKindSigOptions+    , EmptyCaseOptions+    , defaultEmptyCaseOptions      -- ** Functions with optional arguments     , deriveAll0Options@@ -92,6 +93,11 @@     , deriveRepresentable1Options     , deriveRep0Options     , deriveRep1Options++    , makeFrom0Options+    , makeTo0Options+    , makeFrom1Options+    , makeTo1Options   ) where  import           Control.Monad ((>=>), unless, when)@@ -133,32 +139,56 @@   newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) = Compose (f (g a))   $('deriveAll1Options' False ''Compose)   @--} --- | Given the names of a generic class, a type to instantiate, a function in--- the class and the default implementation, generates the code for a basic--- generic instance.-simplInstance :: Name -> Name -> Name -> Name -> Q [Dec]-simplInstance cl ty fn df = do-  x <- newName "x"-  let typ = ForallT [PlainTV x] []-        ((foldl (\a -> AppT a . VarT . tyVarBndrName) (ConT (genRepName Generic DataPlain ty)) []) `AppT` (VarT x))-  fmap (: []) $ instanceD (cxt []) (conT cl `appT` conT ty)-    [funD fn [clause [] (normalB (varE df `appE`-      (sigE (varE undefinedValName) (return typ)))) []]]+* 'EmptyCaseOptions': By default, all derived instances for empty data types+  (i.e., data types with no constructors) use 'error' in @from(1)@/@to(1)@.+  For instance, @data Empty@ would have this derived 'Generic' instance: +  @+  instance Generic Empty where+    type Rep Empty = D1 ('MetaData ...) V1+    from _ = M1 (error "No generic representation for empty datatype Empty")+    to (M1 _) = error "No generic representation for empty datatype Empty"+  @++  This matches the behavior of GHC up until 8.4, when derived @Generic(1)@+  instances began to use the @EmptyCase@ extension. In GHC 8.4, the derived+  'Generic' instance for @Empty@ would instead be:++  @+  instance Generic Empty where+    type Rep Empty = D1 ('MetaData ...) V1+    from x = M1 (case x of {})+    to (M1 x) = case x of {}+  @++  This is a slightly better encoding since, for example, any divergent+  computations passed to 'from' will actually diverge (as opposed to before,+  where the result would always be a call to 'error'). On the other hand, using+  this encoding in @generic-deriving@ has one large drawback: it requires+  enabling @EmptyCase@, an extension which was only introduced in GHC 7.8+  (and only received reliable pattern-match coverage checking in 8.2).++  The 'EmptyCaseOptions' field controls whether code should be emitted that+  uses @EmptyCase@ (i.e., 'EmptyCaseOptions' set to 'True') or not ('False').+  The default value is 'False'. Note that even if set to 'True', this option+  has no effect on GHCs before 7.8, as @EmptyCase@ did not exist then.+-}+ -- | Additional options for configuring derived 'Generic'/'Generic1' instances -- using Template Haskell. data Options = Options-  { repOptions     :: RepOptions-  , kindSigOptions :: KindSigOptions+  { repOptions       :: RepOptions+  , kindSigOptions   :: KindSigOptions+  , emptyCaseOptions :: EmptyCaseOptions   } deriving (Eq, Ord, Read, Show) --- | Sensible default 'Options' ('defaultRepOptions' and 'defaultKindSigOptions').+-- | Sensible default 'Options'. defaultOptions :: Options defaultOptions = Options-  { repOptions     = defaultRepOptions-  , kindSigOptions = defaultKindSigOptions+  { repOptions       = defaultRepOptions+  , kindSigOptions   = defaultKindSigOptions+  , emptyCaseOptions = defaultEmptyCaseOptions   }  -- | Configures whether 'Rep'/'Rep1' type instances should be defined inline in a@@ -180,6 +210,15 @@ defaultKindSigOptions :: KindSigOptions defaultKindSigOptions = True +-- | 'True' if generated code for empty data types should use the @EmptyCase@+-- extension, 'False' otherwise. This has no effect on GHCs before 7.8, since+-- @EmptyCase@ is only available in 7.8 or later.+type EmptyCaseOptions = Bool++-- | Sensible default 'EmptyCaseOptions'.+defaultEmptyCaseOptions :: EmptyCaseOptions+defaultEmptyCaseOptions = False+ -- | A backwards-compatible synonym for 'deriveAll0'. deriveAll :: Name -> Q [Dec] deriveAll = deriveAll0@@ -316,7 +355,8 @@ #else                          [origSigTy] tyInsRHS #endif-      mkBody maker = [clause [] (normalB $ mkCaseExp gClass name cons maker) []]+      ecOptions = emptyCaseOptions opts+      mkBody maker = [clause [] (normalB $ mkCaseExp gClass ecOptions name cons maker) []]       fcs = mkBody mkFrom       tcs = mkBody mkTo @@ -563,32 +603,48 @@  -- | Generates a lambda expression which behaves like 'from'. makeFrom0 :: Name -> Q Exp-makeFrom0 = makeFunCommon mkFrom Generic+makeFrom0 = makeFrom0Options defaultEmptyCaseOptions +-- | Like 'makeFrom0Options', but takes an 'EmptyCaseOptions' argument.+makeFrom0Options :: EmptyCaseOptions -> Name -> Q Exp+makeFrom0Options = makeFunCommon mkFrom Generic+ -- | A backwards-compatible synonym for 'makeTo0'. makeTo :: Name -> Q Exp makeTo = makeTo0  -- | Generates a lambda expression which behaves like 'to'. makeTo0 :: Name -> Q Exp-makeTo0 = makeFunCommon mkTo Generic+makeTo0 = makeTo0Options defaultEmptyCaseOptions +-- | Like 'makeTo0Options', but takes an 'EmptyCaseOptions' argument.+makeTo0Options :: EmptyCaseOptions -> Name -> Q Exp+makeTo0Options = makeFunCommon mkTo Generic+ -- | Generates a lambda expression which behaves like 'from1'. makeFrom1 :: Name -> Q Exp-makeFrom1 = makeFunCommon mkFrom Generic1+makeFrom1 = makeFrom1Options defaultEmptyCaseOptions +-- | Like 'makeFrom1Options', but takes an 'EmptyCaseOptions' argument.+makeFrom1Options :: EmptyCaseOptions -> Name -> Q Exp+makeFrom1Options = makeFunCommon mkFrom Generic1+ -- | Generates a lambda expression which behaves like 'to1'. makeTo1 :: Name -> Q Exp-makeTo1 = makeFunCommon mkTo Generic1+makeTo1 = makeTo1Options defaultEmptyCaseOptions -makeFunCommon :: (GenericClass -> Int -> Int -> Name -> [Con] -> Q Match)-              -> GenericClass -> Name -> Q Exp-makeFunCommon maker gClass n = do+-- | Like 'makeTo1Options', but takes an 'EmptyCaseOptions' argument.+makeTo1Options :: EmptyCaseOptions -> Name -> Q Exp+makeTo1Options = makeFunCommon mkTo Generic1++makeFunCommon :: (GenericClass -> EmptyCaseOptions ->  Int -> Int -> Name -> [Con] -> Q Match)+              -> GenericClass -> EmptyCaseOptions -> Name -> Q Exp+makeFunCommon maker gClass ecOptions n = do   i <- reifyDataInfo n   let (name, _, allTvbs, cons, dv) = either error id i   -- See Note [Forcing buildTypeInstance]   buildTypeInstance gClass False name allTvbs dv-    `seq` mkCaseExp gClass name cons maker+    `seq` mkCaseExp gClass ecOptions name cons maker  genRepName :: GenericClass -> DataVariety -> Name -> Name genRepName gClass dv n = mkName@@ -734,52 +790,72 @@     Just (boxTyName, _, _) -> conT boxTyName     Nothing                -> conT rec0TypeName `appT` return ty -mkCaseExp :: GenericClass -> Name -> [Con]-          -> (GenericClass -> Int -> Int -> Name -> [Con] -> Q Match)+mkCaseExp :: GenericClass -> EmptyCaseOptions -> Name -> [Con]+          -> (GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Con] -> Q Match)           -> Q Exp-mkCaseExp gClass dt cs matchmaker = do+mkCaseExp gClass ecOptions dt cs matchmaker = do   val <- newName "val"-  lam1E (varP val) $ caseE (varE val) [matchmaker gClass 1 0 dt cs]+  lam1E (varP val) $ caseE (varE val) [matchmaker gClass ecOptions 1 0 dt cs] -mkFrom :: GenericClass -> Int -> Int -> Name -> [Con] -> Q Match-mkFrom gClass m i dt cs = do+mkFrom :: GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Con] -> Q Match+mkFrom gClass ecOptions m i dt cs = do     y <- newName "y"     match (varP y)           (normalB $ conE m1DataName `appE` caseE (varE y) cases)           []   where     cases = case cs of-              [] -> [errorFrom dt]+              [] -> errorFrom ecOptions dt               _  -> zipWith (fromCon gClass wrapE (length cs)) [0..] cs     wrapE e = lrE m i e -errorFrom :: Name -> Q Match-errorFrom dt =-  match-    wildP-    (normalB $ varE errorValName `appE` stringE-      ("No generic representation for empty datatype " ++ nameBase dt))-    []--errorTo :: Name -> Q Match-errorTo dt =-  match-    wildP-    (normalB $ varE errorValName `appE` stringE-      ("No values for empty datatype " ++ nameBase dt))-    []+errorFrom :: EmptyCaseOptions -> Name -> [Q Match]+errorFrom useEmptyCase dt+  | useEmptyCase && ghc7'8OrLater+  = []+  | otherwise+  = [do z <- newName "z"+        match+          (varP z)+          (normalB $+            appE (varE seqValName) (varE z) `appE`+            appE (varE errorValName)+                 (stringE $ "No generic representation for empty datatype "+                          ++ nameBase dt))+          []] -mkTo :: GenericClass -> Int -> Int -> Name -> [Con] -> Q Match-mkTo gClass m i dt cs = do+mkTo :: GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Con] -> Q Match+mkTo gClass ecOptions m i dt cs = do     y <- newName "y"     match (conP m1DataName [varP y])           (normalB $ caseE (varE y) cases)           []   where     cases = case cs of-              [] -> [errorTo dt]+              [] -> errorTo ecOptions dt               _  -> zipWith (toCon gClass wrapP (length cs)) [0..] cs     wrapP p = lrP m i p++errorTo :: EmptyCaseOptions -> Name -> [Q Match]+errorTo useEmptyCase dt+  | useEmptyCase && ghc7'8OrLater+  = []+  | otherwise+  = [do z <- newName "z"+        match+          (varP z)+          (normalB $+            appE (varE seqValName) (varE z) `appE`+            appE (varE errorValName)+                 (stringE $ "No values for empty datatype " ++ nameBase dt))+          []]++ghc7'8OrLater :: Bool+#if __GLASGOW_HASKELL__ >= 708+ghc7'8OrLater = True+#else+ghc7'8OrLater = False+#endif  fromCon :: GenericClass -> (Q Exp -> Q Exp) -> Int -> Int -> Con -> Q Match fromCon _ wrap m i (NormalC cn []) =

@@ -769,6 +769,9 @@ mkGHCPrimName_tc :: String -> String -> Name mkGHCPrimName_tc = mkNameG_tc "ghc-prim" +mkGHCPrimName_v :: String -> String -> Name+mkGHCPrimName_v = mkNameG_v "ghc-prim"+ comp1DataName :: Name comp1DataName = mkGD4'4_d "Comp1" @@ -930,6 +933,9 @@  selNameValName :: Name selNameValName = mkGD4'4_v "selName"++seqValName :: Name+seqValName = mkGHCPrimName_v "GHC.Prim" "seq"  toValName :: Name toValName = mkGD4'4_v "to"

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -13,6 +14,10 @@ {-# LANGUAGE PolyKinds #-} #endif +#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE EmptyCase #-}+#endif+ module Generics.Deriving.Traversable (   -- * Generic Traversable class     GTraversable(..)@@ -63,6 +68,14 @@  class GTraversable' t where   gtraverse' :: Applicative f => (a -> f b) -> t a -> f (t b)++instance GTraversable' V1 where+  gtraverse' _ x = pure $ case x of+#if __GLASGOW_HASKELL__ >= 708+                            {}+#else+                            !_ -> error "Void gtraverse"+#endif  instance GTraversable' U1 where   gtraverse' _ U1 = pure U1

@@ -0,0 +1,27 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE DataKinds #-}+#endif++#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE EmptyCase #-}+#endif++module EmptyCaseSpec (main, spec) where++import Generics.Deriving.TH+import Test.Hspec++data Empty a+$(deriveAll0And1Options defaultOptions{emptyCaseOptions = True}+                        ''Empty)++main :: IO ()+main = hspec spec++spec :: Spec+spec = return ()