generic-deriving-1.4.0/0000755000000000000000000000000012060325706013124 5ustar0000000000000000generic-deriving-1.4.0/Setup.hs0000644000000000000000000000013512060325706014557 0ustar0000000000000000module Main (main) where import Distribution.Simple main :: IO () main = defaultMain generic-deriving-1.4.0/LICENSE0000644000000000000000000000277512060325706014144 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.4.0/generic-deriving.cabal0000644000000000000000000000413712060325706017336 0ustar0000000000000000name: generic-deriving version: 1.4.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. category: Generics copyright: 2011-2012 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.3, GHC == 7.2.1, GHC == 7.4.1, GHC == 7.6.1 extra-source-files: examples/Examples.hs 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.ConNames Generics.Deriving.Enum Generics.Deriving.Eq Generics.Deriving.Foldable Generics.Deriving.Functor Generics.Deriving.Show Generics.Deriving.Traversable Generics.Deriving.Uniplate Generics.Deriving.TH build-depends: base < 5, template-haskell >=2.4 && <2.9 if impl(ghc > 7.0) build-depends: ghc-prim < 1 extensions: CPP ghc-options: -Wall generic-deriving-1.4.0/src/0000755000000000000000000000000012060325706013713 5ustar0000000000000000generic-deriving-1.4.0/src/Generics/0000755000000000000000000000000012060325706015452 5ustar0000000000000000generic-deriving-1.4.0/src/Generics/Deriving.hs0000644000000000000000000000103112060325706017550 0ustar0000000000000000 module Generics.Deriving ( module Generics.Deriving.Base, 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.ConNames import Generics.Deriving.Enum import Generics.Deriving.Eq import Generics.Deriving.Functor import Generics.Deriving.Show import Generics.Deriving.Uniplate generic-deriving-1.4.0/src/Generics/Deriving/0000755000000000000000000000000012060325706017221 5ustar0000000000000000generic-deriving-1.4.0/src/Generics/Deriving/Uniplate.hs0000644000000000000000000002425312060325706021344 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} #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 (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 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 Context' (K1 i a) a where context' _ [] = error "Generics.Deriving.Uniplate.context: empty list" context' (K1 _) (c:_) = K1 c instance 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 (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 (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.4.0/src/Generics/Deriving/Traversable.hs0000644000000000000000000000505412060325706022033 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} #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 () -------------------------------------------------------------------------------- -- 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 Maybe where gtraverse = gtraversedefault instance GTraversable [] where gtraverse = gtraversedefault generic-deriving-1.4.0/src/Generics/Deriving/TH.hs0000644000000000000000000003566512060325706020107 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, CPP #-} {-# OPTIONS_GHC -w #-} ----------------------------------------------------------------------------- -- | -- 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. For now, it generates only the 'Generic' instance. -- Empty datatypes are not yet supported. ----------------------------------------------------------------------------- -- Adapted from Generics.Regular.TH module Generics.Deriving.TH ( deriveMeta , deriveData , deriveConstructors , deriveSelectors #if __GLASGOW_HASKELL__ < 701 , deriveAll , deriveRepresentable0 , deriveRep0 , simplInstance #endif ) where import Generics.Deriving.Base import Language.Haskell.TH hiding (Fixity()) import Language.Haskell.TH.Syntax (Lift(..)) import Data.List (intercalate) import Control.Monad -- | 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 i <- reify (genRepName 0 ty) x <- newName "x" let typ = ForallT [PlainTV x] [] ((foldl (\a -> AppT a . VarT . tyVarBndrToName) (ConT (genRepName 0 ty)) (typeVariables i)) `AppT` (VarT x)) fmap (: []) $ instanceD (cxt []) (conT cl `appT` conT ty) [funD fn [clause [] (normalB (varE df `appE` (sigE (global 'undefined) (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, 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 -- | Derive only the 'Rep0' type synonym. Not needed if 'deriveRepresentable0' -- is used. deriveRep0 :: Name -> Q [Dec] deriveRep0 n = do i <- reify n fmap (:[]) $ tySynD (genRepName 0 n) (typeVariables i) (rep0Type n) deriveInst :: Name -> Q [Dec] deriveInst t = do i <- reify t let typ q = foldl (\a -> AppT a . VarT . tyVarBndrToName) (ConT q) (typeVariables i) let tyIns = TySynInstD ''Rep [typ t] (typ (genRepName 0 t)) fcs <- mkFrom t 1 0 t tcs <- mkTo t 1 0 t liftM (:[]) $ instanceD (cxt []) (conT ''Generic `appT` return (typ t)) [return tyIns, funD 'from fcs, funD 'to tcs] dataInstance :: Name -> Q [Dec] dataInstance n = do i <- reify n case i of TyConI (DataD _ n _ _ _) -> mkInstance n TyConI (NewtypeD _ n _ _ _) -> mkInstance n _ -> return [] where mkInstance n = do ds <- mkDataData n is <- mkDataInstance n return $ [ds,is] constrInstance :: Name -> Q [Dec] constrInstance n = do i <- reify n case i of TyConI (DataD _ n _ cs _) -> mkInstance n cs TyConI (NewtypeD _ n _ c _) -> mkInstance n [c] _ -> return [] where mkInstance n cs = do ds <- mapM (mkConstrData n) cs is <- mapM (mkConstrInstance n) cs return $ ds ++ is selectInstance :: Name -> Q [Dec] selectInstance n = do i <- reify n case i of TyConI (DataD _ n _ cs _) -> mkInstance n cs TyConI (NewtypeD _ n _ c _) -> mkInstance n [c] _ -> return [] where mkInstance n cs = do ds <- mapM (mkSelectData n) cs is <- mapM (mkSelectInstance n) cs return $ concat (ds ++ is) typeVariables :: Info -> [TyVarBndr] typeVariables (TyConI (DataD _ _ tv _ _)) = tv typeVariables (TyConI (NewtypeD _ _ tv _ _)) = tv typeVariables _ = [] tyVarBndrToName :: TyVarBndr -> Name tyVarBndrToName (PlainTV name) = name tyVarBndrToName (KindedTV name _) = name stripRecordNames :: Con -> Con stripRecordNames (RecC n f) = NormalC n (map (\(_, s, t) -> (s, t)) f) stripRecordNames c = c genName :: [Name] -> Name genName = mkName . (++"_") . intercalate "_" . map nameBase genRepName :: Int -> Name -> Name genRepName n = mkName . (++"_") . (("Rep" ++ show n) ++) . nameBase mkDataData :: Name -> Q Dec mkDataData n = dataD (cxt []) (genName [n]) [] [] [] mkConstrData :: Name -> Con -> Q Dec mkConstrData dt (NormalC n _) = dataD (cxt []) (genName [dt, n]) [] [] [] mkConstrData dt r@(RecC _ _) = mkConstrData dt (stripRecordNames r) mkConstrData dt (InfixC t1 n t2) = mkConstrData dt (NormalC n [t1,t2]) mkSelectData :: Name -> Con -> Q [Dec] mkSelectData dt r@(RecC n fs) = return (map one fs) where one (f, _, _) = DataD [] (genName [dt, n, f]) [] [] [] mkSelectData dt _ = return [] mkDataInstance :: Name -> Q Dec mkDataInstance n = instanceD (cxt []) (appT (conT ''Datatype) (conT $ genName [n])) [funD 'datatypeName [clause [wildP] (normalB (stringE (nameBase n))) []] ,funD 'moduleName [clause [wildP] (normalB (stringE name)) []]] where name = maybe (error "Cannot fetch module name!") id (nameModule n) instance Lift Fixity where lift Prefix = conE 'Prefix lift (Infix a n) = conE 'Infix `appE` [| a |] `appE` [| n |] instance Lift Associativity where lift LeftAssociative = conE 'LeftAssociative lift RightAssociative = conE 'RightAssociative lift NotAssociative = conE 'NotAssociative mkConstrInstance :: Name -> Con -> Q Dec mkConstrInstance dt (NormalC n _) = mkConstrInstanceWith dt n [] mkConstrInstance dt (RecC n _) = mkConstrInstanceWith dt n [ funD 'conIsRecord [clause [wildP] (normalB (conE 'True)) []]] mkConstrInstance dt (InfixC t1 n t2) = do i <- reify n let fi = case i of DataConI _ _ _ f -> convertFixity f _ -> Prefix instanceD (cxt []) (appT (conT ''Constructor) (conT $ genName [dt, n])) [funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []], funD 'conFixity [clause [wildP] (normalB [| fi |]) []]] where convertFixity (Fixity n d) = Infix (convertDirection d) n convertDirection InfixL = LeftAssociative convertDirection InfixR = RightAssociative convertDirection InfixN = NotAssociative mkConstrInstanceWith :: Name -> Name -> [Q Dec] -> Q Dec mkConstrInstanceWith dt n extra = instanceD (cxt []) (appT (conT ''Constructor) (conT $ genName [dt, n])) (funD 'conName [clause [wildP] (normalB (stringE (nameBase n))) []] : extra) mkSelectInstance :: Name -> Con -> Q [Dec] mkSelectInstance dt r@(RecC n fs) = return (map one fs) where one (f, _, _) = InstanceD ([]) (AppT (ConT ''Selector) (ConT $ genName [dt, n, f])) [FunD 'selName [Clause [WildP] (NormalB (LitE (StringL (nameBase f)))) []]] mkSelectInstance _ _ = return [] rep0Type :: Name -> Q Type rep0Type n = do -- runIO $ putStrLn $ "processing " ++ show n i <- reify n let b = case i of TyConI (DataD _ dt vs cs _) -> (conT ''D1) `appT` (conT $ genName [dt]) `appT` (foldr1' sum (conT ''V1) (map (rep0Con (dt, map tyVarBndrToName vs)) cs)) TyConI (NewtypeD _ dt vs c _) -> (conT ''D1) `appT` (conT $ genName [dt]) `appT` (rep0Con (dt, map tyVarBndrToName vs) c) TyConI (TySynD t _ _) -> error "type synonym?" _ -> error "unknown construct" --appT b (conT $ mkName (nameBase n)) b where sum :: Q Type -> Q Type -> Q Type sum a b = conT ''(:+:) `appT` a `appT` b rep0Con :: (Name, [Name]) -> Con -> Q Type rep0Con (dt, vs) (NormalC n []) = conT ''C1 `appT` (conT $ genName [dt, n]) `appT` (conT ''S1 `appT` conT ''NoSelector `appT` conT ''U1) rep0Con (dt, vs) (NormalC n fs) = conT ''C1 `appT` (conT $ genName [dt, n]) `appT` (foldr1 prod (map (repField (dt, vs) . snd) fs)) where prod :: Q Type -> Q Type -> Q Type prod a b = conT ''(:*:) `appT` a `appT` b rep0Con (dt, vs) r@(RecC n []) = conT ''C1 `appT` (conT $ genName [dt, n]) `appT` conT ''U1 rep0Con (dt, vs) r@(RecC n fs) = conT ''C1 `appT` (conT $ genName [dt, n]) `appT` (foldr1 prod (map (repField' (dt, vs) n) fs)) where prod :: Q Type -> Q Type -> Q Type prod a b = conT ''(:*:) `appT` a `appT` b rep0Con d (InfixC t1 n t2) = rep0Con d (NormalC n [t1,t2]) --dataDeclToType :: (Name, [Name]) -> Type --dataDeclToType (dt, vs) = foldl (\a b -> AppT a (VarT b)) (ConT dt) vs repField :: (Name, [Name]) -> Type -> Q Type --repField d t | t == dataDeclToType d = conT ''I repField d t = conT ''S1 `appT` conT ''NoSelector `appT` (conT ''Rec0 `appT` return t) repField' :: (Name, [Name]) -> Name -> (Name, Strict, Type) -> Q Type --repField' d ns (_, _, t) | t == dataDeclToType d = conT ''I repField' (dt, vs) ns (f, _, t) = conT ''S1 `appT` conT (genName [dt, ns, f]) `appT` (conT ''Rec0 `appT` return t) -- Note: we should generate Par0 too, at some point mkFrom :: Name -> Int -> Int -> Name -> Q [Q Clause] mkFrom ns m i n = do -- runIO $ putStrLn $ "processing " ++ show n let wrapE e = lrE m i e i <- reify n let b = case i of TyConI (DataD _ dt vs cs _) -> zipWith (fromCon wrapE ns (dt, map tyVarBndrToName vs) (length cs)) [0..] cs TyConI (NewtypeD _ dt vs c _) -> [fromCon wrapE ns (dt, map tyVarBndrToName vs) 1 0 c] TyConI (TySynD t _ _) -> error "type synonym?" -- [clause [varP (field 0)] (normalB (wrapE $ conE 'K1 `appE` varE (field 0))) []] _ -> error "unknown construct" return b mkTo :: Name -> Int -> Int -> Name -> Q [Q Clause] mkTo ns m i n = do -- runIO $ putStrLn $ "processing " ++ show n let wrapP p = lrP m i p i <- reify n let b = case i of TyConI (DataD _ dt vs cs _) -> zipWith (toCon wrapP ns (dt, map tyVarBndrToName vs) (length cs)) [0..] cs TyConI (NewtypeD _ dt vs c _) -> [toCon wrapP ns (dt, map tyVarBndrToName vs) 1 0 c] TyConI (TySynD t _ _) -> error "type synonym?" -- [clause [wrapP $ conP 'K1 [varP (field 0)]] (normalB $ varE (field 0)) []] _ -> error "unknown construct" return b fromCon :: (Q Exp -> Q Exp) -> Name -> (Name, [Name]) -> Int -> Int -> Con -> Q Clause fromCon wrap ns (dt, vs) m i (NormalC cn []) = clause [conP cn []] (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ appE (conE 'M1) $ conE 'M1 `appE` (conE 'U1)) [] fromCon wrap ns (dt, vs) m i (NormalC cn fs) = -- runIO (putStrLn ("constructor " ++ show ix)) >> clause [conP cn (map (varP . field) [0..length fs - 1])] (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ conE 'M1 `appE` foldr1 prod (zipWith (fromField (dt, vs)) [0..] (map snd fs))) [] where prod x y = conE '(:*:) `appE` x `appE` y fromCon wrap ns (dt, vs) m i r@(RecC cn []) = clause [conP cn []] (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ conE 'M1 `appE` (conE 'U1)) [] fromCon wrap ns (dt, vs) m i r@(RecC cn fs) = clause [conP cn (map (varP . field) [0..length fs - 1])] (normalB $ appE (conE 'M1) $ wrap $ lrE m i $ conE 'M1 `appE` foldr1 prod (zipWith (fromField (dt, vs)) [0..] (map trd fs))) [] where prod x y = conE '(:*:) `appE` x `appE` y fromCon wrap ns (dt, vs) m i (InfixC t1 cn t2) = fromCon wrap ns (dt, vs) m i (NormalC cn [t1,t2]) fromField :: (Name, [Name]) -> Int -> Type -> Q Exp --fromField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conE 'I `appE` varE (field nr) fromField (dt, vs) nr t = conE 'M1 `appE` (conE 'K1 `appE` varE (field nr)) toCon :: (Q Pat -> Q Pat) -> Name -> (Name, [Name]) -> Int -> Int -> Con -> Q Clause toCon wrap ns (dt, vs) m i (NormalC cn []) = clause [wrap $ conP 'M1 [lrP m i $ conP 'M1 [conP 'M1 [conP 'U1 []]]]] (normalB $ conE cn) [] toCon wrap ns (dt, vs) m i (NormalC cn fs) = -- runIO (putStrLn ("constructor " ++ show ix)) >> clause [wrap $ conP 'M1 [lrP m i $ conP 'M1 [foldr1 prod (zipWith (toField (dt, vs)) [0..] (map snd fs))]]] (normalB $ foldl appE (conE cn) (map (varE . field) [0..length fs - 1])) [] where prod x y = conP '(:*:) [x,y] toCon wrap ns (dt, vs) m i r@(RecC cn []) = clause [wrap $ conP 'M1 [lrP m i $ conP 'M1 [conP 'U1 []]]] (normalB $ conE cn) [] toCon wrap ns (dt, vs) m i r@(RecC cn fs) = clause [wrap $ conP 'M1 [lrP m i $ conP 'M1 [foldr1 prod (zipWith (toField (dt, vs)) [0..] (map trd fs))]]] (normalB $ foldl appE (conE cn) (map (varE . field) [0..length fs - 1])) [] where prod x y = conP '(:*:) [x,y] toCon wrap ns (dt, vs) m i (InfixC t1 cn t2) = toCon wrap ns (dt, vs) m i (NormalC cn [t1,t2]) toField :: (Name, [Name]) -> Int -> Type -> Q Pat --toField (dt, vs) nr t | t == dataDeclToType (dt, vs) = conP 'I [varP (field nr)] toField (dt, vs) nr t = conP 'M1 [conP 'K1 [varP (field nr)]] field :: Int -> Name field n = mkName $ "f" ++ show n lrP :: Int -> Int -> (Q Pat -> Q Pat) lrP 1 0 p = p lrP m 0 p = conP 'L1 [p] lrP m i p = conP 'R1 [lrP (m-1) (i-1) p] lrE :: Int -> Int -> (Q Exp -> Q Exp) lrE 1 0 e = e lrE m 0 e = conE 'L1 `appE` e lrE m i e = conE 'R1 `appE` lrE (m-1) (i-1) e trd (_,_,c) = c -- | Variant of foldr1 which returns a special element for empty lists foldr1' f x [] = x foldr1' _ _ [x] = x foldr1' f x (h:t) = f h (foldr1' f x t) generic-deriving-1.4.0/src/Generics/Deriving/Show.hs0000644000000000000000000001142212060325706020475 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} #endif module Generics.Deriving.Show ( -- * Generic show class GShow(..) -- * Default definition , gshowsPrecdefault ) where import Generics.Deriving.Base import Generics.Deriving.Instances () -------------------------------------------------------------------------------- -- Generic show -------------------------------------------------------------------------------- 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 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 instance (GShow a) => GShow (Maybe a) #else instance (GShow a) => GShow (Maybe a) where gshowsPrec = gshowsPrecdefault #endif gshowsPrecdefault :: (Generic a, GShow' (Rep a)) => Int -> a -> ShowS gshowsPrecdefault n = gshowsPrec' Pref n . from -- Base types instances instance GShow Char where gshowsPrec = showsPrec instance GShow Int where gshowsPrec = showsPrec instance GShow Float where gshowsPrec = showsPrec instance GShow String where gshowsPrec = showsPrec instance GShow Bool where gshowsPrec = showsPrec intersperse :: a -> [a] -> [a] intersperse _ [] = [] intersperse _ [h] = [h] intersperse x (h:t) = h : x : (intersperse x t) instance (GShow a) => GShow [a] where gshowsPrec _ l = showChar '[' . foldr (.) id (intersperse (showChar ',') (map (gshowsPrec 0) l)) . showChar ']' generic-deriving-1.4.0/src/Generics/Deriving/Instances.hs0000644000000000000000000000637112060325706021513 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Generics.Deriving.Instances ( -- Only instances from Generics.Deriving.Base -- and the Generic1 instances #if __GLASGOW_HASKELL__ < 705 Rep1Maybe, Rep1List #endif #if __GLASGOW_HASKELL__ < 701 -- * Representations for base types , Rep0Char, Rep0Int, Rep0Float , Rep0Maybe, Rep0List #endif ) where #if __GLASGOW_HASKELL__ < 705 import Generics.Deriving.Base #endif #if __GLASGOW_HASKELL__ < 701 -------------------------------------------------------------------------------- -- Representation for base types -------------------------------------------------------------------------------- -- Representation types {- type Rep1Par1 = Par1 instance Generic1 Par1 Rep1Par1 where from1 = id to1 = id type Rep1Rec1 f = Rec1 f instance Generic1 (Rec1 f) (Rep1Rec1 f) where from1 = id to1 = id -} -- Kind * type Rep0Char = Rec0 Char instance Generic Char where type Rep Char = Rep0Char from = K1 to = unK1 type Rep0Int = Rec0 Int instance Generic Int where type Rep Int = Rep0Int from = K1 to = unK1 type Rep0Float = Rec0 Float instance Generic Float where type Rep Float = Rep0Float from = K1 to = unK1 -- etc... -- Kind * -> * type Rep0Maybe a = D1 Maybe_ (C1 Nothing_ U1 :+: C1 Just_ (Par0 a)) instance Generic (Maybe a) where type Rep (Maybe a) = Rep0Maybe a from Nothing = M1 (L1 (M1 U1)) from (Just x) = M1 (R1 (M1 (K1 x))) to (M1 (L1 (M1 U1))) = Nothing to (M1 (R1 (M1 (K1 x)))) = Just x type Rep0List a = D1 List__ ((C1 Nil__ U1) :+: (C1 Cons__ (Par0 a :*: Rec0 [a]))) instance Generic [a] where type Rep [a] = Rep0List a from [] = M1 (L1 (M1 U1)) from (h:t) = M1 (R1 (M1 (K1 h :*: K1 t))) to (M1 (L1 (M1 U1))) = [] to (M1 (R1 (M1 (K1 h :*: K1 t)))) = h : t #endif #if __GLASGOW_HASKELL__ < 705 -- GHC 7.2 and 7.4 still need these instances; 7.6 doesn't data Maybe_ data Nothing_ data Just_ instance Datatype Maybe_ where datatypeName _ = "Maybe" moduleName _ = "Representation" instance Constructor Nothing_ where conName _ = "Nothing" instance Constructor Just_ where conName _ = "Just" type Rep1Maybe = D1 Maybe_ (C1 Nothing_ U1 :+: C1 Just_ Par1) instance Generic1 Maybe where type Rep1 Maybe = Rep1Maybe from1 Nothing = M1 (L1 (M1 U1)) from1 (Just x) = M1 (R1 (M1 (Par1 x))) to1 (M1 (L1 (M1 U1))) = Nothing to1 (M1 (R1 (M1 (Par1 x)))) = Just x data List__ data Nil__ data Cons__ instance Datatype List__ where datatypeName _ = "[]" moduleName _ = "Data.List" instance Constructor Nil__ where conName _ = "[]" instance Constructor Cons__ where conName _ = ":" conFixity _ = Infix RightAssociative 5 type Rep1List = D1 List__ ((C1 Nil__ U1) :+: (C1 Cons__ (Par1 :*: Rec1 []))) instance Generic1 [] where type Rep1 [] = Rep1List from1 [] = M1 (L1 (M1 U1)) from1 (h:t) = M1 (R1 (M1 (Par1 h :*: Rec1 t))) to1 (M1 (L1 (M1 U1))) = [] to1 (M1 (R1 (M1 (Par1 h :*: Rec1 t)))) = h : t -- etc... #endif generic-deriving-1.4.0/src/Generics/Deriving/Functor.hs0000644000000000000000000000343712060325706021204 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} #endif module Generics.Deriving.Functor ( -- * GFunctor class GFunctor(..) -- * Default method , gmapdefault ) where import Generics.Deriving.Base import Generics.Deriving.Instances () -------------------------------------------------------------------------------- -- 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 Maybe where gmap = gmapdefault instance GFunctor [] where gmap = gmapdefault generic-deriving-1.4.0/src/Generics/Deriving/Foldable.hs0000644000000000000000000001117112060325706021266 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} #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 Data.Maybe import Data.Monoid import Generics.Deriving.Base import Generics.Deriving.Instances () -------------------------------------------------------------------------------- -- 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 Maybe where gfoldMap = gfoldMapdefault instance GFoldable [] 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.4.0/src/Generics/Deriving/Eq.hs0000644000000000000000000000406612060325706020130 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} #endif module Generics.Deriving.Eq ( -- * Generic show class GEq(..) #if __GLASGOW_HASKELL__ >= 701 -- Nothing #else -- * Default definition , geqdefault #endif ) where import Generics.Deriving.Base import Generics.Deriving.Instances () -- import GHC.Generics -------------------------------------------------------------------------------- -- 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 class GEq a where geq :: a -> a -> Bool #if __GLASGOW_HASKELL__ >= 701 default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool geq x y = geq' (from x) (from y) #endif #if __GLASGOW_HASKELL__ >= 701 -- Nothing; the default is in the class #else geqdefault :: (Generic a, GEq' (Rep a)) => a -> a -> Bool geqdefault x y = geq' (from x) (from y) #endif -- Base types instances instance GEq Char where geq = (==) instance GEq Int where geq = (==) instance GEq Float where geq = (==) #if __GLASGOW_HASKELL__ < 701 instance (GEq a) => GEq (Maybe a) where geq = geqdefault instance (GEq a) => GEq [a] where geq = geqdefault #else instance (GEq a) => GEq (Maybe a) instance (GEq a) => GEq [a] #endif generic-deriving-1.4.0/src/Generics/Deriving/Enum.hs0000644000000000000000000001447012060325706020467 0ustar0000000000000000{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} #endif 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 Generics.Deriving.Base import Generics.Deriving.Instances () import Generics.Deriving.Eq ----------------------------------------------------------------------------- -- 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' ] #if __GLASGOW_HASKELL__ < 701 instance (GEnum a) => GEnum (Maybe a) where genum = genumDefault instance (GEnum a) => GEnum [a] where genum = genumDefault #else instance (GEnum a) => GEnum (Maybe a) instance (GEnum a) => GEnum [a] #endif 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 instance GEnum Int where genum = [0..] ||| (neg 0) where neg n = (n-1) : neg (n-1) -------------------------------------------------------------------------------- -- 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))) #if __GLASGOW_HASKELL__ < 701 instance (GEq a, GEnum a, GIx a) => GIx (Maybe a) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a) => GIx [a] where range = rangeDefault index = indexDefault inRange = inRangeDefault #else instance (GEq a, GEnum a, GIx a) => GIx (Maybe a) instance (GEq a, GEnum a, GIx a) => GIx [a] #endif instance GIx Int where range (m,n) = [m..n] index (m,_n) i = i - m inRange (m,n) i = m <= i && i <= n generic-deriving-1.4.0/src/Generics/Deriving/ConNames.hs0000644000000000000000000000307112060325706021261 0ustar0000000000000000{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# 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 all the possible contructors -- of a type ConNames(..), conNames ) where import Generics.Deriving.Base class ConNames f where gconNames :: f a -> [String] instance (ConNames f, ConNames g) => ConNames (f :+: g) where gconNames (_ :: (f :+: g) a) = gconNames (undefined :: f a) ++ gconNames (undefined :: g a) instance (ConNames f) => ConNames (D1 c f) where gconNames (_ :: (D1 c f) a) = gconNames (undefined :: f a) instance (Constructor c) => ConNames (C1 c f) where gconNames 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)) generic-deriving-1.4.0/src/Generics/Deriving/Base.hs0000644000000000000000000001075012060325706020432 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} module Generics.Deriving.Base ( #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 ) where #if __GLASGOW_HASKELL__ >= 701 import GHC.Generics #else -------------------------------------------------------------------------------- -- Representation types -------------------------------------------------------------------------------- -- | Void: used for datatypes without constructors data V1 p -- | Unit: used for constructors without arguments data U1 p = U1 -- | Used for marking occurrences of the parameter newtype Par1 p = Par1 { unPar1 :: p } -- | Recursive calls of kind * -> * newtype Rec1 f p = Rec1 { unRec1 :: f p } -- | Constants, additional parameters and recursion of kind * newtype K1 i c p = K1 { unK1 :: c } -- | Meta-information (constructor names, etc.) newtype M1 i c f p = M1 { unM1 :: f p } -- | Sums: encode choice between constructors infixr 5 :+: data (:+:) f g p = L1 { unL1 :: f p } | R1 { unR1 :: g p } -- | Products: encode multiple arguments to constructors infixr 6 :*: data (:*:) f g p = f p :*: g p -- | Composition of functors infixr 7 :.: newtype (:.:) f g p = Comp1 { unComp1 :: f (g p) } -- | 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 generic-deriving-1.4.0/examples/0000755000000000000000000000000012060325706014742 5ustar0000000000000000generic-deriving-1.4.0/examples/Examples.hs0000644000000000000000000004036312060325706017062 0ustar0000000000000000{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE CPP #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DatatypeContexts #-} {-# LANGUAGE DeriveFunctor #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DeriveGeneric #-} #endif module Main ( -- * Run all tests main ) where import Prelude hiding (Either(..)) import Generics.Deriving import Generics.Deriving.TH -------------------------------------------------------------------------------- -- Temporary tests for TH generation -------------------------------------------------------------------------------- data (:/:) f a = MyType1Nil | MyType1Cons { myType1Rec :: (f :/: a), myType2Rec :: MyType2 } | MyType1Cons2 (f :/: a) Int a (f a) #if __GLASGOW_HASKELL__ >= 701 deriving Generic #endif data MyType2 = MyType2 Float ([] :/: Int) #if __GLASGOW_HASKELL__ < 701 $(deriveAll ''(:/:)) $(deriveAll ''MyType2) #else -- deriving instance Generic (f :/: a) deriving instance Generic MyType2 #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 = transformdefault 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 = transformdefault #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 type RepNested = D1 Nested_ (C1 Nested_Leaf_ U1 :+: C1 Nested_Nested_ (Par1 :*: Nested :.: Rec1 [])) instance Generic1 Nested where type Rep1 Nested = RepNested from1 Leaf = M1 (L1 (M1 U1)) from1 (Nested a l) = M1 (R1 (M1 (Par1 a :*: Comp1 (gmap Rec1 l)))) to1 (M1 (L1 (M1 U1))) = Leaf to1 (M1 (R1 (M1 (Par1 a :*: Comp1 l)))) = Nested a (gmap unRec1 l) #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 type Rep1GRose f = D1 GRose_ (C1 GRose_GRose_ (Rec1 f :*: f :.: (Rec1 (GRose f)))) instance (GFunctor f) => Generic1 (GRose f) where type Rep1 (GRose f) = Rep1GRose f from1 (GRose a x) = M1 (M1 (Rec1 a :*: Comp1 (gmap Rec1 x))) to1 (M1 (M1 (Rec1 a :*: Comp1 x))) = GRose a (gmap unRec1 x) #endif #if __GLASGOW_HASKELL__ < 701 -- Requires UndecidableInstances instance (GShow (f a), GShow (f (GRose f a))) => GShow (GRose f a) where gshowsPrec = gshowsPrecdefault instance (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 type Rep1Bush = U1 :+: Par1 :*: Bush :.: Rec1 Bush instance Generic1 Bush where type Rep1 Bush = Rep1Bush from1 BushNil = L1 U1 from1 (BushCons a b) = R1 (Par1 a :*: Comp1 (gmap Rec1 b)) to1 (L1 U1) = BushNil to1 (R1 (Par1 a :*: Comp1 b)) = BushCons a (gmap unRec1 b) #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