generic-deriving 1.9.0 → 1.10.0
raw patch · 19 files changed
+8938/−7237 lines, 19 filesdep ~basedep ~template-haskellPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, template-haskell
API changes (from Hackage documentation)
+ Generics.Deriving.Copoint: instance Generics.Deriving.Copoint.GCopoint f => Generics.Deriving.Copoint.GCopoint (Data.Monoid.Alt f)
+ Generics.Deriving.Enum: instance Generics.Deriving.Enum.GEnum GHC.IO.Exception.ExitCode
+ Generics.Deriving.Enum: instance Generics.Deriving.Enum.GEnum GHC.Natural.Natural
+ Generics.Deriving.Enum: instance Generics.Deriving.Enum.GEnum a => Generics.Deriving.Enum.GEnum (Data.Complex.Complex a)
+ Generics.Deriving.Enum: instance Generics.Deriving.Enum.GIx GHC.IO.Exception.ExitCode
+ Generics.Deriving.Eq: instance Generics.Deriving.Eq.GEq (Generics.Deriving.Base.UAddr p)
+ Generics.Deriving.Eq: instance Generics.Deriving.Eq.GEq (Generics.Deriving.Base.UChar p)
+ Generics.Deriving.Eq: instance Generics.Deriving.Eq.GEq (Generics.Deriving.Base.UDouble p)
+ Generics.Deriving.Eq: instance Generics.Deriving.Eq.GEq (Generics.Deriving.Base.UFloat p)
+ Generics.Deriving.Eq: instance Generics.Deriving.Eq.GEq (Generics.Deriving.Base.UInt p)
+ Generics.Deriving.Eq: instance Generics.Deriving.Eq.GEq (Generics.Deriving.Base.UWord p)
+ Generics.Deriving.Eq: instance Generics.Deriving.Eq.GEq Data.Version.Version
+ Generics.Deriving.Eq: instance Generics.Deriving.Eq.GEq a => Generics.Deriving.Eq.GEq (Data.Complex.Complex a)
+ Generics.Deriving.Foldable: instance Generics.Deriving.Foldable.GFoldable Control.Applicative.ZipList
+ Generics.Deriving.Foldable: instance Generics.Deriving.Foldable.GFoldable Data.Complex.Complex
+ Generics.Deriving.Foldable: instance Generics.Deriving.Foldable.GFoldable Data.Monoid.Dual
+ Generics.Deriving.Foldable: instance Generics.Deriving.Foldable.GFoldable Data.Monoid.First
+ Generics.Deriving.Foldable: instance Generics.Deriving.Foldable.GFoldable Data.Monoid.Last
+ Generics.Deriving.Foldable: instance Generics.Deriving.Foldable.GFoldable Data.Monoid.Product
+ Generics.Deriving.Foldable: instance Generics.Deriving.Foldable.GFoldable Data.Monoid.Sum
+ Generics.Deriving.Foldable: instance Generics.Deriving.Foldable.GFoldable Data.Proxy.Proxy
+ Generics.Deriving.Foldable: instance Generics.Deriving.Foldable.GFoldable' Generics.Deriving.Base.UAddr
+ Generics.Deriving.Foldable: instance Generics.Deriving.Foldable.GFoldable' Generics.Deriving.Base.UChar
+ Generics.Deriving.Foldable: instance Generics.Deriving.Foldable.GFoldable' Generics.Deriving.Base.UDouble
+ Generics.Deriving.Foldable: instance Generics.Deriving.Foldable.GFoldable' Generics.Deriving.Base.UFloat
+ Generics.Deriving.Foldable: instance Generics.Deriving.Foldable.GFoldable' Generics.Deriving.Base.UInt
+ Generics.Deriving.Foldable: instance Generics.Deriving.Foldable.GFoldable' Generics.Deriving.Base.UWord
+ Generics.Deriving.Functor: instance Generics.Deriving.Functor.GFunctor Data.Complex.Complex
+ Generics.Deriving.Functor: instance Generics.Deriving.Functor.GFunctor Data.Monoid.Dual
+ Generics.Deriving.Functor: instance Generics.Deriving.Functor.GFunctor Data.Monoid.Product
+ Generics.Deriving.Functor: instance Generics.Deriving.Functor.GFunctor Data.Monoid.Sum
+ Generics.Deriving.Functor: instance Generics.Deriving.Functor.GFunctor Data.Proxy.Proxy
+ Generics.Deriving.Functor: instance Generics.Deriving.Functor.GFunctor' Generics.Deriving.Base.UAddr
+ Generics.Deriving.Functor: instance Generics.Deriving.Functor.GFunctor' Generics.Deriving.Base.UChar
+ Generics.Deriving.Functor: instance Generics.Deriving.Functor.GFunctor' Generics.Deriving.Base.UDouble
+ Generics.Deriving.Functor: instance Generics.Deriving.Functor.GFunctor' Generics.Deriving.Base.UFloat
+ Generics.Deriving.Functor: instance Generics.Deriving.Functor.GFunctor' Generics.Deriving.Base.UInt
+ Generics.Deriving.Functor: instance Generics.Deriving.Functor.GFunctor' Generics.Deriving.Base.UWord
+ Generics.Deriving.Instances: instance GHC.Generics.Constructor Generics.Deriving.Instances.C1_0Complex
+ Generics.Deriving.Instances: instance GHC.Generics.Constructor Generics.Deriving.Instances.C1_0ExitCode
+ Generics.Deriving.Instances: instance GHC.Generics.Constructor Generics.Deriving.Instances.C1_0Proxy
+ Generics.Deriving.Instances: instance GHC.Generics.Constructor Generics.Deriving.Instances.C1_0Version
+ Generics.Deriving.Instances: instance GHC.Generics.Constructor Generics.Deriving.Instances.C1_1ExitCode
+ Generics.Deriving.Instances: instance GHC.Generics.Datatype Generics.Deriving.Instances.D1Complex
+ Generics.Deriving.Instances: instance GHC.Generics.Datatype Generics.Deriving.Instances.D1ExitCode
+ Generics.Deriving.Instances: instance GHC.Generics.Datatype Generics.Deriving.Instances.D1Proxy
+ Generics.Deriving.Instances: instance GHC.Generics.Datatype Generics.Deriving.Instances.D1Version
+ Generics.Deriving.Instances: instance GHC.Generics.Generic (Data.Complex.Complex a)
+ Generics.Deriving.Instances: instance GHC.Generics.Generic Data.Version.Version
+ Generics.Deriving.Instances: instance GHC.Generics.Generic GHC.IO.Exception.ExitCode
+ Generics.Deriving.Instances: instance GHC.Generics.Generic1 Data.Complex.Complex
+ Generics.Deriving.Instances: instance GHC.Generics.Generic1 Data.Proxy.Proxy
+ Generics.Deriving.Instances: instance GHC.Generics.Selector Generics.Deriving.Instances.S1_0_0Version
+ Generics.Deriving.Instances: instance GHC.Generics.Selector Generics.Deriving.Instances.S1_0_1Version
+ Generics.Deriving.Instances: type Rep0Complex a = D1 D1Complex (C1 C1_0Complex (S1 NoSelector (Rec0 a) :*: S1 NoSelector (Rec0 a)))
+ Generics.Deriving.Instances: type Rep0ExitCode = D1 D1ExitCode (C1 C1_0ExitCode U1 :+: C1 C1_1ExitCode (S1 NoSelector (Rec0 Int)))
+ Generics.Deriving.Instances: type Rep0Version = D1 D1Version (C1 C1_0Version (S1 S1_0_0Version (Rec0 [Int]) :*: S1 S1_0_1Version (Rec0 [String])))
+ Generics.Deriving.Instances: type Rep1Complex = D1 D1Complex (C1 C1_0Complex (S1 NoSelector Par1 :*: S1 NoSelector Par1))
+ Generics.Deriving.Instances: type Rep1Proxy = D1 D1Proxy (C1 C1_0Proxy U1)
+ Generics.Deriving.Show: instance Generics.Deriving.Show.GShow (Generics.Deriving.Base.UChar p)
+ Generics.Deriving.Show: instance Generics.Deriving.Show.GShow (Generics.Deriving.Base.UDouble p)
+ Generics.Deriving.Show: instance Generics.Deriving.Show.GShow (Generics.Deriving.Base.UFloat p)
+ Generics.Deriving.Show: instance Generics.Deriving.Show.GShow (Generics.Deriving.Base.UInt p)
+ Generics.Deriving.Show: instance Generics.Deriving.Show.GShow (Generics.Deriving.Base.UWord p)
+ Generics.Deriving.Show: instance Generics.Deriving.Show.GShow Data.Version.Version
+ Generics.Deriving.Show: instance Generics.Deriving.Show.GShow a => Generics.Deriving.Show.GShow (Data.Complex.Complex a)
+ Generics.Deriving.TH: deriveAll0 :: Name -> Q [Dec]
+ Generics.Deriving.TH: deriveAll0And1WithKindSigs :: Name -> Q [Dec]
+ Generics.Deriving.TH: deriveAll0WithKindSigs :: Name -> Q [Dec]
+ Generics.Deriving.TH: deriveAll1WithKindSigs :: Name -> Q [Dec]
+ Generics.Deriving.TH: deriveRep0WithKindSigs :: Name -> Q [Dec]
+ Generics.Deriving.TH: deriveRep1WithKindSigs :: Name -> Q [Dec]
+ Generics.Deriving.TH: deriveRepresentable0WithKindSigs :: Name -> Q [Dec]
+ Generics.Deriving.TH: deriveRepresentable1WithKindSigs :: Name -> Q [Dec]
+ Generics.Deriving.TH: makeFrom0 :: Name -> Q Exp
+ Generics.Deriving.TH: makeRep0FromType :: Name -> Q Type -> Q Type
+ Generics.Deriving.TH: makeRep1FromType :: Name -> Q Type -> Q Type
+ Generics.Deriving.TH: makeTo0 :: Name -> Q Exp
+ Generics.Deriving.Traversable: instance Generics.Deriving.Traversable.GTraversable Control.Applicative.ZipList
+ Generics.Deriving.Traversable: instance Generics.Deriving.Traversable.GTraversable Data.Complex.Complex
+ Generics.Deriving.Traversable: instance Generics.Deriving.Traversable.GTraversable Data.Monoid.Dual
+ Generics.Deriving.Traversable: instance Generics.Deriving.Traversable.GTraversable Data.Monoid.First
+ Generics.Deriving.Traversable: instance Generics.Deriving.Traversable.GTraversable Data.Monoid.Last
+ Generics.Deriving.Traversable: instance Generics.Deriving.Traversable.GTraversable Data.Monoid.Product
+ Generics.Deriving.Traversable: instance Generics.Deriving.Traversable.GTraversable Data.Monoid.Sum
+ Generics.Deriving.Traversable: instance Generics.Deriving.Traversable.GTraversable Data.Proxy.Proxy
+ Generics.Deriving.Traversable: instance Generics.Deriving.Traversable.GTraversable' Generics.Deriving.Base.UAddr
+ Generics.Deriving.Traversable: instance Generics.Deriving.Traversable.GTraversable' Generics.Deriving.Base.UChar
+ Generics.Deriving.Traversable: instance Generics.Deriving.Traversable.GTraversable' Generics.Deriving.Base.UDouble
+ Generics.Deriving.Traversable: instance Generics.Deriving.Traversable.GTraversable' Generics.Deriving.Base.UFloat
+ Generics.Deriving.Traversable: instance Generics.Deriving.Traversable.GTraversable' Generics.Deriving.Base.UInt
+ Generics.Deriving.Traversable: instance Generics.Deriving.Traversable.GTraversable' Generics.Deriving.Base.UWord
Files
- CHANGELOG.md +44/−14
- examples/Examples.hs +660/−639
- generic-deriving.cabal +74/−69
- src/Generics/Deriving.hs +22/−22
- src/Generics/Deriving/Base.hs +802/−802
- src/Generics/Deriving/Copoint.hs +154/−113
- src/Generics/Deriving/Enum.hs +1032/−890
- src/Generics/Deriving/Eq.hs +564/−475
- src/Generics/Deriving/Foldable.hs +304/−196
- src/Generics/Deriving/Functor.hs +210/−113
- src/Generics/Deriving/Instances.hs +1587/−1462
- src/Generics/Deriving/Monoid.hs +251/−241
- src/Generics/Deriving/Show.hs +614/−536
- src/Generics/Deriving/TH.hs +1131/−1072
- src/Generics/Deriving/TH/Internal.hs +558/−109
- src/Generics/Deriving/TH/Post711.hs +138/−0
- src/Generics/Deriving/TH/Pre711.hs +198/−0
- src/Generics/Deriving/Traversable.hs +212/−101
- src/Generics/Deriving/Uniplate.hs +383/−383
CHANGELOG.md view
@@ -1,14 +1,44 @@-# 1.9.0 -* Allow deriving of Generic1 using Template Haskell -* Allow deriving of Generic(1) for data families -* Allow deriving of Generic(1) for constructor-less plain datatypes (but not - data families, due to technical restrictions) -* Support for unboxed representation types on GHC 7.11+ -* More `GCopoint`, `GEnum`, `GEq`, `GFoldable`, `GFunctor`, `GIx`, `GMonoid`, `GShow`, and `GTraversable` instances -* The field accessors for the `(:+:)` type in `Generics.Deriving.Base` have - been removed to be consistent with `GHC.Generics` -* Ensure that TH generates definitions for isNewtype and packageName, if a - recent-enough version of GHC is used -* Ensure that TH-generated names are unique for a given data type's module and - package (similar in spirit to Trac #10487) -* Allow building on stage-1 compilers +# 1.10.0+* On GHC 8.0 and up, `Generics.Deriving.TH` uses the new type literal-based+ machinery+* Rewrote the Template Haskell code to be robust. Among other things, this fixes+ a bug with deriving Generic1 instances on GHC 7.8, and makes it easier to+ derive Generic1 instances for datatypes that utilize GHC 8.0's `-XTypeInType`+ extension.+* Added `deriveAll0` and `makeRep0` for symmetry with `deriveAll1` and+ `makeRep1`+* Added`makeRep0FromType` and `makeRep1FromType` to make it easier to pass+ in the type instance (instead of having to pass each individual type+ variable, which can be error-prone)+* Added functions with the suffix `-WithKindSigs` to allow generating type+ synonyms with explicit kind signatures in the presence of kind-polymorphic+ type variables. This is necessary for some datatypes that use+ `-XTypeInType` to have derived `Generic(1)` instances, but is not turned on+ by default since the TH kind inference is not perfect and would cause+ otherwise valid code to be rejected. Use only if you know what you are doing.+* Fixed bug where a datatype with a single, nullary constructor would generate+ incorrect `Generic` instances+* More sensible `GEnum` instances for fixed-size integral types+* Added `GCopoint`, `GEnum`, `GEq`, `GFoldable`, `GFunctor`, `GMonoid`,+ `GShow`, and `GTraversable` instances for datatypes introduced in GHC 8.0+* Backported `Generic(1)` instances added in GHC 8.0. Specifically, `Generic`+ instances for `Complex` (`base-4.4` and later) `ExitCode`, and `Version`; and+ `Generic1` instances for `Complex` (`base-4.4` and later) and `Proxy`+ (`base-4.7` and later). Added `GEnum`, `GEq`, `GFoldable`, `GFunctor`, `GIx`,+ `GShow`, and `GTraversable` instances for these datatypes where appropriate.++# 1.9.0+* Allow deriving of Generic1 using Template Haskell+* Allow deriving of Generic(1) for data families+* Allow deriving of Generic(1) for constructor-less plain datatypes (but not+ data families, due to technical restrictions)+* Support for unboxed representation types on GHC 7.11++* More `GCopoint`, `GEnum`, `GEq`, `GFoldable`, `GFunctor`, `GIx`, `GMonoid`,+ `GShow`, and `GTraversable` instances+* The field accessors for the `(:+:)` type in `Generics.Deriving.Base` have+ been removed to be consistent with `GHC.Generics`+* Ensure that TH generates definitions for isNewtype and packageName, if a+ recent-enough version of GHC is used+* Ensure that TH-generated names are unique for a given data type's module and+ package (similar in spirit to Trac #10487)+* Allow building on stage-1 compilers
examples/Examples.hs view
@@ -1,639 +1,660 @@-{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DatatypeContexts #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MagicHash #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DeriveGeneric #-} -#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 - -#if __GLASGOW_HASKELL__ >= 701 - deriving ( Generic -# if __GLASGOW_HASKELL__ >= 705 - , Generic1 -# endif - ) -#endif - -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 MyType2 -#endif - -#if __GLASGOW_HASKELL__ < 705 -$(deriveMeta ''Empty) -$(deriveMeta ''(:/:)) -$(deriveMeta ''MyType2) -#endif - -#if __GLASGOW_HASKELL__ < 701 -$(deriveRepresentable0 ''Empty) -$(deriveRepresentable0 ''(:/:)) -$(deriveRepresentable0 ''MyType2) -#endif - -#if __GLASGOW_HASKELL__ >= 705 -deriving instance Generic1 Empty -#else -$(deriveRepresentable1 ''Empty) -$(deriveRepresentable1 ''(:/:)) -#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 - -$(deriveAll ''Main.Lexeme) -$(deriveAll ''Text.Read.Lex.Lexeme) - -#if __GLASGOW_HASKELL__ >= 703 -data family MyType3 a b -newtype instance MyType3 () b = MyType3Newtype b -data instance MyType3 Bool b = MyType3True | MyType3False -data instance MyType3 Int b = MyType3Hash b Addr# Char# Double# Float# Int# Word# - -# if __GLASGOW_HASKELL__ < 707 -$(deriveMeta 'MyType3Newtype) -$(deriveMeta 'MyType3True) -# endif - -# if __GLASGOW_HASKELL__ >= 705 -deriving instance Generic (MyType3 () b) -deriving instance Generic (MyType3 Bool b) -# else -$(deriveRepresentable0 'MyType3Newtype) -$(deriveRepresentable0 'MyType3True) -# endif - -# if __GLASGOW_HASKELL__ >= 707 -deriving instance Generic1 (MyType3 ()) -deriving instance Generic1 (MyType3 Bool) -# else -$(deriveRepresentable1 'MyType3Newtype) -$(deriveRepresentable1 'MyType3False) -# endif - -# if __GLASGOW_HASKELL__ >= 711 -deriving instance Generic (MyType3 Int b) -deriving instance Generic1 (MyType3 Int) -# 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 - -$(deriveAll ''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 +{-# 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__ >= 711+{-# 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,69 +1,74 @@-name: generic-deriving -version: 1.9.0 -synopsis: Generic programming library for generalised deriving. -description: - - This package provides functionality for generalising the deriving mechanism - in Haskell to arbitrary classes. It was first described in the paper: - . - * /A generic deriving mechanism for Haskell/. - Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh. - Haskell'10. - . - The current implementation integrates with the new GHC Generics. See - <http://www.haskell.org/haskellwiki/GHC.Generics> for more information. - Template Haskell code is provided for supporting GHC before version 7.2. - -homepage: https://github.com/dreixel/generic-deriving -bug-reports: https://github.com/dreixel/generic-deriving/issues -category: Generics -copyright: 2011-2013 Universiteit Utrecht, University of Oxford -license: BSD3 -license-file: LICENSE -author: José Pedro Magalhães -maintainer: generics@haskell.org -stability: experimental -build-type: Simple -cabal-version: >= 1.6 -tested-with: GHC == 7.0.4 - , GHC == 7.2.2 - , GHC == 7.4.2 - , GHC == 7.6.3 - , GHC == 7.8.4 - , GHC == 7.10.2 -extra-source-files: examples/Examples.hs - , CHANGELOG.md - , README.md - -source-repository head - type: git - location: https://github.com/dreixel/generic-deriving - -library - hs-source-dirs: src - exposed-modules: Generics.Deriving - Generics.Deriving.Base - Generics.Deriving.Instances - Generics.Deriving.Copoint - Generics.Deriving.ConNames - Generics.Deriving.Enum - Generics.Deriving.Eq - Generics.Deriving.Foldable - Generics.Deriving.Functor - Generics.Deriving.Monoid - Generics.Deriving.Show - Generics.Deriving.Traversable - Generics.Deriving.Uniplate - - Generics.Deriving.TH - - other-modules: Generics.Deriving.TH.Internal - Paths_generic_deriving - - build-depends: base < 5 - , containers >= 0.1 && < 0.6 - , template-haskell >= 2.4 && < 2.12 - if impl(ghc > 7.0) - build-depends: ghc-prim < 1 - - ghc-options: -Wall +name: generic-deriving+version: 1.10.0+synopsis: Generic programming library for generalised deriving.+description:++ This package provides functionality for generalising the deriving mechanism+ in Haskell to arbitrary classes. It was first described in the paper:+ .+ * /A generic deriving mechanism for Haskell/.+ Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh.+ Haskell'10.+ .+ The current implementation integrates with the new GHC Generics. See+ <http://www.haskell.org/haskellwiki/GHC.Generics> for more information.+ Template Haskell code is provided for supporting GHC before version 7.2.++homepage: https://github.com/dreixel/generic-deriving+bug-reports: https://github.com/dreixel/generic-deriving/issues+category: Generics+copyright: 2011-2013 Universiteit Utrecht, University of Oxford+license: BSD3+license-file: LICENSE+author: José Pedro Magalhães+maintainer: generics@haskell.org+stability: experimental+build-type: Simple+cabal-version: >= 1.6+tested-with: GHC == 7.0.4+ , GHC == 7.2.2+ , GHC == 7.4.2+ , GHC == 7.6.3+ , GHC == 7.8.4+ , GHC == 7.10.2+ , GHC == 8.0.1+extra-source-files: examples/Examples.hs+ , CHANGELOG.md+ , README.md++source-repository head+ type: git+ location: https://github.com/dreixel/generic-deriving++library+ hs-source-dirs: src+ exposed-modules: Generics.Deriving+ Generics.Deriving.Base+ Generics.Deriving.Instances+ Generics.Deriving.Copoint+ Generics.Deriving.ConNames+ Generics.Deriving.Enum+ Generics.Deriving.Eq+ Generics.Deriving.Foldable+ Generics.Deriving.Functor+ Generics.Deriving.Monoid+ Generics.Deriving.Show+ Generics.Deriving.Traversable+ Generics.Deriving.Uniplate++ Generics.Deriving.TH++ other-modules: Generics.Deriving.TH.Internal+ Paths_generic_deriving+ if impl(ghc >= 7.11)+ other-modules: Generics.Deriving.TH.Post711+ else+ other-modules: Generics.Deriving.TH.Pre711++ build-depends: base < 5+ , containers >= 0.1 && < 0.6+ , template-haskell >= 2.4 && < 2.12+ if impl(ghc > 7.0)+ build-depends: ghc-prim < 1++ ghc-options: -Wall
src/Generics/Deriving.hs view
@@ -1,22 +1,22 @@- -module Generics.Deriving ( - - module Generics.Deriving.Base, - module Generics.Deriving.Copoint, - module Generics.Deriving.ConNames, - module Generics.Deriving.Enum, - module Generics.Deriving.Eq, - module Generics.Deriving.Functor, - module Generics.Deriving.Show, - module Generics.Deriving.Uniplate - - ) where - -import Generics.Deriving.Base -import Generics.Deriving.Copoint -import Generics.Deriving.ConNames -import Generics.Deriving.Enum -import Generics.Deriving.Eq -import Generics.Deriving.Functor -import Generics.Deriving.Show -import Generics.Deriving.Uniplate ++module Generics.Deriving (++ module Generics.Deriving.Base,+ module Generics.Deriving.Copoint,+ module Generics.Deriving.ConNames,+ module Generics.Deriving.Enum,+ module Generics.Deriving.Eq,+ module Generics.Deriving.Functor,+ module Generics.Deriving.Show,+ module Generics.Deriving.Uniplate++ ) where++import Generics.Deriving.Base+import Generics.Deriving.Copoint+import Generics.Deriving.ConNames+import Generics.Deriving.Enum+import Generics.Deriving.Eq+import Generics.Deriving.Functor+import Generics.Deriving.Show+import Generics.Deriving.Uniplate
src/Generics/Deriving/Base.hs view
@@ -1,802 +1,802 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} - -module Generics.Deriving.Base ( --- * Introduction --- --- | --- --- Datatype-generic functions are are based on the idea of converting values of --- a datatype @T@ into corresponding values of a (nearly) isomorphic type @'Rep' T@. --- The type @'Rep' T@ is --- built from a limited set of type constructors, all provided by this module. A --- datatype-generic function is then an overloaded function with instances --- for most of these type constructors, together with a wrapper that performs --- the mapping between @T@ and @'Rep' T@. By using this technique, we merely need --- a few generic instances in order to implement functionality that works for any --- representable type. --- --- Representable types are collected in the 'Generic' class, which defines the --- associated type 'Rep' as well as conversion functions 'from' and 'to'. --- Typically, you will not define 'Generic' instances by hand, but have the compiler --- derive them for you. - --- ** Representing datatypes --- --- | --- --- The key to defining your own datatype-generic functions is to understand how to --- represent datatypes using the given set of type constructors. --- --- Let us look at an example first: --- --- @ --- data Tree a = Leaf a | Node (Tree a) (Tree a) --- deriving 'Generic' --- @ --- --- The above declaration (which requires the language pragma @DeriveGeneric@) --- causes the following representation to be generated: --- --- @ --- class 'Generic' (Tree a) where --- type 'Rep' (Tree a) = --- 'D1' D1Tree --- ('C1' C1_0Tree --- ('S1' 'NoSelector' ('Par0' a)) --- ':+:' --- 'C1' C1_1Tree --- ('S1' 'NoSelector' ('Rec0' (Tree a)) --- ':*:' --- 'S1' 'NoSelector' ('Rec0' (Tree a)))) --- ... --- @ --- --- /Hint:/ You can obtain information about the code being generated from GHC by passing --- the @-ddump-deriv@ flag. In GHCi, you can expand a type family such as 'Rep' using --- the @:kind!@ command. --- -#if 0 --- /TODO:/ Newer GHC versions abandon the distinction between 'Par0' and 'Rec0' and will --- use 'Rec0' everywhere. --- -#endif --- This is a lot of information! However, most of it is actually merely meta-information --- that makes names of datatypes and constructors and more available on the type level. --- --- Here is a reduced representation for 'Tree' with nearly all meta-information removed, --- for now keeping only the most essential aspects: --- --- @ --- instance 'Generic' (Tree a) where --- type 'Rep' (Tree a) = --- 'Par0' a --- ':+:' --- ('Rec0' (Tree a) ':*:' 'Rec0' (Tree a)) --- @ --- --- The @Tree@ datatype has two constructors. The representation of individual constructors --- is combined using the binary type constructor ':+:'. --- --- The first constructor consists of a single field, which is the parameter @a@. This is --- represented as @'Par0' a@. --- --- The second constructor consists of two fields. Each is a recursive field of type @Tree a@, --- represented as @'Rec0' (Tree a)@. Representations of individual fields are combined using --- the binary type constructor ':*:'. --- --- Now let us explain the additional tags being used in the complete representation: --- --- * The @'S1' 'NoSelector'@ indicates that there is no record field selector associated with --- this field of the constructor. --- --- * The @'C1' C1_0Tree@ and @'C1' C1_1Tree@ invocations indicate that the enclosed part is --- the representation of the first and second constructor of datatype @Tree@, respectively. --- Here, @C1_0Tree@ and @C1_1Tree@ are datatypes generated by the compiler as part of --- @deriving 'Generic'@. These datatypes are proxy types with no values. They are useful --- because they are instances of the type class 'Constructor'. This type class can be used --- to obtain information about the constructor in question, such as its name --- or infix priority. --- --- * The @'D1' D1Tree@ tag indicates that the enclosed part is the representation of the --- datatype @Tree@. Again, @D1Tree@ is a datatype generated by the compiler. It is a --- proxy type, and is useful by being an instance of class 'Datatype', which --- can be used to obtain the name of a datatype, the module it has been defined in, and --- whether it has been defined using @data@ or @newtype@. - --- ** Derived and fundamental representation types --- --- | --- --- There are many datatype-generic functions that do not distinguish between positions that --- are parameters or positions that are recursive calls. There are also many datatype-generic --- functions that do not care about the names of datatypes and constructors at all. To keep --- the number of cases to consider in generic functions in such a situation to a minimum, --- it turns out that many of the type constructors introduced above are actually synonyms, --- defining them to be variants of a smaller set of constructors. - --- *** Individual fields of constructors: 'K1' --- --- | --- --- The type constructors 'Par0' and 'Rec0' are variants of 'K1': --- --- @ --- type 'Par0' = 'K1' 'P' --- type 'Rec0' = 'K1' 'R' --- @ --- --- Here, 'P' and 'R' are type-level proxies again that do not have any associated values. - --- *** Meta information: 'M1' --- --- | --- --- The type constructors 'S1', 'C1' and 'D1' are all variants of 'M1': --- --- @ --- type 'S1' = 'M1' 'S' --- type 'C1' = 'M1' 'C' --- type 'D1' = 'M1' 'D' --- @ --- --- The types 'S', 'C' and 'R' are once again type-level proxies, just used to create --- several variants of 'M1'. - --- *** Additional generic representation type constructors --- --- | --- --- Next to 'K1', 'M1', ':+:' and ':*:' there are a few more type constructors that occur --- in the representations of other datatypes. - --- **** Empty datatypes: 'V1' --- --- | --- --- For empty datatypes, 'V1' is used as a representation. For example, --- --- @ --- data Empty deriving 'Generic' --- @ --- --- yields --- --- @ --- instance 'Generic' Empty where --- type 'Rep' Empty = 'D1' D1Empty 'V1' --- @ - --- **** Constructors without fields: 'U1' --- --- | --- --- If a constructor has no arguments, then 'U1' is used as its representation. For example --- the representation of 'Bool' is --- --- @ --- instance 'Generic' Bool where --- type 'Rep' Bool = --- 'D1' D1Bool --- ('C1' C1_0Bool 'U1' ':+:' 'C1' C1_1Bool 'U1') --- @ - --- *** Representation of types with many constructors or many fields --- --- | --- --- As ':+:' and ':*:' are just binary operators, one might ask what happens if the --- datatype has more than two constructors, or a constructor with more than two --- fields. The answer is simple: the operators are used several times, to combine --- all the constructors and fields as needed. However, users /should not rely on --- a specific nesting strategy/ for ':+:' and ':*:' being used. The compiler is --- free to choose any nesting it prefers. (In practice, the current implementation --- tries to produce a more or less balanced nesting, so that the traversal of the --- structure of the datatype from the root to a particular component can be performed --- in logarithmic rather than linear time.) - --- ** Defining datatype-generic functions --- --- | --- --- A datatype-generic function comprises two parts: --- --- 1. /Generic instances/ for the function, implementing it for most of the representation --- type constructors introduced above. --- --- 2. A /wrapper/ that for any datatype that is in `Generic`, performs the conversion --- between the original value and its `Rep`-based representation and then invokes the --- generic instances. --- --- As an example, let us look at a function 'encode' that produces a naive, but lossless --- bit encoding of values of various datatypes. So we are aiming to define a function --- --- @ --- encode :: 'Generic' a => a -> [Bool] --- @ --- --- where we use 'Bool' as our datatype for bits. --- --- For part 1, we define a class @Encode'@. Perhaps surprisingly, this class is parameterized --- over a type constructor @f@ of kind @* -> *@. This is a technicality: all the representation --- type constructors operate with kind @* -> *@ as base kind. But the type argument is never --- being used. This may be changed at some point in the future. The class has a single method, --- and we use the type we want our final function to have, but we replace the occurrences of --- the generic type argument @a@ with @f p@ (where the @p@ is any argument; it will not be used). --- --- > class Encode' f where --- > encode' :: f p -> [Bool] --- --- With the goal in mind to make @encode@ work on @Tree@ and other datatypes, we now define --- instances for the representation type constructors 'V1', 'U1', ':+:', ':*:', 'K1', and 'M1'. - --- *** Definition of the generic representation types --- --- | --- --- In order to be able to do this, we need to know the actual definitions of these types: --- --- @ --- data 'V1' p -- lifted version of Empty --- data 'U1' p = 'U1' -- lifted version of () --- data (':+:') f g p = 'L1' (f p) | 'R1' (g p) -- lifted version of 'Either' --- data (':*:') f g p = (f p) ':*:' (g p) -- lifted version of (,) --- newtype 'K1' i c p = 'K1' { 'unK1' :: c } -- a container for a c --- newtype 'M1' i t f p = 'M1' { 'unM1' :: f p } -- a wrapper --- @ --- --- So, 'U1' is just the unit type, ':+:' is just a binary choice like 'Either', --- ':*:' is a binary pair like the pair constructor @(,)@, and 'K1' is a value --- of a specific type @c@, and 'M1' wraps a value of the generic type argument, --- which in the lifted world is an @f p@ (where we do not care about @p@). - --- *** Generic instances --- --- | --- --- The instance for 'V1' is slightly awkward (but also rarely used): --- --- @ --- instance Encode' 'V1' where --- encode' x = undefined --- @ --- --- There are no values of type @V1 p@ to pass (except undefined), so this is --- actually impossible. One can ask why it is useful to define an instance for --- 'V1' at all in this case? Well, an empty type can be used as an argument to --- a non-empty type, and you might still want to encode the resulting type. --- As a somewhat contrived example, consider @[Empty]@, which is not an empty --- type, but contains just the empty list. The 'V1' instance ensures that we --- can call the generic function on such types. --- --- There is exactly one value of type 'U1', so encoding it requires no --- knowledge, and we can use zero bits: --- --- @ --- instance Encode' 'U1' where --- encode' 'U1' = [] --- @ --- --- In the case for ':+:', we produce 'False' or 'True' depending on whether --- the constructor of the value provided is located on the left or on the right: --- --- @ --- instance (Encode' f, Encode' g) => Encode' (f ':+:' g) where --- encode' ('L1' x) = False : encode' x --- encode' ('R1' x) = True : encode' x --- @ --- --- In the case for ':*:', we append the encodings of the two subcomponents: --- --- @ --- instance (Encode' f, Encode' g) => Encode' (f ':*:' g) where --- encode' (x ':*:' y) = encode' x ++ encode' y --- @ --- --- The case for 'K1' is rather interesting. Here, we call the final function --- 'encode' that we yet have to define, recursively. We will use another type --- class 'Encode' for that function: --- --- @ --- instance (Encode c) => Encode' ('K1' i c) where --- encode' ('K1' x) = encode x --- @ --- --- Note how 'Par0' and 'Rec0' both being mapped to 'K1' allows us to define --- a uniform instance here. --- --- Similarly, we can define a uniform instance for 'M1', because we completely --- disregard all meta-information: --- --- @ --- instance (Encode' f) => Encode' ('M1' i t f) where --- encode' ('M1' x) = encode' x --- @ --- --- Unlike in 'K1', the instance for 'M1' refers to 'encode'', not 'encode'. - --- *** The wrapper and generic default --- --- | --- --- We now define class 'Encode' for the actual 'encode' function: --- --- @ --- class Encode a where --- encode :: a -> [Bool] --- default encode :: ('Generic' a) => a -> [Bool] --- encode x = encode' ('from' x) --- @ --- --- The incoming 'x' is converted using 'from', then we dispatch to the --- generic instances using 'encode''. We use this as a default definition --- for 'encode'. We need the 'default encode' signature because ordinary --- Haskell default methods must not introduce additional class constraints, --- but our generic default does. --- --- Defining a particular instance is now as simple as saying --- --- @ --- instance (Encode a) => Encode (Tree a) --- @ --- -#if 0 --- /TODO:/ Add usage example? --- -#endif --- The generic default is being used. In the future, it will hopefully be --- possible to use @deriving Encode@ as well, but GHC does not yet support --- that syntax for this situation. --- --- Having 'Encode' as a class has the advantage that we can define --- non-generic special cases, which is particularly useful for abstract --- datatypes that have no structural representation. For example, given --- a suitable integer encoding function 'encodeInt', we can define --- --- @ --- instance Encode Int where --- encode = encodeInt --- @ - --- *** Omitting generic instances --- --- | --- --- It is not always required to provide instances for all the generic --- representation types, but omitting instances restricts the set of --- datatypes the functions will work for: --- --- * If no ':+:' instance is given, the function may still work for --- empty datatypes or datatypes that have a single constructor, --- but will fail on datatypes with more than one constructor. --- --- * If no ':*:' instance is given, the function may still work for --- datatypes where each constructor has just zero or one field, --- in particular for enumeration types. --- --- * If no 'K1' instance is given, the function may still work for --- enumeration types, where no constructor has any fields. --- --- * If no 'V1' instance is given, the function may still work for --- any datatype that is not empty. --- --- * If no 'U1' instance is given, the function may still work for --- any datatype where each constructor has at least one field. --- --- An 'M1' instance is always required (but it can just ignore the --- meta-information, as is the case for 'encode' above). -#if 0 --- *** Using meta-information --- --- | --- --- TODO -#endif --- ** Generic constructor classes --- --- | --- --- Datatype-generic functions as defined above work for a large class --- of datatypes, including parameterized datatypes. (We have used 'Tree' --- as our example above, which is of kind @* -> *@.) However, the --- 'Generic' class ranges over types of kind @*@, and therefore, the --- resulting generic functions (such as 'encode') must be parameterized --- by a generic type argument of kind @*@. --- --- What if we want to define generic classes that range over type --- constructors (such as 'Functor', 'Traversable', or 'Foldable')? - --- *** The 'Generic1' class --- --- | --- --- Like 'Generic', there is a class 'Generic1' that defines a --- representation 'Rep1' and conversion functions 'from1' and 'to1', --- only that 'Generic1' ranges over types of kind @* -> *@. --- The 'Generic1' class is also derivable. --- --- The representation 'Rep1' is ever so slightly different from 'Rep'. --- Let us look at 'Tree' as an example again: --- --- @ --- data Tree a = Leaf a | Node (Tree a) (Tree a) --- deriving 'Generic1' --- @ --- --- The above declaration causes the following representation to be generated: --- --- class 'Generic1' Tree where --- type 'Rep1' Tree = --- 'D1' D1Tree --- ('C1' C1_0Tree --- ('S1' 'NoSelector' 'Par1') --- ':+:' --- 'C1' C1_1Tree --- ('S1' 'NoSelector' ('Rec1' Tree) --- ':*:' --- 'S1' 'NoSelector' ('Rec1' Tree))) --- ... --- --- The representation reuses 'D1', 'C1', 'S1' (and thereby 'M1') as well --- as ':+:' and ':*:' from 'Rep'. (This reusability is the reason that we --- carry around the dummy type argument for kind-@*@-types, but there are --- already enough different names involved without duplicating each of --- these.) --- --- What's different is that we now use 'Par1' to refer to the parameter --- (and that parameter, which used to be @a@), is not mentioned explicitly --- by name anywhere; and we use 'Rec1' to refer to a recursive use of @Tree a@. - --- *** Representation of @* -> *@ types --- --- | --- --- Unlike 'Par0' and 'Rec0', the 'Par1' and 'Rec1' type constructors do not --- map to 'K1'. They are defined directly, as follows: --- --- @ --- newtype 'Par1' p = 'Par1' { 'unPar1' :: p } -- gives access to parameter p --- newtype 'Rec1' f p = 'Rec1' { 'unRec1' :: f p } -- a wrapper --- @ --- --- In 'Par1', the parameter @p@ is used for the first time, whereas 'Rec1' simply --- wraps an application of @f@ to @p@. --- --- Note that 'K1' (in the guise of 'Rec0') can still occur in a 'Rep1' representation, --- namely when the datatype has a field that does not mention the parameter. --- --- The declaration --- --- @ --- data WithInt a = WithInt Int a --- deriving 'Generic1' --- @ --- --- yields --- --- @ --- class 'Rep1' WithInt where --- type 'Rep1' WithInt = --- 'D1' D1WithInt --- ('C1' C1_0WithInt --- ('S1' 'NoSelector' ('Rec0' Int) --- ':*:' --- 'S1' 'NoSelector' 'Par1')) --- @ --- --- If the parameter @a@ appears underneath a composition of other type constructors, --- then the representation involves composition, too: --- --- @ --- data Rose a = Fork a [Rose a] --- @ --- --- yields --- --- @ --- class 'Rep1' Rose where --- type 'Rep1' Rose = --- 'D1' D1Rose --- ('C1' C1_0Rose --- ('S1' 'NoSelector' 'Par1' --- ':*:' --- 'S1' 'NoSelector' ([] ':.:' 'Rec1' Rose) --- @ --- --- where --- --- @ --- newtype (':.:') f g p = 'Comp1' { 'unComp1' :: f (g p) } --- @ - --- *** Representation of unlifted types --- --- | --- --- If one were to attempt to derive a Generic instance for a datatype with an --- unlifted argument (for example, 'Int#'), one might expect the occurrence of --- the 'Int#' argument to be marked with @'Rec0' 'Int#'@. This won't work, --- though, since 'Int#' is of kind @#@ and 'Rec0' expects a type of kind @*@. --- In fact, polymorphism over unlifted types is disallowed completely. --- --- One solution would be to represent an occurrence of 'Int#' with 'Rec0 Int' --- instead. With this approach, however, the programmer has no way of knowing --- whether the 'Int' is actually an 'Int#' in disguise. --- --- Instead of reusing 'Rec0', a separate data family 'URec' is used to mark --- occurrences of common unlifted types: --- --- @ --- data family URec a p --- --- data instance 'URec' ('Ptr' ()) p = 'UAddr' { 'uAddr#' :: 'Addr#' } --- data instance 'URec' 'Char' p = 'UChar' { 'uChar#' :: 'Char#' } --- data instance 'URec' 'Double' p = 'UDouble' { 'uDouble#' :: 'Double#' } --- data instance 'URec' 'Int' p = 'UFloat' { 'uFloat#' :: 'Float#' } --- data instance 'URec' 'Float' p = 'UInt' { 'uInt#' :: 'Int#' } --- data instance 'URec' 'Word' p = 'UWord' { 'uWord#' :: 'Word#' } --- @ --- --- Several type synonyms are provided for convenience: --- --- @ --- type 'UAddr' = 'URec' ('Ptr' ()) --- type 'UChar' = 'URec' 'Char' --- type 'UDouble' = 'URec' 'Double' --- type 'UFloat' = 'URec' 'Float' --- type 'UInt' = 'URec' 'Int' --- type 'UWord' = 'URec' 'Word' --- @ --- --- The declaration --- --- @ --- data IntHash = IntHash Int# --- deriving 'Generic' --- @ --- --- yields --- --- @ --- instance 'Generic' IntHash where --- type 'Rep' IntHash = --- 'D1' D1IntHash --- ('C1' C1_0IntHash --- ('S1' 'NoSelector' 'UInt')) --- @ --- --- Currently, only the six unlifted types listed above are generated, but this --- may be extended to encompass more unlifted types in the future. -#if 0 --- *** Limitations --- --- | --- --- /TODO/ --- --- /TODO:/ Also clear up confusion about 'Rec0' and 'Rec1' not really indicating recursion. --- -#endif -#if __GLASGOW_HASKELL__ < 701 - -- * Generic representation types - V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..) - , (:+:)(..), (:*:)(..), (:.:)(..) - - -- ** Synonyms for convenience - , Rec0, Par0, R, P - , D1, C1, S1, D, C, S - - -- * Meta-information - , Datatype(..), Constructor(..), Selector(..), NoSelector - , Fixity(..), Associativity(..), Arity(..), prec - - -- * Generic type classes - , Generic(..), Generic1(..), - -#else - module GHC.Generics, -#endif -#if __GLASGOW_HASKELL__ < 711 - -- ** Unboxed representation types - URec(..), UAddr, UChar, UDouble, UFloat, UInt, UWord -#endif - ) where - - -#if __GLASGOW_HASKELL__ >= 701 -import GHC.Generics -#endif - -#if __GLASGOW_HASKELL__ < 709 -import Data.Word ( Word ) -#endif - -#if __GLASGOW_HASKELL__ < 711 -import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# ) -import GHC.Ptr ( Ptr ) -#endif - -#if __GLASGOW_HASKELL__ < 701 --------------------------------------------------------------------------------- --- Representation types --------------------------------------------------------------------------------- - --- | Void: used for datatypes without constructors -data V1 p - --- | Unit: used for constructors without arguments -data U1 p = U1 - deriving (Eq, Ord, Read, Show) - --- | Used for marking occurrences of the parameter -newtype Par1 p = Par1 { unPar1 :: p } - deriving (Eq, Ord, Read, Show) - --- | Recursive calls of kind * -> * -newtype Rec1 f p = Rec1 { unRec1 :: f p } - deriving (Eq, Ord, Read, Show) - --- | Constants, additional parameters and recursion of kind * -newtype K1 i c p = K1 { unK1 :: c } - deriving (Eq, Ord, Read, Show) - --- | Meta-information (constructor names, etc.) -newtype M1 i c f p = M1 { unM1 :: f p } - deriving (Eq, Ord, Read, Show) - --- | Sums: encode choice between constructors -infixr 5 :+: -data (:+:) f g p = L1 (f p) | R1 (g p) - deriving (Eq, Ord, Read, Show) - --- | Products: encode multiple arguments to constructors -infixr 6 :*: -data (:*:) f g p = f p :*: g p - deriving (Eq, Ord, Read, Show) - --- | Composition of functors -infixr 7 :.: -newtype (:.:) f g p = Comp1 { unComp1 :: f (g p) } - deriving (Eq, Ord, Read, Show) --- | Tag for K1: recursion (of kind *) -data R --- | Tag for K1: parameters (other than the last) -data P - --- | Type synonym for encoding recursion (of kind *) -type Rec0 = K1 R --- | Type synonym for encoding parameters (other than the last) -type Par0 = K1 P - --- | Tag for M1: datatype -data D --- | Tag for M1: constructor -data C --- | Tag for M1: record selector -data S - --- | Type synonym for encoding meta-information for datatypes -type D1 = M1 D - --- | Type synonym for encoding meta-information for constructors -type C1 = M1 C - --- | Type synonym for encoding meta-information for record selectors -type S1 = M1 S - --- | Class for datatypes that represent datatypes -class Datatype d where - -- | The name of the datatype, fully qualified - datatypeName :: t d (f :: * -> *) a -> String - moduleName :: t d (f :: * -> *) a -> String - --- | Class for datatypes that represent records -class Selector s where - -- | The name of the selector - selName :: t s (f :: * -> *) a -> String - --- | Used for constructor fields without a name -data NoSelector - -instance Selector NoSelector where selName _ = "" - --- | Class for datatypes that represent data constructors -class Constructor c where - -- | The name of the constructor - conName :: t c (f :: * -> *) a -> String - - -- | The fixity of the constructor - conFixity :: t c (f :: * -> *) a -> Fixity - conFixity = const Prefix - - -- | Marks if this constructor is a record - conIsRecord :: t c (f :: * -> *) a -> Bool - conIsRecord = const False - - --- | Datatype to represent the arity of a tuple. -data Arity = NoArity | Arity Int - deriving (Eq, Show, Ord, Read) - --- | Datatype to represent the fixity of a constructor. An infix --- | declaration directly corresponds to an application of 'Infix'. -data Fixity = Prefix | Infix Associativity Int - deriving (Eq, Show, Ord, Read) - --- | Get the precedence of a fixity value. -prec :: Fixity -> Int -prec Prefix = 10 -prec (Infix _ n) = n - --- | Datatype to represent the associativy of a constructor -data Associativity = LeftAssociative - | RightAssociative - | NotAssociative - deriving (Eq, Show, Ord, Read) - --- | Representable types of kind * -class Generic a where - type Rep a :: * -> * - -- | Convert from the datatype to its representation - from :: a -> Rep a x - -- | Convert from the representation to the datatype - to :: Rep a x -> a - --- | Representable types of kind * -> * -class Generic1 f where - type Rep1 f :: * -> * - -- | Convert from the datatype to its representation - from1 :: f a -> Rep1 f a - -- | Convert from the representation to the datatype - to1 :: Rep1 f a -> f a - -#endif - -#if __GLASGOW_HASKELL__ < 711 --- | Constants of kind @#@ -data family URec (a :: *) (p :: *) - --- | Used for marking occurrences of 'Addr#' -data instance URec (Ptr ()) p = UAddr { uAddr# :: Addr# } - deriving (Eq, Ord) - --- | Used for marking occurrences of 'Char#' -data instance URec Char p = UChar { uChar# :: Char# } - deriving (Eq, Ord, Show) - --- | Used for marking occurrences of 'Double#' -data instance URec Double p = UDouble { uDouble# :: Double# } - deriving (Eq, Ord, Show) - --- | Used for marking occurrences of 'Float#' -data instance URec Float p = UFloat { uFloat# :: Float# } - deriving (Eq, Ord, Show) - --- | Used for marking occurrences of 'Int#' -data instance URec Int p = UInt { uInt# :: Int# } - deriving (Eq, Ord, Show) - --- | Used for marking occurrences of 'Word#' -data instance URec Word p = UWord { uWord# :: Word# } - deriving (Eq, Ord, Show) - --- | Type synonym for 'URec': 'Addr#' -type UAddr = URec (Ptr ()) --- | Type synonym for 'URec': 'Char#' -type UChar = URec Char --- | Type synonym for 'URec': 'Double#' -type UDouble = URec Double --- | Type synonym for 'URec': 'Float#' -type UFloat = URec Float --- | Type synonym for 'URec': 'Int#' -type UInt = URec Int --- | Type synonym for 'URec': 'Word#' -type UWord = URec Word -#endif +{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Generics.Deriving.Base (+-- * Introduction+--+-- |+--+-- Datatype-generic functions are are based on the idea of converting values of+-- a datatype @T@ into corresponding values of a (nearly) isomorphic type @'Rep' T@.+-- The type @'Rep' T@ is+-- built from a limited set of type constructors, all provided by this module. A+-- datatype-generic function is then an overloaded function with instances+-- for most of these type constructors, together with a wrapper that performs+-- the mapping between @T@ and @'Rep' T@. By using this technique, we merely need+-- a few generic instances in order to implement functionality that works for any+-- representable type.+--+-- Representable types are collected in the 'Generic' class, which defines the+-- associated type 'Rep' as well as conversion functions 'from' and 'to'.+-- Typically, you will not define 'Generic' instances by hand, but have the compiler+-- derive them for you.++-- ** Representing datatypes+--+-- |+--+-- The key to defining your own datatype-generic functions is to understand how to+-- represent datatypes using the given set of type constructors.+--+-- Let us look at an example first:+--+-- @+-- data Tree a = Leaf a | Node (Tree a) (Tree a)+-- deriving 'Generic'+-- @+--+-- The above declaration (which requires the language pragma @DeriveGeneric@)+-- causes the following representation to be generated:+--+-- @+-- class 'Generic' (Tree a) where+-- type 'Rep' (Tree a) =+-- 'D1' D1Tree+-- ('C1' C1_0Tree+-- ('S1' 'NoSelector' ('Par0' a))+-- ':+:'+-- 'C1' C1_1Tree+-- ('S1' 'NoSelector' ('Rec0' (Tree a))+-- ':*:'+-- 'S1' 'NoSelector' ('Rec0' (Tree a))))+-- ...+-- @+--+-- /Hint:/ You can obtain information about the code being generated from GHC by passing+-- the @-ddump-deriv@ flag. In GHCi, you can expand a type family such as 'Rep' using+-- the @:kind!@ command.+--+#if 0+-- /TODO:/ Newer GHC versions abandon the distinction between 'Par0' and 'Rec0' and will+-- use 'Rec0' everywhere.+--+#endif+-- This is a lot of information! However, most of it is actually merely meta-information+-- that makes names of datatypes and constructors and more available on the type level.+--+-- Here is a reduced representation for 'Tree' with nearly all meta-information removed,+-- for now keeping only the most essential aspects:+--+-- @+-- instance 'Generic' (Tree a) where+-- type 'Rep' (Tree a) =+-- 'Par0' a+-- ':+:'+-- ('Rec0' (Tree a) ':*:' 'Rec0' (Tree a))+-- @+--+-- The @Tree@ datatype has two constructors. The representation of individual constructors+-- is combined using the binary type constructor ':+:'.+--+-- The first constructor consists of a single field, which is the parameter @a@. This is+-- represented as @'Par0' a@.+--+-- The second constructor consists of two fields. Each is a recursive field of type @Tree a@,+-- represented as @'Rec0' (Tree a)@. Representations of individual fields are combined using+-- the binary type constructor ':*:'.+--+-- Now let us explain the additional tags being used in the complete representation:+--+-- * The @'S1' 'NoSelector'@ indicates that there is no record field selector associated with+-- this field of the constructor.+--+-- * The @'C1' C1_0Tree@ and @'C1' C1_1Tree@ invocations indicate that the enclosed part is+-- the representation of the first and second constructor of datatype @Tree@, respectively.+-- Here, @C1_0Tree@ and @C1_1Tree@ are datatypes generated by the compiler as part of+-- @deriving 'Generic'@. These datatypes are proxy types with no values. They are useful+-- because they are instances of the type class 'Constructor'. This type class can be used+-- to obtain information about the constructor in question, such as its name+-- or infix priority.+--+-- * The @'D1' D1Tree@ tag indicates that the enclosed part is the representation of the+-- datatype @Tree@. Again, @D1Tree@ is a datatype generated by the compiler. It is a+-- proxy type, and is useful by being an instance of class 'Datatype', which+-- can be used to obtain the name of a datatype, the module it has been defined in, and+-- whether it has been defined using @data@ or @newtype@.++-- ** Derived and fundamental representation types+--+-- |+--+-- There are many datatype-generic functions that do not distinguish between positions that+-- are parameters or positions that are recursive calls. There are also many datatype-generic+-- functions that do not care about the names of datatypes and constructors at all. To keep+-- the number of cases to consider in generic functions in such a situation to a minimum,+-- it turns out that many of the type constructors introduced above are actually synonyms,+-- defining them to be variants of a smaller set of constructors.++-- *** Individual fields of constructors: 'K1'+--+-- |+--+-- The type constructors 'Par0' and 'Rec0' are variants of 'K1':+--+-- @+-- type 'Par0' = 'K1' 'P'+-- type 'Rec0' = 'K1' 'R'+-- @+--+-- Here, 'P' and 'R' are type-level proxies again that do not have any associated values.++-- *** Meta information: 'M1'+--+-- |+--+-- The type constructors 'S1', 'C1' and 'D1' are all variants of 'M1':+--+-- @+-- type 'S1' = 'M1' 'S'+-- type 'C1' = 'M1' 'C'+-- type 'D1' = 'M1' 'D'+-- @+--+-- The types 'S', 'C' and 'R' are once again type-level proxies, just used to create+-- several variants of 'M1'.++-- *** Additional generic representation type constructors+--+-- |+--+-- Next to 'K1', 'M1', ':+:' and ':*:' there are a few more type constructors that occur+-- in the representations of other datatypes.++-- **** Empty datatypes: 'V1'+--+-- |+--+-- For empty datatypes, 'V1' is used as a representation. For example,+--+-- @+-- data Empty deriving 'Generic'+-- @+--+-- yields+--+-- @+-- instance 'Generic' Empty where+-- type 'Rep' Empty = 'D1' D1Empty 'V1'+-- @++-- **** Constructors without fields: 'U1'+--+-- |+--+-- If a constructor has no arguments, then 'U1' is used as its representation. For example+-- the representation of 'Bool' is+--+-- @+-- instance 'Generic' Bool where+-- type 'Rep' Bool =+-- 'D1' D1Bool+-- ('C1' C1_0Bool 'U1' ':+:' 'C1' C1_1Bool 'U1')+-- @++-- *** Representation of types with many constructors or many fields+--+-- |+--+-- As ':+:' and ':*:' are just binary operators, one might ask what happens if the+-- datatype has more than two constructors, or a constructor with more than two+-- fields. The answer is simple: the operators are used several times, to combine+-- all the constructors and fields as needed. However, users /should not rely on+-- a specific nesting strategy/ for ':+:' and ':*:' being used. The compiler is+-- free to choose any nesting it prefers. (In practice, the current implementation+-- tries to produce a more or less balanced nesting, so that the traversal of the+-- structure of the datatype from the root to a particular component can be performed+-- in logarithmic rather than linear time.)++-- ** Defining datatype-generic functions+--+-- |+--+-- A datatype-generic function comprises two parts:+--+-- 1. /Generic instances/ for the function, implementing it for most of the representation+-- type constructors introduced above.+--+-- 2. A /wrapper/ that for any datatype that is in `Generic`, performs the conversion+-- between the original value and its `Rep`-based representation and then invokes the+-- generic instances.+--+-- As an example, let us look at a function 'encode' that produces a naive, but lossless+-- bit encoding of values of various datatypes. So we are aiming to define a function+--+-- @+-- encode :: 'Generic' a => a -> [Bool]+-- @+--+-- where we use 'Bool' as our datatype for bits.+--+-- For part 1, we define a class @Encode'@. Perhaps surprisingly, this class is parameterized+-- over a type constructor @f@ of kind @* -> *@. This is a technicality: all the representation+-- type constructors operate with kind @* -> *@ as base kind. But the type argument is never+-- being used. This may be changed at some point in the future. The class has a single method,+-- and we use the type we want our final function to have, but we replace the occurrences of+-- the generic type argument @a@ with @f p@ (where the @p@ is any argument; it will not be used).+--+-- > class Encode' f where+-- > encode' :: f p -> [Bool]+--+-- With the goal in mind to make @encode@ work on @Tree@ and other datatypes, we now define+-- instances for the representation type constructors 'V1', 'U1', ':+:', ':*:', 'K1', and 'M1'.++-- *** Definition of the generic representation types+--+-- |+--+-- In order to be able to do this, we need to know the actual definitions of these types:+--+-- @+-- data 'V1' p -- lifted version of Empty+-- data 'U1' p = 'U1' -- lifted version of ()+-- data (':+:') f g p = 'L1' (f p) | 'R1' (g p) -- lifted version of 'Either'+-- data (':*:') f g p = (f p) ':*:' (g p) -- lifted version of (,)+-- newtype 'K1' i c p = 'K1' { 'unK1' :: c } -- a container for a c+-- newtype 'M1' i t f p = 'M1' { 'unM1' :: f p } -- a wrapper+-- @+--+-- So, 'U1' is just the unit type, ':+:' is just a binary choice like 'Either',+-- ':*:' is a binary pair like the pair constructor @(,)@, and 'K1' is a value+-- of a specific type @c@, and 'M1' wraps a value of the generic type argument,+-- which in the lifted world is an @f p@ (where we do not care about @p@).++-- *** Generic instances+--+-- |+--+-- The instance for 'V1' is slightly awkward (but also rarely used):+--+-- @+-- instance Encode' 'V1' where+-- encode' x = undefined+-- @+--+-- There are no values of type @V1 p@ to pass (except undefined), so this is+-- actually impossible. One can ask why it is useful to define an instance for+-- 'V1' at all in this case? Well, an empty type can be used as an argument to+-- a non-empty type, and you might still want to encode the resulting type.+-- As a somewhat contrived example, consider @[Empty]@, which is not an empty+-- type, but contains just the empty list. The 'V1' instance ensures that we+-- can call the generic function on such types.+--+-- There is exactly one value of type 'U1', so encoding it requires no+-- knowledge, and we can use zero bits:+--+-- @+-- instance Encode' 'U1' where+-- encode' 'U1' = []+-- @+--+-- In the case for ':+:', we produce 'False' or 'True' depending on whether+-- the constructor of the value provided is located on the left or on the right:+--+-- @+-- instance (Encode' f, Encode' g) => Encode' (f ':+:' g) where+-- encode' ('L1' x) = False : encode' x+-- encode' ('R1' x) = True : encode' x+-- @+--+-- In the case for ':*:', we append the encodings of the two subcomponents:+--+-- @+-- instance (Encode' f, Encode' g) => Encode' (f ':*:' g) where+-- encode' (x ':*:' y) = encode' x ++ encode' y+-- @+--+-- The case for 'K1' is rather interesting. Here, we call the final function+-- 'encode' that we yet have to define, recursively. We will use another type+-- class 'Encode' for that function:+--+-- @+-- instance (Encode c) => Encode' ('K1' i c) where+-- encode' ('K1' x) = encode x+-- @+--+-- Note how 'Par0' and 'Rec0' both being mapped to 'K1' allows us to define+-- a uniform instance here.+--+-- Similarly, we can define a uniform instance for 'M1', because we completely+-- disregard all meta-information:+--+-- @+-- instance (Encode' f) => Encode' ('M1' i t f) where+-- encode' ('M1' x) = encode' x+-- @+--+-- Unlike in 'K1', the instance for 'M1' refers to 'encode'', not 'encode'.++-- *** The wrapper and generic default+--+-- |+--+-- We now define class 'Encode' for the actual 'encode' function:+--+-- @+-- class Encode a where+-- encode :: a -> [Bool]+-- default encode :: ('Generic' a) => a -> [Bool]+-- encode x = encode' ('from' x)+-- @+--+-- The incoming 'x' is converted using 'from', then we dispatch to the+-- generic instances using 'encode''. We use this as a default definition+-- for 'encode'. We need the 'default encode' signature because ordinary+-- Haskell default methods must not introduce additional class constraints,+-- but our generic default does.+--+-- Defining a particular instance is now as simple as saying+--+-- @+-- instance (Encode a) => Encode (Tree a)+-- @+--+#if 0+-- /TODO:/ Add usage example?+--+#endif+-- The generic default is being used. In the future, it will hopefully be+-- possible to use @deriving Encode@ as well, but GHC does not yet support+-- that syntax for this situation.+--+-- Having 'Encode' as a class has the advantage that we can define+-- non-generic special cases, which is particularly useful for abstract+-- datatypes that have no structural representation. For example, given+-- a suitable integer encoding function 'encodeInt', we can define+--+-- @+-- instance Encode Int where+-- encode = encodeInt+-- @++-- *** Omitting generic instances+--+-- |+--+-- It is not always required to provide instances for all the generic+-- representation types, but omitting instances restricts the set of+-- datatypes the functions will work for:+--+-- * If no ':+:' instance is given, the function may still work for+-- empty datatypes or datatypes that have a single constructor,+-- but will fail on datatypes with more than one constructor.+--+-- * If no ':*:' instance is given, the function may still work for+-- datatypes where each constructor has just zero or one field,+-- in particular for enumeration types.+--+-- * If no 'K1' instance is given, the function may still work for+-- enumeration types, where no constructor has any fields.+--+-- * If no 'V1' instance is given, the function may still work for+-- any datatype that is not empty.+--+-- * If no 'U1' instance is given, the function may still work for+-- any datatype where each constructor has at least one field.+--+-- An 'M1' instance is always required (but it can just ignore the+-- meta-information, as is the case for 'encode' above).+#if 0+-- *** Using meta-information+--+-- |+--+-- TODO+#endif+-- ** Generic constructor classes+--+-- |+--+-- Datatype-generic functions as defined above work for a large class+-- of datatypes, including parameterized datatypes. (We have used 'Tree'+-- as our example above, which is of kind @* -> *@.) However, the+-- 'Generic' class ranges over types of kind @*@, and therefore, the+-- resulting generic functions (such as 'encode') must be parameterized+-- by a generic type argument of kind @*@.+--+-- What if we want to define generic classes that range over type+-- constructors (such as 'Functor', 'Traversable', or 'Foldable')?++-- *** The 'Generic1' class+--+-- |+--+-- Like 'Generic', there is a class 'Generic1' that defines a+-- representation 'Rep1' and conversion functions 'from1' and 'to1',+-- only that 'Generic1' ranges over types of kind @* -> *@.+-- The 'Generic1' class is also derivable.+--+-- The representation 'Rep1' is ever so slightly different from 'Rep'.+-- Let us look at 'Tree' as an example again:+--+-- @+-- data Tree a = Leaf a | Node (Tree a) (Tree a)+-- deriving 'Generic1'+-- @+--+-- The above declaration causes the following representation to be generated:+--+-- class 'Generic1' Tree where+-- type 'Rep1' Tree =+-- 'D1' D1Tree+-- ('C1' C1_0Tree+-- ('S1' 'NoSelector' 'Par1')+-- ':+:'+-- 'C1' C1_1Tree+-- ('S1' 'NoSelector' ('Rec1' Tree)+-- ':*:'+-- 'S1' 'NoSelector' ('Rec1' Tree)))+-- ...+--+-- The representation reuses 'D1', 'C1', 'S1' (and thereby 'M1') as well+-- as ':+:' and ':*:' from 'Rep'. (This reusability is the reason that we+-- carry around the dummy type argument for kind-@*@-types, but there are+-- already enough different names involved without duplicating each of+-- these.)+--+-- What's different is that we now use 'Par1' to refer to the parameter+-- (and that parameter, which used to be @a@), is not mentioned explicitly+-- by name anywhere; and we use 'Rec1' to refer to a recursive use of @Tree a@.++-- *** Representation of @* -> *@ types+--+-- |+--+-- Unlike 'Par0' and 'Rec0', the 'Par1' and 'Rec1' type constructors do not+-- map to 'K1'. They are defined directly, as follows:+--+-- @+-- newtype 'Par1' p = 'Par1' { 'unPar1' :: p } -- gives access to parameter p+-- newtype 'Rec1' f p = 'Rec1' { 'unRec1' :: f p } -- a wrapper+-- @+--+-- In 'Par1', the parameter @p@ is used for the first time, whereas 'Rec1' simply+-- wraps an application of @f@ to @p@.+--+-- Note that 'K1' (in the guise of 'Rec0') can still occur in a 'Rep1' representation,+-- namely when the datatype has a field that does not mention the parameter.+--+-- The declaration+--+-- @+-- data WithInt a = WithInt Int a+-- deriving 'Generic1'+-- @+--+-- yields+--+-- @+-- class 'Rep1' WithInt where+-- type 'Rep1' WithInt =+-- 'D1' D1WithInt+-- ('C1' C1_0WithInt+-- ('S1' 'NoSelector' ('Rec0' Int)+-- ':*:'+-- 'S1' 'NoSelector' 'Par1'))+-- @+--+-- If the parameter @a@ appears underneath a composition of other type constructors,+-- then the representation involves composition, too:+--+-- @+-- data Rose a = Fork a [Rose a]+-- @+--+-- yields+--+-- @+-- class 'Rep1' Rose where+-- type 'Rep1' Rose =+-- 'D1' D1Rose+-- ('C1' C1_0Rose+-- ('S1' 'NoSelector' 'Par1'+-- ':*:'+-- 'S1' 'NoSelector' ([] ':.:' 'Rec1' Rose)+-- @+--+-- where+--+-- @+-- newtype (':.:') f g p = 'Comp1' { 'unComp1' :: f (g p) }+-- @++-- *** Representation of unlifted types+--+-- |+--+-- If one were to attempt to derive a Generic instance for a datatype with an+-- unlifted argument (for example, 'Int#'), one might expect the occurrence of+-- the 'Int#' argument to be marked with @'Rec0' 'Int#'@. This won't work,+-- though, since 'Int#' is of kind @#@ and 'Rec0' expects a type of kind @*@.+-- In fact, polymorphism over unlifted types is disallowed completely.+--+-- One solution would be to represent an occurrence of 'Int#' with 'Rec0 Int'+-- instead. With this approach, however, the programmer has no way of knowing+-- whether the 'Int' is actually an 'Int#' in disguise.+--+-- Instead of reusing 'Rec0', a separate data family 'URec' is used to mark+-- occurrences of common unlifted types:+--+-- @+-- data family URec a p+--+-- data instance 'URec' ('Ptr' ()) p = 'UAddr' { 'uAddr#' :: 'Addr#' }+-- data instance 'URec' 'Char' p = 'UChar' { 'uChar#' :: 'Char#' }+-- data instance 'URec' 'Double' p = 'UDouble' { 'uDouble#' :: 'Double#' }+-- data instance 'URec' 'Int' p = 'UFloat' { 'uFloat#' :: 'Float#' }+-- data instance 'URec' 'Float' p = 'UInt' { 'uInt#' :: 'Int#' }+-- data instance 'URec' 'Word' p = 'UWord' { 'uWord#' :: 'Word#' }+-- @+--+-- Several type synonyms are provided for convenience:+--+-- @+-- type 'UAddr' = 'URec' ('Ptr' ())+-- type 'UChar' = 'URec' 'Char'+-- type 'UDouble' = 'URec' 'Double'+-- type 'UFloat' = 'URec' 'Float'+-- type 'UInt' = 'URec' 'Int'+-- type 'UWord' = 'URec' 'Word'+-- @+--+-- The declaration+--+-- @+-- data IntHash = IntHash Int#+-- deriving 'Generic'+-- @+--+-- yields+--+-- @+-- instance 'Generic' IntHash where+-- type 'Rep' IntHash =+-- 'D1' D1IntHash+-- ('C1' C1_0IntHash+-- ('S1' 'NoSelector' 'UInt'))+-- @+--+-- Currently, only the six unlifted types listed above are generated, but this+-- may be extended to encompass more unlifted types in the future.+#if 0+-- *** Limitations+--+-- |+--+-- /TODO/+--+-- /TODO:/ Also clear up confusion about 'Rec0' and 'Rec1' not really indicating recursion.+--+#endif+#if __GLASGOW_HASKELL__ < 701+ -- * Generic representation types+ V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..)+ , (:+:)(..), (:*:)(..), (:.:)(..)++ -- ** Synonyms for convenience+ , Rec0, Par0, R, P+ , D1, C1, S1, D, C, S++ -- * Meta-information+ , Datatype(..), Constructor(..), Selector(..), NoSelector+ , Fixity(..), Associativity(..), Arity(..), prec++ -- * Generic type classes+ , Generic(..), Generic1(..),++#else+ module GHC.Generics,+#endif+#if __GLASGOW_HASKELL__ < 711+ -- ** Unboxed representation types+ URec(..), UAddr, UChar, UDouble, UFloat, UInt, UWord+#endif+ ) where+++#if __GLASGOW_HASKELL__ >= 701+import GHC.Generics+#endif++#if __GLASGOW_HASKELL__ < 709+import Data.Word ( Word )+#endif++#if __GLASGOW_HASKELL__ < 711+import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# )+import GHC.Ptr ( Ptr )+#endif++#if __GLASGOW_HASKELL__ < 701+--------------------------------------------------------------------------------+-- Representation types+--------------------------------------------------------------------------------++-- | Void: used for datatypes without constructors+data V1 p++-- | Unit: used for constructors without arguments+data U1 p = U1+ deriving (Eq, Ord, Read, Show)++-- | Used for marking occurrences of the parameter+newtype Par1 p = Par1 { unPar1 :: p }+ deriving (Eq, Ord, Read, Show)++-- | Recursive calls of kind * -> *+newtype Rec1 f p = Rec1 { unRec1 :: f p }+ deriving (Eq, Ord, Read, Show)++-- | Constants, additional parameters and recursion of kind *+newtype K1 i c p = K1 { unK1 :: c }+ deriving (Eq, Ord, Read, Show)++-- | Meta-information (constructor names, etc.)+newtype M1 i c f p = M1 { unM1 :: f p }+ deriving (Eq, Ord, Read, Show)++-- | Sums: encode choice between constructors+infixr 5 :+:+data (:+:) f g p = L1 (f p) | R1 (g p)+ deriving (Eq, Ord, Read, Show)++-- | Products: encode multiple arguments to constructors+infixr 6 :*:+data (:*:) f g p = f p :*: g p+ deriving (Eq, Ord, Read, Show)++-- | Composition of functors+infixr 7 :.:+newtype (:.:) f g p = Comp1 { unComp1 :: f (g p) }+ deriving (Eq, Ord, Read, Show)+-- | Tag for K1: recursion (of kind *)+data R+-- | Tag for K1: parameters (other than the last)+data P++-- | Type synonym for encoding recursion (of kind *)+type Rec0 = K1 R+-- | Type synonym for encoding parameters (other than the last)+type Par0 = K1 P++-- | Tag for M1: datatype+data D+-- | Tag for M1: constructor+data C+-- | Tag for M1: record selector+data S++-- | Type synonym for encoding meta-information for datatypes+type D1 = M1 D++-- | Type synonym for encoding meta-information for constructors+type C1 = M1 C++-- | Type synonym for encoding meta-information for record selectors+type S1 = M1 S++-- | Class for datatypes that represent datatypes+class Datatype d where+ -- | The name of the datatype, fully qualified+ datatypeName :: t d (f :: * -> *) a -> String+ moduleName :: t d (f :: * -> *) a -> String++-- | Class for datatypes that represent records+class Selector s where+ -- | The name of the selector+ selName :: t s (f :: * -> *) a -> String++-- | Used for constructor fields without a name+data NoSelector++instance Selector NoSelector where selName _ = ""++-- | Class for datatypes that represent data constructors+class Constructor c where+ -- | The name of the constructor+ conName :: t c (f :: * -> *) a -> String++ -- | The fixity of the constructor+ conFixity :: t c (f :: * -> *) a -> Fixity+ conFixity = const Prefix++ -- | Marks if this constructor is a record+ conIsRecord :: t c (f :: * -> *) a -> Bool+ conIsRecord = const False+++-- | Datatype to represent the arity of a tuple.+data Arity = NoArity | Arity Int+ deriving (Eq, Show, Ord, Read)++-- | Datatype to represent the fixity of a constructor. An infix+-- | declaration directly corresponds to an application of 'Infix'.+data Fixity = Prefix | Infix Associativity Int+ deriving (Eq, Show, Ord, Read)++-- | Get the precedence of a fixity value.+prec :: Fixity -> Int+prec Prefix = 10+prec (Infix _ n) = n++-- | Datatype to represent the associativy of a constructor+data Associativity = LeftAssociative+ | RightAssociative+ | NotAssociative+ deriving (Eq, Show, Ord, Read)++-- | Representable types of kind *+class Generic a where+ type Rep a :: * -> *+ -- | Convert from the datatype to its representation+ from :: a -> Rep a x+ -- | Convert from the representation to the datatype+ to :: Rep a x -> a++-- | Representable types of kind * -> *+class Generic1 f where+ type Rep1 f :: * -> *+ -- | Convert from the datatype to its representation+ from1 :: f a -> Rep1 f a+ -- | Convert from the representation to the datatype+ to1 :: Rep1 f a -> f a++#endif++#if __GLASGOW_HASKELL__ < 711+-- | Constants of kind @#@+data family URec (a :: *) (p :: *)++-- | Used for marking occurrences of 'Addr#'+data instance URec (Ptr ()) p = UAddr { uAddr# :: Addr# }+ deriving (Eq, Ord)++-- | Used for marking occurrences of 'Char#'+data instance URec Char p = UChar { uChar# :: Char# }+ deriving (Eq, Ord, Show)++-- | Used for marking occurrences of 'Double#'+data instance URec Double p = UDouble { uDouble# :: Double# }+ deriving (Eq, Ord, Show)++-- | Used for marking occurrences of 'Float#'+data instance URec Float p = UFloat { uFloat# :: Float# }+ deriving (Eq, Ord, Show)++-- | Used for marking occurrences of 'Int#'+data instance URec Int p = UInt { uInt# :: Int# }+ deriving (Eq, Ord, Show)++-- | Used for marking occurrences of 'Word#'+data instance URec Word p = UWord { uWord# :: Word# }+ deriving (Eq, Ord, Show)++-- | Type synonym for 'URec': 'Addr#'+type UAddr = URec (Ptr ())+-- | Type synonym for 'URec': 'Char#'+type UChar = URec Char+-- | Type synonym for 'URec': 'Double#'+type UDouble = URec Double+-- | Type synonym for 'URec': 'Float#'+type UFloat = URec Float+-- | Type synonym for 'URec': 'Int#'+type UInt = URec Int+-- | Type synonym for 'URec': 'Word#'+type UWord = URec Word+#endif
src/Generics/Deriving/Copoint.hs view
@@ -1,113 +1,154 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -module Generics.Deriving.Copoint ( - -- * GCopoint class - GCopoint(..), - - -- * Default method - gcopointdefault - - ) where - -import Control.Applicative (WrappedMonad) - -import Data.Monoid (Dual, Sum) - -import Generics.Deriving.Base -import Generics.Deriving.Instances () - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -#endif - --------------------------------------------------------------------------------- --- Generic copoint --------------------------------------------------------------------------------- - --- General copoint may return 'Nothing' - -class GCopoint' t where - gcopoint' :: t a -> Maybe a - -instance GCopoint' U1 where - gcopoint' U1 = Nothing - -instance GCopoint' Par1 where - gcopoint' (Par1 a) = Just a - -instance GCopoint' (K1 i c) where - gcopoint' _ = Nothing - -instance GCopoint' f => GCopoint' (M1 i c f) where - gcopoint' (M1 a) = gcopoint' a - -instance (GCopoint' f, GCopoint' g) => GCopoint' (f :+: g) where - gcopoint' (L1 a) = gcopoint' a - gcopoint' (R1 a) = gcopoint' a - --- Favours left "hole" for copoint -instance (GCopoint' f, GCopoint' g) => GCopoint' (f :*: g) where - gcopoint' (a :*: b) = case (gcopoint' a) of - Just x -> Just x - Nothing -> gcopoint' b - -instance (GCopoint f) => GCopoint' (Rec1 f) where - gcopoint' (Rec1 a) = Just $ gcopoint a - -instance (GCopoint f, GCopoint' g) => GCopoint' (f :.: g) where - gcopoint' (Comp1 x) = gcopoint' . gcopoint $ x - -class GCopoint d where - gcopoint :: d a -> a -#if __GLASGOW_HASKELL__ >= 701 - default gcopoint :: (Generic1 d, GCopoint' (Rep1 d)) - => (d a -> a) - gcopoint = gcopointdefault -#endif - -gcopointdefault :: (Generic1 d, GCopoint' (Rep1 d)) - => d a -> a -gcopointdefault x = case (gcopoint' . from1 $ x) of - Just x' -> x' - Nothing -> error "Data type is not copointed" - --- instance (Generic1 d, GCopoint' (Rep1 d)) => GCopoint d - --- Base types instances -instance GCopoint ((,) a) where - gcopoint = gcopointdefault - -instance GCopoint ((,,) a b) where - gcopoint = gcopointdefault - -instance GCopoint ((,,,) a b c) where - gcopoint = gcopointdefault - -instance GCopoint ((,,,,) a b c d) where - gcopoint = gcopointdefault - -instance GCopoint ((,,,,,) a b c d e) where - gcopoint = gcopointdefault - -instance GCopoint ((,,,,,,) a b c d e f) where - gcopoint = gcopointdefault - -instance GCopoint Dual where - gcopoint = gcopointdefault - -#if MIN_VERSION_base(4,8,0) -instance GCopoint Identity where - gcopoint = gcopointdefault -#endif - -instance GCopoint Sum where - gcopoint = gcopointdefault - -instance GCopoint m => GCopoint (WrappedMonad m) where - gcopoint = gcopointdefault +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+#endif++module Generics.Deriving.Copoint (+ -- * GCopoint class+ GCopoint(..),++ -- * Default method+ gcopointdefault++ ) where++import Control.Applicative (WrappedMonad)++import Data.Monoid (Dual)+import qualified Data.Monoid as Monoid (Sum)++import Generics.Deriving.Base+import Generics.Deriving.Instances ()++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+import Data.Monoid (Alt)+#endif++#if MIN_VERSION_base(4,9,0)+import qualified Data.Functor.Sum as Functor (Sum)+import Data.Semigroup (Arg, First, Last, Max, Min, WrappedMonoid)+#endif++--------------------------------------------------------------------------------+-- Generic copoint+--------------------------------------------------------------------------------++-- General copoint may return 'Nothing'++class GCopoint' t where+ gcopoint' :: t a -> Maybe a++instance GCopoint' U1 where+ gcopoint' U1 = Nothing++instance GCopoint' Par1 where+ gcopoint' (Par1 a) = Just a++instance GCopoint' (K1 i c) where+ gcopoint' _ = Nothing++instance GCopoint' f => GCopoint' (M1 i c f) where+ gcopoint' (M1 a) = gcopoint' a++instance (GCopoint' f, GCopoint' g) => GCopoint' (f :+: g) where+ gcopoint' (L1 a) = gcopoint' a+ gcopoint' (R1 a) = gcopoint' a++-- Favours left "hole" for copoint+instance (GCopoint' f, GCopoint' g) => GCopoint' (f :*: g) where+ gcopoint' (a :*: b) = case (gcopoint' a) of+ Just x -> Just x+ Nothing -> gcopoint' b++instance (GCopoint f) => GCopoint' (Rec1 f) where+ gcopoint' (Rec1 a) = Just $ gcopoint a++instance (GCopoint f, GCopoint' g) => GCopoint' (f :.: g) where+ gcopoint' (Comp1 x) = gcopoint' . gcopoint $ x++class GCopoint d where+ gcopoint :: d a -> a+#if __GLASGOW_HASKELL__ >= 701+ default gcopoint :: (Generic1 d, GCopoint' (Rep1 d))+ => (d a -> a)+ gcopoint = gcopointdefault+#endif++gcopointdefault :: (Generic1 d, GCopoint' (Rep1 d))+ => d a -> a+gcopointdefault x = case (gcopoint' . from1 $ x) of+ Just x' -> x'+ Nothing -> error "Data type is not copointed"++-- instance (Generic1 d, GCopoint' (Rep1 d)) => GCopoint d++-- Base types instances+instance GCopoint ((,) a) where+ gcopoint = gcopointdefault++instance GCopoint ((,,) a b) where+ gcopoint = gcopointdefault++instance GCopoint ((,,,) a b c) where+ gcopoint = gcopointdefault++instance GCopoint ((,,,,) a b c d) where+ gcopoint = gcopointdefault++instance GCopoint ((,,,,,) a b c d e) where+ gcopoint = gcopointdefault++instance GCopoint ((,,,,,,) a b c d e f) where+ gcopoint = gcopointdefault++#if MIN_VERSION_base(4,8,0)+instance GCopoint f => GCopoint (Alt f) where+ gcopoint = gcopointdefault+#endif++#if MIN_VERSION_base(4,9,0)+instance GCopoint (Arg a) where+ gcopoint = gcopointdefault+#endif++instance GCopoint Dual where+ gcopoint = gcopointdefault++#if MIN_VERSION_base(4,9,0)+instance GCopoint First where+ gcopoint = gcopointdefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GCopoint Identity where+ gcopoint = gcopointdefault+#endif++#if MIN_VERSION_base(4,9,0)+instance GCopoint Last where+ gcopoint = gcopointdefault++instance GCopoint Max where+ gcopoint = gcopointdefault++instance GCopoint Min where+ gcopoint = gcopointdefault++instance (GCopoint f, GCopoint g) => GCopoint (Functor.Sum f g) where+ gcopoint = gcopointdefault+#endif++instance GCopoint Monoid.Sum where+ gcopoint = gcopointdefault++instance GCopoint m => GCopoint (WrappedMonad m) where+ gcopoint = gcopointdefault++#if MIN_VERSION_base(4,9,0)+instance GCopoint WrappedMonoid where+ gcopoint = gcopointdefault+#endif
src/Generics/Deriving/Enum.hs view
@@ -1,890 +1,1032 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -#include "HsBaseConfig.h" - -module Generics.Deriving.Enum ( - - -- * Generic enum class - GEnum(..) - - -- * Default definitions for GEnum - , genumDefault, toEnumDefault, fromEnumDefault - - -- * Generic Ix class - , GIx(..) - - -- * Default definitions for GIx - , rangeDefault, indexDefault, inRangeDefault - - ) where - -import Control.Applicative (Const, ZipList) - -import Data.Int -import Data.Monoid (All, Any, Dual, First, Last, Product, Sum) -import Data.Word - -import Foreign.C.Types -import Foreign.Ptr - -import Generics.Deriving.Base -import Generics.Deriving.Instances () -import Generics.Deriving.Eq - -import System.Posix.Types - -#if MIN_VERSION_base(4,7,0) -import Data.Proxy (Proxy) -#endif - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -import Data.Monoid (Alt) -import Numeric.Natural (Natural) -#endif - ------------------------------------------------------------------------------ --- Utility functions for Enum' ------------------------------------------------------------------------------ - -infixr 5 ||| - --- | Interleave elements from two lists. Similar to (++), but swap left and --- right arguments on every recursive application. --- --- From Mark Jones' talk at AFP2008 -(|||) :: [a] -> [a] -> [a] -[] ||| ys = ys -(x:xs) ||| ys = x : ys ||| xs - --- | Diagonalization of nested lists. Ensure that some elements from every --- sublist will be included. Handles infinite sublists. --- --- From Mark Jones' talk at AFP2008 -diag :: [[a]] -> [a] -diag = concat . foldr skew [] . map (map (\x -> [x])) - -skew :: [[a]] -> [[a]] -> [[a]] -skew [] ys = ys -skew (x:xs) ys = x : combine (++) xs ys - -combine :: (a -> a -> a) -> [a] -> [a] -> [a] -combine _ xs [] = xs -combine _ [] ys = ys -combine f (x:xs) (y:ys) = f x y : combine f xs ys - -findIndex :: (a -> Bool) -> [a] -> Maybe Int -findIndex p xs = let l = [ i | (y,i) <- zip xs [(0::Int)..], p y] - in if (null l) - then Nothing - else Just (head l) - --------------------------------------------------------------------------------- --- Generic enum --------------------------------------------------------------------------------- - -class Enum' f where - enum' :: [f a] - -instance Enum' U1 where - enum' = [U1] - -instance (GEnum c) => Enum' (K1 i c) where - enum' = map K1 genum - -instance (Enum' f) => Enum' (M1 i c f) where - enum' = map M1 enum' - -instance (Enum' f, Enum' g) => Enum' (f :+: g) where - enum' = map L1 enum' ||| map R1 enum' - -instance (Enum' f, Enum' g) => Enum' (f :*: g) where - enum' = diag [ [ x :*: y | y <- enum' ] | x <- enum' ] - -genumDefault :: (Generic a, Enum' (Rep a)) => [a] -genumDefault = map to enum' - -toEnumDefault :: (Generic a, Enum' (Rep a)) => Int -> a -toEnumDefault i = let l = enum' - in if (length l > i) - then to (l !! i) - else error "toEnum: invalid index" - -fromEnumDefault :: (GEq a, Generic a, Enum' (Rep a)) - => a -> Int -fromEnumDefault x = case findIndex (geq x) (map to enum') of - Nothing -> error "fromEnum: no corresponding index" - Just i -> i - - -class GEnum a where - genum :: [a] - -#if __GLASGOW_HASKELL__ >= 701 - default genum :: (Generic a, Enum' (Rep a)) => [a] - genum = genumDefault -#endif - -genumNum :: (Enum a, Num a) => [a] -genumNum = [0..] ||| (neg 0) where - neg n = (n-1) : neg (n-1) - --- Base types instances -instance GEnum () where - genum = genumDefault - -instance (GEnum a, GEnum b) => GEnum (a, b) where - genum = genumDefault - -instance (GEnum a, GEnum b, GEnum c) => GEnum (a, b, c) where - genum = genumDefault - -instance (GEnum a, GEnum b, GEnum c, GEnum d) => GEnum (a, b, c, d) where - genum = genumDefault - -instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e) => GEnum (a, b, c, d, e) where - genum = genumDefault - -instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f) - => GEnum (a, b, c, d, e, f) where - genum = genumDefault - -instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f, GEnum g) - => GEnum (a, b, c, d, e, f, g) where - genum = genumDefault - -instance GEnum a => GEnum [a] where - genum = genumDefault - -instance (GEnum (f p), GEnum (g p)) => GEnum ((f :+: g) p) where - genum = genumDefault - -instance (GEnum (f p), GEnum (g p)) => GEnum ((f :*: g) p) where - genum = genumDefault - -instance GEnum (f (g p)) => GEnum ((f :.: g) p) where - genum = genumDefault - -instance GEnum All where - genum = genumDefault - -#if MIN_VERSION_base(4,8,0) -instance GEnum (f a) => GEnum (Alt f a) where - genum = genumDefault -#endif - -instance GEnum Any where - genum = genumDefault - -instance GEnum Arity where - genum = genumDefault - -instance GEnum Associativity where - genum = genumDefault - -instance GEnum Bool where - genum = genumDefault - -#if defined(HTYPE_CC_T) -instance GEnum CCc where - genum = genumNum -#endif - -instance GEnum CChar where - genum = genumNum - -instance GEnum CClock where - genum = genumNum - -#if defined(HTYPE_DEV_T) -instance GEnum CDev where - genum = genumNum -#endif - -instance GEnum CDouble where - genum = genumNum - -instance GEnum CFloat where - genum = genumNum - -#if defined(HTYPE_GID_T) -instance GEnum CGid where - genum = genumNum -#endif - -#if defined(HTYPE_INO_T) -instance GEnum CIno where - genum = genumNum -#endif - -instance GEnum CInt where - genum = genumNum - -instance GEnum CIntMax where - genum = genumNum - -instance GEnum CIntPtr where - genum = genumNum - -instance GEnum CLLong where - genum = genumNum - -instance GEnum CLong where - genum = genumNum - -#if defined(HTYPE_MODE_T) -instance GEnum CMode where - genum = genumNum -#endif - -#if defined(HTYPE_NLINK_T) -instance GEnum CNlink where - genum = genumNum -#endif - -#if defined(HTYPE_OFF_T) -instance GEnum COff where - genum = genumNum -#endif - -instance GEnum a => GEnum (Const a b) where - genum = genumDefault - -#if defined(HTYPE_PID_T) -instance GEnum CPid where - genum = genumNum -#endif - -instance GEnum CPtrdiff where - genum = genumNum - -#if defined(HTYPE_RLIM_T) -instance GEnum CRLim where - genum = genumNum -#endif - -instance GEnum CSChar where - genum = genumNum - -#if defined(HTYPE_SPEED_T) -instance GEnum CSpeed where - genum = genumNum -#endif - -#if MIN_VERSION_base(4,4,0) -instance GEnum CSUSeconds where - genum = genumNum -#endif - -instance GEnum CShort where - genum = genumNum - -instance GEnum CSigAtomic where - genum = genumNum - -instance GEnum CSize where - genum = genumNum - -#if defined(HTYPE_SSIZE_T) -instance GEnum CSsize where - genum = genumNum -#endif - -#if defined(HTYPE_TCFLAG_T) -instance GEnum CTcflag where - genum = genumNum -#endif - -instance GEnum CTime where - genum = genumNum - -instance GEnum CUChar where - genum = genumNum - -#if defined(HTYPE_UID_T) -instance GEnum CUid where - genum = genumNum -#endif - -instance GEnum CUInt where - genum = genumNum - -instance GEnum CUIntMax where - genum = genumNum - -instance GEnum CUIntPtr where - genum = genumNum - -instance GEnum CULLong where - genum = genumNum - -instance GEnum CULong where - genum = genumNum - -#if MIN_VERSION_base(4,4,0) -instance GEnum CUSeconds where - genum = genumNum -#endif - -instance GEnum CUShort where - genum = genumNum - -instance GEnum CWchar where - genum = genumNum - -instance GEnum Double where - genum = genumNum - -instance GEnum a => GEnum (Dual a) where - genum = genumDefault - -instance (GEnum a, GEnum b) => GEnum (Either a b) where - genum = genumDefault - -instance GEnum Fd where - genum = genumNum - -instance GEnum a => GEnum (First a) where - genum = genumDefault - -instance GEnum Fixity where - genum = genumDefault - -instance GEnum Float where - genum = genumNum - -#if MIN_VERSION_base(4,8,0) -instance GEnum a => GEnum (Identity a) where - genum = genumDefault -#endif - -instance GEnum Int where - genum = genumNum - -instance GEnum Int8 where - genum = genumNum - -instance GEnum Int16 where - genum = genumNum - -instance GEnum Int32 where - genum = genumNum - -instance GEnum Int64 where - genum = genumNum - -instance GEnum Integer where - genum = genumNum - -instance GEnum IntPtr where - genum = genumNum - -instance GEnum c => GEnum (K1 i c p) where - genum = genumDefault - -instance GEnum a => GEnum (Last a) where - genum = genumDefault - -instance GEnum (f p) => GEnum (M1 i c f p) where - genum = genumDefault - -instance GEnum a => GEnum (Maybe a) where - genum = genumDefault - -instance GEnum Ordering where - genum = genumDefault - -instance GEnum p => GEnum (Par1 p) where - genum = genumDefault - -instance GEnum a => GEnum (Product a) where - genum = genumDefault - -#if MIN_VERSION_base(4,7,0) -instance GEnum (Proxy s) where - genum = genumDefault -#endif - -instance GEnum (f p) => GEnum (Rec1 f p) where - genum = genumDefault - -instance GEnum a => GEnum (Sum a) where - genum = genumDefault - -instance GEnum (U1 p) where - genum = genumDefault - -instance GEnum Word where - genum = genumNum - -instance GEnum Word8 where - genum = genumNum - -instance GEnum Word16 where - genum = genumNum - -instance GEnum Word32 where - genum = genumNum - -instance GEnum Word64 where - genum = genumNum - -instance GEnum WordPtr where - genum = genumNum - -instance GEnum a => GEnum (ZipList a) where - genum = genumDefault - --------------------------------------------------------------------------------- --- Generic Ix --------------------------------------------------------------------------------- - --- Minimal complete instance: 'range', 'index' and 'inRange'. -class (Ord a) => GIx a where - -- | The list of values in the subrange defined by a bounding pair. - range :: (a,a) -> [a] - -- | The position of a subscript in the subrange. - index :: (a,a) -> a -> Int - -- | Returns 'True' the given subscript lies in the range defined - -- the bounding pair. - inRange :: (a,a) -> a -> Bool -#if __GLASGOW_HASKELL__ >= 701 - default range :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> [a] - range = rangeDefault - - default index :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Int - index = indexDefault - - default inRange :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Bool - inRange = inRangeDefault -#endif - -rangeDefault :: (GEq a, Generic a, Enum' (Rep a)) - => (a,a) -> [a] -rangeDefault = t (map to enum') where - t l (x,y) = - case (findIndex (geq x) l, findIndex (geq y) l) of - (Nothing, _) -> error "rangeDefault: no corresponding index" - (_, Nothing) -> error "rangeDefault: no corresponding index" - (Just i, Just j) -> take (j-i) (drop i l) - -indexDefault :: (GEq a, Generic a, Enum' (Rep a)) - => (a,a) -> a -> Int -indexDefault = t (map to enum') where - t l (x,y) z = - case (findIndex (geq x) l, findIndex (geq y) l) of - (Nothing, _) -> error "indexDefault: no corresponding index" - (_, Nothing) -> error "indexDefault: no corresponding index" - (Just i, Just j) -> case findIndex (geq z) (take (j-i) (drop i l)) of - Nothing -> error "indexDefault: index out of range" - Just k -> k - -inRangeDefault :: (GEq a, Generic a, Enum' (Rep a)) - => (a,a) -> a -> Bool -inRangeDefault = t (map to enum') where - t l (x,y) z = - case (findIndex (geq x) l, findIndex (geq y) l) of - (Nothing, _) -> error "indexDefault: no corresponding index" - (_, Nothing) -> error "indexDefault: no corresponding index" - (Just i, Just j) -> maybe False (const True) - (findIndex (geq z) (take (j-i) (drop i l))) - -rangeEnum :: Enum a => (a, a) -> [a] -rangeEnum (m,n) = [m..n] - -indexIntegral :: Integral a => (a, a) -> a -> Int -indexIntegral (m,_n) i = fromIntegral (i - m) - -inRangeOrd :: Ord a => (a, a) -> a -> Bool -inRangeOrd (m,n) i = m <= i && i <= n - --- Base types instances -instance GIx () where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (a, b) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c) - => GIx (a, b, c) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, - GEq d, GEnum d, GIx d) - => GIx (a, b, c, d) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, - GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e) - => GIx (a, b, c, d, e) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, - GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f) - => GIx (a, b, c, d, e, f) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, - GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f, - GEq g, GEnum g, GIx g) - => GIx (a, b, c, d, e, f, g) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a) => GIx [a] where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx All where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -#if MIN_VERSION_base(4,8,0) -instance (GEq (f a), GEnum (f a), GIx (f a)) => GIx (Alt f a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault -#endif - -instance GIx Any where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx Arity where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx Associativity where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx Bool where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx CChar where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -#if defined(HTYPE_GID_T) -instance GIx CGid where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -#if defined(HTYPE_INO_T) -instance GIx CIno where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -instance GIx CInt where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CIntMax where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CIntPtr where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CLLong where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CLong where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -#if defined(HTYPE_MODE_T) -instance GIx CMode where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -#if defined(HTYPE_NLINK_T) -instance GIx CNlink where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -#if defined(HTYPE_OFF_T) -instance GIx COff where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -#if defined(HTYPE_PID_T) -instance GIx CPid where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -instance GIx CPtrdiff where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -#if defined(HTYPE_RLIM_T) -instance GIx CRLim where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -instance GIx CSChar where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CShort where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CSigAtomic where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CSize where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -#if defined(HTYPE_SSIZE_T) -instance GIx CSsize where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -#if defined(HTYPE_TCFLAG_T) -instance GIx CTcflag where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -instance GIx CUChar where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -#if defined(HTYPE_UID_T) -instance GIx CUid where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -instance GIx CUInt where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CUIntMax where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CUIntPtr where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CULLong where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CULong where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CUShort where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CWchar where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance (GEq a, GEnum a, GIx a) => GIx (Dual a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (Either a b) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx Fd where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance (GEq a, GEnum a, GIx a) => GIx (First a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx Fixity where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -#if MIN_VERSION_base(4,8,0) -instance (GEq a, GEnum a, GIx a) => GIx (Identity a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault -#endif - -instance GIx Int where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Int8 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Int16 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Int32 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Int64 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Integer where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx IntPtr where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance (GEq a, GEnum a, GIx a) => GIx (Last a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a) => GIx (Maybe a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -#if MIN_VERSION_base(4,8,0) -instance GIx Natural where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -instance GIx Ordering where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a) => GIx (Product a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -#if MIN_VERSION_base(4,7,0) -instance GIx (Proxy s) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault -#endif - -instance (GEq a, GEnum a, GIx a) => GIx (Sum a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx Word where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Word8 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Word16 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Word32 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Word64 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx WordPtr where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+#endif++#include "HsBaseConfig.h"++module Generics.Deriving.Enum (++ -- * Generic enum class+ GEnum(..)++ -- * Default definitions for GEnum+ , genumDefault, toEnumDefault, fromEnumDefault++ -- * Generic Ix class+ , GIx(..)++ -- * Default definitions for GIx+ , rangeDefault, indexDefault, inRangeDefault++ ) where++import Control.Applicative (Const, ZipList)++import Data.Int+import Data.Monoid (All, Any, Dual, Product, Sum)+import qualified Data.Monoid as Monoid (First, Last)+import Data.Word++import Foreign.C.Types+import Foreign.Ptr++import Generics.Deriving.Base+import Generics.Deriving.Instances ()+import Generics.Deriving.Eq++import System.Exit (ExitCode)+import System.Posix.Types++#if MIN_VERSION_base(4,4,0)+import Data.Complex (Complex)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+import Data.Monoid (Alt)+import Numeric.Natural (Natural)+#endif++#if MIN_VERSION_base(4,9,0)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg, Max, Min, Option, WrappedMonoid)+#endif++-----------------------------------------------------------------------------+-- Utility functions for Enum'+-----------------------------------------------------------------------------++infixr 5 |||++-- | Interleave elements from two lists. Similar to (++), but swap left and+-- right arguments on every recursive application.+--+-- From Mark Jones' talk at AFP2008+(|||) :: [a] -> [a] -> [a]+[] ||| ys = ys+(x:xs) ||| ys = x : ys ||| xs++-- | Diagonalization of nested lists. Ensure that some elements from every+-- sublist will be included. Handles infinite sublists.+--+-- From Mark Jones' talk at AFP2008+diag :: [[a]] -> [a]+diag = concat . foldr skew [] . map (map (\x -> [x]))++skew :: [[a]] -> [[a]] -> [[a]]+skew [] ys = ys+skew (x:xs) ys = x : combine (++) xs ys++combine :: (a -> a -> a) -> [a] -> [a] -> [a]+combine _ xs [] = xs+combine _ [] ys = ys+combine f (x:xs) (y:ys) = f x y : combine f xs ys++findIndex :: (a -> Bool) -> [a] -> Maybe Int+findIndex p xs = let l = [ i | (y,i) <- zip xs [(0::Int)..], p y]+ in if (null l)+ then Nothing+ else Just (head l)++--------------------------------------------------------------------------------+-- Generic enum+--------------------------------------------------------------------------------++class Enum' f where+ enum' :: [f a]++instance Enum' U1 where+ enum' = [U1]++instance (GEnum c) => Enum' (K1 i c) where+ enum' = map K1 genum++instance (Enum' f) => Enum' (M1 i c f) where+ enum' = map M1 enum'++instance (Enum' f, Enum' g) => Enum' (f :+: g) where+ enum' = map L1 enum' ||| map R1 enum'++instance (Enum' f, Enum' g) => Enum' (f :*: g) where+ enum' = diag [ [ x :*: y | y <- enum' ] | x <- enum' ]++genumDefault :: (Generic a, Enum' (Rep a)) => [a]+genumDefault = map to enum'++toEnumDefault :: (Generic a, Enum' (Rep a)) => Int -> a+toEnumDefault i = let l = enum'+ in if (length l > i)+ then to (l !! i)+ else error "toEnum: invalid index"++fromEnumDefault :: (GEq a, Generic a, Enum' (Rep a))+ => a -> Int+fromEnumDefault x = case findIndex (geq x) (map to enum') of+ Nothing -> error "fromEnum: no corresponding index"+ Just i -> i+++class GEnum a where+ genum :: [a]++#if __GLASGOW_HASKELL__ >= 701+ default genum :: (Generic a, Enum' (Rep a)) => [a]+ genum = genumDefault+#endif++genumNumUnbounded :: Num a => [a]+genumNumUnbounded = pos 0 ||| neg 0 where+ pos n = n : pos (n + 1)+ neg n = (n-1) : neg (n - 1)++genumNumBounded :: (Bounded a, Enum a, Num a) => [a]+genumNumBounded = genumNumWithBounds minBound maxBound++genumNumWithBounds :: (Enum a, Num a) => a -> a -> [a]+genumNumWithBounds minB maxB = [0 .. maxB] ||| [-1, -2 .. minB]++-- Base types instances+instance GEnum () where+ genum = genumDefault++instance (GEnum a, GEnum b) => GEnum (a, b) where+ genum = genumDefault++instance (GEnum a, GEnum b, GEnum c) => GEnum (a, b, c) where+ genum = genumDefault++instance (GEnum a, GEnum b, GEnum c, GEnum d) => GEnum (a, b, c, d) where+ genum = genumDefault++instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e) => GEnum (a, b, c, d, e) where+ genum = genumDefault++instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f)+ => GEnum (a, b, c, d, e, f) where+ genum = genumDefault++instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f, GEnum g)+ => GEnum (a, b, c, d, e, f, g) where+ genum = genumDefault++instance GEnum a => GEnum [a] where+ genum = genumDefault++instance (GEnum (f p), GEnum (g p)) => GEnum ((f :+: g) p) where+ genum = genumDefault++instance (GEnum (f p), GEnum (g p)) => GEnum ((f :*: g) p) where+ genum = genumDefault++instance GEnum (f (g p)) => GEnum ((f :.: g) p) where+ genum = genumDefault++instance GEnum All where+ genum = genumDefault++#if MIN_VERSION_base(4,8,0)+instance GEnum (f a) => GEnum (Alt f a) where+ genum = genumDefault+#endif++instance GEnum Any where+ genum = genumDefault++#if MIN_VERSION_base(4,9,0)+instance (GEnum a, GEnum b) => GEnum (Arg a b) where+ genum = genumDefault+#endif++#if !(MIN_VERSION_base(4,9,0))+instance GEnum Arity where+ genum = genumDefault+#endif++instance GEnum Associativity where+ genum = genumDefault++instance GEnum Bool where+ genum = genumDefault++#if defined(HTYPE_CC_T)+instance GEnum CCc where+ genum = genumNumWithBounds (fromIntegral (minBound :: HTYPE_CC_T))+ (fromIntegral (maxBound :: HTYPE_CC_T))+#endif++instance GEnum CChar where+ genum = genumNumBounded++instance GEnum CClock where+ genum = genumNumWithBounds (fromIntegral (minBound :: HTYPE_CLOCK_T))+ (fromIntegral (maxBound :: HTYPE_CLOCK_T))++#if defined(HTYPE_DEV_T)+instance GEnum CDev where+ genum = genumNumWithBounds (fromIntegral (minBound :: HTYPE_DEV_T))+ (fromIntegral (maxBound :: HTYPE_DEV_T))+#endif++instance GEnum CDouble where+ genum = genumNumUnbounded++instance GEnum CFloat where+ genum = genumNumUnbounded++#if defined(HTYPE_GID_T)+instance GEnum CGid where+ genum = genumNumBounded+#endif++#if defined(HTYPE_INO_T)+instance GEnum CIno where+ genum = genumNumBounded+#endif++instance GEnum CInt where+ genum = genumNumBounded++instance GEnum CIntMax where+ genum = genumNumBounded++instance GEnum CIntPtr where+ genum = genumNumBounded++instance GEnum CLLong where+ genum = genumNumBounded++instance GEnum CLong where+ genum = genumNumBounded++#if defined(HTYPE_MODE_T)+instance GEnum CMode where+ genum = genumNumBounded+#endif++#if defined(HTYPE_NLINK_T)+instance GEnum CNlink where+ genum = genumNumBounded+#endif++#if defined(HTYPE_OFF_T)+instance GEnum COff where+ genum = genumNumBounded+#endif++#if MIN_VERSION_base(4,4,0)+instance GEnum a => GEnum (Complex a) where+ genum = genumDefault+#endif++instance GEnum a => GEnum (Const a b) where+ genum = genumDefault++#if defined(HTYPE_PID_T)+instance GEnum CPid where+ genum = genumNumBounded+#endif++instance GEnum CPtrdiff where+ genum = genumNumBounded++#if defined(HTYPE_RLIM_T)+instance GEnum CRLim where+ genum = genumNumBounded+#endif++instance GEnum CSChar where+ genum = genumNumBounded++#if defined(HTYPE_SPEED_T)+instance GEnum CSpeed where+ genum = genumNumWithBounds (fromIntegral (minBound :: HTYPE_SPEED_T))+ (fromIntegral (maxBound :: HTYPE_SPEED_T))+#endif++#if MIN_VERSION_base(4,4,0)+instance GEnum CSUSeconds where+ genum = genumNumWithBounds (fromIntegral (minBound :: HTYPE_SUSECONDS_T))+ (fromIntegral (maxBound :: HTYPE_SUSECONDS_T))+#endif++instance GEnum CShort where+ genum = genumNumBounded++instance GEnum CSigAtomic where+ genum = genumNumBounded++instance GEnum CSize where+ genum = genumNumBounded++#if defined(HTYPE_SSIZE_T)+instance GEnum CSsize where+ genum = genumNumBounded+#endif++#if defined(HTYPE_TCFLAG_T)+instance GEnum CTcflag where+ genum = genumNumBounded+#endif++instance GEnum CTime where+ genum = genumNumWithBounds (fromIntegral (minBound :: HTYPE_TIME_T))+ (fromIntegral (maxBound :: HTYPE_TIME_T))++instance GEnum CUChar where+ genum = genumNumBounded++#if defined(HTYPE_UID_T)+instance GEnum CUid where+ genum = genumNumBounded+#endif++instance GEnum CUInt where+ genum = genumNumBounded++instance GEnum CUIntMax where+ genum = genumNumBounded++instance GEnum CUIntPtr where+ genum = genumNumBounded++instance GEnum CULLong where+ genum = genumNumBounded++instance GEnum CULong where+ genum = genumNumBounded++#if MIN_VERSION_base(4,4,0)+instance GEnum CUSeconds where+ genum = genumNumWithBounds (fromIntegral (minBound :: HTYPE_USECONDS_T))+ (fromIntegral (maxBound :: HTYPE_USECONDS_T))+#endif++instance GEnum CUShort where+ genum = genumNumBounded++instance GEnum CWchar where+ genum = genumNumBounded++instance GEnum Double where+ genum = genumNumUnbounded++instance GEnum a => GEnum (Dual a) where+ genum = genumDefault++instance (GEnum a, GEnum b) => GEnum (Either a b) where+ genum = genumDefault++instance GEnum ExitCode where+ genum = genumDefault++instance GEnum Fd where+ genum = genumNumBounded++instance GEnum a => GEnum (Monoid.First a) where+ genum = genumDefault++#if MIN_VERSION_base(4,9,0)+instance GEnum a => GEnum (Semigroup.First a) where+ genum = genumDefault+#endif++instance GEnum Fixity where+ genum = genumDefault++instance GEnum Float where+ genum = genumNumUnbounded++#if MIN_VERSION_base(4,8,0)+instance GEnum a => GEnum (Identity a) where+ genum = genumDefault+#endif++instance GEnum Int where+ genum = genumNumBounded++instance GEnum Int8 where+ genum = genumNumBounded++instance GEnum Int16 where+ genum = genumNumBounded++instance GEnum Int32 where+ genum = genumNumBounded++instance GEnum Int64 where+ genum = genumNumBounded++instance GEnum Integer where+ genum = genumNumUnbounded++instance GEnum IntPtr where+ genum = genumNumBounded++instance GEnum c => GEnum (K1 i c p) where+ genum = genumDefault++instance GEnum a => GEnum (Monoid.Last a) where+ genum = genumDefault++#if MIN_VERSION_base(4,9,0)+instance GEnum a => GEnum (Semigroup.Last a) where+ genum = genumDefault+#endif++instance GEnum (f p) => GEnum (M1 i c f p) where+ genum = genumDefault++#if MIN_VERSION_base(4,9,0)+instance GEnum a => GEnum (Max a) where+ genum = genumDefault+#endif++instance GEnum a => GEnum (Maybe a) where+ genum = genumDefault++#if MIN_VERSION_base(4,9,0)+instance GEnum a => GEnum (Min a) where+ genum = genumDefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GEnum Natural where+ genum = [0..]+#endif++#if MIN_VERSION_base(4,9,0)+instance GEnum a => GEnum (NonEmpty a) where+ genum = genumDefault++instance GEnum a => GEnum (Option a) where+ genum = genumDefault+#endif++instance GEnum Ordering where+ genum = genumDefault++instance GEnum p => GEnum (Par1 p) where+ genum = genumDefault++instance GEnum a => GEnum (Product a) where+ genum = genumDefault++#if MIN_VERSION_base(4,7,0)+instance GEnum (Proxy s) where+ genum = genumDefault+#endif++instance GEnum (f p) => GEnum (Rec1 f p) where+ genum = genumDefault++instance GEnum a => GEnum (Sum a) where+ genum = genumDefault++instance GEnum (U1 p) where+ genum = genumDefault++instance GEnum Word where+ genum = genumNumBounded++instance GEnum Word8 where+ genum = genumNumBounded++instance GEnum Word16 where+ genum = genumNumBounded++instance GEnum Word32 where+ genum = genumNumBounded++instance GEnum Word64 where+ genum = genumNumBounded++instance GEnum WordPtr where+ genum = genumNumBounded++#if MIN_VERSION_base(4,9,0)+instance GEnum m => GEnum (WrappedMonoid m) where+ genum = genumDefault+#endif++instance GEnum a => GEnum (ZipList a) where+ genum = genumDefault++--------------------------------------------------------------------------------+-- Generic Ix+--------------------------------------------------------------------------------++-- Minimal complete instance: 'range', 'index' and 'inRange'.+class (Ord a) => GIx a where+ -- | The list of values in the subrange defined by a bounding pair.+ range :: (a,a) -> [a]+ -- | The position of a subscript in the subrange.+ index :: (a,a) -> a -> Int+ -- | Returns 'True' the given subscript lies in the range defined+ -- the bounding pair.+ inRange :: (a,a) -> a -> Bool+#if __GLASGOW_HASKELL__ >= 701+ default range :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> [a]+ range = rangeDefault++ default index :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Int+ index = indexDefault++ default inRange :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Bool+ inRange = inRangeDefault+#endif++rangeDefault :: (GEq a, Generic a, Enum' (Rep a))+ => (a,a) -> [a]+rangeDefault = t (map to enum') where+ t l (x,y) =+ case (findIndex (geq x) l, findIndex (geq y) l) of+ (Nothing, _) -> error "rangeDefault: no corresponding index"+ (_, Nothing) -> error "rangeDefault: no corresponding index"+ (Just i, Just j) -> take (j-i) (drop i l)++indexDefault :: (GEq a, Generic a, Enum' (Rep a))+ => (a,a) -> a -> Int+indexDefault = t (map to enum') where+ t l (x,y) z =+ case (findIndex (geq x) l, findIndex (geq y) l) of+ (Nothing, _) -> error "indexDefault: no corresponding index"+ (_, Nothing) -> error "indexDefault: no corresponding index"+ (Just i, Just j) -> case findIndex (geq z) (take (j-i) (drop i l)) of+ Nothing -> error "indexDefault: index out of range"+ Just k -> k++inRangeDefault :: (GEq a, Generic a, Enum' (Rep a))+ => (a,a) -> a -> Bool+inRangeDefault = t (map to enum') where+ t l (x,y) z =+ case (findIndex (geq x) l, findIndex (geq y) l) of+ (Nothing, _) -> error "indexDefault: no corresponding index"+ (_, Nothing) -> error "indexDefault: no corresponding index"+ (Just i, Just j) -> maybe False (const True)+ (findIndex (geq z) (take (j-i) (drop i l)))++rangeEnum :: Enum a => (a, a) -> [a]+rangeEnum (m,n) = [m..n]++indexIntegral :: Integral a => (a, a) -> a -> Int+indexIntegral (m,_n) i = fromIntegral (i - m)++inRangeOrd :: Ord a => (a, a) -> a -> Bool+inRangeOrd (m,n) i = m <= i && i <= n++-- Base types instances+instance GIx () where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (a, b) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c)+ => GIx (a, b, c) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c,+ GEq d, GEnum d, GIx d)+ => GIx (a, b, c, d) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c,+ GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e)+ => GIx (a, b, c, d, e) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c,+ GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f)+ => GIx (a, b, c, d, e, f) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c,+ GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f,+ GEq g, GEnum g, GIx g)+ => GIx (a, b, c, d, e, f, g) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a) => GIx [a] where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance GIx All where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++#if MIN_VERSION_base(4,8,0)+instance (GEq (f a), GEnum (f a), GIx (f a)) => GIx (Alt f a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++instance GIx Any where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++#if MIN_VERSION_base(4,9,0)+instance (GEq a, GEnum a, GIx a, GEnum b) => GIx (Arg a b) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++#if !(MIN_VERSION_base(4,9,0))+instance GIx Arity where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++instance GIx Associativity where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance GIx Bool where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance GIx CChar where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++#if defined(HTYPE_GID_T)+instance GIx CGid where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++#if defined(HTYPE_INO_T)+instance GIx CIno where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++instance GIx CInt where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CIntMax where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CIntPtr where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CLLong where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CLong where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++#if defined(HTYPE_MODE_T)+instance GIx CMode where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++#if defined(HTYPE_NLINK_T)+instance GIx CNlink where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++#if defined(HTYPE_OFF_T)+instance GIx COff where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++#if defined(HTYPE_PID_T)+instance GIx CPid where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++instance GIx CPtrdiff where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++#if defined(HTYPE_RLIM_T)+instance GIx CRLim where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++instance GIx CSChar where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CShort where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CSigAtomic where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CSize where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++#if defined(HTYPE_SSIZE_T)+instance GIx CSsize where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++#if defined(HTYPE_TCFLAG_T)+instance GIx CTcflag where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++instance GIx CUChar where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++#if defined(HTYPE_UID_T)+instance GIx CUid where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++instance GIx CUInt where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CUIntMax where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CUIntPtr where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CULLong where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CULong where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CUShort where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CWchar where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance (GEq a, GEnum a, GIx a) => GIx (Dual a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (Either a b) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance GIx ExitCode where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance GIx Fd where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance (GEq a, GEnum a, GIx a) => GIx (Monoid.First a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++#if MIN_VERSION_base(4,9,0)+instance (GEq a, GEnum a, GIx a) => GIx (Semigroup.First a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++instance GIx Fixity where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++#if MIN_VERSION_base(4,8,0)+instance (GEq a, GEnum a, GIx a) => GIx (Identity a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++instance GIx Int where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Int8 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Int16 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Int32 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Int64 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Integer where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx IntPtr where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance (GEq a, GEnum a, GIx a) => GIx (Monoid.Last a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++#if MIN_VERSION_base(4,9,0)+instance (GEq a, GEnum a, GIx a) => GIx (Semigroup.Last a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++#if MIN_VERSION_base(4,9,0)+instance (GEq a, GEnum a, GIx a) => GIx (Max a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++instance (GEq a, GEnum a, GIx a) => GIx (Maybe a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++#if MIN_VERSION_base(4,9,0)+instance (GEq a, GEnum a, GIx a) => GIx (Min a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GIx Natural where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++#if MIN_VERSION_base(4,9,0)+instance (GEq a, GEnum a, GIx a) => GIx (NonEmpty a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++#if MIN_VERSION_base(4,9,0)+instance (GEq a, GEnum a, GIx a) => GIx (Option a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++instance GIx Ordering where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a) => GIx (Product a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++#if MIN_VERSION_base(4,7,0)+instance GIx (Proxy s) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++instance (GEq a, GEnum a, GIx a) => GIx (Sum a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance GIx Word where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Word8 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Word16 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Word32 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Word64 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx WordPtr where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++#if MIN_VERSION_base(4,9,0)+instance (GEq m, GEnum m, GIx m) => GIx (WrappedMonoid m) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif
src/Generics/Deriving/Eq.hs view
@@ -1,475 +1,564 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MagicHash #-} - -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -#include "HsBaseConfig.h" - -module Generics.Deriving.Eq ( - -- * Generic show class - GEq(..) - - -- * Default definition - , geqdefault - - ) where - -import Control.Applicative (Const, ZipList) - -import Data.Char (GeneralCategory) -import Data.Int -import Data.Monoid (All, Any, Dual, First, Last, Product, Sum) -import Data.Word - -import Foreign.C.Error -import Foreign.C.Types -import Foreign.ForeignPtr (ForeignPtr) -import Foreign.Ptr -import Foreign.StablePtr (StablePtr) - -import Generics.Deriving.Base -import Generics.Deriving.Instances () - -import GHC.Exts hiding (Any) - -import System.Exit (ExitCode) -import System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode) -import System.IO.Error (IOErrorType) -import System.Posix.Types - -#if MIN_VERSION_base(4,7,0) -import Data.Proxy (Proxy) -#endif - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -import Data.Monoid (Alt) -import Data.Void (Void) -import Numeric.Natural (Natural) -#endif - --------------------------------------------------------------------------------- --- Generic show --------------------------------------------------------------------------------- - -class GEq' f where - geq' :: f a -> f a -> Bool - -instance GEq' U1 where - geq' _ _ = True - -instance (GEq c) => GEq' (K1 i c) where - geq' (K1 a) (K1 b) = geq a b - --- No instances for P or Rec because geq is only applicable to types of kind * - -instance (GEq' a) => GEq' (M1 i c a) where - geq' (M1 a) (M1 b) = geq' a b - -instance (GEq' a, GEq' b) => GEq' (a :+: b) where - geq' (L1 a) (L1 b) = geq' a b - geq' (R1 a) (R1 b) = geq' a b - geq' _ _ = False - -instance (GEq' a, GEq' b) => GEq' (a :*: b) where - geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2 - --- Unboxed types -instance GEq' UAddr where - geq' (UAddr a1) (UAddr a2) = isTrue# (eqAddr# a1 a2) -instance GEq' UChar where - geq' (UChar c1) (UChar c2) = isTrue# (eqChar# c1 c2) -instance GEq' UDouble where - geq' (UDouble d1) (UDouble d2) = isTrue# (d1 ==## d2) -instance GEq' UFloat where - geq' (UFloat f1) (UFloat f2) = isTrue# (eqFloat# f1 f2) -instance GEq' UInt where - geq' (UInt i1) (UInt i2) = isTrue# (i1 ==# i2) -instance GEq' UWord where - geq' (UWord w1) (UWord w2) = isTrue# (eqWord# w1 w2) - -#if __GLASGOW_HASKELL__ < 707 -isTrue# :: Bool -> Bool -isTrue# = id -#endif - - -class GEq a where - geq :: a -> a -> Bool - - -#if __GLASGOW_HASKELL__ >= 701 - default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool - geq = geqdefault -#endif - -geqdefault :: (Generic a, GEq' (Rep a)) => a -> a -> Bool -geqdefault x y = geq' (from x) (from y) - --- Base types instances -instance GEq () where - geq = geqdefault - -instance (GEq a, GEq b) => GEq (a, b) where - geq = geqdefault - -instance (GEq a, GEq b, GEq c) => GEq (a, b, c) where - geq = geqdefault - -instance (GEq a, GEq b, GEq c, GEq d) => GEq (a, b, c, d) where - geq = geqdefault - -instance (GEq a, GEq b, GEq c, GEq d, GEq e) => GEq (a, b, c, d, e) where - geq = geqdefault - -instance (GEq a, GEq b, GEq c, GEq d, GEq e, GEq f) - => GEq (a, b, c, d, e, f) where - geq = geqdefault - -instance (GEq a, GEq b, GEq c, GEq d, GEq e, GEq f, GEq g) - => GEq (a, b, c, d, e, f, g) where - geq = geqdefault - -instance GEq a => GEq [a] where - geq = geqdefault - -instance (GEq (f p), GEq (g p)) => GEq ((f :+: g) p) where - geq = geqdefault - -instance (GEq (f p), GEq (g p)) => GEq ((f :*: g) p) where - geq = geqdefault - -instance GEq (f (g p)) => GEq ((f :.: g) p) where - geq = geqdefault - -instance GEq All where - geq = geqdefault - -#if MIN_VERSION_base(4,8,0) -instance GEq (f a) => GEq (Alt f a) where - geq = geqdefault -#endif - -instance GEq Any where - geq = geqdefault - -instance GEq Arity where - geq = geqdefault - -instance GEq Associativity where - geq = geqdefault - -instance GEq Bool where - geq = geqdefault - -instance GEq BufferMode where - geq = (==) - -#if defined(HTYPE_CC_T) -instance GEq CCc where - geq = (==) -#endif - -instance GEq CChar where - geq = (==) - -instance GEq CClock where - geq = (==) - -#if defined(HTYPE_DEV_T) -instance GEq CDev where - geq = (==) -#endif - -instance GEq CDouble where - geq = (==) - -instance GEq CFloat where - geq = (==) - -#if defined(HTYPE_GID_T) -instance GEq CGid where - geq = (==) -#endif - -instance GEq Char where - geq = (==) - -#if defined(HTYPE_INO_T) -instance GEq CIno where - geq = (==) -#endif - -instance GEq CInt where - geq = (==) - -instance GEq CIntMax where - geq = (==) - -instance GEq CIntPtr where - geq = (==) - -instance GEq CLLong where - geq = (==) - -instance GEq CLong where - geq = (==) - -#if defined(HTYPE_MODE_T) -instance GEq CMode where - geq = (==) -#endif - -#if defined(HTYPE_NLINK_T) -instance GEq CNlink where - geq = (==) -#endif - -#if defined(HTYPE_OFF_T) -instance GEq COff where - geq = (==) -#endif - -instance GEq a => GEq (Const a b) where - geq = geqdefault - -#if defined(HTYPE_PID_T) -instance GEq CPid where - geq = (==) -#endif - -instance GEq CPtrdiff where - geq = (==) - -#if defined(HTYPE_RLIM_T) -instance GEq CRLim where - geq = (==) -#endif - -instance GEq CSChar where - geq = (==) - -#if defined(HTYPE_SPEED_T) -instance GEq CSpeed where - geq = (==) -#endif - -#if MIN_VERSION_base(4,4,0) -instance GEq CSUSeconds where - geq = (==) -#endif - -instance GEq CShort where - geq = (==) - -instance GEq CSigAtomic where - geq = (==) - -instance GEq CSize where - geq = (==) - -#if defined(HTYPE_SSIZE_T) -instance GEq CSsize where - geq = (==) -#endif - -#if defined(HTYPE_TCFLAG_T) -instance GEq CTcflag where - geq = (==) -#endif - -instance GEq CTime where - geq = (==) - -instance GEq CUChar where - geq = (==) - -#if defined(HTYPE_UID_T) -instance GEq CUid where - geq = (==) -#endif - -instance GEq CUInt where - geq = (==) - -instance GEq CUIntMax where - geq = (==) - -instance GEq CUIntPtr where - geq = (==) - -instance GEq CULLong where - geq = (==) - -instance GEq CULong where - geq = (==) - -#if MIN_VERSION_base(4,4,0) -instance GEq CUSeconds where - geq = (==) -#endif - -instance GEq CUShort where - geq = (==) - -instance GEq CWchar where - geq = (==) - -instance GEq Double where - geq = (==) - -instance GEq a => GEq (Dual a) where - geq = geqdefault - -instance (GEq a, GEq b) => GEq (Either a b) where - geq = geqdefault - -instance GEq Errno where - geq = (==) - -instance GEq ExitCode where - geq = (==) - -instance GEq Fd where - geq = (==) - -instance GEq a => GEq (First a) where - geq = geqdefault - -instance GEq Fixity where - geq = geqdefault - -instance GEq Float where - geq = (==) - -instance GEq (ForeignPtr a) where - geq = (==) - -instance GEq (FunPtr a) where - geq = (==) - -instance GEq GeneralCategory where - geq = (==) - -instance GEq Handle where - geq = (==) - -instance GEq HandlePosn where - geq = (==) - -#if MIN_VERSION_base(4,8,0) -instance GEq a => GEq (Identity a) where - geq = geqdefault -#endif - -instance GEq Int where - geq = (==) - -instance GEq Int8 where - geq = (==) - -instance GEq Int16 where - geq = (==) - -instance GEq Int32 where - geq = (==) - -instance GEq Int64 where - geq = (==) - -instance GEq Integer where - geq = (==) - -instance GEq IntPtr where - geq = (==) - -instance GEq IOError where - geq = (==) - -instance GEq IOErrorType where - geq = (==) - -instance GEq IOMode where - geq = (==) - -instance GEq c => GEq (K1 i c p) where - geq = geqdefault - -instance GEq a => GEq (Last a) where - geq = geqdefault - -instance GEq (f p) => GEq (M1 i c f p) where - geq = geqdefault - -instance GEq a => GEq (Maybe a) where - geq = geqdefault - -#if MIN_VERSION_base(4,8,0) -instance GEq Natural where - geq = (==) -#endif - -instance GEq Ordering where - geq = geqdefault - -instance GEq p => GEq (Par1 p) where - geq = geqdefault - -instance GEq a => GEq (Product a) where - geq = geqdefault - -#if MIN_VERSION_base(4,7,0) -instance GEq (Proxy s) where - geq = geqdefault -#endif - -instance GEq (Ptr a) where - geq = (==) - -instance GEq (f p) => GEq (Rec1 f p) where - geq = geqdefault - -instance GEq SeekMode where - geq = (==) - -instance GEq (StablePtr a) where - geq = (==) - -instance GEq a => GEq (Sum a) where - geq = geqdefault - -instance GEq (U1 p) where - geq = geqdefault - -#if MIN_VERSION_base(4,8,0) -instance GEq Void where - geq = (==) -#endif - -instance GEq Word where - geq = (==) - -instance GEq Word8 where - geq = (==) - -instance GEq Word16 where - geq = (==) - -instance GEq Word32 where - geq = (==) - -instance GEq Word64 where - geq = (==) - -instance GEq WordPtr where - geq = (==) - -instance GEq a => GEq (ZipList a) where - geq = geqdefault +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MagicHash #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+#endif++#include "HsBaseConfig.h"++module Generics.Deriving.Eq (+ -- * Generic show class+ GEq(..)++ -- * Default definition+ , geqdefault++ ) where++import Control.Applicative (Const, ZipList)++import Data.Char (GeneralCategory)+import Data.Int+import qualified Data.Monoid as Monoid (First, Last)+import Data.Monoid (All, Any, Dual, Product, Sum)+import Data.Version (Version)+import Data.Word++import Foreign.C.Error+import Foreign.C.Types+import Foreign.ForeignPtr (ForeignPtr)+import Foreign.Ptr+import Foreign.StablePtr (StablePtr)++import Generics.Deriving.Base+import Generics.Deriving.Instances ()++import GHC.Exts hiding (Any)++import System.Exit (ExitCode)+import System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode)+import System.IO.Error (IOErrorType)+import System.Posix.Types++#if MIN_VERSION_base(4,4,0)+import Data.Complex (Complex)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+import Data.Monoid (Alt)+import Data.Void (Void)+import Numeric.Natural (Natural)+#endif++#if MIN_VERSION_base(4,9,0)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg(..), Max, Min, Option, WrappedMonoid)+#endif++--------------------------------------------------------------------------------+-- Generic show+--------------------------------------------------------------------------------++class GEq' f where+ geq' :: f a -> f a -> Bool++instance GEq' U1 where+ geq' _ _ = True++instance (GEq c) => GEq' (K1 i c) where+ geq' (K1 a) (K1 b) = geq a b++-- No instances for P or Rec because geq is only applicable to types of kind *++instance (GEq' a) => GEq' (M1 i c a) where+ geq' (M1 a) (M1 b) = geq' a b++instance (GEq' a, GEq' b) => GEq' (a :+: b) where+ geq' (L1 a) (L1 b) = geq' a b+ geq' (R1 a) (R1 b) = geq' a b+ geq' _ _ = False++instance (GEq' a, GEq' b) => GEq' (a :*: b) where+ geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2++-- Unboxed types+instance GEq' UAddr where+ geq' (UAddr a1) (UAddr a2) = isTrue# (eqAddr# a1 a2)+instance GEq' UChar where+ geq' (UChar c1) (UChar c2) = isTrue# (eqChar# c1 c2)+instance GEq' UDouble where+ geq' (UDouble d1) (UDouble d2) = isTrue# (d1 ==## d2)+instance GEq' UFloat where+ geq' (UFloat f1) (UFloat f2) = isTrue# (eqFloat# f1 f2)+instance GEq' UInt where+ geq' (UInt i1) (UInt i2) = isTrue# (i1 ==# i2)+instance GEq' UWord where+ geq' (UWord w1) (UWord w2) = isTrue# (eqWord# w1 w2)++#if __GLASGOW_HASKELL__ < 707+isTrue# :: Bool -> Bool+isTrue# = id+#endif+++class GEq a where+ geq :: a -> a -> Bool+++#if __GLASGOW_HASKELL__ >= 701+ default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool+ geq = geqdefault+#endif++geqdefault :: (Generic a, GEq' (Rep a)) => a -> a -> Bool+geqdefault x y = geq' (from x) (from y)++-- Base types instances+instance GEq () where+ geq = geqdefault++instance (GEq a, GEq b) => GEq (a, b) where+ geq = geqdefault++instance (GEq a, GEq b, GEq c) => GEq (a, b, c) where+ geq = geqdefault++instance (GEq a, GEq b, GEq c, GEq d) => GEq (a, b, c, d) where+ geq = geqdefault++instance (GEq a, GEq b, GEq c, GEq d, GEq e) => GEq (a, b, c, d, e) where+ geq = geqdefault++instance (GEq a, GEq b, GEq c, GEq d, GEq e, GEq f)+ => GEq (a, b, c, d, e, f) where+ geq = geqdefault++instance (GEq a, GEq b, GEq c, GEq d, GEq e, GEq f, GEq g)+ => GEq (a, b, c, d, e, f, g) where+ geq = geqdefault++instance GEq a => GEq [a] where+ geq = geqdefault++instance (GEq (f p), GEq (g p)) => GEq ((f :+: g) p) where+ geq = geqdefault++instance (GEq (f p), GEq (g p)) => GEq ((f :*: g) p) where+ geq = geqdefault++instance GEq (f (g p)) => GEq ((f :.: g) p) where+ geq = geqdefault++instance GEq All where+ geq = geqdefault++#if MIN_VERSION_base(4,8,0)+instance GEq (f a) => GEq (Alt f a) where+ geq = geqdefault+#endif++instance GEq Any where+ geq = geqdefault++#if !(MIN_VERSION_base(4,9,0))+instance GEq Arity where+ geq = geqdefault+#endif++#if MIN_VERSION_base(4,9,0)+instance GEq a => GEq (Arg a b) where+ geq (Arg a _) (Arg b _) = geq a b+#endif++instance GEq Associativity where+ geq = geqdefault++instance GEq Bool where+ geq = geqdefault++instance GEq BufferMode where+ geq = (==)++#if defined(HTYPE_CC_T)+instance GEq CCc where+ geq = (==)+#endif++instance GEq CChar where+ geq = (==)++instance GEq CClock where+ geq = (==)++#if defined(HTYPE_DEV_T)+instance GEq CDev where+ geq = (==)+#endif++instance GEq CDouble where+ geq = (==)++instance GEq CFloat where+ geq = (==)++#if defined(HTYPE_GID_T)+instance GEq CGid where+ geq = (==)+#endif++instance GEq Char where+ geq = (==)++#if defined(HTYPE_INO_T)+instance GEq CIno where+ geq = (==)+#endif++instance GEq CInt where+ geq = (==)++instance GEq CIntMax where+ geq = (==)++instance GEq CIntPtr where+ geq = (==)++instance GEq CLLong where+ geq = (==)++instance GEq CLong where+ geq = (==)++#if defined(HTYPE_MODE_T)+instance GEq CMode where+ geq = (==)+#endif++#if defined(HTYPE_NLINK_T)+instance GEq CNlink where+ geq = (==)+#endif++#if defined(HTYPE_OFF_T)+instance GEq COff where+ geq = (==)+#endif++#if MIN_VERSION_base(4,4,0)+instance GEq a => GEq (Complex a) where+ geq = geqdefault+#endif++instance GEq a => GEq (Const a b) where+ geq = geqdefault++#if defined(HTYPE_PID_T)+instance GEq CPid where+ geq = (==)+#endif++instance GEq CPtrdiff where+ geq = (==)++#if defined(HTYPE_RLIM_T)+instance GEq CRLim where+ geq = (==)+#endif++instance GEq CSChar where+ geq = (==)++#if defined(HTYPE_SPEED_T)+instance GEq CSpeed where+ geq = (==)+#endif++#if MIN_VERSION_base(4,4,0)+instance GEq CSUSeconds where+ geq = (==)+#endif++instance GEq CShort where+ geq = (==)++instance GEq CSigAtomic where+ geq = (==)++instance GEq CSize where+ geq = (==)++#if defined(HTYPE_SSIZE_T)+instance GEq CSsize where+ geq = (==)+#endif++#if defined(HTYPE_TCFLAG_T)+instance GEq CTcflag where+ geq = (==)+#endif++instance GEq CTime where+ geq = (==)++instance GEq CUChar where+ geq = (==)++#if defined(HTYPE_UID_T)+instance GEq CUid where+ geq = (==)+#endif++instance GEq CUInt where+ geq = (==)++instance GEq CUIntMax where+ geq = (==)++instance GEq CUIntPtr where+ geq = (==)++instance GEq CULLong where+ geq = (==)++instance GEq CULong where+ geq = (==)++#if MIN_VERSION_base(4,4,0)+instance GEq CUSeconds where+ geq = (==)+#endif++instance GEq CUShort where+ geq = (==)++instance GEq CWchar where+ geq = (==)++#if MIN_VERSION_base(4,9,0)+instance GEq DecidedStrictness where+ geq = geqdefault+#endif++instance GEq Double where+ geq = (==)++instance GEq a => GEq (Dual a) where+ geq = geqdefault++instance (GEq a, GEq b) => GEq (Either a b) where+ geq = geqdefault++instance GEq Errno where+ geq = (==)++instance GEq ExitCode where+ geq = geqdefault++instance GEq Fd where+ geq = (==)++instance GEq a => GEq (Monoid.First a) where+ geq = geqdefault++#if MIN_VERSION_base(4,9,0)+instance GEq a => GEq (Semigroup.First a) where+ geq = geqdefault+#endif++instance GEq Fixity where+ geq = geqdefault++instance GEq Float where+ geq = (==)++instance GEq (ForeignPtr a) where+ geq = (==)++instance GEq (FunPtr a) where+ geq = (==)++instance GEq GeneralCategory where+ geq = (==)++instance GEq Handle where+ geq = (==)++instance GEq HandlePosn where+ geq = (==)++#if MIN_VERSION_base(4,8,0)+instance GEq a => GEq (Identity a) where+ geq = geqdefault+#endif++instance GEq Int where+ geq = (==)++instance GEq Int8 where+ geq = (==)++instance GEq Int16 where+ geq = (==)++instance GEq Int32 where+ geq = (==)++instance GEq Int64 where+ geq = (==)++instance GEq Integer where+ geq = (==)++instance GEq IntPtr where+ geq = (==)++instance GEq IOError where+ geq = (==)++instance GEq IOErrorType where+ geq = (==)++instance GEq IOMode where+ geq = (==)++instance GEq c => GEq (K1 i c p) where+ geq = geqdefault++instance GEq a => GEq (Monoid.Last a) where+ geq = geqdefault++#if MIN_VERSION_base(4,9,0)+instance GEq a => GEq (Semigroup.Last a) where+ geq = geqdefault+#endif++instance GEq (f p) => GEq (M1 i c f p) where+ geq = geqdefault++instance GEq a => GEq (Maybe a) where+ geq = geqdefault++#if MIN_VERSION_base(4,9,0)+instance GEq a => GEq (Max a) where+ geq = geqdefault++instance GEq a => GEq (Min a) where+ geq = geqdefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GEq Natural where+ geq = (==)+#endif++#if MIN_VERSION_base(4,9,0)+instance GEq a => GEq (NonEmpty a) where+ geq = geqdefault++instance GEq a => GEq (Option a) where+ geq = geqdefault+#endif++instance GEq Ordering where+ geq = geqdefault++instance GEq p => GEq (Par1 p) where+ geq = geqdefault++instance GEq a => GEq (Product a) where+ geq = geqdefault++#if MIN_VERSION_base(4,7,0)+instance GEq (Proxy s) where+ geq = geqdefault+#endif++instance GEq (Ptr a) where+ geq = (==)++instance GEq (f p) => GEq (Rec1 f p) where+ geq = geqdefault++instance GEq SeekMode where+ geq = (==)++instance GEq (StablePtr a) where+ geq = (==)++#if MIN_VERSION_base(4,9,0)+instance GEq SourceStrictness where+ geq = geqdefault++instance GEq SourceUnpackedness where+ geq = geqdefault+#endif++instance GEq a => GEq (Sum a) where+ geq = geqdefault++instance GEq (U1 p) where+ geq = geqdefault++instance GEq (UAddr p) where+ geq = geqdefault++instance GEq (UChar p) where+ geq = geqdefault++instance GEq (UDouble p) where+ geq = geqdefault++instance GEq (UFloat p) where+ geq = geqdefault++instance GEq (UInt p) where+ geq = geqdefault++instance GEq (UWord p) where+ geq = geqdefault++instance GEq Version where+ geq = (==)++#if MIN_VERSION_base(4,8,0)+instance GEq Void where+ geq = (==)+#endif++instance GEq Word where+ geq = (==)++instance GEq Word8 where+ geq = (==)++instance GEq Word16 where+ geq = (==)++instance GEq Word32 where+ geq = (==)++instance GEq Word64 where+ geq = (==)++instance GEq WordPtr where+ geq = (==)++#if MIN_VERSION_base(4,9,0)+instance GEq m => GEq (WrappedMonoid m) where+ geq = geqdefault+#endif++instance GEq a => GEq (ZipList a) where+ geq = geqdefault
src/Generics/Deriving/Foldable.hs view
@@ -1,196 +1,304 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -module Generics.Deriving.Foldable ( - -- * Foldable class - GFoldable(..) - - -- * Default method - , gfoldMapdefault - - -- * Derived functions - , gtoList - , gconcat - , gconcatMap - , gand - , gor - , gany - , gall - , gsum - , gproduct - , gmaximum - , gmaximumBy - , gminimum - , gminimumBy - , gelem - , gnotElem - , gfind - ) where - -import Control.Applicative (Const) - -import Data.Maybe -import Data.Monoid - -import Generics.Deriving.Base -import Generics.Deriving.Instances () - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -#endif - --------------------------------------------------------------------------------- --- Generic fold --------------------------------------------------------------------------------- - -class GFoldable' t where - gfoldMap' :: Monoid m => (a -> m) -> t a -> m - -instance GFoldable' U1 where - gfoldMap' _ U1 = mempty - -instance GFoldable' Par1 where - gfoldMap' f (Par1 a) = f a - -instance GFoldable' (K1 i c) where - gfoldMap' _ (K1 _) = mempty - -instance (GFoldable f) => GFoldable' (Rec1 f) where - gfoldMap' f (Rec1 a) = gfoldMap f a - -instance (GFoldable' f) => GFoldable' (M1 i c f) where - gfoldMap' f (M1 a) = gfoldMap' f a - -instance (GFoldable' f, GFoldable' g) => GFoldable' (f :+: g) where - gfoldMap' f (L1 a) = gfoldMap' f a - gfoldMap' f (R1 a) = gfoldMap' f a - -instance (GFoldable' f, GFoldable' g) => GFoldable' (f :*: g) where - gfoldMap' f (a :*: b) = mappend (gfoldMap' f a) (gfoldMap' f b) - -instance (GFoldable f, GFoldable' g) => GFoldable' (f :.: g) where - gfoldMap' f (Comp1 x) = gfoldMap (gfoldMap' f) x - - -class GFoldable t where - gfoldMap :: Monoid m => (a -> m) -> t a -> m -#if __GLASGOW_HASKELL__ >= 701 - default gfoldMap :: (Generic1 t, GFoldable' (Rep1 t), Monoid m) - => (a -> m) -> t a -> m - gfoldMap = gfoldMapdefault -#endif - - gfold :: Monoid m => t m -> m - gfold = gfoldMap id - - gfoldr :: (a -> b -> b) -> b -> t a -> b - gfoldr f z t = appEndo (gfoldMap (Endo . f) t) z - - gfoldr' :: (a -> b -> b) -> b -> t a -> b - gfoldr' f z0 xs = gfoldl f' id xs z0 - where f' k x z = k $! f x z - - gfoldl :: (a -> b -> a) -> a -> t b -> a - gfoldl f z t = appEndo (getDual (gfoldMap (Dual . Endo . flip f) t)) z - - gfoldl' :: (a -> b -> a) -> a -> t b -> a - gfoldl' f z0 xs = gfoldr f' id xs z0 - where f' x k z = k $! f z x - - gfoldr1 :: (a -> a -> a) -> t a -> a - gfoldr1 f xs = fromMaybe (error "gfoldr1: empty structure") - (gfoldr mf Nothing xs) - where - mf x Nothing = Just x - mf x (Just y) = Just (f x y) - - gfoldl1 :: (a -> a -> a) -> t a -> a - gfoldl1 f xs = fromMaybe (error "foldl1: empty structure") - (gfoldl mf Nothing xs) - where - mf Nothing y = Just y - mf (Just x) y = Just (f x y) - -gfoldMapdefault :: (Generic1 t, GFoldable' (Rep1 t), Monoid m) - => (a -> m) -> t a -> m -gfoldMapdefault f x = gfoldMap' f (from1 x) - --- Base types instances -instance GFoldable [] where - gfoldMap = gfoldMapdefault - -instance GFoldable ((,) a) where - gfoldMap = gfoldMapdefault - -instance GFoldable (Const m) where - gfoldMap = gfoldMapdefault - -instance GFoldable (Either a) where - gfoldMap = gfoldMapdefault - -#if MIN_VERSION_base(4,8,0) -instance GFoldable Identity where - gfoldMap = gfoldMapdefault -#endif - -instance GFoldable Maybe where - gfoldMap = gfoldMapdefault - -gtoList :: GFoldable t => t a -> [a] -gtoList = gfoldr (:) [] - -gconcat :: GFoldable t => t [a] -> [a] -gconcat = gfold - -gconcatMap :: GFoldable t => (a -> [b]) -> t a -> [b] -gconcatMap = gfoldMap - -gand :: GFoldable t => t Bool -> Bool -gand = getAll . gfoldMap All - -gor :: GFoldable t => t Bool -> Bool -gor = getAny . gfoldMap Any - -gany :: GFoldable t => (a -> Bool) -> t a -> Bool -gany p = getAny . gfoldMap (Any . p) - -gall :: GFoldable t => (a -> Bool) -> t a -> Bool -gall p = getAll . gfoldMap (All . p) - -gsum :: (GFoldable t, Num a) => t a -> a -gsum = getSum . gfoldMap Sum - -gproduct :: (GFoldable t, Num a) => t a -> a -gproduct = getProduct . gfoldMap Product - -gmaximum :: (GFoldable t, Ord a) => t a -> a -gmaximum = gfoldr1 max - -gmaximumBy :: GFoldable t => (a -> a -> Ordering) -> t a -> a -gmaximumBy cmp = gfoldr1 max' - where max' x y = case cmp x y of - GT -> x - _ -> y - -gminimum :: (GFoldable t, Ord a) => t a -> a -gminimum = gfoldr1 min - -gminimumBy :: GFoldable t => (a -> a -> Ordering) -> t a -> a -gminimumBy cmp = gfoldr1 min' - where min' x y = case cmp x y of - GT -> y - _ -> x - -gelem :: (GFoldable t, Eq a) => a -> t a -> Bool -gelem = gany . (==) - -gnotElem :: (GFoldable t, Eq a) => a -> t a -> Bool -gnotElem x = not . gelem x - -gfind :: GFoldable t => (a -> Bool) -> t a -> Maybe a -gfind p = listToMaybe . gconcatMap (\ x -> if p x then [x] else []) - +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+#endif++module Generics.Deriving.Foldable (+ -- * Foldable class+ GFoldable(..)++ -- * Default method+ , gfoldMapdefault++ -- * Derived functions+ , gtoList+ , gconcat+ , gconcatMap+ , gand+ , gor+ , gany+ , gall+ , gsum+ , gproduct+ , gmaximum+ , gmaximumBy+ , gminimum+ , gminimumBy+ , gelem+ , gnotElem+ , gfind+ ) where++import Control.Applicative (Const, ZipList)++import Data.Maybe+import qualified Data.Monoid as Monoid (First, Last, Product(..), Sum(..))+import Data.Monoid (All(..), Any(..), Dual(..), Endo(..))+#if !(MIN_VERSION_base(4,8,0))+import Data.Monoid (Monoid(..))+#endif++import Generics.Deriving.Base+import Generics.Deriving.Instances ()++#if MIN_VERSION_base(4,4,0)+import Data.Complex (Complex)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+#endif++#if MIN_VERSION_base(4,9,0)+import qualified Data.Functor.Product as Functor (Product)+import qualified Data.Functor.Sum as Functor (Sum)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg, Max, Min, Option, WrappedMonoid)+#endif++--------------------------------------------------------------------------------+-- Generic fold+--------------------------------------------------------------------------------++class GFoldable' t where+ gfoldMap' :: Monoid m => (a -> m) -> t a -> m++instance GFoldable' U1 where+ gfoldMap' _ U1 = mempty++instance GFoldable' Par1 where+ gfoldMap' f (Par1 a) = f a++instance GFoldable' (K1 i c) where+ gfoldMap' _ (K1 _) = mempty++instance (GFoldable f) => GFoldable' (Rec1 f) where+ gfoldMap' f (Rec1 a) = gfoldMap f a++instance (GFoldable' f) => GFoldable' (M1 i c f) where+ gfoldMap' f (M1 a) = gfoldMap' f a++instance (GFoldable' f, GFoldable' g) => GFoldable' (f :+: g) where+ gfoldMap' f (L1 a) = gfoldMap' f a+ gfoldMap' f (R1 a) = gfoldMap' f a++instance (GFoldable' f, GFoldable' g) => GFoldable' (f :*: g) where+ gfoldMap' f (a :*: b) = mappend (gfoldMap' f a) (gfoldMap' f b)++instance (GFoldable f, GFoldable' g) => GFoldable' (f :.: g) where+ gfoldMap' f (Comp1 x) = gfoldMap (gfoldMap' f) x++instance GFoldable' UAddr where+ gfoldMap' _ (UAddr _) = mempty++instance GFoldable' UChar where+ gfoldMap' _ (UChar _) = mempty++instance GFoldable' UDouble where+ gfoldMap' _ (UDouble _) = mempty++instance GFoldable' UFloat where+ gfoldMap' _ (UFloat _) = mempty++instance GFoldable' UInt where+ gfoldMap' _ (UInt _) = mempty++instance GFoldable' UWord where+ gfoldMap' _ (UWord _) = mempty++class GFoldable t where+ gfoldMap :: Monoid m => (a -> m) -> t a -> m+#if __GLASGOW_HASKELL__ >= 701+ default gfoldMap :: (Generic1 t, GFoldable' (Rep1 t), Monoid m)+ => (a -> m) -> t a -> m+ gfoldMap = gfoldMapdefault+#endif++ gfold :: Monoid m => t m -> m+ gfold = gfoldMap id++ gfoldr :: (a -> b -> b) -> b -> t a -> b+ gfoldr f z t = appEndo (gfoldMap (Endo . f) t) z++ gfoldr' :: (a -> b -> b) -> b -> t a -> b+ gfoldr' f z0 xs = gfoldl f' id xs z0+ where f' k x z = k $! f x z++ gfoldl :: (a -> b -> a) -> a -> t b -> a+ gfoldl f z t = appEndo (getDual (gfoldMap (Dual . Endo . flip f) t)) z++ gfoldl' :: (a -> b -> a) -> a -> t b -> a+ gfoldl' f z0 xs = gfoldr f' id xs z0+ where f' x k z = k $! f z x++ gfoldr1 :: (a -> a -> a) -> t a -> a+ gfoldr1 f xs = fromMaybe (error "gfoldr1: empty structure")+ (gfoldr mf Nothing xs)+ where+ mf x Nothing = Just x+ mf x (Just y) = Just (f x y)++ gfoldl1 :: (a -> a -> a) -> t a -> a+ gfoldl1 f xs = fromMaybe (error "foldl1: empty structure")+ (gfoldl mf Nothing xs)+ where+ mf Nothing y = Just y+ mf (Just x) y = Just (f x y)++gfoldMapdefault :: (Generic1 t, GFoldable' (Rep1 t), Monoid m)+ => (a -> m) -> t a -> m+gfoldMapdefault f x = gfoldMap' f (from1 x)++-- Base types instances+instance GFoldable ((,) a) where+ gfoldMap = gfoldMapdefault++instance GFoldable [] where+ gfoldMap = gfoldMapdefault++#if MIN_VERSION_base(4,9,0)+instance GFoldable (Arg a) where+ gfoldMap = gfoldMapdefault+#endif++#if MIN_VERSION_base(4,4,0)+instance GFoldable Complex where+ gfoldMap = gfoldMapdefault+#endif++instance GFoldable (Const m) where+ gfoldMap = gfoldMapdefault++instance GFoldable Dual where+ gfoldMap = gfoldMapdefault++instance GFoldable (Either a) where+ gfoldMap = gfoldMapdefault++instance GFoldable Monoid.First where+ gfoldMap = gfoldMapdefault++#if MIN_VERSION_base(4,9,0)+instance GFoldable (Semigroup.First) where+ gfoldMap = gfoldMapdefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GFoldable Identity where+ gfoldMap = gfoldMapdefault+#endif++instance GFoldable Monoid.Last where+ gfoldMap = gfoldMapdefault++#if MIN_VERSION_base(4,9,0)+instance GFoldable Semigroup.Last where+ gfoldMap = gfoldMapdefault++instance GFoldable Max where+ gfoldMap = gfoldMapdefault+#endif++instance GFoldable Maybe where+ gfoldMap = gfoldMapdefault++#if MIN_VERSION_base(4,9,0)+instance GFoldable Min where+ gfoldMap = gfoldMapdefault++instance GFoldable NonEmpty where+ gfoldMap = gfoldMapdefault++instance GFoldable Option where+ gfoldMap = gfoldMapdefault+#endif++instance GFoldable Monoid.Product where+ gfoldMap = gfoldMapdefault++#if MIN_VERSION_base(4,9,0)+instance (GFoldable f, GFoldable g) => GFoldable (Functor.Product f g) where+ gfoldMap = gfoldMapdefault+#endif++#if MIN_VERSION_base(4,7,0)+instance GFoldable Proxy where+ gfoldMap = gfoldMapdefault+#endif++instance GFoldable Monoid.Sum where+ gfoldMap = gfoldMapdefault++#if MIN_VERSION_base(4,9,0)+instance (GFoldable f, GFoldable g) => GFoldable (Functor.Sum f g) where+ gfoldMap = gfoldMapdefault++instance GFoldable WrappedMonoid where+ gfoldMap = gfoldMapdefault+#endif++instance GFoldable ZipList where+ gfoldMap = gfoldMapdefault++gtoList :: GFoldable t => t a -> [a]+gtoList = gfoldr (:) []++gconcat :: GFoldable t => t [a] -> [a]+gconcat = gfold++gconcatMap :: GFoldable t => (a -> [b]) -> t a -> [b]+gconcatMap = gfoldMap++gand :: GFoldable t => t Bool -> Bool+gand = getAll . gfoldMap All++gor :: GFoldable t => t Bool -> Bool+gor = getAny . gfoldMap Any++gany :: GFoldable t => (a -> Bool) -> t a -> Bool+gany p = getAny . gfoldMap (Any . p)++gall :: GFoldable t => (a -> Bool) -> t a -> Bool+gall p = getAll . gfoldMap (All . p)++gsum :: (GFoldable t, Num a) => t a -> a+gsum = Monoid.getSum . gfoldMap Monoid.Sum++gproduct :: (GFoldable t, Num a) => t a -> a+gproduct = Monoid.getProduct . gfoldMap Monoid.Product++gmaximum :: (GFoldable t, Ord a) => t a -> a+gmaximum = gfoldr1 max++gmaximumBy :: GFoldable t => (a -> a -> Ordering) -> t a -> a+gmaximumBy cmp = gfoldr1 max'+ where max' x y = case cmp x y of+ GT -> x+ _ -> y++gminimum :: (GFoldable t, Ord a) => t a -> a+gminimum = gfoldr1 min++gminimumBy :: GFoldable t => (a -> a -> Ordering) -> t a -> a+gminimumBy cmp = gfoldr1 min'+ where min' x y = case cmp x y of+ GT -> y+ _ -> x++gelem :: (GFoldable t, Eq a) => a -> t a -> Bool+gelem = gany . (==)++gnotElem :: (GFoldable t, Eq a) => a -> t a -> Bool+gnotElem x = not . gelem x++gfind :: GFoldable t => (a -> Bool) -> t a -> Maybe a+gfind p = listToMaybe . gconcatMap (\ x -> if p x then [x] else [])
src/Generics/Deriving/Functor.hs view
@@ -1,113 +1,210 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -module Generics.Deriving.Functor ( - -- * GFunctor class - GFunctor(..) - - -- * Default method - , gmapdefault - - ) where - -import Control.Applicative (Const, ZipList) - -import Data.Monoid (First, Last) - -import Generics.Deriving.Base -import Generics.Deriving.Instances () - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -import Data.Monoid (Alt) -#endif - --------------------------------------------------------------------------------- --- Generic fmap --------------------------------------------------------------------------------- - -class GFunctor' f where - gmap' :: (a -> b) -> f a -> f b - -instance GFunctor' U1 where - gmap' _ U1 = U1 - -instance GFunctor' Par1 where - gmap' f (Par1 a) = Par1 (f a) - -instance GFunctor' (K1 i c) where - gmap' _ (K1 a) = K1 a - -instance (GFunctor f) => GFunctor' (Rec1 f) where - gmap' f (Rec1 a) = Rec1 (gmap f a) - -instance (GFunctor' f) => GFunctor' (M1 i c f) where - gmap' f (M1 a) = M1 (gmap' f a) - -instance (GFunctor' f, GFunctor' g) => GFunctor' (f :+: g) where - gmap' f (L1 a) = L1 (gmap' f a) - gmap' f (R1 a) = R1 (gmap' f a) - -instance (GFunctor' f, GFunctor' g) => GFunctor' (f :*: g) where - gmap' f (a :*: b) = gmap' f a :*: gmap' f b - -instance (GFunctor f, GFunctor' g) => GFunctor' (f :.: g) where - gmap' f (Comp1 x) = Comp1 (gmap (gmap' f) x) - - -class GFunctor f where - gmap :: (a -> b) -> f a -> f b -#if __GLASGOW_HASKELL__ >= 701 - default gmap :: (Generic1 f, GFunctor' (Rep1 f)) - => (a -> b) -> f a -> f b - gmap = gmapdefault -#endif - -gmapdefault :: (Generic1 f, GFunctor' (Rep1 f)) - => (a -> b) -> f a -> f b -gmapdefault f = to1 . gmap' f . from1 - --- Base types instances -instance GFunctor ((->) r) where - gmap = fmap - -instance GFunctor ((,) a) where - gmap = gmapdefault - -instance GFunctor [] where - gmap = gmapdefault - -#if MIN_VERSION_base(4,8,0) -instance GFunctor f => GFunctor (Alt f) where - gmap = gmapdefault -#endif - -instance GFunctor (Const m) where - gmap = gmapdefault - -instance GFunctor (Either a) where - gmap = gmapdefault - -instance GFunctor First where - gmap = gmapdefault - -#if MIN_VERSION_base(4,8,0) -instance GFunctor Identity where - gmap = gmapdefault -#endif - -instance GFunctor IO where - gmap = fmap - -instance GFunctor Last where - gmap = gmapdefault - -instance GFunctor Maybe where - gmap = gmapdefault - -instance GFunctor ZipList where - gmap = gmapdefault +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+#endif++module Generics.Deriving.Functor (+ -- * GFunctor class+ GFunctor(..)++ -- * Default method+ , gmapdefault++ ) where++import Control.Applicative (Const, ZipList)++import qualified Data.Monoid as Monoid (First, Last, Product, Sum)+import Data.Monoid (Dual)++import Generics.Deriving.Base+import Generics.Deriving.Instances ()++#if MIN_VERSION_base(4,4,0)+import Data.Complex (Complex)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+import Data.Monoid (Alt)+#endif++#if MIN_VERSION_base(4,9,0)+import qualified Data.Functor.Product as Functor (Product)+import qualified Data.Functor.Sum as Functor (Sum)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg, Max, Min, Option, WrappedMonoid)+#endif++--------------------------------------------------------------------------------+-- Generic fmap+--------------------------------------------------------------------------------++class GFunctor' f where+ gmap' :: (a -> b) -> f a -> f b++instance GFunctor' U1 where+ gmap' _ U1 = U1++instance GFunctor' Par1 where+ gmap' f (Par1 a) = Par1 (f a)++instance GFunctor' (K1 i c) where+ gmap' _ (K1 a) = K1 a++instance (GFunctor f) => GFunctor' (Rec1 f) where+ gmap' f (Rec1 a) = Rec1 (gmap f a)++instance (GFunctor' f) => GFunctor' (M1 i c f) where+ gmap' f (M1 a) = M1 (gmap' f a)++instance (GFunctor' f, GFunctor' g) => GFunctor' (f :+: g) where+ gmap' f (L1 a) = L1 (gmap' f a)+ gmap' f (R1 a) = R1 (gmap' f a)++instance (GFunctor' f, GFunctor' g) => GFunctor' (f :*: g) where+ gmap' f (a :*: b) = gmap' f a :*: gmap' f b++instance (GFunctor f, GFunctor' g) => GFunctor' (f :.: g) where+ gmap' f (Comp1 x) = Comp1 (gmap (gmap' f) x)++instance GFunctor' UAddr where+ gmap' _ (UAddr a) = UAddr a++instance GFunctor' UChar where+ gmap' _ (UChar c) = UChar c++instance GFunctor' UDouble where+ gmap' _ (UDouble d) = UDouble d++instance GFunctor' UFloat where+ gmap' _ (UFloat f) = UFloat f++instance GFunctor' UInt where+ gmap' _ (UInt i) = UInt i++instance GFunctor' UWord where+ gmap' _ (UWord w) = UWord w++class GFunctor f where+ gmap :: (a -> b) -> f a -> f b+#if __GLASGOW_HASKELL__ >= 701+ default gmap :: (Generic1 f, GFunctor' (Rep1 f))+ => (a -> b) -> f a -> f b+ gmap = gmapdefault+#endif++gmapdefault :: (Generic1 f, GFunctor' (Rep1 f))+ => (a -> b) -> f a -> f b+gmapdefault f = to1 . gmap' f . from1++-- Base types instances+instance GFunctor ((->) r) where+ gmap = fmap++instance GFunctor ((,) a) where+ gmap = gmapdefault++instance GFunctor [] where+ gmap = gmapdefault++#if MIN_VERSION_base(4,8,0)+instance GFunctor f => GFunctor (Alt f) where+ gmap = gmapdefault+#endif++#if MIN_VERSION_base(4,9,0)+instance GFunctor (Arg a) where+ gmap = gmapdefault+#endif++#if MIN_VERSION_base(4,4,0)+instance GFunctor Complex where+ gmap = gmapdefault+#endif++instance GFunctor (Const m) where+ gmap = gmapdefault++instance GFunctor Dual where+ gmap = gmapdefault++instance GFunctor (Either a) where+ gmap = gmapdefault++instance GFunctor Monoid.First where+ gmap = gmapdefault++#if MIN_VERSION_base(4,9,0)+instance GFunctor (Semigroup.First) where+ gmap = gmapdefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GFunctor Identity where+ gmap = gmapdefault+#endif++instance GFunctor IO where+ gmap = fmap++instance GFunctor Monoid.Last where+ gmap = gmapdefault++#if MIN_VERSION_base(4,9,0)+instance GFunctor Semigroup.Last where+ gmap = gmapdefault++instance GFunctor Max where+ gmap = gmapdefault+#endif++instance GFunctor Maybe where+ gmap = gmapdefault++#if MIN_VERSION_base(4,9,0)+instance GFunctor Min where+ gmap = gmapdefault++instance GFunctor NonEmpty where+ gmap = gmapdefault++instance GFunctor Option where+ gmap = gmapdefault+#endif++instance GFunctor Monoid.Product where+ gmap = gmapdefault++#if MIN_VERSION_base(4,9,0)+instance (GFunctor f, GFunctor g) => GFunctor (Functor.Product f g) where+ gmap = gmapdefault+#endif++#if MIN_VERSION_base(4,7,0)+instance GFunctor Proxy where+ gmap = gmapdefault+#endif++instance GFunctor Monoid.Sum where+ gmap = gmapdefault++#if MIN_VERSION_base(4,9,0)+instance (GFunctor f, GFunctor g) => GFunctor (Functor.Sum f g) where+ gmap = gmapdefault++instance GFunctor WrappedMonoid where+ gmap = gmapdefault+#endif++instance GFunctor ZipList where+ gmap = gmapdefault
src/Generics/Deriving/Instances.hs view
@@ -1,1462 +1,1587 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Generics.Deriving.Instances ( --- Only instances from Generics.Deriving.Base --- and the Generic1 instances -#if __GLASGOW_HASKELL__ < 711 - Rep0UAddr - , Rep0UChar - , Rep0UDouble - , Rep0UFloat - , Rep0UInt - , Rep0UWord -#endif -#if __GLASGOW_HASKELL__ < 708 - , Rep0All - , Rep0Any - , Rep0Arity - , Rep0Associativity - , Rep0Const - , Rep1Const - , Rep0Dual - , Rep1Dual - , Rep0Endo - , Rep0First - , Rep1First - , Rep0Fixity - , Rep0Last - , Rep1Last - , Rep0Product - , Rep1Product - , Rep0Sum - , Rep1Sum - , Rep0WrappedArrow - , Rep1WrappedArrow - , Rep0WrappedMonad - , Rep1WrappedMonad - , Rep0ZipList - , Rep1ZipList - , Rep0U1 - , Rep0Par1 - , Rep0Rec1 - , Rep0K1 - , Rep0M1 - , Rep0ConSum - , Rep0ConProduct - , Rep0ConCompose -#endif -#if __GLASGOW_HASKELL__ < 705 - , Rep1Either - , Rep1List - , Rep1Maybe - , Rep1Tuple2 - , Rep1Tuple3 - , Rep1Tuple4 - , Rep1Tuple5 - , Rep1Tuple6 - , Rep1Tuple7 -#endif -#if __GLASGOW_HASKELL__ < 701 - -- * Representations for base types - , Rep0Bool - , Rep0Char - , Rep0Double - , Rep0Either - , Rep0Int - , Rep0Float - , Rep0List - , Rep0Maybe - , Rep0Ordering - , Rep0Tuple2 - , Rep0Tuple3 - , Rep0Tuple4 - , Rep0Tuple5 - , Rep0Tuple6 - , Rep0Tuple7 - , Rep0Unit -#endif - ) where - -#if __GLASGOW_HASKELL__ < 708 -import Control.Applicative -import Data.Monoid -#endif - -#if __GLASGOW_HASKELL__ < 711 -import Generics.Deriving.Base -#endif - -#if __GLASGOW_HASKELL__ < 711 -type Rep0UAddr p = D1 D1UAddr (C1 C1_0UAddr (S1 S1_0_0UAddr UAddr)) - -instance Generic (UAddr p) where - type Rep (UAddr p) = Rep0UAddr p - from (UAddr a) = M1 (M1 (M1 (UAddr a))) - to (M1 (M1 (M1 (UAddr a)))) = UAddr a - -data D1UAddr -data C1_0UAddr -data S1_0_0UAddr - -instance Datatype D1UAddr where - datatypeName _ = "UAddr" - moduleName _ = "Generics.Deriving.Base" - -instance Constructor C1_0UAddr where - conName _ = "UAddr" - conIsRecord _ = True - -instance Selector S1_0_0UAddr where - selName _ = "uAddr#" - ------ - -type Rep0UChar p = D1 D1UChar (C1 C1_0UChar (S1 S1_0_0UChar UChar)) - -instance Generic (UChar p) where - type Rep (UChar p) = Rep0UChar p - from (UChar c) = M1 (M1 (M1 (UChar c))) - to (M1 (M1 (M1 (UChar c)))) = UChar c - -data D1UChar -data C1_0UChar -data S1_0_0UChar - -instance Datatype D1UChar where - datatypeName _ = "UChar" - moduleName _ = "Generics.Deriving.Base" - -instance Constructor C1_0UChar where - conName _ = "UChar" - conIsRecord _ = True - -instance Selector S1_0_0UChar where - selName _ = "uChar#" - ------ - -type Rep0UDouble p = D1 D1UDouble (C1 C1_0UDouble (S1 S1_0_0UDouble UDouble)) - -instance Generic (UDouble p) where - type Rep (UDouble p) = Rep0UDouble p - from (UDouble d) = M1 (M1 (M1 (UDouble d))) - to (M1 (M1 (M1 (UDouble d)))) = UDouble d - -data D1UDouble -data C1_0UDouble -data S1_0_0UDouble - -instance Datatype D1UDouble where - datatypeName _ = "UDouble" - moduleName _ = "Generics.Deriving.Base" - -instance Constructor C1_0UDouble where - conName _ = "UDouble" - conIsRecord _ = True - -instance Selector S1_0_0UDouble where - selName _ = "uDouble#" - ------ - -type Rep0UFloat p = D1 D1UFloat (C1 C1_0UFloat (S1 S1_0_0UFloat UFloat)) - -instance Generic (UFloat p) where - type Rep (UFloat p) = Rep0UFloat p - from (UFloat f) = M1 (M1 (M1 (UFloat f))) - to (M1 (M1 (M1 (UFloat f)))) = UFloat f - -data D1UFloat -data C1_0UFloat -data S1_0_0UFloat - -instance Datatype D1UFloat where - datatypeName _ = "UFloat" - moduleName _ = "Generics.Deriving.Base" - -instance Constructor C1_0UFloat where - conName _ = "UFloat" - conIsRecord _ = True - -instance Selector S1_0_0UFloat where - selName _ = "uFloat#" - ------ - -type Rep0UInt p = D1 D1UInt (C1 C1_0UInt (S1 S1_0_0UInt UInt)) - -instance Generic (UInt p) where - type Rep (UInt p) = Rep0UInt p - from (UInt i) = M1 (M1 (M1 (UInt i))) - to (M1 (M1 (M1 (UInt i)))) = UInt i - -data D1UInt -data C1_0UInt -data S1_0_0UInt - -instance Datatype D1UInt where - datatypeName _ = "UInt" - moduleName _ = "Generics.Deriving.Base" - -instance Constructor C1_0UInt where - conName _ = "UInt" - conIsRecord _ = True - -instance Selector S1_0_0UInt where - selName _ = "uInt#" - ------ - -type Rep0UWord p = D1 D1UWord (C1 C1_0UWord (S1 S1_0_0UWord UWord)) - -instance Generic (UWord p) where - type Rep (UWord p) = Rep0UWord p - from (UWord w) = M1 (M1 (M1 (UWord w))) - to (M1 (M1 (M1 (UWord w)))) = UWord w - -data D1UWord -data C1_0UWord -data S1_0_0UWord - -instance Datatype D1UWord where - datatypeName _ = "UWord" - moduleName _ = "Generics.Deriving.Base" - -instance Constructor C1_0UWord where - conName _ = "UWord" - conIsRecord _ = True - -instance Selector S1_0_0UWord where - selName _ = "uWord#" -#endif - ------ - -#if __GLASGOW_HASKELL__ < 708 --------------------------------------------------------------------------------- --- Representations for base types --------------------------------------------------------------------------------- - -type Rep0All = D1 D1All (C1 C1_0All (S1 S1_0_0All (Rec0 Bool))) - -instance Generic All where - type Rep All = Rep0All - from (All a) = M1 (M1 (M1 (K1 a))) - to (M1 (M1 (M1 (K1 a)))) = All a - -data D1All -data C1_0All -data S1_0_0All - -instance Datatype D1All where - datatypeName _ = "All" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0All where - conName _ = "All" - conIsRecord _ = True - -instance Selector S1_0_0All where - selName _ = "getAll" - ------ - -type Rep0Any = D1 D1Any (C1 C1_0Any (S1 S1_0_0Any (Rec0 Bool))) - -instance Generic Any where - type Rep Any = Rep0Any - from (Any a) = M1 (M1 (M1 (K1 a))) - to (M1 (M1 (M1 (K1 a)))) = Any a - -data D1Any -data C1_0Any -data S1_0_0Any - -instance Datatype D1Any where - datatypeName _ = "Any" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0Any where - conName _ = "Any" - conIsRecord _ = True - -instance Selector S1_0_0Any where - selName _ = "getAny" - ------ - -type Rep0Arity = D1 D1Arity (C1 C1_0Arity U1 - :+: C1 C1_1Arity (S1 NoSelector (Rec0 Int))) - -instance Generic Arity where - type Rep Arity = Rep0Arity - - from NoArity = M1 (L1 (M1 U1)) - from (Arity a) = M1 (R1 (M1 (M1 (K1 a)))) - - to (M1 (L1 (M1 U1))) = NoArity - to (M1 (R1 (M1 (M1 (K1 a))))) = Arity a - -data D1Arity -data C1_0Arity -data C1_1Arity - -instance Datatype D1Arity where - datatypeName _ = "Arity" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0Arity where - conName _ = "NoArity" - -instance Constructor C1_1Arity where - conName _ = "Arity" - ------ - -type Rep0Associativity = D1 D1Associativity (C1 C1_0Associativity U1 - :+: (C1 C1_1Associativity U1 - :+: C1 C1_2Associativity U1)) - -instance Generic Associativity where - type Rep Associativity = Rep0Associativity - - from LeftAssociative = M1 (L1 (M1 U1)) - from RightAssociative = M1 (R1 (L1 (M1 U1))) - from NotAssociative = M1 (R1 (R1 (M1 U1))) - - to (M1 (L1 (M1 U1))) = LeftAssociative - to (M1 (R1 (L1 (M1 U1)))) = RightAssociative - to (M1 (R1 (R1 (M1 U1)))) = NotAssociative - -data D1Associativity -data C1_0Associativity -data C1_1Associativity -data C1_2Associativity - -instance Datatype D1Associativity where - datatypeName _ = "Associativity" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0Associativity where - conName _ = "LeftAssociative" - -instance Constructor C1_1Associativity where - conName _ = "RightAssociative" - -instance Constructor C1_2Associativity where - conName _ = "NotAssociative" - ------ - -type Rep0Const a b = D1 D1Const (C1 C1_0Const (S1 S1_0_0Const (Rec0 a))) -type Rep1Const a = D1 D1Const (C1 C1_0Const (S1 S1_0_0Const (Rec0 a))) - -instance Generic (Const a b) where - type Rep (Const a b) = Rep0Const a b - from (Const a) = M1 (M1 (M1 (K1 a))) - to (M1 (M1 (M1 (K1 a)))) = Const a - -instance Generic1 (Const a) where - type Rep1 (Const a) = Rep1Const a - from1 (Const a) = M1 (M1 (M1 (K1 a))) - to1 (M1 (M1 (M1 (K1 a)))) = Const a - -data D1Const -data C1_0Const -data S1_0_0Const - -instance Datatype D1Const where - datatypeName _ = "Const" - moduleName _ = "Control.Applicative" - -instance Constructor C1_0Const where - conName _ = "Const" - conIsRecord _ = True - -instance Selector S1_0_0Const where - selName _ = "getConst" - ------ - -type Rep0Dual a = D1 D1Dual (C1 C1_0Dual (S1 S1_0_0Dual (Rec0 a))) -type Rep1Dual = D1 D1Dual (C1 C1_0Dual (S1 S1_0_0Dual Par1)) - -instance Generic (Dual a) where - type Rep (Dual a) = Rep0Dual a - from (Dual d) = M1 (M1 (M1 (K1 d))) - to (M1 (M1 (M1 (K1 d)))) = Dual d - -instance Generic1 Dual where - type Rep1 Dual = Rep1Dual - from1 (Dual d) = M1 (M1 (M1 (Par1 d))) - to1 (M1 (M1 (M1 (Par1 d)))) = Dual d - -data D1Dual -data C1_0Dual -data S1_0_0Dual - -instance Datatype D1Dual where - datatypeName _ = "Dual" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0Dual where - conName _ = "Dual" - conIsRecord _ = True - -instance Selector S1_0_0Dual where - selName _ = "getDual" - ------ - -type Rep0Endo a = D1 D1Endo (C1 C1_0Endo (S1 S1_0_0Endo (Rec0 (a -> a)))) - -instance Generic (Endo a) where - type Rep (Endo a) = Rep0Endo a - from (Endo e) = M1 (M1 (M1 (K1 e))) - to (M1 (M1 (M1 (K1 e)))) = Endo e - -data D1Endo -data C1_0Endo -data S1_0_0Endo - -instance Datatype D1Endo where - datatypeName _ = "Endo" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0Endo where - conName _ = "Endo" - conIsRecord _ = True - -instance Selector S1_0_0Endo where - selName _ = "appEndo" - ------ - -type Rep0First a = D1 D1First (C1 C1_0First (S1 S1_0_0First (Rec0 (Maybe a)))) -type Rep1First = D1 D1First (C1 C1_0First (S1 S1_0_0First (Rec1 Maybe))) - -instance Generic (First a) where - type Rep (First a) = Rep0First a - from (First f) = M1 (M1 (M1 (K1 f))) - to (M1 (M1 (M1 (K1 f)))) = First f - -instance Generic1 First where - type Rep1 First = Rep1First - from1 (First f) = M1 (M1 (M1 (Rec1 f))) - to1 (M1 (M1 (M1 (Rec1 f)))) = First f - -data D1First -data C1_0First -data S1_0_0First - -instance Datatype D1First where - datatypeName _ = "First" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0First where - conName _ = "First" - conIsRecord _ = True - -instance Selector S1_0_0First where - selName _ = "getFirst" - ------ - -type Rep0Fixity = D1 D1Fixity (C1 C1_0Fixity U1 - :+: C1 C1_1Fixity (S1 NoSelector (Rec0 Associativity) - :*: S1 NoSelector (Rec0 Int))) - -instance Generic Fixity where - type Rep Fixity = Rep0Fixity - - from Prefix = M1 (L1 (M1 U1)) - from (Infix a i) = M1 (R1 (M1 (M1 (K1 a) :*: M1 (K1 i)))) - - to (M1 (L1 (M1 U1))) = Prefix - to (M1 (R1 (M1 (M1 (K1 a) :*: M1 (K1 i))))) = Infix a i - -data D1Fixity -data C1_0Fixity -data C1_1Fixity - -instance Datatype D1Fixity where - datatypeName _ = "Fixity" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0Fixity where - conName _ = "Prefix" - -instance Constructor C1_1Fixity where - conName _ = "Infix" - ------ - -type Rep0Last a = D1 D1Last (C1 C1_0Last (S1 S1_0_0Last (Rec0 (Maybe a)))) -type Rep1Last = D1 D1Last (C1 C1_0Last (S1 S1_0_0Last (Rec1 Maybe))) - -instance Generic (Last a) where - type Rep (Last a) = Rep0Last a - from (Last l) = M1 (M1 (M1 (K1 l))) - to (M1 (M1 (M1 (K1 l)))) = Last l - -instance Generic1 Last where - type Rep1 Last = Rep1Last - from1 (Last l) = M1 (M1 (M1 (Rec1 l))) - to1 (M1 (M1 (M1 (Rec1 l)))) = Last l - -data D1Last -data C1_0Last -data S1_0_0Last - -instance Datatype D1Last where - datatypeName _ = "Last" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0Last where - conName _ = "Last" - conIsRecord _ = True - -instance Selector S1_0_0Last where - selName _ = "getLast" - ------ - -type Rep0Product a = D1 D1Product (C1 C1_0Product (S1 S1_0_0Product (Rec0 a))) -type Rep1Product = D1 D1Product (C1 C1_0Product (S1 S1_0_0Product Par1)) - -instance Generic (Product a) where - type Rep (Product a) = Rep0Product a - from (Product p) = M1 (M1 (M1 (K1 p))) - to (M1 (M1 (M1 (K1 p)))) = Product p - -instance Generic1 Product where - type Rep1 Product = Rep1Product - from1 (Product p) = M1 (M1 (M1 (Par1 p))) - to1 (M1 (M1 (M1 (Par1 p)))) = Product p - -data D1Product -data C1_0Product -data S1_0_0Product - -instance Datatype D1Product where - datatypeName _ = "Product" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0Product where - conName _ = "Product" - conIsRecord _ = True - -instance Selector S1_0_0Product where - selName _ = "getProduct" - ------ - -type Rep0Sum a = D1 D1Sum (C1 C1_0Sum (S1 S1_0_0Sum (Rec0 a))) -type Rep1Sum = D1 D1Sum (C1 C1_0Sum (S1 S1_0_0Sum Par1)) - -instance Generic (Sum a) where - type Rep (Sum a) = Rep0Sum a - from (Sum s) = M1 (M1 (M1 (K1 s))) - to (M1 (M1 (M1 (K1 s)))) = Sum s - -instance Generic1 Sum where - type Rep1 Sum = Rep1Sum - from1 (Sum s) = M1 (M1 (M1 (Par1 s))) - to1 (M1 (M1 (M1 (Par1 s)))) = Sum s - -data D1Sum -data C1_0Sum -data S1_0_0Sum - -instance Datatype D1Sum where - datatypeName _ = "Sum" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0Sum where - conName _ = "Sum" - conIsRecord _ = True - -instance Selector S1_0_0Sum where - selName _ = "getSum" - ------ - -type Rep0WrappedArrow a b c = - D1 D1WrappedArrow (C1 C1_0WrappedArrow (S1 S1_0_0WrappedArrow (Rec0 (a b c)))) -type Rep1WrappedArrow a b = - D1 D1WrappedArrow (C1 C1_0WrappedArrow (S1 S1_0_0WrappedArrow (Rec1 (a b)))) - -instance Generic (WrappedArrow a b c) where - type Rep (WrappedArrow a b c) = Rep0WrappedArrow a b c - from (WrapArrow a) = M1 (M1 (M1 (K1 a))) - to (M1 (M1 (M1 (K1 a)))) = WrapArrow a - -instance Generic1 (WrappedArrow a b) where - type Rep1 (WrappedArrow a b) = Rep1WrappedArrow a b - from1 (WrapArrow a) = M1 (M1 (M1 (Rec1 a))) - to1 (M1 (M1 (M1 (Rec1 a)))) = WrapArrow a - -data D1WrappedArrow -data C1_0WrappedArrow -data S1_0_0WrappedArrow - -instance Datatype D1WrappedArrow where - datatypeName _ = "WrappedArrow" - moduleName _ = "Control.Applicative" - -instance Constructor C1_0WrappedArrow where - conName _ = "WrapArrow" - conIsRecord _ = True - -instance Selector S1_0_0WrappedArrow where - selName _ = "unwrapArrow" - ------ - -type Rep0WrappedMonad m a = - D1 D1WrappedMonad (C1 C1_0WrappedMonad (S1 S1_0_0WrappedMonad (Rec0 (m a)))) -type Rep1WrappedMonad m = - D1 D1WrappedMonad (C1 C1_0WrappedMonad (S1 S1_0_0WrappedMonad (Rec1 m))) - -instance Generic (WrappedMonad m a) where - type Rep (WrappedMonad m a) = Rep0WrappedMonad m a - from (WrapMonad m) = M1 (M1 (M1 (K1 m))) - to (M1 (M1 (M1 (K1 m)))) = WrapMonad m - -instance Generic1 (WrappedMonad m) where - type Rep1 (WrappedMonad m) = Rep1WrappedMonad m - from1 (WrapMonad m) = M1 (M1 (M1 (Rec1 m))) - to1 (M1 (M1 (M1 (Rec1 m)))) = WrapMonad m - -data D1WrappedMonad -data C1_0WrappedMonad -data S1_0_0WrappedMonad - -instance Datatype D1WrappedMonad where - datatypeName _ = "WrappedMonad" - moduleName _ = "Control.Applicative" - -instance Constructor C1_0WrappedMonad where - conName _ = "WrapMonad" - conIsRecord _ = True - -instance Selector S1_0_0WrappedMonad where - selName _ = "unwrapMonad" - ------ - -type Rep0ZipList a = D1 D1ZipList (C1 C1_0ZipList (S1 S1_0_0ZipList (Rec0 [a]))) -type Rep1ZipList = D1 D1ZipList (C1 C1_0ZipList (S1 S1_0_0ZipList (Rec1 []))) - -instance Generic (ZipList a) where - type Rep (ZipList a) = Rep0ZipList a - from (ZipList z) = M1 (M1 (M1 (K1 z))) - to (M1 (M1 (M1 (K1 z)))) = ZipList z - -instance Generic1 ZipList where - type Rep1 ZipList = Rep1ZipList - from1 (ZipList z) = M1 (M1 (M1 (Rec1 z))) - to1 (M1 (M1 (M1 (Rec1 z)))) = ZipList z - -data D1ZipList -data C1_0ZipList -data S1_0_0ZipList - -instance Datatype D1ZipList where - datatypeName _ = "ZipList" - moduleName _ = "Control.Applicative" - -instance Constructor C1_0ZipList where - conName _ = "ZipList" - conIsRecord _ = True - -instance Selector S1_0_0ZipList where - selName _ = "getZipList" - ------ - -type Rep0U1 p = D1 D1U1 (C1 C1_0U1 U1) - -instance Generic (U1 p) where - type Rep (U1 p) = Rep0U1 p - from U1 = M1 (M1 U1) - to (M1 (M1 U1)) = U1 - -data D1U1 -data C1_0U1 - -instance Datatype D1U1 where - datatypeName _ = "U1" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0U1 where - conName _ = "U1" - ------ - -type Rep0Par1 p = D1 D1Par1 (C1 C1_0Par1 (S1 S1_0_0Par1 (Rec0 p))) - -instance Generic (Par1 p) where - type Rep (Par1 p) = Rep0Par1 p - from (Par1 p) = M1 (M1 (M1 (K1 p))) - to (M1 (M1 (M1 (K1 p)))) = Par1 p - -data D1Par1 -data C1_0Par1 -data S1_0_0Par1 - -instance Datatype D1Par1 where - datatypeName _ = "Par1" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0Par1 where - conName _ = "Par1" - conIsRecord _ = True - -instance Selector S1_0_0Par1 where - selName _ = "unPar1" - ------ - -type Rep0Rec1 f p = D1 D1Rec1 (C1 C1_0Rec1 (S1 S1_0_0Rec1 (Rec0 (f p)))) - -instance Generic (Rec1 f p) where - type Rep (Rec1 f p) = Rep0Rec1 f p - from (Rec1 r) = M1 (M1 (M1 (K1 r))) - to (M1 (M1 (M1 (K1 r)))) = Rec1 r - -data D1Rec1 -data C1_0Rec1 -data S1_0_0Rec1 - -instance Datatype D1Rec1 where - datatypeName _ = "Rec1" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0Rec1 where - conName _ = "Rec1" - conIsRecord _ = True - -instance Selector S1_0_0Rec1 where - selName _ = "unRec1" - ------ - -type Rep0K1 i c p = D1 D1K1 (C1 C1_0K1 (S1 S1_0_0K1 (Rec0 c))) - -instance Generic (K1 i c p) where - type Rep (K1 i c p) = Rep0K1 i c p - from (K1 c) = M1 (M1 (M1 (K1 c))) - to (M1 (M1 (M1 (K1 c)))) = K1 c - -data D1K1 -data C1_0K1 -data S1_0_0K1 - -instance Datatype D1K1 where - datatypeName _ = "K1" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0K1 where - conName _ = "K1" - conIsRecord _ = True - -instance Selector S1_0_0K1 where - selName _ = "unK1" - ------ - -type Rep0M1 i c f p = D1 D1M1 (C1 C1_0M1 (S1 S1_0_0M1 (Rec0 (f p)))) - -instance Generic (M1 i c f p) where - type Rep (M1 i c f p) = Rep0M1 i c f p - from (M1 m) = M1 (M1 (M1 (K1 m))) - to (M1 (M1 (M1 (K1 m)))) = M1 m - -data D1M1 -data C1_0M1 -data S1_0_0M1 - -instance Datatype D1M1 where - datatypeName _ = "M1" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0M1 where - conName _ = "M1" - conIsRecord _ = True - -instance Selector S1_0_0M1 where - selName _ = "unM1" - ------ - -type Rep0ConSum f g p = D1 D1ConSum (C1 C1_0ConSum (S1 NoSelector (Rec0 (f p))) - :+: C1 C1_1ConSum (S1 NoSelector (Rec0 (g p)))) - -instance Generic ((f :+: g) p) where - type Rep ((f :+: g) p) = Rep0ConSum f g p - - from (L1 l) = M1 (L1 (M1 (M1 (K1 l)))) - from (R1 r) = M1 (R1 (M1 (M1 (K1 r)))) - - to (M1 (L1 (M1 (M1 (K1 l))))) = L1 l - to (M1 (R1 (M1 (M1 (K1 r))))) = R1 r - -data D1ConSum -data C1_0ConSum -data C1_1ConSum - -instance Datatype D1ConSum where - datatypeName _ = ":+:" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0ConSum where - conName _ = "L1" - -instance Constructor C1_1ConSum where - conName _ = "R1" - ------ - -type Rep0ConProduct f g p = - D1 D1ConProduct (C1 C1_ConProduct (S1 NoSelector (Rec0 (f p)) - :*: S1 NoSelector (Rec0 (g p)))) - -instance Generic ((f :*: g) p) where - type Rep ((f :*: g) p) = Rep0ConProduct f g p - from (f :*: g) = M1 (M1 (M1 (K1 f) :*: M1 (K1 g))) - to (M1 (M1 (M1 (K1 f) :*: M1 (K1 g)))) = f :*: g - -data D1ConProduct -data C1_ConProduct - -instance Datatype D1ConProduct where - datatypeName _ = ":*:" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_ConProduct where - conName _ = ":*:" - conFixity _ = Infix RightAssociative 6 - ------ - -type Rep0ConCompose f g p = - D1 D1ConCompose (C1 C1_0ConCompose (S1 S1_0_0ConCompose (Rec0 (f (g p))))) - -instance Generic ((f :.: g) p) where - type Rep ((f :.: g) p) = Rep0ConCompose f g p - from (Comp1 c) = M1 (M1 (M1 (K1 c))) - to (M1 (M1 (M1 (K1 c)))) = Comp1 c - -data D1ConCompose -data C1_0ConCompose -data S1_0_0ConCompose - -instance Datatype D1ConCompose where - datatypeName _ = ":.:" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0ConCompose where - conName _ = "Comp1" - conIsRecord _ = True - -instance Selector S1_0_0ConCompose where - selName _ = "unComp1" -#endif - ------ - -#if __GLASGOW_HASKELL__ < 705 -type Rep1List = D1 D1List (C1 C1_0List U1 :+: - C1 C1_1List (S1 NoSelector Par1 - :*: S1 NoSelector (Rec1 []))) - -instance Generic1 [] where - type Rep1 [] = Rep1List - - from1 [] = M1 (L1 (M1 U1)) - from1 (h:t) = M1 (R1 (M1 (M1 (Par1 h) :*: M1 (Rec1 t)))) - - to1 (M1 (L1 (M1 U1))) = [] - to1 (M1 (R1 (M1 (M1 (Par1 h) :*: M1 (Rec1 t))))) = h : t - -data D1List -data C1_0List -data C1_1List - -instance Datatype D1List where - datatypeName _ = "[]" - moduleName _ = "GHC.Types" - -instance Constructor C1_0List where - conName _ = "[]" - -instance Constructor C1_1List where - conName _ = ":" - conFixity _ = Infix RightAssociative 5 - ------ - -type Rep1Either a = D1 D1Either (C1 C1_0Either (S1 NoSelector (Rec0 a)) - :+: C1 C1_1Either (S1 NoSelector Par1)) - -instance Generic1 (Either a) where - type Rep1 (Either a) = Rep1Either a - - from1 (Left l) = M1 (L1 (M1 (M1 (K1 l)))) - from1 (Right r) = M1 (R1 (M1 (M1 (Par1 r)))) - - to1 (M1 (L1 (M1 (M1 (K1 l))))) = Left l - to1 (M1 (R1 (M1 (M1 (Par1 r))))) = Right r - -data D1Either -data C1_0Either -data C1_1Either - -instance Datatype D1Either where - datatypeName _ = "Either" - moduleName _ = "Data.Either" - -instance Constructor C1_0Either where - conName _ = "Left" - -instance Constructor C1_1Either where - conName _ = "Right" - ------ - -type Rep1Maybe = D1 D1Maybe (C1 C1_0Maybe U1 - :+: C1 C1_1Maybe (S1 NoSelector Par1)) - -instance Generic1 Maybe where - type Rep1 Maybe = Rep1Maybe - - from1 Nothing = M1 (L1 (M1 U1)) - from1 (Just j) = M1 (R1 (M1 (M1 (Par1 j)))) - - to1 (M1 (L1 (M1 U1))) = Nothing - to1 (M1 (R1 (M1 (M1 (Par1 j))))) = Just j - -data D1Maybe -data C1_0Maybe -data C1_1Maybe - -instance Datatype D1Maybe where - datatypeName _ = "Maybe" - -- As of base-4.7.0.0, Maybe is actually located in GHC.Base. - -- We don't need to worry about this for the versions of base - -- that this instance is defined for, however. - moduleName _ = "Data.Maybe" - -instance Constructor C1_0Maybe where - conName _ = "Nothing" - -instance Constructor C1_1Maybe where - conName _ = "Just" - ------ - -type Rep1Tuple2 a = D1 D1Tuple2 (C1 C1_0Tuple2 (S1 NoSelector (Rec0 a) - :*: S1 NoSelector Par1)) - -instance Generic1 ((,) a) where - type Rep1 ((,) a) = Rep1Tuple2 a - from1 (a, b) = M1 (M1 (M1 (K1 a) :*: M1 (Par1 b))) - to1 (M1 (M1 (M1 (K1 a) :*: M1 (Par1 b)))) = (a, b) - -data D1Tuple2 -data C1_0Tuple2 - -instance Datatype D1Tuple2 where - datatypeName _ = "(,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple2 where - conName _ = "(,)" - ------ - -type Rep1Tuple3 a b = D1 D1Tuple3 (C1 C1_0Tuple3 (S1 NoSelector (Rec0 a) - :*: (S1 NoSelector (Rec0 b) - :*: S1 NoSelector Par1))) - -instance Generic1 ((,,) a b) where - type Rep1 ((,,) a b) = Rep1Tuple3 a b - from1 (a, b, c) = M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (Par1 c)))) - to1 (M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (Par1 c))))) = (a, b, c) - -data D1Tuple3 -data C1_0Tuple3 - -instance Datatype D1Tuple3 where - datatypeName _ = "(,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple3 where - conName _ = "(,,)" - ------ - -type Rep1Tuple4 a b c = D1 D1Tuple4 (C1 C1_0Tuple4 ((S1 NoSelector (Rec0 a) - :*: S1 NoSelector (Rec0 b)) - :*: (S1 NoSelector (Rec0 c) - :*: S1 NoSelector Par1))) - -instance Generic1 ((,,,) a b c) where - type Rep1 ((,,,) a b c) = Rep1Tuple4 a b c - - from1 (a, b, c, d) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: M1 (Par1 d)))) - - to1 (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: M1 (Par1 d))))) - = (a, b, c, d) - -data D1Tuple4 -data C1_0Tuple4 - -instance Datatype D1Tuple4 where - datatypeName _ = "(,,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple4 where - conName _ = "(,,,)" - ------ - -type Rep1Tuple5 a b c d = D1 D1Tuple5 (C1 C1_0Tuple5 ((S1 NoSelector (Rec0 a) - :*: S1 NoSelector (Rec0 b)) - :*: (S1 NoSelector (Rec0 c) - :*: (S1 NoSelector (Rec0 d) - :*: S1 NoSelector Par1)))) - -instance Generic1 ((,,,,) a b c d) where - type Rep1 ((,,,,) a b c d) = Rep1Tuple5 a b c d - - from1 (a, b, c, d, e) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (Par1 e))))) - - to1 (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (Par1 e)))))) - = (a, b, c, d, e) - -data D1Tuple5 -data C1_0Tuple5 - -instance Datatype D1Tuple5 where - datatypeName _ = "(,,,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple5 where - conName _ = "(,,,,)" - ------ - -type Rep1Tuple6 a b c d e = - D1 D1Tuple6 (C1 C1_0Tuple6 ((S1 NoSelector (Rec0 a) - :*: (S1 NoSelector (Rec0 b) - :*: S1 NoSelector (Rec0 c))) - :*: (S1 NoSelector (Rec0 d) - :*: (S1 NoSelector (Rec0 e) - :*: S1 NoSelector Par1)))) - -instance Generic1 ((,,,,,) a b c d e) where - type Rep1 ((,,,,,) a b c d e) = Rep1Tuple6 a b c d e - - from1 (a, b, c, d, e, f) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (Par1 f))))) - - to1 (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (Par1 f)))))) - = (a, b, c, d, e, f) - -data D1Tuple6 -data C1_0Tuple6 - -instance Datatype D1Tuple6 where - datatypeName _ = "(,,,,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple6 where - conName _ = "(,,,,,)" - ------ - -type Rep1Tuple7 a b c d e f = - D1 D1Tuple7 (C1 C1_0Tuple7 ((S1 NoSelector (Rec0 a) - :*: (S1 NoSelector (Rec0 b) - :*: S1 NoSelector (Rec0 c))) - :*: ((S1 NoSelector (Rec0 d) - :*: S1 NoSelector (Rec0 e)) - :*: (S1 NoSelector (Rec0 f) - :*: S1 NoSelector Par1)))) - -instance Generic1 ((,,,,,,) a b c d e f) where - type Rep1 ((,,,,,,) a b c d e f) = Rep1Tuple7 a b c d e f - - from1 (a, b, c, d, e, f, g) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (Par1 g))))) - - to1 (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (Par1 g)))))) - = (a, b, c, d, e, f, g) - -data D1Tuple7 -data C1_0Tuple7 - -instance Datatype D1Tuple7 where - datatypeName _ = "(,,,,,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple7 where - conName _ = "(,,,,,,)" -#endif - ------ - -#if __GLASGOW_HASKELL__ < 701 -type Rep0Bool = D1 D1Bool (C1 C1_0Bool U1 :+: C1 C1_1Bool U1) - -instance Generic Bool where - type Rep Bool = Rep0Bool - - from False = M1 (L1 (M1 U1)) - from True = M1 (R1 (M1 U1)) - - to (M1 (L1 (M1 U1))) = False - to (M1 (R1 (M1 U1))) = True - -data D1Bool -data C1_0Bool -data C1_1Bool - -instance Datatype D1Bool where - datatypeName _ = "Bool" - moduleName _ = "GHC.Bool" - -instance Constructor C1_0Bool where - conName _ = "False" - -instance Constructor C1_1Bool where - conName _ = "True" - ------ - -data D_Char -data C_Char - -instance Datatype D_Char where - datatypeName _ = "Char" - moduleName _ = "GHC.Base" - -instance Constructor C_Char where - conName _ = "" -- JPM: I'm not sure this is the right implementation... - -type Rep0Char = D1 D_Char (C1 C_Char (S1 NoSelector (Rec0 Char))) - -instance Generic Char where - type Rep Char = Rep0Char - from x = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = x - ------ - -data D_Double -data C_Double - -instance Datatype D_Double where - datatypeName _ = "Double" - moduleName _ = "GHC.Float" - -instance Constructor C_Double where - conName _ = "" -- JPM: I'm not sure this is the right implementation... - -type Rep0Double = D1 D_Double (C1 C_Double (S1 NoSelector (Rec0 Double))) - -instance Generic Double where - type Rep Double = Rep0Double - from x = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = x - ------ - -type Rep0Either a b = D1 D1Either (C1 C1_0Either (S1 NoSelector (Rec0 a)) - :+: C1 C1_1Either (S1 NoSelector (Rec0 b))) - -instance Generic (Either a b) where - type Rep (Either a b) = Rep0Either a b - - from (Left l) = M1 (L1 (M1 (M1 (K1 l)))) - from (Right r) = M1 (R1 (M1 (M1 (K1 r)))) - - to (M1 (L1 (M1 (M1 (K1 l))))) = Left l - to (M1 (R1 (M1 (M1 (K1 r))))) = Right r - ------ - -data D_Int -data C_Int - -instance Datatype D_Int where - datatypeName _ = "Int" - moduleName _ = "GHC.Int" - -instance Constructor C_Int where - conName _ = "" -- JPM: I'm not sure this is the right implementation... - -type Rep0Int = D1 D_Int (C1 C_Int (S1 NoSelector (Rec0 Int))) - -instance Generic Int where - type Rep Int = Rep0Int - from x = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = x - ------ - -data D_Float -data C_Float - -instance Datatype D_Float where - datatypeName _ = "Float" - moduleName _ = "GHC.Float" - -instance Constructor C_Float where - conName _ = "" -- JPM: I'm not sure this is the right implementation... - -type Rep0Float = D1 D_Float (C1 C_Float (S1 NoSelector (Rec0 Float))) - -instance Generic Float where - type Rep Float = Rep0Float - from x = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = x - ------ - -type Rep0List a = - D1 D1List (C1 C1_0List U1 :+: C1 C1_1List (S1 NoSelector (Rec0 a) - :*: S1 NoSelector (Rec0 [a]))) - -instance Generic [a] where - type Rep [a] = Rep0List a - - from [] = M1 (L1 (M1 U1)) - from (h:t) = M1 (R1 (M1 (M1 (K1 h) :*: M1 (K1 t)))) - - to (M1 (L1 (M1 U1))) = [] - to (M1 (R1 (M1 (M1 (K1 h) :*: M1 (K1 t))))) = h : t - ------ - -type Rep0Maybe a = D1 D1Maybe (C1 C1_0Maybe U1 - :+: C1 C1_1Maybe (S1 NoSelector (Rec0 a))) - -instance Generic (Maybe a) where - type Rep (Maybe a) = Rep0Maybe a - - from Nothing = M1 (L1 (M1 U1)) - from (Just j) = M1 (R1 (M1 (M1 (K1 j)))) - - to (M1 (L1 (M1 U1))) = Nothing - to (M1 (R1 (M1 (M1 (K1 j))))) = Just j - ------ - -type Rep0Ordering = D1 D1Ordering (C1 C1_0Ordering U1 - :+: (C1 C1_1Ordering U1 :+: C1 C1_2Ordering U1)) - -instance Generic Ordering where - type Rep Ordering = Rep0Ordering - - from LT = M1 (L1 (M1 U1)) - from EQ = M1 (R1 (L1 (M1 U1))) - from GT = M1 (R1 (R1 (M1 U1))) - - to (M1 (L1 (M1 U1))) = LT - to (M1 (R1 (L1 (M1 U1)))) = EQ - to (M1 (R1 (R1 (M1 U1)))) = GT - -data D1Ordering -data C1_0Ordering -data C1_1Ordering -data C1_2Ordering - -instance Datatype D1Ordering where - datatypeName _ = "Ordering" - moduleName _ = "GHC.Ordering" - -instance Constructor C1_0Ordering where - conName _ = "LT" - -instance Constructor C1_1Ordering where - conName _ = "EQ" - -instance Constructor C1_2Ordering where - conName _ = "GT" - ------ - -type Rep0Unit = D1 D1Unit (C1 C1_0Unit U1) - -instance Generic () where - type Rep () = Rep0Unit - from () = M1 (M1 U1) - to (M1 (M1 U1)) = () - -data D1Unit -data C1_0Unit - -instance Datatype D1Unit where - datatypeName _ = "()" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Unit where - conName _ = "()" - ------ - -type Rep0Tuple2 a b = D1 D1Tuple2 (C1 C1_0Tuple2 (S1 NoSelector (Rec0 a) - :*: S1 NoSelector (Rec0 b))) - -instance Generic (a, b) where - type Rep (a, b) = Rep0Tuple2 a b - from (a, b) = M1 (M1 (M1 (K1 a) :*: M1 (K1 b))) - to (M1 (M1 (M1 (K1 a) :*: M1 (K1 b)))) = (a, b) - ------ - -type Rep0Tuple3 a b c = D1 D1Tuple3 (C1 C1_0Tuple3 (S1 NoSelector (Rec0 a) - :*: (S1 NoSelector (Rec0 b) - :*: S1 NoSelector (Rec0 c)))) - -instance Generic (a, b, c) where - type Rep (a, b, c) = Rep0Tuple3 a b c - from (a, b, c) = M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c)))) - to (M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))))) = (a, b, c) - ------ - -type Rep0Tuple4 a b c d = D1 D1Tuple4 (C1 C1_0Tuple4 ((S1 NoSelector (Rec0 a) - :*: S1 NoSelector (Rec0 b)) - :*: (S1 NoSelector (Rec0 c) - :*: S1 NoSelector (Rec0 d)))) - -instance Generic (a, b, c, d) where - type Rep (a, b, c, d) = Rep0Tuple4 a b c d - - from (a, b, c, d) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: M1 (K1 d)))) - - to (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: M1 (K1 d))))) - = (a, b, c, d) - ------ - -type Rep0Tuple5 a b c d e = D1 D1Tuple5 (C1 C1_0Tuple5 ((S1 NoSelector (Rec0 a) - :*: S1 NoSelector (Rec0 b)) - :*: (S1 NoSelector (Rec0 c) - :*: (S1 NoSelector (Rec0 d) - :*: S1 NoSelector (Rec0 e))))) - -instance Generic (a, b, c, d, e) where - type Rep (a, b, c, d, e) = Rep0Tuple5 a b c d e - - from (a, b, c, d, e) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (K1 e))))) - - to (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (K1 e)))))) - = (a, b, c, d, e) - ------ - -type Rep0Tuple6 a b c d e f = D1 D1Tuple6 (C1 C1_0Tuple6 ((S1 NoSelector (Rec0 a) - :*: (S1 NoSelector (Rec0 b) - :*: S1 NoSelector (Rec0 c))) - :*: (S1 NoSelector (Rec0 d) - :*: (S1 NoSelector (Rec0 e) - :*: S1 NoSelector (Rec0 f))))) - -instance Generic (a, b, c, d, e, f) where - type Rep (a, b, c, d, e, f) = Rep0Tuple6 a b c d e f - - from (a, b, c, d, e, f) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (K1 f))))) - - to (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (K1 f)))))) - = (a, b, c, d, e, f) - ------ - -type Rep0Tuple7 a b c d e f g - = D1 D1Tuple7 (C1 C1_0Tuple7 ((S1 NoSelector (Rec0 a) - :*: (S1 NoSelector (Rec0 b) - :*: S1 NoSelector (Rec0 c))) - :*: ((S1 NoSelector (Rec0 d) - :*: S1 NoSelector (Rec0 e)) - :*: (S1 NoSelector (Rec0 f) - :*: S1 NoSelector (Rec0 g))))) - -instance Generic (a, b, c, d, e, f, g) where - type Rep (a, b, c, d, e, f, g) = Rep0Tuple7 a b c d e f g - - from (a, b, c, d, e, f, g) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (K1 g))))) - - to (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (K1 g)))))) - = (a, b, c, d, e, f, g) - -#endif +{-# LANGUAGE CPP #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Generics.Deriving.Instances (+-- Only instances from Generics.Deriving.Base+-- and the Generic1 instances+#if __GLASGOW_HASKELL__ < 711+ Rep0ExitCode+ , Rep0UAddr+ , Rep0UChar+ , Rep0UDouble+ , Rep0UFloat+ , Rep0UInt+ , Rep0UWord+ , Rep0Version+# if __GLASGOW_HASKELL__ >= 701+ , Rep0Complex+ , Rep1Complex+# endif+# if __GLASGOW_HASKELL__ >= 707+ , Rep1Proxy+# endif+#endif+#if __GLASGOW_HASKELL__ < 708+ , Rep0All+ , Rep0Any+ , Rep0Arity+ , Rep0Associativity+ , Rep0Const+ , Rep1Const+ , Rep0Dual+ , Rep1Dual+ , Rep0Endo+ , Rep0First+ , Rep1First+ , Rep0Fixity+ , Rep0Last+ , Rep1Last+ , Rep0Product+ , Rep1Product+ , Rep0Sum+ , Rep1Sum+ , Rep0WrappedArrow+ , Rep1WrappedArrow+ , Rep0WrappedMonad+ , Rep1WrappedMonad+ , Rep0ZipList+ , Rep1ZipList+ , Rep0U1+ , Rep0Par1+ , Rep0Rec1+ , Rep0K1+ , Rep0M1+ , Rep0ConSum+ , Rep0ConProduct+ , Rep0ConCompose+#endif+#if __GLASGOW_HASKELL__ < 705+ , Rep1Either+ , Rep1List+ , Rep1Maybe+ , Rep1Tuple2+ , Rep1Tuple3+ , Rep1Tuple4+ , Rep1Tuple5+ , Rep1Tuple6+ , Rep1Tuple7+#endif+#if __GLASGOW_HASKELL__ < 701+ -- * Representations for base types+ , Rep0Bool+ , Rep0Char+ , Rep0Double+ , Rep0Either+ , Rep0Int+ , Rep0Float+ , Rep0List+ , Rep0Maybe+ , Rep0Ordering+ , Rep0Tuple2+ , Rep0Tuple3+ , Rep0Tuple4+ , Rep0Tuple5+ , Rep0Tuple6+ , Rep0Tuple7+ , Rep0Unit+#endif+ ) where++#if __GLASGOW_HASKELL__ < 708+import Control.Applicative+import Data.Monoid+#endif++#if __GLASGOW_HASKELL__ >= 701 && __GLASGOW_HASKELL__ < 711+import Data.Complex (Complex(..))+#endif++#if __GLASGOW_HASKELL__ >= 707 && __GLASGOW_HASKELL__ < 711+import Data.Proxy (Proxy(..))+#endif++#if __GLASGOW_HASKELL__ < 711+import Data.Version (Version(..))+import Generics.Deriving.Base+import System.Exit (ExitCode(..))+#endif++#if __GLASGOW_HASKELL__ < 711+type Rep0ExitCode = D1 D1ExitCode (C1 C1_0ExitCode U1+ :+: C1 C1_1ExitCode (S1 NoSelector (Rec0 Int)))++instance Generic ExitCode where+ type Rep ExitCode = Rep0ExitCode+ from ExitSuccess = M1 (L1 (M1 U1))+ from (ExitFailure g) = M1 (R1 (M1 (M1 (K1 g))))+ to (M1 (L1 (M1 U1))) = ExitSuccess+ to (M1 (R1 (M1 (M1 (K1 g))))) = ExitFailure g++data D1ExitCode+data C1_0ExitCode+data C1_1ExitCode++instance Datatype D1ExitCode where+ datatypeName _ = "ExitCode"+ moduleName _ = "GHC.IO.Exception"++instance Constructor C1_0ExitCode where+ conName _ = "ExitSuccess"++instance Constructor C1_1ExitCode where+ conName _ = "ExitFailure"++-----++type Rep0UAddr p = D1 D1UAddr (C1 C1_0UAddr (S1 S1_0_0UAddr UAddr))++instance Generic (UAddr p) where+ type Rep (UAddr p) = Rep0UAddr p+ from (UAddr a) = M1 (M1 (M1 (UAddr a)))+ to (M1 (M1 (M1 (UAddr a)))) = UAddr a++data D1UAddr+data C1_0UAddr+data S1_0_0UAddr++instance Datatype D1UAddr where+ datatypeName _ = "UAddr"+ moduleName _ = "Generics.Deriving.Base"++instance Constructor C1_0UAddr where+ conName _ = "UAddr"+ conIsRecord _ = True++instance Selector S1_0_0UAddr where+ selName _ = "uAddr#"++-----++type Rep0UChar p = D1 D1UChar (C1 C1_0UChar (S1 S1_0_0UChar UChar))++instance Generic (UChar p) where+ type Rep (UChar p) = Rep0UChar p+ from (UChar c) = M1 (M1 (M1 (UChar c)))+ to (M1 (M1 (M1 (UChar c)))) = UChar c++data D1UChar+data C1_0UChar+data S1_0_0UChar++instance Datatype D1UChar where+ datatypeName _ = "UChar"+ moduleName _ = "Generics.Deriving.Base"++instance Constructor C1_0UChar where+ conName _ = "UChar"+ conIsRecord _ = True++instance Selector S1_0_0UChar where+ selName _ = "uChar#"++-----++type Rep0UDouble p = D1 D1UDouble (C1 C1_0UDouble (S1 S1_0_0UDouble UDouble))++instance Generic (UDouble p) where+ type Rep (UDouble p) = Rep0UDouble p+ from (UDouble d) = M1 (M1 (M1 (UDouble d)))+ to (M1 (M1 (M1 (UDouble d)))) = UDouble d++data D1UDouble+data C1_0UDouble+data S1_0_0UDouble++instance Datatype D1UDouble where+ datatypeName _ = "UDouble"+ moduleName _ = "Generics.Deriving.Base"++instance Constructor C1_0UDouble where+ conName _ = "UDouble"+ conIsRecord _ = True++instance Selector S1_0_0UDouble where+ selName _ = "uDouble#"++-----++type Rep0UFloat p = D1 D1UFloat (C1 C1_0UFloat (S1 S1_0_0UFloat UFloat))++instance Generic (UFloat p) where+ type Rep (UFloat p) = Rep0UFloat p+ from (UFloat f) = M1 (M1 (M1 (UFloat f)))+ to (M1 (M1 (M1 (UFloat f)))) = UFloat f++data D1UFloat+data C1_0UFloat+data S1_0_0UFloat++instance Datatype D1UFloat where+ datatypeName _ = "UFloat"+ moduleName _ = "Generics.Deriving.Base"++instance Constructor C1_0UFloat where+ conName _ = "UFloat"+ conIsRecord _ = True++instance Selector S1_0_0UFloat where+ selName _ = "uFloat#"++-----++type Rep0UInt p = D1 D1UInt (C1 C1_0UInt (S1 S1_0_0UInt UInt))++instance Generic (UInt p) where+ type Rep (UInt p) = Rep0UInt p+ from (UInt i) = M1 (M1 (M1 (UInt i)))+ to (M1 (M1 (M1 (UInt i)))) = UInt i++data D1UInt+data C1_0UInt+data S1_0_0UInt++instance Datatype D1UInt where+ datatypeName _ = "UInt"+ moduleName _ = "Generics.Deriving.Base"++instance Constructor C1_0UInt where+ conName _ = "UInt"+ conIsRecord _ = True++instance Selector S1_0_0UInt where+ selName _ = "uInt#"++-----++type Rep0UWord p = D1 D1UWord (C1 C1_0UWord (S1 S1_0_0UWord UWord))++instance Generic (UWord p) where+ type Rep (UWord p) = Rep0UWord p+ from (UWord w) = M1 (M1 (M1 (UWord w)))+ to (M1 (M1 (M1 (UWord w)))) = UWord w++data D1UWord+data C1_0UWord+data S1_0_0UWord++instance Datatype D1UWord where+ datatypeName _ = "UWord"+ moduleName _ = "Generics.Deriving.Base"++instance Constructor C1_0UWord where+ conName _ = "UWord"+ conIsRecord _ = True++instance Selector S1_0_0UWord where+ selName _ = "uWord#"++-----++type Rep0Version = D1 D1Version (C1 C1_0Version (S1 S1_0_0Version (Rec0 [Int])+ :*: S1 S1_0_1Version (Rec0 [String])))++instance Generic Version where+ type Rep Version = Rep0Version+ from (Version b t) = M1 (M1 (M1 (K1 b) :*: M1 (K1 t)))+ to (M1 (M1 (M1 (K1 b) :*: M1 (K1 t)))) = Version b t++data D1Version+data C1_0Version+data S1_0_0Version+data S1_0_1Version++instance Datatype D1Version where+ datatypeName _ = "Version"+ moduleName _ = "Data.Version"++instance Constructor C1_0Version where+ conName _ = "Version"+ conIsRecord _ = True++instance Selector S1_0_0Version where+ selName _ = "versionBranch"++instance Selector S1_0_1Version where+ selName _ = "versionTags"++-----++# if __GLASGOW_HASKELL__ >= 701+type Rep0Complex a = D1 D1Complex (C1 C1_0Complex (S1 NoSelector (Rec0 a)+ :*: S1 NoSelector (Rec0 a)))+type Rep1Complex = D1 D1Complex (C1 C1_0Complex (S1 NoSelector Par1+ :*: S1 NoSelector Par1))++instance Generic (Complex a) where+ type Rep (Complex a) = Rep0Complex a+ from (a :+ b) = M1 (M1 (M1 (K1 a) :*: M1 (K1 b)))+ to (M1 (M1 (M1 (K1 a) :*: M1 (K1 b)))) = a :+ b++instance Generic1 Complex where+ type Rep1 Complex = Rep1Complex+ from1 (a :+ b) = M1 (M1 (M1 (Par1 a) :*: M1 (Par1 b)))+ to1 (M1 (M1 (M1 a :*: M1 b))) = unPar1 a :+ unPar1 b++data D1Complex+data C1_0Complex++instance Datatype D1Complex where+ datatypeName _ = "Complex"+ moduleName _ = "Data.Complex"++instance Constructor C1_0Complex where+ conName _ = ":+"+ conFixity _ = Infix LeftAssociative 9+# endif++-----++# if __GLASGOW_HASKELL__ >= 707+type Rep1Proxy = D1 D1Proxy (C1 C1_0Proxy U1)++instance Generic1 Proxy where+ type Rep1 Proxy = Rep1Proxy+ from1 Proxy = M1 (M1 U1)+ to1 (M1 (M1 U1)) = Proxy++data D1Proxy+data C1_0Proxy++instance Datatype D1Proxy where+ datatypeName _ = "Proxy"+ moduleName _ = "Data.Proxy"++instance Constructor C1_0Proxy where+ conName _ = "Proxy"+# endif+#endif++-----++#if __GLASGOW_HASKELL__ < 708+--------------------------------------------------------------------------------+-- Representations for base types+--------------------------------------------------------------------------------++type Rep0All = D1 D1All (C1 C1_0All (S1 S1_0_0All (Rec0 Bool)))++instance Generic All where+ type Rep All = Rep0All+ from (All a) = M1 (M1 (M1 (K1 a)))+ to (M1 (M1 (M1 (K1 a)))) = All a++data D1All+data C1_0All+data S1_0_0All++instance Datatype D1All where+ datatypeName _ = "All"+ moduleName _ = "Data.Monoid"++instance Constructor C1_0All where+ conName _ = "All"+ conIsRecord _ = True++instance Selector S1_0_0All where+ selName _ = "getAll"++-----++type Rep0Any = D1 D1Any (C1 C1_0Any (S1 S1_0_0Any (Rec0 Bool)))++instance Generic Any where+ type Rep Any = Rep0Any+ from (Any a) = M1 (M1 (M1 (K1 a)))+ to (M1 (M1 (M1 (K1 a)))) = Any a++data D1Any+data C1_0Any+data S1_0_0Any++instance Datatype D1Any where+ datatypeName _ = "Any"+ moduleName _ = "Data.Monoid"++instance Constructor C1_0Any where+ conName _ = "Any"+ conIsRecord _ = True++instance Selector S1_0_0Any where+ selName _ = "getAny"++-----++type Rep0Arity = D1 D1Arity (C1 C1_0Arity U1+ :+: C1 C1_1Arity (S1 NoSelector (Rec0 Int)))++instance Generic Arity where+ type Rep Arity = Rep0Arity++ from NoArity = M1 (L1 (M1 U1))+ from (Arity a) = M1 (R1 (M1 (M1 (K1 a))))++ to (M1 (L1 (M1 U1))) = NoArity+ to (M1 (R1 (M1 (M1 (K1 a))))) = Arity a++data D1Arity+data C1_0Arity+data C1_1Arity++instance Datatype D1Arity where+ datatypeName _ = "Arity"+# if __GLASGOW_HASKELL__ < 701+ moduleName _ = "Generics.Deriving.Base"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_0Arity where+ conName _ = "NoArity"++instance Constructor C1_1Arity where+ conName _ = "Arity"++-----++type Rep0Associativity = D1 D1Associativity (C1 C1_0Associativity U1+ :+: (C1 C1_1Associativity U1+ :+: C1 C1_2Associativity U1))++instance Generic Associativity where+ type Rep Associativity = Rep0Associativity++ from LeftAssociative = M1 (L1 (M1 U1))+ from RightAssociative = M1 (R1 (L1 (M1 U1)))+ from NotAssociative = M1 (R1 (R1 (M1 U1)))++ to (M1 (L1 (M1 U1))) = LeftAssociative+ to (M1 (R1 (L1 (M1 U1)))) = RightAssociative+ to (M1 (R1 (R1 (M1 U1)))) = NotAssociative++data D1Associativity+data C1_0Associativity+data C1_1Associativity+data C1_2Associativity++instance Datatype D1Associativity where+ datatypeName _ = "Associativity"+# if __GLASGOW_HASKELL__ < 701+ moduleName _ = "Generics.Deriving.Base"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_0Associativity where+ conName _ = "LeftAssociative"++instance Constructor C1_1Associativity where+ conName _ = "RightAssociative"++instance Constructor C1_2Associativity where+ conName _ = "NotAssociative"++-----++type Rep0Const a b = D1 D1Const (C1 C1_0Const (S1 S1_0_0Const (Rec0 a)))+type Rep1Const a = D1 D1Const (C1 C1_0Const (S1 S1_0_0Const (Rec0 a)))++instance Generic (Const a b) where+ type Rep (Const a b) = Rep0Const a b+ from (Const a) = M1 (M1 (M1 (K1 a)))+ to (M1 (M1 (M1 (K1 a)))) = Const a++instance Generic1 (Const a) where+ type Rep1 (Const a) = Rep1Const a+ from1 (Const a) = M1 (M1 (M1 (K1 a)))+ to1 (M1 (M1 (M1 (K1 a)))) = Const a++data D1Const+data C1_0Const+data S1_0_0Const++instance Datatype D1Const where+ datatypeName _ = "Const"+ moduleName _ = "Control.Applicative"++instance Constructor C1_0Const where+ conName _ = "Const"+ conIsRecord _ = True++instance Selector S1_0_0Const where+ selName _ = "getConst"++-----++type Rep0Dual a = D1 D1Dual (C1 C1_0Dual (S1 S1_0_0Dual (Rec0 a)))+type Rep1Dual = D1 D1Dual (C1 C1_0Dual (S1 S1_0_0Dual Par1))++instance Generic (Dual a) where+ type Rep (Dual a) = Rep0Dual a+ from (Dual d) = M1 (M1 (M1 (K1 d)))+ to (M1 (M1 (M1 (K1 d)))) = Dual d++instance Generic1 Dual where+ type Rep1 Dual = Rep1Dual+ from1 (Dual d) = M1 (M1 (M1 (Par1 d)))+ to1 (M1 (M1 (M1 (Par1 d)))) = Dual d++data D1Dual+data C1_0Dual+data S1_0_0Dual++instance Datatype D1Dual where+ datatypeName _ = "Dual"+ moduleName _ = "Data.Monoid"++instance Constructor C1_0Dual where+ conName _ = "Dual"+ conIsRecord _ = True++instance Selector S1_0_0Dual where+ selName _ = "getDual"++-----++type Rep0Endo a = D1 D1Endo (C1 C1_0Endo (S1 S1_0_0Endo (Rec0 (a -> a))))++instance Generic (Endo a) where+ type Rep (Endo a) = Rep0Endo a+ from (Endo e) = M1 (M1 (M1 (K1 e)))+ to (M1 (M1 (M1 (K1 e)))) = Endo e++data D1Endo+data C1_0Endo+data S1_0_0Endo++instance Datatype D1Endo where+ datatypeName _ = "Endo"+ moduleName _ = "Data.Monoid"++instance Constructor C1_0Endo where+ conName _ = "Endo"+ conIsRecord _ = True++instance Selector S1_0_0Endo where+ selName _ = "appEndo"++-----++type Rep0First a = D1 D1First (C1 C1_0First (S1 S1_0_0First (Rec0 (Maybe a))))+type Rep1First = D1 D1First (C1 C1_0First (S1 S1_0_0First (Rec1 Maybe)))++instance Generic (First a) where+ type Rep (First a) = Rep0First a+ from (First f) = M1 (M1 (M1 (K1 f)))+ to (M1 (M1 (M1 (K1 f)))) = First f++instance Generic1 First where+ type Rep1 First = Rep1First+ from1 (First f) = M1 (M1 (M1 (Rec1 f)))+ to1 (M1 (M1 (M1 (Rec1 f)))) = First f++data D1First+data C1_0First+data S1_0_0First++instance Datatype D1First where+ datatypeName _ = "First"+ moduleName _ = "Data.Monoid"++instance Constructor C1_0First where+ conName _ = "First"+ conIsRecord _ = True++instance Selector S1_0_0First where+ selName _ = "getFirst"++-----++type Rep0Fixity = D1 D1Fixity (C1 C1_0Fixity U1+ :+: C1 C1_1Fixity (S1 NoSelector (Rec0 Associativity)+ :*: S1 NoSelector (Rec0 Int)))++instance Generic Fixity where+ type Rep Fixity = Rep0Fixity++ from Prefix = M1 (L1 (M1 U1))+ from (Infix a i) = M1 (R1 (M1 (M1 (K1 a) :*: M1 (K1 i))))++ to (M1 (L1 (M1 U1))) = Prefix+ to (M1 (R1 (M1 (M1 (K1 a) :*: M1 (K1 i))))) = Infix a i++data D1Fixity+data C1_0Fixity+data C1_1Fixity++instance Datatype D1Fixity where+ datatypeName _ = "Fixity"+# if __GLASGOW_HASKELL__ < 701+ moduleName _ = "Generics.Deriving.Base"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_0Fixity where+ conName _ = "Prefix"++instance Constructor C1_1Fixity where+ conName _ = "Infix"++-----++type Rep0Last a = D1 D1Last (C1 C1_0Last (S1 S1_0_0Last (Rec0 (Maybe a))))+type Rep1Last = D1 D1Last (C1 C1_0Last (S1 S1_0_0Last (Rec1 Maybe)))++instance Generic (Last a) where+ type Rep (Last a) = Rep0Last a+ from (Last l) = M1 (M1 (M1 (K1 l)))+ to (M1 (M1 (M1 (K1 l)))) = Last l++instance Generic1 Last where+ type Rep1 Last = Rep1Last+ from1 (Last l) = M1 (M1 (M1 (Rec1 l)))+ to1 (M1 (M1 (M1 (Rec1 l)))) = Last l++data D1Last+data C1_0Last+data S1_0_0Last++instance Datatype D1Last where+ datatypeName _ = "Last"+ moduleName _ = "Data.Monoid"++instance Constructor C1_0Last where+ conName _ = "Last"+ conIsRecord _ = True++instance Selector S1_0_0Last where+ selName _ = "getLast"++-----++type Rep0Product a = D1 D1Product (C1 C1_0Product (S1 S1_0_0Product (Rec0 a)))+type Rep1Product = D1 D1Product (C1 C1_0Product (S1 S1_0_0Product Par1))++instance Generic (Product a) where+ type Rep (Product a) = Rep0Product a+ from (Product p) = M1 (M1 (M1 (K1 p)))+ to (M1 (M1 (M1 (K1 p)))) = Product p++instance Generic1 Product where+ type Rep1 Product = Rep1Product+ from1 (Product p) = M1 (M1 (M1 (Par1 p)))+ to1 (M1 (M1 (M1 (Par1 p)))) = Product p++data D1Product+data C1_0Product+data S1_0_0Product++instance Datatype D1Product where+ datatypeName _ = "Product"+ moduleName _ = "Data.Monoid"++instance Constructor C1_0Product where+ conName _ = "Product"+ conIsRecord _ = True++instance Selector S1_0_0Product where+ selName _ = "getProduct"++-----++type Rep0Sum a = D1 D1Sum (C1 C1_0Sum (S1 S1_0_0Sum (Rec0 a)))+type Rep1Sum = D1 D1Sum (C1 C1_0Sum (S1 S1_0_0Sum Par1))++instance Generic (Sum a) where+ type Rep (Sum a) = Rep0Sum a+ from (Sum s) = M1 (M1 (M1 (K1 s)))+ to (M1 (M1 (M1 (K1 s)))) = Sum s++instance Generic1 Sum where+ type Rep1 Sum = Rep1Sum+ from1 (Sum s) = M1 (M1 (M1 (Par1 s)))+ to1 (M1 (M1 (M1 (Par1 s)))) = Sum s++data D1Sum+data C1_0Sum+data S1_0_0Sum++instance Datatype D1Sum where+ datatypeName _ = "Sum"+ moduleName _ = "Data.Monoid"++instance Constructor C1_0Sum where+ conName _ = "Sum"+ conIsRecord _ = True++instance Selector S1_0_0Sum where+ selName _ = "getSum"++-----++type Rep0WrappedArrow a b c =+ D1 D1WrappedArrow (C1 C1_0WrappedArrow (S1 S1_0_0WrappedArrow (Rec0 (a b c))))+type Rep1WrappedArrow a b =+ D1 D1WrappedArrow (C1 C1_0WrappedArrow (S1 S1_0_0WrappedArrow (Rec1 (a b))))++instance Generic (WrappedArrow a b c) where+ type Rep (WrappedArrow a b c) = Rep0WrappedArrow a b c+ from (WrapArrow a) = M1 (M1 (M1 (K1 a)))+ to (M1 (M1 (M1 (K1 a)))) = WrapArrow a++instance Generic1 (WrappedArrow a b) where+ type Rep1 (WrappedArrow a b) = Rep1WrappedArrow a b+ from1 (WrapArrow a) = M1 (M1 (M1 (Rec1 a)))+ to1 (M1 (M1 (M1 (Rec1 a)))) = WrapArrow a++data D1WrappedArrow+data C1_0WrappedArrow+data S1_0_0WrappedArrow++instance Datatype D1WrappedArrow where+ datatypeName _ = "WrappedArrow"+ moduleName _ = "Control.Applicative"++instance Constructor C1_0WrappedArrow where+ conName _ = "WrapArrow"+ conIsRecord _ = True++instance Selector S1_0_0WrappedArrow where+ selName _ = "unwrapArrow"++-----++type Rep0WrappedMonad m a =+ D1 D1WrappedMonad (C1 C1_0WrappedMonad (S1 S1_0_0WrappedMonad (Rec0 (m a))))+type Rep1WrappedMonad m =+ D1 D1WrappedMonad (C1 C1_0WrappedMonad (S1 S1_0_0WrappedMonad (Rec1 m)))++instance Generic (WrappedMonad m a) where+ type Rep (WrappedMonad m a) = Rep0WrappedMonad m a+ from (WrapMonad m) = M1 (M1 (M1 (K1 m)))+ to (M1 (M1 (M1 (K1 m)))) = WrapMonad m++instance Generic1 (WrappedMonad m) where+ type Rep1 (WrappedMonad m) = Rep1WrappedMonad m+ from1 (WrapMonad m) = M1 (M1 (M1 (Rec1 m)))+ to1 (M1 (M1 (M1 (Rec1 m)))) = WrapMonad m++data D1WrappedMonad+data C1_0WrappedMonad+data S1_0_0WrappedMonad++instance Datatype D1WrappedMonad where+ datatypeName _ = "WrappedMonad"+ moduleName _ = "Control.Applicative"++instance Constructor C1_0WrappedMonad where+ conName _ = "WrapMonad"+ conIsRecord _ = True++instance Selector S1_0_0WrappedMonad where+ selName _ = "unwrapMonad"++-----++type Rep0ZipList a = D1 D1ZipList (C1 C1_0ZipList (S1 S1_0_0ZipList (Rec0 [a])))+type Rep1ZipList = D1 D1ZipList (C1 C1_0ZipList (S1 S1_0_0ZipList (Rec1 [])))++instance Generic (ZipList a) where+ type Rep (ZipList a) = Rep0ZipList a+ from (ZipList z) = M1 (M1 (M1 (K1 z)))+ to (M1 (M1 (M1 (K1 z)))) = ZipList z++instance Generic1 ZipList where+ type Rep1 ZipList = Rep1ZipList+ from1 (ZipList z) = M1 (M1 (M1 (Rec1 z)))+ to1 (M1 (M1 (M1 (Rec1 z)))) = ZipList z++data D1ZipList+data C1_0ZipList+data S1_0_0ZipList++instance Datatype D1ZipList where+ datatypeName _ = "ZipList"+ moduleName _ = "Control.Applicative"++instance Constructor C1_0ZipList where+ conName _ = "ZipList"+ conIsRecord _ = True++instance Selector S1_0_0ZipList where+ selName _ = "getZipList"++-----++type Rep0U1 p = D1 D1U1 (C1 C1_0U1 U1)++instance Generic (U1 p) where+ type Rep (U1 p) = Rep0U1 p+ from U1 = M1 (M1 U1)+ to (M1 (M1 U1)) = U1++data D1U1+data C1_0U1++instance Datatype D1U1 where+ datatypeName _ = "U1"+# if __GLASGOW_HASKELL__ < 701+ moduleName _ = "Generics.Deriving.Base"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_0U1 where+ conName _ = "U1"++-----++type Rep0Par1 p = D1 D1Par1 (C1 C1_0Par1 (S1 S1_0_0Par1 (Rec0 p)))++instance Generic (Par1 p) where+ type Rep (Par1 p) = Rep0Par1 p+ from (Par1 p) = M1 (M1 (M1 (K1 p)))+ to (M1 (M1 (M1 (K1 p)))) = Par1 p++data D1Par1+data C1_0Par1+data S1_0_0Par1++instance Datatype D1Par1 where+ datatypeName _ = "Par1"+# if __GLASGOW_HASKELL__ < 701+ moduleName _ = "Generics.Deriving.Base"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_0Par1 where+ conName _ = "Par1"+ conIsRecord _ = True++instance Selector S1_0_0Par1 where+ selName _ = "unPar1"++-----++type Rep0Rec1 f p = D1 D1Rec1 (C1 C1_0Rec1 (S1 S1_0_0Rec1 (Rec0 (f p))))++instance Generic (Rec1 f p) where+ type Rep (Rec1 f p) = Rep0Rec1 f p+ from (Rec1 r) = M1 (M1 (M1 (K1 r)))+ to (M1 (M1 (M1 (K1 r)))) = Rec1 r++data D1Rec1+data C1_0Rec1+data S1_0_0Rec1++instance Datatype D1Rec1 where+ datatypeName _ = "Rec1"+# if __GLASGOW_HASKELL__ < 701+ moduleName _ = "Generics.Deriving.Base"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_0Rec1 where+ conName _ = "Rec1"+ conIsRecord _ = True++instance Selector S1_0_0Rec1 where+ selName _ = "unRec1"++-----++type Rep0K1 i c p = D1 D1K1 (C1 C1_0K1 (S1 S1_0_0K1 (Rec0 c)))++instance Generic (K1 i c p) where+ type Rep (K1 i c p) = Rep0K1 i c p+ from (K1 c) = M1 (M1 (M1 (K1 c)))+ to (M1 (M1 (M1 (K1 c)))) = K1 c++data D1K1+data C1_0K1+data S1_0_0K1++instance Datatype D1K1 where+ datatypeName _ = "K1"+# if __GLASGOW_HASKELL__ < 701+ moduleName _ = "Generics.Deriving.Base"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_0K1 where+ conName _ = "K1"+ conIsRecord _ = True++instance Selector S1_0_0K1 where+ selName _ = "unK1"++-----++type Rep0M1 i c f p = D1 D1M1 (C1 C1_0M1 (S1 S1_0_0M1 (Rec0 (f p))))++instance Generic (M1 i c f p) where+ type Rep (M1 i c f p) = Rep0M1 i c f p+ from (M1 m) = M1 (M1 (M1 (K1 m)))+ to (M1 (M1 (M1 (K1 m)))) = M1 m++data D1M1+data C1_0M1+data S1_0_0M1++instance Datatype D1M1 where+ datatypeName _ = "M1"+# if __GLASGOW_HASKELL__ < 701+ moduleName _ = "Generics.Deriving.Base"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_0M1 where+ conName _ = "M1"+ conIsRecord _ = True++instance Selector S1_0_0M1 where+ selName _ = "unM1"++-----++type Rep0ConSum f g p = D1 D1ConSum (C1 C1_0ConSum (S1 NoSelector (Rec0 (f p)))+ :+: C1 C1_1ConSum (S1 NoSelector (Rec0 (g p))))++instance Generic ((f :+: g) p) where+ type Rep ((f :+: g) p) = Rep0ConSum f g p++ from (L1 l) = M1 (L1 (M1 (M1 (K1 l))))+ from (R1 r) = M1 (R1 (M1 (M1 (K1 r))))++ to (M1 (L1 (M1 (M1 (K1 l))))) = L1 l+ to (M1 (R1 (M1 (M1 (K1 r))))) = R1 r++data D1ConSum+data C1_0ConSum+data C1_1ConSum++instance Datatype D1ConSum where+ datatypeName _ = ":+:"+# if __GLASGOW_HASKELL__ < 701+ moduleName _ = "Generics.Deriving.Base"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_0ConSum where+ conName _ = "L1"++instance Constructor C1_1ConSum where+ conName _ = "R1"++-----++type Rep0ConProduct f g p =+ D1 D1ConProduct (C1 C1_ConProduct (S1 NoSelector (Rec0 (f p))+ :*: S1 NoSelector (Rec0 (g p))))++instance Generic ((f :*: g) p) where+ type Rep ((f :*: g) p) = Rep0ConProduct f g p+ from (f :*: g) = M1 (M1 (M1 (K1 f) :*: M1 (K1 g)))+ to (M1 (M1 (M1 (K1 f) :*: M1 (K1 g)))) = f :*: g++data D1ConProduct+data C1_ConProduct++instance Datatype D1ConProduct where+ datatypeName _ = ":*:"+# if __GLASGOW_HASKELL__ < 701+ moduleName _ = "Generics.Deriving.Base"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_ConProduct where+ conName _ = ":*:"+ conFixity _ = Infix RightAssociative 6++-----++type Rep0ConCompose f g p =+ D1 D1ConCompose (C1 C1_0ConCompose (S1 S1_0_0ConCompose (Rec0 (f (g p)))))++instance Generic ((f :.: g) p) where+ type Rep ((f :.: g) p) = Rep0ConCompose f g p+ from (Comp1 c) = M1 (M1 (M1 (K1 c)))+ to (M1 (M1 (M1 (K1 c)))) = Comp1 c++data D1ConCompose+data C1_0ConCompose+data S1_0_0ConCompose++instance Datatype D1ConCompose where+ datatypeName _ = ":.:"+# if __GLASGOW_HASKELL__ < 701+ moduleName _ = "Generics.Deriving.Base"+# else+ moduleName _ = "GHC.Generics"+# endif++instance Constructor C1_0ConCompose where+ conName _ = "Comp1"+ conIsRecord _ = True++instance Selector S1_0_0ConCompose where+ selName _ = "unComp1"+#endif++-----++#if __GLASGOW_HASKELL__ < 705+type Rep1List = D1 D1List (C1 C1_0List U1 :+:+ C1 C1_1List (S1 NoSelector Par1+ :*: S1 NoSelector (Rec1 [])))++instance Generic1 [] where+ type Rep1 [] = Rep1List++ from1 [] = M1 (L1 (M1 U1))+ from1 (h:t) = M1 (R1 (M1 (M1 (Par1 h) :*: M1 (Rec1 t))))++ to1 (M1 (L1 (M1 U1))) = []+ to1 (M1 (R1 (M1 (M1 (Par1 h) :*: M1 (Rec1 t))))) = h : t++data D1List+data C1_0List+data C1_1List++instance Datatype D1List where+ datatypeName _ = "[]"+ moduleName _ = "GHC.Types"++instance Constructor C1_0List where+ conName _ = "[]"++instance Constructor C1_1List where+ conName _ = ":"+ conFixity _ = Infix RightAssociative 5++-----++type Rep1Either a = D1 D1Either (C1 C1_0Either (S1 NoSelector (Rec0 a))+ :+: C1 C1_1Either (S1 NoSelector Par1))++instance Generic1 (Either a) where+ type Rep1 (Either a) = Rep1Either a++ from1 (Left l) = M1 (L1 (M1 (M1 (K1 l))))+ from1 (Right r) = M1 (R1 (M1 (M1 (Par1 r))))++ to1 (M1 (L1 (M1 (M1 (K1 l))))) = Left l+ to1 (M1 (R1 (M1 (M1 (Par1 r))))) = Right r++data D1Either+data C1_0Either+data C1_1Either++instance Datatype D1Either where+ datatypeName _ = "Either"+ moduleName _ = "Data.Either"++instance Constructor C1_0Either where+ conName _ = "Left"++instance Constructor C1_1Either where+ conName _ = "Right"++-----++type Rep1Maybe = D1 D1Maybe (C1 C1_0Maybe U1+ :+: C1 C1_1Maybe (S1 NoSelector Par1))++instance Generic1 Maybe where+ type Rep1 Maybe = Rep1Maybe++ from1 Nothing = M1 (L1 (M1 U1))+ from1 (Just j) = M1 (R1 (M1 (M1 (Par1 j))))++ to1 (M1 (L1 (M1 U1))) = Nothing+ to1 (M1 (R1 (M1 (M1 (Par1 j))))) = Just j++data D1Maybe+data C1_0Maybe+data C1_1Maybe++instance Datatype D1Maybe where+ datatypeName _ = "Maybe"+ -- As of base-4.7.0.0, Maybe is actually located in GHC.Base.+ -- We don't need to worry about this for the versions of base+ -- that this instance is defined for, however.+ moduleName _ = "Data.Maybe"++instance Constructor C1_0Maybe where+ conName _ = "Nothing"++instance Constructor C1_1Maybe where+ conName _ = "Just"++-----++type Rep1Tuple2 a = D1 D1Tuple2 (C1 C1_0Tuple2 (S1 NoSelector (Rec0 a)+ :*: S1 NoSelector Par1))++instance Generic1 ((,) a) where+ type Rep1 ((,) a) = Rep1Tuple2 a+ from1 (a, b) = M1 (M1 (M1 (K1 a) :*: M1 (Par1 b)))+ to1 (M1 (M1 (M1 (K1 a) :*: M1 (Par1 b)))) = (a, b)++data D1Tuple2+data C1_0Tuple2++instance Datatype D1Tuple2 where+ datatypeName _ = "(,)"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Tuple2 where+ conName _ = "(,)"++-----++type Rep1Tuple3 a b = D1 D1Tuple3 (C1 C1_0Tuple3 (S1 NoSelector (Rec0 a)+ :*: (S1 NoSelector (Rec0 b)+ :*: S1 NoSelector Par1)))++instance Generic1 ((,,) a b) where+ type Rep1 ((,,) a b) = Rep1Tuple3 a b+ from1 (a, b, c) = M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (Par1 c))))+ to1 (M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (Par1 c))))) = (a, b, c)++data D1Tuple3+data C1_0Tuple3++instance Datatype D1Tuple3 where+ datatypeName _ = "(,,)"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Tuple3 where+ conName _ = "(,,)"++-----++type Rep1Tuple4 a b c = D1 D1Tuple4 (C1 C1_0Tuple4 ((S1 NoSelector (Rec0 a)+ :*: S1 NoSelector (Rec0 b))+ :*: (S1 NoSelector (Rec0 c)+ :*: S1 NoSelector Par1)))++instance Generic1 ((,,,) a b c) where+ type Rep1 ((,,,) a b c) = Rep1Tuple4 a b c++ from1 (a, b, c, d) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b))+ :*: (M1 (K1 c) :*: M1 (Par1 d))))++ to1 (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b))+ :*: (M1 (K1 c) :*: M1 (Par1 d)))))+ = (a, b, c, d)++data D1Tuple4+data C1_0Tuple4++instance Datatype D1Tuple4 where+ datatypeName _ = "(,,,)"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Tuple4 where+ conName _ = "(,,,)"++-----++type Rep1Tuple5 a b c d = D1 D1Tuple5 (C1 C1_0Tuple5 ((S1 NoSelector (Rec0 a)+ :*: S1 NoSelector (Rec0 b))+ :*: (S1 NoSelector (Rec0 c)+ :*: (S1 NoSelector (Rec0 d)+ :*: S1 NoSelector Par1))))++instance Generic1 ((,,,,) a b c d) where+ type Rep1 ((,,,,) a b c d) = Rep1Tuple5 a b c d++ from1 (a, b, c, d, e) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b))+ :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (Par1 e)))))++ to1 (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b))+ :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (Par1 e))))))+ = (a, b, c, d, e)++data D1Tuple5+data C1_0Tuple5++instance Datatype D1Tuple5 where+ datatypeName _ = "(,,,,)"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Tuple5 where+ conName _ = "(,,,,)"++-----++type Rep1Tuple6 a b c d e =+ D1 D1Tuple6 (C1 C1_0Tuple6 ((S1 NoSelector (Rec0 a)+ :*: (S1 NoSelector (Rec0 b)+ :*: S1 NoSelector (Rec0 c)))+ :*: (S1 NoSelector (Rec0 d)+ :*: (S1 NoSelector (Rec0 e)+ :*: S1 NoSelector Par1))))++instance Generic1 ((,,,,,) a b c d e) where+ type Rep1 ((,,,,,) a b c d e) = Rep1Tuple6 a b c d e++ from1 (a, b, c, d, e, f) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c)))+ :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (Par1 f)))))++ to1 (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c)))+ :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (Par1 f))))))+ = (a, b, c, d, e, f)++data D1Tuple6+data C1_0Tuple6++instance Datatype D1Tuple6 where+ datatypeName _ = "(,,,,,)"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Tuple6 where+ conName _ = "(,,,,,)"++-----++type Rep1Tuple7 a b c d e f =+ D1 D1Tuple7 (C1 C1_0Tuple7 ((S1 NoSelector (Rec0 a)+ :*: (S1 NoSelector (Rec0 b)+ :*: S1 NoSelector (Rec0 c)))+ :*: ((S1 NoSelector (Rec0 d)+ :*: S1 NoSelector (Rec0 e))+ :*: (S1 NoSelector (Rec0 f)+ :*: S1 NoSelector Par1))))++instance Generic1 ((,,,,,,) a b c d e f) where+ type Rep1 ((,,,,,,) a b c d e f) = Rep1Tuple7 a b c d e f++ from1 (a, b, c, d, e, f, g) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c)))+ :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (Par1 g)))))++ to1 (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c)))+ :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (Par1 g))))))+ = (a, b, c, d, e, f, g)++data D1Tuple7+data C1_0Tuple7++instance Datatype D1Tuple7 where+ datatypeName _ = "(,,,,,,)"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Tuple7 where+ conName _ = "(,,,,,,)"+#endif++-----++#if __GLASGOW_HASKELL__ < 701+type Rep0Bool = D1 D1Bool (C1 C1_0Bool U1 :+: C1 C1_1Bool U1)++instance Generic Bool where+ type Rep Bool = Rep0Bool++ from False = M1 (L1 (M1 U1))+ from True = M1 (R1 (M1 U1))++ to (M1 (L1 (M1 U1))) = False+ to (M1 (R1 (M1 U1))) = True++data D1Bool+data C1_0Bool+data C1_1Bool++instance Datatype D1Bool where+ datatypeName _ = "Bool"+ moduleName _ = "GHC.Bool"++instance Constructor C1_0Bool where+ conName _ = "False"++instance Constructor C1_1Bool where+ conName _ = "True"++-----++data D_Char+data C_Char++instance Datatype D_Char where+ datatypeName _ = "Char"+ moduleName _ = "GHC.Base"++instance Constructor C_Char where+ conName _ = "" -- JPM: I'm not sure this is the right implementation...++type Rep0Char = D1 D_Char (C1 C_Char (S1 NoSelector (Rec0 Char)))++instance Generic Char where+ type Rep Char = Rep0Char+ from x = M1 (M1 (M1 (K1 x)))+ to (M1 (M1 (M1 (K1 x)))) = x++-----++data D_Double+data C_Double++instance Datatype D_Double where+ datatypeName _ = "Double"+ moduleName _ = "GHC.Float"++instance Constructor C_Double where+ conName _ = "" -- JPM: I'm not sure this is the right implementation...++type Rep0Double = D1 D_Double (C1 C_Double (S1 NoSelector (Rec0 Double)))++instance Generic Double where+ type Rep Double = Rep0Double+ from x = M1 (M1 (M1 (K1 x)))+ to (M1 (M1 (M1 (K1 x)))) = x++-----++type Rep0Either a b = D1 D1Either (C1 C1_0Either (S1 NoSelector (Rec0 a))+ :+: C1 C1_1Either (S1 NoSelector (Rec0 b)))++instance Generic (Either a b) where+ type Rep (Either a b) = Rep0Either a b++ from (Left l) = M1 (L1 (M1 (M1 (K1 l))))+ from (Right r) = M1 (R1 (M1 (M1 (K1 r))))++ to (M1 (L1 (M1 (M1 (K1 l))))) = Left l+ to (M1 (R1 (M1 (M1 (K1 r))))) = Right r++-----++data D_Int+data C_Int++instance Datatype D_Int where+ datatypeName _ = "Int"+ moduleName _ = "GHC.Int"++instance Constructor C_Int where+ conName _ = "" -- JPM: I'm not sure this is the right implementation...++type Rep0Int = D1 D_Int (C1 C_Int (S1 NoSelector (Rec0 Int)))++instance Generic Int where+ type Rep Int = Rep0Int+ from x = M1 (M1 (M1 (K1 x)))+ to (M1 (M1 (M1 (K1 x)))) = x++-----++data D_Float+data C_Float++instance Datatype D_Float where+ datatypeName _ = "Float"+ moduleName _ = "GHC.Float"++instance Constructor C_Float where+ conName _ = "" -- JPM: I'm not sure this is the right implementation...++type Rep0Float = D1 D_Float (C1 C_Float (S1 NoSelector (Rec0 Float)))++instance Generic Float where+ type Rep Float = Rep0Float+ from x = M1 (M1 (M1 (K1 x)))+ to (M1 (M1 (M1 (K1 x)))) = x++-----++type Rep0List a =+ D1 D1List (C1 C1_0List U1 :+: C1 C1_1List (S1 NoSelector (Rec0 a)+ :*: S1 NoSelector (Rec0 [a])))++instance Generic [a] where+ type Rep [a] = Rep0List a++ from [] = M1 (L1 (M1 U1))+ from (h:t) = M1 (R1 (M1 (M1 (K1 h) :*: M1 (K1 t))))++ to (M1 (L1 (M1 U1))) = []+ to (M1 (R1 (M1 (M1 (K1 h) :*: M1 (K1 t))))) = h : t++-----++type Rep0Maybe a = D1 D1Maybe (C1 C1_0Maybe U1+ :+: C1 C1_1Maybe (S1 NoSelector (Rec0 a)))++instance Generic (Maybe a) where+ type Rep (Maybe a) = Rep0Maybe a++ from Nothing = M1 (L1 (M1 U1))+ from (Just j) = M1 (R1 (M1 (M1 (K1 j))))++ to (M1 (L1 (M1 U1))) = Nothing+ to (M1 (R1 (M1 (M1 (K1 j))))) = Just j++-----++type Rep0Ordering = D1 D1Ordering (C1 C1_0Ordering U1+ :+: (C1 C1_1Ordering U1 :+: C1 C1_2Ordering U1))++instance Generic Ordering where+ type Rep Ordering = Rep0Ordering++ from LT = M1 (L1 (M1 U1))+ from EQ = M1 (R1 (L1 (M1 U1)))+ from GT = M1 (R1 (R1 (M1 U1)))++ to (M1 (L1 (M1 U1))) = LT+ to (M1 (R1 (L1 (M1 U1)))) = EQ+ to (M1 (R1 (R1 (M1 U1)))) = GT++data D1Ordering+data C1_0Ordering+data C1_1Ordering+data C1_2Ordering++instance Datatype D1Ordering where+ datatypeName _ = "Ordering"+ moduleName _ = "GHC.Ordering"++instance Constructor C1_0Ordering where+ conName _ = "LT"++instance Constructor C1_1Ordering where+ conName _ = "EQ"++instance Constructor C1_2Ordering where+ conName _ = "GT"++-----++type Rep0Unit = D1 D1Unit (C1 C1_0Unit U1)++instance Generic () where+ type Rep () = Rep0Unit+ from () = M1 (M1 U1)+ to (M1 (M1 U1)) = ()++data D1Unit+data C1_0Unit++instance Datatype D1Unit where+ datatypeName _ = "()"+ moduleName _ = "GHC.Tuple"++instance Constructor C1_0Unit where+ conName _ = "()"++-----++type Rep0Tuple2 a b = D1 D1Tuple2 (C1 C1_0Tuple2 (S1 NoSelector (Rec0 a)+ :*: S1 NoSelector (Rec0 b)))++instance Generic (a, b) where+ type Rep (a, b) = Rep0Tuple2 a b+ from (a, b) = M1 (M1 (M1 (K1 a) :*: M1 (K1 b)))+ to (M1 (M1 (M1 (K1 a) :*: M1 (K1 b)))) = (a, b)++-----++type Rep0Tuple3 a b c = D1 D1Tuple3 (C1 C1_0Tuple3 (S1 NoSelector (Rec0 a)+ :*: (S1 NoSelector (Rec0 b)+ :*: S1 NoSelector (Rec0 c))))++instance Generic (a, b, c) where+ type Rep (a, b, c) = Rep0Tuple3 a b c+ from (a, b, c) = M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))))+ to (M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))))) = (a, b, c)++-----++type Rep0Tuple4 a b c d = D1 D1Tuple4 (C1 C1_0Tuple4 ((S1 NoSelector (Rec0 a)+ :*: S1 NoSelector (Rec0 b))+ :*: (S1 NoSelector (Rec0 c)+ :*: S1 NoSelector (Rec0 d))))++instance Generic (a, b, c, d) where+ type Rep (a, b, c, d) = Rep0Tuple4 a b c d++ from (a, b, c, d) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b))+ :*: (M1 (K1 c) :*: M1 (K1 d))))++ to (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b))+ :*: (M1 (K1 c) :*: M1 (K1 d)))))+ = (a, b, c, d)++-----++type Rep0Tuple5 a b c d e = D1 D1Tuple5 (C1 C1_0Tuple5 ((S1 NoSelector (Rec0 a)+ :*: S1 NoSelector (Rec0 b))+ :*: (S1 NoSelector (Rec0 c)+ :*: (S1 NoSelector (Rec0 d)+ :*: S1 NoSelector (Rec0 e)))))++instance Generic (a, b, c, d, e) where+ type Rep (a, b, c, d, e) = Rep0Tuple5 a b c d e++ from (a, b, c, d, e) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b))+ :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (K1 e)))))++ to (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b))+ :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (K1 e))))))+ = (a, b, c, d, e)++-----++type Rep0Tuple6 a b c d e f = D1 D1Tuple6 (C1 C1_0Tuple6 ((S1 NoSelector (Rec0 a)+ :*: (S1 NoSelector (Rec0 b)+ :*: S1 NoSelector (Rec0 c)))+ :*: (S1 NoSelector (Rec0 d)+ :*: (S1 NoSelector (Rec0 e)+ :*: S1 NoSelector (Rec0 f)))))++instance Generic (a, b, c, d, e, f) where+ type Rep (a, b, c, d, e, f) = Rep0Tuple6 a b c d e f++ from (a, b, c, d, e, f) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c)))+ :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (K1 f)))))++ to (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c)))+ :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (K1 f))))))+ = (a, b, c, d, e, f)++-----++type Rep0Tuple7 a b c d e f g+ = D1 D1Tuple7 (C1 C1_0Tuple7 ((S1 NoSelector (Rec0 a)+ :*: (S1 NoSelector (Rec0 b)+ :*: S1 NoSelector (Rec0 c)))+ :*: ((S1 NoSelector (Rec0 d)+ :*: S1 NoSelector (Rec0 e))+ :*: (S1 NoSelector (Rec0 f)+ :*: S1 NoSelector (Rec0 g)))))++instance Generic (a, b, c, d, e, f, g) where+ type Rep (a, b, c, d, e, f, g) = Rep0Tuple7 a b c d e f g++ from (a, b, c, d, e, f, g) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c)))+ :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (K1 g)))))++ to (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c)))+ :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (K1 g))))))+ = (a, b, c, d, e, f, g)++#endif
src/Generics/Deriving/Monoid.hs view
@@ -1,241 +1,251 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} - -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - --- | This module provides two main features: --- --- 1. 'GMonoid', a generic version of the 'Monoid' type class, including instances --- of the types from "Data.Monoid" --- --- 2. Default generic definitions for the 'Monoid' methods 'mempty' and 'mappend' --- --- The generic defaults only work for types without alternatives (i.e. they have --- only one constructor). We cannot in general know how to deal with different --- constructors. - -module Generics.Deriving.Monoid ( - - -- * GMonoid type class - GMonoid(..), - - -- * Default definitions - -- ** GMonoid - gmemptydefault, - gmappenddefault, - - -- ** Monoid - -- | These functions can be used in a 'Monoid' instance. For example: - -- - -- @ - -- -- LANGUAGE DeriveGeneric - -- - -- import Generics.Deriving.Base (Generic) - -- import Generics.Deriving.Monoid - -- - -- data T a = C a (Maybe a) deriving Generic - -- - -- instance Monoid a => Monoid (T a) where - -- mempty = memptydefault - -- mappend = mappenddefault - -- @ - memptydefault, - mappenddefault, - - -- * The Monoid module - -- | This is exported for convenient access to the various wrapper types. - module Data.Monoid, - - ) where - --------------------------------------------------------------------------------- - -import Control.Applicative -import Data.Monoid -import Generics.Deriving.Base -import Generics.Deriving.Instances () - -#if MIN_VERSION_base(4,7,0) -import Data.Proxy (Proxy) -#endif - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -#endif - --------------------------------------------------------------------------------- - -class GMonoid' f where - gmempty' :: f x - gmappend' :: f x -> f x -> f x - -instance GMonoid' U1 where - gmempty' = U1 - gmappend' U1 U1 = U1 - -instance GMonoid a => GMonoid' (K1 i a) where - gmempty' = K1 gmempty - gmappend' (K1 x) (K1 y) = K1 (x `gmappend` y) - -instance GMonoid' f => GMonoid' (M1 i c f) where - gmempty' = M1 gmempty' - gmappend' (M1 x) (M1 y) = M1 (x `gmappend'` y) - -instance (GMonoid' f, GMonoid' h) => GMonoid' (f :*: h) where - gmempty' = gmempty' :*: gmempty' - gmappend' (x1 :*: y1) (x2 :*: y2) = gmappend' x1 x2 :*: gmappend' y1 y2 - --------------------------------------------------------------------------------- - -gmemptydefault :: (Generic a, GMonoid' (Rep a)) => a -gmemptydefault = to gmempty' - -gmappenddefault :: (Generic a, GMonoid' (Rep a)) => a -> a -> a -gmappenddefault x y = to (gmappend' (from x) (from y)) - --------------------------------------------------------------------------------- - -class Monoid' f where - mempty' :: f x - mappend' :: f x -> f x -> f x - -instance Monoid' U1 where - mempty' = U1 - mappend' U1 U1 = U1 - -instance Monoid a => Monoid' (K1 i a) where - mempty' = K1 mempty - mappend' (K1 x) (K1 y) = K1 (x `mappend` y) - -instance Monoid' f => Monoid' (M1 i c f) where - mempty' = M1 mempty' - mappend' (M1 x) (M1 y) = M1 (x `mappend'` y) - -instance (Monoid' f, Monoid' h) => Monoid' (f :*: h) where - mempty' = mempty' :*: mempty' - mappend' (x1 :*: y1) (x2 :*: y2) = mappend' x1 x2 :*: mappend' y1 y2 - --------------------------------------------------------------------------------- - -memptydefault :: (Generic a, Monoid' (Rep a)) => a -memptydefault = to mempty' - -mappenddefault :: (Generic a, Monoid' (Rep a)) => a -> a -> a -mappenddefault x y = to (mappend' (from x) (from y)) - --------------------------------------------------------------------------------- - -class GMonoid a where - - -- | Generic 'mempty' - gmempty :: a - - -- | Generic 'mappend' - gmappend :: a -> a -> a - - -- | Generic 'mconcat' - gmconcat :: [a] -> a - gmconcat = foldr gmappend gmempty - -#if __GLASGOW_HASKELL__ >= 701 - default gmempty :: (Generic a, GMonoid' (Rep a)) => a - gmempty = to gmempty' - - default gmappend :: (Generic a, GMonoid' (Rep a)) => a -> a -> a - gmappend x y = to (gmappend' (from x) (from y)) -#endif - --------------------------------------------------------------------------------- - --- Instances that reuse Monoid -instance GMonoid Ordering where - gmempty = mempty - gmappend = mappend -instance GMonoid () where - gmempty = mempty - gmappend = mappend -instance GMonoid Any where - gmempty = mempty - gmappend = mappend -instance GMonoid All where - gmempty = mempty - gmappend = mappend -instance GMonoid (First a) where - gmempty = mempty - gmappend = mappend -instance GMonoid (Last a) where - gmempty = mempty - gmappend = mappend -instance Num a => GMonoid (Sum a) where - gmempty = mempty - gmappend = mappend -instance Num a => GMonoid (Product a) where - gmempty = mempty - gmappend = mappend -instance GMonoid [a] where - gmempty = mempty - gmappend = mappend -instance GMonoid (Endo a) where - gmempty = mempty - gmappend = mappend - --- Handwritten instances -instance GMonoid a => GMonoid (Dual a) where - gmempty = Dual gmempty - gmappend (Dual x) (Dual y) = Dual (gmappend y x) -instance GMonoid a => GMonoid (Maybe a) where - gmempty = Nothing - gmappend Nothing x = x - gmappend x Nothing = x - gmappend (Just x) (Just y) = Just (gmappend x y) -instance GMonoid b => GMonoid (a -> b) where - gmempty _ = gmempty - gmappend f g x = gmappend (f x) (g x) -instance GMonoid a => GMonoid (Const a b) where - gmempty = gmemptydefault - gmappend = gmappenddefault - -#if MIN_VERSION_base(4,7,0) -instance GMonoid (Proxy s) where - gmempty = memptydefault - gmappend = mappenddefault -#endif - -#if MIN_VERSION_base(4,8,0) -instance GMonoid a => GMonoid (Identity a) where - gmempty = gmemptydefault - gmappend = gmappenddefault -#endif - --- Tuple instances -instance (GMonoid a,GMonoid b) => GMonoid (a,b) where - gmempty = (gmempty,gmempty) - gmappend (a1,b1) (a2,b2) = - (gmappend a1 a2,gmappend b1 b2) -instance (GMonoid a,GMonoid b,GMonoid c) => GMonoid (a,b,c) where - gmempty = (gmempty,gmempty,gmempty) - gmappend (a1,b1,c1) (a2,b2,c2) = - (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2) -instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d) => GMonoid (a,b,c,d) where - gmempty = (gmempty,gmempty,gmempty,gmempty) - gmappend (a1,b1,c1,d1) (a2,b2,c2,d2) = - (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2) -instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e) => GMonoid (a,b,c,d,e) where - gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty) - gmappend (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) = - (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2) -instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f) => GMonoid (a,b,c,d,e,f) where - gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty) - gmappend (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) = - (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2) -instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f,GMonoid g) => GMonoid (a,b,c,d,e,f,g) where - gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty) - gmappend (a1,b1,c1,d1,e1,f1,g1) (a2,b2,c2,d2,e2,f2,g2) = - (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2,gmappend g1 g2) -instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f,GMonoid g,GMonoid h) => GMonoid (a,b,c,d,e,f,g,h) where - gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty) - gmappend (a1,b1,c1,d1,e1,f1,g1,h1) (a2,b2,c2,d2,e2,f2,g2,h2) = - (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2,gmappend g1 g2,gmappend h1 h2) +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+#endif++-- | This module provides two main features:+--+-- 1. 'GMonoid', a generic version of the 'Monoid' type class, including instances+-- of the types from "Data.Monoid"+--+-- 2. Default generic definitions for the 'Monoid' methods 'mempty' and 'mappend'+--+-- The generic defaults only work for types without alternatives (i.e. they have+-- only one constructor). We cannot in general know how to deal with different+-- constructors.++module Generics.Deriving.Monoid (++ -- * GMonoid type class+ GMonoid(..),++ -- * Default definitions+ -- ** GMonoid+ gmemptydefault,+ gmappenddefault,++ -- ** Monoid+ -- | These functions can be used in a 'Monoid' instance. For example:+ --+ -- @+ -- -- LANGUAGE DeriveGeneric+ --+ -- import Generics.Deriving.Base (Generic)+ -- import Generics.Deriving.Monoid+ --+ -- data T a = C a (Maybe a) deriving Generic+ --+ -- instance Monoid a => Monoid (T a) where+ -- mempty = memptydefault+ -- mappend = mappenddefault+ -- @+ memptydefault,+ mappenddefault,++ -- * The Monoid module+ -- | This is exported for convenient access to the various wrapper types.+ module Data.Monoid,++ ) where++--------------------------------------------------------------------------------++import Control.Applicative+import Data.Monoid+import Generics.Deriving.Base+import Generics.Deriving.Instances ()++#if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+#endif++#if MIN_VERSION_base(4,9,0)+import Data.Semigroup (WrappedMonoid)+#endif++--------------------------------------------------------------------------------++class GMonoid' f where+ gmempty' :: f x+ gmappend' :: f x -> f x -> f x++instance GMonoid' U1 where+ gmempty' = U1+ gmappend' U1 U1 = U1++instance GMonoid a => GMonoid' (K1 i a) where+ gmempty' = K1 gmempty+ gmappend' (K1 x) (K1 y) = K1 (x `gmappend` y)++instance GMonoid' f => GMonoid' (M1 i c f) where+ gmempty' = M1 gmempty'+ gmappend' (M1 x) (M1 y) = M1 (x `gmappend'` y)++instance (GMonoid' f, GMonoid' h) => GMonoid' (f :*: h) where+ gmempty' = gmempty' :*: gmempty'+ gmappend' (x1 :*: y1) (x2 :*: y2) = gmappend' x1 x2 :*: gmappend' y1 y2++--------------------------------------------------------------------------------++gmemptydefault :: (Generic a, GMonoid' (Rep a)) => a+gmemptydefault = to gmempty'++gmappenddefault :: (Generic a, GMonoid' (Rep a)) => a -> a -> a+gmappenddefault x y = to (gmappend' (from x) (from y))++--------------------------------------------------------------------------------++class Monoid' f where+ mempty' :: f x+ mappend' :: f x -> f x -> f x++instance Monoid' U1 where+ mempty' = U1+ mappend' U1 U1 = U1++instance Monoid a => Monoid' (K1 i a) where+ mempty' = K1 mempty+ mappend' (K1 x) (K1 y) = K1 (x `mappend` y)++instance Monoid' f => Monoid' (M1 i c f) where+ mempty' = M1 mempty'+ mappend' (M1 x) (M1 y) = M1 (x `mappend'` y)++instance (Monoid' f, Monoid' h) => Monoid' (f :*: h) where+ mempty' = mempty' :*: mempty'+ mappend' (x1 :*: y1) (x2 :*: y2) = mappend' x1 x2 :*: mappend' y1 y2++--------------------------------------------------------------------------------++memptydefault :: (Generic a, Monoid' (Rep a)) => a+memptydefault = to mempty'++mappenddefault :: (Generic a, Monoid' (Rep a)) => a -> a -> a+mappenddefault x y = to (mappend' (from x) (from y))++--------------------------------------------------------------------------------++class GMonoid a where++ -- | Generic 'mempty'+ gmempty :: a++ -- | Generic 'mappend'+ gmappend :: a -> a -> a++ -- | Generic 'mconcat'+ gmconcat :: [a] -> a+ gmconcat = foldr gmappend gmempty++#if __GLASGOW_HASKELL__ >= 701+ default gmempty :: (Generic a, GMonoid' (Rep a)) => a+ gmempty = to gmempty'++ default gmappend :: (Generic a, GMonoid' (Rep a)) => a -> a -> a+ gmappend x y = to (gmappend' (from x) (from y))+#endif++--------------------------------------------------------------------------------++-- Instances that reuse Monoid+instance GMonoid Ordering where+ gmempty = mempty+ gmappend = mappend+instance GMonoid () where+ gmempty = mempty+ gmappend = mappend+instance GMonoid Any where+ gmempty = mempty+ gmappend = mappend+instance GMonoid All where+ gmempty = mempty+ gmappend = mappend+instance GMonoid (First a) where+ gmempty = mempty+ gmappend = mappend+instance GMonoid (Last a) where+ gmempty = mempty+ gmappend = mappend+instance Num a => GMonoid (Sum a) where+ gmempty = mempty+ gmappend = mappend+instance Num a => GMonoid (Product a) where+ gmempty = mempty+ gmappend = mappend+instance GMonoid [a] where+ gmempty = mempty+ gmappend = mappend+instance GMonoid (Endo a) where+ gmempty = mempty+ gmappend = mappend++-- Handwritten instances+instance GMonoid a => GMonoid (Dual a) where+ gmempty = Dual gmempty+ gmappend (Dual x) (Dual y) = Dual (gmappend y x)+instance GMonoid a => GMonoid (Maybe a) where+ gmempty = Nothing+ gmappend Nothing x = x+ gmappend x Nothing = x+ gmappend (Just x) (Just y) = Just (gmappend x y)+instance GMonoid b => GMonoid (a -> b) where+ gmempty _ = gmempty+ gmappend f g x = gmappend (f x) (g x)+instance GMonoid a => GMonoid (Const a b) where+ gmempty = gmemptydefault+ gmappend = gmappenddefault++#if MIN_VERSION_base(4,7,0)+instance GMonoid (Proxy s) where+ gmempty = memptydefault+ gmappend = mappenddefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GMonoid a => GMonoid (Identity a) where+ gmempty = gmemptydefault+ gmappend = gmappenddefault+#endif++#if MIN_VERSION_base(4,9,0)+instance GMonoid m => GMonoid (WrappedMonoid m) where+ gmempty = gmemptydefault+ gmappend = gmappenddefault+#endif++-- Tuple instances+instance (GMonoid a,GMonoid b) => GMonoid (a,b) where+ gmempty = (gmempty,gmempty)+ gmappend (a1,b1) (a2,b2) =+ (gmappend a1 a2,gmappend b1 b2)+instance (GMonoid a,GMonoid b,GMonoid c) => GMonoid (a,b,c) where+ gmempty = (gmempty,gmempty,gmempty)+ gmappend (a1,b1,c1) (a2,b2,c2) =+ (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2)+instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d) => GMonoid (a,b,c,d) where+ gmempty = (gmempty,gmempty,gmempty,gmempty)+ gmappend (a1,b1,c1,d1) (a2,b2,c2,d2) =+ (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2)+instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e) => GMonoid (a,b,c,d,e) where+ gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty)+ gmappend (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) =+ (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2)+instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f) => GMonoid (a,b,c,d,e,f) where+ gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty)+ gmappend (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) =+ (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2)+instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f,GMonoid g) => GMonoid (a,b,c,d,e,f,g) where+ gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty)+ gmappend (a1,b1,c1,d1,e1,f1,g1) (a2,b2,c2,d2,e2,f2,g2) =+ (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2,gmappend g1 g2)+instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f,GMonoid g,GMonoid h) => GMonoid (a,b,c,d,e,f,g,h) where+ gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty)+ gmappend (a1,b1,c1,d1,e1,f1,g1,h1) (a2,b2,c2,d2,e2,f2,g2,h2) =+ (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2,gmappend g1 g2,gmappend h1 h2)
src/Generics/Deriving/Show.hs view
@@ -1,536 +1,614 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} - -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -#if __GLASGOW_HASKELL__ < 709 -{-# LANGUAGE OverlappingInstances #-} -#endif - -module Generics.Deriving.Show ( - -- * Generic show class - GShow(..) - - -- * Default definition - , gshowsPrecdefault - - ) where - -import Control.Applicative (Const, ZipList) - -import Data.Char (GeneralCategory) -import Data.Int -import Data.Monoid (All, Any, Dual, First, Last, Product, Sum) -import Data.Word - -import Foreign.C.Types -import Foreign.ForeignPtr (ForeignPtr) -import Foreign.Ptr - -import Generics.Deriving.Base -import Generics.Deriving.Instances () - -import GHC.Exts hiding (Any) - -import System.Exit (ExitCode) -import System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode) -import System.IO.Error (IOErrorType) -import System.Posix.Types - -#if MIN_VERSION_base(4,7,0) -import Data.Proxy (Proxy) -#endif - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -import Data.Monoid (Alt) -import Data.Void (Void) -import Numeric.Natural (Natural) -#endif - --------------------------------------------------------------------------------- --- Generic show --------------------------------------------------------------------------------- - -intersperse :: a -> [a] -> [a] -intersperse _ [] = [] -intersperse _ [h] = [h] -intersperse x (h:t) = h : x : (intersperse x t) - -appPrec :: Int -appPrec = 2 - -data Type = Rec | Tup | Pref | Inf String - -class GShow' f where - gshowsPrec' :: Type -> Int -> f a -> ShowS - isNullary :: f a -> Bool - isNullary = error "generic show (isNullary): unnecessary case" - -instance GShow' U1 where - gshowsPrec' _ _ U1 = id - isNullary _ = True - -instance (GShow c) => GShow' (K1 i c) where - gshowsPrec' _ n (K1 a) = gshowsPrec n a - isNullary _ = False - --- No instances for P or Rec because gshow is only applicable to types of kind * - -instance (GShow' a, Constructor c) => GShow' (M1 C c a) where - gshowsPrec' _ n c@(M1 x) = - case fixity of - Prefix -> showParen (n > appPrec && not (isNullary x)) - ( showString (conName c) - . if (isNullary x) then id else showChar ' ' - . showBraces t (gshowsPrec' t appPrec x)) - Infix _ m -> showParen (n > m) (showBraces t (gshowsPrec' t m x)) - where fixity = conFixity c - t = if (conIsRecord c) then Rec else - case (conIsTuple c) of - True -> Tup - False -> case fixity of - Prefix -> Pref - Infix _ _ -> Inf (show (conName c)) - showBraces :: Type -> ShowS -> ShowS - showBraces Rec p = showChar '{' . p . showChar '}' - showBraces Tup p = showChar '(' . p . showChar ')' - showBraces Pref p = p - showBraces (Inf _) p = p - conIsTuple y = tupleName (conName y) where - tupleName ('(':',':_) = True - tupleName _ = False - -instance (Selector s, GShow' a) => GShow' (M1 S s a) where - gshowsPrec' t n s@(M1 x) | selName s == "" = --showParen (n > appPrec) - (gshowsPrec' t n x) - | otherwise = showString (selName s) - . showString " = " - . gshowsPrec' t 0 x - isNullary (M1 x) = isNullary x - -instance (GShow' a) => GShow' (M1 D d a) where - gshowsPrec' t n (M1 x) = gshowsPrec' t n x - -instance (GShow' a, GShow' b) => GShow' (a :+: b) where - gshowsPrec' t n (L1 x) = gshowsPrec' t n x - gshowsPrec' t n (R1 x) = gshowsPrec' t n x - -instance (GShow' a, GShow' b) => GShow' (a :*: b) where - gshowsPrec' t@Rec n (a :*: b) = - gshowsPrec' t n a . showString ", " . gshowsPrec' t n b - gshowsPrec' t@(Inf s) n (a :*: b) = - gshowsPrec' t n a . showString s . gshowsPrec' t n b - gshowsPrec' t@Tup n (a :*: b) = - gshowsPrec' t n a . showChar ',' . gshowsPrec' t n b - gshowsPrec' t@Pref n (a :*: b) = - gshowsPrec' t (n+1) a . showChar ' ' . gshowsPrec' t (n+1) b - - -- If we have a product then it is not a nullary constructor - isNullary _ = False - --- Unboxed types -instance GShow' UChar where - gshowsPrec' _ _ (UChar c) = showsPrec 0 (C# c) . showChar '#' -instance GShow' UDouble where - gshowsPrec' _ _ (UDouble d) = showsPrec 0 (D# d) . showString "##" -instance GShow' UFloat where - gshowsPrec' _ _ (UFloat f) = showsPrec 0 (F# f) . showChar '#' -instance GShow' UInt where - gshowsPrec' _ _ (UInt i) = showsPrec 0 (I# i) . showChar '#' -instance GShow' UWord where - gshowsPrec' _ _ (UWord w) = showsPrec 0 (W# w) . showString "##" - - -class GShow a where - gshowsPrec :: Int -> a -> ShowS - gshows :: a -> ShowS - gshows = gshowsPrec 0 - gshow :: a -> String - gshow x = gshows x "" -#if __GLASGOW_HASKELL__ >= 701 - default gshowsPrec :: (Generic a, GShow' (Rep a)) - => Int -> a -> ShowS - gshowsPrec = gshowsPrecdefault -#endif - -gshowsPrecdefault :: (Generic a, GShow' (Rep a)) - => Int -> a -> ShowS -gshowsPrecdefault n = gshowsPrec' Pref n . from - - --- Base types instances --- Base types instances -instance GShow () where - gshowsPrec = gshowsPrecdefault - -instance (GShow a, GShow b) => GShow (a, b) where - gshowsPrec = gshowsPrecdefault - -instance (GShow a, GShow b, GShow c) => GShow (a, b, c) where - gshowsPrec = gshowsPrecdefault - -instance (GShow a, GShow b, GShow c, GShow d) => GShow (a, b, c, d) where - gshowsPrec = gshowsPrecdefault - -instance (GShow a, GShow b, GShow c, GShow d, GShow e) => GShow (a, b, c, d, e) where - gshowsPrec = gshowsPrecdefault - -instance (GShow a, GShow b, GShow c, GShow d, GShow e, GShow f) - => GShow (a, b, c, d, e, f) where - gshowsPrec = gshowsPrecdefault - -instance (GShow a, GShow b, GShow c, GShow d, GShow e, GShow f, GShow g) - => GShow (a, b, c, d, e, f, g) where - gshowsPrec = gshowsPrecdefault - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPABLE #-} -#endif - (GShow a) => GShow [a] where - gshowsPrec _ l = showChar '[' - . foldr (.) id - (intersperse (showChar ',') (map (gshowsPrec 0) l)) - . showChar ']' - -instance (GShow (f p), GShow (g p)) => GShow ((f :+: g) p) where - gshowsPrec = gshowsPrecdefault - -instance (GShow (f p), GShow (g p)) => GShow ((f :*: g) p) where - gshowsPrec = gshowsPrecdefault - -instance GShow (f (g p)) => GShow ((f :.: g) p) where - gshowsPrec = gshowsPrecdefault - -instance GShow All where - gshowsPrec = gshowsPrecdefault - -#if MIN_VERSION_base(4,8,0) -instance GShow (f a) => GShow (Alt f a) where - gshowsPrec = gshowsPrecdefault -#endif - -instance GShow Any where - gshowsPrec = gshowsPrecdefault - -instance GShow Arity where - gshowsPrec = gshowsPrecdefault - -instance GShow Associativity where - gshowsPrec = gshowsPrecdefault - -instance GShow Bool where - gshowsPrec = gshowsPrecdefault - -instance GShow BufferMode where - gshowsPrec = showsPrec - -#if defined(HTYPE_CC_T) -instance GShow CCc where - gshowsPrec = showsPrec -#endif - -instance GShow CChar where - gshowsPrec = showsPrec - -instance GShow CClock where - gshowsPrec = showsPrec - -#if defined(HTYPE_DEV_T) -instance GShow CDev where - gshowsPrec = showsPrec -#endif - -instance GShow CDouble where - gshowsPrec = showsPrec - -instance GShow CFloat where - gshowsPrec = showsPrec - -#if defined(HTYPE_GID_T) -instance GShow CGid where - gshowsPrec = showsPrec -#endif - -instance GShow Char where - gshowsPrec = showsPrec - -#if defined(HTYPE_INO_T) -instance GShow CIno where - gshowsPrec = showsPrec -#endif - -instance GShow CInt where - gshowsPrec = showsPrec - -instance GShow CIntMax where - gshowsPrec = showsPrec - -instance GShow CIntPtr where - gshowsPrec = showsPrec - -instance GShow CLLong where - gshowsPrec = showsPrec - -instance GShow CLong where - gshowsPrec = showsPrec - -#if defined(HTYPE_MODE_T) -instance GShow CMode where - gshowsPrec = showsPrec -#endif - -#if defined(HTYPE_NLINK_T) -instance GShow CNlink where - gshowsPrec = showsPrec -#endif - -#if defined(HTYPE_OFF_T) -instance GShow COff where - gshowsPrec = showsPrec -#endif - -instance GShow a => GShow (Const a b) where - gshowsPrec = gshowsPrecdefault - -#if defined(HTYPE_PID_T) -instance GShow CPid where - gshowsPrec = showsPrec -#endif - -instance GShow CPtrdiff where - gshowsPrec = showsPrec - -#if defined(HTYPE_RLIM_T) -instance GShow CRLim where - gshowsPrec = showsPrec -#endif - -instance GShow CSChar where - gshowsPrec = showsPrec - -#if defined(HTYPE_SPEED_T) -instance GShow CSpeed where - gshowsPrec = showsPrec -#endif - -#if MIN_VERSION_base(4,4,0) -instance GShow CSUSeconds where - gshowsPrec = showsPrec -#endif - -instance GShow CShort where - gshowsPrec = showsPrec - -instance GShow CSigAtomic where - gshowsPrec = showsPrec - -instance GShow CSize where - gshowsPrec = showsPrec - -#if defined(HTYPE_SSIZE_T) -instance GShow CSsize where - gshowsPrec = showsPrec -#endif - -#if defined(HTYPE_TCFLAG_T) -instance GShow CTcflag where - gshowsPrec = showsPrec -#endif - -instance GShow CTime where - gshowsPrec = showsPrec - -instance GShow CUChar where - gshowsPrec = showsPrec - -#if defined(HTYPE_UID_T) -instance GShow CUid where - gshowsPrec = showsPrec -#endif - -instance GShow CUInt where - gshowsPrec = showsPrec - -instance GShow CUIntMax where - gshowsPrec = showsPrec - -instance GShow CUIntPtr where - gshowsPrec = showsPrec - -instance GShow CULLong where - gshowsPrec = showsPrec - -instance GShow CULong where - gshowsPrec = showsPrec - -#if MIN_VERSION_base(4,4,0) -instance GShow CUSeconds where - gshowsPrec = showsPrec -#endif - -instance GShow CUShort where - gshowsPrec = showsPrec - -instance GShow CWchar where - gshowsPrec = showsPrec - -instance GShow Double where - gshowsPrec = showsPrec - -instance GShow a => GShow (Dual a) where - gshowsPrec = gshowsPrecdefault - -instance (GShow a, GShow b) => GShow (Either a b) where - gshowsPrec = gshowsPrecdefault - -instance GShow ExitCode where - gshowsPrec = showsPrec - -instance GShow Fd where - gshowsPrec = showsPrec - -instance GShow a => GShow (First a) where - gshowsPrec = gshowsPrecdefault - -instance GShow Fixity where - gshowsPrec = gshowsPrecdefault - -instance GShow Float where - gshowsPrec = showsPrec - -instance GShow (ForeignPtr a) where - gshowsPrec = showsPrec - -instance GShow (FunPtr a) where - gshowsPrec = showsPrec - -instance GShow GeneralCategory where - gshowsPrec = showsPrec - -instance GShow Handle where - gshowsPrec = showsPrec - -instance GShow HandlePosn where - gshowsPrec = showsPrec - -#if MIN_VERSION_base(4,8,0) -instance GShow a => GShow (Identity a) where - gshowsPrec = gshowsPrecdefault -#endif - -instance GShow Int where - gshowsPrec = showsPrec - -instance GShow Int8 where - gshowsPrec = showsPrec - -instance GShow Int16 where - gshowsPrec = showsPrec - -instance GShow Int32 where - gshowsPrec = showsPrec - -instance GShow Int64 where - gshowsPrec = showsPrec - -instance GShow Integer where - gshowsPrec = showsPrec - -instance GShow IntPtr where - gshowsPrec = showsPrec - -instance GShow IOError where - gshowsPrec = showsPrec - -instance GShow IOErrorType where - gshowsPrec = showsPrec - -instance GShow IOMode where - gshowsPrec = showsPrec - -instance GShow c => GShow (K1 i c p) where - gshowsPrec = gshowsPrecdefault - -instance GShow a => GShow (Last a) where - gshowsPrec = gshowsPrecdefault - -instance GShow (f p) => GShow (M1 i c f p) where - gshowsPrec = gshowsPrecdefault - -instance GShow a => GShow (Maybe a) where - gshowsPrec = gshowsPrecdefault - -#if MIN_VERSION_base(4,8,0) -instance GShow Natural where - gshowsPrec = showsPrec -#endif - -instance GShow Ordering where - gshowsPrec = gshowsPrecdefault - -instance GShow p => GShow (Par1 p) where - gshowsPrec = gshowsPrecdefault - -instance GShow a => GShow (Product a) where - gshowsPrec = gshowsPrecdefault - -#if MIN_VERSION_base(4,7,0) -instance GShow (Proxy s) where - gshowsPrec = gshowsPrecdefault -#endif - -instance GShow (Ptr a) where - gshowsPrec = showsPrec - -instance GShow (f p) => GShow (Rec1 f p) where - gshowsPrec = gshowsPrecdefault - -instance GShow SeekMode where - gshowsPrec = showsPrec - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPING #-} -#endif - GShow String where - gshowsPrec = showsPrec - -instance GShow a => GShow (Sum a) where - gshowsPrec = gshowsPrecdefault - -instance GShow (U1 p) where - gshowsPrec = gshowsPrecdefault - -#if MIN_VERSION_base(4,8,0) -instance GShow Void where - gshowsPrec = showsPrec -#endif - -instance GShow Word where - gshowsPrec = showsPrec - -instance GShow Word8 where - gshowsPrec = showsPrec - -instance GShow Word16 where - gshowsPrec = showsPrec - -instance GShow Word32 where - gshowsPrec = showsPrec - -instance GShow Word64 where - gshowsPrec = showsPrec - -instance GShow WordPtr where - gshowsPrec = showsPrec - -instance GShow a => GShow (ZipList a) where - gshowsPrec = gshowsPrecdefault +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+#endif++#if __GLASGOW_HASKELL__ < 709+{-# LANGUAGE OverlappingInstances #-}+#endif++module Generics.Deriving.Show (+ -- * Generic show class+ GShow(..)++ -- * Default definition+ , gshowsPrecdefault++ ) where++import Control.Applicative (Const, ZipList)++import Data.Char (GeneralCategory)+import Data.Int+import Data.Monoid (All, Any, Dual, Product, Sum)+import qualified Data.Monoid as Monoid (First, Last)+import Data.Version (Version)+import Data.Word++import Foreign.C.Types+import Foreign.ForeignPtr (ForeignPtr)+import Foreign.Ptr++import Generics.Deriving.Base+import Generics.Deriving.Instances ()++import GHC.Exts hiding (Any)++import System.Exit (ExitCode)+import System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode)+import System.IO.Error (IOErrorType)+import System.Posix.Types++#if MIN_VERSION_base(4,4,0)+import Data.Complex (Complex)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+import Data.Monoid (Alt)+import Data.Void (Void)+import Numeric.Natural (Natural)+#endif++#if MIN_VERSION_base(4,9,0)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg, Max, Min, Option, WrappedMonoid)+#endif++--------------------------------------------------------------------------------+-- Generic show+--------------------------------------------------------------------------------++intersperse :: a -> [a] -> [a]+intersperse _ [] = []+intersperse _ [h] = [h]+intersperse x (h:t) = h : x : (intersperse x t)++appPrec :: Int+appPrec = 2++data Type = Rec | Tup | Pref | Inf String++class GShow' f where+ gshowsPrec' :: Type -> Int -> f a -> ShowS+ isNullary :: f a -> Bool+ isNullary = error "generic show (isNullary): unnecessary case"++instance GShow' U1 where+ gshowsPrec' _ _ U1 = id+ isNullary _ = True++instance (GShow c) => GShow' (K1 i c) where+ gshowsPrec' _ n (K1 a) = gshowsPrec n a+ isNullary _ = False++-- No instances for P or Rec because gshow is only applicable to types of kind *++instance (GShow' a, Constructor c) => GShow' (M1 C c a) where+ gshowsPrec' _ n c@(M1 x) =+ case fixity of+ Prefix -> showParen (n > appPrec && not (isNullary x))+ ( showString (conName c)+ . if (isNullary x) then id else showChar ' '+ . showBraces t (gshowsPrec' t appPrec x))+ Infix _ m -> showParen (n > m) (showBraces t (gshowsPrec' t m x))+ where fixity = conFixity c+ t = if (conIsRecord c) then Rec else+ case (conIsTuple c) of+ True -> Tup+ False -> case fixity of+ Prefix -> Pref+ Infix _ _ -> Inf (show (conName c))+ showBraces :: Type -> ShowS -> ShowS+ showBraces Rec p = showChar '{' . p . showChar '}'+ showBraces Tup p = showChar '(' . p . showChar ')'+ showBraces Pref p = p+ showBraces (Inf _) p = p++ conIsTuple :: C1 c f p -> Bool+ conIsTuple y = tupleName (conName y) where+ tupleName ('(':',':_) = True+ tupleName _ = False++instance (Selector s, GShow' a) => GShow' (M1 S s a) where+ gshowsPrec' t n s@(M1 x) | selName s == "" = --showParen (n > appPrec)+ (gshowsPrec' t n x)+ | otherwise = showString (selName s)+ . showString " = "+ . gshowsPrec' t 0 x+ isNullary (M1 x) = isNullary x++instance (GShow' a) => GShow' (M1 D d a) where+ gshowsPrec' t n (M1 x) = gshowsPrec' t n x++instance (GShow' a, GShow' b) => GShow' (a :+: b) where+ gshowsPrec' t n (L1 x) = gshowsPrec' t n x+ gshowsPrec' t n (R1 x) = gshowsPrec' t n x++instance (GShow' a, GShow' b) => GShow' (a :*: b) where+ gshowsPrec' t@Rec n (a :*: b) =+ gshowsPrec' t n a . showString ", " . gshowsPrec' t n b+ gshowsPrec' t@(Inf s) n (a :*: b) =+ gshowsPrec' t n a . showString s . gshowsPrec' t n b+ gshowsPrec' t@Tup n (a :*: b) =+ gshowsPrec' t n a . showChar ',' . gshowsPrec' t n b+ gshowsPrec' t@Pref n (a :*: b) =+ gshowsPrec' t (n+1) a . showChar ' ' . gshowsPrec' t (n+1) b++ -- If we have a product then it is not a nullary constructor+ isNullary _ = False++-- Unboxed types+instance GShow' UChar where+ gshowsPrec' _ _ (UChar c) = showsPrec 0 (C# c) . showChar '#'+instance GShow' UDouble where+ gshowsPrec' _ _ (UDouble d) = showsPrec 0 (D# d) . showString "##"+instance GShow' UFloat where+ gshowsPrec' _ _ (UFloat f) = showsPrec 0 (F# f) . showChar '#'+instance GShow' UInt where+ gshowsPrec' _ _ (UInt i) = showsPrec 0 (I# i) . showChar '#'+instance GShow' UWord where+ gshowsPrec' _ _ (UWord w) = showsPrec 0 (W# w) . showString "##"+++class GShow a where+ gshowsPrec :: Int -> a -> ShowS+ gshows :: a -> ShowS+ gshows = gshowsPrec 0+ gshow :: a -> String+ gshow x = gshows x ""+#if __GLASGOW_HASKELL__ >= 701+ default gshowsPrec :: (Generic a, GShow' (Rep a))+ => Int -> a -> ShowS+ gshowsPrec = gshowsPrecdefault+#endif++gshowsPrecdefault :: (Generic a, GShow' (Rep a))+ => Int -> a -> ShowS+gshowsPrecdefault n = gshowsPrec' Pref n . from+++-- Base types instances+-- Base types instances+instance GShow () where+ gshowsPrec = gshowsPrecdefault++instance (GShow a, GShow b) => GShow (a, b) where+ gshowsPrec = gshowsPrecdefault++instance (GShow a, GShow b, GShow c) => GShow (a, b, c) where+ gshowsPrec = gshowsPrecdefault++instance (GShow a, GShow b, GShow c, GShow d) => GShow (a, b, c, d) where+ gshowsPrec = gshowsPrecdefault++instance (GShow a, GShow b, GShow c, GShow d, GShow e) => GShow (a, b, c, d, e) where+ gshowsPrec = gshowsPrecdefault++instance (GShow a, GShow b, GShow c, GShow d, GShow e, GShow f)+ => GShow (a, b, c, d, e, f) where+ gshowsPrec = gshowsPrecdefault++instance (GShow a, GShow b, GShow c, GShow d, GShow e, GShow f, GShow g)+ => GShow (a, b, c, d, e, f, g) where+ gshowsPrec = gshowsPrecdefault++instance+#if __GLASGOW_HASKELL__ >= 709+ {-# OVERLAPPABLE #-}+#endif+ (GShow a) => GShow [a] where+ gshowsPrec _ l = showChar '['+ . foldr (.) id+ (intersperse (showChar ',') (map (gshowsPrec 0) l))+ . showChar ']'++instance (GShow (f p), GShow (g p)) => GShow ((f :+: g) p) where+ gshowsPrec = gshowsPrecdefault++instance (GShow (f p), GShow (g p)) => GShow ((f :*: g) p) where+ gshowsPrec = gshowsPrecdefault++instance GShow (f (g p)) => GShow ((f :.: g) p) where+ gshowsPrec = gshowsPrecdefault++instance GShow All where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,8,0)+instance GShow (f a) => GShow (Alt f a) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow Any where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,9,0)+instance (GShow a, GShow b) => GShow (Arg a b) where+ gshowsPrec = gshowsPrecdefault+#endif++#if !(MIN_VERSION_base(4,9,0))+instance GShow Arity where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow Associativity where+ gshowsPrec = gshowsPrecdefault++instance GShow Bool where+ gshowsPrec = gshowsPrecdefault++instance GShow BufferMode where+ gshowsPrec = showsPrec++#if defined(HTYPE_CC_T)+instance GShow CCc where+ gshowsPrec = showsPrec+#endif++instance GShow CChar where+ gshowsPrec = showsPrec++instance GShow CClock where+ gshowsPrec = showsPrec++#if defined(HTYPE_DEV_T)+instance GShow CDev where+ gshowsPrec = showsPrec+#endif++instance GShow CDouble where+ gshowsPrec = showsPrec++instance GShow CFloat where+ gshowsPrec = showsPrec++#if defined(HTYPE_GID_T)+instance GShow CGid where+ gshowsPrec = showsPrec+#endif++instance GShow Char where+ gshowsPrec = showsPrec++#if defined(HTYPE_INO_T)+instance GShow CIno where+ gshowsPrec = showsPrec+#endif++instance GShow CInt where+ gshowsPrec = showsPrec++instance GShow CIntMax where+ gshowsPrec = showsPrec++instance GShow CIntPtr where+ gshowsPrec = showsPrec++instance GShow CLLong where+ gshowsPrec = showsPrec++instance GShow CLong where+ gshowsPrec = showsPrec++#if defined(HTYPE_MODE_T)+instance GShow CMode where+ gshowsPrec = showsPrec+#endif++#if defined(HTYPE_NLINK_T)+instance GShow CNlink where+ gshowsPrec = showsPrec+#endif++#if defined(HTYPE_OFF_T)+instance GShow COff where+ gshowsPrec = showsPrec+#endif++#if MIN_VERSION_base(4,4,0)+instance GShow a => GShow (Complex a) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow a => GShow (Const a b) where+ gshowsPrec = gshowsPrecdefault++#if defined(HTYPE_PID_T)+instance GShow CPid where+ gshowsPrec = showsPrec+#endif++instance GShow CPtrdiff where+ gshowsPrec = showsPrec++#if defined(HTYPE_RLIM_T)+instance GShow CRLim where+ gshowsPrec = showsPrec+#endif++instance GShow CSChar where+ gshowsPrec = showsPrec++#if defined(HTYPE_SPEED_T)+instance GShow CSpeed where+ gshowsPrec = showsPrec+#endif++#if MIN_VERSION_base(4,4,0)+instance GShow CSUSeconds where+ gshowsPrec = showsPrec+#endif++instance GShow CShort where+ gshowsPrec = showsPrec++instance GShow CSigAtomic where+ gshowsPrec = showsPrec++instance GShow CSize where+ gshowsPrec = showsPrec++#if defined(HTYPE_SSIZE_T)+instance GShow CSsize where+ gshowsPrec = showsPrec+#endif++#if defined(HTYPE_TCFLAG_T)+instance GShow CTcflag where+ gshowsPrec = showsPrec+#endif++instance GShow CTime where+ gshowsPrec = showsPrec++instance GShow CUChar where+ gshowsPrec = showsPrec++#if defined(HTYPE_UID_T)+instance GShow CUid where+ gshowsPrec = showsPrec+#endif++instance GShow CUInt where+ gshowsPrec = showsPrec++instance GShow CUIntMax where+ gshowsPrec = showsPrec++instance GShow CUIntPtr where+ gshowsPrec = showsPrec++instance GShow CULLong where+ gshowsPrec = showsPrec++instance GShow CULong where+ gshowsPrec = showsPrec++#if MIN_VERSION_base(4,4,0)+instance GShow CUSeconds where+ gshowsPrec = showsPrec+#endif++instance GShow CUShort where+ gshowsPrec = showsPrec++instance GShow CWchar where+ gshowsPrec = showsPrec++instance GShow Double where+ gshowsPrec = showsPrec++instance GShow a => GShow (Dual a) where+ gshowsPrec = gshowsPrecdefault++instance (GShow a, GShow b) => GShow (Either a b) where+ gshowsPrec = gshowsPrecdefault++instance GShow ExitCode where+ gshowsPrec = gshowsPrecdefault++instance GShow Fd where+ gshowsPrec = showsPrec++instance GShow a => GShow (Monoid.First a) where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,9,0)+instance GShow a => GShow (Semigroup.First a) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow Fixity where+ gshowsPrec = gshowsPrecdefault++instance GShow Float where+ gshowsPrec = showsPrec++instance GShow (ForeignPtr a) where+ gshowsPrec = showsPrec++instance GShow (FunPtr a) where+ gshowsPrec = showsPrec++instance GShow GeneralCategory where+ gshowsPrec = showsPrec++instance GShow Handle where+ gshowsPrec = showsPrec++instance GShow HandlePosn where+ gshowsPrec = showsPrec++#if MIN_VERSION_base(4,8,0)+instance GShow a => GShow (Identity a) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow Int where+ gshowsPrec = showsPrec++instance GShow Int8 where+ gshowsPrec = showsPrec++instance GShow Int16 where+ gshowsPrec = showsPrec++instance GShow Int32 where+ gshowsPrec = showsPrec++instance GShow Int64 where+ gshowsPrec = showsPrec++instance GShow Integer where+ gshowsPrec = showsPrec++instance GShow IntPtr where+ gshowsPrec = showsPrec++instance GShow IOError where+ gshowsPrec = showsPrec++instance GShow IOErrorType where+ gshowsPrec = showsPrec++instance GShow IOMode where+ gshowsPrec = showsPrec++instance GShow c => GShow (K1 i c p) where+ gshowsPrec = gshowsPrecdefault++instance GShow a => GShow (Monoid.Last a) where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,9,0)+instance GShow a => GShow (Semigroup.Last a) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow (f p) => GShow (M1 i c f p) where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,9,0)+instance GShow a => GShow (Max a) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow a => GShow (Maybe a) where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,9,0)+instance GShow a => GShow (Min a) where+ gshowsPrec = gshowsPrecdefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GShow Natural where+ gshowsPrec = showsPrec+#endif++#if MIN_VERSION_base(4,9,0)+instance GShow a => GShow (NonEmpty a) where+ gshowsPrec = gshowsPrecdefault++instance GShow a => GShow (Option a) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow Ordering where+ gshowsPrec = gshowsPrecdefault++instance GShow p => GShow (Par1 p) where+ gshowsPrec = gshowsPrecdefault++instance GShow a => GShow (Product a) where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,7,0)+instance GShow (Proxy s) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow (Ptr a) where+ gshowsPrec = showsPrec++instance GShow (f p) => GShow (Rec1 f p) where+ gshowsPrec = gshowsPrecdefault++instance GShow SeekMode where+ gshowsPrec = showsPrec++instance+#if __GLASGOW_HASKELL__ >= 709+ {-# OVERLAPPING #-}+#endif+ GShow String where+ gshowsPrec = showsPrec++instance GShow a => GShow (Sum a) where+ gshowsPrec = gshowsPrecdefault++instance GShow (U1 p) where+ gshowsPrec = gshowsPrecdefault++instance GShow (UChar p) where+ gshowsPrec = gshowsPrecdefault++instance GShow (UDouble p) where+ gshowsPrec = gshowsPrecdefault++instance GShow (UFloat p) where+ gshowsPrec = gshowsPrecdefault++instance GShow (UInt p) where+ gshowsPrec = gshowsPrecdefault++instance GShow (UWord p) where+ gshowsPrec = gshowsPrecdefault++instance GShow Version where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,8,0)+instance GShow Void where+ gshowsPrec = showsPrec+#endif++instance GShow Word where+ gshowsPrec = showsPrec++instance GShow Word8 where+ gshowsPrec = showsPrec++instance GShow Word16 where+ gshowsPrec = showsPrec++instance GShow Word32 where+ gshowsPrec = showsPrec++instance GShow Word64 where+ gshowsPrec = showsPrec++instance GShow WordPtr where+ gshowsPrec = showsPrec++#if MIN_VERSION_base(4,9,0)+instance GShow m => GShow (WrappedMonoid m) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow a => GShow (ZipList a) where+ gshowsPrec = gshowsPrecdefault
src/Generics/Deriving/TH.hs view
@@ -1,1072 +1,1131 @@-{-# LANGUAGE CPP #-}---------------------------------------------------------------------------------- |--- Module : Generics.Deriving.TH--- Copyright : (c) 2008--2009 Universiteit Utrecht--- License : BSD3------ Maintainer : generics@haskell.org--- Stability : experimental--- Portability : non-portable------ This module contains Template Haskell code that can be used to--- automatically generate the boilerplate code for the generic deriving--- library.------ To use these functions, pass the name of a data type as an argument:------ @--- {-# LANGUAGE TemplateHaskell #-}------ data Example a = Example Int Char a--- $('deriveAll0' ''Example) -- Derives Generic instance--- $('deriveAll1' ''Example) -- Derives Generic1 instance--- $('deriveAll0And1' ''Example) -- Derives Generic and Generic1 instances--- @------ On GHC 7.4 or later, this code can also be used with data families. To derive--- for a data family instance, pass the name of one of the instance's constructors:------ @--- {-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-}------ data family Family a b--- newtype instance Family Char b = FamilyChar Char--- data instance Family Bool b = FamilyTrue | FamilyFalse------ $('deriveAll0' 'FamilyChar) -- instance Generic (Family Char b) where ...--- $('deriveAll1' 'FamilyTrue) -- instance Generic1 (Family Bool) where ...--- -- Alternatively, one could type $(deriveAll1 'FamilyFalse)--- @------ If you are deriving for data family instances, be aware of a bug on GHC--- 7.8 (<https://ghc.haskell.org/trac/ghc/ticket/9692 Trac #9692>) which can--- cause incorrectly derived 'Generic1' instances if a data family--- declaration and one of its instances use different type variables:------ @--- data family Foo a b c--- data instance Foo Int y z = Foo Int y z--- $(deriveAll1 'Foo)--- @------ To avoid this issue, it is recommened that you use the same type variables--- in the same positions in which they appeared in the data family declaration:------ @--- data family Foo a b c--- data instance Foo Int b c = Foo Int b c--- $(deriveAll1 'Foo)--- @---------------------------------------------------------------------------------- Adapted from Generics.Regular.TH-module Generics.Deriving.TH (-- deriveMeta- , deriveData- , deriveConstructors- , deriveSelectors-- , deriveAll- , deriveAll1- , deriveAll0And1- , deriveRepresentable0- , deriveRepresentable1- , deriveRep0- , deriveRep1- , simplInstance- -- * @make@- functions- -- $make- , makeRep0- , makeFrom- , makeTo- , makeRep1- , makeFrom1- , makeTo1- ) where--import Data.Char (isAlphaNum, ord)-import Data.List-#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710-import qualified Data.Map as Map-import Data.Map as Map (Map)-#endif-#if __GLASGOW_HASKELL__ >= 706 && __GLASGOW_HASKELL__ < 710-import qualified Data.Set as Set-import Data.Set (Set)-#endif--import Generics.Deriving.Base-import Generics.Deriving.TH.Internal--import Language.Haskell.TH.Lib-import Language.Haskell.TH.Syntax (Name(..), NameFlavour(..), Lift(..),- modString, pkgString)-import Language.Haskell.TH hiding (Fixity())---- | 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 . tyVarBndrToName) (ConT (genRepName 0 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)))) []]]----- | Given the type and the name (as string) for the type to derive,--- generate the 'Data' instance, the 'Constructor' instances, the 'Selector'--- instances, and the 'Representable0' instance.-deriveAll :: Name -> Q [Dec]-deriveAll n =- do a <- deriveMeta n- b <- deriveRepresentable0 n- return (a ++ b)---- | Given the type and the name (as string) for the type to derive,--- generate the 'Data' instance, the 'Constructor' instances, the 'Selector'--- instances, and the 'Representable1' instance.-deriveAll1 :: Name -> Q [Dec]-deriveAll1 n =- do a <- deriveMeta n- b <- deriveRepresentable1 n- return (a ++ b)---- | Given the type and the name (as string) for the type to derive,--- generate the 'Data' instance, the 'Constructor' instances, the 'Selector'--- instances, the 'Representable0' instance, and the 'Representable1' instance.-deriveAll0And1 :: Name -> Q [Dec]-deriveAll0And1 n =- do a <- deriveMeta n- b <- deriveRepresentable0 n- c <- deriveRepresentable1 n- return (a ++ b ++ c)---- | Given the type and the name (as string) for the type to derive,--- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector'--- instances.-deriveMeta :: Name -> Q [Dec]-deriveMeta n =- do a <- deriveData n- b <- deriveConstructors n- c <- deriveSelectors n- return (a ++ b ++ c)---- | Given a datatype name, derive a datatype and instance of class 'Datatype'.-deriveData :: Name -> Q [Dec]-deriveData = dataInstance---- | Given a datatype name, derive datatypes and--- instances of class 'Constructor'.-deriveConstructors :: Name -> Q [Dec]-deriveConstructors = constrInstance---- | Given a datatype name, derive datatypes and instances of class 'Selector'.-deriveSelectors :: Name -> Q [Dec]-deriveSelectors = selectInstance---- | Given the type and the name (as string) for the Representable0 type--- synonym to derive, generate the 'Representable0' instance.-deriveRepresentable0 :: Name -> Q [Dec]-deriveRepresentable0 n = do- rep0 <- deriveRep0 n- inst <- deriveInst n- return $ rep0 ++ inst---- | Given the type and the name (as string) for the Representable1 type--- synonym to derive, generate the 'Representable1' instance.-deriveRepresentable1 :: Name -> Q [Dec]-deriveRepresentable1 n = do- rep1 <- deriveRep1 n- inst1 <- deriveInst1 n- return $ rep1 ++ inst1---- | Derive only the 'Rep0' type synonym. Not needed if 'deriveRepresentable0'--- is used.-deriveRep0 :: Name -> Q [Dec]-deriveRep0 = deriveRepCommon 0---- | Derive only the 'Rep1' type synonym. Not needed if 'deriveRepresentable1'--- is used.-deriveRep1 :: Name -> Q [Dec]-deriveRep1 = deriveRepCommon 1--deriveRepCommon :: Int -> Name -> Q [Dec]-deriveRepCommon arity n = do- i <- reifyDataInfo n- let (name, _, allTvbs, cons, dv) = either error id i- (tvbs, _, gk) = buildTypeInstance arity name allTvbs cons dv-- fmap (:[]) $ tySynD (genRepName arity dv name)- (map unKindedTV tvbs) -- The typechecker will infer the kinds of- -- the TyVarBndrs in a type synonym- -- declaration, so we don't need to- -- splice them explicitly- (repType gk dv name cons)--deriveInst :: Name -> Q [Dec]-deriveInst = deriveInstCommon genericTypeName repTypeName 0 fromValName toValName--deriveInst1 :: Name -> Q [Dec]-deriveInst1 = deriveInstCommon generic1TypeName rep1TypeName 1 from1ValName to1ValName--deriveInstCommon :: Name -> Name -> Int -> Name -> Name -> Name -> Q [Dec]-deriveInstCommon genericName repName arity fromName toName n = do- i <- reifyDataInfo n- let (name, _, allTvbs, cons, dv) = either error id i- (tvbs, origTy, gk) = buildTypeInstance arity name allTvbs cons dv- repTy = applyTyToTvbs (genRepName arity dv name) tvbs-#if __GLASGOW_HASKELL__ >= 707- tyIns = TySynInstD repName (TySynEqn [origTy] repTy)-#else- tyIns = TySynInstD repName [origTy] repTy-#endif- mkBody maker = [clause [] (normalB $ mkCaseExp gk name cons maker) []]- fcs = mkBody mkFrom- tcs = mkBody mkTo-- fmap (:[]) $- instanceD (cxt []) (conT genericName `appT` return origTy)- [return tyIns, funD fromName fcs, funD toName tcs]--{- $make--There are some data types for which the Template Haskell deriver functions in-this module are not sophisticated enough to infer the correct 'Generic' or-'Generic1' instances. As an example, consider this data type:--@-data Fix f a = Fix (f (Fix f a))-@--A proper 'Generic1' instance would look like this:--@-instance Functor f => Generic1 (Fix f) where ...-@--Unfortunately, 'deriveRepresentable1' cannot infer the @Functor f@ constraint.-One can still define a 'Generic1' instance for @Fix@, however, by using the-functions in this module that are prefixed with @make@-. For example:--@-$('deriveMeta' ''Fix)-$('deriveRep1' ''Fix)-instance Functor f => Generic1 (Fix f) where- type Rep1 (Fix f) = $('makeRep1' ''Fix) f- from1 = $('makeFrom1' ''Fix)- to1 = $('makeTo1' ''Fix)-@--Note that due to the lack of type-level lambdas in Haskell, one must manually-apply @$('makeRep1' ''Fix)@ to the type parameters of @Fix@ (@f@ in the above-example).---}---- | Generates the 'Rep0' type synonym constructor (as opposed to 'deriveRep0',--- which generates the type synonym declaration).-makeRep0 :: Name -> Q Type-makeRep0 = makeRepCommon 0---- | Generates the 'Rep1' type synonym constructor (as opposed to 'deriveRep1',--- which generates the type synonym declaration).-makeRep1 :: Name -> Q Type-makeRep1 = makeRepCommon 1--makeRepCommon :: Int -> Name -> Q Type-makeRepCommon arity n = do- i <- reifyDataInfo n- case i of- Left msg -> error msg- Right (name, _, _, _, dv) -> conT $ genRepName arity dv name---- | Generates a lambda expression which behaves like 'from'.-makeFrom :: Name -> Q Exp-makeFrom = makeFunCommon mkFrom 0---- | Generates a lambda expression which behaves like 'to'.-makeTo :: Name -> Q Exp-makeTo = makeFunCommon mkTo 0---- | Generates a lambda expression which behaves like 'from1'.-makeFrom1 :: Name -> Q Exp-makeFrom1 = makeFunCommon mkFrom 1---- | Generates a lambda expression which behaves like 'to1'.-makeTo1 :: Name -> Q Exp-makeTo1 = makeFunCommon mkTo 1--makeFunCommon :: (GenericKind -> Int -> Int -> Name -> [Con] -> [Q Match])- -> Int -> Name -> Q Exp-makeFunCommon maker arity n = do- i <- reifyDataInfo n- let (name, _, allTvbs, cons, dv) = either error id i- (_, _, gk) = buildTypeInstance arity name allTvbs cons dv- mkCaseExp gk name cons maker--dataInstance :: Name -> Q [Dec]-dataInstance n = do- i <- reifyDataInfo n- case i of- Left _ -> return []- Right (n', isNT, _, _, dv) -> mkInstance n' dv isNT- where- mkInstance n' dv isNT = do- ds <- mkDataData dv n'- is <- mkDataInstance dv n' isNT- return $ [ds,is]--constrInstance :: Name -> Q [Dec]-constrInstance n = do- i <- reifyDataInfo n- case i of- Left _ -> return []- Right (n', _, _, cs, dv) -> mkInstance n' cs dv- where- mkInstance n' cs dv = do- ds <- mapM (mkConstrData dv n') cs- is <- mapM (mkConstrInstance dv n') cs- return $ ds ++ is--selectInstance :: Name -> Q [Dec]-selectInstance n = do- i <- reifyDataInfo n- case i of- Left _ -> return []- Right (n', _, _, cs, dv) -> mkInstance n' cs dv- where- mkInstance n' cs dv = do- ds <- mapM (mkSelectData dv n') cs- is <- mapM (mkSelectInstance dv n') cs- return $ concat (ds ++ is)--genName :: DataVariety -> [Name] -> Name-genName dv ns = mkName- . showsDataVariety dv- . intercalate "_"- . consQualName- $ map (sanitizeName . nameBase) ns- where- consQualName :: [String] -> [String]- consQualName = case ns of- [] -> id- n:_ -> (showNameQual n :)--genRepName :: Int -> DataVariety -> Name -> Name-genRepName arity dv n = mkName- . showsDataVariety dv- . (("Rep" ++ show arity) ++)- . ((showNameQual n ++ "_") ++)- . sanitizeName- $ nameBase n--showsDataVariety :: DataVariety -> ShowS-showsDataVariety dv = (++ '_':label dv)- where- label DataPlain = "Plain"- label (DataFamily n _) = "Family_" ++ sanitizeName (nameBase n)--showNameQual :: Name -> String-showNameQual = sanitizeName . showQual- where- showQual (Name _ (NameQ m)) = modString m- showQual (Name _ (NameG _ pkg m)) = pkgString pkg ++ ":" ++ modString m- showQual _ = ""---- | Credit to Víctor López Juan for this trick-sanitizeName :: String -> String-sanitizeName nb = 'N':(- nb >>= \x -> case x of- c | isAlphaNum c || c == '\''-> [c]- '_' -> "__"- c -> "_" ++ show (ord c))--mkDataData :: DataVariety -> Name -> Q Dec-mkDataData dv n = dataD (cxt []) (genName dv [n]) [] [] []--mkConstrData :: DataVariety -> Name -> Con -> Q Dec-mkConstrData dv dt (NormalC n _) =- dataD (cxt []) (genName dv [dt, n]) [] [] []-mkConstrData dv dt r@(RecC _ _) =- mkConstrData dv dt (stripRecordNames r)-mkConstrData dv dt (InfixC t1 n t2) =- mkConstrData dv dt (NormalC n [t1,t2])-mkConstrData _ _ (ForallC _ _ con) = forallCError con--mkSelectData :: DataVariety -> Name -> Con -> Q [Dec]-mkSelectData dv dt (RecC n fs) = return (map one fs)- where one (f, _, _) = DataD [] (genName dv [dt, n, f]) [] [] []-mkSelectData _ _ _ = return []---mkDataInstance :: DataVariety -> Name -> Bool -> Q Dec-mkDataInstance dv n _isNewtype =- instanceD (cxt []) (appT (conT datatypeTypeName) (conT $ genName dv [n])) $- [ funD datatypeNameValName [clause [wildP] (normalB (stringE (nameBase n))) []]- , funD moduleNameValName [clause [wildP] (normalB (stringE name)) []]-#if __GLASGOW_HASKELL__ >= 711- , funD packageNameValName [clause [wildP] (normalB (stringE pkgName)) []]-#endif- ]-#if __GLASGOW_HASKELL__ >= 708- ++ if _isNewtype- then [funD isNewtypeValName [clause [wildP] (normalB (conE trueDataName)) []]]- else []-#endif- where- name = maybe (error "Cannot fetch module name!") id (nameModule n)-#if __GLASGOW_HASKELL__ >= 711- pkgName = maybe (error "Cannot fetch package name!") id (namePackage n)-#endif--liftFixity :: Fixity -> Q Exp-liftFixity Prefix = conE prefixDataName-liftFixity (Infix a n) = conE infixDataName- `appE` liftAssociativity a- `appE` lift n--liftAssociativity :: Associativity -> Q Exp-liftAssociativity LeftAssociative = conE leftAssociativeDataName-liftAssociativity RightAssociative = conE rightAssociativeDataName-liftAssociativity NotAssociative = conE notAssociativeDataName--mkConstrInstance :: DataVariety -> Name -> Con -> Q Dec-mkConstrInstance dv dt (NormalC n _) = mkConstrInstanceWith dv dt n []-mkConstrInstance dv dt (RecC n _) = mkConstrInstanceWith dv dt n- [ funD conIsRecordValName [clause [wildP] (normalB (conE trueDataName)) []]]-mkConstrInstance dv dt (InfixC _ n _) =- do- i <- reify n-#if __GLASGOW_HASKELL__ >= 711- fi <- case i of- DataConI{} -> fmap convertFixity $ reifyFixity n- _ -> return Prefix-#else- let fi = case i of- DataConI _ _ _ f -> convertFixity f- _ -> Prefix-#endif- instanceD (cxt []) (appT (conT constructorTypeName) (conT $ genName dv [dt, n]))- [funD conNameValName [clause [wildP] (normalB (stringE (nameBase n))) []],- funD conFixityValName [clause [wildP] (normalB (liftFixity fi)) []]]- where- convertFixity (Fixity n' d) = Infix (convertDirection d) n'- convertDirection InfixL = LeftAssociative- convertDirection InfixR = RightAssociative- convertDirection InfixN = NotAssociative-mkConstrInstance _ _ (ForallC _ _ con) = forallCError con--mkConstrInstanceWith :: DataVariety -> Name -> Name -> [Q Dec] -> Q Dec-mkConstrInstanceWith dv dt n extra =- instanceD (cxt []) (appT (conT constructorTypeName) (conT $ genName dv [dt, n]))- (funD conNameValName [clause [wildP] (normalB (stringE (nameBase n))) []] : extra)--mkSelectInstance :: DataVariety -> Name -> Con -> Q [Dec]-mkSelectInstance dv dt (RecC n fs) = return (map one fs) where- one (f, _, _) =- InstanceD ([]) (AppT (ConT selectorTypeName) (ConT $ genName dv [dt, n, f]))- [FunD selNameValName [Clause [WildP]- (NormalB (LitE (StringL (nameBase f)))) []]]-mkSelectInstance _ _ _ = return []--repType :: GenericKind -> DataVariety -> Name -> [Con] -> Q Type-repType gk dv dt cs =- conT d1TypeName `appT` (conT $ genName dv [dt]) `appT`- foldr1' sum' (conT v1TypeName)- (map (repCon gk dv dt) cs)- where- sum' :: Q Type -> Q Type -> Q Type- sum' a b = conT sumTypeName `appT` a `appT` b--repCon :: GenericKind -> DataVariety -> Name -> Con -> Q Type-repCon _ dv dt (NormalC n []) =- conT c1TypeName `appT` (conT $ genName dv [dt, n]) `appT`- (conT s1TypeName `appT` conT noSelectorTypeName `appT` conT u1TypeName)-repCon gk dv dt (NormalC n fs) =- conT c1TypeName `appT` (conT $ genName dv [dt, n]) `appT`- (foldr1 prod (map (repField gk . snd) fs)) where- prod :: Q Type -> Q Type -> Q Type- prod a b = conT productTypeName `appT` a `appT` b-repCon _ dv dt (RecC n []) =- conT c1TypeName `appT` (conT $ genName dv [dt, n]) `appT` conT u1TypeName-repCon gk dv dt (RecC n fs) =- conT c1TypeName `appT` (conT $ genName dv [dt, n]) `appT`- (foldr1 prod (map (repField' gk dv dt n) fs)) where- prod :: Q Type -> Q Type -> Q Type- prod a b = conT productTypeName `appT` a `appT` b--repCon gk dv dt (InfixC t1 n t2) = repCon gk dv dt (NormalC n [t1,t2])-repCon _ _ _ (ForallC _ _ con) = forallCError con----dataDeclToType :: (Name, [Name]) -> Type---dataDeclToType (dt, vs) = foldl (\a b -> AppT a (VarT b)) (ConT dt) vs--repField :: GenericKind -> Type -> Q Type---repField d t | t == dataDeclToType d = conT ''I-repField gk t = conT s1TypeName `appT` conT noSelectorTypeName `appT`- (repFieldArg gk =<< expandSyn t)--repField' :: GenericKind -> DataVariety -> Name -> Name -> (Name, Strict, Type) -> Q Type---repField' d ns (_, _, t) | t == dataDeclToType d = conT ''I-repField' gk dv dt ns (f, _, t) = conT s1TypeName- `appT` conT (genName dv [dt, ns, f])- `appT` (repFieldArg gk =<< expandSyn t)--- Note: we should generate Par0 too, at some point--repFieldArg :: GenericKind -> Type -> Q Type-repFieldArg _ ForallT{} = rankNError-repFieldArg gk (SigT t _) = repFieldArg gk t-repFieldArg Gen0 t = boxT t-repFieldArg (Gen1 nb) (VarT t) | NameBase t == nb = conT par1TypeName-repFieldArg gk@(Gen1 nb) t = do- let tyHead:tyArgs = unapplyTy t- numLastArgs = min 1 $ length tyArgs- (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs- rec0Type = boxT t- phiType = return $ applyTyToTys tyHead lhsArgs-- inspectTy :: Type -> Q Type- inspectTy (VarT a)- | NameBase a == nb- = conT rec1TypeName `appT` phiType- inspectTy (SigT ty _) = inspectTy ty- inspectTy beta- | not (ground beta nb)- = conT composeTypeName `appT` phiType- `appT` repFieldArg gk beta- inspectTy _ = rec0Type-- itf <- isTyFamily tyHead- if any (not . (`ground` nb)) lhsArgs- || any (not . (`ground` nb)) tyArgs && itf- then outOfPlaceTyVarError- else case rhsArgs of- [] -> rec0Type- ty:_ -> inspectTy ty--boxT :: Type -> Q Type-boxT ty = case unboxedRepNames ty of- Just (boxTyName, _, _) -> conT boxTyName- Nothing -> conT rec0TypeName `appT` return ty--mkCaseExp :: GenericKind -> Name -> [Con]- -> (GenericKind -> Int -> Int -> Name -> [Con] -> [Q Match])- -> Q Exp-mkCaseExp gk dt cs matchmaker = do- val <- newName "val"- lam1E (varP val) $ caseE (varE val) $ matchmaker gk 1 0 dt cs--mkFrom :: GenericKind -> Int -> Int -> Name -> [Con] -> [Q Match]-mkFrom _ _ _ dt [] = [errorFrom dt]-mkFrom gk m i _ cs = zipWith (fromCon gk wrapE (length cs)) [0..] cs- where- wrapE e = lrE m i e--errorFrom :: Name -> Q Match-errorFrom dt =- match- wildP- (normalB $ appE (conE m1DataName) $ varE errorValName `appE` stringE- ("No generic representation for empty datatype " ++ nameBase dt))- []--errorTo :: Name -> Q Match-errorTo dt =- match- (conP m1DataName [wildP])- (normalB $ varE errorValName `appE` stringE- ("No values for empty datatype " ++ nameBase dt))- []--mkTo :: GenericKind -> Int -> Int -> Name -> [Con] -> [Q Match]-mkTo _ _ _ dt [] = [errorTo dt]-mkTo gk m i _ cs = zipWith (toCon gk wrapP (length cs)) [0..] cs- where- wrapP p = lrP m i p--fromCon :: GenericKind -> (Q Exp -> Q Exp) -> Int -> Int -> Con -> Q Match-fromCon _ wrap m i (NormalC cn []) =- match- (conP cn [])- (normalB $ appE (conE m1DataName) $ wrap $ lrE m i $ appE (conE m1DataName) $- conE m1DataName `appE` (conE u1DataName)) []-fromCon gk wrap m i (NormalC cn fs) =- -- runIO (putStrLn ("constructor " ++ show ix)) >>- match- (conP cn (map (varP . field) [0..length fs - 1]))- (normalB $ appE (conE m1DataName) $ wrap $ lrE m i $ conE m1DataName `appE`- foldr1 prod (zipWith (fromField gk) [0..] (map snd fs))) []- where prod x y = conE productDataName `appE` x `appE` y-fromCon _ wrap m i (RecC cn []) =- match- (conP cn [])- (normalB $ appE (conE m1DataName)- $ wrap $ lrE m i $ conE m1DataName `appE` (conE u1DataName)) []-fromCon gk wrap m i (RecC cn fs) =- match- (conP cn (map (varP . field) [0..length fs - 1]))- (normalB $ appE (conE m1DataName) $ wrap $ lrE m i $ conE m1DataName `appE`- foldr1 prod (zipWith (fromField gk) [0..] (map trd fs))) []- where prod x y = conE productDataName `appE` x `appE` y-fromCon gk wrap m i (InfixC t1 cn t2) =- fromCon gk wrap m i (NormalC cn [t1,t2])-fromCon _ _ _ _ (ForallC _ _ con) = forallCError con--fromField :: GenericKind -> Int -> Type -> Q Exp---fromField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conE 'I `appE` varE (field nr)-fromField gk nr t = conE m1DataName `appE` (fromFieldWrap gk nr =<< expandSyn t)--fromFieldWrap :: GenericKind -> Int -> Type -> Q Exp-fromFieldWrap _ _ ForallT{} = rankNError-fromFieldWrap gk nr (SigT t _) = fromFieldWrap gk nr t-fromFieldWrap Gen0 nr t = conE (boxRepName t) `appE` varE (field nr)-fromFieldWrap (Gen1 nb) nr t = wC t nb `appE` varE (field nr)--wC :: Type -> NameBase -> Q Exp-wC (VarT n) nb | NameBase n == nb = conE par1DataName-wC t nb- | ground t nb = conE $ boxRepName t- | otherwise = do- let tyHead:tyArgs = unapplyTy t- numLastArgs = min 1 $ length tyArgs- (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs-- inspectTy :: Type -> Q Exp- inspectTy ForallT{} = rankNError- inspectTy (SigT ty _) = inspectTy ty- inspectTy (VarT a)- | NameBase a == nb- = conE rec1DataName- inspectTy beta = infixApp (conE comp1DataName)- (varE composeValName)- (varE fmapValName `appE` wC beta nb)-- itf <- isTyFamily tyHead- if any (not . (`ground` nb)) lhsArgs- || any (not . (`ground` nb)) tyArgs && itf- then outOfPlaceTyVarError- else case rhsArgs of- [] -> conE $ boxRepName t- ty:_ -> inspectTy ty--boxRepName :: Type -> Name-boxRepName = maybe k1DataName (\(_, boxName, _) -> boxName) . unboxedRepNames--toCon :: GenericKind -> (Q Pat -> Q Pat) -> Int -> Int -> Con -> Q Match-toCon _ wrap m i (NormalC cn []) =- match- (wrap $ conP m1DataName [lrP m i $ conP m1DataName- [conP m1DataName [conP u1DataName []]]])- (normalB $ conE cn) []-toCon gk wrap m i (NormalC cn fs) =- -- runIO (putStrLn ("constructor " ++ show ix)) >>- match- (wrap $ conP m1DataName [lrP m i $ conP m1DataName- [foldr1 prod (zipWith (\nr -> toField gk nr . snd) [0..] fs)]])- (normalB $ foldl appE (conE cn) (zipWith (\nr t -> expandSyn t >>= toConUnwC gk nr)- [0..] (map snd fs))) []- where prod x y = conP productDataName [x,y]-toCon _ wrap m i (RecC cn []) =- match- (wrap $ conP m1DataName [lrP m i $ conP m1DataName [conP u1DataName []]])- (normalB $ conE cn) []-toCon gk wrap m i (RecC cn fs) =- match- (wrap $ conP m1DataName [lrP m i $ conP m1DataName- [foldr1 prod (zipWith (\nr (_, _, t) -> toField gk nr t) [0..] fs)]])- (normalB $ foldl appE (conE cn) (zipWith (\nr t -> expandSyn t >>= toConUnwC gk nr)- [0..] (map trd fs))) []- where prod x y = conP productDataName [x,y]-toCon gk wrap m i (InfixC t1 cn t2) =- toCon gk wrap m i (NormalC cn [t1,t2])-toCon _ _ _ _ (ForallC _ _ con) = forallCError con--toConUnwC :: GenericKind -> Int -> Type -> Q Exp-toConUnwC Gen0 nr _ = varE $ field nr-toConUnwC (Gen1 nb) nr t = unwC t nb `appE` varE (field nr)--toField :: GenericKind -> Int -> Type -> Q Pat---toField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conP 'I [varP (field nr)]-toField gk nr t = conP m1DataName [toFieldWrap gk nr t]--toFieldWrap :: GenericKind -> Int -> Type -> Q Pat-toFieldWrap Gen0 nr t = conP (boxRepName t) [varP (field nr)]-toFieldWrap (Gen1 _) nr _ = varP (field nr)--field :: Int -> Name-field n = mkName $ "f" ++ show n--unwC :: Type -> NameBase -> Q Exp-unwC (SigT t _) nb = unwC t nb-unwC (VarT n) nb | NameBase n == nb = varE unPar1ValName-unwC t nb- | ground t nb = varE $ unboxRepName t- | otherwise = do- let tyHead:tyArgs = unapplyTy t- numLastArgs = min 1 $ length tyArgs- (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs-- inspectTy :: Type -> Q Exp- inspectTy ForallT{} = rankNError- inspectTy (SigT ty _) = inspectTy ty- inspectTy (VarT a)- | NameBase a == nb- = varE unRec1ValName- inspectTy beta = infixApp (varE fmapValName `appE` unwC beta nb)- (varE composeValName)- (varE unComp1ValName)-- itf <- isTyFamily tyHead- if any (not . (`ground` nb)) lhsArgs- || any (not . (`ground` nb)) tyArgs && itf- then outOfPlaceTyVarError- else case rhsArgs of- [] -> varE $ unboxRepName t- ty:_ -> inspectTy ty--unboxRepName :: Type -> Name-unboxRepName = maybe unK1ValName (\(_, _, unboxName) -> unboxName) . unboxedRepNames--lrP :: Int -> Int -> (Q Pat -> Q Pat)-lrP 1 0 p = p-lrP _ 0 p = conP l1DataName [p]-lrP m i p = conP r1DataName [lrP (m-1) (i-1) p]--lrE :: Int -> Int -> (Q Exp -> Q Exp)-lrE 1 0 e = e-lrE _ 0 e = conE l1DataName `appE` e-lrE m i e = conE r1DataName `appE` lrE (m-1) (i-1) e--unboxedRepNames :: Type -> Maybe (Name, Name, Name)-unboxedRepNames ty- | ty == ConT addrHashTypeName = Just (uAddrTypeName, uAddrDataName, uAddrHashValName)- | ty == ConT charHashTypeName = Just (uCharTypeName, uCharDataName, uCharHashValName)- | ty == ConT doubleHashTypeName = Just (uDoubleTypeName, uDoubleDataName, uDoubleHashValName)- | ty == ConT floatHashTypeName = Just (uFloatTypeName, uFloatDataName, uFloatHashValName)- | ty == ConT intHashTypeName = Just (uIntTypeName, uIntDataName, uIntHashValName)- | ty == ConT wordHashTypeName = Just (uWordTypeName, uWordDataName, uWordHashValName)- | otherwise = Nothing---- | Boilerplate for top level splices.------ The given Name must meet one of two criteria:------ 1. It must be the name of a type constructor of a plain data type or newtype.--- 2. It must be the name of a data family instance or newtype instance constructor.------ Any other value will result in an exception.-reifyDataInfo :: Name- -> Q (Either String (Name, Bool, [TyVarBndr], [Con], DataVariety))-reifyDataInfo name = do- info <- reify name- case info of- TyConI dec ->- return $ case dec of- DataD ctxt _ tvbs cons _ -> Right $- checkDataContext name ctxt (name, False, tvbs, cons, DataPlain)- NewtypeD ctxt _ tvbs con _ -> Right $- checkDataContext name ctxt (name, True, tvbs, [con], DataPlain)- TySynD{} -> Left $ ns ++ "Type synonyms are not supported."- _ -> Left $ ns ++ "Unsupported type: " ++ show dec-#if MIN_VERSION_template_haskell(2,7,0)-# if MIN_VERSION_template_haskell(2,11,0)- DataConI _ _ parentName -> do-# else- DataConI _ _ parentName _ -> do-# endif- parentInfo <- reify parentName- return $ case parentInfo of-# if MIN_VERSION_template_haskell(2,11,0)- FamilyI (DataFamilyD _ tvbs _) decs ->-# else- FamilyI (FamilyD DataFam _ tvbs _) decs ->-# endif- -- This isn't total, but the API requires that the data family instance have- -- at least one constructor anyways, so this will always succeed.- let instDec = flip find decs $ any ((name ==) . constructorName) . dataDecCons- in case instDec of- Just (DataInstD ctxt _ instTys cons _) -> Right $- checkDataContext parentName ctxt- (parentName, False, tvbs, cons, DataFamily (constructorName $ head cons) instTys)- Just (NewtypeInstD ctxt _ instTys con _) -> Right $- checkDataContext parentName ctxt- (parentName, True, tvbs, [con], DataFamily (constructorName con) instTys)- _ -> Left $ ns ++- "Could not find data or newtype instance constructor."- _ -> Left $ ns ++ "Data constructor " ++ show name ++- " is not from a data family instance constructor."-# if MIN_VERSION_template_haskell(2,11,0)- FamilyI DataFamilyD{} _ ->-# else- FamilyI (FamilyD DataFam _ _ _) _ ->-# endif- return . Left $- ns ++ "Cannot use a data family name. Use a data family instance constructor instead."- _ -> return . Left $ ns ++ "The name must be of a plain data type constructor, "- ++ "or a data family instance constructor."-#else- DataConI{} -> return . Left $ ns ++ "Cannot use a data constructor."- ++ "\n\t(Note: if you are trying to derive for a data family instance, use GHC >= 7.4 instead.)"- _ -> return . Left $ ns ++ "The name must be of a plain type constructor."-#endif- where- ns :: String- ns = "Generics.Deriving.TH.reifyDataInfo: "---- | Deduces the non-eta-reduced type variables, the instance type, the GenericKind--- value to use for a Generic(1) instance.-buildTypeInstance :: Int- -- ^ Generic(0) or Generic1- -> Name- -- ^ The type constructor or data family name- -> [TyVarBndr]- -- ^ The type variables from the data type/data family declaration- -> [Con]- -- ^ The constructors of the data type/data family declaration- -> DataVariety- -- ^ If using a data family instance, provides the types used- -- to instantiate the instance- -> ([TyVarBndr], Type, GenericKind)-buildTypeInstance arity tyConName tvbs _ DataPlain- | remainingLength < 0 || not (wellKinded droppedKinds) -- If we have enough well-kinded type variables- = derivingKindError tyConName- | otherwise = (remaining, instanceType, genericKindFromArity arity droppedNbs)- where- instanceType :: Type- instanceType = applyTyToTvbs tyConName remaining-- remainingLength :: Int- remainingLength = length tvbs - arity-- remaining, dropped :: [TyVarBndr]- (remaining, dropped) = splitAt remainingLength tvbs-- droppedKinds :: [Kind]- droppedKinds = map tyVarBndrToKind dropped-- droppedNbs :: [NameBase]- droppedNbs = map tyVarBndrToNameBase dropped-buildTypeInstance arity parentName tvbs _cons (DataFamily _ instTysAndKinds)- | remainingLength < 0 || not (wellKinded droppedKinds) -- If we have enough well-kinded type variables- = derivingKindError parentName- | canEtaReduce remaining dropped -- If it is safe to drop the type variables- = (lhsTvbs, instanceType, genericKindFromArity arity droppedNbs)- | otherwise = etaReductionError instanceType- where- -- We need to make sure that type variables in the instance head which have- -- constraints aren't poly-kinded, e.g.,- --- -- @- -- instance Generic (Foo (f :: k)) where- -- @- --- -- To do this, we remove every kind ascription (i.e., strip off every 'SigT').- instanceType :: Type- instanceType = applyTyToTys (ConT parentName) $ map unSigT remaining-- remainingLength :: Int- remainingLength = length tvbs - arity-- remaining, dropped :: [Type]- (remaining, dropped) = splitAt remainingLength rhsTypes-- droppedKinds :: [Kind]- droppedKinds = map tyVarBndrToKind . snd $ splitAt remainingLength tvbs-- droppedNbs :: [NameBase]- droppedNbs = map varTToNameBase dropped-- -- We need to be mindful of an old GHC bug which causes kind variables to appear in- -- @instTysAndKinds@ (as the name suggests) if- --- -- (1) @PolyKinds@ is enabled- -- (2) either GHC 7.6 or 7.8 is being used (for more info, see Trac #9692).- --- -- Since Template Haskell doesn't seem to have a mechanism for detecting which- -- language extensions are enabled, we do the next-best thing by counting- -- the number of distinct kind variables in the data family declaration, and- -- then dropping that number of entries from @instTysAndKinds@.- instTypes :: [Type]- instTypes =-#if __GLASGOW_HASKELL__ >= 710 || !(MIN_VERSION_template_haskell(2,8,0))- instTysAndKinds-#else- drop (Set.size . Set.unions $ map (distinctKindVars . tyVarBndrToKind) tvbs)- instTysAndKinds- where- distinctKindVars :: Kind -> Set Name-# if MIN_VERSION_template_haskell(2,8,0)- distinctKindVars (AppT k1 k2) = distinctKindVars k1 `Set.union` distinctKindVars k2- distinctKindVars (SigT k _) = distinctKindVars k- distinctKindVars (VarT k) = Set.singleton k-# endif- distinctKindVars _ = Set.empty-#endif-- lhsTvbs :: [TyVarBndr]- lhsTvbs = map (uncurry replaceTyVarName)- . filter (isTyVar . snd)- . take remainingLength- $ zip tvbs rhsTypes-- -- In GHC 7.8, only the @Type@s up to the rightmost non-eta-reduced type variable- -- in @instTypes@ are provided (as a result of a bug reported in Trac #9692). This- -- is pretty inconvenient, as it makes it impossible to come up with the correct- -- instance types in some cases. For example, consider the following code:- --- -- @- -- data family Foo a b c- -- data instance Foo Int y z = Foo Int y z- -- $(deriveAll1 'Foo)- -- @- --- -- Due to the aformentioned bug, Template Haskell doesn't tell us the names of- -- either of type variables in the data instance (@y@ and @z@). As a result, we- -- won't know to which fields of the 'Foo' constructor contain the rightmost type- -- variable, which will result in an incorrect instance. Urgh.- --- -- A workaround is to ensure that you use the exact same type variables, in the- -- exact same order, in the data family declaration and any data or newtype- -- instances:- --- -- @- -- data family Foo a b c- -- data instance Foo Int b c = Foo Int b c- -- $(deriveAll1 'Foo)- -- @- --- -- Thankfully, other versions of GHC don't seem to have this bug.- rhsTypes :: [Type]- rhsTypes =-#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710- instTypes ++ map tyVarBndrToType- (alignTyVarBndrs _cons $ drop (length instTypes) tvbs)- where- tyVarBndrToType :: TyVarBndr -> Type- tyVarBndrToType (PlainTV n) = VarT n- tyVarBndrToType (KindedTV n k) = SigT (VarT n) k-- mapTyVarBndrName :: Name -> TyVarBndr -> TyVarBndr- mapTyVarBndrName n PlainTV{} = PlainTV n- mapTyVarBndrName n (KindedTV _ k) = KindedTV n k-- -- To compensate for Trac #9692, we borrow some type variables from the data- -- family declaration. However, the type variables used in a data family- -- declaration are completely different from those used in a data family- -- instance, even if their names appear to be the same. In particular,- -- Template Haskell gives them different Name values.- --- -- We can account for this by walking through the constructors' type signatures- -- to figure out what the correct Names should be, then replace the type- -- variables from the data family declaration (which we borrow) with those- -- from the constructors' type signatures.- alignTyVarBndrs :: [Con] -> [TyVarBndr] -> [TyVarBndr]- alignTyVarBndrs cons' tvbs' =- let nbSet = Set.fromList $ map tyVarBndrToNameBase tvbs'- nbMap = snd $ foldr alignCon (nbSet, Map.empty) cons'- in map (\tvb -> mapTyVarBndrName (Map.findWithDefault- (tyVarBndrToName tvb)- (tyVarBndrToNameBase tvb)- nbMap- ) tvb- ) tvbs'-- alignCon :: Con- -> (Set NameBase, Map NameBase Name)- -> (Set NameBase, Map NameBase Name)- alignCon _ (nbs, m) | Set.null nbs = (nbs, m)- alignCon (NormalC _ tys) state = foldr alignTy state $ map snd tys- alignCon (RecC n tys) state = alignCon (NormalC n $ map shrink tys) state- where- shrink (_, b, c) = (b, c)- alignCon (InfixC ty1 n ty2) state = alignCon (NormalC n [ty1, ty2]) state- alignCon (ForallC _ _ con) _ = forallCError con-- alignTy :: Type- -> (Set NameBase, Map NameBase Name)- -> (Set NameBase, Map NameBase Name)- alignTy _ (nbs, m) | Set.null nbs = (nbs, m)- alignTy ForallT{} _ = rankNError- alignTy (AppT t1 t2) state = alignTy t2 $ alignTy t1 state- alignTy (SigT t _) state = alignTy t state- alignTy (VarT n) (nbs, m) =- let nb = NameBase n- in if nb `Set.member` nbs- then let nbs' = nb `Set.delete` nbs- m' = Map.insert nb n m- in (nbs', m')- else (nbs, m)- alignTy _ state = state-#else- instTypes-#endif---- | True if the type does not mention the NameBase-ground :: Type -> NameBase -> Bool-ground (AppT t1 t2) nb = ground t1 nb && ground t2 nb-ground (SigT t _) nb = ground t nb-ground (VarT n) nb = NameBase n /= nb-ground ForallT{} _ = rankNError-ground _ _ = True---- | One of the last type variables cannot be eta-reduced (see the canEtaReduce--- function for the criteria it would have to meet).-etaReductionError :: Type -> a-etaReductionError instanceType = error $- "Cannot eta-reduce to an instance of form \n\tinstance (...) => "- ++ pprint instanceType---- | Either the given data type doesn't have enough type variables, or one of--- the type variables to be eta-reduced cannot realize kind *.-derivingKindError :: Name -> a-derivingKindError tyConName = error- . showString "Cannot derive well-kinded instance of form ‘Generic1 "- . showParen True- ( showString (nameBase tyConName)- . showString " ..."- )- . showString "‘\n\tClass Generic1 expects an argument of kind * -> *"- $ ""--outOfPlaceTyVarError :: a-outOfPlaceTyVarError = error $- "Type applied to an argument involving the last parameter is not of kind * -> *"---- | Deriving Generic(1) doesn't work with ExistentialQuantification-forallCError :: Con -> a-forallCError con = error $- nameBase (constructorName con) ++ " must be a vanilla data constructor"---- | Cannot have a constructor argument of form (forall a1 ... an. <type>)--- when deriving Generic(1)-rankNError :: a-rankNError = error "Cannot have polymorphic arguments"---- | One cannot derive Generic(1) instance for anything that uses DatatypeContexts,--- so check to make sure the Cxt field of a datatype is null.-checkDataContext :: Name -> Cxt -> a -> a-checkDataContext _ [] x = x-checkDataContext dataName _ _ = error $- nameBase dataName ++ " must not have a datatype context"---- | Indicates whether Generic (Gen0) or Generic1 (Gen1) is being derived. Gen1--- bundles the Name of the last type parameter.-data GenericKind = Gen0 | Gen1 NameBase---- | Construct a GenericKind value from its arity.-genericKindFromArity :: Int -> [NameBase] -> GenericKind-genericKindFromArity 0 _ = Gen0-genericKindFromArity 1 nbs = Gen1 $ head nbs-genericKindFromArity _ _ = error "Invalid arity"---- | Indicates whether Generic(1) is being derived for a plain data type (DataPlain)--- or a data family instance (DataFamily). DataFamily bundles the Name of the data--- family instance's first constructor (for Name-generation purposes) and the types--- used to instantiate the instance.-data DataVariety = DataPlain | DataFamily Name [Type]+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+-- |+-- Module : Generics.Deriving.TH+-- Copyright : (c) 2008--2009 Universiteit Utrecht+-- License : BSD3+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- This module contains Template Haskell code that can be used to+-- automatically generate the boilerplate code for the generic deriving+-- library.+--+-- To use these functions, pass the name of a data type as an argument:+--+-- @+-- {-# LANGUAGE TemplateHaskell #-}+--+-- data Example a = Example Int Char a+-- $('deriveAll0' ''Example) -- Derives Generic instance+-- $('deriveAll1' ''Example) -- Derives Generic1 instance+-- $('deriveAll0And1' ''Example) -- Derives Generic and Generic1 instances+-- @+--+-- On GHC 7.4 or later, this code can also be used with data families. To derive+-- for a data family instance, pass the name of one of the instance's constructors:+--+-- @+-- {-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-}+--+-- data family Family a b+-- newtype instance Family Char x = FamilyChar Char+-- data instance Family Bool x = FamilyTrue | FamilyFalse+--+-- $('deriveAll0' 'FamilyChar) -- instance Generic (Family Char b) where ...+-- $('deriveAll1' 'FamilyTrue) -- instance Generic1 (Family Bool) where ...+-- -- Alternatively, one could type $(deriveAll1 'FamilyFalse)+-- @+-----------------------------------------------------------------------------++-- Adapted from Generics.Regular.TH+module Generics.Deriving.TH (++ deriveMeta+ , deriveData+ , deriveConstructors+ , deriveSelectors++ , deriveAll+ , deriveAll0+ , deriveAll1+ , deriveAll0And1+ , deriveRepresentable0+ , deriveRepresentable1+ , deriveRep0+ , deriveRep1+ , simplInstance+ -- * -@WithSigs@ functions+ -- $withSigs+ , deriveAll0WithKindSigs+ , deriveAll1WithKindSigs+ , deriveAll0And1WithKindSigs+ , deriveRepresentable0WithKindSigs+ , deriveRepresentable1WithKindSigs+ , deriveRep0WithKindSigs+ , deriveRep1WithKindSigs+ -- * @make@- functions+ -- $make+ , makeRep0+ , makeRep0FromType+ , makeFrom+ , makeFrom0+ , makeTo+ , makeTo0+ , makeRep1+ , makeRep1FromType+ , makeFrom1+ , makeTo1+ ) where++import Control.Monad ((>=>), unless, when)++#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))+import Data.Foldable (foldr')+#endif+import Data.List (nub)+import qualified Data.Map as Map (fromList)++import Generics.Deriving.TH.Internal+#if __GLASGOW_HASKELL__ >= 711+import Generics.Deriving.TH.Post711+#else+import Generics.Deriving.TH.Pre711+#endif++import Language.Haskell.TH.Lib+import Language.Haskell.TH++{- $withSigs+By default, 'deriveRep0', 'deriveRep1', and functions that invoke it generate+type synonyms whose type variable binders do not have explicit kind binders for+polykinded type variables. This is a pretty reasonable default, since puts less+of a burden on the Template Haskell machinery to get the kinds just right, and+lets the kind inferencer do more work. However, there are times when you want to+have explicit kind signatures, such as if you have a datatype that uses+@-XTypeInType@. For example:++@+data Prox (a :: k) (b :: *) = Prox k+$('deriveRep0WithKindSigs' ''Prox)+@++will result in something like:++@+type Rep0Prox (a :: k) (b :: *) = Rec0 k+@++Whereas if you had used 'deriveRep0', you would have something like:++@+type Rep0Prox a (b :: *) = Rec0 k+@++which will fail to compile, since k is out-of-scope!+-}++-- | 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)))) []]]++-- | A backwards-compatible synonym for 'deriveAll0'.+deriveAll :: Name -> Q [Dec]+deriveAll = deriveAll0++-- | Given the type and the name (as string) for the type to derive,+-- generate the 'Data' instance, the 'Constructor' instances, the 'Selector'+-- instances, and the 'Representable0' instance.+deriveAll0 :: Name -> Q [Dec]+deriveAll0 = deriveAllCommon True False False++-- | Like 'deriveAll0', except that the type variable binders in the+-- 'Rep' type synonym will have explicit kind signatures.+deriveAll0WithKindSigs :: Name -> Q [Dec]+deriveAll0WithKindSigs = deriveAllCommon True False True++-- | Given the type and the name (as string) for the type to derive,+-- generate the 'Data' instance, the 'Constructor' instances, the 'Selector'+-- instances, and the 'Representable1' instance.+deriveAll1 :: Name -> Q [Dec]+deriveAll1 = deriveAllCommon False True False++-- | Like 'deriveAll1', except that the type variable binders in the+-- 'Rep1' type synonym will have explicit kind signatures.+deriveAll1WithKindSigs :: Name -> Q [Dec]+deriveAll1WithKindSigs = deriveAllCommon False True True++-- | Given the type and the name (as string) for the type to derive,+-- generate the 'Data' instance, the 'Constructor' instances, the 'Selector'+-- instances, the 'Representable0' instance, and the 'Representable1' instance.+deriveAll0And1 :: Name -> Q [Dec]+deriveAll0And1 = deriveAllCommon True True False++-- | Like 'deriveAll0And1', except that the type variable binders in the+-- 'Rep' and 'Rep1' type synonyms will have explicit kind signatures.+deriveAll0And1WithKindSigs :: Name -> Q [Dec]+deriveAll0And1WithKindSigs = deriveAllCommon True True True++deriveAllCommon :: Bool -> Bool -> Bool -> Name -> Q [Dec]+deriveAllCommon generic generic1 useKindSigs n = do+ a <- deriveMeta n+ b <- if generic+ then deriveRepresentableCommon Generic useKindSigs n+ else return []+ c <- if generic1+ then deriveRepresentableCommon Generic1 useKindSigs n+ else return []+ return (a ++ b ++ c)++-- | Given the type and the name (as string) for the Representable0 type+-- synonym to derive, generate the 'Representable0' instance.+deriveRepresentable0 :: Name -> Q [Dec]+deriveRepresentable0 = deriveRepresentableCommon Generic False++-- | Like 'deriveRepresentable0', except that the type variable binders in the+-- 'Rep' type synonym will have explicit kind signatures.+deriveRepresentable0WithKindSigs :: Name -> Q [Dec]+deriveRepresentable0WithKindSigs = deriveRepresentableCommon Generic True++-- | Given the type and the name (as string) for the Representable1 type+-- synonym to derive, generate the 'Representable1' instance.+deriveRepresentable1 :: Name -> Q [Dec]+deriveRepresentable1 = deriveRepresentableCommon Generic1 False++-- | Like 'deriveRepresentable1', except that the type variable binders in the+-- 'Rep1' type synonym will have explicit kind signatures.+deriveRepresentable1WithKindSigs :: Name -> Q [Dec]+deriveRepresentable1WithKindSigs = deriveRepresentableCommon Generic1 True++deriveRepresentableCommon :: GenericClass -> Bool -> Name -> Q [Dec]+deriveRepresentableCommon gClass useKindSigs n = do+ rep <- deriveRepCommon gClass useKindSigs n+ inst <- deriveInst gClass n+ return (rep ++ inst)++-- | Derive only the 'Rep0' type synonym. Not needed if 'deriveRepresentable0'+-- is used.+deriveRep0 :: Name -> Q [Dec]+deriveRep0 = deriveRepCommon Generic False++-- | Like 'deriveRep0', except that the type variable binders in the 'Rep'+-- type synonym will have explicit kind signatures.+deriveRep0WithKindSigs :: Name -> Q [Dec]+deriveRep0WithKindSigs = deriveRepCommon Generic True++-- | Derive only the 'Rep1' type synonym. Not needed if 'deriveRepresentable1'+-- is used.+deriveRep1 :: Name -> Q [Dec]+deriveRep1 = deriveRepCommon Generic1 False++-- | Like 'deriveRep1', except that the type variable binders in the 'Rep1'+-- type synonym will have explicit kind signatures.+deriveRep1WithKindSigs :: Name -> Q [Dec]+deriveRep1WithKindSigs = deriveRepCommon Generic1 True++deriveRepCommon :: GenericClass -> Bool -> Name -> Q [Dec]+deriveRepCommon gClass useKindSigs n = do+ i <- reifyDataInfo n+ let (name, isNT, declTvbs, cons, dv) = either error id i+ -- See Note [Forcing buildTypeInstance]+ !_ <- buildTypeInstance gClass name declTvbs dv++ tySynTvbs <- grabTyVarBndrsFromCons gClass cons+ let tySynTvbs' = if useKindSigs+ then tySynTvbs+ else map (\tvb -> if isKindMonomorphic (tyVarBndrKind tvb)+ then tvb+ else unKindedTV tvb) tySynTvbs+ fmap (:[]) $ tySynD (genRepName gClass dv name)+ tySynTvbs'+ -- The typechecker will infer the kinds of the TyVarBndrs+ -- in a type synonym declaration, so we don't need to+ -- splice them in explicitly (hence the unKindedTV call).+ (repType gClass dv name isNT cons tySynTvbs)++deriveInst :: GenericClass -> Name -> Q [Dec]+deriveInst Generic = deriveInstCommon genericTypeName repTypeName Generic fromValName toValName+deriveInst Generic1 = deriveInstCommon generic1TypeName rep1TypeName Generic1 from1ValName to1ValName++deriveInstCommon :: Name -> Name -> GenericClass -> Name -> Name -> Name -> Q [Dec]+deriveInstCommon genericName repName gClass fromName toName n = do+ i <- reifyDataInfo n+ let (name, _, allTvbs, cons, dv) = either error id i+ origTy <- buildTypeInstance gClass name allTvbs dv+ repTySynApp <- makeRepTySynApp gClass dv name cons origTy+ let tyIns = TySynInstD repName+#if __GLASGOW_HASKELL__ >= 707+ (TySynEqn [origTy] repTySynApp)+#else+ [origTy] repTySynApp+#endif+ mkBody maker = [clause [] (normalB $ mkCaseExp gClass name cons maker) []]+ fcs = mkBody mkFrom+ tcs = mkBody mkTo++ fmap (:[]) $+ instanceD (cxt []) (conT genericName `appT` return origTy)+ [return tyIns, funD fromName fcs, funD toName tcs]++{- $make++There are some data types for which the Template Haskell deriver functions in+this module are not sophisticated enough to infer the correct 'Generic' or+'Generic1' instances. As an example, consider this data type:++@+data Fix f a = Fix (f (Fix f a))+@++A proper 'Generic1' instance would look like this:++@+instance Functor f => Generic1 (Fix f) where ...+@++Unfortunately, 'deriveRepresentable1' cannot infer the @Functor f@ constraint.+One can still define a 'Generic1' instance for @Fix@, however, by using the+functions in this module that are prefixed with @make@-. For example:++@+$('deriveMeta' ''Fix)+$('deriveRep1' ''Fix)+instance Functor f => Generic1 (Fix f) where+ type Rep1 (Fix f) = $('makeRep1FromType' ''Fix [t| Fix f |])+ from1 = $('makeFrom1' ''Fix)+ to1 = $('makeTo1' ''Fix)+@++Note that due to the lack of type-level lambdas in Haskell, one must manually+apply @'makeRep1FromType' ''Fix@ to the type @Fix f@.++Be aware that there is a bug on GHC 7.0, 7.2, and 7.4 which might prevent you from+using 'makeRep0FromType' and 'makeRep1FromType'. In the @Fix@ example above, you+would experience the following error:++@+ Kinded thing `f' used as a type+ In the Template Haskell quotation [t| Fix f |]+@++Then a workaround is to use 'makeRep1' instead, which requires you to pass as+arguments the type variables that occur in the instance, in order from left to+right, excluding duplicates. (Normally, 'makeRep1FromType' would figure this+out for you.) Using the above example:++@+$('deriveMeta' ''Fix)+$('deriveRep1' ''Fix)+instance Functor f => Generic1 (Fix f) where+ type Rep1 (Fix f) = $('makeRep1' ''Fix) f+ from1 = $('makeFrom1' ''Fix)+ to1 = $('makeTo1' ''Fix)+@++On GHC 7.4, you might encounter more complicated examples involving data+families. For instance:++@+data family Fix a b c d+newtype instance Fix b (f c) (g b) a = Fix (f (Fix b (f c) (g b) a))++$('deriveMeta' ''Fix)+$('deriveRep1' ''Fix)+instance Functor f => Generic1 (Fix b (f c) (g b)) where+ type Rep1 (Fix b (f c) (g b)) = $('makeRep1' 'Fix) b f c g+ from1 = $('makeFrom1' 'Fix)+ to1 = $('makeTo1' 'Fix)+@++Note that you don't pass @b@ twice, only once.+-}++-- | Generates the 'Rep' type synonym constructor (as opposed to 'deriveRep0',+-- which generates the type synonym declaration). After splicing it into+-- Haskell source, it expects types as arguments. For example:+--+-- @+-- type Rep (Foo a b) = $('makeRep0' ''Foo) a b+-- @+makeRep0 :: Name -> Q Type+makeRep0 n = makeRepCommon Generic n Nothing++-- | Generates the 'Rep1' type synonym constructor (as opposed to 'deriveRep1',+-- which generates the type synonym declaration). After splicing it into+-- Haskell source, it expects types as arguments. For example:+--+-- @+-- type Rep1 (Foo a b) = $('makeRep1' ''Foo) a b+-- @+makeRep1 :: Name -> Q Type+makeRep1 n = makeRepCommon Generic1 n Nothing++-- | Generates the 'Rep' type synonym constructor (as opposed to 'deriveRep0',+-- which generates the type synonym declaration) applied to its type arguments.+-- Unlike 'makeRep0', this also takes a quoted 'Type' as an argument, e.g.,+--+-- @+-- type Rep (Foo a b) = $('makeRep0FromType' ''Foo [t| Foo a b |])+-- @+makeRep0FromType :: Name -> Q Type -> Q Type+makeRep0FromType n = makeRepCommon Generic n . Just++-- | Generates the 'Rep1' type synonym constructor (as opposed to 'deriveRep1',+-- which generates the type synonym declaration) applied to its type arguments.+-- Unlike 'makeRep1', this also takes a quoted 'Type' as an argument, e.g.,+--+-- @+-- type Rep1 (Foo a b) = $('makeRep1FromType' ''Foo [t| Foo a b |])+-- @+makeRep1FromType :: Name -> Q Type -> Q Type+makeRep1FromType n = makeRepCommon Generic1 n . Just++makeRepCommon :: GenericClass+ -> Name+ -> Maybe (Q Type)+ -> Q Type+makeRepCommon gClass n mbQTy = do+ i <- reifyDataInfo n+ let (name, _, _, cons, dv) = either error id i+ case mbQTy of+ Just qTy -> do+ ty <- qTy+ makeRepTySynApp gClass dv name cons ty+ Nothing -> conT $ genRepName gClass dv name++makeRepTySynApp :: GenericClass+ -> DataVariety+ -> Name+ -> [Con]+ -> Type+ -> Q Type+makeRepTySynApp gClass dv name cons ty = do+ -- Here, we figure out the distinct type variables (in order from left-to-right)+ -- 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 $ visibleTyVarsOfType 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+ -- variables than the generated type synonym can accept.+ -- See Note [Arguments to generated type synonyms]+ tySynTvbs <- grabTyVarBndrsFromCons gClass cons+ return . applyTyToTvbs (genRepName gClass dv name)+ $ zipWith const instTvbs tySynTvbs++-- | A backwards-compatible synonym for 'makeFrom0'.+makeFrom :: Name -> Q Exp+makeFrom = makeFrom0++-- | Generates a lambda expression which behaves like 'from'.+makeFrom0 :: Name -> Q Exp+makeFrom0 = 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++-- | Generates a lambda expression which behaves like 'from1'.+makeFrom1 :: Name -> Q Exp+makeFrom1 = makeFunCommon mkFrom Generic1++-- | Generates a lambda expression which behaves like 'to1'.+makeTo1 :: Name -> Q Exp+makeTo1 = makeFunCommon mkTo Generic1++makeFunCommon :: (GenericClass -> Int -> Int -> Name -> [Con] -> [Q Match])+ -> GenericClass -> Name -> Q Exp+makeFunCommon maker gClass n = do+ i <- reifyDataInfo n+ let (name, _, allTvbs, cons, dv) = either error id i+ -- See Note [Forcing buildTypeInstance]+ buildTypeInstance gClass name allTvbs dv+ `seq` mkCaseExp gClass name cons maker++genRepName :: GenericClass -> DataVariety -> Name -> Name+genRepName gClass dv n = mkName+ . showsDataVariety dv+ . (("Rep" ++ show (fromEnum gClass)) ++)+ . ((showNameQual n ++ "_") ++)+ . sanitizeName+ $ nameBase n++repType :: GenericClass+ -> DataVariety+ -> Name+ -> Bool+ -> [Con]+ -> [TyVarBndr]+ -> Q Type+repType gClass dv dt isNT cs tySynTvbs =+ conT d1TypeName `appT` mkMetaDataType dv dt isNT `appT`+ foldr1' sum' (conT v1TypeName)+ (map (repCon gClass dv dt tySynTvbs) cs)+ where+ sum' :: Q Type -> Q Type -> Q Type+ sum' a b = conT sumTypeName `appT` a `appT` b++repCon :: GenericClass+ -> DataVariety+ -> Name+ -> [TyVarBndr]+ -> Con+ -> Q Type+repCon gClass dv dt tySynTvbs (NormalC n bts) = do+ let bangs = map fst bts+ ssis <- reifySelStrictInfo n bangs+ repConWith gClass dv dt n tySynTvbs Nothing ssis False False+repCon gClass dv dt tySynTvbs (RecC n vbts) = do+ let (selNames, bangs, _) = unzip3 vbts+ ssis <- reifySelStrictInfo n bangs+ repConWith gClass dv dt n tySynTvbs (Just selNames) ssis True False+repCon gClass dv dt tySynTvbs (InfixC t1 n t2) = do+ let bangs = map fst [t1, t2]+ ssis <- reifySelStrictInfo n bangs+ repConWith gClass dv dt n tySynTvbs Nothing ssis False True+repCon _ _ _ _ con = gadtError con++repConWith :: GenericClass+ -> DataVariety+ -> Name+ -> Name+ -> [TyVarBndr]+ -> Maybe [Name]+ -> [SelStrictInfo]+ -> Bool+ -> Bool+ -> Q Type+repConWith gClass dv dt n tySynTvbs mbSelNames ssis isRecord isInfix = do+ (conTvbs, ts, gk) <- reifyConTys gClass n++ let structureType :: Q Type+ structureType = case ssis of+ [] -> conT u1TypeName+ _ -> foldr1 prodT f++ -- See Note [Substituting types in a constructor type signature]+ typeSubst :: TypeSubst+ typeSubst = Map.fromList $+ zip (concatMap tyVarNamesOfTyVarBndr conTvbs)+ (concatMap (map VarT . tyVarNamesOfTyVarBndr) tySynTvbs)++ f :: [Q Type]+ f = case mbSelNames of+ Just selNames -> zipWith3 (repField gk dv dt n typeSubst . Just)+ selNames ssis ts+ Nothing -> zipWith (repField gk dv dt n typeSubst Nothing)+ ssis ts++ conT c1TypeName+ `appT` mkMetaConsType dv dt n isRecord isInfix+ `appT` structureType++prodT :: Q Type -> Q Type -> Q Type+prodT a b = conT productTypeName `appT` a `appT` b++repField :: GenericKind+ -> DataVariety+ -> Name+ -> Name+ -> TypeSubst+ -> Maybe Name+ -> SelStrictInfo+ -> Type+ -> Q Type+repField gk dv dt ns typeSubst mbF ssi t =+ conT s1TypeName+ `appT` mkMetaSelType dv dt ns mbF ssi+ `appT` (repFieldArg gk =<< expandSyn t'')+ where+ -- See Note [Substituting types in constructor type signatures]+ t', t'' :: Type+ t' = case gk of+ Gen1 _ (Just kvName) -> substNameWithKind kvName starK t+ _ -> t+ t'' = substType typeSubst t'++repFieldArg :: GenericKind -> Type -> Q Type+repFieldArg _ ForallT{} = rankNError+repFieldArg gk (SigT t _) = repFieldArg gk t+repFieldArg Gen0 t = boxT t+repFieldArg (Gen1 name _) (VarT t) | t == name = conT par1TypeName+repFieldArg gk@(Gen1 name _) t = do+ let tyHead:tyArgs = unapplyTy t+ numLastArgs = min 1 $ length tyArgs+ (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs+ rec0Type = boxT t+ phiType = return $ applyTyToTys tyHead lhsArgs++ inspectTy :: Type -> Q Type+ inspectTy (VarT a)+ | a == name+ = conT rec1TypeName `appT` phiType+ inspectTy (SigT ty _) = inspectTy ty+ inspectTy beta+ | not (ground beta name)+ = conT composeTypeName `appT` phiType+ `appT` repFieldArg gk beta+ inspectTy _ = rec0Type++ itf <- isTyFamily tyHead+ if any (not . (`ground` name)) lhsArgs+ || any (not . (`ground` name)) tyArgs && itf+ then outOfPlaceTyVarError+ else case rhsArgs of+ [] -> rec0Type+ ty:_ -> inspectTy ty++boxT :: Type -> Q Type+boxT ty = case unboxedRepNames ty of+ Just (boxTyName, _, _) -> conT boxTyName+ Nothing -> conT rec0TypeName `appT` return ty++mkCaseExp :: GenericClass -> Name -> [Con]+ -> (GenericClass -> Int -> Int -> Name -> [Con] -> [Q Match])+ -> Q Exp+mkCaseExp gClass dt cs matchmaker = do+ val <- newName "val"+ lam1E (varP val) $ caseE (varE val) $ matchmaker gClass 1 0 dt cs++mkFrom :: GenericClass -> Int -> Int -> Name -> [Con] -> [Q Match]+mkFrom _ _ _ dt [] = [errorFrom dt]+mkFrom gClass m i _ cs = zipWith (fromCon gClass wrapE (length cs)) [0..] cs+ where+ wrapE e = lrE m i e++errorFrom :: Name -> Q Match+errorFrom dt =+ match+ wildP+ (normalB $ appE (conE m1DataName) $ varE errorValName `appE` stringE+ ("No generic representation for empty datatype " ++ nameBase dt))+ []++errorTo :: Name -> Q Match+errorTo dt =+ match+ (conP m1DataName [wildP])+ (normalB $ varE errorValName `appE` stringE+ ("No values for empty datatype " ++ nameBase dt))+ []++mkTo :: GenericClass -> Int -> Int -> Name -> [Con] -> [Q Match]+mkTo _ _ _ dt [] = [errorTo dt]+mkTo gClass m i _ cs = zipWith (toCon gClass wrapP (length cs)) [0..] cs+ where+ wrapP p = lrP m i p++fromCon :: GenericClass -> (Q Exp -> Q Exp) -> Int -> Int -> Con -> Q Match+fromCon _ wrap m i (NormalC cn []) =+ match+ (conP cn [])+ (normalB $ appE (conE m1DataName)+ $ wrap $ lrE m i $ conE m1DataName `appE` (conE u1DataName)) []+fromCon gClass wrap m i (NormalC cn _) = do+ (ts, gk) <- fmap shrink $ reifyConTys gClass cn+ fNames <- newNameList "f" $ length ts+ match+ (conP cn (map varP fNames))+ (normalB $ appE (conE m1DataName) $ wrap $ lrE m i $ conE m1DataName `appE`+ foldr1 prodE (zipWith (fromField gk) fNames ts)) []+fromCon _ wrap m i (RecC cn []) =+ match+ (conP cn [])+ (normalB $ appE (conE m1DataName)+ $ wrap $ lrE m i $ conE m1DataName `appE` (conE u1DataName)) []+fromCon gClass wrap m i (RecC cn _) = do+ (ts, gk) <- fmap shrink $ reifyConTys gClass cn+ fNames <- newNameList "f" $ length ts+ match+ (conP cn (map varP fNames))+ (normalB $ appE (conE m1DataName) $ wrap $ lrE m i $ conE m1DataName `appE`+ foldr1 prodE (zipWith (fromField gk) fNames ts)) []+fromCon gClass wrap m i (InfixC t1 cn t2) =+ fromCon gClass wrap m i (NormalC cn [t1,t2])+fromCon _ _ _ _ con = gadtError con++prodE :: Q Exp -> Q Exp -> Q Exp+prodE x y = conE productDataName `appE` x `appE` y++fromField :: GenericKind -> Name -> Type -> Q Exp+fromField gk nr t = conE m1DataName `appE` (fromFieldWrap gk nr =<< expandSyn t)++fromFieldWrap :: GenericKind -> Name -> Type -> Q Exp+fromFieldWrap _ _ ForallT{} = rankNError+fromFieldWrap gk nr (SigT t _) = fromFieldWrap gk nr t+fromFieldWrap Gen0 nr t = conE (boxRepName t) `appE` varE nr+fromFieldWrap (Gen1 name _) nr t = wC t name `appE` varE nr++wC :: Type -> Name -> Q Exp+wC (VarT t) name | t == name = conE par1DataName+wC t name+ | ground t name = conE $ boxRepName t+ | otherwise = do+ let tyHead:tyArgs = unapplyTy t+ numLastArgs = min 1 $ length tyArgs+ (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs++ inspectTy :: Type -> Q Exp+ inspectTy ForallT{} = rankNError+ inspectTy (SigT ty _) = inspectTy ty+ inspectTy (VarT a)+ | a == name+ = conE rec1DataName+ inspectTy beta = infixApp (conE comp1DataName)+ (varE composeValName)+ (varE fmapValName `appE` wC beta name)++ itf <- isTyFamily tyHead+ if any (not . (`ground` name)) lhsArgs+ || any (not . (`ground` name)) tyArgs && itf+ then outOfPlaceTyVarError+ else case rhsArgs of+ [] -> conE $ boxRepName t+ ty:_ -> inspectTy ty++boxRepName :: Type -> Name+boxRepName = maybe k1DataName snd3 . unboxedRepNames++toCon :: GenericClass -> (Q Pat -> Q Pat) -> Int -> Int -> Con -> Q Match+toCon _ wrap m i (NormalC cn []) =+ match+ (wrap $ conP m1DataName [lrP m i $ conP m1DataName [conP u1DataName []]])+ (normalB $ conE cn) []+toCon gClass wrap m i (NormalC cn _) = do+ (ts, gk) <- fmap shrink $ reifyConTys gClass cn+ fNames <- newNameList "f" $ length ts+ match+ (wrap $ conP m1DataName [lrP m i $ conP m1DataName+ [foldr1 prod (zipWith (toField gk) fNames ts)]])+ (normalB $ foldl appE (conE cn) (zipWith (\nr -> expandSyn >=> toConUnwC gk nr)+ fNames ts)) []+ where prod x y = conP productDataName [x,y]+toCon _ wrap m i (RecC cn []) =+ match+ (wrap $ conP m1DataName [lrP m i $ conP m1DataName [conP u1DataName []]])+ (normalB $ conE cn) []+toCon gClass wrap m i (RecC cn _) = do+ (ts, gk) <- fmap shrink $ reifyConTys gClass cn+ fNames <- newNameList "f" $ length ts+ match+ (wrap $ conP m1DataName [lrP m i $ conP m1DataName+ [foldr1 prod (zipWith (toField gk) fNames ts)]])+ (normalB $ foldl appE (conE cn) (zipWith (\nr -> expandSyn >=> toConUnwC gk nr)+ fNames ts)) []+ where prod x y = conP productDataName [x,y]+toCon gk wrap m i (InfixC t1 cn t2) =+ toCon gk wrap m i (NormalC cn [t1,t2])+toCon _ _ _ _ con = gadtError con++toConUnwC :: GenericKind -> Name -> Type -> Q Exp+toConUnwC Gen0 nr _ = varE nr+toConUnwC (Gen1 name _) nr t = unwC t name `appE` varE nr++toField :: GenericKind -> Name -> Type -> Q Pat+toField gk nr t = conP m1DataName [toFieldWrap gk nr t]++toFieldWrap :: GenericKind -> Name -> Type -> Q Pat+toFieldWrap Gen0 nr t = conP (boxRepName t) [varP nr]+toFieldWrap Gen1{} nr _ = varP nr++unwC :: Type -> Name -> Q Exp+unwC (SigT t _) name = unwC t name+unwC (VarT t) name | t == name = varE unPar1ValName+unwC t name+ | ground t name = varE $ unboxRepName t+ | otherwise = do+ let tyHead:tyArgs = unapplyTy t+ numLastArgs = min 1 $ length tyArgs+ (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs++ inspectTy :: Type -> Q Exp+ inspectTy ForallT{} = rankNError+ inspectTy (SigT ty _) = inspectTy ty+ inspectTy (VarT a)+ | a == name+ = varE unRec1ValName+ inspectTy beta = infixApp (varE fmapValName `appE` unwC beta name)+ (varE composeValName)+ (varE unComp1ValName)++ itf <- isTyFamily tyHead+ if any (not . (`ground` name)) lhsArgs+ || any (not . (`ground` name)) tyArgs && itf+ then outOfPlaceTyVarError+ else case rhsArgs of+ [] -> varE $ unboxRepName t+ ty:_ -> inspectTy ty++unboxRepName :: Type -> Name+unboxRepName = maybe unK1ValName trd3 . unboxedRepNames++lrP :: Int -> Int -> (Q Pat -> Q Pat)+lrP 1 0 p = p+lrP _ 0 p = conP l1DataName [p]+lrP m i p = conP r1DataName [lrP (m-1) (i-1) p]++lrE :: Int -> Int -> (Q Exp -> Q Exp)+lrE 1 0 e = e+lrE _ 0 e = conE l1DataName `appE` e+lrE m i e = conE r1DataName `appE` lrE (m-1) (i-1) e++unboxedRepNames :: Type -> Maybe (Name, Name, Name)+unboxedRepNames ty+ | ty == ConT addrHashTypeName = Just (uAddrTypeName, uAddrDataName, uAddrHashValName)+ | ty == ConT charHashTypeName = Just (uCharTypeName, uCharDataName, uCharHashValName)+ | ty == ConT doubleHashTypeName = Just (uDoubleTypeName, uDoubleDataName, uDoubleHashValName)+ | ty == ConT floatHashTypeName = Just (uFloatTypeName, uFloatDataName, uFloatHashValName)+ | ty == ConT intHashTypeName = Just (uIntTypeName, uIntDataName, uIntHashValName)+ | ty == ConT wordHashTypeName = Just (uWordTypeName, uWordDataName, uWordHashValName)+ | otherwise = Nothing++-- | Deduces the instance type to use for a Generic(1) instance.+buildTypeInstance :: GenericClass+ -- ^ Generic or Generic1+ -> Name+ -- ^ The type constructor or data family name+ -> [TyVarBndr]+ -- ^ The type variables from the data type/data family declaration+ -> DataVariety+ -- ^ If using a data family instance, provides the types used+ -- to instantiate the instance+ -> Q Type+-- Plain data type/newtype case+buildTypeInstance gClass tyConName tvbs DataPlain =+ let varTys :: [Type]+ varTys = map tyVarBndrToType tvbs+ in buildTypeInstanceFromTys gClass tyConName varTys False+-- Data family instance case+--+-- The CPP is present to work around a couple of annoying old GHC bugs.+-- See Note [Polykinded data families in Template Haskell]+buildTypeInstance gClass parentName tvbs (DataFamily _ instTysAndKinds) = do+#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0)+ let instTys :: [Type]+ instTys = zipWith stealKindForType tvbs instTysAndKinds+#else+ let kindVarNames :: [Name]+ kindVarNames = nub $ concatMap (tyVarNamesOfType . tyVarBndrKind) tvbs++ numKindVars :: Int+ numKindVars = length kindVarNames++ givenKinds, givenKinds' :: [Kind]+ givenTys :: [Type]+ (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds+ givenKinds' = map sanitizeStars givenKinds++ -- A GHC 7.6-specific bug requires us to replace all occurrences of+ -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it.+ -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot.+ sanitizeStars :: Kind -> Kind+ sanitizeStars = go+ where+ go :: Kind -> Kind+ go (AppT t1 t2) = AppT (go t1) (go t2)+ go (SigT t k) = SigT (go t) (go k)+ go (ConT n) | n == starKindName = StarT+ go t = t++ -- If we run this code with GHC 7.8, we might have to generate extra type+ -- variables to compensate for any type variables that Template Haskell+ -- eta-reduced away.+ -- See Note [Polykinded data families in Template Haskell]+ xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys)++ let xTys :: [Type]+ xTys = map VarT xTypeNames+ -- ^ Because these type variables were eta-reduced away, we can only+ -- determine their kind by using stealKindForType. Therefore, we mark+ -- them as VarT to ensure they will be given an explicit kind annotation+ -- (and so the kind inference machinery has the right information).++ substNamesWithKinds :: [(Name, Kind)] -> Type -> Type+ substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks++ -- The types from the data family instance might not have explicit kind+ -- annotations, which the kind machinery needs to work correctly. To+ -- compensate, we use stealKindForType to explicitly annotate any+ -- types without kind annotations.+ instTys :: [Type]+ instTys = map (substNamesWithKinds (zip kindVarNames givenKinds'))+ -- ^ Note that due to a GHC 7.8-specific bug+ -- (see Note [Polykinded data families in Template Haskell]),+ -- there may be more kind variable names than there are kinds+ -- to substitute. But this is OK! If a kind is eta-reduced, it+ -- means that is was not instantiated to something more specific,+ -- so we need not substitute it. Using stealKindForType will+ -- grab the correct kind.+ $ zipWith stealKindForType tvbs (givenTys ++ xTys)+#endif+ buildTypeInstanceFromTys gClass parentName instTys True++-- For the given Types, deduces the instance type to use for a Generic(1) instance.+-- Coming up with the instance type isn't as simple as dropping the last types, as+-- you need to be wary of kinds being instantiated with *.+-- See Note [Type inference in derived instances]+buildTypeInstanceFromTys :: GenericClass+ -- ^ Generic or Generic1+ -> Name+ -- ^ The type constructor or data family name+ -> [Type]+ -- ^ The types to instantiate the instance with+ -> Bool+ -- ^ True if it's a data family, False otherwise+ -> Q Type+buildTypeInstanceFromTys gClass tyConName varTysOrig isDataFamily = do+ -- Make sure to expand through type/kind synonyms! Otherwise, the+ -- eta-reduction check might get tripped up over type variables in a+ -- synonym that are actually dropped.+ -- (See GHC Trac #11416 for a scenario where this actually happened.)+ varTysExp <- mapM expandSyn varTysOrig++ let remainingLength :: Int+ remainingLength = length varTysOrig - fromEnum gClass++ droppedTysExp :: [Type]+ droppedTysExp = drop remainingLength varTysExp++ droppedStarKindStati :: [StarKindStatus]+ droppedStarKindStati = map canRealizeKindStar droppedTysExp++ -- Check there are enough types to drop and that all of them are either of+ -- kind * or kind k (for some kind variable k). If not, throw an error.+ when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $+ derivingKindError tyConName++ let droppedKindVarNames :: [Name]+ droppedKindVarNames = catKindVarNames droppedStarKindStati++ -- Substitute kind * for any dropped kind variables+ varTysExpSubst :: [Type]+ varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp++ -- We must take care to avoid allowing Generic1 instances where a visible kind+ -- binder is instantiated to * (which should only happen in the presence of+ -- -XTypeInType). See the documentation for instantiationError for an example+ -- of when this can occur.+ --+ -- A quick-and-dirty way to accomplish this is to check if the visible type+ -- binders of the original type, and of the type post-synonym-expansion, are+ -- both the same. If not, it's likely that one of the type binders was+ -- instantiated to a specific type (likely *).+ when (concatMap visibleTyVarsOfType varTysExp+ /= concatMap visibleTyVarsOfType varTysExpSubst) $+ instantiationError tyConName++ let remainingTysExpSubst, droppedTysExpSubst :: [Type]+ (remainingTysExpSubst, droppedTysExpSubst) =+ splitAt remainingLength varTysExpSubst++ -- If any of the dropped types were polykinded, ensure that there are of+ -- kind * after substituting * for the dropped kind variables. If not,+ -- throw an error.+ unless (all hasKindStar droppedTysExpSubst) $+ derivingKindError tyConName++ -- We now substitute all of the specialized-to-* kind variable names+ -- with *, but in the original types, not the synonym-expanded types. The reason+ -- we do this is a superficial one: we want the derived instance to resemble+ -- the datatype written in source code as closely as possible. For example,+ -- for the following data family instance:+ --+ -- data family Fam a+ -- newtype instance Fam String = Fam String+ --+ -- We'd want to generate the instance:+ --+ -- instance C (Fam String)+ --+ -- Not:+ --+ -- instance C (Fam [Char])+ let remainingTysOrigSubst :: [Type]+ remainingTysOrigSubst =+ map (substNamesWithKindStar droppedKindVarNames)+ $ take remainingLength varTysOrig++ remainingTysOrigSubst' :: [Type]+ -- See Note [Kind signatures in derived instances] for an explanation+ -- of the isDataFamily check.+ remainingTysOrigSubst' =+ if isDataFamily+ then remainingTysOrigSubst+ else map unSigT remainingTysOrigSubst++ instanceType :: Type+ instanceType = applyTyToTys (ConT tyConName) remainingTysOrigSubst'++ -- Ensure the dropped types can be safely eta-reduced. Otherwise,+ -- throw an error.+ unless (canEtaReduce remainingTysExpSubst droppedTysExpSubst) $+ etaReductionError instanceType+ return instanceType++-- See Note [Arguments to generated type synonyms]+grabTyVarBndrsFromCons :: GenericClass -> [Con] -> Q [TyVarBndr]+grabTyVarBndrsFromCons _ [] = return []+grabTyVarBndrsFromCons gClass (con:_) =+ fmap fst3 $ reifyConTys gClass (constructorName con)++{-+Note [Forcing buildTypeInstance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Sometimes, we don't explicitly need to generate a Generic(1) type instance, but+we force buildTypeInstance nevertheless. This is because it performs some checks+for whether or not the provided datatype can actually have Generic(1) implemented for+it, and produces errors if it can't. Otherwise, laziness would cause these checks+to be skipped entirely, which could result in some indecipherable type errors+down the road.++Note [Substituting types in constructor type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++While reifyConTys gives you the type variables of a constructor, they may not be+the same of the data declaration's type variables. The classic example of this is+GADTs:++ data GADT a b where+ GADTCon :: e -> f -> GADT e f++The type variables of GADTCon are completely different from the declaration's, which+can cause a problem when generating a Rep instance:++ type Rep (GADT a b) = Rec0 e :*: Rec0 f++Naïvely, we would generate something like this, since traversing the constructor+would give us precisely those arguments. Not good. We need to perform a type+substitution to ensure that e maps to a, and f maps to b.++This turns out to be surprisingly simple. Whenever you have a constructor type+signature like (e -> f -> GADT e f), take the result type, collect all of its+distinct type variables in order from left-to-right, and then map them to their+corresponding type variables from the data declaration.++There is another obscure case where we need to do a type subtitution. With+-XTypeInType enabled, you might have something like this:++ data Proxy (a :: k) (b :: k) = Proxy k deriving Generic1++Then k gets specialized to *, which means that k should NOT show up in the RHS of+a Rep1 type instance! To avoid this, make sure to substitute k with *.++Note [Arguments to generated type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++A surprisingly difficult component of generating the type synonyms for Rep/Rep1 is+coming up with the type synonym variable arguments, since they have to be just the+right name and kind to work. The type signature of a constructor does a remarkably+good job of coming up with these type variables for us, so if at least one constructor+exists, we simply steal the type variables from that constructor's type signature+for use in the generated type synonym. We also count the number of type variables+that the first constructor's type signature has in order to determine how many+type variables we should give it as arguments in the generated+(type Rep (Foo ...) = <makeRep> ...) code.++This leads one to ask: what if there are no constructors? If that's the case, then+we're OK, since that means no type variables can possibly appear on the RHS of the+type synonym! In such a special case, we're perfectly justified in making the type+synonym not have any type variable arguments, and similarly, we don't apply any+arguments to it in the generated (type Rep Foo = <makeRep>) code.++Note [Polykinded data families in Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In order to come up with the correct instance context and head for an instance, e.g.,++ instance C a => C (Data a) where ...++We need to know the exact types and kinds used to instantiate the instance. For+plain old datatypes, this is simple: every type must be a type variable, and+Template Haskell reliably tells us the type variables and their kinds.++Doing the same for data families proves to be much harder for three reasons:++1. On any version of Template Haskell, it may not tell you what an instantiated+ type's kind is. For instance, in the following data family instance:++ data family Fam (f :: * -> *) (a :: *)+ data instance Fam f a++ Then if we use TH's reify function, it would tell us the TyVarBndrs of the+ data family declaration are:++ [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT]++ and the instantiated types of the data family instance are:++ [VarT f1,VarT a1]++ We can't just pass [VarT f1,VarT a1] to buildTypeInstanceFromTys, since we+ have no way of knowing their kinds. Luckily, the TyVarBndrs tell us what the+ kind is in case an instantiated type isn't a SigT, so we use the stealKindForType+ function to ensure all of the instantiated types are SigTs before passing them+ to buildTypeInstanceFromTys.+2. On GHC 7.6 and 7.8, a bug is present in which Template Haskell lists all of+ the specified kinds of a data family instance efore any of the instantiated+ types. Fortunately, this is easy to deal with: you simply count the number of+ distinct kind variables in the data family declaration, take that many elements+ from the front of the Types list of the data family instance, substitute the+ kind variables with their respective instantiated kinds (which you took earlier),+ and proceed as normal.+3. On GHC 7.8, an even uglier bug is present (GHC Trac #9692) in which Template+ Haskell might not even list all of the Types of a data family instance, since+ they are eta-reduced away! And yes, kinds can be eta-reduced too.++ The simplest workaround is to count how many instantiated types are missing from+ the list and generate extra type variables to use in their place. Luckily, we+ needn't worry much if its kind was eta-reduced away, since using stealKindForType+ will get it back.++Note [Kind signatures in derived instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++It is possible to put explicit kind signatures into the derived instances, e.g.,++ instance C a => C (Data (f :: * -> *)) where ...++But it is preferable to avoid this if possible. If we come up with an incorrect+kind signature (which is entirely possible, since our type inferencer is pretty+unsophisticated - see Note [Type inference in derived instances]), then GHC will+flat-out reject the instance, which is quite unfortunate.++Plain old datatypes have the advantage that you can avoid using any kind signatures+at all in their instances. This is because a datatype declaration uses all type+variables, so the types that we use in a derived instance uniquely determine their+kinds. As long as we plug in the right types, the kind inferencer can do the rest+of the work. For this reason, we use unSigT to remove all kind signatures before+splicing in the instance context and head.++Data family instances are trickier, since a data family can have two instances that+are distinguished by kind alone, e.g.,++ data family Fam (a :: k)+ data instance Fam (a :: * -> *)+ data instance Fam (a :: *)++If we dropped the kind signatures for C (Fam a), then GHC will have no way of+knowing which instance we are talking about. To avoid this scenario, we always+include explicit kind signatures in data family instances. There is a chance that+the inferred kind signatures will be incorrect, but if so, we can always fall back+on the make- functions.++-}
src/Generics/Deriving/TH/Internal.hs view
@@ -15,14 +15,17 @@ module Generics.Deriving.TH.Internal where -import Data.Function (on)+import Data.Char (isAlphaNum, ord)+import Data.Foldable (foldr') import Data.List import qualified Data.Map as Map import Data.Map as Map (Map)+import Data.Maybe (mapMaybe) import qualified Data.Set as Set import Data.Set (Set) import Language.Haskell.TH.Lib+import Language.Haskell.TH.Ppr (pprint) import Language.Haskell.TH.Syntax #ifndef CURRENT_PACKAGE_KEY@@ -40,9 +43,18 @@ expandSyn (ForallT tvs ctx t) = fmap (ForallT tvs ctx) $ expandSyn t expandSyn t@AppT{} = expandSynApp t [] expandSyn t@ConT{} = expandSynApp t []-expandSyn (SigT t _) = expandSyn t -- Ignore kind synonyms+expandSyn (SigT t k) = do t' <- expandSyn t+ k' <- expandSynKind k+ return (SigT t' k') expandSyn t = return t +expandSynKind :: Kind -> Q Kind+#if MIN_VERSION_template_haskell(2,8,0)+expandSynKind = expandSyn+#else+expandSynKind = return -- There are no kind synonyms to deal with+#endif+ expandSynApp :: Type -> [Type] -> Q Type expandSynApp (AppT t1 t2) ts = do t2' <- expandSyn t2@@ -54,55 +66,140 @@ TyConI (TySynD _ tvs rhs) -> let (ts', ts'') = splitAt (length tvs) ts subs = mkSubst tvs ts'- rhs' = subst subs rhs+ rhs' = substType subs rhs in expandSynApp rhs' ts'' _ -> return $ foldl' AppT t ts expandSynApp t ts = do t' <- expandSyn t return $ foldl' AppT t' ts -type Subst = Map Name Type+type TypeSubst = Map Name Type+type KindSubst = Map Name Kind -mkSubst :: [TyVarBndr] -> [Type] -> Subst+mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst mkSubst vs ts =- let vs' = map tyVarBndrToName vs+ let vs' = map tyVarBndrName vs in Map.fromList $ zip vs' ts -subst :: Subst -> Type -> Type-subst subs (ForallT v c t) = ForallT v c $ subst subs t-subst subs t@(VarT n) = Map.findWithDefault t n subs-subst subs (AppT t1 t2) = AppT (subst subs t1) (subst subs t2)-subst subs (SigT t k) = SigT (subst subs t) k-subst _ t = t+substType :: TypeSubst -> Type -> Type+substType subs (ForallT v c t) = ForallT v c $ substType subs t+substType subs t@(VarT n) = Map.findWithDefault t n subs+substType subs (AppT t1 t2) = AppT (substType subs t1) (substType subs t2)+substType subs (SigT t k) = SigT (substType subs t)+#if MIN_VERSION_template_haskell(2,8,0)+ (substType subs k)+#else+ k+#endif+substType _ t = t +substKind :: KindSubst -> Type -> Type+#if MIN_VERSION_template_haskell(2,8,0)+substKind = substType+#else+substKind _ = id -- There are no kind variables!+#endif++substNameWithKind :: Name -> Kind -> Type -> Type+substNameWithKind n k = substKind (Map.singleton n k)++substNamesWithKindStar :: [Name] -> Type -> Type+substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns++substTyVarBndrKind :: KindSubst -> TyVarBndr -> TyVarBndr+substTyVarBndrKind _subs (KindedTV n k) = KindedTV n $+#if MIN_VERSION_template_haskell(2,8,0)+ substKind _subs k+#else+ k+#endif+substTyVarBndrKind _ tvb = tvb++substNameWithKindStarInTyVarBndr :: Name -> TyVarBndr -> TyVarBndr+substNameWithKindStarInTyVarBndr n = substTyVarBndrKind (Map.singleton n starK)+ ---------------------------------------------------------------------------------- NameBase+-- StarKindStatus ------------------------------------------------------------------------------- --- | A wrapper around Name which only uses the nameBase (not the entire Name)--- to compare for equality. For example, if you had two Names a_123 and a_456,--- they are not equal as Names, but they are equal as NameBases.------ This is useful when inspecting type variables, since a type variable in an--- instance context may have a distinct Name from a type variable within an--- actual constructor declaration, but we'd want to treat them as the same--- if they have the same nameBase (since that's what the programmer uses to--- begin with).-newtype NameBase = NameBase { getName :: Name }+-- | Whether a type is not of kind *, is of kind *, or is a kind variable.+data StarKindStatus = NotKindStar+ | KindStar+ | IsKindVar Name+ deriving Eq -getNameBase :: NameBase -> String-getNameBase = nameBase . getName+-- | Does a Type have kind * or k (for some kind variable k)?+canRealizeKindStar :: Type -> StarKindStatus+canRealizeKindStar t+ | hasKindStar t = KindStar+ | otherwise = case t of+#if MIN_VERSION_template_haskell(2,8,0)+ SigT _ (VarT k) -> IsKindVar k+#endif+ _ -> NotKindStar -instance Eq NameBase where- (==) = (==) `on` getNameBase+-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.+-- Otherwise, returns 'Nothing'.+starKindStatusToName :: StarKindStatus -> Maybe Name+starKindStatusToName (IsKindVar n) = Just n+starKindStatusToName _ = Nothing -instance Ord NameBase where- compare = compare `on` getNameBase+-- | Concat together all of the StarKindStatuses that are IsKindVar and extract+-- the kind variables' Names out.+catKindVarNames :: [StarKindStatus] -> [Name]+catKindVarNames = mapMaybe starKindStatusToName ------------------------------------------------------------------------------- -- Assorted utilities ------------------------------------------------------------------------------- +-- | Returns True if a Type has kind *.+hasKindStar :: Type -> Bool+hasKindStar VarT{} = True+#if MIN_VERSION_template_haskell(2,8,0)+hasKindStar (SigT _ StarT) = True+#else+hasKindStar (SigT _ StarK) = True+#endif+hasKindStar _ = False++tyVarNamesOfTyVarBndr :: TyVarBndr -> [Name]+tyVarNamesOfTyVarBndr (PlainTV n) = [n]+tyVarNamesOfTyVarBndr (KindedTV n k) = n:kindVarNamesOfKind k++-- | Gets all of the type/kind variable names mentioned somewhere in a Type.+tyVarNamesOfType :: Type -> [Name]+tyVarNamesOfType = go+ where+ go :: Type -> [Name]+ 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) = [n]+ go _ = []++-- | Gets all of the kind variable names mentioned somewhere in a Kind.+kindVarNamesOfKind :: Kind -> [Name]+#if MIN_VERSION_template_haskell(2,8,0)+kindVarNamesOfKind = tyVarNamesOfType+#else+kindVarNamesOfKind _ = [] -- There are no kind variables+#endif++-- | Gets all of the specified type/kind variable names mentioned in a Type. In+-- contrast to 'tyVarNamesOfType', 'visibleTyVarsOfType' does not go into kinds+-- of 'SigT's.+visibleTyVarsOfType :: Type -> [TyVarBndr]+visibleTyVarsOfType = go+ where+ go :: Type -> [TyVarBndr]+ go (AppT t1 t2) = go t1 ++ go t2+ go (SigT t _) = go t+ go (VarT n) = [PlainTV n]+ go _ = []+ -- | Is the given type a type family constructor (and not a data family constructor)? isTyFamily :: Type -> Q Bool isTyFamily (ConT n) = do@@ -121,13 +218,21 @@ _ -> False isTyFamily _ = return False +-- | True if the type does not mention the Name+ground :: Type -> Name -> Bool+ground (AppT t1 t2) name = ground t1 name && ground t2 name+ground (SigT t _) name = ground t name+ground (VarT t) name = t /= name+ground ForallT{} _ = rankNError+ground _ _ = True+ -- | Construct a type via curried application. applyTyToTys :: Type -> [Type] -> Type applyTyToTys = foldl' AppT -- | Apply a type constructor name to type variable binders. applyTyToTvbs :: Name -> [TyVarBndr] -> Type-applyTyToTvbs = foldl' (\a -> AppT a . VarT . tyVarBndrToName) . ConT+applyTyToTvbs = foldl' (\a -> AppT a . tyVarBndrToType) . ConT -- | Split an applied type into its individual components. For example, this: --@@ -144,72 +249,63 @@ unapplyTy = reverse . go where go :: Type -> [Type]- go (AppT t1 t2) = t2:go t1- go (SigT t _) = go t- go t = [t]+ go (AppT t1 t2) = t2 : go t1+ go (SigT t _) = go t+ go (ForallT _ _ t) = go t+ go t = [t] -- | Split a type signature by the arrows on its spine. For example, this: -- -- @--- (Int -> String) -> Char -> ()+-- forall a b. (a -> b) -> Char -> () -- @ -- -- would split to this: -- -- @--- [Int -> String, Char, ()]+-- ([a, b], [a -> b, Char, ()]) -- @-uncurryTy :: Type -> [Type]-uncurryTy (AppT (AppT ArrowT t1) t2) = t1:uncurryTy t2-uncurryTy (SigT t _) = uncurryTy t-uncurryTy t = [t]+uncurryTy :: Type -> ([TyVarBndr], [Type])+uncurryTy (AppT (AppT ArrowT t1) t2) =+ let (tvbs, tys) = uncurryTy t2+ in (tvbs, t1:tys)+uncurryTy (SigT t _) = uncurryTy t+uncurryTy (ForallT tvbs _ t) =+ let (tvbs', tys) = uncurryTy t+ in (tvbs ++ tvbs', tys)+uncurryTy t = ([], [t]) -- | Like uncurryType, except on a kind level.-uncurryKind :: Kind -> [Kind]+uncurryKind :: Kind -> ([TyVarBndr], [Kind]) #if MIN_VERSION_template_haskell(2,8,0) uncurryKind = uncurryTy #else-uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2-uncurryKind k = [k]+uncurryKind (ArrowK k1 k2) =+ let (kvbs, ks) = uncurryKind k2+ in (kvbs, k1:ks)+uncurryKind k = ([], [k]) #endif -canRealizeKindStar :: Kind -> Bool-canRealizeKindStar k = case uncurryKind k of- [k'] -> case k' of-#if MIN_VERSION_template_haskell(2,8,0)- StarT -> True- VarT{} -> True -- Kind k can be instantiated with *-#else- StarK -> True-#endif- _ -> False- _ -> False--wellKinded :: [Kind] -> Bool-wellKinded = all canRealizeKindStar---- | Replace the Name of a TyVarBndr with one from a Type (if the Type has a Name).-replaceTyVarName :: TyVarBndr -> Type -> TyVarBndr-replaceTyVarName tvb (SigT t _) = replaceTyVarName tvb t-replaceTyVarName PlainTV{} (VarT n) = PlainTV n-replaceTyVarName (KindedTV _ k) (VarT n) = KindedTV n k-replaceTyVarName tvb _ = tvb+tyVarBndrToType :: TyVarBndr -> Type+tyVarBndrToType (PlainTV n) = VarT n+tyVarBndrToType (KindedTV n k) = SigT (VarT n) k -tyVarBndrToName :: TyVarBndr -> Name-tyVarBndrToName (PlainTV name) = name-tyVarBndrToName (KindedTV name _) = name+tyVarBndrName :: TyVarBndr -> Name+tyVarBndrName (PlainTV name) = name+tyVarBndrName (KindedTV name _) = name -tyVarBndrToNameBase :: TyVarBndr -> NameBase-tyVarBndrToNameBase = NameBase . tyVarBndrToName+tyVarBndrKind :: TyVarBndr -> Kind+tyVarBndrKind PlainTV{} = starK+tyVarBndrKind (KindedTV _ k) = k -tyVarBndrToKind :: TyVarBndr -> Kind-tyVarBndrToKind PlainTV{} = starK-tyVarBndrToKind (KindedTV _ k) = k+-- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr.+stealKindForType :: TyVarBndr -> Type -> Type+stealKindForType tvb t@VarT{} = SigT t (tyVarBndrKind tvb)+stealKindForType _ t = t -stripRecordNames :: Con -> Con-stripRecordNames (RecC n f) =- NormalC n (map (\(_, s, t) -> (s, t)) f)-stripRecordNames c = c+-- | Generate a list of fresh names with a common prefix, and numbered suffixes.+newNameList :: String -> Int -> Q [Name]+newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n] -- | Checks to see if the last types in a data family instance can be safely eta- -- reduced (i.e., dropped), given the other types. This checks for three conditions:@@ -220,29 +316,56 @@ canEtaReduce :: [Type] -> [Type] -> Bool canEtaReduce remaining dropped = all isTyVar dropped- && allDistinct nbs -- Make sure not to pass something of type [Type], since Type- -- didn't have an Ord instance until template-haskell-2.10.0.0- && not (any (`mentionsNameBase` nbs) remaining)+ -- Make sure not to pass something of type [Type], since Type+ -- didn't have an Ord instance until template-haskell-2.10.0.0+ && allDistinct droppedNames+ && not (any (`mentionsName` droppedNames) remaining) where- nbs :: [NameBase]- nbs = map varTToNameBase dropped+ droppedNames :: [Name]+ droppedNames = map varTToName dropped --- | Extract the Name from a type variable.+-- | Extract the Name from a type variable. If the argument Type is not a+-- type variable, throw an error. varTToName :: Type -> Name varTToName (VarT n) = n varTToName (SigT t _) = varTToName t varTToName _ = error "Not a type variable!" --- | Extract the NameBase from a type variable.-varTToNameBase :: Type -> NameBase-varTToNameBase = NameBase . varTToName- -- | Is the given type a variable? isTyVar :: Type -> Bool isTyVar VarT{} = True isTyVar (SigT t _) = isTyVar t isTyVar _ = False +-- | Is the given kind a variable?+isKindVar :: Kind -> Bool+#if MIN_VERSION_template_haskell(2,8,0)+isKindVar = isTyVar+#else+isKindVar _ = False -- There are no kind variables+#endif++-- | Returns 'True' is a 'Type' contains no type variables.+isTypeMonomorphic :: Type -> Bool+isTypeMonomorphic = go+ where+ go :: Type -> Bool+ 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{} = False+ go _ = True++-- | Returns 'True' is a 'Kind' contains no kind variables.+isKindMonomorphic :: Kind -> Bool+#if MIN_VERSION_template_haskell(2,8,0)+isKindMonomorphic = isTypeMonomorphic+#else+isKindMonomorphic _ = True -- There are no kind variables+#endif+ -- | Peel off a kind signature from a Type (if it has one). unSigT :: Type -> Type unSigT (SigT t _) = t@@ -253,19 +376,18 @@ unKindedTV (KindedTV n _) = PlainTV n unKindedTV tvb = tvb --- | Does the given type mention any of the NameBases in the list?-mentionsNameBase :: Type -> [NameBase] -> Bool-mentionsNameBase = go Set.empty+-- | Does the given type mention any of the Names in the list?+mentionsName :: Type -> [Name] -> Bool+mentionsName = go where- go :: Set NameBase -> Type -> [NameBase] -> Bool- go foralls (ForallT tvbs _ t) nbs =- go (foralls `Set.union` Set.fromList (map tyVarBndrToNameBase tvbs)) t nbs- go foralls (AppT t1 t2) nbs = go foralls t1 nbs || go foralls t2 nbs- go foralls (SigT t _) nbs = go foralls t nbs- go foralls (VarT n) nbs = varNb `elem` nbs && not (varNb `Set.member` foralls)- where- varNb = NameBase n- go _ _ _ = False+ go :: Type -> [Name] -> Bool+ go (AppT t1 t2) names = go t1 names || go t2 names+ go (SigT t _k) names = go t names+#if MIN_VERSION_template_haskell(2,8,0)+ || go _k names+#endif+ go (VarT n) names = n `elem` names+ go _ _ = False -- | Are all of the items in a list (which have an ordering) distinct? --@@ -279,9 +401,18 @@ | otherwise = allDistinct' (Set.insert x uniqs) xs allDistinct' _ _ = True -trd :: (a, b, c) -> c-trd (_,_,c) = c+fst3 :: (a, b, c) -> a+fst3 (a, _, _) = a +snd3 :: (a, b, c) -> b+snd3 (_, b, _) = b++trd3 :: (a, b, c) -> c+trd3 (_, _, c) = c++shrink :: (a, b, c) -> (b, c)+shrink (_, b, c) = (b, c)+ -- | Variant of foldr1 which returns a special element for empty lists foldr1' :: (a -> a -> a) -> a -> [a] -> a foldr1' _ x [] = x@@ -294,15 +425,263 @@ constructorName (RecC name _ ) = name constructorName (InfixC _ name _ ) = name constructorName (ForallC _ _ con) = constructorName con+#if MIN_VERSION_template_haskell(2,11,0)+constructorName (GadtC names _ _) = head names+constructorName (RecGadtC names _ _) = head names+#endif #if MIN_VERSION_template_haskell(2,7,0) -- | Extracts the constructors of a data or newtype declaration. dataDecCons :: Dec -> [Con]-dataDecCons (DataInstD _ _ _ cons _) = cons-dataDecCons (NewtypeInstD _ _ _ con _) = [con]+dataDecCons (DataInstD _ _ _+# if MIN_VERSION_template_haskell(2,11,0)+ _+# endif+ cons _) = cons+dataDecCons (NewtypeInstD _ _ _+# if MIN_VERSION_template_haskell(2,11,0)+ _+# endif+ con _) = [con] dataDecCons _ = error "Must be a data or newtype declaration." #endif +-- | Indicates whether Generic or Generic1 is being derived.+data GenericClass = Generic | Generic1 deriving Enum++-- | Like 'GenericArity', but bundling two things in the 'Gen1' case:+--+-- 1. The 'Name' of the last type parameter.+-- 2. If that last type parameter had kind k (where k is some kind variable),+-- then it has 'Just' the kind variable 'Name'. Otherwise, it has 'Nothing'.+data GenericKind = Gen0+ | Gen1 Name (Maybe Name)++-- Determines the universally quantified type variables, the types of a constructor's+-- arguments, and the last type parameter name (if there is one).+reifyConTys :: GenericClass+ -> Name+ -> Q ([TyVarBndr], [Type], GenericKind)+reifyConTys gClass conName = do+ info <- reify conName+ let (tvbs, uncTy) = case info of+ DataConI _ ty _+#if !(MIN_VERSION_template_haskell(2,11,0))+ _+#endif+ -> uncurryTy ty+ _ -> error "Must be a data constructor"+ let (argTys, [resTy]) = splitAt (length uncTy - 1) uncTy+ -- Make sure to expand through synonyms on the last type, or else you might+ -- have something like+ --+ -- type Constant a b = a+ -- data Good a = Good (Constant a b)+ --+ -- which you'd only be able to tell was legal if you expand Constant a b to a!+ resTyExp <- expandSyn resTy+ let numResTyVars = length . nub $ visibleTyVarsOfType resTyExp+ -- ^ We need to grab a number of type variables from the constructor's+ -- type signature to re-use for the Rep(1) type synonym's type variable+ -- binders. As it turns out, that number is equal to the number of distinct+ -- type variables which appear in the result type.+ --+ -- We assume that the visible type variables all come last in the list+ -- of forall'd type variables. I suppose nothing guarantees this, but+ -- this seems to always be the case via experimentation. Fingers crossed.+ -- TODO: This doesn't work with -XTypeInType and data families+ visibleTvbs = drop (length tvbs - numResTyVars) tvbs+ let (visibleTvbs', gk) = case gClass of+ Generic -> (visibleTvbs, Gen0)+ Generic1 ->+ -- If deriving Generic1 and the last type variable is polykinded,+ -- make sure to substitute that kind with * in the other type+ -- variable binders' kind signatures+ let headVisibleTvbs :: [TyVarBndr]+ lastVisibleTvb :: TyVarBndr+ (headVisibleTvbs, [lastVisibleTvb]) =+ splitAt (length visibleTvbs - 1) visibleTvbs++ mbLastArgKindName :: Maybe Name+ mbLastArgKindName = starKindStatusToName+ . canRealizeKindStar+ $ tyVarBndrToType lastVisibleTvb++ visibleTvbsSubst :: [TyVarBndr]+ visibleTvbsSubst =+ case mbLastArgKindName of+ Nothing -> headVisibleTvbs+ Just lakn -> map (substNameWithKindStarInTyVarBndr lakn)+ headVisibleTvbs+ in ( visibleTvbsSubst+ , Gen1 (tyVarBndrName lastVisibleTvb) mbLastArgKindName+ )+ return (visibleTvbs', argTys, gk)++-- | Indicates whether Generic(1) is being derived for a plain data type (DataPlain)+-- or a data family instance (DataFamily). DataFamily bundles the Name of the data+-- family instance's first constructor (for Name-generation purposes) and the types+-- used to instantiate the instance.+data DataVariety = DataPlain | DataFamily Name [Type]++showsDataVariety :: DataVariety -> ShowS+showsDataVariety dv = (++ '_':label dv)+ where+ label DataPlain = "Plain"+ label (DataFamily n _) = "Family_" ++ sanitizeName (nameBase n)++showNameQual :: Name -> String+showNameQual = sanitizeName . showQual+ where+ showQual (Name _ (NameQ m)) = modString m+ showQual (Name _ (NameG _ pkg m)) = pkgString pkg ++ ":" ++ modString m+ showQual _ = ""++-- | Credit to Víctor López Juan for this trick+sanitizeName :: String -> String+sanitizeName nb = 'N':(+ nb >>= \x -> case x of+ c | isAlphaNum c || c == '\''-> [c]+ '_' -> "__"+ c -> "_" ++ show (ord c))++-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce+-- function for the criteria it would have to meet).+etaReductionError :: Type -> a+etaReductionError instanceType = error $+ "Cannot eta-reduce to an instance of form \n\tinstance (...) => "+ ++ pprint instanceType++-- | Either the given data type doesn't have enough type variables, or one of+-- the type variables to be eta-reduced cannot realize kind *.+derivingKindError :: Name -> a+derivingKindError tyConName = error+ . showString "Cannot derive well-kinded instance of form ‘Generic1 "+ . showParen True+ ( showString (nameBase tyConName)+ . showString " ..."+ )+ . showString "‘\n\tClass Generic1 expects an argument of kind * -> *"+ $ ""++outOfPlaceTyVarError :: a+outOfPlaceTyVarError = error $+ "Type applied to an argument involving the last parameter is not of kind * -> *"++-- | Deriving Generic(1) doesn't work with ExistentialQuantification or GADTs+gadtError :: Con -> a+gadtError con = error $+ nameBase (constructorName con) ++ " must be a vanilla data constructor"++-- | Cannot have a constructor argument of form (forall a1 ... an. <type>)+-- when deriving Generic(1)+rankNError :: a+rankNError = error "Cannot have polymorphic arguments"++-- | Cannot have a Generic(1) instance where the instance head's type is instantiated+-- to be a more "saturated" type than the original data declaration. That means+-- something like this would be rejected:+--+-- @+-- {-# LANGUAGE TypeInType #-}+-- data Hm k (a :: k) deriving Generic1+-- @+--+-- Since having a Generic1 instance would force k to be instantiated with *,+-- resulting in an instance Generic1 (Hm *) instead of instance Generic1 (Hm k).+instantiationError :: Name -> a+instantiationError tyConName = error $+ nameBase tyConName ++ " must not be instantiated"++-- | Boilerplate for top level splices.+--+-- The given Name must meet one of two criteria:+--+-- 1. It must be the name of a type constructor of a plain data type or newtype.+-- 2. It must be the name of a data family instance or newtype instance constructor.+--+-- Any other value will result in an exception.+reifyDataInfo :: Name+ -> Q (Either String (Name, Bool, [TyVarBndr], [Con], DataVariety))+reifyDataInfo name = do+ info <- reify name+ case info of+ TyConI dec ->+ return $ case dec of+ DataD ctxt _ tvbs+#if MIN_VERSION_template_haskell(2,11,0)+ _+#endif+ cons _ -> Right $+ checkDataContext name ctxt (name, False, tvbs, cons, DataPlain)+ NewtypeD ctxt _ tvbs+#if MIN_VERSION_template_haskell(2,11,0)+ _+#endif+ con _ -> Right $+ checkDataContext name ctxt (name, True, tvbs, [con], DataPlain)+ TySynD{} -> Left $ ns ++ "Type synonyms are not supported."+ _ -> Left $ ns ++ "Unsupported type: " ++ show dec+#if MIN_VERSION_template_haskell(2,7,0)+# if MIN_VERSION_template_haskell(2,11,0)+ DataConI _ _ parentName -> do+# else+ DataConI _ _ parentName _ -> do+# endif+ parentInfo <- reify parentName+ return $ case parentInfo of+# if MIN_VERSION_template_haskell(2,11,0)+ FamilyI (DataFamilyD _ tvbs _) decs ->+# else+ FamilyI (FamilyD DataFam _ tvbs _) decs ->+# endif+ -- This isn't total, but the API requires that the data family instance have+ -- at least one constructor anyways, so this will always succeed.+ let instDec = flip find decs $ any ((name ==) . constructorName) . dataDecCons+ in case instDec of+ Just (DataInstD ctxt _ instTys+# if MIN_VERSION_template_haskell(2,11,0)+ _+# endif+ cons _) -> Right $+ checkDataContext parentName ctxt+ (parentName, False, tvbs, cons, DataFamily (constructorName $ head cons) instTys)+ Just (NewtypeInstD ctxt _ instTys+# if MIN_VERSION_template_haskell(2,11,0)+ _+# endif+ con _) -> Right $+ checkDataContext parentName ctxt+ (parentName, True, tvbs, [con], DataFamily (constructorName con) instTys)+ _ -> Left $ ns +++ "Could not find data or newtype instance constructor."+ _ -> Left $ ns ++ "Data constructor " ++ show name +++ " is not from a data family instance constructor."+# if MIN_VERSION_template_haskell(2,11,0)+ FamilyI DataFamilyD{} _ ->+# else+ FamilyI (FamilyD DataFam _ _ _) _ ->+# endif+ return . Left $+ ns ++ "Cannot use a data family name. Use a data family instance constructor instead."+ _ -> return . Left $ ns ++ "The name must be of a plain data type constructor, "+ ++ "or a data family instance constructor."+#else+ DataConI{} -> return . Left $ ns ++ "Cannot use a data constructor."+ ++ "\n\t(Note: if you are trying to derive for a data family instance, use GHC >= 7.4 instead.)"+ _ -> return . Left $ ns ++ "The name must be of a plain type constructor."+#endif+ where+ ns :: String+ ns = "Generics.Deriving.TH.reifyDataInfo: "++-- | One cannot derive Generic(1) instance for anything that uses DatatypeContexts,+-- so check to make sure the Cxt field of a datatype is null.+checkDataContext :: Name -> Cxt -> a -> a+checkDataContext _ [] x = x+checkDataContext dataName _ _ = error $+ nameBase dataName ++ " must not have a datatype context"+ ------------------------------------------------------------------------------- -- Manually quoted names -------------------------------------------------------------------------------@@ -366,6 +745,15 @@ mkGD7'11_v = mkNameG_v gdPackageKey "Generics.Deriving.Base" #endif +mkBaseName_d :: String -> String -> Name+mkBaseName_d = mkNameG_d "base"++mkGHCPrimName_d :: String -> String -> Name+mkGHCPrimName_d = mkNameG_d "ghc-prim"++mkGHCPrimName_tc :: String -> String -> Name+mkGHCPrimName_tc = mkNameG_tc "ghc-prim"+ comp1DataName :: Name comp1DataName = mkGD7'1_d "Comp1" @@ -527,11 +915,6 @@ moduleNameValName :: Name moduleNameValName = mkGD7'1_v "moduleName" -#if __GLASGOW_HASKELL__ >= 711-packageNameValName :: Name-packageNameValName = mkGD7'1_v "packageName"-#endif- selNameValName :: Name selNameValName = mkGD7'1_v "selName" @@ -571,13 +954,24 @@ unRec1ValName :: Name unRec1ValName = mkGD7'1_v "unRec1" -trueDataName :: Name+trueDataName, falseDataName :: Name #if __GLASGOW_HASKELL__ >= 701-trueDataName = mkNameG_d "ghc-prim" "GHC.Types" "True"+trueDataName = mkGHCPrimName_d "GHC.Types" "True"+falseDataName = mkGHCPrimName_d "GHC.Types" "False" #else-trueDataName = mkNameG_d "ghc-prim" "GHC.Bool" "True"+trueDataName = mkGHCPrimName_d "GHC.Bool" "True"+falseDataName = mkGHCPrimName_d "GHC.Bool" "False" #endif +nothingDataName, justDataName :: Name+#if __GLASGOW_HASKELL__ >= 709+nothingDataName = mkBaseName_d "GHC.Base" "Nothing"+justDataName = mkBaseName_d "GHC.Base" "Just"+#else+nothingDataName = mkBaseName_d "Data.Maybe" "Nothing"+justDataName = mkBaseName_d "Data.Maybe" "Just"+#endif+ mkGHCPrim_tc :: String -> Name mkGHCPrim_tc = mkNameG_tc "ghc-prim" "GHC.Prim" @@ -610,3 +1004,58 @@ undefinedValName :: Name undefinedValName = mkNameG_v "base" "GHC.Err" "undefined"++#if __GLASGOW_HASKELL__ >= 705 && __GLASGOW_HASKELL__ < 711+starKindName :: Name+starKindName = mkGHCPrimName_tc "GHC.Prim" "*"+#endif++#if __GLASGOW_HASKELL__ >= 711+decidedLazyDataName :: Name+decidedLazyDataName = mkGD7'11_d "DecidedLazy"++decidedStrictDataName :: Name+decidedStrictDataName = mkGD7'11_d "DecidedStrict"++decidedUnpackDataName :: Name+decidedUnpackDataName = mkGD7'11_d "DecidedUnpack"++infixIDataName :: Name+infixIDataName = mkGD7'11_d "InfixI"++metaConsDataName :: Name+metaConsDataName = mkGD7'11_d "MetaCons"++metaDataDataName :: Name+metaDataDataName = mkGD7'11_d "MetaData"++metaNoSelDataName :: Name+metaNoSelDataName = mkGD7'11_d "MetaNoSel"++metaSelDataName :: Name+metaSelDataName = mkGD7'11_d "MetaSel"++noSourceStrictnessDataName :: Name+noSourceStrictnessDataName = mkGD7'11_d "NoSourceStrictness"++noSourceUnpackednessDataName :: Name+noSourceUnpackednessDataName = mkGD7'11_d "NoSourceUnpackedness"++prefixIDataName :: Name+prefixIDataName = mkGD7'11_d "PrefixI"++sourceLazyDataName :: Name+sourceLazyDataName = mkGD7'11_d "SourceLazy"++sourceNoUnpackDataName :: Name+sourceNoUnpackDataName = mkGD7'11_d "SourceNoUnpack"++sourceStrictDataName :: Name+sourceStrictDataName = mkGD7'11_d "SourceStrict"++sourceUnpackDataName :: Name+sourceUnpackDataName = mkGD7'11_d "SourceUnpack"++packageNameValName :: Name+packageNameValName = mkGD7'1_v "packageName"+#endif
+ src/Generics/Deriving/TH/Post711.hs view
@@ -0,0 +1,138 @@+-----------------------------------------------------------------------------+-- |+-- Module : Generics.Deriving.TH.Post711+-- Copyright : (c) 2008--2009 Universiteit Utrecht+-- License : BSD3+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- Template Haskell machinery for the type-literal-based variant of GHC+-- generics introduced in GHC 7.11.+-----------------------------------------------------------------------------++module Generics.Deriving.TH.Post711 (+ deriveMeta+ , deriveData+ , deriveConstructors+ , deriveSelectors+ , mkMetaDataType+ , mkMetaConsType+ , mkMetaSelType+ , SelStrictInfo(..)+ , reifySelStrictInfo+ ) where++import Data.Maybe (fromMaybe)++import Generics.Deriving.TH.Internal++import Language.Haskell.TH.Lib+import Language.Haskell.TH.Syntax++mkMetaDataType :: DataVariety -> Name -> Bool -> Q Type+mkMetaDataType _ n isNewtype =+ promotedT metaDataDataName+ `appT` litT (strTyLit (nameBase n))+ `appT` litT (strTyLit m)+ `appT` litT (strTyLit pkg)+ `appT` promoteBool isNewtype+ where+ m, pkg :: String+ m = fromMaybe (error "Cannot fetch module name!") (nameModule n)+ pkg = fromMaybe (error "Cannot fetch package name!") (namePackage n)++mkMetaConsType :: DataVariety -> Name -> Name -> Bool -> Bool -> Q Type+mkMetaConsType _ _ n conIsRecord conIsInfix = do+ mbFi <- reifyFixity n+ promotedT metaConsDataName+ `appT` litT (strTyLit (nameBase n))+ `appT` fixityIPromotedType mbFi conIsInfix+ `appT` promoteBool conIsRecord++promoteBool :: Bool -> Q Type+promoteBool True = promotedT trueDataName+promoteBool False = promotedT falseDataName++fixityIPromotedType :: Maybe Fixity -> Bool -> Q Type+fixityIPromotedType mbFi True =+ promotedT infixIDataName+ `appT` promoteAssociativity a+ `appT` litT (numTyLit (toInteger n))+ where+ Fixity n a = fromMaybe defaultFixity mbFi+fixityIPromotedType _ False = promotedT prefixIDataName++promoteAssociativity :: FixityDirection -> Q Type+promoteAssociativity InfixL = promotedT leftAssociativeDataName+promoteAssociativity InfixR = promotedT rightAssociativeDataName+promoteAssociativity InfixN = promotedT notAssociativeDataName++mkMetaSelType :: DataVariety -> Name -> Name -> Maybe Name -> SelStrictInfo -> Q Type+mkMetaSelType _ _ _ mbF (SelStrictInfo su ss ds) =+ let mbSelNameT = case mbF of+ Just f -> promotedT justDataName `appT` litT (strTyLit (nameBase f))+ Nothing -> promotedT nothingDataName+ in promotedT metaSelDataName+ `appT` mbSelNameT+ `appT` promoteSourceUnpackedness su+ `appT` promoteSourceStrictness ss+ `appT` promoteDecidedStrictness ds++data SelStrictInfo = SelStrictInfo SourceUnpackedness SourceStrictness DecidedStrictness++promoteSourceUnpackedness :: SourceUnpackedness -> Q Type+promoteSourceUnpackedness NoSourceUnpackedness = promotedT noSourceUnpackednessDataName+promoteSourceUnpackedness SourceNoUnpack = promotedT sourceNoUnpackDataName+promoteSourceUnpackedness SourceUnpack = promotedT sourceUnpackDataName++promoteSourceStrictness :: SourceStrictness -> Q Type+promoteSourceStrictness NoSourceStrictness = promotedT noSourceStrictnessDataName+promoteSourceStrictness SourceLazy = promotedT sourceLazyDataName+promoteSourceStrictness SourceStrict = promotedT sourceStrictDataName++promoteDecidedStrictness :: DecidedStrictness -> Q Type+promoteDecidedStrictness DecidedLazy = promotedT decidedLazyDataName+promoteDecidedStrictness DecidedStrict = promotedT decidedStrictDataName+promoteDecidedStrictness DecidedUnpack = promotedT decidedUnpackDataName++reifySelStrictInfo :: Name -> [Bang] -> Q [SelStrictInfo]+reifySelStrictInfo conName bangs = do+ dcdStrs <- reifyConStrictness conName+ let (srcUnpks, srcStrs) = unzip $ map splitBang bangs+ return $ zipWith3 SelStrictInfo srcUnpks srcStrs dcdStrs++splitBang :: Bang -> (SourceUnpackedness, SourceStrictness)+splitBang (Bang su ss) = (su, ss)++-- | Given the type and the name (as string) for the type to derive,+-- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector'+-- instances.+--+-- On GHC 7.11 and up, this functionality is no longer used in GHC generics,+-- so this function generates no declarations.+deriveMeta :: Name -> Q [Dec]+deriveMeta _ = return []++-- | Given a datatype name, derive a datatype and instance of class 'Datatype'.+--+-- On GHC 7.11 and up, this functionality is no longer used in GHC generics,+-- so this function generates no declarations.+deriveData :: Name -> Q [Dec]+deriveData _ = return []++-- | Given a datatype name, derive datatypes and+-- instances of class 'Constructor'.+--+-- On GHC 7.11 and up, this functionality is no longer used in GHC generics,+-- so this function generates no declarations.+deriveConstructors :: Name -> Q [Dec]+deriveConstructors _ = return []++-- | Given a datatype name, derive datatypes and instances of class 'Selector'.+--+-- On GHC 7.11 and up, this functionality is no longer used in GHC generics,+-- so this function generates no declarations.+deriveSelectors :: Name -> Q [Dec]+deriveSelectors _ = return []
+ src/Generics/Deriving/TH/Pre711.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+-- |+-- Module : Generics.Deriving.TH.Pre711+-- Copyright : (c) 2008--2009 Universiteit Utrecht+-- License : BSD3+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- Template Haskell machinery for the proxy datatype variant of GHC generics+-- used up until GHC 7.11.+-----------------------------------------------------------------------------++module Generics.Deriving.TH.Pre711 (+ deriveMeta+ , deriveData+ , deriveConstructors+ , deriveSelectors+ , mkMetaDataType+ , mkMetaConsType+ , mkMetaSelType+ , SelStrictInfo+ , reifySelStrictInfo+ ) where++import Data.List (intercalate)+import Data.Maybe (fromMaybe)++import Generics.Deriving.TH.Internal++import Language.Haskell.TH.Lib+import Language.Haskell.TH.Syntax++-- | Given the type and the name (as string) for the type to derive,+-- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector'+-- instances.+deriveMeta :: Name -> Q [Dec]+deriveMeta n =+ do a <- deriveData n+ b <- deriveConstructors n+ c <- deriveSelectors n+ return (a ++ b ++ c)++-- | Given a datatype name, derive a datatype and instance of class 'Datatype'.+deriveData :: Name -> Q [Dec]+deriveData = dataInstance++-- | Given a datatype name, derive datatypes and+-- instances of class 'Constructor'.+deriveConstructors :: Name -> Q [Dec]+deriveConstructors = constrInstance++-- | Given a datatype name, derive datatypes and instances of class 'Selector'.+deriveSelectors :: Name -> Q [Dec]+deriveSelectors = selectInstance++dataInstance :: Name -> Q [Dec]+dataInstance n = do+ i <- reifyDataInfo n+ case i of+ Left _ -> return []+ Right (n', isNT, _, _, dv) -> mkInstance n' dv isNT+ where+ mkInstance n' dv isNT = do+ ds <- mkDataData dv n'+ is <- mkDataInstance dv n' isNT+ return $ [ds,is]++constrInstance :: Name -> Q [Dec]+constrInstance n = do+ i <- reifyDataInfo n+ case i of+ Left _ -> return []+ Right (n', _, _, cs, dv) -> mkInstance n' cs dv+ where+ mkInstance n' cs dv = do+ ds <- mapM (mkConstrData dv n') cs+ is <- mapM (mkConstrInstance dv n') cs+ return $ ds ++ is++selectInstance :: Name -> Q [Dec]+selectInstance n = do+ i <- reifyDataInfo n+ case i of+ Left _ -> return []+ Right (n', _, _, cs, dv) -> mkInstance n' cs dv+ where+ mkInstance n' cs dv = do+ ds <- mapM (mkSelectData dv n') cs+ is <- mapM (mkSelectInstance dv n') cs+ return $ concat (ds ++ is)++mkDataData :: DataVariety -> Name -> Q Dec+mkDataData dv n = dataD (cxt []) (genName dv [n]) [] [] []++mkConstrData :: DataVariety -> Name -> Con -> Q Dec+mkConstrData dv dt (NormalC n _) =+ dataD (cxt []) (genName dv [dt, n]) [] [] []+mkConstrData dv dt (RecC n f) =+ mkConstrData dv dt (NormalC n (map shrink f))+mkConstrData dv dt (InfixC t1 n t2) =+ mkConstrData dv dt (NormalC n [t1,t2])+mkConstrData _ _ con = gadtError con++mkSelectData :: DataVariety -> Name -> Con -> Q [Dec]+mkSelectData dv dt (RecC n fs) = return (map one fs)+ where one (f, _, _) = DataD [] (genName dv [dt, n, f]) [] [] []+mkSelectData _ _ _ = return []++mkDataInstance :: DataVariety -> Name -> Bool -> Q Dec+mkDataInstance dv n isNewtype =+ instanceD (cxt []) (appT (conT datatypeTypeName) (mkMetaDataType dv n isNewtype)) $+ [ funD datatypeNameValName [clause [wildP] (normalB (stringE (nameBase n))) []]+ , funD moduleNameValName [clause [wildP] (normalB (stringE name)) []]+ ]+#if __GLASGOW_HASKELL__ >= 708+ ++ if isNewtype+ then [funD isNewtypeValName [clause [wildP] (normalB (conE trueDataName)) []]]+ else []+#endif+ where+ name = fromMaybe (error "Cannot fetch module name!") (nameModule n)++liftFixity :: Fixity -> Q Exp+liftFixity (Fixity n a) = conE infixDataName+ `appE` liftAssociativity a+ `appE` lift n++liftAssociativity :: FixityDirection -> Q Exp+liftAssociativity InfixL = conE leftAssociativeDataName+liftAssociativity InfixR = conE rightAssociativeDataName+liftAssociativity InfixN = conE notAssociativeDataName++mkConstrInstance :: DataVariety -> Name -> Con -> Q Dec+mkConstrInstance dv dt (NormalC n _) = mkConstrInstanceWith dv dt n False False []+mkConstrInstance dv dt (RecC n _) =+ mkConstrInstanceWith dv dt n True False+ [funD conIsRecordValName [clause [wildP] (normalB (conE trueDataName)) []]]+mkConstrInstance dv dt (InfixC _ n _) = do+ i <- reify n+ let fi = case i of+ DataConI _ _ _ f -> f+ _ -> error $ "Not a data constructor name: " ++ show n+ mkConstrInstanceWith dv dt n False True+ [funD conFixityValName [clause [wildP] (normalB (liftFixity fi)) []]]+mkConstrInstance _ _ con = gadtError con++mkConstrInstanceWith :: DataVariety+ -> Name+ -> Name+ -> Bool+ -> Bool+ -> [Q Dec]+ -> Q Dec+mkConstrInstanceWith dv dt n isRecord isInfix extra =+ instanceD+ (cxt [])+ (appT (conT constructorTypeName) (mkMetaConsType dv dt n isRecord isInfix))+ (funD conNameValName [clause [wildP] (normalB (stringE (nameBase n))) []] : extra)++mkSelectInstance :: DataVariety -> Name -> Con -> Q [Dec]+mkSelectInstance dv dt (RecC n fs) = mapM (one . fst3) fs where+ one :: Name -> Q Dec+ one f =+ instanceD (cxt []) (appT (conT selectorTypeName) (mkMetaSelType dv dt n (Just f) ()))+ [funD selNameValName [clause [wildP]+ (normalB (litE (stringL (nameBase f)))) []]]+mkSelectInstance _ _ _ = return []++genName :: DataVariety -> [Name] -> Name+genName dv ns = mkName+ . showsDataVariety dv+ . intercalate "_"+ . consQualName+ $ map (sanitizeName . nameBase) ns+ where+ consQualName :: [String] -> [String]+ consQualName = case ns of+ [] -> id+ n:_ -> (showNameQual n :)++mkMetaDataType :: DataVariety -> Name -> Bool -> Q Type+mkMetaDataType dv n _ = conT $ genName dv [n]++mkMetaConsType :: DataVariety -> Name -> Name -> Bool -> Bool -> Q Type+mkMetaConsType dv dt n _ _ = conT $ genName dv [dt, n]++mkMetaSelType :: DataVariety -> Name -> Name -> Maybe Name -> SelStrictInfo -> Q Type+mkMetaSelType dv dt n (Just f) () = conT $ genName dv [dt, n, f]+mkMetaSelType _ _ _ Nothing () = conT noSelectorTypeName++type SelStrictInfo = ()++reifySelStrictInfo :: Name -> [Strict] -> Q [SelStrictInfo]+reifySelStrictInfo _ bangs = return (map (const ()) bangs)
src/Generics/Deriving/Traversable.hs view
@@ -1,101 +1,212 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -module Generics.Deriving.Traversable ( - -- * GTraversable class - GTraversable(..) - - -- * Default method - , gtraversedefault - - ) where - -import Control.Applicative - -import Generics.Deriving.Base -import Generics.Deriving.Foldable -import Generics.Deriving.Functor -import Generics.Deriving.Instances () - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -#endif - --------------------------------------------------------------------------------- --- Generic traverse --------------------------------------------------------------------------------- - -class GTraversable' t where - gtraverse' :: Applicative f => (a -> f b) -> t a -> f (t b) - -instance GTraversable' U1 where - gtraverse' _ U1 = pure U1 - -instance GTraversable' Par1 where - gtraverse' f (Par1 a) = Par1 <$> f a - -instance GTraversable' (K1 i c) where - gtraverse' _ (K1 a) = pure (K1 a) - -instance (GTraversable f) => GTraversable' (Rec1 f) where - gtraverse' f (Rec1 a) = Rec1 <$> gtraverse f a - -instance (GTraversable' f) => GTraversable' (M1 i c f) where - gtraverse' f (M1 a) = M1 <$> gtraverse' f a - -instance (GTraversable' f, GTraversable' g) => GTraversable' (f :+: g) where - gtraverse' f (L1 a) = L1 <$> gtraverse' f a - gtraverse' f (R1 a) = R1 <$> gtraverse' f a - -instance (GTraversable' f, GTraversable' g) => GTraversable' (f :*: g) where - gtraverse' f (a :*: b) = (:*:) <$> gtraverse' f a <*> gtraverse' f b - -instance (GTraversable f, GTraversable' g) => GTraversable' (f :.: g) where - gtraverse' f (Comp1 x) = Comp1 <$> gtraverse (gtraverse' f) x - - -class (GFunctor t, GFoldable t) => GTraversable t where - gtraverse :: Applicative f => (a -> f b) -> t a -> f (t b) -#if __GLASGOW_HASKELL__ >= 701 - default gtraverse :: (Generic1 t, GTraversable' (Rep1 t), Applicative f) - => (a -> f b) -> t a -> f (t b) - gtraverse = gtraversedefault -#endif - - gsequenceA :: Applicative f => t (f a) -> f (t a) - gsequenceA = gtraverse id - - gmapM :: Monad m => (a -> m b) -> t a -> m (t b) - gmapM f = unwrapMonad . gtraverse (WrapMonad . f) - - gsequence :: Monad m => t (m a) -> m (t a) - gsequence = gmapM id - -gtraversedefault :: (Generic1 t, GTraversable' (Rep1 t), Applicative f) - => (a -> f b) -> t a -> f (t b) -gtraversedefault f x = to1 <$> gtraverse' f (from1 x) - --- Base types instances -instance GTraversable [] where - gtraverse = gtraversedefault - -instance GTraversable ((,) a) where - gtraverse = gtraversedefault - -instance GTraversable (Const m) where - gtraverse = gtraversedefault - -instance GTraversable (Either a) where - gtraverse = gtraversedefault - -#if MIN_VERSION_base(4,8,0) -instance GTraversable Identity where - gtraverse = gtraversedefault -#endif - -instance GTraversable Maybe where - gtraverse = gtraversedefault +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+#endif++module Generics.Deriving.Traversable (+ -- * GTraversable class+ GTraversable(..)++ -- * Default method+ , gtraversedefault++ ) where++import Control.Applicative (Const, WrappedMonad(..), ZipList)+#if !(MIN_VERSION_base(4,8,0))+import Control.Applicative (Applicative(..), (<$>))+#endif++import qualified Data.Monoid as Monoid (First, Last, Product, Sum)+import Data.Monoid (Dual)++import Generics.Deriving.Base+import Generics.Deriving.Foldable+import Generics.Deriving.Functor+import Generics.Deriving.Instances ()++#if MIN_VERSION_base(4,4,0)+import Data.Complex (Complex)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+#endif++#if MIN_VERSION_base(4,9,0)+import qualified Data.Functor.Product as Functor (Product)+import qualified Data.Functor.Sum as Functor (Sum)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg, Max, Min, Option, WrappedMonoid)+#endif++--------------------------------------------------------------------------------+-- Generic traverse+--------------------------------------------------------------------------------++class GTraversable' t where+ gtraverse' :: Applicative f => (a -> f b) -> t a -> f (t b)++instance GTraversable' U1 where+ gtraverse' _ U1 = pure U1++instance GTraversable' Par1 where+ gtraverse' f (Par1 a) = Par1 <$> f a++instance GTraversable' (K1 i c) where+ gtraverse' _ (K1 a) = pure (K1 a)++instance (GTraversable f) => GTraversable' (Rec1 f) where+ gtraverse' f (Rec1 a) = Rec1 <$> gtraverse f a++instance (GTraversable' f) => GTraversable' (M1 i c f) where+ gtraverse' f (M1 a) = M1 <$> gtraverse' f a++instance (GTraversable' f, GTraversable' g) => GTraversable' (f :+: g) where+ gtraverse' f (L1 a) = L1 <$> gtraverse' f a+ gtraverse' f (R1 a) = R1 <$> gtraverse' f a++instance (GTraversable' f, GTraversable' g) => GTraversable' (f :*: g) where+ gtraverse' f (a :*: b) = (:*:) <$> gtraverse' f a <*> gtraverse' f b++instance (GTraversable f, GTraversable' g) => GTraversable' (f :.: g) where+ gtraverse' f (Comp1 x) = Comp1 <$> gtraverse (gtraverse' f) x++instance GTraversable' UAddr where+ gtraverse' _ (UAddr a) = pure (UAddr a)++instance GTraversable' UChar where+ gtraverse' _ (UChar c) = pure (UChar c)++instance GTraversable' UDouble where+ gtraverse' _ (UDouble d) = pure (UDouble d)++instance GTraversable' UFloat where+ gtraverse' _ (UFloat f) = pure (UFloat f)++instance GTraversable' UInt where+ gtraverse' _ (UInt i) = pure (UInt i)++instance GTraversable' UWord where+ gtraverse' _ (UWord w) = pure (UWord w)++class (GFunctor t, GFoldable t) => GTraversable t where+ gtraverse :: Applicative f => (a -> f b) -> t a -> f (t b)+#if __GLASGOW_HASKELL__ >= 701+ default gtraverse :: (Generic1 t, GTraversable' (Rep1 t), Applicative f)+ => (a -> f b) -> t a -> f (t b)+ gtraverse = gtraversedefault+#endif++ gsequenceA :: Applicative f => t (f a) -> f (t a)+ gsequenceA = gtraverse id++ gmapM :: Monad m => (a -> m b) -> t a -> m (t b)+ gmapM f = unwrapMonad . gtraverse (WrapMonad . f)++ gsequence :: Monad m => t (m a) -> m (t a)+ gsequence = gmapM id++gtraversedefault :: (Generic1 t, GTraversable' (Rep1 t), Applicative f)+ => (a -> f b) -> t a -> f (t b)+gtraversedefault f x = to1 <$> gtraverse' f (from1 x)++-- Base types instances+instance GTraversable ((,) a) where+ gtraverse = gtraversedefault++instance GTraversable [] where+ gtraverse = gtraversedefault++#if MIN_VERSION_base(4,9,0)+instance GTraversable (Arg a) where+ gtraverse = gtraversedefault+#endif++#if MIN_VERSION_base(4,4,0)+instance GTraversable Complex where+ gtraverse = gtraversedefault+#endif++instance GTraversable (Const m) where+ gtraverse = gtraversedefault++instance GTraversable Dual where+ gtraverse = gtraversedefault++instance GTraversable (Either a) where+ gtraverse = gtraversedefault++instance GTraversable Monoid.First where+ gtraverse = gtraversedefault++#if MIN_VERSION_base(4,9,0)+instance GTraversable (Semigroup.First) where+ gtraverse = gtraversedefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GTraversable Identity where+ gtraverse = gtraversedefault+#endif++instance GTraversable Monoid.Last where+ gtraverse = gtraversedefault++#if MIN_VERSION_base(4,9,0)+instance GTraversable Semigroup.Last where+ gtraverse = gtraversedefault++instance GTraversable Max where+ gtraverse = gtraversedefault+#endif++instance GTraversable Maybe where+ gtraverse = gtraversedefault++#if MIN_VERSION_base(4,9,0)+instance GTraversable Min where+ gtraverse = gtraversedefault++instance GTraversable NonEmpty where+ gtraverse = gtraversedefault++instance GTraversable Option where+ gtraverse = gtraversedefault+#endif++instance GTraversable Monoid.Product where+ gtraverse = gtraversedefault++#if MIN_VERSION_base(4,9,0)+instance (GTraversable f, GTraversable g) => GTraversable (Functor.Product f g) where+ gtraverse = gtraversedefault+#endif++#if MIN_VERSION_base(4,7,0)+instance GTraversable Proxy where+ gtraverse = gtraversedefault+#endif++instance GTraversable Monoid.Sum where+ gtraverse = gtraversedefault++#if MIN_VERSION_base(4,9,0)+instance (GTraversable f, GTraversable g) => GTraversable (Functor.Sum f g) where+ gtraverse = gtraversedefault++instance GTraversable WrappedMonoid where+ gtraverse = gtraversedefault+#endif++instance GTraversable ZipList where+ gtraverse = gtraversedefault
src/Generics/Deriving/Uniplate.hs view
@@ -1,383 +1,383 @@-{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} - -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -#if __GLASGOW_HASKELL__ < 709 -{-# LANGUAGE OverlappingInstances #-} -#endif - --------------------------------------------------------------------------------- --- | --- Module : Generics.Deriving.Uniplate --- Copyright : 2011-2012 Universiteit Utrecht, University of Oxford --- License : BSD3 --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable --- --- Summary: Functions inspired by the Uniplate generic programming library, --- mostly implemented by Sean Leather. --------------------------------------------------------------------------------- - -module Generics.Deriving.Uniplate ( - Uniplate(..) - - -- * Derived functions - , uniplate - , universe - , rewrite - , rewriteM - , contexts - , holes - , para - - -- * Default definitions - , childrendefault - , contextdefault - , descenddefault - , descendMdefault - , transformdefault - , transformMdefault - - ) where - - -import Generics.Deriving.Base -import Generics.Deriving.Instances () - -import Control.Monad (liftM, liftM2) -import GHC.Exts (build) - --------------------------------------------------------------------------------- --- Generic Uniplate --------------------------------------------------------------------------------- - -class Uniplate' f b where - children' :: f a -> [b] - descend' :: (b -> b) -> f a -> f a - descendM' :: Monad m => (b -> m b) -> f a -> m (f a) - transform' :: (b -> b) -> f a -> f a - transformM' :: Monad m => (b -> m b) -> f a -> m (f a) - -instance Uniplate' U1 a where - children' U1 = [] - descend' _ U1 = U1 - descendM' _ U1 = return U1 - transform' _ U1 = U1 - transformM' _ U1 = return U1 - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPING #-} -#endif - (Uniplate a) => Uniplate' (K1 i a) a where - children' (K1 a) = [a] - descend' f (K1 a) = K1 (f a) - descendM' f (K1 a) = liftM K1 (f a) - transform' f (K1 a) = K1 (transform f a) - transformM' f (K1 a) = liftM K1 (transformM f a) - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPABLE #-} -#endif - Uniplate' (K1 i a) b where - children' (K1 _) = [] - descend' _ (K1 a) = K1 a - descendM' _ (K1 a) = return (K1 a) - transform' _ (K1 a) = K1 a - transformM' _ (K1 a) = return (K1 a) - -instance (Uniplate' f b) => Uniplate' (M1 i c f) b where - children' (M1 a) = children' a - descend' f (M1 a) = M1 (descend' f a) - descendM' f (M1 a) = liftM M1 (descendM' f a) - transform' f (M1 a) = M1 (transform' f a) - transformM' f (M1 a) = liftM M1 (transformM' f a) - -instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :+: g) b where - children' (L1 a) = children' a - children' (R1 a) = children' a - descend' f (L1 a) = L1 (descend' f a) - descend' f (R1 a) = R1 (descend' f a) - descendM' f (L1 a) = liftM L1 (descendM' f a) - descendM' f (R1 a) = liftM R1 (descendM' f a) - transform' f (L1 a) = L1 (transform' f a) - transform' f (R1 a) = R1 (transform' f a) - transformM' f (L1 a) = liftM L1 (transformM' f a) - transformM' f (R1 a) = liftM R1 (transformM' f a) - -instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :*: g) b where - children' (a :*: b) = children' a ++ children' b - descend' f (a :*: b) = descend' f a :*: descend' f b - descendM' f (a :*: b) = liftM2 (:*:) (descendM' f a) (descendM' f b) - transform' f (a :*: b) = transform' f a :*: transform' f b - transformM' f (a :*: b) = liftM2 (:*:) (transformM' f a) (transformM' f b) - - --- Context' is a separate class from Uniplate' since it uses special product --- instances, but the context function still appears in Uniplate. -class Context' f b where - context' :: f a -> [b] -> f a - -instance Context' U1 b where - context' U1 _ = U1 - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPING #-} -#endif - Context' (K1 i a) a where - context' _ [] = error "Generics.Deriving.Uniplate.context: empty list" - context' (K1 _) (c:_) = K1 c - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPABLE #-} -#endif - Context' (K1 i a) b where - context' (K1 a) _ = K1 a - -instance (Context' f b) => Context' (M1 i c f) b where - context' (M1 a) cs = M1 (context' a cs) - -instance (Context' f b, Context' g b) => Context' (f :+: g) b where - context' (L1 a) cs = L1 (context' a cs) - context' (R1 a) cs = R1 (context' a cs) - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPING #-} -#endif - (Context' g a) => Context' (M1 i c (K1 j a) :*: g) a where - context' _ [] = error "Generics.Deriving.Uniplate.context: empty list" - context' (M1 (K1 _) :*: b) (c:cs) = M1 (K1 c) :*: context' b cs - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPABLE #-} -#endif - (Context' g b) => Context' (f :*: g) b where - context' (a :*: b) cs = a :*: context' b cs - - -class Uniplate a where - children :: a -> [a] -#if __GLASGOW_HASKELL__ >= 701 - default children :: (Generic a, Uniplate' (Rep a) a) => a -> [a] - children = childrendefault -#endif - - context :: a -> [a] -> a -#if __GLASGOW_HASKELL__ >= 701 - default context :: (Generic a, Context' (Rep a) a) => a -> [a] -> a - context = contextdefault -#endif - - descend :: (a -> a) -> a -> a -#if __GLASGOW_HASKELL__ >= 701 - default descend :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a - descend = descenddefault -#endif - - descendM :: Monad m => (a -> m a) -> a -> m a -#if __GLASGOW_HASKELL__ >= 701 - default descendM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a - descendM = descendMdefault -#endif - - transform :: (a -> a) -> a -> a -#if __GLASGOW_HASKELL__ >= 701 - default transform :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a - transform = transformdefault -#endif - - transformM :: Monad m => (a -> m a) -> a -> m a -#if __GLASGOW_HASKELL__ >= 701 - default transformM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a - transformM = transformMdefault -#endif - -childrendefault :: (Generic a, Uniplate' (Rep a) a) => a -> [a] -childrendefault = children' . from - -contextdefault :: (Generic a, Context' (Rep a) a) => a -> [a] -> a -contextdefault x cs = to (context' (from x) cs) - -descenddefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a -descenddefault f = to . descend' f . from - -descendMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a -descendMdefault f = liftM to . descendM' f . from - -transformdefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a -transformdefault f = f . to . transform' f . from - -transformMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a -transformMdefault f = liftM to . transformM' f . from - - --- Derived functions (mostly copied from Neil Michell's code) - -uniplate :: Uniplate a => a -> ([a], [a] -> a) -uniplate a = (children a, context a) - -universe :: Uniplate a => a -> [a] -universe a = build (go a) - where - go x cons nil = cons x $ foldr ($) nil $ map (\c -> go c cons) $ children x - -rewrite :: Uniplate a => (a -> Maybe a) -> a -> a -rewrite f = transform g - where - g x = maybe x (rewrite f) (f x) - -rewriteM :: (Monad m, Uniplate a) => (a -> m (Maybe a)) -> a -> m a -rewriteM f = transformM g - where - g x = f x >>= maybe (return x) (rewriteM f) - -contexts :: Uniplate a => a -> [(a, a -> a)] -contexts a = (a, id) : f (holes a) - where - f xs = [ (ch2, ctx1 . ctx2) - | (ch1, ctx1) <- xs - , (ch2, ctx2) <- contexts ch1] - -holes :: Uniplate a => a -> [(a, a -> a)] -holes a = uncurry f (uniplate a) - where - f [] _ = [] - f (x:xs) gen = (x, gen . (:xs)) : f xs (gen . (x:)) - -para :: Uniplate a => (a -> [r] -> r) -> a -> r -para f x = f x $ map (para f) $ children x - - --- Base types instances -instance Uniplate Bool where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate Char where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate Double where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate Float where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate Int where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate () where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return - --- Tuple instances -instance Uniplate (b,c) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (b,c,d) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (b,c,d,e) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (b,c,d,e,f) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (b,c,d,e,f,g) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (b,c,d,e,f,g,h) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return - --- Parameterized type instances -instance Uniplate (Maybe a) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (Either a b) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return - -instance Uniplate [a] where - children [] = [] - children (_:t) = [t] - context _ [] = error "Generics.Deriving.Uniplate.context: empty list" - context [] _ = [] - context (h:_) (t:_) = h:t - descend _ [] = [] - descend f (h:t) = h:f t - descendM _ [] = return [] - descendM f (h:t) = f t >>= \t' -> return (h:t') - transform f [] = f [] - transform f (h:t) = f (h:transform f t) - transformM f [] = f [] - transformM f (h:t) = transformM f t >>= \t' -> f (h:t') - +{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+#endif++#if __GLASGOW_HASKELL__ < 709+{-# LANGUAGE OverlappingInstances #-}+#endif++--------------------------------------------------------------------------------+-- |+-- Module : Generics.Deriving.Uniplate+-- Copyright : 2011-2012 Universiteit Utrecht, University of Oxford+-- License : BSD3+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- Summary: Functions inspired by the Uniplate generic programming library,+-- mostly implemented by Sean Leather.+--------------------------------------------------------------------------------++module Generics.Deriving.Uniplate (+ Uniplate(..)++ -- * Derived functions+ , uniplate+ , universe+ , rewrite+ , rewriteM+ , contexts+ , holes+ , para++ -- * Default definitions+ , childrendefault+ , contextdefault+ , descenddefault+ , descendMdefault+ , transformdefault+ , transformMdefault++ ) where+++import Generics.Deriving.Base+import Generics.Deriving.Instances ()++import Control.Monad (liftM, liftM2)+import GHC.Exts (build)++--------------------------------------------------------------------------------+-- Generic Uniplate+--------------------------------------------------------------------------------++class Uniplate' f b where+ children' :: f a -> [b]+ descend' :: (b -> b) -> f a -> f a+ descendM' :: Monad m => (b -> m b) -> f a -> m (f a)+ transform' :: (b -> b) -> f a -> f a+ transformM' :: Monad m => (b -> m b) -> f a -> m (f a)++instance Uniplate' U1 a where+ children' U1 = []+ descend' _ U1 = U1+ descendM' _ U1 = return U1+ transform' _ U1 = U1+ transformM' _ U1 = return U1++instance+#if __GLASGOW_HASKELL__ >= 709+ {-# OVERLAPPING #-}+#endif+ (Uniplate a) => Uniplate' (K1 i a) a where+ children' (K1 a) = [a]+ descend' f (K1 a) = K1 (f a)+ descendM' f (K1 a) = liftM K1 (f a)+ transform' f (K1 a) = K1 (transform f a)+ transformM' f (K1 a) = liftM K1 (transformM f a)++instance+#if __GLASGOW_HASKELL__ >= 709+ {-# OVERLAPPABLE #-}+#endif+ Uniplate' (K1 i a) b where+ children' (K1 _) = []+ descend' _ (K1 a) = K1 a+ descendM' _ (K1 a) = return (K1 a)+ transform' _ (K1 a) = K1 a+ transformM' _ (K1 a) = return (K1 a)++instance (Uniplate' f b) => Uniplate' (M1 i c f) b where+ children' (M1 a) = children' a+ descend' f (M1 a) = M1 (descend' f a)+ descendM' f (M1 a) = liftM M1 (descendM' f a)+ transform' f (M1 a) = M1 (transform' f a)+ transformM' f (M1 a) = liftM M1 (transformM' f a)++instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :+: g) b where+ children' (L1 a) = children' a+ children' (R1 a) = children' a+ descend' f (L1 a) = L1 (descend' f a)+ descend' f (R1 a) = R1 (descend' f a)+ descendM' f (L1 a) = liftM L1 (descendM' f a)+ descendM' f (R1 a) = liftM R1 (descendM' f a)+ transform' f (L1 a) = L1 (transform' f a)+ transform' f (R1 a) = R1 (transform' f a)+ transformM' f (L1 a) = liftM L1 (transformM' f a)+ transformM' f (R1 a) = liftM R1 (transformM' f a)++instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :*: g) b where+ children' (a :*: b) = children' a ++ children' b+ descend' f (a :*: b) = descend' f a :*: descend' f b+ descendM' f (a :*: b) = liftM2 (:*:) (descendM' f a) (descendM' f b)+ transform' f (a :*: b) = transform' f a :*: transform' f b+ transformM' f (a :*: b) = liftM2 (:*:) (transformM' f a) (transformM' f b)+++-- Context' is a separate class from Uniplate' since it uses special product+-- instances, but the context function still appears in Uniplate.+class Context' f b where+ context' :: f a -> [b] -> f a++instance Context' U1 b where+ context' U1 _ = U1++instance+#if __GLASGOW_HASKELL__ >= 709+ {-# OVERLAPPING #-}+#endif+ Context' (K1 i a) a where+ context' _ [] = error "Generics.Deriving.Uniplate.context: empty list"+ context' (K1 _) (c:_) = K1 c++instance+#if __GLASGOW_HASKELL__ >= 709+ {-# OVERLAPPABLE #-}+#endif+ Context' (K1 i a) b where+ context' (K1 a) _ = K1 a++instance (Context' f b) => Context' (M1 i c f) b where+ context' (M1 a) cs = M1 (context' a cs)++instance (Context' f b, Context' g b) => Context' (f :+: g) b where+ context' (L1 a) cs = L1 (context' a cs)+ context' (R1 a) cs = R1 (context' a cs)++instance+#if __GLASGOW_HASKELL__ >= 709+ {-# OVERLAPPING #-}+#endif+ (Context' g a) => Context' (M1 i c (K1 j a) :*: g) a where+ context' _ [] = error "Generics.Deriving.Uniplate.context: empty list"+ context' (M1 (K1 _) :*: b) (c:cs) = M1 (K1 c) :*: context' b cs++instance+#if __GLASGOW_HASKELL__ >= 709+ {-# OVERLAPPABLE #-}+#endif+ (Context' g b) => Context' (f :*: g) b where+ context' (a :*: b) cs = a :*: context' b cs+++class Uniplate a where+ children :: a -> [a]+#if __GLASGOW_HASKELL__ >= 701+ default children :: (Generic a, Uniplate' (Rep a) a) => a -> [a]+ children = childrendefault+#endif++ context :: a -> [a] -> a+#if __GLASGOW_HASKELL__ >= 701+ default context :: (Generic a, Context' (Rep a) a) => a -> [a] -> a+ context = contextdefault+#endif++ descend :: (a -> a) -> a -> a+#if __GLASGOW_HASKELL__ >= 701+ default descend :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a+ descend = descenddefault+#endif++ descendM :: Monad m => (a -> m a) -> a -> m a+#if __GLASGOW_HASKELL__ >= 701+ default descendM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a+ descendM = descendMdefault+#endif++ transform :: (a -> a) -> a -> a+#if __GLASGOW_HASKELL__ >= 701+ default transform :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a+ transform = transformdefault+#endif++ transformM :: Monad m => (a -> m a) -> a -> m a+#if __GLASGOW_HASKELL__ >= 701+ default transformM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a+ transformM = transformMdefault+#endif++childrendefault :: (Generic a, Uniplate' (Rep a) a) => a -> [a]+childrendefault = children' . from++contextdefault :: (Generic a, Context' (Rep a) a) => a -> [a] -> a+contextdefault x cs = to (context' (from x) cs)++descenddefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a+descenddefault f = to . descend' f . from++descendMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a+descendMdefault f = liftM to . descendM' f . from++transformdefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a+transformdefault f = f . to . transform' f . from++transformMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a+transformMdefault f = liftM to . transformM' f . from+++-- Derived functions (mostly copied from Neil Michell's code)++uniplate :: Uniplate a => a -> ([a], [a] -> a)+uniplate a = (children a, context a)++universe :: Uniplate a => a -> [a]+universe a = build (go a)+ where+ go x cons nil = cons x $ foldr ($) nil $ map (\c -> go c cons) $ children x++rewrite :: Uniplate a => (a -> Maybe a) -> a -> a+rewrite f = transform g+ where+ g x = maybe x (rewrite f) (f x)++rewriteM :: (Monad m, Uniplate a) => (a -> m (Maybe a)) -> a -> m a+rewriteM f = transformM g+ where+ g x = f x >>= maybe (return x) (rewriteM f)++contexts :: Uniplate a => a -> [(a, a -> a)]+contexts a = (a, id) : f (holes a)+ where+ f xs = [ (ch2, ctx1 . ctx2)+ | (ch1, ctx1) <- xs+ , (ch2, ctx2) <- contexts ch1]++holes :: Uniplate a => a -> [(a, a -> a)]+holes a = uncurry f (uniplate a)+ where+ f [] _ = []+ f (x:xs) gen = (x, gen . (:xs)) : f xs (gen . (x:))++para :: Uniplate a => (a -> [r] -> r) -> a -> r+para f x = f x $ map (para f) $ children x+++-- Base types instances+instance Uniplate Bool where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate Char where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate Double where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate Float where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate Int where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate () where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return++-- Tuple instances+instance Uniplate (b,c) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate (b,c,d) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate (b,c,d,e) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate (b,c,d,e,f) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate (b,c,d,e,f,g) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate (b,c,d,e,f,g,h) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return++-- Parameterized type instances+instance Uniplate (Maybe a) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate (Either a b) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return++instance Uniplate [a] where+ children [] = []+ children (_:t) = [t]+ context _ [] = error "Generics.Deriving.Uniplate.context: empty list"+ context [] _ = []+ context (h:_) (t:_) = h:t+ descend _ [] = []+ descend f (h:t) = h:f t+ descendM _ [] = return []+ descendM f (h:t) = f t >>= \t' -> return (h:t')+ transform f [] = f []+ transform f (h:t) = f (h:transform f t)+ transformM f [] = f []+ transformM f (h:t) = transformM f t >>= \t' -> f (h:t')+