generic-deriving 1.11 → 1.11.1
raw patch · 9 files changed
+560/−695 lines, 9 filesdep +generic-derivingdep +hspecdep ~basedep ~template-haskellPVP ok
version bump matches the API change (PVP)
Dependencies added: generic-deriving, hspec
Dependency ranges changed: base, template-haskell
API changes (from Hackage documentation)
Files
- CHANGELOG.md +7/−1
- examples/Examples.hs +0/−660
- generic-deriving.cabal +17/−4
- src/Generics/Deriving/Base/Internal.hs +65/−5
- src/Generics/Deriving/TH.hs +12/−5
- src/Generics/Deriving/TH/Internal.hs +7/−20
- tests/ExampleSpec.hs +421/−0
- tests/Spec.hs +1/−0
- tests/TypeInTypeSpec.hs +30/−0
CHANGELOG.md view
@@ -1,5 +1,11 @@+# 1.11.1 [2016.09.10]+* Fix Template Haskell regression involving data families+* Convert examples to test suite+* Backport missing `Data` and `Typeable` instances for `Rec1`, `M1`, `(:*:)`,+ `(:+:)`, and `(:.:)`+ # 1.11-* The behavior of function in `Generics.Deriving.TH` has changed with respect+* The behavior of functions in `Generics.Deriving.TH` have changed with respect to when type synonyms are generated for `Rep(1)` definitions. In particular: * By default, `deriveRepresentable(1)` will no longer define its `Rep(1)`
− examples/Examples.hs
@@ -1,660 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DatatypeContexts #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE UndecidableInstances #-}--#if __GLASGOW_HASKELL__ >= 701-{-# LANGUAGE DeriveGeneric #-}-#endif--#if __GLASGOW_HASKELL__ >= 705-{-# LANGUAGE DataKinds #-}-#endif--{-# OPTIONS_GHC -fno-warn-orphans #-}--module Main (- -- * Run all tests- main- ) where--import Prelude hiding (Either(..))-import Generics.Deriving-import Generics.Deriving.TH-import GHC.Exts (Addr#, Char#, Double#, Float#, Int#, Word#)-import qualified Text.Read.Lex (Lexeme)------------------------------------------------------------------------------------- Temporary tests for TH generation-----------------------------------------------------------------------------------data Empty a--data (:/:) f a = MyType1Nil- | MyType1Cons { myType1Rec :: (f :/: a), myType2Rec :: MyType2 }- | MyType1Cons2 (f :/: a) Int a (f a)- | (f :/: a) :/: MyType2--infixr 5 :!@!:-data GADTSyntax a b where- GADTPrefix :: d -> c -> GADTSyntax c d- (:!@!:) :: e -> f -> GADTSyntax e f--data MyType2 = MyType2 Float ([] :/: Int)-data PlainHash a = Hash a Addr# Char# Double# Float# Int# Word#--#if __GLASGOW_HASKELL__ >= 701-deriving instance Generic (Empty a)-deriving instance Generic (f :/: a)-deriving instance Generic MyType2-#endif--#if __GLASGOW_HASKELL__ < 705-$(deriveMeta ''Empty)-$(deriveMeta ''(:/:))-$(deriveMeta ''GADTSyntax)-$(deriveMeta ''MyType2)-#endif--#if __GLASGOW_HASKELL__ < 701-$(deriveRepresentable0 ''Empty)-$(deriveRepresentable0 ''(:/:))-$(deriveRepresentable0 ''MyType2)-#endif--#if __GLASGOW_HASKELL__ >= 705-deriving instance Generic (GADTSyntax a b)-deriving instance Generic1 Empty-deriving instance Generic1 ((:/:) f)-deriving instance Generic1 (GADTSyntax a)-#else-$(deriveRepresentable0 ''GADTSyntax)-$(deriveRepresentable1 ''Empty)-$(deriveRepresentable1 ''(:/:))-$(deriveRepresentable1 ''GADTSyntax)-#endif--#if __GLASGOW_HASKELL__ >= 711-deriving instance Generic (PlainHash a)-deriving instance Generic1 PlainHash-#else-$(deriveAll0And1 ''PlainHash)-#endif---- Test to see if generated names are unique-data Lexeme = Lexeme--$(deriveAll0 ''Main.Lexeme)-$(deriveAll0 ''Text.Read.Lex.Lexeme)--#if __GLASGOW_HASKELL__ >= 703-data family MyType3 a b (c :: * -> *) d e-newtype instance MyType3 (f x) (f x) f x y = MyType3Newtype y-data instance MyType3 Bool () f x y = MyType3True | MyType3False-data instance MyType3 Int () f x y = MyType3Hash y Addr# Char# Double# Float# Int# Word#--# if __GLASGOW_HASKELL__ < 707-$(deriveMeta 'MyType3Newtype)-$(deriveMeta 'MyType3True)-# endif--# if __GLASGOW_HASKELL__ >= 705-deriving instance Generic (MyType3 (f x) (f x) f x y)-deriving instance Generic (MyType3 Bool () f x y)-# else-$(deriveRep0 'MyType3Newtype)-instance Generic (MyType3 (f x) (f x) f x y) where- type Rep (MyType3 (f x) (f x) f x y) = $(makeRep0 'MyType3Newtype) f x y- from = $(makeFrom0 'MyType3Newtype)- to = $(makeTo0 'MyType3Newtype)--$(deriveRepresentable0 'MyType3True)-# endif--# if __GLASGOW_HASKELL__ >= 707-deriving instance Generic1 (MyType3 (f x) (f x) f x)-deriving instance Generic1 (MyType3 Bool () f x)-# else-$(deriveRep1 'MyType3Newtype)-instance Generic1 (MyType3 (f x) (f x) f x) where- type Rep1 (MyType3 (f x) (f x) f x) = $(makeRep1 'MyType3Newtype) f x- from1 = $(makeFrom1 'MyType3Newtype)- to1 = $(makeTo1 'MyType3Newtype)--$(deriveRepresentable1 'MyType3False)-# endif--# if __GLASGOW_HASKELL__ >= 711-deriving instance Generic (MyType3 Int () f x y)-deriving instance Generic1 (MyType3 Int () f x)-# else-$(deriveAll0And1 'MyType3Hash)-# endif-#endif------------------------------------------------------------------------------------- Example: Haskell's lists and Maybe-----------------------------------------------------------------------------------hList1, hList2 :: [Int]-hList1 = [1..10]-hList2 = [2,4..]--maybe1 = Nothing-maybe2 = Just (Just 'p')--double :: [Int] -> [Int]-double [] = []-double (x:xs) = x:x:xs--testsStandard = [ gshow hList1- , gshow (children maybe2)- , gshow (transform (const "abc") [])- , gshow (transform double hList1)- , gshow (geq hList1 hList1)- , gshow (geq maybe1 maybe2)- , gshow (take 5 (genum :: [Maybe Int]))- , gshow (take 15 (genum :: [[Int]]))- , gshow (range ([0], [1::Int]))- , gshow (inRange ([0], [3,5::Int]) hList1) ]------------------------------------------------------------------------------------- Example: trees of integers (kind *)-----------------------------------------------------------------------------------data Tree = Empty | Branch Int Tree Tree--#if __GLASGOW_HASKELL__ >= 701--deriving instance Generic Tree--instance GShow Tree-instance Uniplate Tree-instance GEnum Tree--#else--$(deriveAll0 ''Tree)--instance GShow Tree where gshowsPrec = gshowsPrecdefault-instance Uniplate Tree where- children = childrendefault- context = contextdefault- descend = descenddefault- descendM = descendMdefault- transform = transformdefault- transformM = transformMdefault-instance GEnum Tree where genum = genumDefault--#endif--upgradeTree :: Tree -> Tree-upgradeTree Empty = Branch 0 Empty Empty-upgradeTree (Branch n l r) = Branch (succ n) l r---- Example usage-tree = Branch 2 Empty (Branch 1 Empty Empty)-testsTree = [ gshow tree- , gshow (children tree)- , gshow (descend (descend (\_ -> Branch 0 Empty Empty)) tree)- , gshow (context tree [Branch 1 Empty Empty,Empty])- , gshow (transform upgradeTree tree)- , gshow (take 10 (genum :: [Tree])) ]------------------------------------------------------------------------------------- Example: lists (kind * -> *)-----------------------------------------------------------------------------------data List a = Nil | Cons a (List a)--#if __GLASGOW_HASKELL__ >= 701-deriving instance Generic (List a)-#else--type Rep0List_ a = D1 List_ ((:+:) (C1 Nil_ U1) (C1 Cons_ ((:*:) (Par0 a) (Rec0 (List a)))))-instance Generic (List a) where- type Rep (List a) = Rep0List_ a- from Nil = M1 (L1 (M1 U1))- from (Cons h t) = M1 (R1 (M1 ((:*:) (K1 h) (K1 t))))- to (M1 (L1 (M1 U1))) = Nil- to (M1 (R1 (M1 (K1 h :*: K1 t)))) = Cons h t--#endif--#if __GLASGOW_HASKELL__ >= 705-deriving instance Generic1 List-#else--data List_-data Nil_-data Cons_--instance Datatype List_ where- datatypeName _ = "List"- moduleName _ = "Examples"--instance Constructor Nil_ where conName _ = "Nil"-instance Constructor Cons_ where conName _ = "Cons"--type Rep1List_ = D1 List_ ((:+:) (C1 Nil_ U1) (C1 Cons_ ((:*:) Par1 (Rec1 List))))-instance Generic1 List where- type Rep1 List = Rep1List_- from1 Nil = M1 (L1 (M1 U1))- from1 (Cons h t) = M1 (R1 (M1 (Par1 h :*: Rec1 t)))- to1 (M1 (L1 (M1 U1))) = Nil- to1 (M1 (R1 (M1 (Par1 h :*: Rec1 t)))) = Cons h t--#endif--#if __GLASGOW_HASKELL__ < 701--- Instance for generic functions (should be automatically generated)-instance GFunctor List where- gmap = gmapdefault--instance (GShow a) => GShow (List a) where- gshowsPrec = gshowsPrecdefault--instance (Uniplate a) => Uniplate (List a) where- children = childrendefault- context = contextdefault- descend = descenddefault- descendM = descendMdefault- transform = transformdefault- transformM = transformMdefault--#else--instance GFunctor List-instance (GShow a) => GShow (List a)-instance (Uniplate a) => Uniplate (List a)--#endif---- Example usage-list = Cons 'p' (Cons 'q' Nil)-listlist = Cons list (Cons Nil Nil) -- ["pq",""]--testsList = [ gshow (gmap fromEnum list)- , gshow (gmap gshow listlist)- , gshow list- , gshow listlist- , gshow (children list)- , gshow (children listlist) ]-------------------------------------------------------------------------------------- Example: Nested datatype, record selectors-----------------------------------------------------------------------------------data Nested a = Leaf | Nested { value :: a, rec :: Nested [a] }- deriving Functor--#if __GLASGOW_HASKELL__ >= 701-deriving instance Generic (Nested a)-#endif--#if __GLASGOW_HASKELL__ < 705-$(deriveMeta ''Nested)-#endif--#if __GLASGOW_HASKELL__ < 701-$(deriveRepresentable0 ''Nested)-#endif--#if __GLASGOW_HASKELL__ >= 705-deriving instance Generic1 Nested-#else-$(deriveRepresentable1 ''Nested)-#endif--#if __GLASGOW_HASKELL__ < 701--- Instance for gshow (should be automatically generated)-instance (GShow a) => GShow (Nested a) where- gshowsPrec = gshowsPrecdefault--instance GFunctor Nested where- gmap = gmapdefault--#else--instance (GShow a) => GShow (Nested a)-instance GFunctor Nested--#endif---- Example usage-nested :: Nested Int-nested = Nested 1 (Nested [2] (Nested [[3],[4,5],[]] Leaf))---nested = Nested 1 (Nested (Nested 1 Leaf) Leaf)---testsNested = [ gshow nested- , gshow (gmap gshow nested) ]------------------------------------------------------------------------------------- Example: Type composition-----------------------------------------------------------------------------------data Rose a = Rose [a] [Rose a]--#if __GLASGOW_HASKELL__ >= 701-deriving instance Generic (Rose a)-#else--type Rep0Rose a = D1 RoseD (C1 RoseC (Rec0 [a] :*: Rec0 [Rose a]))-instance Generic (Rose a) where- type Rep (Rose a) = Rep0Rose a- from (Rose a x) = M1 (M1 (K1 a :*: K1 x))- to (M1 (M1 (K1 a :*: K1 x))) = Rose a x--#endif--#if __GLASGOW_HASKELL__ >= 705-deriving instance Generic1 Rose-#else--data RoseD-data RoseC--instance Datatype RoseD where- datatypeName _ = "Rose"- moduleName _ = "Examples"--instance Constructor RoseC where conName _ = "Rose"---- Generic1 instances-type RepRose = D1 RoseD (C1 RoseC (Rec1 [] :*: [] :.: Rec1 Rose))-instance Generic1 Rose where- type Rep1 Rose = RepRose- from1 (Rose a x) = M1 (M1 (Rec1 a :*: Comp1 (gmap Rec1 x)))- to1 (M1 (M1 (Rec1 a :*: Comp1 x))) = Rose a (gmap unRec1 x)--#endif--#if __GLASGOW_HASKELL__ >= 701--instance (GShow a) => GShow (Rose a)-instance GFunctor Rose--#else---- Instance for gshow (should be automatically generated)-instance (GShow a) => GShow (Rose a) where- gshowsPrec = gshowsPrecdefault--instance GFunctor Rose where- gmap = gmapdefault--#endif---- Example usage-rose1 :: Rose Int-rose1 = Rose [1,2] [Rose [3,4] [], Rose [5] []]--testsRose = [ gshow rose1- , gshow (gmap gshow rose1) ]------------------------------------------------------------------------------------- Example: Higher-order kinded datatype, type composition-----------------------------------------------------------------------------------data GRose f a = GRose (f a) (f (GRose f a))--deriving instance (Functor f) => Functor (GRose f)--#if __GLASGOW_HASKELL__ >= 701-deriving instance Generic (GRose f a)-#endif--#if __GLASGOW_HASKELL__ < 705-$(deriveMeta ''GRose)-#endif--#if __GLASGOW_HASKELL__ < 701-$(deriveRepresentable0 ''GRose)-#endif--#if __GLASGOW_HASKELL__ >= 705-deriving instance (Functor f) => Generic1 (GRose f)-#else-$(deriveRep1 ''GRose)-instance (Functor f) => Generic1 (GRose f) where- type Rep1 (GRose f) = $(makeRep1 ''GRose) f- from1 = $(makeFrom1 ''GRose)- to1 = $(makeTo1 ''GRose)-#endif--#if __GLASGOW_HASKELL__ < 701--- Requires UndecidableInstances-instance (GShow (f a), GShow (f (GRose f a))) => GShow (GRose f a) where- gshowsPrec = gshowsPrecdefault--instance (Functor f, GFunctor f) => GFunctor (GRose f) where- gmap = gmapdefault--#else--instance (GShow (f a), GShow (f (GRose f a))) => GShow (GRose f a)-instance (Functor f, GFunctor f) => GFunctor (GRose f)--#endif---- Example usage-grose1 :: GRose [] Int-grose1 = GRose [1,2] [GRose [3] [], GRose [] []]--testsGRose = [ gshow grose1- , gshow (gmap gshow grose1) ]------------------------------------------------------------------------------------- Example: NGRose (minimal)------------------------------------------------------------------------------------- Cannot represent because of nesting on an argument other than the parameter-{--data NGRose f a = NGNode a (f (NGRose (Comp f f) a))-data Comp f g a = Comp (f (g a))--type Rep0NGRose f a = Par0 a :*: Rec0 (f (NGRose (Comp f f) a))-instance Generic (NGRose f a) (Rep0NGRose f a) where- from (NGNode a x) = K1 a :*: K1 x- to (K1 a :*: K1 x) = NGNode a x--type Rep0Comp f g a = Rec0 (f (g a))-instance Generic (Comp f g a) (Rep0Comp f g a) where- from (Comp x) = K1 x- to (K1 x) = Comp x--type Rep1Comp f g = f :.: Rec1 g-instance (GFunctor f) => Generic1 (Comp f g) (Rep1Comp f g) where- from1 (Comp x) = Comp1 (gmap Rec1 x)- to1 (Comp1 x) = Comp (gmap unRec1 x)--type Rep1NGRose f = Par1 :*: f :.: Rec1 (NGRose (Comp f f))-instance (GFunctor f) => Generic1 (NGRose f) (Rep1NGRose f) where- from1 (NGNode a x) = Par1 a :*: (Comp1 (gmap Rec1 x))- to1 (Par1 a :*: Comp1 x) = NGNode a (gmap unRec1 x)--instance (GShow a, GShow (f (NGRose (Comp f f) a))) => GShow (NGRose f a) where- gshowsPrec = t undefined where- t :: (GShow a, GShow (f (NGRose (Comp f f) a))) => Rep0NGRose f a x -> NGRose f a -> ShowS- t = gshowsPrecdefault--instance (GShow a) => GShow (Comp f g a) where- gshowsPrec = t undefined where- t :: (GShow a) => Rep0Comp f g a x -> Comp f g a -> ShowS- t = gshowsPrecdefault--instance (GFunctor f, GFunctor (Comp f f)) => GFunctor (NGRose f) where- gmap = t undefined where- t :: (GFunctor f, GFunctor (Comp f f)) => Rep1NGRose f a -> (a -> b) -> NGRose f a -> NGRose f b- t = gmapdefault--ngrose1 :: NGRose [] Int-ngrose1 = NGNode 0 [ngrose2, ngrose2]--ngrose2 :: NGRose (Comp [] []) Int-ngrose2 = NGNode 1 (Comp [])--testsNGRose = [ gshow ngrose1- , gshow (gmap gshow ngrose1) ]--}------------------------------------------------------------------------------------- Example: Double type composition (minimal)------------------------------------------------------------------------------------- Add this to EHC-unComp (Comp1 x) = x--data Weird a = Weird [[[a]]] deriving Show--type Rep1Weird = [] :.: [] :.: Rec1 []-instance Generic1 Weird where- type Rep1 Weird = Rep1Weird- from1 (Weird x) = Comp1 (gmap (Comp1 . gmap Rec1) x)- to1 (Comp1 x) = Weird (gmap (gmap unRec1 . unComp) x)--#if __GLASGOW_HASKELL__ >= 701--instance GFunctor Weird--#else--instance GFunctor Weird where- gmap = gmapdefault--#endif------------------------------------------------------------------------------------- Example: Nested datatype Bush (minimal)-----------------------------------------------------------------------------------data Bush a = BushNil | BushCons a (Bush (Bush a)) deriving Functor--#if __GLASGOW_HASKELL__ >= 701-deriving instance Generic (Bush a)-#endif--#if __GLASGOW_HASKELL__ < 705-$(deriveMeta ''Bush)-#endif--#if __GLASGOW_HASKELL__ < 701-$(deriveRepresentable0 ''Bush)-#endif--#if __GLASGOW_HASKELL__ >= 705-deriving instance Generic1 Bush-#else-$(deriveRepresentable1 ''Bush)-#endif--#if __GLASGOW_HASKELL__ < 701--instance GFunctor Bush where- gmap = gmapdefault--instance (GShow a) => GShow (Bush a) where- gshowsPrec = gshowsPrecdefault--#else--instance GFunctor Bush-instance (GShow a) => GShow (Bush a)--#endif---- Example usage-bush1 :: Bush Int-bush1 = BushCons 0 (BushCons (BushCons 1 BushNil) BushNil)--testsBush = [ gshow bush1- , gshow (gmap gshow bush1) ]------------------------------------------------------------------------------------- Example: Two parameters, datatype constraint, nested on other parameter------------------------------------------------------------------------------------- Any constraints on |b| mean we cannot generate the Generic1 instance--- Constraints on |a| are just propagated to Generic and generic--- function instances-data (Show a) => Either a b = Left (Either [a] b) | Right b----- Generic1 instances-type Rep0Either a b = Rec0 (Either [a] b) :+: Rec0 b-instance (Show a) => Generic (Either a b) where- type Rep (Either a b) = Rep0Either a b- from (Left a) = L1 (K1 a)- from (Right a) = R1 (K1 a)- to (L1 (K1 a)) = Left a- to (R1 (K1 a)) = Right a--type RepEither a = Rec1 (Either [a]) :+: Par1-instance (Show a) => Generic1 (Either a) where- type Rep1 (Either a) = RepEither a- from1 (Left a) = L1 (Rec1 a)- from1 (Right a) = R1 (Par1 a)- to1 (L1 (Rec1 a)) = Left a- to1 (R1 (Par1 a)) = Right a---#if __GLASGOW_HASKELL__ < 701--- Instance for gshow (should be automatically generated)-instance (Show a, GShow a, GShow b) => GShow (Either a b) where- gshowsPrec = gshowsPrecdefault--instance (Show a) => GFunctor (Either a) where- gmap = gmapdefault--#else--instance (Show a, GShow a, GShow b) => GShow (Either a b)-instance (Show a) => GFunctor (Either a)--#endif--either1 :: Either Int Char-either1 = Left either2--either2 :: Either [Int] Char-either2 = Right 'p'--testsEither = [ gshow either1- , gshow (gmap gshow either1) ]------------------------------------------------------------------------------------- Main tests-----------------------------------------------------------------------------------main :: IO ()-main = do- let p = putStrLn . ((++) "- ") . show- putStrLn "[] and Maybe tests:"- mapM_ p testsStandard- putStrLn "Tests for Tree:"- mapM_ p testsTree- putStrLn "\nTests for List:"- mapM_ p testsList- putStrLn "\nTests for Rose:"- mapM_ p testsRose- putStrLn "\nTests for GRose:"- mapM_ p testsGRose- putStrLn "\nTests for Either:"- mapM_ p testsEither- putStrLn "\nTests for Nested:"- mapM_ p testsNested- putStrLn "\nTests for Bush:"- mapM_ p testsBush
generic-deriving.cabal view
@@ -1,5 +1,5 @@ name: generic-deriving-version: 1.11+version: 1.11.1 synopsis: Generic programming library for generalised deriving. description: @@ -24,7 +24,7 @@ maintainer: generics@haskell.org stability: experimental build-type: Simple-cabal-version: >= 1.6+cabal-version: >= 1.10 tested-with: GHC == 7.0.4 , GHC == 7.2.2 , GHC == 7.4.2@@ -32,8 +32,7 @@ , GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.1-extra-source-files: examples/Examples.hs- , CHANGELOG.md+extra-source-files: CHANGELOG.md , README.md source-repository head@@ -78,4 +77,18 @@ , ghc-prim < 1 , template-haskell >= 2.4 && < 2.12 + default-language: Haskell2010 ghc-options: -Wall++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules: ExampleSpec+ TypeInTypeSpec+ build-depends: base >= 4.3 && < 5+ , generic-deriving == 1.11.1+ , hspec >= 2 && < 3+ , template-haskell >= 2.4 && < 2.12+ hs-source-dirs: tests+ default-language: Haskell2010+ ghc-options: -Wall -threaded -rtsopts
src/Generics/Deriving/Base/Internal.hs view
@@ -729,8 +729,17 @@ -- | Recursive calls of kind * -> * newtype Rec1 f p = Rec1 { unRec1 :: f p }- deriving (Eq, Ord, Read, Functor, Foldable, Traversable, Show)+ deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data) +instance Typeable1 f => Typeable1 (Rec1 f) where+ typeOf1 t = mkTyConApp rec1TyCon [typeOf1 (f t)]+ where+ f :: Rec1 f a -> f a+ f = undefined++rec1TyCon :: TyCon+rec1TyCon = mkTyCon "Generics.Deriving.Base.Internal.Rec1"+ instance Applicative f => Applicative (Rec1 f) where pure a = Rec1 (pure a) Rec1 f <*> Rec1 x = Rec1 (f <*> x)@@ -763,8 +772,23 @@ -- | Meta-information (constructor names, etc.) newtype M1 i c f p = M1 { unM1 :: f p }- deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)+ deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data) +instance (Typeable i, Typeable c, Typeable1 f) => Typeable1 (M1 i c f) where+ typeOf1 t = mkTyConApp m1TyCon [typeOf (i t), typeOf (c t), typeOf1 (f t)]+ where+ i :: M1 i c f p -> i+ i = undefined++ c :: M1 i c f p -> c+ c = undefined++ f :: M1 i c f p -> f p+ f = undefined++m1TyCon :: TyCon+m1TyCon = mkTyCon "Generics.Deriving.Base.Internal.M1"+ instance Applicative f => Applicative (M1 i c f) where pure a = M1 (pure a) M1 f <*> M1 x = M1 (f <*> x)@@ -787,13 +811,37 @@ -- | Sums: encode choice between constructors infixr 5 :+: data (:+:) f g p = L1 (f p) | R1 (g p)- deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)+ deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data) +instance (Typeable1 f, Typeable1 g) => Typeable1 (f :+: g) where+ typeOf1 t = mkTyConApp conSumTyCon [typeOf1 (f t), typeOf1 (g t)]+ where+ f :: (f :+: g) p -> f p+ f = undefined++ g :: (f :+: g) p -> g p+ g = undefined++conSumTyCon :: TyCon+conSumTyCon = mkTyCon "Generics.Deriving.Base.Internal.:+:"+ -- | Products: encode multiple arguments to constructors infixr 6 :*: data (:*:) f g p = f p :*: g p- deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)+ deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data) +instance (Typeable1 f, Typeable1 g) => Typeable1 (f :*: g) where+ typeOf1 t = mkTyConApp conProductTyCon [typeOf1 (f t), typeOf1 (g t)]+ where+ f :: (f :*: g) p -> f p+ f = undefined++ g :: (f :*: g) p -> g p+ g = undefined++conProductTyCon :: TyCon+conProductTyCon = mkTyCon "Generics.Deriving.Base.Internal.:*:"+ instance (Applicative f, Applicative g) => Applicative (f :*: g) where pure a = pure a :*: pure a (f :*: g) <*> (x :*: y) = (f <*> x) :*: (g <*> y)@@ -822,7 +870,19 @@ -- | Composition of functors infixr 7 :.: newtype (:.:) f g p = Comp1 { unComp1 :: f (g p) }- deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable)+ deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data)++instance (Typeable1 f, Typeable1 g) => Typeable1 (f :.: g) where+ typeOf1 t = mkTyConApp conComposeTyCon [typeOf1 (f t), typeOf1 (g t)]+ where+ f :: (f :.: g) p -> f p+ f = undefined++ g :: (f :.: g) p -> g p+ g = undefined++conComposeTyCon :: TyCon+conComposeTyCon = mkTyCon "Generics.Deriving.Base.Internal.:.:" instance (Applicative f, Applicative g) => Applicative (f :.: g) where pure x = Comp1 (pure (pure x))
src/Generics/Deriving/TH.hs view
@@ -289,7 +289,14 @@ deriveInst Generic = deriveInstCommon genericTypeName repTypeName Generic fromValName toValName deriveInst Generic1 = deriveInstCommon generic1TypeName rep1TypeName Generic1 from1ValName to1ValName -deriveInstCommon :: Name -> Name -> GenericClass -> Name -> Name -> Options -> Name -> Q [Dec]+deriveInstCommon :: Name+ -> Name+ -> GenericClass+ -> Name+ -> Name+ -> Options+ -> Name+ -> Q [Dec] deriveInstCommon genericName repName gClass fromName toName opts n = do i <- reifyDataInfo n let (name, isNT, allTvbs, cons, dv) = either error id i@@ -526,7 +533,7 @@ -> Type -> Q Type makeRepInline gClass dv name isNT cons ty = do- let instVars = map tyVarBndrToType $ tyVarsOfType ty+ let instVars = map tyVarBndrToType $ requiredTyVarsOfType ty repType gClass dv name isNT cons instVars makeRepTySynApp :: GenericClass@@ -540,7 +547,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 = nub . map unKindedTV $ requiredTyVarsOfType ty+ let instTvbs = map unKindedTV $ requiredTyVarsOfType ty -- We grab the type variables from the first constructor's type signature. -- Or, if there are no constructors, we grab no type variables. The latter -- is okay because we use zipWith to ensure that we never pass more type@@ -647,8 +654,8 @@ -- See Note [Substituting types in a constructor type signature] typeSubst :: TypeSubst typeSubst = Map.fromList $- zip (concatMap tyVarNamesOfType conVars)- (concatMap (map VarT . tyVarNamesOfType) tySynVars)+ zip (nub $ concatMap tyVarNamesOfType conVars)+ (nub $ concatMap (map VarT . tyVarNamesOfType) tySynVars) f :: [Q Type] f = case mbSelNames of
src/Generics/Deriving/TH/Internal.hs view
@@ -176,30 +176,17 @@ go (VarT n) = [n] go _ = [] --- | Gets all of the type/kind variable binders mentioned in a Type.-tyVarsOfType :: Type -> [TyVarBndr]-tyVarsOfType = go- where- go :: Type -> [TyVarBndr]- go (AppT t1 t2) = go t1 ++ go t2- go (SigT t _k) = go t-#if MIN_VERSION_template_haskell(2,8,0)- ++ go _k-#endif- go (VarT n) = [PlainTV n]- go _ = []---- | Gets all of the required type/kind variable binders mentioned in a Type. In--- contrast to 'tyVarsOfType', 'requiredTyVarsOfType' does not go into kinds--- of 'SigT's.+-- | 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 'tyVarNamesOfType'). requiredTyVarsOfType :: Type -> [TyVarBndr] requiredTyVarsOfType = go where go :: Type -> [TyVarBndr]- go (AppT t1 t2) = go t1 ++ go t2- go (SigT t _) = go t- go (VarT n) = [PlainTV n]- go _ = []+ go (AppT t1 t2) = go t1 ++ go t2+ go (SigT (VarT n) k) = [KindedTV n k]+ go (VarT n) = [PlainTV n]+ go _ = [] -- | Converts a VarT or a SigT into Just the corresponding TyVarBndr. -- Converts other Types to Nothing.
+ tests/ExampleSpec.hs view
@@ -0,0 +1,421 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++#if __GLASGOW_HASKELL__ >= 705+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+#endif++{-# OPTIONS_GHC -fno-warn-orphans #-}++module ExampleSpec (main, spec) where++import Generics.Deriving+import Generics.Deriving.TH++import GHC.Exts (Addr#, Char#, Double#, Float#, Int#, Word#)++import Prelude hiding (Either(..))++import Test.Hspec (Spec, describe, hspec, it, parallel, shouldBe)++import qualified Text.Read.Lex (Lexeme)++main :: IO ()+main = hspec spec++spec :: Spec+spec = parallel $ do+ describe "[] and Maybe tests" $ do+ it "gshow hList" $+ gshow hList `shouldBe`+ "[1,2,3,4,5,6,7,8,9,10]"++ it "gshow (children maybe2)" $+ gshow (children maybe2) `shouldBe`+ "[]"++ it "gshow (transform (const \"abc\") [])" $+ gshow (transform (const "abc") []) `shouldBe`+ "\"abc\""++ it "gshow (transform double hList)" $+ gshow (transform double hList) `shouldBe`+ "[1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,10,10]"++ it "gshow (geq hList hList)" $+ gshow (geq hList hList) `shouldBe`+ "True"++ it "gshow (geq maybe1 maybe2)" $+ gshow (geq maybe1 maybe2) `shouldBe`+ "False"++ it "gshow (take 5 genum)" $+ gshow (take 5 (genum :: [Maybe Int])) `shouldBe`+ "[Nothing,Just 0,Just -1,Just 1,Just -2]"++ it "gshow (take 15 genum)" $+ gshow (take 15 (genum :: [[Int]])) `shouldBe`+ "[[],[0],[0,0],[-1],[0,0,0],[-1,0],[1],[0,-1],[-1,0,0],[1,0],[-2],[0,0,0,0],[-1,-1],[1,0,0],[-2,0]]"++ it "gshow (range ([0], [1]))" $+ gshow (range ([0], [1::Int])) `shouldBe`+ "[[0],[0,0],[-1],[0,0,0],[-1,0]]"++ it "gshow (inRange ([0], [3,5]) hList)" $+ gshow (inRange ([0], [3,5::Int]) hList) `shouldBe`+ "False"++ describe "Tests for Tree" $ do+ it "gshow tree" $+ gshow tree `shouldBe`+ "Branch 2 Empty (Branch 1 Empty Empty)"++ it "gshow (children tree)" $+ gshow (children tree) `shouldBe`+ "[Empty,Branch 1 Empty Empty]"++ it "gshow (descend (descend (\\_ -> Branch 0 Empty Empty)) tree)" $+ gshow (descend (descend (\_ -> Branch 0 Empty Empty)) tree) `shouldBe`+ "Branch 2 Empty (Branch 1 (Branch 0 Empty Empty) (Branch 0 Empty Empty))"++ it "gshow (context tree [Branch 1 Empty Empty,Empty])" $+ gshow (context tree [Branch 1 Empty Empty,Empty]) `shouldBe`+ "Branch 2 (Branch 1 Empty Empty) Empty"++ it "gshow (transform upgradeTree tree)" $+ gshow (transform upgradeTree tree) `shouldBe`+ "Branch 3 (Branch 0 Empty Empty) (Branch 2 (Branch 0 Empty Empty) (Branch 0 Empty Empty))"++ it "gshow (take 10 genum)" $ do+ gshow (take 10 (genum :: [Tree])) `shouldBe`+ "[Empty,Branch 0 Empty Empty,Branch 0 Empty (Branch 0 Empty Empty),Branch -1 Empty Empty,Branch 0 (Branch 0 Empty Empty) Empty,Branch -1 Empty (Branch 0 Empty Empty),Branch 1 Empty Empty,Branch 0 Empty (Branch 0 Empty (Branch 0 Empty Empty)),Branch -1 (Branch 0 Empty Empty) Empty,Branch 1 Empty (Branch 0 Empty Empty)]"++ describe "Tests for List" $ do+ it "gshow (gmap fromEnum list)" $+ gshow (gmap fromEnum list) `shouldBe`+ "Cons 112 (Cons 113 Nil)"++ it "gshow (gmap gshow listlist)" $+ gshow (gmap gshow listlist) `shouldBe`+ "Cons \"Cons 'p' (Cons 'q' Nil)\" (Cons \"Nil\" Nil)"++ it "gshow list" $+ gshow list `shouldBe`+ "Cons 'p' (Cons 'q' Nil)"++ it "gshow listlist" $+ gshow listlist `shouldBe`+ "Cons (Cons 'p' (Cons 'q' Nil)) (Cons Nil Nil)"++ it "gshow (children list)" $+ gshow (children list) `shouldBe`+ "[Cons 'q' Nil]"++ it "gshow (children listlist)" $+ gshow (children listlist) `shouldBe`+ "[Cons Nil Nil]"++ describe "Tests for Rose" $ do+ it "gshow rose1" $+ gshow rose1 `shouldBe`+ "Rose [1,2] [Rose [3,4] [],Rose [5] []]"++ it "gshow (gmap gshow rose1)" $+ gshow (gmap gshow rose1) `shouldBe`+ "Rose [\"1\",\"2\"] [Rose [\"3\",\"4\"] [],Rose [\"5\"] []]"++ describe "Tests for GRose" $ do+ it "gshow grose1" $+ gshow grose1 `shouldBe`+ "GRose [1,2] [GRose [3] [],GRose [] []]"++ it "gshow (gmap gshow grose1)" $+ gshow (gmap gshow grose1) `shouldBe`+ "GRose [\"1\",\"2\"] [GRose [\"3\"] [],GRose [] []]"++ describe "Tests for Either" $ do+ it "gshow either1" $+ gshow either1 `shouldBe`+ "Left Right 'p'"++ it "gshow (gmap gshow either1)" $+ gshow (gmap gshow either1) `shouldBe`+ "Left Right \"'p'\""++ describe "Tests for Nested" $ do+ it "gshow nested" $+ gshow nested `shouldBe`+ "Nested {value = 1, rec = Nested {value = [2], rec = Nested {value = [[3],[4,5],[]], rec = Leaf}}}"++ it "gshow (gmap gshow nested)" $+ gshow (gmap gshow nested) `shouldBe`+ "Nested {value = \"1\", rec = Nested {value = [\"2\"], rec = Nested {value = [[\"3\"],[\"4\",\"5\"],[]], rec = Leaf}}}"++ describe "Tests for Bush" $ do+ it "gshow bush1" $+ gshow bush1 `shouldBe`+ "BushCons 0 (BushCons (BushCons 1 BushNil) BushNil)"++ it "gshow (gmap gshow bush1)" $+ gshow (gmap gshow bush1) `shouldBe`+ "BushCons \"0\" (BushCons (BushCons \"1\" BushNil) BushNil)"++-------------------------------------------------------------------------------+-- Example: Haskell's lists and Maybe+-------------------------------------------------------------------------------++hList:: [Int]+hList = [1..10]++maybe1, maybe2 :: Maybe (Maybe Char)+maybe1 = Nothing+maybe2 = Just (Just 'p')++double :: [Int] -> [Int]+double [] = []+double (x:xs) = x:x:xs++-------------------------------------------------------------------------------+-- Example: trees of integers (kind *)+-------------------------------------------------------------------------------++data Tree = Empty | Branch Int Tree Tree++instance GShow Tree where+ gshowsPrec = gshowsPrecdefault++instance Uniplate Tree where+ children = childrendefault+ context = contextdefault+ descend = descenddefault+ descendM = descendMdefault+ transform = transformdefault+ transformM = transformMdefault++instance GEnum Tree where+ genum = genumDefault++upgradeTree :: Tree -> Tree+upgradeTree Empty = Branch 0 Empty Empty+upgradeTree (Branch n l r) = Branch (succ n) l r++tree :: Tree+tree = Branch 2 Empty (Branch 1 Empty Empty)++-------------------------------------------------------------------------------+-- Example: lists (kind * -> *)+-------------------------------------------------------------------------------++data List a = Nil | Cons a (List a)++instance GFunctor List where+ gmap = gmapdefault++instance (GShow a) => GShow (List a) where+ gshowsPrec = gshowsPrecdefault++instance (Uniplate a) => Uniplate (List a) where+ children = childrendefault+ context = contextdefault+ descend = descenddefault+ descendM = descendMdefault+ transform = transformdefault+ transformM = transformMdefault++list :: List Char+list = Cons 'p' (Cons 'q' Nil)++listlist :: List (List Char)+listlist = Cons list (Cons Nil Nil) -- ["pq",""]++-------------------------------------------------------------------------------+-- Example: Type composition+-------------------------------------------------------------------------------++data Rose a = Rose [a] [Rose a]++instance (GShow a) => GShow (Rose a) where+ gshowsPrec = gshowsPrecdefault++instance GFunctor Rose where+ gmap = gmapdefault++-- Example usage+rose1 :: Rose Int+rose1 = Rose [1,2] [Rose [3,4] [], Rose [5] []]++-------------------------------------------------------------------------------+-- Example: Higher-order kinded datatype, type composition+-------------------------------------------------------------------------------++data GRose f a = GRose (f a) (f (GRose f a))+deriving instance Functor f => Functor (GRose f)++instance (GShow (f a), GShow (f (GRose f a))) => GShow (GRose f a) where+ gshowsPrec = gshowsPrecdefault++instance (Functor f, GFunctor f) => GFunctor (GRose f) where+ gmap = gmapdefault++grose1 :: GRose [] Int+grose1 = GRose [1,2] [GRose [3] [], GRose [] []]++-------------------------------------------------------------------------------+-- Example: Two parameters, nested on other parameter+-------------------------------------------------------------------------------++data Either a b = Left (Either [a] b) | Right b++instance (GShow a, GShow b) => GShow (Either a b) where+ gshowsPrec = gshowsPrecdefault++instance GFunctor (Either a) where+ gmap = gmapdefault++either1 :: Either Int Char+either1 = Left either2++either2 :: Either [Int] Char+either2 = Right 'p'++-------------------------------------------------------------------------------+-- Example: Nested datatype, record selectors+-------------------------------------------------------------------------------++data Nested a = Leaf | Nested { value :: a, rec :: Nested [a] }+ deriving Functor++instance (GShow a) => GShow (Nested a) where+ gshowsPrec = gshowsPrecdefault++instance GFunctor Nested where+ gmap = gmapdefault++nested :: Nested Int+nested = Nested { value = 1, rec = Nested [2] (Nested [[3],[4,5],[]] Leaf) }++-------------------------------------------------------------------------------+-- Example: Nested datatype Bush (minimal)+-------------------------------------------------------------------------------++data Bush a = BushNil | BushCons a (Bush (Bush a)) deriving Functor++instance GFunctor Bush where+ gmap = gmapdefault++instance (GShow a) => GShow (Bush a) where+ gshowsPrec = gshowsPrecdefault++bush1 :: Bush Int+bush1 = BushCons 0 (BushCons (BushCons 1 BushNil) BushNil)++-------------------------------------------------------------------------------+-- Example: Double type composition (minimal)+-------------------------------------------------------------------------------++data Weird a = Weird [[[a]]] deriving Show++instance GFunctor Weird where+ gmap = gmapdefault++--------------------------------------------------------------------------------+-- Temporary tests for TH generation+--------------------------------------------------------------------------------++data Empty a++data (:/:) f a = MyType1Nil+ | MyType1Cons { _myType1Rec :: (f :/: a), _myType2Rec :: MyType2 }+ | MyType1Cons2 (f :/: a) Int a (f a)+ | (f :/: a) :/: MyType2++infixr 5 :!@!:+data GADTSyntax a b where+ GADTPrefix :: d -> c -> GADTSyntax c d+ (:!@!:) :: e -> f -> GADTSyntax e f++data MyType2 = MyType2 Float ([] :/: Int)+data PlainHash a = Hash a Addr# Char# Double# Float# Int# Word#++-- Test to see if generated names are unique+data Lexeme = Lexeme++#if MIN_VERSION_template_haskell(2,7,0)+data family MyType3+# if __GLASGOW_HASKELL__ >= 705+ (a :: v) (b :: w) (c :: x) (d :: y) (e :: z)+# else+ (a :: *) (b :: *) (c :: * -> *) (d :: *) (e :: *)+# endif+newtype instance MyType3 (f p) (f p) f p q = MyType3Newtype q+data instance MyType3 Bool () f p q = MyType3True | MyType3False+data instance MyType3 Int () f p q = MyType3Hash q Addr# Char# Double# Float# Int# Word#+#endif++-------------------------------------------------------------------------------+-- Template Haskell bits+-------------------------------------------------------------------------------++$(deriveAll0 ''Tree)++$(deriveAll0And1 ''List)++$(deriveAll0And1 ''Rose)++$(deriveMeta ''GRose)+$(deriveRepresentable0 ''GRose)+$(deriveRep1 ''GRose)+instance Functor f => Generic1 (GRose f) where+ type Rep1 (GRose f) = $(makeRep1 ''GRose) f+ from1 = $(makeFrom1 ''GRose)+ to1 = $(makeTo1 ''GRose)++$(deriveAll0And1 ''Either)++$(deriveAll0And1 ''Nested)++$(deriveAll0And1 ''Bush)++$(deriveAll0And1 ''Weird)++$(deriveAll0And1 ''Empty)+$(deriveAll0And1 ''(:/:))+$(deriveAll0And1 ''GADTSyntax)+$(deriveAll0 ''MyType2)+$(deriveAll0And1 ''PlainHash)+$(deriveAll0 ''ExampleSpec.Lexeme)+$(deriveAll0 ''Text.Read.Lex.Lexeme)++#if MIN_VERSION_template_haskell(2,7,0)+# if __GLASGOW_HASKELL__ < 705+-- We can't use deriveAll0And1 on GHC 7.4 due to an old bug :(+$(deriveMeta 'MyType3Newtype)+$(deriveRep0 'MyType3Newtype)+$(deriveRep1 'MyType3Newtype)+instance Generic (MyType3 (f p) (f p) f p q) where+ type Rep (MyType3 (f p) (f p) f p q) = $(makeRep0 'MyType3Newtype) f p q+ from = $(makeFrom0 'MyType3Newtype)+ to = $(makeTo0 'MyType3Newtype)+instance Generic1 (MyType3 (f p) (f p) f p) where+ type Rep1 (MyType3 (f p) (f p) f p) = $(makeRep1 'MyType3Newtype) f p+ from1 = $(makeFrom1 'MyType3Newtype)+ to1 = $(makeTo1 'MyType3Newtype)+# else+$(deriveAll0And1 'MyType3Newtype)+# endif+$(deriveAll0And1 'MyType3False)+$(deriveAll0And1 'MyType3Hash)+#endif
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ tests/TypeInTypeSpec.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++#if __GLASGOW_HASKELL__ >= 800+{-# LANGUAGE TypeInType #-}+#endif++module TypeInTypeSpec (main, spec) where++import Test.Hspec++#if __GLASGOW_HASKELL__ >= 800+import Data.Proxy (Proxy)+import Generics.Deriving.TH++data TyCon x (a :: x) (b :: k) = TyCon k x (Proxy a) (TyCon x a b)+$(deriveAll0And1 ''TyCon)++data family TyFam x (a :: x) (b :: k)+data instance TyFam x (a :: x) (b :: k) = TyFam k x (Proxy a) (TyFam x a b)+$(deriveAll0And1 'TyFam)+#endif++main :: IO ()+main = hspec spec++spec :: Spec+spec = return ()