generic-deriving-1.9.0/0000755000000000000000000000000012623367676013152 5ustar0000000000000000generic-deriving-1.9.0/Setup.hs0000644000000000000000000000012712623367676014606 0ustar0000000000000000module Main (main) where import Distribution.Simple main :: IO () main = defaultMain generic-deriving-1.9.0/README.md0000644000000000000000000000270312623367676014433 0ustar0000000000000000## `generic-deriving`: Generic programming library for generalised deriving [![Hackage](https://img.shields.io/hackage/v/generic-deriving.svg)][Hackage: generic-deriving] [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/generic-deriving.svg)](http://packdeps.haskellers.com/reverse/generic-deriving) [![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] [![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3] [![Build](https://img.shields.io/travis/dreixel/generic-deriving.svg)](https://travis-ci.org/dreixel/generic-deriving) [Hackage: generic-deriving]: http://hackage.haskell.org/package/generic-deriving "generic-deriving package on Hackage" [Haskell.org]: http://www.haskell.org "The Haskell Programming Language" [tl;dr Legal: BSD3]: https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29 "BSD 3-Clause License (Revised)" 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](http://dreixel.net/research/pdf/gdmh.pdf). Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh. Haskell'10. The current implementation integrates with the new GHC Generics. See http://www.haskell.org/haskellwiki/GHC.Generics for more information. Template Haskell code is provided for supporting older GHCs. generic-deriving-1.9.0/LICENSE0000644000000000000000000000274112623367676014163 0ustar0000000000000000Copyright (c) 2010 Universiteit Utrecht All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of Universiteit Utrecht nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. generic-deriving-1.9.0/generic-deriving.cabal0000644000000000000000000000527212623367676017365 0ustar0000000000000000name: 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 generic-deriving-1.9.0/CHANGELOG.md0000644000000000000000000000147012623367676014765 0ustar0000000000000000# 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 generic-deriving-1.9.0/src/0000755000000000000000000000000012623367676013741 5ustar0000000000000000generic-deriving-1.9.0/src/Generics/0000755000000000000000000000000012623367676015500 5ustar0000000000000000generic-deriving-1.9.0/src/Generics/Deriving.hs0000644000000000000000000000113612623367676017604 0ustar0000000000000000 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 generic-deriving-1.9.0/src/Generics/Deriving/0000755000000000000000000000000012623367676017247 5ustar0000000000000000generic-deriving-1.9.0/src/Generics/Deriving/Uniplate.hs0000644000000000000000000002517212623367676021373 0ustar0000000000000000{-# 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') generic-deriving-1.9.0/src/Generics/Deriving/Traversable.hs0000644000000000000000000000570512623367676022064 0ustar0000000000000000{-# 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 generic-deriving-1.9.0/src/Generics/Deriving/TH.hs0000644000000000000000000012120012623367676020112 0ustar0000000000000000{-# 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] generic-deriving-1.9.0/src/Generics/Deriving/Show.hs0000644000000000000000000003232312623367676020526 0ustar0000000000000000{-# 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 generic-deriving-1.9.0/src/Generics/Deriving/Monoid.hs0000644000000000000000000001717012623367676021036 0ustar0000000000000000{-# 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) generic-deriving-1.9.0/src/Generics/Deriving/Instances.hs0000644000000000000000000011370512623367676021541 0ustar0000000000000000{-# 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 generic-deriving-1.9.0/src/Generics/Deriving/Functor.hs0000644000000000000000000000523112623367676021224 0ustar0000000000000000{-# 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 generic-deriving-1.9.0/src/Generics/Deriving/Foldable.hs0000644000000000000000000001204412623367676021314 0ustar0000000000000000{-# 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 []) generic-deriving-1.9.0/src/Generics/Deriving/Eq.hs0000644000000000000000000002156212623367676020156 0ustar0000000000000000{-# 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 generic-deriving-1.9.0/src/Generics/Deriving/Enum.hs0000644000000000000000000005136412623367676020520 0ustar0000000000000000{-# 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 generic-deriving-1.9.0/src/Generics/Deriving/Copoint.hs0000644000000000000000000000573112623367676021224 0ustar0000000000000000{-# 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 generic-deriving-1.9.0/src/Generics/Deriving/ConNames.hs0000644000000000000000000000354612623367676021316 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Generics.Deriving.ConNames -- Copyright : (c) 2012 University of Oxford -- License : BSD3 -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable -- -- Summary: Return the name of all the constructors of a type. -- ----------------------------------------------------------------------------- module Generics.Deriving.ConNames ( -- * Functionality for retrieving the names of the possible contructors -- of a type or the constructor name of a given value ConNames(..), conNames, conNameOf ) where import Generics.Deriving.Base class ConNames f where gconNames :: f a -> [String] gconNameOf :: f a -> String instance (ConNames f, ConNames g) => ConNames (f :+: g) where gconNames (_ :: (f :+: g) a) = gconNames (undefined :: f a) ++ gconNames (undefined :: g a) gconNameOf (L1 x) = gconNameOf x gconNameOf (R1 x) = gconNameOf x instance (ConNames f) => ConNames (D1 c f) where gconNames (_ :: (D1 c f) a) = gconNames (undefined :: f a) gconNameOf (M1 x) = gconNameOf x instance (Constructor c) => ConNames (C1 c f) where gconNames x = [conName x] gconNameOf x = conName x -- We should never need any other instances. -- | Return the name of all the constructors of the type of the given term. conNames :: (Generic a, ConNames (Rep a)) => a -> [String] conNames x = gconNames (undefined `asTypeOf` (from x)) -- | Return the name of the constructor of the given term conNameOf :: (ConNames (Rep a), Generic a) => a -> String conNameOf x = gconNameOf (from x) generic-deriving-1.9.0/src/Generics/Deriving/Base.hs0000644000000000000000000006420512623367676020464 0ustar0000000000000000{-# 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 generic-deriving-1.9.0/src/Generics/Deriving/TH/0000755000000000000000000000000012623367676017562 5ustar0000000000000000generic-deriving-1.9.0/src/Generics/Deriving/TH/Internal.hs0000644000000000000000000004130512623367676021675 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Generics.Deriving.TH.Internal -- Copyright : (c) 2008--2009 Universiteit Utrecht -- License : BSD3 -- -- Maintainer : generics@haskell.org -- Stability : experimental -- Portability : non-portable -- -- Template Haskell-related utilities. ----------------------------------------------------------------------------- module Generics.Deriving.TH.Internal where import Data.Function (on) import Data.List import qualified Data.Map as Map import Data.Map as Map (Map) import qualified Data.Set as Set import Data.Set (Set) import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax #ifndef CURRENT_PACKAGE_KEY import Data.Version (showVersion) import Paths_generic_deriving (version) #endif ------------------------------------------------------------------------------- -- Expanding type synonyms ------------------------------------------------------------------------------- -- | Expands all type synonyms in a type. Written by Dan Rosén in the -- @genifunctors@ package (licensed under BSD3). expandSyn :: Type -> Q Type 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 t = return t expandSynApp :: Type -> [Type] -> Q Type expandSynApp (AppT t1 t2) ts = do t2' <- expandSyn t2 expandSynApp t1 (t2':ts) expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts expandSynApp t@(ConT n) ts = do info <- reify n case info of TyConI (TySynD _ tvs rhs) -> let (ts', ts'') = splitAt (length tvs) ts subs = mkSubst tvs ts' rhs' = subst 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 mkSubst :: [TyVarBndr] -> [Type] -> Subst mkSubst vs ts = let vs' = map tyVarBndrToName 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 ------------------------------------------------------------------------------- -- NameBase ------------------------------------------------------------------------------- -- | 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 } getNameBase :: NameBase -> String getNameBase = nameBase . getName instance Eq NameBase where (==) = (==) `on` getNameBase instance Ord NameBase where compare = compare `on` getNameBase ------------------------------------------------------------------------------- -- Assorted utilities ------------------------------------------------------------------------------- -- | Is the given type a type family constructor (and not a data family constructor)? isTyFamily :: Type -> Q Bool isTyFamily (ConT n) = do info <- reify n return $ case info of #if MIN_VERSION_template_haskell(2,11,0) FamilyI OpenTypeFamilyD{} _ -> True #elif MIN_VERSION_template_haskell(2,7,0) FamilyI (FamilyD TypeFam _ _ _) _ -> True #else TyConI (FamilyD TypeFam _ _ _) -> True #endif #if MIN_VERSION_template_haskell(2,9,0) FamilyI ClosedTypeFamilyD{} _ -> True #endif _ -> False isTyFamily _ = return False -- | 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 -- | Split an applied type into its individual components. For example, this: -- -- @ -- Either Int Char -- @ -- -- would split to this: -- -- @ -- [Either, Int, Char] -- @ unapplyTy :: Type -> [Type] unapplyTy = reverse . go where go :: Type -> [Type] go (AppT t1 t2) = t2:go t1 go (SigT t _) = go t go t = [t] -- | Split a type signature by the arrows on its spine. For example, this: -- -- @ -- (Int -> String) -> Char -> () -- @ -- -- would split to this: -- -- @ -- [Int -> String, Char, ()] -- @ uncurryTy :: Type -> [Type] uncurryTy (AppT (AppT ArrowT t1) t2) = t1:uncurryTy t2 uncurryTy (SigT t _) = uncurryTy t uncurryTy t = [t] -- | Like uncurryType, except on a kind level. uncurryKind :: Kind -> [Kind] #if MIN_VERSION_template_haskell(2,8,0) uncurryKind = uncurryTy #else uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2 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 tyVarBndrToName :: TyVarBndr -> Name tyVarBndrToName (PlainTV name) = name tyVarBndrToName (KindedTV name _) = name tyVarBndrToNameBase :: TyVarBndr -> NameBase tyVarBndrToNameBase = NameBase . tyVarBndrToName tyVarBndrToKind :: TyVarBndr -> Kind tyVarBndrToKind PlainTV{} = starK tyVarBndrToKind (KindedTV _ k) = k stripRecordNames :: Con -> Con stripRecordNames (RecC n f) = NormalC n (map (\(_, s, t) -> (s, t)) f) stripRecordNames c = c -- | 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: -- -- (1) All of the dropped types are type variables -- (2) All of the dropped types are distinct -- (3) None of the remaining types mention any of the dropped types 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) where nbs :: [NameBase] nbs = map varTToNameBase dropped -- | Extract the Name from a type variable. 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 -- | Peel off a kind signature from a Type (if it has one). unSigT :: Type -> Type unSigT (SigT t _) = t unSigT t = t -- | Peel off a kind signature from a TyVarBndr (if it has one). unKindedTV :: TyVarBndr -> TyVarBndr 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 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 -- | Are all of the items in a list (which have an ordering) distinct? -- -- This uses Set (as opposed to nub) for better asymptotic time complexity. allDistinct :: Ord a => [a] -> Bool allDistinct = allDistinct' Set.empty where allDistinct' :: Ord a => Set a -> [a] -> Bool allDistinct' uniqs (x:xs) | x `Set.member` uniqs = False | otherwise = allDistinct' (Set.insert x uniqs) xs allDistinct' _ _ = True trd :: (a, b, c) -> c trd (_,_,c) = c -- | Variant of foldr1 which returns a special element for empty lists foldr1' :: (a -> a -> a) -> a -> [a] -> a foldr1' _ x [] = x foldr1' _ _ [x] = x foldr1' f x (h:t) = f h (foldr1' f x t) -- | Extracts the name of a constructor. constructorName :: Con -> Name constructorName (NormalC name _ ) = name constructorName (RecC name _ ) = name constructorName (InfixC _ name _ ) = name constructorName (ForallC _ _ con) = constructorName con #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 _ = error "Must be a data or newtype declaration." #endif ------------------------------------------------------------------------------- -- Manually quoted names ------------------------------------------------------------------------------- -- By manually generating these names we avoid needing to use the -- TemplateHaskell language extension when compiling the generic-deriving library. -- This allows the library to be used in stage1 cross-compilers. gdPackageKey :: String #ifdef CURRENT_PACKAGE_KEY gdPackageKey = CURRENT_PACKAGE_KEY #else gdPackageKey = "generic-deriving-" ++ showVersion version #endif mkGD7'1_d :: String -> Name #if __GLASGOW_HASKELL__ >= 705 mkGD7'1_d = mkNameG_d "base" "GHC.Generics" #elif __GLASGOW_HASKELL__ >= 701 mkGD7'1_d = mkNameG_d "ghc-prim" "GHC.Generics" #else mkGD7'1_d = mkNameG_d gdPackageKey "Generics.Deriving.Base" #endif mkGD7'11_d :: String -> Name #if __GLASGOW_HASKELL__ >= 711 mkGD7'11_d = mkNameG_d "base" "GHC.Generics" #else mkGD7'11_d = mkNameG_d gdPackageKey "Generics.Deriving.Base" #endif mkGD7'1_tc :: String -> Name #if __GLASGOW_HASKELL__ >= 705 mkGD7'1_tc = mkNameG_tc "base" "GHC.Generics" #elif __GLASGOW_HASKELL__ >= 701 mkGD7'1_tc = mkNameG_tc "ghc-prim" "GHC.Generics" #else mkGD7'1_tc = mkNameG_tc gdPackageKey "Generics.Deriving.Base" #endif mkGD7'11_tc :: String -> Name #if __GLASGOW_HASKELL__ >= 711 mkGD7'11_tc = mkNameG_tc "base" "GHC.Generics" #else mkGD7'11_tc = mkNameG_tc gdPackageKey "Generics.Deriving.Base" #endif mkGD7'1_v :: String -> Name #if __GLASGOW_HASKELL__ >= 705 mkGD7'1_v = mkNameG_v "base" "GHC.Generics" #elif __GLASGOW_HASKELL__ >= 701 mkGD7'1_v = mkNameG_v "ghc-prim" "GHC.Generics" #else mkGD7'1_v = mkNameG_v gdPackageKey "Generics.Deriving.Base" #endif mkGD7'11_v :: String -> Name #if __GLASGOW_HASKELL__ >= 711 mkGD7'11_v = mkNameG_v "base" "GHC.Generics" #else mkGD7'11_v = mkNameG_v gdPackageKey "Generics.Deriving.Base" #endif comp1DataName :: Name comp1DataName = mkGD7'1_d "Comp1" infixDataName :: Name infixDataName = mkGD7'1_d "Infix" k1DataName :: Name k1DataName = mkGD7'1_d "K1" l1DataName :: Name l1DataName = mkGD7'1_d "L1" leftAssociativeDataName :: Name leftAssociativeDataName = mkGD7'1_d "LeftAssociative" m1DataName :: Name m1DataName = mkGD7'1_d "M1" notAssociativeDataName :: Name notAssociativeDataName = mkGD7'1_d "NotAssociative" par1DataName :: Name par1DataName = mkGD7'1_d "Par1" prefixDataName :: Name prefixDataName = mkGD7'1_d "Prefix" productDataName :: Name productDataName = mkGD7'1_d ":*:" r1DataName :: Name r1DataName = mkGD7'1_d "R1" rec1DataName :: Name rec1DataName = mkGD7'1_d "Rec1" rightAssociativeDataName :: Name rightAssociativeDataName = mkGD7'1_d "RightAssociative" u1DataName :: Name u1DataName = mkGD7'1_d "U1" uAddrDataName :: Name uAddrDataName = mkGD7'11_d "UAddr" uCharDataName :: Name uCharDataName = mkGD7'11_d "UChar" uDoubleDataName :: Name uDoubleDataName = mkGD7'11_d "UDouble" uFloatDataName :: Name uFloatDataName = mkGD7'11_d "UFloat" uIntDataName :: Name uIntDataName = mkGD7'11_d "UInt" uWordDataName :: Name uWordDataName = mkGD7'11_d "UWord" c1TypeName :: Name c1TypeName = mkGD7'1_tc "C1" composeTypeName :: Name composeTypeName = mkGD7'1_tc ":.:" constructorTypeName :: Name constructorTypeName = mkGD7'1_tc "Constructor" d1TypeName :: Name d1TypeName = mkGD7'1_tc "D1" genericTypeName :: Name genericTypeName = mkGD7'1_tc "Generic" generic1TypeName :: Name generic1TypeName = mkGD7'1_tc "Generic1" datatypeTypeName :: Name datatypeTypeName = mkGD7'1_tc "Datatype" noSelectorTypeName :: Name noSelectorTypeName = mkGD7'1_tc "NoSelector" par1TypeName :: Name par1TypeName = mkGD7'1_tc "Par1" productTypeName :: Name productTypeName = mkGD7'1_tc ":*:" rec0TypeName :: Name rec0TypeName = mkGD7'1_tc "Rec0" rec1TypeName :: Name rec1TypeName = mkGD7'1_tc "Rec1" repTypeName :: Name repTypeName = mkGD7'1_tc "Rep" rep1TypeName :: Name rep1TypeName = mkGD7'1_tc "Rep1" s1TypeName :: Name s1TypeName = mkGD7'1_tc "S1" selectorTypeName :: Name selectorTypeName = mkGD7'1_tc "Selector" sumTypeName :: Name sumTypeName = mkGD7'1_tc ":+:" u1TypeName :: Name u1TypeName = mkGD7'1_tc "U1" uAddrTypeName :: Name uAddrTypeName = mkGD7'11_tc "UAddr" uCharTypeName :: Name uCharTypeName = mkGD7'11_tc "UChar" uDoubleTypeName :: Name uDoubleTypeName = mkGD7'11_tc "UDouble" uFloatTypeName :: Name uFloatTypeName = mkGD7'11_tc "UFloat" uIntTypeName :: Name uIntTypeName = mkGD7'11_tc "UInt" uWordTypeName :: Name uWordTypeName = mkGD7'11_tc "UWord" v1TypeName :: Name v1TypeName = mkGD7'1_tc "V1" conFixityValName :: Name conFixityValName = mkGD7'1_v "conFixity" conIsRecordValName :: Name conIsRecordValName = mkGD7'1_v "conIsRecord" conNameValName :: Name conNameValName = mkGD7'1_v "conName" datatypeNameValName :: Name datatypeNameValName = mkGD7'1_v "datatypeName" #if __GLASGOW_HASKELL__ >= 708 isNewtypeValName :: Name isNewtypeValName = mkGD7'1_v "isNewtype" #endif fromValName :: Name fromValName = mkGD7'1_v "from" from1ValName :: Name from1ValName = mkGD7'1_v "from1" 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" toValName :: Name toValName = mkGD7'1_v "to" to1ValName :: Name to1ValName = mkGD7'1_v "to1" uAddrHashValName :: Name uAddrHashValName = mkGD7'11_v "uAddr#" uCharHashValName :: Name uCharHashValName = mkGD7'11_v "uChar#" uDoubleHashValName :: Name uDoubleHashValName = mkGD7'11_v "uDouble#" uFloatHashValName :: Name uFloatHashValName = mkGD7'11_v "uFloat#" uIntHashValName :: Name uIntHashValName = mkGD7'11_v "uInt#" uWordHashValName :: Name uWordHashValName = mkGD7'11_v "uWord#" unComp1ValName :: Name unComp1ValName = mkGD7'1_v "unComp1" unK1ValName :: Name unK1ValName = mkGD7'1_v "unK1" unPar1ValName :: Name unPar1ValName = mkGD7'1_v "unPar1" unRec1ValName :: Name unRec1ValName = mkGD7'1_v "unRec1" trueDataName :: Name #if __GLASGOW_HASKELL__ >= 701 trueDataName = mkNameG_d "ghc-prim" "GHC.Types" "True" #else trueDataName = mkNameG_d "ghc-prim" "GHC.Bool" "True" #endif mkGHCPrim_tc :: String -> Name mkGHCPrim_tc = mkNameG_tc "ghc-prim" "GHC.Prim" addrHashTypeName :: Name addrHashTypeName = mkGHCPrim_tc "Addr#" charHashTypeName :: Name charHashTypeName = mkGHCPrim_tc "Char#" doubleHashTypeName :: Name doubleHashTypeName = mkGHCPrim_tc "Double#" floatHashTypeName :: Name floatHashTypeName = mkGHCPrim_tc "Float#" intHashTypeName :: Name intHashTypeName = mkGHCPrim_tc "Int#" wordHashTypeName :: Name wordHashTypeName = mkGHCPrim_tc "Word#" composeValName :: Name composeValName = mkNameG_v "base" "GHC.Base" "." errorValName :: Name errorValName = mkNameG_v "base" "GHC.Err" "error" fmapValName :: Name fmapValName = mkNameG_v "base" "GHC.Base" "fmap" undefinedValName :: Name undefinedValName = mkNameG_v "base" "GHC.Err" "undefined" generic-deriving-1.9.0/examples/0000755000000000000000000000000012623367676014770 5ustar0000000000000000generic-deriving-1.9.0/examples/Examples.hs0000644000000000000000000004302012623367676017101 0ustar0000000000000000{-# 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