diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/examples/Examples.hs b/examples/Examples.hs --- a/examples/Examples.hs +++ b/examples/Examples.hs @@ -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 diff --git a/generic-deriving.cabal b/generic-deriving.cabal --- a/generic-deriving.cabal +++ b/generic-deriving.cabal @@ -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 - 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 + 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 diff --git a/src/Generics/Deriving.hs b/src/Generics/Deriving.hs --- a/src/Generics/Deriving.hs +++ b/src/Generics/Deriving.hs @@ -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 diff --git a/src/Generics/Deriving/Base.hs b/src/Generics/Deriving/Base.hs --- a/src/Generics/Deriving/Base.hs +++ b/src/Generics/Deriving/Base.hs @@ -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 diff --git a/src/Generics/Deriving/Copoint.hs b/src/Generics/Deriving/Copoint.hs --- a/src/Generics/Deriving/Copoint.hs +++ b/src/Generics/Deriving/Copoint.hs @@ -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 diff --git a/src/Generics/Deriving/Enum.hs b/src/Generics/Deriving/Enum.hs --- a/src/Generics/Deriving/Enum.hs +++ b/src/Generics/Deriving/Enum.hs @@ -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 diff --git a/src/Generics/Deriving/Eq.hs b/src/Generics/Deriving/Eq.hs --- a/src/Generics/Deriving/Eq.hs +++ b/src/Generics/Deriving/Eq.hs @@ -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 diff --git a/src/Generics/Deriving/Foldable.hs b/src/Generics/Deriving/Foldable.hs --- a/src/Generics/Deriving/Foldable.hs +++ b/src/Generics/Deriving/Foldable.hs @@ -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 []) diff --git a/src/Generics/Deriving/Functor.hs b/src/Generics/Deriving/Functor.hs --- a/src/Generics/Deriving/Functor.hs +++ b/src/Generics/Deriving/Functor.hs @@ -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 diff --git a/src/Generics/Deriving/Instances.hs b/src/Generics/Deriving/Instances.hs --- a/src/Generics/Deriving/Instances.hs +++ b/src/Generics/Deriving/Instances.hs @@ -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 diff --git a/src/Generics/Deriving/Monoid.hs b/src/Generics/Deriving/Monoid.hs --- a/src/Generics/Deriving/Monoid.hs +++ b/src/Generics/Deriving/Monoid.hs @@ -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) diff --git a/src/Generics/Deriving/Show.hs b/src/Generics/Deriving/Show.hs --- a/src/Generics/Deriving/Show.hs +++ b/src/Generics/Deriving/Show.hs @@ -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 diff --git a/src/Generics/Deriving/TH.hs b/src/Generics/Deriving/TH.hs --- a/src/Generics/Deriving/TH.hs +++ b/src/Generics/Deriving/TH.hs @@ -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 () 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. ) --- 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 ...) = ...) 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 = ) 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. + +-} diff --git a/src/Generics/Deriving/TH/Internal.hs b/src/Generics/Deriving/TH/Internal.hs --- a/src/Generics/Deriving/TH/Internal.hs +++ b/src/Generics/Deriving/TH/Internal.hs @@ -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. ) +-- 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 diff --git a/src/Generics/Deriving/TH/Post711.hs b/src/Generics/Deriving/TH/Post711.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Deriving/TH/Post711.hs @@ -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 [] diff --git a/src/Generics/Deriving/TH/Pre711.hs b/src/Generics/Deriving/TH/Pre711.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Deriving/TH/Pre711.hs @@ -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) diff --git a/src/Generics/Deriving/Traversable.hs b/src/Generics/Deriving/Traversable.hs --- a/src/Generics/Deriving/Traversable.hs +++ b/src/Generics/Deriving/Traversable.hs @@ -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 diff --git a/src/Generics/Deriving/Uniplate.hs b/src/Generics/Deriving/Uniplate.hs --- a/src/Generics/Deriving/Uniplate.hs +++ b/src/Generics/Deriving/Uniplate.hs @@ -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') +