diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +# 1.10.1 +* Added `Generics.Deriving.Semigroup` +* Added `GMonoid` instance for `Data.Monoid.Alt` +* Fixed a bug in the `GEnum` instances for unsigned `Integral` types +* Added `Safe`/`Trustworthy` pragmas +* Made instances polykinded where possible + # 1.10.0 * On GHC 8.0 and up, `Generics.Deriving.TH` uses the new type literal-based machinery diff --git a/generic-deriving.cabal b/generic-deriving.cabal --- a/generic-deriving.cabal +++ b/generic-deriving.cabal @@ -1,5 +1,5 @@ name: generic-deriving -version: 1.10.0 +version: 1.10.1 synopsis: Generic programming library for generalised deriving. description: @@ -52,13 +52,15 @@ Generics.Deriving.Foldable Generics.Deriving.Functor Generics.Deriving.Monoid + Generics.Deriving.Semigroup Generics.Deriving.Show Generics.Deriving.Traversable Generics.Deriving.Uniplate Generics.Deriving.TH - other-modules: Generics.Deriving.TH.Internal + other-modules: Generics.Deriving.Base.Internal + Generics.Deriving.TH.Internal Paths_generic_deriving if impl(ghc >= 7.11) other-modules: Generics.Deriving.TH.Post711 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,10 @@ {-# 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 - +#if __GLASGOW_HASKELL__ >= 702 +{-# LANGUAGE Safe #-} #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) +module Generics.Deriving.Base (module Generics.Deriving.Base.Internal) where --- | 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 +import Generics.Deriving.Base.Internal +import Generics.Deriving.Instances () diff --git a/src/Generics/Deriving/Base/Internal.hs b/src/Generics/Deriving/Base/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Deriving/Base/Internal.hs @@ -0,0 +1,808 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} + +#if __GLASGOW_HASKELL__ >= 711 +{-# LANGUAGE Safe #-} +#elif __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif + +module Generics.Deriving.Base.Internal ( +-- * 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/ConNames.hs b/src/Generics/Deriving/ConNames.hs --- a/src/Generics/Deriving/ConNames.hs +++ b/src/Generics/Deriving/ConNames.hs @@ -1,8 +1,17 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} + +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Safe #-} +#endif + +#if __GLASGOW_HASKELL__ >= 705 +{-# LANGUAGE PolyKinds #-} +#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 @@ -2,10 +2,16 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} + #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE Safe #-} #endif +#if __GLASGOW_HASKELL__ >= 705 +{-# LANGUAGE PolyKinds #-} +#endif + module Generics.Deriving.Copoint ( -- * GCopoint class GCopoint(..), @@ -21,7 +27,6 @@ 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) 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,12 +1,19 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} + #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE Trustworthy #-} #endif +#if __GLASGOW_HASKELL__ >= 705 +{-# LANGUAGE PolyKinds #-} +#endif + #include "HsBaseConfig.h" module Generics.Deriving.Enum ( @@ -36,7 +43,6 @@ import Foreign.Ptr import Generics.Deriving.Base -import Generics.Deriving.Instances () import Generics.Deriving.Eq import System.Exit (ExitCode) @@ -47,7 +53,10 @@ #endif #if MIN_VERSION_base(4,7,0) +import Data.Coerce (coerce) import Data.Proxy (Proxy) +#else +import Unsafe.Coerce (unsafeCoerce) #endif #if MIN_VERSION_base(4,8,0) @@ -149,12 +158,17 @@ 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 +genumNumSigned :: (Bounded a, Enum a, Num a) => [a] +genumNumSigned = [0 .. maxBound] ||| [-1, -2 .. minBound] -genumNumWithBounds :: (Enum a, Num a) => a -> a -> [a] -genumNumWithBounds minB maxB = [0 .. maxB] ||| [-1, -2 .. minB] +genumNumUnsigned :: (Enum a, Num a) => [a] +genumNumUnsigned = [0 ..] +#if !(MIN_VERSION_base(4,7,0)) +coerce :: a -> b +coerce = unsafeCoerce +#endif + -- Base types instances instance GEnum () where genum = genumDefault @@ -220,67 +234,64 @@ #if defined(HTYPE_CC_T) instance GEnum CCc where - genum = genumNumWithBounds (fromIntegral (minBound :: HTYPE_CC_T)) - (fromIntegral (maxBound :: HTYPE_CC_T)) + genum = coerce (genum :: [HTYPE_CC_T]) #endif instance GEnum CChar where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_CHAR]) instance GEnum CClock where - genum = genumNumWithBounds (fromIntegral (minBound :: HTYPE_CLOCK_T)) - (fromIntegral (maxBound :: HTYPE_CLOCK_T)) + genum = coerce (genum :: [HTYPE_CLOCK_T]) #if defined(HTYPE_DEV_T) instance GEnum CDev where - genum = genumNumWithBounds (fromIntegral (minBound :: HTYPE_DEV_T)) - (fromIntegral (maxBound :: HTYPE_DEV_T)) + genum = coerce (genum :: [HTYPE_DEV_T]) #endif instance GEnum CDouble where - genum = genumNumUnbounded + genum = coerce (genum :: [HTYPE_DOUBLE]) instance GEnum CFloat where - genum = genumNumUnbounded + genum = coerce (genum :: [HTYPE_FLOAT]) #if defined(HTYPE_GID_T) instance GEnum CGid where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_GID_T]) #endif #if defined(HTYPE_INO_T) instance GEnum CIno where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_INO_T]) #endif instance GEnum CInt where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_INT]) instance GEnum CIntMax where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_INTMAX_T]) instance GEnum CIntPtr where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_INTPTR_T]) instance GEnum CLLong where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_LONG_LONG]) instance GEnum CLong where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_LONG]) #if defined(HTYPE_MODE_T) instance GEnum CMode where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_MODE_T]) #endif #if defined(HTYPE_NLINK_T) instance GEnum CNlink where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_NLINK_T]) #endif #if defined(HTYPE_OFF_T) instance GEnum COff where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_OFF_T]) #endif #if MIN_VERSION_base(4,4,0) @@ -293,89 +304,85 @@ #if defined(HTYPE_PID_T) instance GEnum CPid where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_PID_T]) #endif instance GEnum CPtrdiff where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_PTRDIFF_T]) #if defined(HTYPE_RLIM_T) instance GEnum CRLim where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_RLIM_T]) #endif instance GEnum CSChar where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_SIGNED_CHAR]) #if defined(HTYPE_SPEED_T) instance GEnum CSpeed where - genum = genumNumWithBounds (fromIntegral (minBound :: HTYPE_SPEED_T)) - (fromIntegral (maxBound :: HTYPE_SPEED_T)) + genum = coerce (genum :: [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)) + genum = coerce (genum :: [HTYPE_SUSECONDS_T]) #endif instance GEnum CShort where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_SHORT]) instance GEnum CSigAtomic where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_SIG_ATOMIC_T]) instance GEnum CSize where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_SIZE_T]) #if defined(HTYPE_SSIZE_T) instance GEnum CSsize where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_SSIZE_T]) #endif #if defined(HTYPE_TCFLAG_T) instance GEnum CTcflag where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_TCFLAG_T]) #endif instance GEnum CTime where - genum = genumNumWithBounds (fromIntegral (minBound :: HTYPE_TIME_T)) - (fromIntegral (maxBound :: HTYPE_TIME_T)) + genum = coerce (genum :: [HTYPE_TIME_T]) instance GEnum CUChar where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_UNSIGNED_CHAR]) #if defined(HTYPE_UID_T) instance GEnum CUid where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_UID_T]) #endif instance GEnum CUInt where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_UNSIGNED_INT]) instance GEnum CUIntMax where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_UINTMAX_T]) instance GEnum CUIntPtr where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_UINTPTR_T]) instance GEnum CULLong where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_UNSIGNED_LONG_LONG]) instance GEnum CULong where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_UNSIGNED_LONG]) #if MIN_VERSION_base(4,4,0) instance GEnum CUSeconds where - genum = genumNumWithBounds (fromIntegral (minBound :: HTYPE_USECONDS_T)) - (fromIntegral (maxBound :: HTYPE_USECONDS_T)) + genum = coerce (genum :: [HTYPE_USECONDS_T]) #endif instance GEnum CUShort where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_UNSIGNED_SHORT]) instance GEnum CWchar where - genum = genumNumBounded + genum = coerce (genum :: [HTYPE_WCHAR_T]) instance GEnum Double where genum = genumNumUnbounded @@ -390,7 +397,7 @@ genum = genumDefault instance GEnum Fd where - genum = genumNumBounded + genum = coerce (genum :: [CInt]) instance GEnum a => GEnum (Monoid.First a) where genum = genumDefault @@ -412,25 +419,25 @@ #endif instance GEnum Int where - genum = genumNumBounded + genum = genumNumSigned instance GEnum Int8 where - genum = genumNumBounded + genum = genumNumSigned instance GEnum Int16 where - genum = genumNumBounded + genum = genumNumSigned instance GEnum Int32 where - genum = genumNumBounded + genum = genumNumSigned instance GEnum Int64 where - genum = genumNumBounded + genum = genumNumSigned instance GEnum Integer where genum = genumNumUnbounded instance GEnum IntPtr where - genum = genumNumBounded + genum = genumNumSigned instance GEnum c => GEnum (K1 i c p) where genum = genumDefault @@ -461,7 +468,7 @@ #if MIN_VERSION_base(4,8,0) instance GEnum Natural where - genum = [0..] + genum = genumNumUnsigned #endif #if MIN_VERSION_base(4,9,0) @@ -482,7 +489,13 @@ genum = genumDefault #if MIN_VERSION_base(4,7,0) -instance GEnum (Proxy s) where +instance GEnum +# if MIN_VERSION_base(4,9,0) + (Proxy s) +# else + (Proxy (s :: *)) +# endif + where genum = genumDefault #endif @@ -496,22 +509,22 @@ genum = genumDefault instance GEnum Word where - genum = genumNumBounded + genum = genumNumUnsigned instance GEnum Word8 where - genum = genumNumBounded + genum = genumNumUnsigned instance GEnum Word16 where - genum = genumNumBounded + genum = genumNumUnsigned instance GEnum Word32 where - genum = genumNumBounded + genum = genumNumUnsigned instance GEnum Word64 where - genum = genumNumBounded + genum = genumNumUnsigned instance GEnum WordPtr where - genum = genumNumBounded + genum = genumNumUnsigned #if MIN_VERSION_base(4,9,0) instance GEnum m => GEnum (WrappedMonoid m) where @@ -983,7 +996,13 @@ inRange = inRangeDefault #if MIN_VERSION_base(4,7,0) -instance GIx (Proxy s) where +instance GIx +# if MIN_VERSION_base(4,9,0) + (Proxy s) +# else + (Proxy (s :: *)) +# endif + where range = rangeDefault index = indexDefault inRange = inRangeDefault 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,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -8,8 +9,13 @@ #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE Trustworthy #-} #endif +#if __GLASGOW_HASKELL__ >= 705 +{-# LANGUAGE PolyKinds #-} +#endif + #include "HsBaseConfig.h" module Generics.Deriving.Eq ( @@ -37,7 +43,6 @@ import Foreign.StablePtr (StablePtr) import Generics.Deriving.Base -import Generics.Deriving.Instances () import GHC.Exts hiding (Any) @@ -481,7 +486,13 @@ geq = geqdefault #if MIN_VERSION_base(4,7,0) -instance GEq (Proxy s) where +instance GEq +# if MIN_VERSION_base(4,9,0) + (Proxy s) +# else + (Proxy (s :: *)) +# endif + where geq = geqdefault #endif 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 @@ -3,10 +3,16 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} + #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE Safe #-} #endif +#if __GLASGOW_HASKELL__ >= 705 +{-# LANGUAGE PolyKinds #-} +#endif + module Generics.Deriving.Foldable ( -- * Foldable class GFoldable(..) @@ -43,7 +49,6 @@ #endif import Generics.Deriving.Base -import Generics.Deriving.Instances () #if MIN_VERSION_base(4,4,0) import Data.Complex (Complex) 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 @@ -3,10 +3,16 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} + #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE Safe #-} #endif +#if __GLASGOW_HASKELL__ >= 705 +{-# LANGUAGE PolyKinds #-} +#endif + module Generics.Deriving.Functor ( -- * GFunctor class GFunctor(..) @@ -22,7 +28,6 @@ import Data.Monoid (Dual) import Generics.Deriving.Base -import Generics.Deriving.Instances () #if MIN_VERSION_base(4,4,0) import Data.Complex (Complex) 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 @@ -5,6 +5,17 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} + +#if __GLASGOW_HASKELL__ >= 711 +{-# LANGUAGE Safe #-} +#elif __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif + +#if __GLASGOW_HASKELL__ >= 705 +{-# LANGUAGE PolyKinds #-} +#endif + {-# OPTIONS_GHC -fno-warn-orphans #-} module Generics.Deriving.Instances ( @@ -108,7 +119,7 @@ #if __GLASGOW_HASKELL__ < 711 import Data.Version (Version(..)) -import Generics.Deriving.Base +import Generics.Deriving.Base.Internal import System.Exit (ExitCode(..)) #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,11 +1,17 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE Safe #-} #endif +#if __GLASGOW_HASKELL__ >= 705 +{-# LANGUAGE PolyKinds #-} +#endif + -- | This module provides two main features: -- -- 1. 'GMonoid', a generic version of the 'Monoid' type class, including instances @@ -56,7 +62,6 @@ 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) @@ -185,6 +190,11 @@ instance GMonoid (Endo a) where gmempty = mempty gmappend = mappend +#if MIN_VERSION_base(4,8,0) +instance Alternative f => GMonoid (Alt f a) where + gmempty = mempty + gmappend = mappend +#endif -- Handwritten instances instance GMonoid a => GMonoid (Dual a) where @@ -203,7 +213,13 @@ gmappend = gmappenddefault #if MIN_VERSION_base(4,7,0) -instance GMonoid (Proxy s) where +instance GMonoid +# if MIN_VERSION_base(4,9,0) + (Proxy s) +# else + (Proxy (s :: *)) +# endif + where gmempty = memptydefault gmappend = mappenddefault #endif diff --git a/src/Generics/Deriving/Semigroup.hs b/src/Generics/Deriving/Semigroup.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Deriving/Semigroup.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} + +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE Safe #-} +#endif + +#if __GLASGOW_HASKELL__ >= 705 +{-# LANGUAGE PolyKinds #-} +#endif + +module Generics.Deriving.Semigroup ( + -- * Generic semigroup class + GSemigroup(..) + + -- * Default definition + , gsappenddefault + + ) where + +import Control.Applicative +import Data.Monoid as Monoid +#if MIN_VERSION_base(4,5,0) + hiding ((<>)) +#endif +import Generics.Deriving.Base + +#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.Void (Void) +#endif + +#if MIN_VERSION_base(4,9,0) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Semigroup as Semigroup +import Generics.Deriving.Monoid (GMonoid(..)) +#endif + +------------------------------------------------------------------------------- + +infixr 6 `gsappend'` +class GSemigroup' f where + gsappend' :: f x -> f x -> f x + +instance GSemigroup' U1 where + gsappend' U1 U1 = U1 + +instance GSemigroup a => GSemigroup' (K1 i a) where + gsappend' (K1 x) (K1 y) = K1 (gsappend x y) + +instance GSemigroup' f => GSemigroup' (M1 i c f) where + gsappend' (M1 x) (M1 y) = M1 (gsappend' x y) + +instance (GSemigroup' f, GSemigroup' g) => GSemigroup' (f :*: g) where + gsappend' (x1 :*: y1) (x2 :*: y2) = gsappend' x1 x2 :*: gsappend' y1 y2 + +------------------------------------------------------------------------------- + +infixr 6 `gsappend` +class GSemigroup a where + gsappend :: a -> a -> a +#if __GLASGOW_HASKELL__ >= 701 + default gsappend :: (Generic a, GSemigroup' (Rep a)) => a -> a -> a + gsappend = gsappenddefault +#endif + + gstimes :: Integral b => b -> a -> a + gstimes y0 x0 + | y0 <= 0 = error "gstimes: positive multiplier expected" + | otherwise = f x0 y0 + where + f x y + | even y = f (gsappend x x) (y `quot` 2) + | y == 1 = x + | otherwise = g (gsappend x x) (pred y `quot` 2) x + g x y z + | even y = g (gsappend x x) (y `quot` 2) z + | y == 1 = gsappend x z + | otherwise = g (gsappend x x) (pred y `quot` 2) (gsappend x z) + +#if MIN_VERSION_base(4,9,0) + -- | Only available with @base-4.9@ or later + gsconcat :: NonEmpty a -> a + gsconcat (a :| as) = go a as where + go b (c:cs) = gsappend b (go c cs) + go b [] = b +#endif + +infixr 6 `gsappenddefault` +gsappenddefault :: (Generic a, GSemigroup' (Rep a)) => a -> a -> a +gsappenddefault x y = to (gsappend' (from x) (from y)) + +------------------------------------------------------------------------------- + +-- Instances that reuse Monoid +instance GSemigroup Ordering where + gsappend = mappend +instance GSemigroup () where + gsappend = mappend +instance GSemigroup Any where + gsappend = mappend +instance GSemigroup All where + gsappend = mappend +instance GSemigroup (Monoid.First a) where + gsappend = mappend +instance GSemigroup (Monoid.Last a) where + gsappend = mappend +instance Num a => GSemigroup (Sum a) where + gsappend = mappend +instance Num a => GSemigroup (Product a) where + gsappend = mappend +instance GSemigroup [a] where + gsappend = mappend +instance GSemigroup (Endo a) where + gsappend = mappend +#if MIN_VERSION_base(4,8,0) +instance Alternative f => GSemigroup (Alt f a) where + gsappend = mappend +#endif + +-- Handwritten instances +instance GSemigroup a => GSemigroup (Dual a) where + gsappend (Dual x) (Dual y) = Dual (gsappend y x) +instance GSemigroup a => GSemigroup (Maybe a) where + gsappend Nothing x = x + gsappend x Nothing = x + gsappend (Just x) (Just y) = Just (gsappend x y) +instance GSemigroup b => GSemigroup (a -> b) where + gsappend f g x = gsappend (f x) (g x) +instance GSemigroup a => GSemigroup (Const a b) where + gsappend = gsappenddefault +instance GSemigroup (Either a b) where + gsappend Left{} b = b + gsappend a _ = a + +#if MIN_VERSION_base(4,7,0) +instance GSemigroup +# if MIN_VERSION_base(4,9,0) + (Proxy s) +# else + (Proxy (s :: *)) +# endif + where + gsappend = gsappenddefault +#endif + +#if MIN_VERSION_base(4,8,0) +instance GSemigroup a => GSemigroup (Identity a) where + gsappend = gsappenddefault + +instance GSemigroup Void where + gsappend a _ = a +#endif + +#if MIN_VERSION_base(4,9,0) +instance GSemigroup (Semigroup.First a) where + gsappend = (<>) + +instance GSemigroup (Semigroup.Last a) where + gsappend = (<>) + +instance Ord a => GSemigroup (Max a) where + gsappend = (<>) + +instance Ord a => GSemigroup (Min a) where + gsappend = (<>) + +instance GSemigroup (NonEmpty a) where + gsappend = (<>) + +instance GSemigroup a => GSemigroup (Option a) where + gsappend (Option a) (Option b) = Option (gsappend a b) + +instance GMonoid m => GSemigroup (WrappedMonoid m) where + gsappend (WrapMonoid a) (WrapMonoid b) = WrapMonoid (gmappend a b) +#endif + +-- Tuple instances +instance (GSemigroup a,GSemigroup b) => GSemigroup (a,b) where + gsappend (a1,b1) (a2,b2) = + (gsappend a1 a2,gsappend b1 b2) +instance (GSemigroup a,GSemigroup b,GSemigroup c) => GSemigroup (a,b,c) where + gsappend (a1,b1,c1) (a2,b2,c2) = + (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2) +instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d) => GSemigroup (a,b,c,d) where + gsappend (a1,b1,c1,d1) (a2,b2,c2,d2) = + (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2) +instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e) => GSemigroup (a,b,c,d,e) where + gsappend (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) = + (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2) +instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e,GSemigroup f) => GSemigroup (a,b,c,d,e,f) where + gsappend (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) = + (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2,gsappend f1 f2) +instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e,GSemigroup f,GSemigroup g) => GSemigroup (a,b,c,d,e,f,g) where + gsappend (a1,b1,c1,d1,e1,f1,g1) (a2,b2,c2,d2,e2,f2,g2) = + (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2,gsappend f1 f2,gsappend g1 g2) +instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e,GSemigroup f,GSemigroup g,GSemigroup h) => GSemigroup (a,b,c,d,e,f,g,h) where + gsappend (a1,b1,c1,d1,e1,f1,g1,h1) (a2,b2,c2,d2,e2,f2,g2,h2) = + (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2,gsappend f1 f2,gsappend g1 g2,gsappend 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 @@ -8,6 +8,7 @@ #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ < 709 @@ -37,7 +38,6 @@ import Foreign.Ptr import Generics.Deriving.Base -import Generics.Deriving.Instances () import GHC.Exts hiding (Any) 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 @@ -3,10 +3,16 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} + #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE Safe #-} #endif +#if __GLASGOW_HASKELL__ >= 705 +{-# LANGUAGE PolyKinds #-} +#endif + module Generics.Deriving.Traversable ( -- * GTraversable class GTraversable(..) @@ -27,7 +33,6 @@ 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) 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 @@ -7,8 +7,13 @@ #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE Trustworthy #-} #endif +#if __GLASGOW_HASKELL__ >= 705 +{-# LANGUAGE PolyKinds #-} +#endif + #if __GLASGOW_HASKELL__ < 709 {-# LANGUAGE OverlappingInstances #-} #endif @@ -51,7 +56,6 @@ import Generics.Deriving.Base -import Generics.Deriving.Instances () import Control.Monad (liftM, liftM2) import GHC.Exts (build)