From 8c15239d75f928b3a6e15ca5660a7a10df7cb164 Mon Sep 17 00:00:00 2001 From: RyanGlScott Date: Sun, 8 Nov 2015 12:19:28 -0800 Subject: [PATCH] Use Unix line-endings [ci skip] --- examples/Examples.hs | 1278 +++++------ examples/reference.out | 92 +- misc/Tuples.hs | 206 +- src/Generics/Deriving.hs | 44 +- src/Generics/Deriving/Base.hs | 1604 +++++++------- src/Generics/Deriving/Copoint.hs | 226 +- src/Generics/Deriving/Enum.hs | 1780 ++++++++-------- src/Generics/Deriving/Eq.hs | 950 ++++----- src/Generics/Deriving/Functor.hs | 226 +- src/Generics/Deriving/Instances.hs | 2924 +++++++++++++------------- src/Generics/Deriving/Show.hs | 1072 +++++----- src/Generics/Deriving/Traversable.hs | 202 +- src/Generics/Deriving/Uniplate.hs | 766 +++---- 13 files changed, 5685 insertions(+), 5685 deletions(-) diff --git a/examples/Examples.hs b/examples/Examples.hs index 7bacd5e..d9a97e8 100644 --- a/examples/Examples.hs +++ b/examples/Examples.hs @@ -1,639 +1,639 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE DatatypeContexts #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE MagicHash #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DeriveGeneric #-} -#endif -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Main ( - -- * Run all tests - main - ) where - -import Prelude hiding (Either(..)) -import Generics.Deriving -import Generics.Deriving.TH -import GHC.Exts (Addr#, Char#, Double#, Float#, Int#, Word#) -import qualified Text.Read.Lex (Lexeme) - --------------------------------------------------------------------------------- --- Temporary tests for TH generation --------------------------------------------------------------------------------- - -data Empty a - -data (:/:) f a = MyType1Nil - | MyType1Cons { myType1Rec :: (f :/: a), myType2Rec :: MyType2 } - | MyType1Cons2 (f :/: a) Int a (f a) - | (f :/: a) :/: MyType2 - -#if __GLASGOW_HASKELL__ >= 701 - deriving ( Generic -# if __GLASGOW_HASKELL__ >= 705 - , Generic1 -# endif - ) -#endif - -data MyType2 = MyType2 Float ([] :/: Int) -data PlainHash a = Hash a Addr# Char# Double# Float# Int# Word# - -#if __GLASGOW_HASKELL__ >= 701 -deriving instance Generic (Empty a) -deriving instance Generic MyType2 -#endif - -#if __GLASGOW_HASKELL__ < 705 -$(deriveMeta ''Empty) -$(deriveMeta ''(:/:)) -$(deriveMeta ''MyType2) -#endif - -#if __GLASGOW_HASKELL__ < 701 -$(deriveRepresentable0 ''Empty) -$(deriveRepresentable0 ''(:/:)) -$(deriveRepresentable0 ''MyType2) -#endif - -#if __GLASGOW_HASKELL__ >= 705 -deriving instance Generic1 Empty -#else -$(deriveRepresentable1 ''Empty) -$(deriveRepresentable1 ''(:/:)) -#endif - -#if __GLASGOW_HASKELL__ >= 711 -deriving instance Generic (PlainHash a) -deriving instance Generic1 PlainHash -#else -$(deriveAll0And1 ''PlainHash) -#endif - --- Test to see if generated names are unique -data Lexeme = Lexeme - -$(deriveAll ''Main.Lexeme) -$(deriveAll ''Text.Read.Lex.Lexeme) - -#if __GLASGOW_HASKELL__ >= 703 -data family MyType3 a b -newtype instance MyType3 () b = MyType3Newtype b -data instance MyType3 Bool b = MyType3True | MyType3False -data instance MyType3 Int b = MyType3Hash b Addr# Char# Double# Float# Int# Word# - -# if __GLASGOW_HASKELL__ < 707 -$(deriveMeta 'MyType3Newtype) -$(deriveMeta 'MyType3True) -# endif - -# if __GLASGOW_HASKELL__ >= 705 -deriving instance Generic (MyType3 () b) -deriving instance Generic (MyType3 Bool b) -# else -$(deriveRepresentable0 'MyType3Newtype) -$(deriveRepresentable0 'MyType3True) -# endif - -# if __GLASGOW_HASKELL__ >= 707 -deriving instance Generic1 (MyType3 ()) -deriving instance Generic1 (MyType3 Bool) -# else -$(deriveRepresentable1 'MyType3Newtype) -$(deriveRepresentable1 'MyType3False) -# endif - -# if __GLASGOW_HASKELL__ >= 711 -deriving instance Generic (MyType3 Int b) -deriving instance Generic1 (MyType3 Int) -# else -$(deriveAll0And1 'MyType3Hash) -# endif -#endif - --------------------------------------------------------------------------------- --- Example: Haskell's lists and Maybe --------------------------------------------------------------------------------- - -hList1, hList2 :: [Int] -hList1 = [1..10] -hList2 = [2,4..] - -maybe1 = Nothing -maybe2 = Just (Just 'p') - -double :: [Int] -> [Int] -double [] = [] -double (x:xs) = x:x:xs - -testsStandard = [ gshow hList1 - , gshow (children maybe2) - , gshow (transform (const "abc") []) - , gshow (transform double hList1) - , gshow (geq hList1 hList1) - , gshow (geq maybe1 maybe2) - , gshow (take 5 (genum :: [Maybe Int])) - , gshow (take 15 (genum :: [[Int]])) - , gshow (range ([0], [1::Int])) - , gshow (inRange ([0], [3,5::Int]) hList1) ] - --------------------------------------------------------------------------------- --- Example: trees of integers (kind *) --------------------------------------------------------------------------------- - -data Tree = Empty | Branch Int Tree Tree - -#if __GLASGOW_HASKELL__ >= 701 - -deriving instance Generic Tree - -instance GShow Tree -instance Uniplate Tree -instance GEnum Tree - -#else - -$(deriveAll ''Tree) - -instance GShow Tree where gshowsPrec = gshowsPrecdefault -instance Uniplate Tree where - children = childrendefault - context = contextdefault - descend = descenddefault - descendM = descendMdefault - transform = transformdefault - transformM = transformMdefault -instance GEnum Tree where genum = genumDefault - -#endif - -upgradeTree :: Tree -> Tree -upgradeTree Empty = Branch 0 Empty Empty -upgradeTree (Branch n l r) = Branch (succ n) l r - --- Example usage -tree = Branch 2 Empty (Branch 1 Empty Empty) -testsTree = [ gshow tree - , gshow (children tree) - , gshow (descend (descend (\_ -> Branch 0 Empty Empty)) tree) - , gshow (context tree [Branch 1 Empty Empty,Empty]) - , gshow (transform upgradeTree tree) - , gshow (take 10 (genum :: [Tree])) ] - --------------------------------------------------------------------------------- --- Example: lists (kind * -> *) --------------------------------------------------------------------------------- - -data List a = Nil | Cons a (List a) - -#if __GLASGOW_HASKELL__ >= 701 -deriving instance Generic (List a) -#else - -type Rep0List_ a = D1 List_ ((:+:) (C1 Nil_ U1) (C1 Cons_ ((:*:) (Par0 a) (Rec0 (List a))))) -instance Generic (List a) where - type Rep (List a) = Rep0List_ a - from Nil = M1 (L1 (M1 U1)) - from (Cons h t) = M1 (R1 (M1 ((:*:) (K1 h) (K1 t)))) - to (M1 (L1 (M1 U1))) = Nil - to (M1 (R1 (M1 (K1 h :*: K1 t)))) = Cons h t - -#endif - -#if __GLASGOW_HASKELL__ >= 705 -deriving instance Generic1 List -#else - -data List_ -data Nil_ -data Cons_ - -instance Datatype List_ where - datatypeName _ = "List" - moduleName _ = "Examples" - -instance Constructor Nil_ where conName _ = "Nil" -instance Constructor Cons_ where conName _ = "Cons" - -type Rep1List_ = D1 List_ ((:+:) (C1 Nil_ U1) (C1 Cons_ ((:*:) Par1 (Rec1 List)))) -instance Generic1 List where - type Rep1 List = Rep1List_ - from1 Nil = M1 (L1 (M1 U1)) - from1 (Cons h t) = M1 (R1 (M1 (Par1 h :*: Rec1 t))) - to1 (M1 (L1 (M1 U1))) = Nil - to1 (M1 (R1 (M1 (Par1 h :*: Rec1 t)))) = Cons h t - -#endif - -#if __GLASGOW_HASKELL__ < 701 --- Instance for generic functions (should be automatically generated) -instance GFunctor List where - gmap = gmapdefault - -instance (GShow a) => GShow (List a) where - gshowsPrec = gshowsPrecdefault - -instance (Uniplate a) => Uniplate (List a) where - children = childrendefault - context = contextdefault - descend = descenddefault - descendM = descendMdefault - transform = transformdefault - transformM = transformMdefault - -#else - -instance GFunctor List -instance (GShow a) => GShow (List a) -instance (Uniplate a) => Uniplate (List a) - -#endif - --- Example usage -list = Cons 'p' (Cons 'q' Nil) -listlist = Cons list (Cons Nil Nil) -- ["pq",""] - -testsList = [ gshow (gmap fromEnum list) - , gshow (gmap gshow listlist) - , gshow list - , gshow listlist - , gshow (children list) - , gshow (children listlist) ] - - --------------------------------------------------------------------------------- --- Example: Nested datatype, record selectors --------------------------------------------------------------------------------- - -data Nested a = Leaf | Nested { value :: a, rec :: Nested [a] } - deriving Functor - -#if __GLASGOW_HASKELL__ >= 701 -deriving instance Generic (Nested a) -#endif - -#if __GLASGOW_HASKELL__ < 705 -$(deriveMeta ''Nested) -#endif - -#if __GLASGOW_HASKELL__ < 701 -$(deriveRepresentable0 ''Nested) -#endif - -#if __GLASGOW_HASKELL__ >= 705 -deriving instance Generic1 Nested -#else -$(deriveRepresentable1 ''Nested) -#endif - -#if __GLASGOW_HASKELL__ < 701 --- Instance for gshow (should be automatically generated) -instance (GShow a) => GShow (Nested a) where - gshowsPrec = gshowsPrecdefault - -instance GFunctor Nested where - gmap = gmapdefault - -#else - -instance (GShow a) => GShow (Nested a) -instance GFunctor Nested - -#endif - --- Example usage -nested :: Nested Int -nested = Nested 1 (Nested [2] (Nested [[3],[4,5],[]] Leaf)) ---nested = Nested 1 (Nested (Nested 1 Leaf) Leaf) - - -testsNested = [ gshow nested - , gshow (gmap gshow nested) ] - --------------------------------------------------------------------------------- --- Example: Type composition --------------------------------------------------------------------------------- - -data Rose a = Rose [a] [Rose a] - -#if __GLASGOW_HASKELL__ >= 701 -deriving instance Generic (Rose a) -#else - -type Rep0Rose a = D1 RoseD (C1 RoseC (Rec0 [a] :*: Rec0 [Rose a])) -instance Generic (Rose a) where - type Rep (Rose a) = Rep0Rose a - from (Rose a x) = M1 (M1 (K1 a :*: K1 x)) - to (M1 (M1 (K1 a :*: K1 x))) = Rose a x - -#endif - -#if __GLASGOW_HASKELL__ >= 705 -deriving instance Generic1 Rose -#else - -data RoseD -data RoseC - -instance Datatype RoseD where - datatypeName _ = "Rose" - moduleName _ = "Examples" - -instance Constructor RoseC where conName _ = "Rose" - --- Generic1 instances -type RepRose = D1 RoseD (C1 RoseC (Rec1 [] :*: [] :.: Rec1 Rose)) -instance Generic1 Rose where - type Rep1 Rose = RepRose - from1 (Rose a x) = M1 (M1 (Rec1 a :*: Comp1 (gmap Rec1 x))) - to1 (M1 (M1 (Rec1 a :*: Comp1 x))) = Rose a (gmap unRec1 x) - -#endif - -#if __GLASGOW_HASKELL__ >= 701 - -instance (GShow a) => GShow (Rose a) -instance GFunctor Rose - -#else - --- Instance for gshow (should be automatically generated) -instance (GShow a) => GShow (Rose a) where - gshowsPrec = gshowsPrecdefault - -instance GFunctor Rose where - gmap = gmapdefault - -#endif - --- Example usage -rose1 :: Rose Int -rose1 = Rose [1,2] [Rose [3,4] [], Rose [5] []] - -testsRose = [ gshow rose1 - , gshow (gmap gshow rose1) ] - --------------------------------------------------------------------------------- --- Example: Higher-order kinded datatype, type composition --------------------------------------------------------------------------------- - -data GRose f a = GRose (f a) (f (GRose f a)) - -deriving instance (Functor f) => Functor (GRose f) - -#if __GLASGOW_HASKELL__ >= 701 -deriving instance Generic (GRose f a) -#endif - -#if __GLASGOW_HASKELL__ < 705 -$(deriveMeta ''GRose) -#endif - -#if __GLASGOW_HASKELL__ < 701 -$(deriveRepresentable0 ''GRose) -#endif - -#if __GLASGOW_HASKELL__ >= 705 -deriving instance (Functor f) => Generic1 (GRose f) -#else -$(deriveRep1 ''GRose) -instance (Functor f) => Generic1 (GRose f) where - type Rep1 (GRose f) = $(makeRep1 ''GRose) f - from1 = $(makeFrom1 ''GRose) - to1 = $(makeTo1 ''GRose) -#endif - -#if __GLASGOW_HASKELL__ < 701 --- Requires UndecidableInstances -instance (GShow (f a), GShow (f (GRose f a))) => GShow (GRose f a) where - gshowsPrec = gshowsPrecdefault - -instance (Functor f, GFunctor f) => GFunctor (GRose f) where - gmap = gmapdefault - -#else - -instance (GShow (f a), GShow (f (GRose f a))) => GShow (GRose f a) -instance (Functor f, GFunctor f) => GFunctor (GRose f) - -#endif - --- Example usage -grose1 :: GRose [] Int -grose1 = GRose [1,2] [GRose [3] [], GRose [] []] - -testsGRose = [ gshow grose1 - , gshow (gmap gshow grose1) ] - --------------------------------------------------------------------------------- --- Example: NGRose (minimal) --------------------------------------------------------------------------------- - --- Cannot represent because of nesting on an argument other than the parameter -{- -data NGRose f a = NGNode a (f (NGRose (Comp f f) a)) -data Comp f g a = Comp (f (g a)) - -type Rep0NGRose f a = Par0 a :*: Rec0 (f (NGRose (Comp f f) a)) -instance Generic (NGRose f a) (Rep0NGRose f a) where - from (NGNode a x) = K1 a :*: K1 x - to (K1 a :*: K1 x) = NGNode a x - -type Rep0Comp f g a = Rec0 (f (g a)) -instance Generic (Comp f g a) (Rep0Comp f g a) where - from (Comp x) = K1 x - to (K1 x) = Comp x - -type Rep1Comp f g = f :.: Rec1 g -instance (GFunctor f) => Generic1 (Comp f g) (Rep1Comp f g) where - from1 (Comp x) = Comp1 (gmap Rec1 x) - to1 (Comp1 x) = Comp (gmap unRec1 x) - -type Rep1NGRose f = Par1 :*: f :.: Rec1 (NGRose (Comp f f)) -instance (GFunctor f) => Generic1 (NGRose f) (Rep1NGRose f) where - from1 (NGNode a x) = Par1 a :*: (Comp1 (gmap Rec1 x)) - to1 (Par1 a :*: Comp1 x) = NGNode a (gmap unRec1 x) - -instance (GShow a, GShow (f (NGRose (Comp f f) a))) => GShow (NGRose f a) where - gshowsPrec = t undefined where - t :: (GShow a, GShow (f (NGRose (Comp f f) a))) => Rep0NGRose f a x -> NGRose f a -> ShowS - t = gshowsPrecdefault - -instance (GShow a) => GShow (Comp f g a) where - gshowsPrec = t undefined where - t :: (GShow a) => Rep0Comp f g a x -> Comp f g a -> ShowS - t = gshowsPrecdefault - -instance (GFunctor f, GFunctor (Comp f f)) => GFunctor (NGRose f) where - gmap = t undefined where - t :: (GFunctor f, GFunctor (Comp f f)) => Rep1NGRose f a -> (a -> b) -> NGRose f a -> NGRose f b - t = gmapdefault - -ngrose1 :: NGRose [] Int -ngrose1 = NGNode 0 [ngrose2, ngrose2] - -ngrose2 :: NGRose (Comp [] []) Int -ngrose2 = NGNode 1 (Comp []) - -testsNGRose = [ gshow ngrose1 - , gshow (gmap gshow ngrose1) ] --} - --------------------------------------------------------------------------------- --- Example: Double type composition (minimal) --------------------------------------------------------------------------------- - --- Add this to EHC -unComp (Comp1 x) = x - -data Weird a = Weird [[[a]]] deriving Show - -type Rep1Weird = [] :.: [] :.: Rec1 [] -instance Generic1 Weird where - type Rep1 Weird = Rep1Weird - from1 (Weird x) = Comp1 (gmap (Comp1 . gmap Rec1) x) - to1 (Comp1 x) = Weird (gmap (gmap unRec1 . unComp) x) - -#if __GLASGOW_HASKELL__ >= 701 - -instance GFunctor Weird - -#else - -instance GFunctor Weird where - gmap = gmapdefault - -#endif - --------------------------------------------------------------------------------- --- Example: Nested datatype Bush (minimal) --------------------------------------------------------------------------------- - -data Bush a = BushNil | BushCons a (Bush (Bush a)) deriving Functor - -#if __GLASGOW_HASKELL__ >= 701 -deriving instance Generic (Bush a) -#endif - -#if __GLASGOW_HASKELL__ < 705 -$(deriveMeta ''Bush) -#endif - -#if __GLASGOW_HASKELL__ < 701 -$(deriveRepresentable0 ''Bush) -#endif - -#if __GLASGOW_HASKELL__ >= 705 -deriving instance Generic1 Bush -#else -$(deriveRepresentable1 ''Bush) -#endif - -#if __GLASGOW_HASKELL__ < 701 - -instance GFunctor Bush where - gmap = gmapdefault - -instance (GShow a) => GShow (Bush a) where - gshowsPrec = gshowsPrecdefault - -#else - -instance GFunctor Bush -instance (GShow a) => GShow (Bush a) - -#endif - --- Example usage -bush1 :: Bush Int -bush1 = BushCons 0 (BushCons (BushCons 1 BushNil) BushNil) - -testsBush = [ gshow bush1 - , gshow (gmap gshow bush1) ] - --------------------------------------------------------------------------------- --- Example: Two parameters, datatype constraint, nested on other parameter --------------------------------------------------------------------------------- - --- Any constraints on |b| mean we cannot generate the Generic1 instance --- Constraints on |a| are just propagated to Generic and generic --- function instances -data (Show a) => Either a b = Left (Either [a] b) | Right b - - --- Generic1 instances -type Rep0Either a b = Rec0 (Either [a] b) :+: Rec0 b -instance (Show a) => Generic (Either a b) where - type Rep (Either a b) = Rep0Either a b - from (Left a) = L1 (K1 a) - from (Right a) = R1 (K1 a) - to (L1 (K1 a)) = Left a - to (R1 (K1 a)) = Right a - -type RepEither a = Rec1 (Either [a]) :+: Par1 -instance (Show a) => Generic1 (Either a) where - type Rep1 (Either a) = RepEither a - from1 (Left a) = L1 (Rec1 a) - from1 (Right a) = R1 (Par1 a) - to1 (L1 (Rec1 a)) = Left a - to1 (R1 (Par1 a)) = Right a - - -#if __GLASGOW_HASKELL__ < 701 --- Instance for gshow (should be automatically generated) -instance (Show a, GShow a, GShow b) => GShow (Either a b) where - gshowsPrec = gshowsPrecdefault - -instance (Show a) => GFunctor (Either a) where - gmap = gmapdefault - -#else - -instance (Show a, GShow a, GShow b) => GShow (Either a b) -instance (Show a) => GFunctor (Either a) - -#endif - -either1 :: Either Int Char -either1 = Left either2 - -either2 :: Either [Int] Char -either2 = Right 'p' - -testsEither = [ gshow either1 - , gshow (gmap gshow either1) ] - --------------------------------------------------------------------------------- --- Main tests --------------------------------------------------------------------------------- - -main :: IO () -main = do - let p = putStrLn . ((++) "- ") . show - putStrLn "[] and Maybe tests:" - mapM_ p testsStandard - putStrLn "Tests for Tree:" - mapM_ p testsTree - putStrLn "\nTests for List:" - mapM_ p testsList - putStrLn "\nTests for Rose:" - mapM_ p testsRose - putStrLn "\nTests for GRose:" - mapM_ p testsGRose - putStrLn "\nTests for Either:" - mapM_ p testsEither - putStrLn "\nTests for Nested:" - mapM_ p testsNested - putStrLn "\nTests for Bush:" - mapM_ p testsBush +{-# LANGUAGE 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 diff --git a/examples/reference.out b/examples/reference.out index 2d47165..7c0aa59 100644 --- a/examples/reference.out +++ b/examples/reference.out @@ -1,46 +1,46 @@ -[] and Maybe tests: -- "[1,2,3,4,5,6,7,8,9,10]" -- "[]" -- "\"abc\"" -- "[1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,10,10]" -- "True" -- "False" -- "[Nothing,Just 0,Just -1,Just 1,Just -2]" -- "[[],[0],[0,0],[-1],[0,0,0],[-1,0],[1],[0,-1],[-1,0,0],[1,0],[-2],[0,0,0,0],[-1,-1],[1,0,0],[-2,0]]" -- "[[0],[0,0],[-1],[0,0,0],[-1,0]]" -- "False" -Tests for Tree: -- "Branch 2 Empty (Branch 1 Empty Empty)" -- "[Empty,Branch 1 Empty Empty]" -- "Branch 2 Empty (Branch 1 (Branch 0 Empty Empty) (Branch 0 Empty Empty))" -- "Branch 2 (Branch 1 Empty Empty) Empty" -- "Branch 3 (Branch 0 Empty Empty) (Branch 2 (Branch 0 Empty Empty) (Branch 0 Empty Empty))" -- "[Empty,Branch 0 Empty Empty,Branch 0 Empty (Branch 0 Empty Empty),Branch -1 Empty Empty,Branch 0 (Branch 0 Empty Empty) Empty,Branch -1 Empty (Branch 0 Empty Empty),Branch 1 Empty Empty,Branch 0 Empty (Branch 0 Empty (Branch 0 Empty Empty)),Branch -1 (Branch 0 Empty Empty) Empty,Branch 1 Empty (Branch 0 Empty Empty)]" - -Tests for List: -- "Cons 112 (Cons 113 Nil)" -- "Cons \"Cons 'p' (Cons 'q' Nil)\" (Cons \"Nil\" Nil)" -- "Cons 'p' (Cons 'q' Nil)" -- "Cons (Cons 'p' (Cons 'q' Nil)) (Cons Nil Nil)" -- "[Cons 'q' Nil]" -- "[Cons Nil Nil]" - -Tests for Rose: -- "Rose [1,2] [Rose [3,4] [],Rose [5] []]" -- "Rose [\"1\",\"2\"] [Rose [\"3\",\"4\"] [],Rose [\"5\"] []]" - -Tests for GRose: -- "GRose [1,2] [GRose [3] [],GRose [] []]" -- "GRose [\"1\",\"2\"] [GRose [\"3\"] [],GRose [] []]" - -Tests for Either: -- "'p'" -- "\"'p'\"" - -Tests for Nested: -- "Nested {value = 1, rec = Nested {value = [2], rec = Nested {value = [[3],[4,5],[]], rec = Leaf}}}" -- "Nested {value = \"1\", rec = Nested {value = [\"2\"], rec = Nested {value = [[\"3\"],[\"4\",\"5\"],[]], rec = Leaf}}}" - -Tests for Bush: -- "BushCons 0 (BushCons (BushCons 1 BushNil) BushNil)" -- "BushCons \"0\" (BushCons (BushCons \"1\" BushNil) BushNil)" +[] and Maybe tests: +- "[1,2,3,4,5,6,7,8,9,10]" +- "[]" +- "\"abc\"" +- "[1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,10,10]" +- "True" +- "False" +- "[Nothing,Just 0,Just -1,Just 1,Just -2]" +- "[[],[0],[0,0],[-1],[0,0,0],[-1,0],[1],[0,-1],[-1,0,0],[1,0],[-2],[0,0,0,0],[-1,-1],[1,0,0],[-2,0]]" +- "[[0],[0,0],[-1],[0,0,0],[-1,0]]" +- "False" +Tests for Tree: +- "Branch 2 Empty (Branch 1 Empty Empty)" +- "[Empty,Branch 1 Empty Empty]" +- "Branch 2 Empty (Branch 1 (Branch 0 Empty Empty) (Branch 0 Empty Empty))" +- "Branch 2 (Branch 1 Empty Empty) Empty" +- "Branch 3 (Branch 0 Empty Empty) (Branch 2 (Branch 0 Empty Empty) (Branch 0 Empty Empty))" +- "[Empty,Branch 0 Empty Empty,Branch 0 Empty (Branch 0 Empty Empty),Branch -1 Empty Empty,Branch 0 (Branch 0 Empty Empty) Empty,Branch -1 Empty (Branch 0 Empty Empty),Branch 1 Empty Empty,Branch 0 Empty (Branch 0 Empty (Branch 0 Empty Empty)),Branch -1 (Branch 0 Empty Empty) Empty,Branch 1 Empty (Branch 0 Empty Empty)]" + +Tests for List: +- "Cons 112 (Cons 113 Nil)" +- "Cons \"Cons 'p' (Cons 'q' Nil)\" (Cons \"Nil\" Nil)" +- "Cons 'p' (Cons 'q' Nil)" +- "Cons (Cons 'p' (Cons 'q' Nil)) (Cons Nil Nil)" +- "[Cons 'q' Nil]" +- "[Cons Nil Nil]" + +Tests for Rose: +- "Rose [1,2] [Rose [3,4] [],Rose [5] []]" +- "Rose [\"1\",\"2\"] [Rose [\"3\",\"4\"] [],Rose [\"5\"] []]" + +Tests for GRose: +- "GRose [1,2] [GRose [3] [],GRose [] []]" +- "GRose [\"1\",\"2\"] [GRose [\"3\"] [],GRose [] []]" + +Tests for Either: +- "'p'" +- "\"'p'\"" + +Tests for Nested: +- "Nested {value = 1, rec = Nested {value = [2], rec = Nested {value = [[3],[4,5],[]], rec = Leaf}}}" +- "Nested {value = \"1\", rec = Nested {value = [\"2\"], rec = Nested {value = [[\"3\"],[\"4\",\"5\"],[]], rec = Leaf}}}" + +Tests for Bush: +- "BushCons 0 (BushCons (BushCons 1 BushNil) BushNil)" +- "BushCons \"0\" (BushCons (BushCons \"1\" BushNil) BushNil)" diff --git a/misc/Tuples.hs b/misc/Tuples.hs index 73cf900..b47ee34 100644 --- a/misc/Tuples.hs +++ b/misc/Tuples.hs @@ -1,103 +1,103 @@ - -module Main where - -import Data.List (intersperse) -import System.Environment (getArgs) - - --------------------------------------------------------------------------------- --- Tuples --------------------------------------------------------------------------------- - -u, tab, newline, sp :: ShowS -u = showChar '_' -tab = showString " " -newline = showChar '\n' -sp = showChar ' ' -vars :: [ShowS] -vars = map ((showChar 'x' .) . shows) [1..] -paren :: ShowS -> ShowS -paren x = showChar '(' . x . showChar ')' -concatS :: [ShowS] -> ShowS -concatS = foldr (.) id - -tuple :: Int -> ShowS -tuple m = showChar '(' . showString (replicate (m-1) ',') . showChar ')' - -unlinesS :: [ShowS] -> ShowS -unlinesS = foldr1 (\a b -> a . newline . b) - -createDataDecls :: Int -> ShowS -createDataDecls m = let n = shows m - s = showString "data Tuple" - in s . n . u . newline . s . n . showChar 'C' . u - -dataInstance :: Int -> ShowS -dataInstance m = let n = shows m - l1 = showString "instance Datatype Tuple" - . n . u . showString " where" - l2 = tab . showString "datatypeName _ = \"" - . tuple m . showChar '"' - l3 = tab . showString "moduleName _ = \"Prelude\"" - in unlinesS [l1, l2, l3] - -conInstance :: Int -> ShowS -conInstance m = let n = shows m - in showString "instance Constructor Tuple" . n . u - . showString " where conName _ = \"" . tuple m . showChar '"' - --- x is 0 or 1 -pairPat, repName, rep, repInst, funs :: Int -> Int -> ShowS -pairPat x m = tuple m . sp . - (concatS $ intersperse sp (take (m - x) vars)) - -repName x m = showString "Rep" . shows x . showString "Tuple" . shows m . u - -rep x m = let n = shows m - v = take (m - x) vars - vs = concatS $ intersperse sp v - recs = concatS $ intersperse (showString " :*: ") $ - map (showString "Rec0 " .) v - last = showString $ if (x == 1) then " :*: Par1" else "" - body = recs . last - in showString "type " . repName x m . sp . vs - . showString " = D1 Tuple" . n . showString "_ (C1 Tuple" . n - . showString "C_ (S1 NoSelector (" . body . showString ")))" - -repInst x m = let n = shows m - y = shows x - vs = concatS $ intersperse sp (take (m - x) vars) - in showString "instance Representable" . y . sp - . paren (pairPat x m) . showString " (" . repName x m . sp - . vs . showString ") where" - . newline . funs x m - -funs x m = - let v = take (m - x) vars - recs = concatS $ intersperse (showString " :*: ") $ - map (showString "K1 " .) v - last = if (x == 1) then showString " :*: Par1 " . (vars !! (m-x)) - else showString "" - eq = showChar '=' - body = paren (showString "M1 (M1 (M1 (" . recs . last . showString ")))") - pat = paren (pairPat 0 m) - in tab . concatS (intersperse sp [showString "from" . shows x, pat, eq, body]) - . newline . - tab . concatS (intersperse sp [showString "to" . shows x, body, eq, pat]) - - -gen :: Int -> ShowS -gen m = concatS (intersperse (newline . newline) - [ createDataDecls m, dataInstance m, conInstance m - , rep 0 m, repInst 0 m, rep 1 m, repInst 1 m]) - -main :: IO () -main = do let r :: [String] -> Int - r (n:_) = read n - r _ = error "Integer argument missing" - com = showString "\n\n" - . concatS (map showChar (replicate 80 '-')) - . showString "\n\n" - a <- getArgs - (putStr . ($ "")) $ concatS $ - intersperse com [ gen m | m <- [2..(r a)]] + +module Main where + +import Data.List (intersperse) +import System.Environment (getArgs) + + +-------------------------------------------------------------------------------- +-- Tuples +-------------------------------------------------------------------------------- + +u, tab, newline, sp :: ShowS +u = showChar '_' +tab = showString " " +newline = showChar '\n' +sp = showChar ' ' +vars :: [ShowS] +vars = map ((showChar 'x' .) . shows) [1..] +paren :: ShowS -> ShowS +paren x = showChar '(' . x . showChar ')' +concatS :: [ShowS] -> ShowS +concatS = foldr (.) id + +tuple :: Int -> ShowS +tuple m = showChar '(' . showString (replicate (m-1) ',') . showChar ')' + +unlinesS :: [ShowS] -> ShowS +unlinesS = foldr1 (\a b -> a . newline . b) + +createDataDecls :: Int -> ShowS +createDataDecls m = let n = shows m + s = showString "data Tuple" + in s . n . u . newline . s . n . showChar 'C' . u + +dataInstance :: Int -> ShowS +dataInstance m = let n = shows m + l1 = showString "instance Datatype Tuple" + . n . u . showString " where" + l2 = tab . showString "datatypeName _ = \"" + . tuple m . showChar '"' + l3 = tab . showString "moduleName _ = \"Prelude\"" + in unlinesS [l1, l2, l3] + +conInstance :: Int -> ShowS +conInstance m = let n = shows m + in showString "instance Constructor Tuple" . n . u + . showString " where conName _ = \"" . tuple m . showChar '"' + +-- x is 0 or 1 +pairPat, repName, rep, repInst, funs :: Int -> Int -> ShowS +pairPat x m = tuple m . sp . + (concatS $ intersperse sp (take (m - x) vars)) + +repName x m = showString "Rep" . shows x . showString "Tuple" . shows m . u + +rep x m = let n = shows m + v = take (m - x) vars + vs = concatS $ intersperse sp v + recs = concatS $ intersperse (showString " :*: ") $ + map (showString "Rec0 " .) v + last = showString $ if (x == 1) then " :*: Par1" else "" + body = recs . last + in showString "type " . repName x m . sp . vs + . showString " = D1 Tuple" . n . showString "_ (C1 Tuple" . n + . showString "C_ (S1 NoSelector (" . body . showString ")))" + +repInst x m = let n = shows m + y = shows x + vs = concatS $ intersperse sp (take (m - x) vars) + in showString "instance Representable" . y . sp + . paren (pairPat x m) . showString " (" . repName x m . sp + . vs . showString ") where" + . newline . funs x m + +funs x m = + let v = take (m - x) vars + recs = concatS $ intersperse (showString " :*: ") $ + map (showString "K1 " .) v + last = if (x == 1) then showString " :*: Par1 " . (vars !! (m-x)) + else showString "" + eq = showChar '=' + body = paren (showString "M1 (M1 (M1 (" . recs . last . showString ")))") + pat = paren (pairPat 0 m) + in tab . concatS (intersperse sp [showString "from" . shows x, pat, eq, body]) + . newline . + tab . concatS (intersperse sp [showString "to" . shows x, body, eq, pat]) + + +gen :: Int -> ShowS +gen m = concatS (intersperse (newline . newline) + [ createDataDecls m, dataInstance m, conInstance m + , rep 0 m, repInst 0 m, rep 1 m, repInst 1 m]) + +main :: IO () +main = do let r :: [String] -> Int + r (n:_) = read n + r _ = error "Integer argument missing" + com = showString "\n\n" + . concatS (map showChar (replicate 80 '-')) + . showString "\n\n" + a <- getArgs + (putStr . ($ "")) $ concatS $ + intersperse com [ gen m | m <- [2..(r a)]] diff --git a/src/Generics/Deriving.hs b/src/Generics/Deriving.hs index aa459f3..b43db4d 100644 --- a/src/Generics/Deriving.hs +++ b/src/Generics/Deriving.hs @@ -1,22 +1,22 @@ - -module Generics.Deriving ( - - module Generics.Deriving.Base, - module Generics.Deriving.Copoint, - module Generics.Deriving.ConNames, - module Generics.Deriving.Enum, - module Generics.Deriving.Eq, - module Generics.Deriving.Functor, - module Generics.Deriving.Show, - module Generics.Deriving.Uniplate - - ) where - -import Generics.Deriving.Base -import Generics.Deriving.Copoint -import Generics.Deriving.ConNames -import Generics.Deriving.Enum -import Generics.Deriving.Eq -import Generics.Deriving.Functor -import Generics.Deriving.Show -import Generics.Deriving.Uniplate + +module Generics.Deriving ( + + module Generics.Deriving.Base, + module Generics.Deriving.Copoint, + module Generics.Deriving.ConNames, + module Generics.Deriving.Enum, + module Generics.Deriving.Eq, + module Generics.Deriving.Functor, + module Generics.Deriving.Show, + module Generics.Deriving.Uniplate + + ) where + +import Generics.Deriving.Base +import Generics.Deriving.Copoint +import Generics.Deriving.ConNames +import Generics.Deriving.Enum +import Generics.Deriving.Eq +import Generics.Deriving.Functor +import Generics.Deriving.Show +import Generics.Deriving.Uniplate diff --git a/src/Generics/Deriving/Base.hs b/src/Generics/Deriving/Base.hs index 0115d0a..53f56f3 100644 --- a/src/Generics/Deriving/Base.hs +++ b/src/Generics/Deriving/Base.hs @@ -1,802 +1,802 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} - -module Generics.Deriving.Base ( --- * Introduction --- --- | --- --- Datatype-generic functions are are based on the idea of converting values of --- a datatype @T@ into corresponding values of a (nearly) isomorphic type @'Rep' T@. --- The type @'Rep' T@ is --- built from a limited set of type constructors, all provided by this module. A --- datatype-generic function is then an overloaded function with instances --- for most of these type constructors, together with a wrapper that performs --- the mapping between @T@ and @'Rep' T@. By using this technique, we merely need --- a few generic instances in order to implement functionality that works for any --- representable type. --- --- Representable types are collected in the 'Generic' class, which defines the --- associated type 'Rep' as well as conversion functions 'from' and 'to'. --- Typically, you will not define 'Generic' instances by hand, but have the compiler --- derive them for you. - --- ** Representing datatypes --- --- | --- --- The key to defining your own datatype-generic functions is to understand how to --- represent datatypes using the given set of type constructors. --- --- Let us look at an example first: --- --- @ --- data Tree a = Leaf a | Node (Tree a) (Tree a) --- deriving 'Generic' --- @ --- --- The above declaration (which requires the language pragma @DeriveGeneric@) --- causes the following representation to be generated: --- --- @ --- class 'Generic' (Tree a) where --- type 'Rep' (Tree a) = --- 'D1' D1Tree --- ('C1' C1_0Tree --- ('S1' 'NoSelector' ('Par0' a)) --- ':+:' --- 'C1' C1_1Tree --- ('S1' 'NoSelector' ('Rec0' (Tree a)) --- ':*:' --- 'S1' 'NoSelector' ('Rec0' (Tree a)))) --- ... --- @ --- --- /Hint:/ You can obtain information about the code being generated from GHC by passing --- the @-ddump-deriv@ flag. In GHCi, you can expand a type family such as 'Rep' using --- the @:kind!@ command. --- -#if 0 --- /TODO:/ Newer GHC versions abandon the distinction between 'Par0' and 'Rec0' and will --- use 'Rec0' everywhere. --- -#endif --- This is a lot of information! However, most of it is actually merely meta-information --- that makes names of datatypes and constructors and more available on the type level. --- --- Here is a reduced representation for 'Tree' with nearly all meta-information removed, --- for now keeping only the most essential aspects: --- --- @ --- instance 'Generic' (Tree a) where --- type 'Rep' (Tree a) = --- 'Par0' a --- ':+:' --- ('Rec0' (Tree a) ':*:' 'Rec0' (Tree a)) --- @ --- --- The @Tree@ datatype has two constructors. The representation of individual constructors --- is combined using the binary type constructor ':+:'. --- --- The first constructor consists of a single field, which is the parameter @a@. This is --- represented as @'Par0' a@. --- --- The second constructor consists of two fields. Each is a recursive field of type @Tree a@, --- represented as @'Rec0' (Tree a)@. Representations of individual fields are combined using --- the binary type constructor ':*:'. --- --- Now let us explain the additional tags being used in the complete representation: --- --- * The @'S1' 'NoSelector'@ indicates that there is no record field selector associated with --- this field of the constructor. --- --- * The @'C1' C1_0Tree@ and @'C1' C1_1Tree@ invocations indicate that the enclosed part is --- the representation of the first and second constructor of datatype @Tree@, respectively. --- Here, @C1_0Tree@ and @C1_1Tree@ are datatypes generated by the compiler as part of --- @deriving 'Generic'@. These datatypes are proxy types with no values. They are useful --- because they are instances of the type class 'Constructor'. This type class can be used --- to obtain information about the constructor in question, such as its name --- or infix priority. --- --- * The @'D1' D1Tree@ tag indicates that the enclosed part is the representation of the --- datatype @Tree@. Again, @D1Tree@ is a datatype generated by the compiler. It is a --- proxy type, and is useful by being an instance of class 'Datatype', which --- can be used to obtain the name of a datatype, the module it has been defined in, and --- whether it has been defined using @data@ or @newtype@. - --- ** Derived and fundamental representation types --- --- | --- --- There are many datatype-generic functions that do not distinguish between positions that --- are parameters or positions that are recursive calls. There are also many datatype-generic --- functions that do not care about the names of datatypes and constructors at all. To keep --- the number of cases to consider in generic functions in such a situation to a minimum, --- it turns out that many of the type constructors introduced above are actually synonyms, --- defining them to be variants of a smaller set of constructors. - --- *** Individual fields of constructors: 'K1' --- --- | --- --- The type constructors 'Par0' and 'Rec0' are variants of 'K1': --- --- @ --- type 'Par0' = 'K1' 'P' --- type 'Rec0' = 'K1' 'R' --- @ --- --- Here, 'P' and 'R' are type-level proxies again that do not have any associated values. - --- *** Meta information: 'M1' --- --- | --- --- The type constructors 'S1', 'C1' and 'D1' are all variants of 'M1': --- --- @ --- type 'S1' = 'M1' 'S' --- type 'C1' = 'M1' 'C' --- type 'D1' = 'M1' 'D' --- @ --- --- The types 'S', 'C' and 'R' are once again type-level proxies, just used to create --- several variants of 'M1'. - --- *** Additional generic representation type constructors --- --- | --- --- Next to 'K1', 'M1', ':+:' and ':*:' there are a few more type constructors that occur --- in the representations of other datatypes. - --- **** Empty datatypes: 'V1' --- --- | --- --- For empty datatypes, 'V1' is used as a representation. For example, --- --- @ --- data Empty deriving 'Generic' --- @ --- --- yields --- --- @ --- instance 'Generic' Empty where --- type 'Rep' Empty = 'D1' D1Empty 'V1' --- @ - --- **** Constructors without fields: 'U1' --- --- | --- --- If a constructor has no arguments, then 'U1' is used as its representation. For example --- the representation of 'Bool' is --- --- @ --- instance 'Generic' Bool where --- type 'Rep' Bool = --- 'D1' D1Bool --- ('C1' C1_0Bool 'U1' ':+:' 'C1' C1_1Bool 'U1') --- @ - --- *** Representation of types with many constructors or many fields --- --- | --- --- As ':+:' and ':*:' are just binary operators, one might ask what happens if the --- datatype has more than two constructors, or a constructor with more than two --- fields. The answer is simple: the operators are used several times, to combine --- all the constructors and fields as needed. However, users /should not rely on --- a specific nesting strategy/ for ':+:' and ':*:' being used. The compiler is --- free to choose any nesting it prefers. (In practice, the current implementation --- tries to produce a more or less balanced nesting, so that the traversal of the --- structure of the datatype from the root to a particular component can be performed --- in logarithmic rather than linear time.) - --- ** Defining datatype-generic functions --- --- | --- --- A datatype-generic function comprises two parts: --- --- 1. /Generic instances/ for the function, implementing it for most of the representation --- type constructors introduced above. --- --- 2. A /wrapper/ that for any datatype that is in `Generic`, performs the conversion --- between the original value and its `Rep`-based representation and then invokes the --- generic instances. --- --- As an example, let us look at a function 'encode' that produces a naive, but lossless --- bit encoding of values of various datatypes. So we are aiming to define a function --- --- @ --- encode :: 'Generic' a => a -> [Bool] --- @ --- --- where we use 'Bool' as our datatype for bits. --- --- For part 1, we define a class @Encode'@. Perhaps surprisingly, this class is parameterized --- over a type constructor @f@ of kind @* -> *@. This is a technicality: all the representation --- type constructors operate with kind @* -> *@ as base kind. But the type argument is never --- being used. This may be changed at some point in the future. The class has a single method, --- and we use the type we want our final function to have, but we replace the occurrences of --- the generic type argument @a@ with @f p@ (where the @p@ is any argument; it will not be used). --- --- > class Encode' f where --- > encode' :: f p -> [Bool] --- --- With the goal in mind to make @encode@ work on @Tree@ and other datatypes, we now define --- instances for the representation type constructors 'V1', 'U1', ':+:', ':*:', 'K1', and 'M1'. - --- *** Definition of the generic representation types --- --- | --- --- In order to be able to do this, we need to know the actual definitions of these types: --- --- @ --- data 'V1' p -- lifted version of Empty --- data 'U1' p = 'U1' -- lifted version of () --- data (':+:') f g p = 'L1' (f p) | 'R1' (g p) -- lifted version of 'Either' --- data (':*:') f g p = (f p) ':*:' (g p) -- lifted version of (,) --- newtype 'K1' i c p = 'K1' { 'unK1' :: c } -- a container for a c --- newtype 'M1' i t f p = 'M1' { 'unM1' :: f p } -- a wrapper --- @ --- --- So, 'U1' is just the unit type, ':+:' is just a binary choice like 'Either', --- ':*:' is a binary pair like the pair constructor @(,)@, and 'K1' is a value --- of a specific type @c@, and 'M1' wraps a value of the generic type argument, --- which in the lifted world is an @f p@ (where we do not care about @p@). - --- *** Generic instances --- --- | --- --- The instance for 'V1' is slightly awkward (but also rarely used): --- --- @ --- instance Encode' 'V1' where --- encode' x = undefined --- @ --- --- There are no values of type @V1 p@ to pass (except undefined), so this is --- actually impossible. One can ask why it is useful to define an instance for --- 'V1' at all in this case? Well, an empty type can be used as an argument to --- a non-empty type, and you might still want to encode the resulting type. --- As a somewhat contrived example, consider @[Empty]@, which is not an empty --- type, but contains just the empty list. The 'V1' instance ensures that we --- can call the generic function on such types. --- --- There is exactly one value of type 'U1', so encoding it requires no --- knowledge, and we can use zero bits: --- --- @ --- instance Encode' 'U1' where --- encode' 'U1' = [] --- @ --- --- In the case for ':+:', we produce 'False' or 'True' depending on whether --- the constructor of the value provided is located on the left or on the right: --- --- @ --- instance (Encode' f, Encode' g) => Encode' (f ':+:' g) where --- encode' ('L1' x) = False : encode' x --- encode' ('R1' x) = True : encode' x --- @ --- --- In the case for ':*:', we append the encodings of the two subcomponents: --- --- @ --- instance (Encode' f, Encode' g) => Encode' (f ':*:' g) where --- encode' (x ':*:' y) = encode' x ++ encode' y --- @ --- --- The case for 'K1' is rather interesting. Here, we call the final function --- 'encode' that we yet have to define, recursively. We will use another type --- class 'Encode' for that function: --- --- @ --- instance (Encode c) => Encode' ('K1' i c) where --- encode' ('K1' x) = encode x --- @ --- --- Note how 'Par0' and 'Rec0' both being mapped to 'K1' allows us to define --- a uniform instance here. --- --- Similarly, we can define a uniform instance for 'M1', because we completely --- disregard all meta-information: --- --- @ --- instance (Encode' f) => Encode' ('M1' i t f) where --- encode' ('M1' x) = encode' x --- @ --- --- Unlike in 'K1', the instance for 'M1' refers to 'encode'', not 'encode'. - --- *** The wrapper and generic default --- --- | --- --- We now define class 'Encode' for the actual 'encode' function: --- --- @ --- class Encode a where --- encode :: a -> [Bool] --- default encode :: ('Generic' a) => a -> [Bool] --- encode x = encode' ('from' x) --- @ --- --- The incoming 'x' is converted using 'from', then we dispatch to the --- generic instances using 'encode''. We use this as a default definition --- for 'encode'. We need the 'default encode' signature because ordinary --- Haskell default methods must not introduce additional class constraints, --- but our generic default does. --- --- Defining a particular instance is now as simple as saying --- --- @ --- instance (Encode a) => Encode (Tree a) --- @ --- -#if 0 --- /TODO:/ Add usage example? --- -#endif --- The generic default is being used. In the future, it will hopefully be --- possible to use @deriving Encode@ as well, but GHC does not yet support --- that syntax for this situation. --- --- Having 'Encode' as a class has the advantage that we can define --- non-generic special cases, which is particularly useful for abstract --- datatypes that have no structural representation. For example, given --- a suitable integer encoding function 'encodeInt', we can define --- --- @ --- instance Encode Int where --- encode = encodeInt --- @ - --- *** Omitting generic instances --- --- | --- --- It is not always required to provide instances for all the generic --- representation types, but omitting instances restricts the set of --- datatypes the functions will work for: --- --- * If no ':+:' instance is given, the function may still work for --- empty datatypes or datatypes that have a single constructor, --- but will fail on datatypes with more than one constructor. --- --- * If no ':*:' instance is given, the function may still work for --- datatypes where each constructor has just zero or one field, --- in particular for enumeration types. --- --- * If no 'K1' instance is given, the function may still work for --- enumeration types, where no constructor has any fields. --- --- * If no 'V1' instance is given, the function may still work for --- any datatype that is not empty. --- --- * If no 'U1' instance is given, the function may still work for --- any datatype where each constructor has at least one field. --- --- An 'M1' instance is always required (but it can just ignore the --- meta-information, as is the case for 'encode' above). -#if 0 --- *** Using meta-information --- --- | --- --- TODO -#endif --- ** Generic constructor classes --- --- | --- --- Datatype-generic functions as defined above work for a large class --- of datatypes, including parameterized datatypes. (We have used 'Tree' --- as our example above, which is of kind @* -> *@.) However, the --- 'Generic' class ranges over types of kind @*@, and therefore, the --- resulting generic functions (such as 'encode') must be parameterized --- by a generic type argument of kind @*@. --- --- What if we want to define generic classes that range over type --- constructors (such as 'Functor', 'Traversable', or 'Foldable')? - --- *** The 'Generic1' class --- --- | --- --- Like 'Generic', there is a class 'Generic1' that defines a --- representation 'Rep1' and conversion functions 'from1' and 'to1', --- only that 'Generic1' ranges over types of kind @* -> *@. --- The 'Generic1' class is also derivable. --- --- The representation 'Rep1' is ever so slightly different from 'Rep'. --- Let us look at 'Tree' as an example again: --- --- @ --- data Tree a = Leaf a | Node (Tree a) (Tree a) --- deriving 'Generic1' --- @ --- --- The above declaration causes the following representation to be generated: --- --- class 'Generic1' Tree where --- type 'Rep1' Tree = --- 'D1' D1Tree --- ('C1' C1_0Tree --- ('S1' 'NoSelector' 'Par1') --- ':+:' --- 'C1' C1_1Tree --- ('S1' 'NoSelector' ('Rec1' Tree) --- ':*:' --- 'S1' 'NoSelector' ('Rec1' Tree))) --- ... --- --- The representation reuses 'D1', 'C1', 'S1' (and thereby 'M1') as well --- as ':+:' and ':*:' from 'Rep'. (This reusability is the reason that we --- carry around the dummy type argument for kind-@*@-types, but there are --- already enough different names involved without duplicating each of --- these.) --- --- What's different is that we now use 'Par1' to refer to the parameter --- (and that parameter, which used to be @a@), is not mentioned explicitly --- by name anywhere; and we use 'Rec1' to refer to a recursive use of @Tree a@. - --- *** Representation of @* -> *@ types --- --- | --- --- Unlike 'Par0' and 'Rec0', the 'Par1' and 'Rec1' type constructors do not --- map to 'K1'. They are defined directly, as follows: --- --- @ --- newtype 'Par1' p = 'Par1' { 'unPar1' :: p } -- gives access to parameter p --- newtype 'Rec1' f p = 'Rec1' { 'unRec1' :: f p } -- a wrapper --- @ --- --- In 'Par1', the parameter @p@ is used for the first time, whereas 'Rec1' simply --- wraps an application of @f@ to @p@. --- --- Note that 'K1' (in the guise of 'Rec0') can still occur in a 'Rep1' representation, --- namely when the datatype has a field that does not mention the parameter. --- --- The declaration --- --- @ --- data WithInt a = WithInt Int a --- deriving 'Generic1' --- @ --- --- yields --- --- @ --- class 'Rep1' WithInt where --- type 'Rep1' WithInt = --- 'D1' D1WithInt --- ('C1' C1_0WithInt --- ('S1' 'NoSelector' ('Rec0' Int) --- ':*:' --- 'S1' 'NoSelector' 'Par1')) --- @ --- --- If the parameter @a@ appears underneath a composition of other type constructors, --- then the representation involves composition, too: --- --- @ --- data Rose a = Fork a [Rose a] --- @ --- --- yields --- --- @ --- class 'Rep1' Rose where --- type 'Rep1' Rose = --- 'D1' D1Rose --- ('C1' C1_0Rose --- ('S1' 'NoSelector' 'Par1' --- ':*:' --- 'S1' 'NoSelector' ([] ':.:' 'Rec1' Rose) --- @ --- --- where --- --- @ --- newtype (':.:') f g p = 'Comp1' { 'unComp1' :: f (g p) } --- @ - --- *** Representation of unlifted types --- --- | --- --- If one were to attempt to derive a Generic instance for a datatype with an --- unlifted argument (for example, 'Int#'), one might expect the occurrence of --- the 'Int#' argument to be marked with @'Rec0' 'Int#'@. This won't work, --- though, since 'Int#' is of kind @#@ and 'Rec0' expects a type of kind @*@. --- In fact, polymorphism over unlifted types is disallowed completely. --- --- One solution would be to represent an occurrence of 'Int#' with 'Rec0 Int' --- instead. With this approach, however, the programmer has no way of knowing --- whether the 'Int' is actually an 'Int#' in disguise. --- --- Instead of reusing 'Rec0', a separate data family 'URec' is used to mark --- occurrences of common unlifted types: --- --- @ --- data family URec a p --- --- data instance 'URec' ('Ptr' ()) p = 'UAddr' { 'uAddr#' :: 'Addr#' } --- data instance 'URec' 'Char' p = 'UChar' { 'uChar#' :: 'Char#' } --- data instance 'URec' 'Double' p = 'UDouble' { 'uDouble#' :: 'Double#' } --- data instance 'URec' 'Int' p = 'UFloat' { 'uFloat#' :: 'Float#' } --- data instance 'URec' 'Float' p = 'UInt' { 'uInt#' :: 'Int#' } --- data instance 'URec' 'Word' p = 'UWord' { 'uWord#' :: 'Word#' } --- @ --- --- Several type synonyms are provided for convenience: --- --- @ --- type 'UAddr' = 'URec' ('Ptr' ()) --- type 'UChar' = 'URec' 'Char' --- type 'UDouble' = 'URec' 'Double' --- type 'UFloat' = 'URec' 'Float' --- type 'UInt' = 'URec' 'Int' --- type 'UWord' = 'URec' 'Word' --- @ --- --- The declaration --- --- @ --- data IntHash = IntHash Int# --- deriving 'Generic' --- @ --- --- yields --- --- @ --- instance 'Generic' IntHash where --- type 'Rep' IntHash = --- 'D1' D1IntHash --- ('C1' C1_0IntHash --- ('S1' 'NoSelector' 'UInt')) --- @ --- --- Currently, only the six unlifted types listed above are generated, but this --- may be extended to encompass more unlifted types in the future. -#if 0 --- *** Limitations --- --- | --- --- /TODO/ --- --- /TODO:/ Also clear up confusion about 'Rec0' and 'Rec1' not really indicating recursion. --- -#endif -#if __GLASGOW_HASKELL__ < 701 - -- * Generic representation types - V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..) - , (:+:)(..), (:*:)(..), (:.:)(..) - - -- ** Synonyms for convenience - , Rec0, Par0, R, P - , D1, C1, S1, D, C, S - - -- * Meta-information - , Datatype(..), Constructor(..), Selector(..), NoSelector - , Fixity(..), Associativity(..), Arity(..), prec - - -- * Generic type classes - , Generic(..), Generic1(..), - -#else - module GHC.Generics, -#endif -#if __GLASGOW_HASKELL__ < 711 - -- ** Unboxed representation types - URec(..), UAddr, UChar, UDouble, UFloat, UInt, UWord -#endif - ) where - - -#if __GLASGOW_HASKELL__ >= 701 -import GHC.Generics -#endif - -#if __GLASGOW_HASKELL__ < 709 -import Data.Word ( Word ) -#endif - -#if __GLASGOW_HASKELL__ < 711 -import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# ) -import GHC.Ptr ( Ptr ) -#endif - -#if __GLASGOW_HASKELL__ < 701 --------------------------------------------------------------------------------- --- Representation types --------------------------------------------------------------------------------- - --- | Void: used for datatypes without constructors -data V1 p - --- | Unit: used for constructors without arguments -data U1 p = U1 - deriving (Eq, Ord, Read, Show) - --- | Used for marking occurrences of the parameter -newtype Par1 p = Par1 { unPar1 :: p } - deriving (Eq, Ord, Read, Show) - --- | Recursive calls of kind * -> * -newtype Rec1 f p = Rec1 { unRec1 :: f p } - deriving (Eq, Ord, Read, Show) - --- | Constants, additional parameters and recursion of kind * -newtype K1 i c p = K1 { unK1 :: c } - deriving (Eq, Ord, Read, Show) - --- | Meta-information (constructor names, etc.) -newtype M1 i c f p = M1 { unM1 :: f p } - deriving (Eq, Ord, Read, Show) - --- | Sums: encode choice between constructors -infixr 5 :+: -data (:+:) f g p = L1 (f p) | R1 (g p) - deriving (Eq, Ord, Read, Show) - --- | Products: encode multiple arguments to constructors -infixr 6 :*: -data (:*:) f g p = f p :*: g p - deriving (Eq, Ord, Read, Show) - --- | Composition of functors -infixr 7 :.: -newtype (:.:) f g p = Comp1 { unComp1 :: f (g p) } - deriving (Eq, Ord, Read, Show) --- | Tag for K1: recursion (of kind *) -data R --- | Tag for K1: parameters (other than the last) -data P - --- | Type synonym for encoding recursion (of kind *) -type Rec0 = K1 R --- | Type synonym for encoding parameters (other than the last) -type Par0 = K1 P - --- | Tag for M1: datatype -data D --- | Tag for M1: constructor -data C --- | Tag for M1: record selector -data S - --- | Type synonym for encoding meta-information for datatypes -type D1 = M1 D - --- | Type synonym for encoding meta-information for constructors -type C1 = M1 C - --- | Type synonym for encoding meta-information for record selectors -type S1 = M1 S - --- | Class for datatypes that represent datatypes -class Datatype d where - -- | The name of the datatype, fully qualified - datatypeName :: t d (f :: * -> *) a -> String - moduleName :: t d (f :: * -> *) a -> String - --- | Class for datatypes that represent records -class Selector s where - -- | The name of the selector - selName :: t s (f :: * -> *) a -> String - --- | Used for constructor fields without a name -data NoSelector - -instance Selector NoSelector where selName _ = "" - --- | Class for datatypes that represent data constructors -class Constructor c where - -- | The name of the constructor - conName :: t c (f :: * -> *) a -> String - - -- | The fixity of the constructor - conFixity :: t c (f :: * -> *) a -> Fixity - conFixity = const Prefix - - -- | Marks if this constructor is a record - conIsRecord :: t c (f :: * -> *) a -> Bool - conIsRecord = const False - - --- | Datatype to represent the arity of a tuple. -data Arity = NoArity | Arity Int - deriving (Eq, Show, Ord, Read) - --- | Datatype to represent the fixity of a constructor. An infix --- | declaration directly corresponds to an application of 'Infix'. -data Fixity = Prefix | Infix Associativity Int - deriving (Eq, Show, Ord, Read) - --- | Get the precedence of a fixity value. -prec :: Fixity -> Int -prec Prefix = 10 -prec (Infix _ n) = n - --- | Datatype to represent the associativy of a constructor -data Associativity = LeftAssociative - | RightAssociative - | NotAssociative - deriving (Eq, Show, Ord, Read) - --- | Representable types of kind * -class Generic a where - type Rep a :: * -> * - -- | Convert from the datatype to its representation - from :: a -> Rep a x - -- | Convert from the representation to the datatype - to :: Rep a x -> a - --- | Representable types of kind * -> * -class Generic1 f where - type Rep1 f :: * -> * - -- | Convert from the datatype to its representation - from1 :: f a -> Rep1 f a - -- | Convert from the representation to the datatype - to1 :: Rep1 f a -> f a - -#endif - -#if __GLASGOW_HASKELL__ < 711 --- | Constants of kind @#@ -data family URec (a :: *) (p :: *) - --- | Used for marking occurrences of 'Addr#' -data instance URec (Ptr ()) p = UAddr { uAddr# :: Addr# } - deriving (Eq, Ord) - --- | Used for marking occurrences of 'Char#' -data instance URec Char p = UChar { uChar# :: Char# } - deriving (Eq, Ord, Show) - --- | Used for marking occurrences of 'Double#' -data instance URec Double p = UDouble { uDouble# :: Double# } - deriving (Eq, Ord, Show) - --- | Used for marking occurrences of 'Float#' -data instance URec Float p = UFloat { uFloat# :: Float# } - deriving (Eq, Ord, Show) - --- | Used for marking occurrences of 'Int#' -data instance URec Int p = UInt { uInt# :: Int# } - deriving (Eq, Ord, Show) - --- | Used for marking occurrences of 'Word#' -data instance URec Word p = UWord { uWord# :: Word# } - deriving (Eq, Ord, Show) - --- | Type synonym for 'URec': 'Addr#' -type UAddr = URec (Ptr ()) --- | Type synonym for 'URec': 'Char#' -type UChar = URec Char --- | Type synonym for 'URec': 'Double#' -type UDouble = URec Double --- | Type synonym for 'URec': 'Float#' -type UFloat = URec Float --- | Type synonym for 'URec': 'Int#' -type UInt = URec Int --- | Type synonym for 'URec': 'Word#' -type UWord = URec Word -#endif +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Generics.Deriving.Base ( +-- * Introduction +-- +-- | +-- +-- Datatype-generic functions are are based on the idea of converting values of +-- a datatype @T@ into corresponding values of a (nearly) isomorphic type @'Rep' T@. +-- The type @'Rep' T@ is +-- built from a limited set of type constructors, all provided by this module. A +-- datatype-generic function is then an overloaded function with instances +-- for most of these type constructors, together with a wrapper that performs +-- the mapping between @T@ and @'Rep' T@. By using this technique, we merely need +-- a few generic instances in order to implement functionality that works for any +-- representable type. +-- +-- Representable types are collected in the 'Generic' class, which defines the +-- associated type 'Rep' as well as conversion functions 'from' and 'to'. +-- Typically, you will not define 'Generic' instances by hand, but have the compiler +-- derive them for you. + +-- ** Representing datatypes +-- +-- | +-- +-- The key to defining your own datatype-generic functions is to understand how to +-- represent datatypes using the given set of type constructors. +-- +-- Let us look at an example first: +-- +-- @ +-- data Tree a = Leaf a | Node (Tree a) (Tree a) +-- deriving 'Generic' +-- @ +-- +-- The above declaration (which requires the language pragma @DeriveGeneric@) +-- causes the following representation to be generated: +-- +-- @ +-- class 'Generic' (Tree a) where +-- type 'Rep' (Tree a) = +-- 'D1' D1Tree +-- ('C1' C1_0Tree +-- ('S1' 'NoSelector' ('Par0' a)) +-- ':+:' +-- 'C1' C1_1Tree +-- ('S1' 'NoSelector' ('Rec0' (Tree a)) +-- ':*:' +-- 'S1' 'NoSelector' ('Rec0' (Tree a)))) +-- ... +-- @ +-- +-- /Hint:/ You can obtain information about the code being generated from GHC by passing +-- the @-ddump-deriv@ flag. In GHCi, you can expand a type family such as 'Rep' using +-- the @:kind!@ command. +-- +#if 0 +-- /TODO:/ Newer GHC versions abandon the distinction between 'Par0' and 'Rec0' and will +-- use 'Rec0' everywhere. +-- +#endif +-- This is a lot of information! However, most of it is actually merely meta-information +-- that makes names of datatypes and constructors and more available on the type level. +-- +-- Here is a reduced representation for 'Tree' with nearly all meta-information removed, +-- for now keeping only the most essential aspects: +-- +-- @ +-- instance 'Generic' (Tree a) where +-- type 'Rep' (Tree a) = +-- 'Par0' a +-- ':+:' +-- ('Rec0' (Tree a) ':*:' 'Rec0' (Tree a)) +-- @ +-- +-- The @Tree@ datatype has two constructors. The representation of individual constructors +-- is combined using the binary type constructor ':+:'. +-- +-- The first constructor consists of a single field, which is the parameter @a@. This is +-- represented as @'Par0' a@. +-- +-- The second constructor consists of two fields. Each is a recursive field of type @Tree a@, +-- represented as @'Rec0' (Tree a)@. Representations of individual fields are combined using +-- the binary type constructor ':*:'. +-- +-- Now let us explain the additional tags being used in the complete representation: +-- +-- * The @'S1' 'NoSelector'@ indicates that there is no record field selector associated with +-- this field of the constructor. +-- +-- * The @'C1' C1_0Tree@ and @'C1' C1_1Tree@ invocations indicate that the enclosed part is +-- the representation of the first and second constructor of datatype @Tree@, respectively. +-- Here, @C1_0Tree@ and @C1_1Tree@ are datatypes generated by the compiler as part of +-- @deriving 'Generic'@. These datatypes are proxy types with no values. They are useful +-- because they are instances of the type class 'Constructor'. This type class can be used +-- to obtain information about the constructor in question, such as its name +-- or infix priority. +-- +-- * The @'D1' D1Tree@ tag indicates that the enclosed part is the representation of the +-- datatype @Tree@. Again, @D1Tree@ is a datatype generated by the compiler. It is a +-- proxy type, and is useful by being an instance of class 'Datatype', which +-- can be used to obtain the name of a datatype, the module it has been defined in, and +-- whether it has been defined using @data@ or @newtype@. + +-- ** Derived and fundamental representation types +-- +-- | +-- +-- There are many datatype-generic functions that do not distinguish between positions that +-- are parameters or positions that are recursive calls. There are also many datatype-generic +-- functions that do not care about the names of datatypes and constructors at all. To keep +-- the number of cases to consider in generic functions in such a situation to a minimum, +-- it turns out that many of the type constructors introduced above are actually synonyms, +-- defining them to be variants of a smaller set of constructors. + +-- *** Individual fields of constructors: 'K1' +-- +-- | +-- +-- The type constructors 'Par0' and 'Rec0' are variants of 'K1': +-- +-- @ +-- type 'Par0' = 'K1' 'P' +-- type 'Rec0' = 'K1' 'R' +-- @ +-- +-- Here, 'P' and 'R' are type-level proxies again that do not have any associated values. + +-- *** Meta information: 'M1' +-- +-- | +-- +-- The type constructors 'S1', 'C1' and 'D1' are all variants of 'M1': +-- +-- @ +-- type 'S1' = 'M1' 'S' +-- type 'C1' = 'M1' 'C' +-- type 'D1' = 'M1' 'D' +-- @ +-- +-- The types 'S', 'C' and 'R' are once again type-level proxies, just used to create +-- several variants of 'M1'. + +-- *** Additional generic representation type constructors +-- +-- | +-- +-- Next to 'K1', 'M1', ':+:' and ':*:' there are a few more type constructors that occur +-- in the representations of other datatypes. + +-- **** Empty datatypes: 'V1' +-- +-- | +-- +-- For empty datatypes, 'V1' is used as a representation. For example, +-- +-- @ +-- data Empty deriving 'Generic' +-- @ +-- +-- yields +-- +-- @ +-- instance 'Generic' Empty where +-- type 'Rep' Empty = 'D1' D1Empty 'V1' +-- @ + +-- **** Constructors without fields: 'U1' +-- +-- | +-- +-- If a constructor has no arguments, then 'U1' is used as its representation. For example +-- the representation of 'Bool' is +-- +-- @ +-- instance 'Generic' Bool where +-- type 'Rep' Bool = +-- 'D1' D1Bool +-- ('C1' C1_0Bool 'U1' ':+:' 'C1' C1_1Bool 'U1') +-- @ + +-- *** Representation of types with many constructors or many fields +-- +-- | +-- +-- As ':+:' and ':*:' are just binary operators, one might ask what happens if the +-- datatype has more than two constructors, or a constructor with more than two +-- fields. The answer is simple: the operators are used several times, to combine +-- all the constructors and fields as needed. However, users /should not rely on +-- a specific nesting strategy/ for ':+:' and ':*:' being used. The compiler is +-- free to choose any nesting it prefers. (In practice, the current implementation +-- tries to produce a more or less balanced nesting, so that the traversal of the +-- structure of the datatype from the root to a particular component can be performed +-- in logarithmic rather than linear time.) + +-- ** Defining datatype-generic functions +-- +-- | +-- +-- A datatype-generic function comprises two parts: +-- +-- 1. /Generic instances/ for the function, implementing it for most of the representation +-- type constructors introduced above. +-- +-- 2. A /wrapper/ that for any datatype that is in `Generic`, performs the conversion +-- between the original value and its `Rep`-based representation and then invokes the +-- generic instances. +-- +-- As an example, let us look at a function 'encode' that produces a naive, but lossless +-- bit encoding of values of various datatypes. So we are aiming to define a function +-- +-- @ +-- encode :: 'Generic' a => a -> [Bool] +-- @ +-- +-- where we use 'Bool' as our datatype for bits. +-- +-- For part 1, we define a class @Encode'@. Perhaps surprisingly, this class is parameterized +-- over a type constructor @f@ of kind @* -> *@. This is a technicality: all the representation +-- type constructors operate with kind @* -> *@ as base kind. But the type argument is never +-- being used. This may be changed at some point in the future. The class has a single method, +-- and we use the type we want our final function to have, but we replace the occurrences of +-- the generic type argument @a@ with @f p@ (where the @p@ is any argument; it will not be used). +-- +-- > class Encode' f where +-- > encode' :: f p -> [Bool] +-- +-- With the goal in mind to make @encode@ work on @Tree@ and other datatypes, we now define +-- instances for the representation type constructors 'V1', 'U1', ':+:', ':*:', 'K1', and 'M1'. + +-- *** Definition of the generic representation types +-- +-- | +-- +-- In order to be able to do this, we need to know the actual definitions of these types: +-- +-- @ +-- data 'V1' p -- lifted version of Empty +-- data 'U1' p = 'U1' -- lifted version of () +-- data (':+:') f g p = 'L1' (f p) | 'R1' (g p) -- lifted version of 'Either' +-- data (':*:') f g p = (f p) ':*:' (g p) -- lifted version of (,) +-- newtype 'K1' i c p = 'K1' { 'unK1' :: c } -- a container for a c +-- newtype 'M1' i t f p = 'M1' { 'unM1' :: f p } -- a wrapper +-- @ +-- +-- So, 'U1' is just the unit type, ':+:' is just a binary choice like 'Either', +-- ':*:' is a binary pair like the pair constructor @(,)@, and 'K1' is a value +-- of a specific type @c@, and 'M1' wraps a value of the generic type argument, +-- which in the lifted world is an @f p@ (where we do not care about @p@). + +-- *** Generic instances +-- +-- | +-- +-- The instance for 'V1' is slightly awkward (but also rarely used): +-- +-- @ +-- instance Encode' 'V1' where +-- encode' x = undefined +-- @ +-- +-- There are no values of type @V1 p@ to pass (except undefined), so this is +-- actually impossible. One can ask why it is useful to define an instance for +-- 'V1' at all in this case? Well, an empty type can be used as an argument to +-- a non-empty type, and you might still want to encode the resulting type. +-- As a somewhat contrived example, consider @[Empty]@, which is not an empty +-- type, but contains just the empty list. The 'V1' instance ensures that we +-- can call the generic function on such types. +-- +-- There is exactly one value of type 'U1', so encoding it requires no +-- knowledge, and we can use zero bits: +-- +-- @ +-- instance Encode' 'U1' where +-- encode' 'U1' = [] +-- @ +-- +-- In the case for ':+:', we produce 'False' or 'True' depending on whether +-- the constructor of the value provided is located on the left or on the right: +-- +-- @ +-- instance (Encode' f, Encode' g) => Encode' (f ':+:' g) where +-- encode' ('L1' x) = False : encode' x +-- encode' ('R1' x) = True : encode' x +-- @ +-- +-- In the case for ':*:', we append the encodings of the two subcomponents: +-- +-- @ +-- instance (Encode' f, Encode' g) => Encode' (f ':*:' g) where +-- encode' (x ':*:' y) = encode' x ++ encode' y +-- @ +-- +-- The case for 'K1' is rather interesting. Here, we call the final function +-- 'encode' that we yet have to define, recursively. We will use another type +-- class 'Encode' for that function: +-- +-- @ +-- instance (Encode c) => Encode' ('K1' i c) where +-- encode' ('K1' x) = encode x +-- @ +-- +-- Note how 'Par0' and 'Rec0' both being mapped to 'K1' allows us to define +-- a uniform instance here. +-- +-- Similarly, we can define a uniform instance for 'M1', because we completely +-- disregard all meta-information: +-- +-- @ +-- instance (Encode' f) => Encode' ('M1' i t f) where +-- encode' ('M1' x) = encode' x +-- @ +-- +-- Unlike in 'K1', the instance for 'M1' refers to 'encode'', not 'encode'. + +-- *** The wrapper and generic default +-- +-- | +-- +-- We now define class 'Encode' for the actual 'encode' function: +-- +-- @ +-- class Encode a where +-- encode :: a -> [Bool] +-- default encode :: ('Generic' a) => a -> [Bool] +-- encode x = encode' ('from' x) +-- @ +-- +-- The incoming 'x' is converted using 'from', then we dispatch to the +-- generic instances using 'encode''. We use this as a default definition +-- for 'encode'. We need the 'default encode' signature because ordinary +-- Haskell default methods must not introduce additional class constraints, +-- but our generic default does. +-- +-- Defining a particular instance is now as simple as saying +-- +-- @ +-- instance (Encode a) => Encode (Tree a) +-- @ +-- +#if 0 +-- /TODO:/ Add usage example? +-- +#endif +-- The generic default is being used. In the future, it will hopefully be +-- possible to use @deriving Encode@ as well, but GHC does not yet support +-- that syntax for this situation. +-- +-- Having 'Encode' as a class has the advantage that we can define +-- non-generic special cases, which is particularly useful for abstract +-- datatypes that have no structural representation. For example, given +-- a suitable integer encoding function 'encodeInt', we can define +-- +-- @ +-- instance Encode Int where +-- encode = encodeInt +-- @ + +-- *** Omitting generic instances +-- +-- | +-- +-- It is not always required to provide instances for all the generic +-- representation types, but omitting instances restricts the set of +-- datatypes the functions will work for: +-- +-- * If no ':+:' instance is given, the function may still work for +-- empty datatypes or datatypes that have a single constructor, +-- but will fail on datatypes with more than one constructor. +-- +-- * If no ':*:' instance is given, the function may still work for +-- datatypes where each constructor has just zero or one field, +-- in particular for enumeration types. +-- +-- * If no 'K1' instance is given, the function may still work for +-- enumeration types, where no constructor has any fields. +-- +-- * If no 'V1' instance is given, the function may still work for +-- any datatype that is not empty. +-- +-- * If no 'U1' instance is given, the function may still work for +-- any datatype where each constructor has at least one field. +-- +-- An 'M1' instance is always required (but it can just ignore the +-- meta-information, as is the case for 'encode' above). +#if 0 +-- *** Using meta-information +-- +-- | +-- +-- TODO +#endif +-- ** Generic constructor classes +-- +-- | +-- +-- Datatype-generic functions as defined above work for a large class +-- of datatypes, including parameterized datatypes. (We have used 'Tree' +-- as our example above, which is of kind @* -> *@.) However, the +-- 'Generic' class ranges over types of kind @*@, and therefore, the +-- resulting generic functions (such as 'encode') must be parameterized +-- by a generic type argument of kind @*@. +-- +-- What if we want to define generic classes that range over type +-- constructors (such as 'Functor', 'Traversable', or 'Foldable')? + +-- *** The 'Generic1' class +-- +-- | +-- +-- Like 'Generic', there is a class 'Generic1' that defines a +-- representation 'Rep1' and conversion functions 'from1' and 'to1', +-- only that 'Generic1' ranges over types of kind @* -> *@. +-- The 'Generic1' class is also derivable. +-- +-- The representation 'Rep1' is ever so slightly different from 'Rep'. +-- Let us look at 'Tree' as an example again: +-- +-- @ +-- data Tree a = Leaf a | Node (Tree a) (Tree a) +-- deriving 'Generic1' +-- @ +-- +-- The above declaration causes the following representation to be generated: +-- +-- class 'Generic1' Tree where +-- type 'Rep1' Tree = +-- 'D1' D1Tree +-- ('C1' C1_0Tree +-- ('S1' 'NoSelector' 'Par1') +-- ':+:' +-- 'C1' C1_1Tree +-- ('S1' 'NoSelector' ('Rec1' Tree) +-- ':*:' +-- 'S1' 'NoSelector' ('Rec1' Tree))) +-- ... +-- +-- The representation reuses 'D1', 'C1', 'S1' (and thereby 'M1') as well +-- as ':+:' and ':*:' from 'Rep'. (This reusability is the reason that we +-- carry around the dummy type argument for kind-@*@-types, but there are +-- already enough different names involved without duplicating each of +-- these.) +-- +-- What's different is that we now use 'Par1' to refer to the parameter +-- (and that parameter, which used to be @a@), is not mentioned explicitly +-- by name anywhere; and we use 'Rec1' to refer to a recursive use of @Tree a@. + +-- *** Representation of @* -> *@ types +-- +-- | +-- +-- Unlike 'Par0' and 'Rec0', the 'Par1' and 'Rec1' type constructors do not +-- map to 'K1'. They are defined directly, as follows: +-- +-- @ +-- newtype 'Par1' p = 'Par1' { 'unPar1' :: p } -- gives access to parameter p +-- newtype 'Rec1' f p = 'Rec1' { 'unRec1' :: f p } -- a wrapper +-- @ +-- +-- In 'Par1', the parameter @p@ is used for the first time, whereas 'Rec1' simply +-- wraps an application of @f@ to @p@. +-- +-- Note that 'K1' (in the guise of 'Rec0') can still occur in a 'Rep1' representation, +-- namely when the datatype has a field that does not mention the parameter. +-- +-- The declaration +-- +-- @ +-- data WithInt a = WithInt Int a +-- deriving 'Generic1' +-- @ +-- +-- yields +-- +-- @ +-- class 'Rep1' WithInt where +-- type 'Rep1' WithInt = +-- 'D1' D1WithInt +-- ('C1' C1_0WithInt +-- ('S1' 'NoSelector' ('Rec0' Int) +-- ':*:' +-- 'S1' 'NoSelector' 'Par1')) +-- @ +-- +-- If the parameter @a@ appears underneath a composition of other type constructors, +-- then the representation involves composition, too: +-- +-- @ +-- data Rose a = Fork a [Rose a] +-- @ +-- +-- yields +-- +-- @ +-- class 'Rep1' Rose where +-- type 'Rep1' Rose = +-- 'D1' D1Rose +-- ('C1' C1_0Rose +-- ('S1' 'NoSelector' 'Par1' +-- ':*:' +-- 'S1' 'NoSelector' ([] ':.:' 'Rec1' Rose) +-- @ +-- +-- where +-- +-- @ +-- newtype (':.:') f g p = 'Comp1' { 'unComp1' :: f (g p) } +-- @ + +-- *** Representation of unlifted types +-- +-- | +-- +-- If one were to attempt to derive a Generic instance for a datatype with an +-- unlifted argument (for example, 'Int#'), one might expect the occurrence of +-- the 'Int#' argument to be marked with @'Rec0' 'Int#'@. This won't work, +-- though, since 'Int#' is of kind @#@ and 'Rec0' expects a type of kind @*@. +-- In fact, polymorphism over unlifted types is disallowed completely. +-- +-- One solution would be to represent an occurrence of 'Int#' with 'Rec0 Int' +-- instead. With this approach, however, the programmer has no way of knowing +-- whether the 'Int' is actually an 'Int#' in disguise. +-- +-- Instead of reusing 'Rec0', a separate data family 'URec' is used to mark +-- occurrences of common unlifted types: +-- +-- @ +-- data family URec a p +-- +-- data instance 'URec' ('Ptr' ()) p = 'UAddr' { 'uAddr#' :: 'Addr#' } +-- data instance 'URec' 'Char' p = 'UChar' { 'uChar#' :: 'Char#' } +-- data instance 'URec' 'Double' p = 'UDouble' { 'uDouble#' :: 'Double#' } +-- data instance 'URec' 'Int' p = 'UFloat' { 'uFloat#' :: 'Float#' } +-- data instance 'URec' 'Float' p = 'UInt' { 'uInt#' :: 'Int#' } +-- data instance 'URec' 'Word' p = 'UWord' { 'uWord#' :: 'Word#' } +-- @ +-- +-- Several type synonyms are provided for convenience: +-- +-- @ +-- type 'UAddr' = 'URec' ('Ptr' ()) +-- type 'UChar' = 'URec' 'Char' +-- type 'UDouble' = 'URec' 'Double' +-- type 'UFloat' = 'URec' 'Float' +-- type 'UInt' = 'URec' 'Int' +-- type 'UWord' = 'URec' 'Word' +-- @ +-- +-- The declaration +-- +-- @ +-- data IntHash = IntHash Int# +-- deriving 'Generic' +-- @ +-- +-- yields +-- +-- @ +-- instance 'Generic' IntHash where +-- type 'Rep' IntHash = +-- 'D1' D1IntHash +-- ('C1' C1_0IntHash +-- ('S1' 'NoSelector' 'UInt')) +-- @ +-- +-- Currently, only the six unlifted types listed above are generated, but this +-- may be extended to encompass more unlifted types in the future. +#if 0 +-- *** Limitations +-- +-- | +-- +-- /TODO/ +-- +-- /TODO:/ Also clear up confusion about 'Rec0' and 'Rec1' not really indicating recursion. +-- +#endif +#if __GLASGOW_HASKELL__ < 701 + -- * Generic representation types + V1, U1(..), Par1(..), Rec1(..), K1(..), M1(..) + , (:+:)(..), (:*:)(..), (:.:)(..) + + -- ** Synonyms for convenience + , Rec0, Par0, R, P + , D1, C1, S1, D, C, S + + -- * Meta-information + , Datatype(..), Constructor(..), Selector(..), NoSelector + , Fixity(..), Associativity(..), Arity(..), prec + + -- * Generic type classes + , Generic(..), Generic1(..), + +#else + module GHC.Generics, +#endif +#if __GLASGOW_HASKELL__ < 711 + -- ** Unboxed representation types + URec(..), UAddr, UChar, UDouble, UFloat, UInt, UWord +#endif + ) where + + +#if __GLASGOW_HASKELL__ >= 701 +import GHC.Generics +#endif + +#if __GLASGOW_HASKELL__ < 709 +import Data.Word ( Word ) +#endif + +#if __GLASGOW_HASKELL__ < 711 +import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# ) +import GHC.Ptr ( Ptr ) +#endif + +#if __GLASGOW_HASKELL__ < 701 +-------------------------------------------------------------------------------- +-- Representation types +-------------------------------------------------------------------------------- + +-- | Void: used for datatypes without constructors +data V1 p + +-- | Unit: used for constructors without arguments +data U1 p = U1 + deriving (Eq, Ord, Read, Show) + +-- | Used for marking occurrences of the parameter +newtype Par1 p = Par1 { unPar1 :: p } + deriving (Eq, Ord, Read, Show) + +-- | Recursive calls of kind * -> * +newtype Rec1 f p = Rec1 { unRec1 :: f p } + deriving (Eq, Ord, Read, Show) + +-- | Constants, additional parameters and recursion of kind * +newtype K1 i c p = K1 { unK1 :: c } + deriving (Eq, Ord, Read, Show) + +-- | Meta-information (constructor names, etc.) +newtype M1 i c f p = M1 { unM1 :: f p } + deriving (Eq, Ord, Read, Show) + +-- | Sums: encode choice between constructors +infixr 5 :+: +data (:+:) f g p = L1 (f p) | R1 (g p) + deriving (Eq, Ord, Read, Show) + +-- | Products: encode multiple arguments to constructors +infixr 6 :*: +data (:*:) f g p = f p :*: g p + deriving (Eq, Ord, Read, Show) + +-- | Composition of functors +infixr 7 :.: +newtype (:.:) f g p = Comp1 { unComp1 :: f (g p) } + deriving (Eq, Ord, Read, Show) +-- | Tag for K1: recursion (of kind *) +data R +-- | Tag for K1: parameters (other than the last) +data P + +-- | Type synonym for encoding recursion (of kind *) +type Rec0 = K1 R +-- | Type synonym for encoding parameters (other than the last) +type Par0 = K1 P + +-- | Tag for M1: datatype +data D +-- | Tag for M1: constructor +data C +-- | Tag for M1: record selector +data S + +-- | Type synonym for encoding meta-information for datatypes +type D1 = M1 D + +-- | Type synonym for encoding meta-information for constructors +type C1 = M1 C + +-- | Type synonym for encoding meta-information for record selectors +type S1 = M1 S + +-- | Class for datatypes that represent datatypes +class Datatype d where + -- | The name of the datatype, fully qualified + datatypeName :: t d (f :: * -> *) a -> String + moduleName :: t d (f :: * -> *) a -> String + +-- | Class for datatypes that represent records +class Selector s where + -- | The name of the selector + selName :: t s (f :: * -> *) a -> String + +-- | Used for constructor fields without a name +data NoSelector + +instance Selector NoSelector where selName _ = "" + +-- | Class for datatypes that represent data constructors +class Constructor c where + -- | The name of the constructor + conName :: t c (f :: * -> *) a -> String + + -- | The fixity of the constructor + conFixity :: t c (f :: * -> *) a -> Fixity + conFixity = const Prefix + + -- | Marks if this constructor is a record + conIsRecord :: t c (f :: * -> *) a -> Bool + conIsRecord = const False + + +-- | Datatype to represent the arity of a tuple. +data Arity = NoArity | Arity Int + deriving (Eq, Show, Ord, Read) + +-- | Datatype to represent the fixity of a constructor. An infix +-- | declaration directly corresponds to an application of 'Infix'. +data Fixity = Prefix | Infix Associativity Int + deriving (Eq, Show, Ord, Read) + +-- | Get the precedence of a fixity value. +prec :: Fixity -> Int +prec Prefix = 10 +prec (Infix _ n) = n + +-- | Datatype to represent the associativy of a constructor +data Associativity = LeftAssociative + | RightAssociative + | NotAssociative + deriving (Eq, Show, Ord, Read) + +-- | Representable types of kind * +class Generic a where + type Rep a :: * -> * + -- | Convert from the datatype to its representation + from :: a -> Rep a x + -- | Convert from the representation to the datatype + to :: Rep a x -> a + +-- | Representable types of kind * -> * +class Generic1 f where + type Rep1 f :: * -> * + -- | Convert from the datatype to its representation + from1 :: f a -> Rep1 f a + -- | Convert from the representation to the datatype + to1 :: Rep1 f a -> f a + +#endif + +#if __GLASGOW_HASKELL__ < 711 +-- | Constants of kind @#@ +data family URec (a :: *) (p :: *) + +-- | Used for marking occurrences of 'Addr#' +data instance URec (Ptr ()) p = UAddr { uAddr# :: Addr# } + deriving (Eq, Ord) + +-- | Used for marking occurrences of 'Char#' +data instance URec Char p = UChar { uChar# :: Char# } + deriving (Eq, Ord, Show) + +-- | Used for marking occurrences of 'Double#' +data instance URec Double p = UDouble { uDouble# :: Double# } + deriving (Eq, Ord, Show) + +-- | Used for marking occurrences of 'Float#' +data instance URec Float p = UFloat { uFloat# :: Float# } + deriving (Eq, Ord, Show) + +-- | Used for marking occurrences of 'Int#' +data instance URec Int p = UInt { uInt# :: Int# } + deriving (Eq, Ord, Show) + +-- | Used for marking occurrences of 'Word#' +data instance URec Word p = UWord { uWord# :: Word# } + deriving (Eq, Ord, Show) + +-- | Type synonym for 'URec': 'Addr#' +type UAddr = URec (Ptr ()) +-- | Type synonym for 'URec': 'Char#' +type UChar = URec Char +-- | Type synonym for 'URec': 'Double#' +type UDouble = URec Double +-- | Type synonym for 'URec': 'Float#' +type UFloat = URec Float +-- | Type synonym for 'URec': 'Int#' +type UInt = URec Int +-- | Type synonym for 'URec': 'Word#' +type UWord = URec Word +#endif diff --git a/src/Generics/Deriving/Copoint.hs b/src/Generics/Deriving/Copoint.hs index df0506c..fd1c075 100644 --- a/src/Generics/Deriving/Copoint.hs +++ b/src/Generics/Deriving/Copoint.hs @@ -1,113 +1,113 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -module Generics.Deriving.Copoint ( - -- * GCopoint class - GCopoint(..), - - -- * Default method - gcopointdefault - - ) where - -import Control.Applicative (WrappedMonad) - -import Data.Monoid (Dual, Sum) - -import Generics.Deriving.Base -import Generics.Deriving.Instances () - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -#endif - --------------------------------------------------------------------------------- --- Generic copoint --------------------------------------------------------------------------------- - --- General copoint may return 'Nothing' - -class GCopoint' t where - gcopoint' :: t a -> Maybe a - -instance GCopoint' U1 where - gcopoint' U1 = Nothing - -instance GCopoint' Par1 where - gcopoint' (Par1 a) = Just a - -instance GCopoint' (K1 i c) where - gcopoint' _ = Nothing - -instance GCopoint' f => GCopoint' (M1 i c f) where - gcopoint' (M1 a) = gcopoint' a - -instance (GCopoint' f, GCopoint' g) => GCopoint' (f :+: g) where - gcopoint' (L1 a) = gcopoint' a - gcopoint' (R1 a) = gcopoint' a - --- Favours left "hole" for copoint -instance (GCopoint' f, GCopoint' g) => GCopoint' (f :*: g) where - gcopoint' (a :*: b) = case (gcopoint' a) of - Just x -> Just x - Nothing -> gcopoint' b - -instance (GCopoint f) => GCopoint' (Rec1 f) where - gcopoint' (Rec1 a) = Just $ gcopoint a - -instance (GCopoint f, GCopoint' g) => GCopoint' (f :.: g) where - gcopoint' (Comp1 x) = gcopoint' . gcopoint $ x - -class GCopoint d where - gcopoint :: d a -> a -#if __GLASGOW_HASKELL__ >= 701 - default gcopoint :: (Generic1 d, GCopoint' (Rep1 d)) - => (d a -> a) - gcopoint = gcopointdefault -#endif - -gcopointdefault :: (Generic1 d, GCopoint' (Rep1 d)) - => d a -> a -gcopointdefault x = case (gcopoint' . from1 $ x) of - Just x' -> x' - Nothing -> error "Data type is not copointed" - --- instance (Generic1 d, GCopoint' (Rep1 d)) => GCopoint d - --- Base types instances -instance GCopoint ((,) a) where - gcopoint = gcopointdefault - -instance GCopoint ((,,) a b) where - gcopoint = gcopointdefault - -instance GCopoint ((,,,) a b c) where - gcopoint = gcopointdefault - -instance GCopoint ((,,,,) a b c d) where - gcopoint = gcopointdefault - -instance GCopoint ((,,,,,) a b c d e) where - gcopoint = gcopointdefault - -instance GCopoint ((,,,,,,) a b c d e f) where - gcopoint = gcopointdefault - -instance GCopoint Dual where - gcopoint = gcopointdefault - -#if MIN_VERSION_base(4,8,0) -instance GCopoint Identity where - gcopoint = gcopointdefault -#endif - -instance GCopoint Sum where - gcopoint = gcopointdefault - -instance GCopoint m => GCopoint (WrappedMonad m) where - gcopoint = gcopointdefault +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE DefaultSignatures #-} +#endif + +module Generics.Deriving.Copoint ( + -- * GCopoint class + GCopoint(..), + + -- * Default method + gcopointdefault + + ) where + +import Control.Applicative (WrappedMonad) + +import Data.Monoid (Dual, 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 diff --git a/src/Generics/Deriving/Enum.hs b/src/Generics/Deriving/Enum.hs index 842f2c9..fb89d0a 100644 --- a/src/Generics/Deriving/Enum.hs +++ b/src/Generics/Deriving/Enum.hs @@ -1,890 +1,890 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -#include "HsBaseConfig.h" - -module Generics.Deriving.Enum ( - - -- * Generic enum class - GEnum(..) - - -- * Default definitions for GEnum - , genumDefault, toEnumDefault, fromEnumDefault - - -- * Generic Ix class - , GIx(..) - - -- * Default definitions for GIx - , rangeDefault, indexDefault, inRangeDefault - - ) where - -import Control.Applicative (Const, ZipList) - -import Data.Int -import Data.Monoid (All, Any, Dual, First, Last, Product, Sum) -import Data.Word - -import Foreign.C.Types -import Foreign.Ptr - -import Generics.Deriving.Base -import Generics.Deriving.Instances () -import Generics.Deriving.Eq - -import System.Posix.Types - -#if MIN_VERSION_base(4,7,0) -import Data.Proxy (Proxy) -#endif - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -import Data.Monoid (Alt) -import Numeric.Natural (Natural) -#endif - ------------------------------------------------------------------------------ --- Utility functions for Enum' ------------------------------------------------------------------------------ - -infixr 5 ||| - --- | Interleave elements from two lists. Similar to (++), but swap left and --- right arguments on every recursive application. --- --- From Mark Jones' talk at AFP2008 -(|||) :: [a] -> [a] -> [a] -[] ||| ys = ys -(x:xs) ||| ys = x : ys ||| xs - --- | Diagonalization of nested lists. Ensure that some elements from every --- sublist will be included. Handles infinite sublists. --- --- From Mark Jones' talk at AFP2008 -diag :: [[a]] -> [a] -diag = concat . foldr skew [] . map (map (\x -> [x])) - -skew :: [[a]] -> [[a]] -> [[a]] -skew [] ys = ys -skew (x:xs) ys = x : combine (++) xs ys - -combine :: (a -> a -> a) -> [a] -> [a] -> [a] -combine _ xs [] = xs -combine _ [] ys = ys -combine f (x:xs) (y:ys) = f x y : combine f xs ys - -findIndex :: (a -> Bool) -> [a] -> Maybe Int -findIndex p xs = let l = [ i | (y,i) <- zip xs [(0::Int)..], p y] - in if (null l) - then Nothing - else Just (head l) - --------------------------------------------------------------------------------- --- Generic enum --------------------------------------------------------------------------------- - -class Enum' f where - enum' :: [f a] - -instance Enum' U1 where - enum' = [U1] - -instance (GEnum c) => Enum' (K1 i c) where - enum' = map K1 genum - -instance (Enum' f) => Enum' (M1 i c f) where - enum' = map M1 enum' - -instance (Enum' f, Enum' g) => Enum' (f :+: g) where - enum' = map L1 enum' ||| map R1 enum' - -instance (Enum' f, Enum' g) => Enum' (f :*: g) where - enum' = diag [ [ x :*: y | y <- enum' ] | x <- enum' ] - -genumDefault :: (Generic a, Enum' (Rep a)) => [a] -genumDefault = map to enum' - -toEnumDefault :: (Generic a, Enum' (Rep a)) => Int -> a -toEnumDefault i = let l = enum' - in if (length l > i) - then to (l !! i) - else error "toEnum: invalid index" - -fromEnumDefault :: (GEq a, Generic a, Enum' (Rep a)) - => a -> Int -fromEnumDefault x = case findIndex (geq x) (map to enum') of - Nothing -> error "fromEnum: no corresponding index" - Just i -> i - - -class GEnum a where - genum :: [a] - -#if __GLASGOW_HASKELL__ >= 701 - default genum :: (Generic a, Enum' (Rep a)) => [a] - genum = genumDefault -#endif - -genumNum :: (Enum a, Num a) => [a] -genumNum = [0..] ||| (neg 0) where - neg n = (n-1) : neg (n-1) - --- Base types instances -instance GEnum () where - genum = genumDefault - -instance (GEnum a, GEnum b) => GEnum (a, b) where - genum = genumDefault - -instance (GEnum a, GEnum b, GEnum c) => GEnum (a, b, c) where - genum = genumDefault - -instance (GEnum a, GEnum b, GEnum c, GEnum d) => GEnum (a, b, c, d) where - genum = genumDefault - -instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e) => GEnum (a, b, c, d, e) where - genum = genumDefault - -instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f) - => GEnum (a, b, c, d, e, f) where - genum = genumDefault - -instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f, GEnum g) - => GEnum (a, b, c, d, e, f, g) where - genum = genumDefault - -instance GEnum a => GEnum [a] where - genum = genumDefault - -instance (GEnum (f p), GEnum (g p)) => GEnum ((f :+: g) p) where - genum = genumDefault - -instance (GEnum (f p), GEnum (g p)) => GEnum ((f :*: g) p) where - genum = genumDefault - -instance GEnum (f (g p)) => GEnum ((f :.: g) p) where - genum = genumDefault - -instance GEnum All where - genum = genumDefault - -#if MIN_VERSION_base(4,8,0) -instance GEnum (f a) => GEnum (Alt f a) where - genum = genumDefault -#endif - -instance GEnum Any where - genum = genumDefault - -instance GEnum Arity where - genum = genumDefault - -instance GEnum Associativity where - genum = genumDefault - -instance GEnum Bool where - genum = genumDefault - -#if defined(HTYPE_CC_T) -instance GEnum CCc where - genum = genumNum -#endif - -instance GEnum CChar where - genum = genumNum - -instance GEnum CClock where - genum = genumNum - -#if defined(HTYPE_DEV_T) -instance GEnum CDev where - genum = genumNum -#endif - -instance GEnum CDouble where - genum = genumNum - -instance GEnum CFloat where - genum = genumNum - -#if defined(HTYPE_GID_T) -instance GEnum CGid where - genum = genumNum -#endif - -#if defined(HTYPE_INO_T) -instance GEnum CIno where - genum = genumNum -#endif - -instance GEnum CInt where - genum = genumNum - -instance GEnum CIntMax where - genum = genumNum - -instance GEnum CIntPtr where - genum = genumNum - -instance GEnum CLLong where - genum = genumNum - -instance GEnum CLong where - genum = genumNum - -#if defined(HTYPE_MODE_T) -instance GEnum CMode where - genum = genumNum -#endif - -#if defined(HTYPE_NLINK_T) -instance GEnum CNlink where - genum = genumNum -#endif - -#if defined(HTYPE_OFF_T) -instance GEnum COff where - genum = genumNum -#endif - -instance GEnum a => GEnum (Const a b) where - genum = genumDefault - -#if defined(HTYPE_PID_T) -instance GEnum CPid where - genum = genumNum -#endif - -instance GEnum CPtrdiff where - genum = genumNum - -#if defined(HTYPE_RLIM_T) -instance GEnum CRLim where - genum = genumNum -#endif - -instance GEnum CSChar where - genum = genumNum - -#if defined(HTYPE_SPEED_T) -instance GEnum CSpeed where - genum = genumNum -#endif - -#if MIN_VERSION_base(4,4,0) -instance GEnum CSUSeconds where - genum = genumNum -#endif - -instance GEnum CShort where - genum = genumNum - -instance GEnum CSigAtomic where - genum = genumNum - -instance GEnum CSize where - genum = genumNum - -#if defined(HTYPE_SSIZE_T) -instance GEnum CSsize where - genum = genumNum -#endif - -#if defined(HTYPE_TCFLAG_T) -instance GEnum CTcflag where - genum = genumNum -#endif - -instance GEnum CTime where - genum = genumNum - -instance GEnum CUChar where - genum = genumNum - -#if defined(HTYPE_UID_T) -instance GEnum CUid where - genum = genumNum -#endif - -instance GEnum CUInt where - genum = genumNum - -instance GEnum CUIntMax where - genum = genumNum - -instance GEnum CUIntPtr where - genum = genumNum - -instance GEnum CULLong where - genum = genumNum - -instance GEnum CULong where - genum = genumNum - -#if MIN_VERSION_base(4,4,0) -instance GEnum CUSeconds where - genum = genumNum -#endif - -instance GEnum CUShort where - genum = genumNum - -instance GEnum CWchar where - genum = genumNum - -instance GEnum Double where - genum = genumNum - -instance GEnum a => GEnum (Dual a) where - genum = genumDefault - -instance (GEnum a, GEnum b) => GEnum (Either a b) where - genum = genumDefault - -instance GEnum Fd where - genum = genumNum - -instance GEnum a => GEnum (First a) where - genum = genumDefault - -instance GEnum Fixity where - genum = genumDefault - -instance GEnum Float where - genum = genumNum - -#if MIN_VERSION_base(4,8,0) -instance GEnum a => GEnum (Identity a) where - genum = genumDefault -#endif - -instance GEnum Int where - genum = genumNum - -instance GEnum Int8 where - genum = genumNum - -instance GEnum Int16 where - genum = genumNum - -instance GEnum Int32 where - genum = genumNum - -instance GEnum Int64 where - genum = genumNum - -instance GEnum Integer where - genum = genumNum - -instance GEnum IntPtr where - genum = genumNum - -instance GEnum c => GEnum (K1 i c p) where - genum = genumDefault - -instance GEnum a => GEnum (Last a) where - genum = genumDefault - -instance GEnum (f p) => GEnum (M1 i c f p) where - genum = genumDefault - -instance GEnum a => GEnum (Maybe a) where - genum = genumDefault - -instance GEnum Ordering where - genum = genumDefault - -instance GEnum p => GEnum (Par1 p) where - genum = genumDefault - -instance GEnum a => GEnum (Product a) where - genum = genumDefault - -#if MIN_VERSION_base(4,7,0) -instance GEnum (Proxy s) where - genum = genumDefault -#endif - -instance GEnum (f p) => GEnum (Rec1 f p) where - genum = genumDefault - -instance GEnum a => GEnum (Sum a) where - genum = genumDefault - -instance GEnum (U1 p) where - genum = genumDefault - -instance GEnum Word where - genum = genumNum - -instance GEnum Word8 where - genum = genumNum - -instance GEnum Word16 where - genum = genumNum - -instance GEnum Word32 where - genum = genumNum - -instance GEnum Word64 where - genum = genumNum - -instance GEnum WordPtr where - genum = genumNum - -instance GEnum a => GEnum (ZipList a) where - genum = genumDefault - --------------------------------------------------------------------------------- --- Generic Ix --------------------------------------------------------------------------------- - --- Minimal complete instance: 'range', 'index' and 'inRange'. -class (Ord a) => GIx a where - -- | The list of values in the subrange defined by a bounding pair. - range :: (a,a) -> [a] - -- | The position of a subscript in the subrange. - index :: (a,a) -> a -> Int - -- | Returns 'True' the given subscript lies in the range defined - -- the bounding pair. - inRange :: (a,a) -> a -> Bool -#if __GLASGOW_HASKELL__ >= 701 - default range :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> [a] - range = rangeDefault - - default index :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Int - index = indexDefault - - default inRange :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Bool - inRange = inRangeDefault -#endif - -rangeDefault :: (GEq a, Generic a, Enum' (Rep a)) - => (a,a) -> [a] -rangeDefault = t (map to enum') where - t l (x,y) = - case (findIndex (geq x) l, findIndex (geq y) l) of - (Nothing, _) -> error "rangeDefault: no corresponding index" - (_, Nothing) -> error "rangeDefault: no corresponding index" - (Just i, Just j) -> take (j-i) (drop i l) - -indexDefault :: (GEq a, Generic a, Enum' (Rep a)) - => (a,a) -> a -> Int -indexDefault = t (map to enum') where - t l (x,y) z = - case (findIndex (geq x) l, findIndex (geq y) l) of - (Nothing, _) -> error "indexDefault: no corresponding index" - (_, Nothing) -> error "indexDefault: no corresponding index" - (Just i, Just j) -> case findIndex (geq z) (take (j-i) (drop i l)) of - Nothing -> error "indexDefault: index out of range" - Just k -> k - -inRangeDefault :: (GEq a, Generic a, Enum' (Rep a)) - => (a,a) -> a -> Bool -inRangeDefault = t (map to enum') where - t l (x,y) z = - case (findIndex (geq x) l, findIndex (geq y) l) of - (Nothing, _) -> error "indexDefault: no corresponding index" - (_, Nothing) -> error "indexDefault: no corresponding index" - (Just i, Just j) -> maybe False (const True) - (findIndex (geq z) (take (j-i) (drop i l))) - -rangeEnum :: Enum a => (a, a) -> [a] -rangeEnum (m,n) = [m..n] - -indexIntegral :: Integral a => (a, a) -> a -> Int -indexIntegral (m,_n) i = fromIntegral (i - m) - -inRangeOrd :: Ord a => (a, a) -> a -> Bool -inRangeOrd (m,n) i = m <= i && i <= n - --- Base types instances -instance GIx () where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (a, b) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c) - => GIx (a, b, c) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, - GEq d, GEnum d, GIx d) - => GIx (a, b, c, d) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, - GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e) - => GIx (a, b, c, d, e) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, - GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f) - => GIx (a, b, c, d, e, f) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, - GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f, - GEq g, GEnum g, GIx g) - => GIx (a, b, c, d, e, f, g) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a) => GIx [a] where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx All where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -#if MIN_VERSION_base(4,8,0) -instance (GEq (f a), GEnum (f a), GIx (f a)) => GIx (Alt f a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault -#endif - -instance GIx Any where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx Arity where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx Associativity where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx Bool where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx CChar where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -#if defined(HTYPE_GID_T) -instance GIx CGid where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -#if defined(HTYPE_INO_T) -instance GIx CIno where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -instance GIx CInt where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CIntMax where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CIntPtr where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CLLong where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CLong where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -#if defined(HTYPE_MODE_T) -instance GIx CMode where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -#if defined(HTYPE_NLINK_T) -instance GIx CNlink where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -#if defined(HTYPE_OFF_T) -instance GIx COff where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -#if defined(HTYPE_PID_T) -instance GIx CPid where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -instance GIx CPtrdiff where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -#if defined(HTYPE_RLIM_T) -instance GIx CRLim where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -instance GIx CSChar where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CShort where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CSigAtomic where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CSize where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -#if defined(HTYPE_SSIZE_T) -instance GIx CSsize where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -#if defined(HTYPE_TCFLAG_T) -instance GIx CTcflag where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -instance GIx CUChar where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -#if defined(HTYPE_UID_T) -instance GIx CUid where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -instance GIx CUInt where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CUIntMax where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CUIntPtr where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CULLong where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CULong where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CUShort where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx CWchar where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance (GEq a, GEnum a, GIx a) => GIx (Dual a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (Either a b) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx Fd where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance (GEq a, GEnum a, GIx a) => GIx (First a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx Fixity where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -#if MIN_VERSION_base(4,8,0) -instance (GEq a, GEnum a, GIx a) => GIx (Identity a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault -#endif - -instance GIx Int where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Int8 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Int16 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Int32 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Int64 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Integer where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx IntPtr where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance (GEq a, GEnum a, GIx a) => GIx (Last a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a) => GIx (Maybe a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -#if MIN_VERSION_base(4,8,0) -instance GIx Natural where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd -#endif - -instance GIx Ordering where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance (GEq a, GEnum a, GIx a) => GIx (Product a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -#if MIN_VERSION_base(4,7,0) -instance GIx (Proxy s) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault -#endif - -instance (GEq a, GEnum a, GIx a) => GIx (Sum a) where - range = rangeDefault - index = indexDefault - inRange = inRangeDefault - -instance GIx Word where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Word8 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Word16 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Word32 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx Word64 where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd - -instance GIx WordPtr where - range = rangeEnum - index = indexIntegral - inRange = inRangeOrd +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE DefaultSignatures #-} +#endif + +#include "HsBaseConfig.h" + +module Generics.Deriving.Enum ( + + -- * Generic enum class + GEnum(..) + + -- * Default definitions for GEnum + , genumDefault, toEnumDefault, fromEnumDefault + + -- * Generic Ix class + , GIx(..) + + -- * Default definitions for GIx + , rangeDefault, indexDefault, inRangeDefault + + ) where + +import Control.Applicative (Const, ZipList) + +import Data.Int +import Data.Monoid (All, Any, Dual, 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 diff --git a/src/Generics/Deriving/Eq.hs b/src/Generics/Deriving/Eq.hs index af860c3..bc00cae 100644 --- a/src/Generics/Deriving/Eq.hs +++ b/src/Generics/Deriving/Eq.hs @@ -1,475 +1,475 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE MagicHash #-} - -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -#include "HsBaseConfig.h" - -module Generics.Deriving.Eq ( - -- * Generic show class - GEq(..) - - -- * Default definition - , geqdefault - - ) where - -import Control.Applicative (Const, ZipList) - -import Data.Char (GeneralCategory) -import Data.Int -import Data.Monoid (All, Any, Dual, First, Last, Product, Sum) -import Data.Word - -import Foreign.C.Error -import Foreign.C.Types -import Foreign.ForeignPtr (ForeignPtr) -import Foreign.Ptr -import Foreign.StablePtr (StablePtr) - -import Generics.Deriving.Base -import Generics.Deriving.Instances () - -import GHC.Exts hiding (Any) - -import System.Exit (ExitCode) -import System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode) -import System.IO.Error (IOErrorType) -import System.Posix.Types - -#if MIN_VERSION_base(4,7,0) -import Data.Proxy (Proxy) -#endif - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -import Data.Monoid (Alt) -import Data.Void (Void) -import Numeric.Natural (Natural) -#endif - --------------------------------------------------------------------------------- --- Generic show --------------------------------------------------------------------------------- - -class GEq' f where - geq' :: f a -> f a -> Bool - -instance GEq' U1 where - geq' _ _ = True - -instance (GEq c) => GEq' (K1 i c) where - geq' (K1 a) (K1 b) = geq a b - --- No instances for P or Rec because geq is only applicable to types of kind * - -instance (GEq' a) => GEq' (M1 i c a) where - geq' (M1 a) (M1 b) = geq' a b - -instance (GEq' a, GEq' b) => GEq' (a :+: b) where - geq' (L1 a) (L1 b) = geq' a b - geq' (R1 a) (R1 b) = geq' a b - geq' _ _ = False - -instance (GEq' a, GEq' b) => GEq' (a :*: b) where - geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2 - --- Unboxed types -instance GEq' UAddr where - geq' (UAddr a1) (UAddr a2) = isTrue# (eqAddr# a1 a2) -instance GEq' UChar where - geq' (UChar c1) (UChar c2) = isTrue# (eqChar# c1 c2) -instance GEq' UDouble where - geq' (UDouble d1) (UDouble d2) = isTrue# (d1 ==## d2) -instance GEq' UFloat where - geq' (UFloat f1) (UFloat f2) = isTrue# (eqFloat# f1 f2) -instance GEq' UInt where - geq' (UInt i1) (UInt i2) = isTrue# (i1 ==# i2) -instance GEq' UWord where - geq' (UWord w1) (UWord w2) = isTrue# (eqWord# w1 w2) - -#if __GLASGOW_HASKELL__ < 707 -isTrue# :: Bool -> Bool -isTrue# = id -#endif - - -class GEq a where - geq :: a -> a -> Bool - - -#if __GLASGOW_HASKELL__ >= 701 - default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool - geq = geqdefault -#endif - -geqdefault :: (Generic a, GEq' (Rep a)) => a -> a -> Bool -geqdefault x y = geq' (from x) (from y) - --- Base types instances -instance GEq () where - geq = geqdefault - -instance (GEq a, GEq b) => GEq (a, b) where - geq = geqdefault - -instance (GEq a, GEq b, GEq c) => GEq (a, b, c) where - geq = geqdefault - -instance (GEq a, GEq b, GEq c, GEq d) => GEq (a, b, c, d) where - geq = geqdefault - -instance (GEq a, GEq b, GEq c, GEq d, GEq e) => GEq (a, b, c, d, e) where - geq = geqdefault - -instance (GEq a, GEq b, GEq c, GEq d, GEq e, GEq f) - => GEq (a, b, c, d, e, f) where - geq = geqdefault - -instance (GEq a, GEq b, GEq c, GEq d, GEq e, GEq f, GEq g) - => GEq (a, b, c, d, e, f, g) where - geq = geqdefault - -instance GEq a => GEq [a] where - geq = geqdefault - -instance (GEq (f p), GEq (g p)) => GEq ((f :+: g) p) where - geq = geqdefault - -instance (GEq (f p), GEq (g p)) => GEq ((f :*: g) p) where - geq = geqdefault - -instance GEq (f (g p)) => GEq ((f :.: g) p) where - geq = geqdefault - -instance GEq All where - geq = geqdefault - -#if MIN_VERSION_base(4,8,0) -instance GEq (f a) => GEq (Alt f a) where - geq = geqdefault -#endif - -instance GEq Any where - geq = geqdefault - -instance GEq Arity where - geq = geqdefault - -instance GEq Associativity where - geq = geqdefault - -instance GEq Bool where - geq = geqdefault - -instance GEq BufferMode where - geq = (==) - -#if defined(HTYPE_CC_T) -instance GEq CCc where - geq = (==) -#endif - -instance GEq CChar where - geq = (==) - -instance GEq CClock where - geq = (==) - -#if defined(HTYPE_DEV_T) -instance GEq CDev where - geq = (==) -#endif - -instance GEq CDouble where - geq = (==) - -instance GEq CFloat where - geq = (==) - -#if defined(HTYPE_GID_T) -instance GEq CGid where - geq = (==) -#endif - -instance GEq Char where - geq = (==) - -#if defined(HTYPE_INO_T) -instance GEq CIno where - geq = (==) -#endif - -instance GEq CInt where - geq = (==) - -instance GEq CIntMax where - geq = (==) - -instance GEq CIntPtr where - geq = (==) - -instance GEq CLLong where - geq = (==) - -instance GEq CLong where - geq = (==) - -#if defined(HTYPE_MODE_T) -instance GEq CMode where - geq = (==) -#endif - -#if defined(HTYPE_NLINK_T) -instance GEq CNlink where - geq = (==) -#endif - -#if defined(HTYPE_OFF_T) -instance GEq COff where - geq = (==) -#endif - -instance GEq a => GEq (Const a b) where - geq = geqdefault - -#if defined(HTYPE_PID_T) -instance GEq CPid where - geq = (==) -#endif - -instance GEq CPtrdiff where - geq = (==) - -#if defined(HTYPE_RLIM_T) -instance GEq CRLim where - geq = (==) -#endif - -instance GEq CSChar where - geq = (==) - -#if defined(HTYPE_SPEED_T) -instance GEq CSpeed where - geq = (==) -#endif - -#if MIN_VERSION_base(4,4,0) -instance GEq CSUSeconds where - geq = (==) -#endif - -instance GEq CShort where - geq = (==) - -instance GEq CSigAtomic where - geq = (==) - -instance GEq CSize where - geq = (==) - -#if defined(HTYPE_SSIZE_T) -instance GEq CSsize where - geq = (==) -#endif - -#if defined(HTYPE_TCFLAG_T) -instance GEq CTcflag where - geq = (==) -#endif - -instance GEq CTime where - geq = (==) - -instance GEq CUChar where - geq = (==) - -#if defined(HTYPE_UID_T) -instance GEq CUid where - geq = (==) -#endif - -instance GEq CUInt where - geq = (==) - -instance GEq CUIntMax where - geq = (==) - -instance GEq CUIntPtr where - geq = (==) - -instance GEq CULLong where - geq = (==) - -instance GEq CULong where - geq = (==) - -#if MIN_VERSION_base(4,4,0) -instance GEq CUSeconds where - geq = (==) -#endif - -instance GEq CUShort where - geq = (==) - -instance GEq CWchar where - geq = (==) - -instance GEq Double where - geq = (==) - -instance GEq a => GEq (Dual a) where - geq = geqdefault - -instance (GEq a, GEq b) => GEq (Either a b) where - geq = geqdefault - -instance GEq Errno where - geq = (==) - -instance GEq ExitCode where - geq = (==) - -instance GEq Fd where - geq = (==) - -instance GEq a => GEq (First a) where - geq = geqdefault - -instance GEq Fixity where - geq = geqdefault - -instance GEq Float where - geq = (==) - -instance GEq (ForeignPtr a) where - geq = (==) - -instance GEq (FunPtr a) where - geq = (==) - -instance GEq GeneralCategory where - geq = (==) - -instance GEq Handle where - geq = (==) - -instance GEq HandlePosn where - geq = (==) - -#if MIN_VERSION_base(4,8,0) -instance GEq a => GEq (Identity a) where - geq = geqdefault -#endif - -instance GEq Int where - geq = (==) - -instance GEq Int8 where - geq = (==) - -instance GEq Int16 where - geq = (==) - -instance GEq Int32 where - geq = (==) - -instance GEq Int64 where - geq = (==) - -instance GEq Integer where - geq = (==) - -instance GEq IntPtr where - geq = (==) - -instance GEq IOError where - geq = (==) - -instance GEq IOErrorType where - geq = (==) - -instance GEq IOMode where - geq = (==) - -instance GEq c => GEq (K1 i c p) where - geq = geqdefault - -instance GEq a => GEq (Last a) where - geq = geqdefault - -instance GEq (f p) => GEq (M1 i c f p) where - geq = geqdefault - -instance GEq a => GEq (Maybe a) where - geq = geqdefault - -#if MIN_VERSION_base(4,8,0) -instance GEq Natural where - geq = (==) -#endif - -instance GEq Ordering where - geq = geqdefault - -instance GEq p => GEq (Par1 p) where - geq = geqdefault - -instance GEq a => GEq (Product a) where - geq = geqdefault - -#if MIN_VERSION_base(4,7,0) -instance GEq (Proxy s) where - geq = geqdefault -#endif - -instance GEq (Ptr a) where - geq = (==) - -instance GEq (f p) => GEq (Rec1 f p) where - geq = geqdefault - -instance GEq SeekMode where - geq = (==) - -instance GEq (StablePtr a) where - geq = (==) - -instance GEq a => GEq (Sum a) where - geq = geqdefault - -instance GEq (U1 p) where - geq = geqdefault - -#if MIN_VERSION_base(4,8,0) -instance GEq Void where - geq = (==) -#endif - -instance GEq Word where - geq = (==) - -instance GEq Word8 where - geq = (==) - -instance GEq Word16 where - geq = (==) - -instance GEq Word32 where - geq = (==) - -instance GEq Word64 where - geq = (==) - -instance GEq WordPtr where - geq = (==) - -instance GEq a => GEq (ZipList a) where - geq = geqdefault +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MagicHash #-} + +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE DefaultSignatures #-} +#endif + +#include "HsBaseConfig.h" + +module Generics.Deriving.Eq ( + -- * Generic show class + GEq(..) + + -- * Default definition + , geqdefault + + ) where + +import Control.Applicative (Const, ZipList) + +import Data.Char (GeneralCategory) +import Data.Int +import 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 diff --git a/src/Generics/Deriving/Functor.hs b/src/Generics/Deriving/Functor.hs index db6150b..dcfa7b6 100644 --- a/src/Generics/Deriving/Functor.hs +++ b/src/Generics/Deriving/Functor.hs @@ -1,113 +1,113 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -module Generics.Deriving.Functor ( - -- * GFunctor class - GFunctor(..) - - -- * Default method - , gmapdefault - - ) where - -import Control.Applicative (Const, ZipList) - -import Data.Monoid (First, Last) - -import Generics.Deriving.Base -import Generics.Deriving.Instances () - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -import Data.Monoid (Alt) -#endif - --------------------------------------------------------------------------------- --- Generic fmap --------------------------------------------------------------------------------- - -class GFunctor' f where - gmap' :: (a -> b) -> f a -> f b - -instance GFunctor' U1 where - gmap' _ U1 = U1 - -instance GFunctor' Par1 where - gmap' f (Par1 a) = Par1 (f a) - -instance GFunctor' (K1 i c) where - gmap' _ (K1 a) = K1 a - -instance (GFunctor f) => GFunctor' (Rec1 f) where - gmap' f (Rec1 a) = Rec1 (gmap f a) - -instance (GFunctor' f) => GFunctor' (M1 i c f) where - gmap' f (M1 a) = M1 (gmap' f a) - -instance (GFunctor' f, GFunctor' g) => GFunctor' (f :+: g) where - gmap' f (L1 a) = L1 (gmap' f a) - gmap' f (R1 a) = R1 (gmap' f a) - -instance (GFunctor' f, GFunctor' g) => GFunctor' (f :*: g) where - gmap' f (a :*: b) = gmap' f a :*: gmap' f b - -instance (GFunctor f, GFunctor' g) => GFunctor' (f :.: g) where - gmap' f (Comp1 x) = Comp1 (gmap (gmap' f) x) - - -class GFunctor f where - gmap :: (a -> b) -> f a -> f b -#if __GLASGOW_HASKELL__ >= 701 - default gmap :: (Generic1 f, GFunctor' (Rep1 f)) - => (a -> b) -> f a -> f b - gmap = gmapdefault -#endif - -gmapdefault :: (Generic1 f, GFunctor' (Rep1 f)) - => (a -> b) -> f a -> f b -gmapdefault f = to1 . gmap' f . from1 - --- Base types instances -instance GFunctor ((->) r) where - gmap = fmap - -instance GFunctor ((,) a) where - gmap = gmapdefault - -instance GFunctor [] where - gmap = gmapdefault - -#if MIN_VERSION_base(4,8,0) -instance GFunctor f => GFunctor (Alt f) where - gmap = gmapdefault -#endif - -instance GFunctor (Const m) where - gmap = gmapdefault - -instance GFunctor (Either a) where - gmap = gmapdefault - -instance GFunctor First where - gmap = gmapdefault - -#if MIN_VERSION_base(4,8,0) -instance GFunctor Identity where - gmap = gmapdefault -#endif - -instance GFunctor IO where - gmap = fmap - -instance GFunctor Last where - gmap = gmapdefault - -instance GFunctor Maybe where - gmap = gmapdefault - -instance GFunctor ZipList where - gmap = gmapdefault +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE 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 diff --git a/src/Generics/Deriving/Instances.hs b/src/Generics/Deriving/Instances.hs index e7057d6..6b62b96 100644 --- a/src/Generics/Deriving/Instances.hs +++ b/src/Generics/Deriving/Instances.hs @@ -1,1462 +1,1462 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Generics.Deriving.Instances ( --- Only instances from Generics.Deriving.Base --- and the Generic1 instances -#if __GLASGOW_HASKELL__ < 711 - Rep0UAddr - , Rep0UChar - , Rep0UDouble - , Rep0UFloat - , Rep0UInt - , Rep0UWord -#endif -#if __GLASGOW_HASKELL__ < 708 - , Rep0All - , Rep0Any - , Rep0Arity - , Rep0Associativity - , Rep0Const - , Rep1Const - , Rep0Dual - , Rep1Dual - , Rep0Endo - , Rep0First - , Rep1First - , Rep0Fixity - , Rep0Last - , Rep1Last - , Rep0Product - , Rep1Product - , Rep0Sum - , Rep1Sum - , Rep0WrappedArrow - , Rep1WrappedArrow - , Rep0WrappedMonad - , Rep1WrappedMonad - , Rep0ZipList - , Rep1ZipList - , Rep0U1 - , Rep0Par1 - , Rep0Rec1 - , Rep0K1 - , Rep0M1 - , Rep0ConSum - , Rep0ConProduct - , Rep0ConCompose -#endif -#if __GLASGOW_HASKELL__ < 705 - , Rep1Either - , Rep1List - , Rep1Maybe - , Rep1Tuple2 - , Rep1Tuple3 - , Rep1Tuple4 - , Rep1Tuple5 - , Rep1Tuple6 - , Rep1Tuple7 -#endif -#if __GLASGOW_HASKELL__ < 701 - -- * Representations for base types - , Rep0Bool - , Rep0Char - , Rep0Double - , Rep0Either - , Rep0Int - , Rep0Float - , Rep0List - , Rep0Maybe - , Rep0Ordering - , Rep0Tuple2 - , Rep0Tuple3 - , Rep0Tuple4 - , Rep0Tuple5 - , Rep0Tuple6 - , Rep0Tuple7 - , Rep0Unit -#endif - ) where - -#if __GLASGOW_HASKELL__ < 708 -import Control.Applicative -import Data.Monoid -#endif - -#if __GLASGOW_HASKELL__ < 711 -import Generics.Deriving.Base -#endif - -#if __GLASGOW_HASKELL__ < 711 -type Rep0UAddr p = D1 D1UAddr (C1 C1_0UAddr (S1 S1_0_0UAddr UAddr)) - -instance Generic (UAddr p) where - type Rep (UAddr p) = Rep0UAddr p - from (UAddr a) = M1 (M1 (M1 (UAddr a))) - to (M1 (M1 (M1 (UAddr a)))) = UAddr a - -data D1UAddr -data C1_0UAddr -data S1_0_0UAddr - -instance Datatype D1UAddr where - datatypeName _ = "UAddr" - moduleName _ = "Generics.Deriving.Base" - -instance Constructor C1_0UAddr where - conName _ = "UAddr" - conIsRecord _ = True - -instance Selector S1_0_0UAddr where - selName _ = "uAddr#" - ------ - -type Rep0UChar p = D1 D1UChar (C1 C1_0UChar (S1 S1_0_0UChar UChar)) - -instance Generic (UChar p) where - type Rep (UChar p) = Rep0UChar p - from (UChar c) = M1 (M1 (M1 (UChar c))) - to (M1 (M1 (M1 (UChar c)))) = UChar c - -data D1UChar -data C1_0UChar -data S1_0_0UChar - -instance Datatype D1UChar where - datatypeName _ = "UChar" - moduleName _ = "Generics.Deriving.Base" - -instance Constructor C1_0UChar where - conName _ = "UChar" - conIsRecord _ = True - -instance Selector S1_0_0UChar where - selName _ = "uChar#" - ------ - -type Rep0UDouble p = D1 D1UDouble (C1 C1_0UDouble (S1 S1_0_0UDouble UDouble)) - -instance Generic (UDouble p) where - type Rep (UDouble p) = Rep0UDouble p - from (UDouble d) = M1 (M1 (M1 (UDouble d))) - to (M1 (M1 (M1 (UDouble d)))) = UDouble d - -data D1UDouble -data C1_0UDouble -data S1_0_0UDouble - -instance Datatype D1UDouble where - datatypeName _ = "UDouble" - moduleName _ = "Generics.Deriving.Base" - -instance Constructor C1_0UDouble where - conName _ = "UDouble" - conIsRecord _ = True - -instance Selector S1_0_0UDouble where - selName _ = "uDouble#" - ------ - -type Rep0UFloat p = D1 D1UFloat (C1 C1_0UFloat (S1 S1_0_0UFloat UFloat)) - -instance Generic (UFloat p) where - type Rep (UFloat p) = Rep0UFloat p - from (UFloat f) = M1 (M1 (M1 (UFloat f))) - to (M1 (M1 (M1 (UFloat f)))) = UFloat f - -data D1UFloat -data C1_0UFloat -data S1_0_0UFloat - -instance Datatype D1UFloat where - datatypeName _ = "UFloat" - moduleName _ = "Generics.Deriving.Base" - -instance Constructor C1_0UFloat where - conName _ = "UFloat" - conIsRecord _ = True - -instance Selector S1_0_0UFloat where - selName _ = "uFloat#" - ------ - -type Rep0UInt p = D1 D1UInt (C1 C1_0UInt (S1 S1_0_0UInt UInt)) - -instance Generic (UInt p) where - type Rep (UInt p) = Rep0UInt p - from (UInt i) = M1 (M1 (M1 (UInt i))) - to (M1 (M1 (M1 (UInt i)))) = UInt i - -data D1UInt -data C1_0UInt -data S1_0_0UInt - -instance Datatype D1UInt where - datatypeName _ = "UInt" - moduleName _ = "Generics.Deriving.Base" - -instance Constructor C1_0UInt where - conName _ = "UInt" - conIsRecord _ = True - -instance Selector S1_0_0UInt where - selName _ = "uInt#" - ------ - -type Rep0UWord p = D1 D1UWord (C1 C1_0UWord (S1 S1_0_0UWord UWord)) - -instance Generic (UWord p) where - type Rep (UWord p) = Rep0UWord p - from (UWord w) = M1 (M1 (M1 (UWord w))) - to (M1 (M1 (M1 (UWord w)))) = UWord w - -data D1UWord -data C1_0UWord -data S1_0_0UWord - -instance Datatype D1UWord where - datatypeName _ = "UWord" - moduleName _ = "Generics.Deriving.Base" - -instance Constructor C1_0UWord where - conName _ = "UWord" - conIsRecord _ = True - -instance Selector S1_0_0UWord where - selName _ = "uWord#" -#endif - ------ - -#if __GLASGOW_HASKELL__ < 708 --------------------------------------------------------------------------------- --- Representations for base types --------------------------------------------------------------------------------- - -type Rep0All = D1 D1All (C1 C1_0All (S1 S1_0_0All (Rec0 Bool))) - -instance Generic All where - type Rep All = Rep0All - from (All a) = M1 (M1 (M1 (K1 a))) - to (M1 (M1 (M1 (K1 a)))) = All a - -data D1All -data C1_0All -data S1_0_0All - -instance Datatype D1All where - datatypeName _ = "All" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0All where - conName _ = "All" - conIsRecord _ = True - -instance Selector S1_0_0All where - selName _ = "getAll" - ------ - -type Rep0Any = D1 D1Any (C1 C1_0Any (S1 S1_0_0Any (Rec0 Bool))) - -instance Generic Any where - type Rep Any = Rep0Any - from (Any a) = M1 (M1 (M1 (K1 a))) - to (M1 (M1 (M1 (K1 a)))) = Any a - -data D1Any -data C1_0Any -data S1_0_0Any - -instance Datatype D1Any where - datatypeName _ = "Any" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0Any where - conName _ = "Any" - conIsRecord _ = True - -instance Selector S1_0_0Any where - selName _ = "getAny" - ------ - -type Rep0Arity = D1 D1Arity (C1 C1_0Arity U1 - :+: C1 C1_1Arity (S1 NoSelector (Rec0 Int))) - -instance Generic Arity where - type Rep Arity = Rep0Arity - - from NoArity = M1 (L1 (M1 U1)) - from (Arity a) = M1 (R1 (M1 (M1 (K1 a)))) - - to (M1 (L1 (M1 U1))) = NoArity - to (M1 (R1 (M1 (M1 (K1 a))))) = Arity a - -data D1Arity -data C1_0Arity -data C1_1Arity - -instance Datatype D1Arity where - datatypeName _ = "Arity" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0Arity where - conName _ = "NoArity" - -instance Constructor C1_1Arity where - conName _ = "Arity" - ------ - -type Rep0Associativity = D1 D1Associativity (C1 C1_0Associativity U1 - :+: (C1 C1_1Associativity U1 - :+: C1 C1_2Associativity U1)) - -instance Generic Associativity where - type Rep Associativity = Rep0Associativity - - from LeftAssociative = M1 (L1 (M1 U1)) - from RightAssociative = M1 (R1 (L1 (M1 U1))) - from NotAssociative = M1 (R1 (R1 (M1 U1))) - - to (M1 (L1 (M1 U1))) = LeftAssociative - to (M1 (R1 (L1 (M1 U1)))) = RightAssociative - to (M1 (R1 (R1 (M1 U1)))) = NotAssociative - -data D1Associativity -data C1_0Associativity -data C1_1Associativity -data C1_2Associativity - -instance Datatype D1Associativity where - datatypeName _ = "Associativity" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0Associativity where - conName _ = "LeftAssociative" - -instance Constructor C1_1Associativity where - conName _ = "RightAssociative" - -instance Constructor C1_2Associativity where - conName _ = "NotAssociative" - ------ - -type Rep0Const a b = D1 D1Const (C1 C1_0Const (S1 S1_0_0Const (Rec0 a))) -type Rep1Const a = D1 D1Const (C1 C1_0Const (S1 S1_0_0Const (Rec0 a))) - -instance Generic (Const a b) where - type Rep (Const a b) = Rep0Const a b - from (Const a) = M1 (M1 (M1 (K1 a))) - to (M1 (M1 (M1 (K1 a)))) = Const a - -instance Generic1 (Const a) where - type Rep1 (Const a) = Rep1Const a - from1 (Const a) = M1 (M1 (M1 (K1 a))) - to1 (M1 (M1 (M1 (K1 a)))) = Const a - -data D1Const -data C1_0Const -data S1_0_0Const - -instance Datatype D1Const where - datatypeName _ = "Const" - moduleName _ = "Control.Applicative" - -instance Constructor C1_0Const where - conName _ = "Const" - conIsRecord _ = True - -instance Selector S1_0_0Const where - selName _ = "getConst" - ------ - -type Rep0Dual a = D1 D1Dual (C1 C1_0Dual (S1 S1_0_0Dual (Rec0 a))) -type Rep1Dual = D1 D1Dual (C1 C1_0Dual (S1 S1_0_0Dual Par1)) - -instance Generic (Dual a) where - type Rep (Dual a) = Rep0Dual a - from (Dual d) = M1 (M1 (M1 (K1 d))) - to (M1 (M1 (M1 (K1 d)))) = Dual d - -instance Generic1 Dual where - type Rep1 Dual = Rep1Dual - from1 (Dual d) = M1 (M1 (M1 (Par1 d))) - to1 (M1 (M1 (M1 (Par1 d)))) = Dual d - -data D1Dual -data C1_0Dual -data S1_0_0Dual - -instance Datatype D1Dual where - datatypeName _ = "Dual" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0Dual where - conName _ = "Dual" - conIsRecord _ = True - -instance Selector S1_0_0Dual where - selName _ = "getDual" - ------ - -type Rep0Endo a = D1 D1Endo (C1 C1_0Endo (S1 S1_0_0Endo (Rec0 (a -> a)))) - -instance Generic (Endo a) where - type Rep (Endo a) = Rep0Endo a - from (Endo e) = M1 (M1 (M1 (K1 e))) - to (M1 (M1 (M1 (K1 e)))) = Endo e - -data D1Endo -data C1_0Endo -data S1_0_0Endo - -instance Datatype D1Endo where - datatypeName _ = "Endo" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0Endo where - conName _ = "Endo" - conIsRecord _ = True - -instance Selector S1_0_0Endo where - selName _ = "appEndo" - ------ - -type Rep0First a = D1 D1First (C1 C1_0First (S1 S1_0_0First (Rec0 (Maybe a)))) -type Rep1First = D1 D1First (C1 C1_0First (S1 S1_0_0First (Rec1 Maybe))) - -instance Generic (First a) where - type Rep (First a) = Rep0First a - from (First f) = M1 (M1 (M1 (K1 f))) - to (M1 (M1 (M1 (K1 f)))) = First f - -instance Generic1 First where - type Rep1 First = Rep1First - from1 (First f) = M1 (M1 (M1 (Rec1 f))) - to1 (M1 (M1 (M1 (Rec1 f)))) = First f - -data D1First -data C1_0First -data S1_0_0First - -instance Datatype D1First where - datatypeName _ = "First" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0First where - conName _ = "First" - conIsRecord _ = True - -instance Selector S1_0_0First where - selName _ = "getFirst" - ------ - -type Rep0Fixity = D1 D1Fixity (C1 C1_0Fixity U1 - :+: C1 C1_1Fixity (S1 NoSelector (Rec0 Associativity) - :*: S1 NoSelector (Rec0 Int))) - -instance Generic Fixity where - type Rep Fixity = Rep0Fixity - - from Prefix = M1 (L1 (M1 U1)) - from (Infix a i) = M1 (R1 (M1 (M1 (K1 a) :*: M1 (K1 i)))) - - to (M1 (L1 (M1 U1))) = Prefix - to (M1 (R1 (M1 (M1 (K1 a) :*: M1 (K1 i))))) = Infix a i - -data D1Fixity -data C1_0Fixity -data C1_1Fixity - -instance Datatype D1Fixity where - datatypeName _ = "Fixity" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0Fixity where - conName _ = "Prefix" - -instance Constructor C1_1Fixity where - conName _ = "Infix" - ------ - -type Rep0Last a = D1 D1Last (C1 C1_0Last (S1 S1_0_0Last (Rec0 (Maybe a)))) -type Rep1Last = D1 D1Last (C1 C1_0Last (S1 S1_0_0Last (Rec1 Maybe))) - -instance Generic (Last a) where - type Rep (Last a) = Rep0Last a - from (Last l) = M1 (M1 (M1 (K1 l))) - to (M1 (M1 (M1 (K1 l)))) = Last l - -instance Generic1 Last where - type Rep1 Last = Rep1Last - from1 (Last l) = M1 (M1 (M1 (Rec1 l))) - to1 (M1 (M1 (M1 (Rec1 l)))) = Last l - -data D1Last -data C1_0Last -data S1_0_0Last - -instance Datatype D1Last where - datatypeName _ = "Last" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0Last where - conName _ = "Last" - conIsRecord _ = True - -instance Selector S1_0_0Last where - selName _ = "getLast" - ------ - -type Rep0Product a = D1 D1Product (C1 C1_0Product (S1 S1_0_0Product (Rec0 a))) -type Rep1Product = D1 D1Product (C1 C1_0Product (S1 S1_0_0Product Par1)) - -instance Generic (Product a) where - type Rep (Product a) = Rep0Product a - from (Product p) = M1 (M1 (M1 (K1 p))) - to (M1 (M1 (M1 (K1 p)))) = Product p - -instance Generic1 Product where - type Rep1 Product = Rep1Product - from1 (Product p) = M1 (M1 (M1 (Par1 p))) - to1 (M1 (M1 (M1 (Par1 p)))) = Product p - -data D1Product -data C1_0Product -data S1_0_0Product - -instance Datatype D1Product where - datatypeName _ = "Product" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0Product where - conName _ = "Product" - conIsRecord _ = True - -instance Selector S1_0_0Product where - selName _ = "getProduct" - ------ - -type Rep0Sum a = D1 D1Sum (C1 C1_0Sum (S1 S1_0_0Sum (Rec0 a))) -type Rep1Sum = D1 D1Sum (C1 C1_0Sum (S1 S1_0_0Sum Par1)) - -instance Generic (Sum a) where - type Rep (Sum a) = Rep0Sum a - from (Sum s) = M1 (M1 (M1 (K1 s))) - to (M1 (M1 (M1 (K1 s)))) = Sum s - -instance Generic1 Sum where - type Rep1 Sum = Rep1Sum - from1 (Sum s) = M1 (M1 (M1 (Par1 s))) - to1 (M1 (M1 (M1 (Par1 s)))) = Sum s - -data D1Sum -data C1_0Sum -data S1_0_0Sum - -instance Datatype D1Sum where - datatypeName _ = "Sum" - moduleName _ = "Data.Monoid" - -instance Constructor C1_0Sum where - conName _ = "Sum" - conIsRecord _ = True - -instance Selector S1_0_0Sum where - selName _ = "getSum" - ------ - -type Rep0WrappedArrow a b c = - D1 D1WrappedArrow (C1 C1_0WrappedArrow (S1 S1_0_0WrappedArrow (Rec0 (a b c)))) -type Rep1WrappedArrow a b = - D1 D1WrappedArrow (C1 C1_0WrappedArrow (S1 S1_0_0WrappedArrow (Rec1 (a b)))) - -instance Generic (WrappedArrow a b c) where - type Rep (WrappedArrow a b c) = Rep0WrappedArrow a b c - from (WrapArrow a) = M1 (M1 (M1 (K1 a))) - to (M1 (M1 (M1 (K1 a)))) = WrapArrow a - -instance Generic1 (WrappedArrow a b) where - type Rep1 (WrappedArrow a b) = Rep1WrappedArrow a b - from1 (WrapArrow a) = M1 (M1 (M1 (Rec1 a))) - to1 (M1 (M1 (M1 (Rec1 a)))) = WrapArrow a - -data D1WrappedArrow -data C1_0WrappedArrow -data S1_0_0WrappedArrow - -instance Datatype D1WrappedArrow where - datatypeName _ = "WrappedArrow" - moduleName _ = "Control.Applicative" - -instance Constructor C1_0WrappedArrow where - conName _ = "WrapArrow" - conIsRecord _ = True - -instance Selector S1_0_0WrappedArrow where - selName _ = "unwrapArrow" - ------ - -type Rep0WrappedMonad m a = - D1 D1WrappedMonad (C1 C1_0WrappedMonad (S1 S1_0_0WrappedMonad (Rec0 (m a)))) -type Rep1WrappedMonad m = - D1 D1WrappedMonad (C1 C1_0WrappedMonad (S1 S1_0_0WrappedMonad (Rec1 m))) - -instance Generic (WrappedMonad m a) where - type Rep (WrappedMonad m a) = Rep0WrappedMonad m a - from (WrapMonad m) = M1 (M1 (M1 (K1 m))) - to (M1 (M1 (M1 (K1 m)))) = WrapMonad m - -instance Generic1 (WrappedMonad m) where - type Rep1 (WrappedMonad m) = Rep1WrappedMonad m - from1 (WrapMonad m) = M1 (M1 (M1 (Rec1 m))) - to1 (M1 (M1 (M1 (Rec1 m)))) = WrapMonad m - -data D1WrappedMonad -data C1_0WrappedMonad -data S1_0_0WrappedMonad - -instance Datatype D1WrappedMonad where - datatypeName _ = "WrappedMonad" - moduleName _ = "Control.Applicative" - -instance Constructor C1_0WrappedMonad where - conName _ = "WrapMonad" - conIsRecord _ = True - -instance Selector S1_0_0WrappedMonad where - selName _ = "unwrapMonad" - ------ - -type Rep0ZipList a = D1 D1ZipList (C1 C1_0ZipList (S1 S1_0_0ZipList (Rec0 [a]))) -type Rep1ZipList = D1 D1ZipList (C1 C1_0ZipList (S1 S1_0_0ZipList (Rec1 []))) - -instance Generic (ZipList a) where - type Rep (ZipList a) = Rep0ZipList a - from (ZipList z) = M1 (M1 (M1 (K1 z))) - to (M1 (M1 (M1 (K1 z)))) = ZipList z - -instance Generic1 ZipList where - type Rep1 ZipList = Rep1ZipList - from1 (ZipList z) = M1 (M1 (M1 (Rec1 z))) - to1 (M1 (M1 (M1 (Rec1 z)))) = ZipList z - -data D1ZipList -data C1_0ZipList -data S1_0_0ZipList - -instance Datatype D1ZipList where - datatypeName _ = "ZipList" - moduleName _ = "Control.Applicative" - -instance Constructor C1_0ZipList where - conName _ = "ZipList" - conIsRecord _ = True - -instance Selector S1_0_0ZipList where - selName _ = "getZipList" - ------ - -type Rep0U1 p = D1 D1U1 (C1 C1_0U1 U1) - -instance Generic (U1 p) where - type Rep (U1 p) = Rep0U1 p - from U1 = M1 (M1 U1) - to (M1 (M1 U1)) = U1 - -data D1U1 -data C1_0U1 - -instance Datatype D1U1 where - datatypeName _ = "U1" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0U1 where - conName _ = "U1" - ------ - -type Rep0Par1 p = D1 D1Par1 (C1 C1_0Par1 (S1 S1_0_0Par1 (Rec0 p))) - -instance Generic (Par1 p) where - type Rep (Par1 p) = Rep0Par1 p - from (Par1 p) = M1 (M1 (M1 (K1 p))) - to (M1 (M1 (M1 (K1 p)))) = Par1 p - -data D1Par1 -data C1_0Par1 -data S1_0_0Par1 - -instance Datatype D1Par1 where - datatypeName _ = "Par1" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0Par1 where - conName _ = "Par1" - conIsRecord _ = True - -instance Selector S1_0_0Par1 where - selName _ = "unPar1" - ------ - -type Rep0Rec1 f p = D1 D1Rec1 (C1 C1_0Rec1 (S1 S1_0_0Rec1 (Rec0 (f p)))) - -instance Generic (Rec1 f p) where - type Rep (Rec1 f p) = Rep0Rec1 f p - from (Rec1 r) = M1 (M1 (M1 (K1 r))) - to (M1 (M1 (M1 (K1 r)))) = Rec1 r - -data D1Rec1 -data C1_0Rec1 -data S1_0_0Rec1 - -instance Datatype D1Rec1 where - datatypeName _ = "Rec1" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0Rec1 where - conName _ = "Rec1" - conIsRecord _ = True - -instance Selector S1_0_0Rec1 where - selName _ = "unRec1" - ------ - -type Rep0K1 i c p = D1 D1K1 (C1 C1_0K1 (S1 S1_0_0K1 (Rec0 c))) - -instance Generic (K1 i c p) where - type Rep (K1 i c p) = Rep0K1 i c p - from (K1 c) = M1 (M1 (M1 (K1 c))) - to (M1 (M1 (M1 (K1 c)))) = K1 c - -data D1K1 -data C1_0K1 -data S1_0_0K1 - -instance Datatype D1K1 where - datatypeName _ = "K1" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0K1 where - conName _ = "K1" - conIsRecord _ = True - -instance Selector S1_0_0K1 where - selName _ = "unK1" - ------ - -type Rep0M1 i c f p = D1 D1M1 (C1 C1_0M1 (S1 S1_0_0M1 (Rec0 (f p)))) - -instance Generic (M1 i c f p) where - type Rep (M1 i c f p) = Rep0M1 i c f p - from (M1 m) = M1 (M1 (M1 (K1 m))) - to (M1 (M1 (M1 (K1 m)))) = M1 m - -data D1M1 -data C1_0M1 -data S1_0_0M1 - -instance Datatype D1M1 where - datatypeName _ = "M1" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0M1 where - conName _ = "M1" - conIsRecord _ = True - -instance Selector S1_0_0M1 where - selName _ = "unM1" - ------ - -type Rep0ConSum f g p = D1 D1ConSum (C1 C1_0ConSum (S1 NoSelector (Rec0 (f p))) - :+: C1 C1_1ConSum (S1 NoSelector (Rec0 (g p)))) - -instance Generic ((f :+: g) p) where - type Rep ((f :+: g) p) = Rep0ConSum f g p - - from (L1 l) = M1 (L1 (M1 (M1 (K1 l)))) - from (R1 r) = M1 (R1 (M1 (M1 (K1 r)))) - - to (M1 (L1 (M1 (M1 (K1 l))))) = L1 l - to (M1 (R1 (M1 (M1 (K1 r))))) = R1 r - -data D1ConSum -data C1_0ConSum -data C1_1ConSum - -instance Datatype D1ConSum where - datatypeName _ = ":+:" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0ConSum where - conName _ = "L1" - -instance Constructor C1_1ConSum where - conName _ = "R1" - ------ - -type Rep0ConProduct f g p = - D1 D1ConProduct (C1 C1_ConProduct (S1 NoSelector (Rec0 (f p)) - :*: S1 NoSelector (Rec0 (g p)))) - -instance Generic ((f :*: g) p) where - type Rep ((f :*: g) p) = Rep0ConProduct f g p - from (f :*: g) = M1 (M1 (M1 (K1 f) :*: M1 (K1 g))) - to (M1 (M1 (M1 (K1 f) :*: M1 (K1 g)))) = f :*: g - -data D1ConProduct -data C1_ConProduct - -instance Datatype D1ConProduct where - datatypeName _ = ":*:" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_ConProduct where - conName _ = ":*:" - conFixity _ = Infix RightAssociative 6 - ------ - -type Rep0ConCompose f g p = - D1 D1ConCompose (C1 C1_0ConCompose (S1 S1_0_0ConCompose (Rec0 (f (g p))))) - -instance Generic ((f :.: g) p) where - type Rep ((f :.: g) p) = Rep0ConCompose f g p - from (Comp1 c) = M1 (M1 (M1 (K1 c))) - to (M1 (M1 (M1 (K1 c)))) = Comp1 c - -data D1ConCompose -data C1_0ConCompose -data S1_0_0ConCompose - -instance Datatype D1ConCompose where - datatypeName _ = ":.:" -# if __GLASGOW_HASKELL < 701 - moduleName _ = "Generics.Deriving.Base" -# else - moduleName _ = "GHC.Generics" -# endif - -instance Constructor C1_0ConCompose where - conName _ = "Comp1" - conIsRecord _ = True - -instance Selector S1_0_0ConCompose where - selName _ = "unComp1" -#endif - ------ - -#if __GLASGOW_HASKELL__ < 705 -type Rep1List = D1 D1List (C1 C1_0List U1 :+: - C1 C1_1List (S1 NoSelector Par1 - :*: S1 NoSelector (Rec1 []))) - -instance Generic1 [] where - type Rep1 [] = Rep1List - - from1 [] = M1 (L1 (M1 U1)) - from1 (h:t) = M1 (R1 (M1 (M1 (Par1 h) :*: M1 (Rec1 t)))) - - to1 (M1 (L1 (M1 U1))) = [] - to1 (M1 (R1 (M1 (M1 (Par1 h) :*: M1 (Rec1 t))))) = h : t - -data D1List -data C1_0List -data C1_1List - -instance Datatype D1List where - datatypeName _ = "[]" - moduleName _ = "GHC.Types" - -instance Constructor C1_0List where - conName _ = "[]" - -instance Constructor C1_1List where - conName _ = ":" - conFixity _ = Infix RightAssociative 5 - ------ - -type Rep1Either a = D1 D1Either (C1 C1_0Either (S1 NoSelector (Rec0 a)) - :+: C1 C1_1Either (S1 NoSelector Par1)) - -instance Generic1 (Either a) where - type Rep1 (Either a) = Rep1Either a - - from1 (Left l) = M1 (L1 (M1 (M1 (K1 l)))) - from1 (Right r) = M1 (R1 (M1 (M1 (Par1 r)))) - - to1 (M1 (L1 (M1 (M1 (K1 l))))) = Left l - to1 (M1 (R1 (M1 (M1 (Par1 r))))) = Right r - -data D1Either -data C1_0Either -data C1_1Either - -instance Datatype D1Either where - datatypeName _ = "Either" - moduleName _ = "Data.Either" - -instance Constructor C1_0Either where - conName _ = "Left" - -instance Constructor C1_1Either where - conName _ = "Right" - ------ - -type Rep1Maybe = D1 D1Maybe (C1 C1_0Maybe U1 - :+: C1 C1_1Maybe (S1 NoSelector Par1)) - -instance Generic1 Maybe where - type Rep1 Maybe = Rep1Maybe - - from1 Nothing = M1 (L1 (M1 U1)) - from1 (Just j) = M1 (R1 (M1 (M1 (Par1 j)))) - - to1 (M1 (L1 (M1 U1))) = Nothing - to1 (M1 (R1 (M1 (M1 (Par1 j))))) = Just j - -data D1Maybe -data C1_0Maybe -data C1_1Maybe - -instance Datatype D1Maybe where - datatypeName _ = "Maybe" - -- As of base-4.7.0.0, Maybe is actually located in GHC.Base. - -- We don't need to worry about this for the versions of base - -- that this instance is defined for, however. - moduleName _ = "Data.Maybe" - -instance Constructor C1_0Maybe where - conName _ = "Nothing" - -instance Constructor C1_1Maybe where - conName _ = "Just" - ------ - -type Rep1Tuple2 a = D1 D1Tuple2 (C1 C1_0Tuple2 (S1 NoSelector (Rec0 a) - :*: S1 NoSelector Par1)) - -instance Generic1 ((,) a) where - type Rep1 ((,) a) = Rep1Tuple2 a - from1 (a, b) = M1 (M1 (M1 (K1 a) :*: M1 (Par1 b))) - to1 (M1 (M1 (M1 (K1 a) :*: M1 (Par1 b)))) = (a, b) - -data D1Tuple2 -data C1_0Tuple2 - -instance Datatype D1Tuple2 where - datatypeName _ = "(,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple2 where - conName _ = "(,)" - ------ - -type Rep1Tuple3 a b = D1 D1Tuple3 (C1 C1_0Tuple3 (S1 NoSelector (Rec0 a) - :*: (S1 NoSelector (Rec0 b) - :*: S1 NoSelector Par1))) - -instance Generic1 ((,,) a b) where - type Rep1 ((,,) a b) = Rep1Tuple3 a b - from1 (a, b, c) = M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (Par1 c)))) - to1 (M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (Par1 c))))) = (a, b, c) - -data D1Tuple3 -data C1_0Tuple3 - -instance Datatype D1Tuple3 where - datatypeName _ = "(,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple3 where - conName _ = "(,,)" - ------ - -type Rep1Tuple4 a b c = D1 D1Tuple4 (C1 C1_0Tuple4 ((S1 NoSelector (Rec0 a) - :*: S1 NoSelector (Rec0 b)) - :*: (S1 NoSelector (Rec0 c) - :*: S1 NoSelector Par1))) - -instance Generic1 ((,,,) a b c) where - type Rep1 ((,,,) a b c) = Rep1Tuple4 a b c - - from1 (a, b, c, d) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: M1 (Par1 d)))) - - to1 (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: M1 (Par1 d))))) - = (a, b, c, d) - -data D1Tuple4 -data C1_0Tuple4 - -instance Datatype D1Tuple4 where - datatypeName _ = "(,,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple4 where - conName _ = "(,,,)" - ------ - -type Rep1Tuple5 a b c d = D1 D1Tuple5 (C1 C1_0Tuple5 ((S1 NoSelector (Rec0 a) - :*: S1 NoSelector (Rec0 b)) - :*: (S1 NoSelector (Rec0 c) - :*: (S1 NoSelector (Rec0 d) - :*: S1 NoSelector Par1)))) - -instance Generic1 ((,,,,) a b c d) where - type Rep1 ((,,,,) a b c d) = Rep1Tuple5 a b c d - - from1 (a, b, c, d, e) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (Par1 e))))) - - to1 (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (Par1 e)))))) - = (a, b, c, d, e) - -data D1Tuple5 -data C1_0Tuple5 - -instance Datatype D1Tuple5 where - datatypeName _ = "(,,,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple5 where - conName _ = "(,,,,)" - ------ - -type Rep1Tuple6 a b c d e = - D1 D1Tuple6 (C1 C1_0Tuple6 ((S1 NoSelector (Rec0 a) - :*: (S1 NoSelector (Rec0 b) - :*: S1 NoSelector (Rec0 c))) - :*: (S1 NoSelector (Rec0 d) - :*: (S1 NoSelector (Rec0 e) - :*: S1 NoSelector Par1)))) - -instance Generic1 ((,,,,,) a b c d e) where - type Rep1 ((,,,,,) a b c d e) = Rep1Tuple6 a b c d e - - from1 (a, b, c, d, e, f) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (Par1 f))))) - - to1 (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (Par1 f)))))) - = (a, b, c, d, e, f) - -data D1Tuple6 -data C1_0Tuple6 - -instance Datatype D1Tuple6 where - datatypeName _ = "(,,,,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple6 where - conName _ = "(,,,,,)" - ------ - -type Rep1Tuple7 a b c d e f = - D1 D1Tuple7 (C1 C1_0Tuple7 ((S1 NoSelector (Rec0 a) - :*: (S1 NoSelector (Rec0 b) - :*: S1 NoSelector (Rec0 c))) - :*: ((S1 NoSelector (Rec0 d) - :*: S1 NoSelector (Rec0 e)) - :*: (S1 NoSelector (Rec0 f) - :*: S1 NoSelector Par1)))) - -instance Generic1 ((,,,,,,) a b c d e f) where - type Rep1 ((,,,,,,) a b c d e f) = Rep1Tuple7 a b c d e f - - from1 (a, b, c, d, e, f, g) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (Par1 g))))) - - to1 (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (Par1 g)))))) - = (a, b, c, d, e, f, g) - -data D1Tuple7 -data C1_0Tuple7 - -instance Datatype D1Tuple7 where - datatypeName _ = "(,,,,,,)" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Tuple7 where - conName _ = "(,,,,,,)" -#endif - ------ - -#if __GLASGOW_HASKELL__ < 701 -type Rep0Bool = D1 D1Bool (C1 C1_0Bool U1 :+: C1 C1_1Bool U1) - -instance Generic Bool where - type Rep Bool = Rep0Bool - - from False = M1 (L1 (M1 U1)) - from True = M1 (R1 (M1 U1)) - - to (M1 (L1 (M1 U1))) = False - to (M1 (R1 (M1 U1))) = True - -data D1Bool -data C1_0Bool -data C1_1Bool - -instance Datatype D1Bool where - datatypeName _ = "Bool" - moduleName _ = "GHC.Bool" - -instance Constructor C1_0Bool where - conName _ = "False" - -instance Constructor C1_1Bool where - conName _ = "True" - ------ - -data D_Char -data C_Char - -instance Datatype D_Char where - datatypeName _ = "Char" - moduleName _ = "GHC.Base" - -instance Constructor C_Char where - conName _ = "" -- JPM: I'm not sure this is the right implementation... - -type Rep0Char = D1 D_Char (C1 C_Char (S1 NoSelector (Rec0 Char))) - -instance Generic Char where - type Rep Char = Rep0Char - from x = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = x - ------ - -data D_Double -data C_Double - -instance Datatype D_Double where - datatypeName _ = "Double" - moduleName _ = "GHC.Float" - -instance Constructor C_Double where - conName _ = "" -- JPM: I'm not sure this is the right implementation... - -type Rep0Double = D1 D_Double (C1 C_Double (S1 NoSelector (Rec0 Double))) - -instance Generic Double where - type Rep Double = Rep0Double - from x = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = x - ------ - -type Rep0Either a b = D1 D1Either (C1 C1_0Either (S1 NoSelector (Rec0 a)) - :+: C1 C1_1Either (S1 NoSelector (Rec0 b))) - -instance Generic (Either a b) where - type Rep (Either a b) = Rep0Either a b - - from (Left l) = M1 (L1 (M1 (M1 (K1 l)))) - from (Right r) = M1 (R1 (M1 (M1 (K1 r)))) - - to (M1 (L1 (M1 (M1 (K1 l))))) = Left l - to (M1 (R1 (M1 (M1 (K1 r))))) = Right r - ------ - -data D_Int -data C_Int - -instance Datatype D_Int where - datatypeName _ = "Int" - moduleName _ = "GHC.Int" - -instance Constructor C_Int where - conName _ = "" -- JPM: I'm not sure this is the right implementation... - -type Rep0Int = D1 D_Int (C1 C_Int (S1 NoSelector (Rec0 Int))) - -instance Generic Int where - type Rep Int = Rep0Int - from x = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = x - ------ - -data D_Float -data C_Float - -instance Datatype D_Float where - datatypeName _ = "Float" - moduleName _ = "GHC.Float" - -instance Constructor C_Float where - conName _ = "" -- JPM: I'm not sure this is the right implementation... - -type Rep0Float = D1 D_Float (C1 C_Float (S1 NoSelector (Rec0 Float))) - -instance Generic Float where - type Rep Float = Rep0Float - from x = M1 (M1 (M1 (K1 x))) - to (M1 (M1 (M1 (K1 x)))) = x - ------ - -type Rep0List a = - D1 D1List (C1 C1_0List U1 :+: C1 C1_1List (S1 NoSelector (Rec0 a) - :*: S1 NoSelector (Rec0 [a]))) - -instance Generic [a] where - type Rep [a] = Rep0List a - - from [] = M1 (L1 (M1 U1)) - from (h:t) = M1 (R1 (M1 (M1 (K1 h) :*: M1 (K1 t)))) - - to (M1 (L1 (M1 U1))) = [] - to (M1 (R1 (M1 (M1 (K1 h) :*: M1 (K1 t))))) = h : t - ------ - -type Rep0Maybe a = D1 D1Maybe (C1 C1_0Maybe U1 - :+: C1 C1_1Maybe (S1 NoSelector (Rec0 a))) - -instance Generic (Maybe a) where - type Rep (Maybe a) = Rep0Maybe a - - from Nothing = M1 (L1 (M1 U1)) - from (Just j) = M1 (R1 (M1 (M1 (K1 j)))) - - to (M1 (L1 (M1 U1))) = Nothing - to (M1 (R1 (M1 (M1 (K1 j))))) = Just j - ------ - -type Rep0Ordering = D1 D1Ordering (C1 C1_0Ordering U1 - :+: (C1 C1_1Ordering U1 :+: C1 C1_2Ordering U1)) - -instance Generic Ordering where - type Rep Ordering = Rep0Ordering - - from LT = M1 (L1 (M1 U1)) - from EQ = M1 (R1 (L1 (M1 U1))) - from GT = M1 (R1 (R1 (M1 U1))) - - to (M1 (L1 (M1 U1))) = LT - to (M1 (R1 (L1 (M1 U1)))) = EQ - to (M1 (R1 (R1 (M1 U1)))) = GT - -data D1Ordering -data C1_0Ordering -data C1_1Ordering -data C1_2Ordering - -instance Datatype D1Ordering where - datatypeName _ = "Ordering" - moduleName _ = "GHC.Ordering" - -instance Constructor C1_0Ordering where - conName _ = "LT" - -instance Constructor C1_1Ordering where - conName _ = "EQ" - -instance Constructor C1_2Ordering where - conName _ = "GT" - ------ - -type Rep0Unit = D1 D1Unit (C1 C1_0Unit U1) - -instance Generic () where - type Rep () = Rep0Unit - from () = M1 (M1 U1) - to (M1 (M1 U1)) = () - -data D1Unit -data C1_0Unit - -instance Datatype D1Unit where - datatypeName _ = "()" - moduleName _ = "GHC.Tuple" - -instance Constructor C1_0Unit where - conName _ = "()" - ------ - -type Rep0Tuple2 a b = D1 D1Tuple2 (C1 C1_0Tuple2 (S1 NoSelector (Rec0 a) - :*: S1 NoSelector (Rec0 b))) - -instance Generic (a, b) where - type Rep (a, b) = Rep0Tuple2 a b - from (a, b) = M1 (M1 (M1 (K1 a) :*: M1 (K1 b))) - to (M1 (M1 (M1 (K1 a) :*: M1 (K1 b)))) = (a, b) - ------ - -type Rep0Tuple3 a b c = D1 D1Tuple3 (C1 C1_0Tuple3 (S1 NoSelector (Rec0 a) - :*: (S1 NoSelector (Rec0 b) - :*: S1 NoSelector (Rec0 c)))) - -instance Generic (a, b, c) where - type Rep (a, b, c) = Rep0Tuple3 a b c - from (a, b, c) = M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c)))) - to (M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))))) = (a, b, c) - ------ - -type Rep0Tuple4 a b c d = D1 D1Tuple4 (C1 C1_0Tuple4 ((S1 NoSelector (Rec0 a) - :*: S1 NoSelector (Rec0 b)) - :*: (S1 NoSelector (Rec0 c) - :*: S1 NoSelector (Rec0 d)))) - -instance Generic (a, b, c, d) where - type Rep (a, b, c, d) = Rep0Tuple4 a b c d - - from (a, b, c, d) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: M1 (K1 d)))) - - to (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: M1 (K1 d))))) - = (a, b, c, d) - ------ - -type Rep0Tuple5 a b c d e = D1 D1Tuple5 (C1 C1_0Tuple5 ((S1 NoSelector (Rec0 a) - :*: S1 NoSelector (Rec0 b)) - :*: (S1 NoSelector (Rec0 c) - :*: (S1 NoSelector (Rec0 d) - :*: S1 NoSelector (Rec0 e))))) - -instance Generic (a, b, c, d, e) where - type Rep (a, b, c, d, e) = Rep0Tuple5 a b c d e - - from (a, b, c, d, e) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (K1 e))))) - - to (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) - :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (K1 e)))))) - = (a, b, c, d, e) - ------ - -type Rep0Tuple6 a b c d e f = D1 D1Tuple6 (C1 C1_0Tuple6 ((S1 NoSelector (Rec0 a) - :*: (S1 NoSelector (Rec0 b) - :*: S1 NoSelector (Rec0 c))) - :*: (S1 NoSelector (Rec0 d) - :*: (S1 NoSelector (Rec0 e) - :*: S1 NoSelector (Rec0 f))))) - -instance Generic (a, b, c, d, e, f) where - type Rep (a, b, c, d, e, f) = Rep0Tuple6 a b c d e f - - from (a, b, c, d, e, f) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (K1 f))))) - - to (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (K1 f)))))) - = (a, b, c, d, e, f) - ------ - -type Rep0Tuple7 a b c d e f g - = D1 D1Tuple7 (C1 C1_0Tuple7 ((S1 NoSelector (Rec0 a) - :*: (S1 NoSelector (Rec0 b) - :*: S1 NoSelector (Rec0 c))) - :*: ((S1 NoSelector (Rec0 d) - :*: S1 NoSelector (Rec0 e)) - :*: (S1 NoSelector (Rec0 f) - :*: S1 NoSelector (Rec0 g))))) - -instance Generic (a, b, c, d, e, f, g) where - type Rep (a, b, c, d, e, f, g) = Rep0Tuple7 a b c d e f g - - from (a, b, c, d, e, f, g) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (K1 g))))) - - to (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) - :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (K1 g)))))) - = (a, b, c, d, e, f, g) - -#endif +{-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Generics.Deriving.Instances ( +-- Only instances from Generics.Deriving.Base +-- and the Generic1 instances +#if __GLASGOW_HASKELL__ < 711 + 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 diff --git a/src/Generics/Deriving/Show.hs b/src/Generics/Deriving/Show.hs index ce9f592..8f5e299 100644 --- a/src/Generics/Deriving/Show.hs +++ b/src/Generics/Deriving/Show.hs @@ -1,536 +1,536 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} - -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -#if __GLASGOW_HASKELL__ < 709 -{-# LANGUAGE OverlappingInstances #-} -#endif - -module Generics.Deriving.Show ( - -- * Generic show class - GShow(..) - - -- * Default definition - , gshowsPrecdefault - - ) where - -import Control.Applicative (Const, ZipList) - -import Data.Char (GeneralCategory) -import Data.Int -import Data.Monoid (All, Any, Dual, First, Last, Product, Sum) -import Data.Word - -import Foreign.C.Types -import Foreign.ForeignPtr (ForeignPtr) -import Foreign.Ptr - -import Generics.Deriving.Base -import Generics.Deriving.Instances () - -import GHC.Exts hiding (Any) - -import System.Exit (ExitCode) -import System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode) -import System.IO.Error (IOErrorType) -import System.Posix.Types - -#if MIN_VERSION_base(4,7,0) -import Data.Proxy (Proxy) -#endif - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -import Data.Monoid (Alt) -import Data.Void (Void) -import Numeric.Natural (Natural) -#endif - --------------------------------------------------------------------------------- --- Generic show --------------------------------------------------------------------------------- - -intersperse :: a -> [a] -> [a] -intersperse _ [] = [] -intersperse _ [h] = [h] -intersperse x (h:t) = h : x : (intersperse x t) - -appPrec :: Int -appPrec = 2 - -data Type = Rec | Tup | Pref | Inf String - -class GShow' f where - gshowsPrec' :: Type -> Int -> f a -> ShowS - isNullary :: f a -> Bool - isNullary = error "generic show (isNullary): unnecessary case" - -instance GShow' U1 where - gshowsPrec' _ _ U1 = id - isNullary _ = True - -instance (GShow c) => GShow' (K1 i c) where - gshowsPrec' _ n (K1 a) = gshowsPrec n a - isNullary _ = False - --- No instances for P or Rec because gshow is only applicable to types of kind * - -instance (GShow' a, Constructor c) => GShow' (M1 C c a) where - gshowsPrec' _ n c@(M1 x) = - case fixity of - Prefix -> showParen (n > appPrec && not (isNullary x)) - ( showString (conName c) - . if (isNullary x) then id else showChar ' ' - . showBraces t (gshowsPrec' t appPrec x)) - Infix _ m -> showParen (n > m) (showBraces t (gshowsPrec' t m x)) - where fixity = conFixity c - t = if (conIsRecord c) then Rec else - case (conIsTuple c) of - True -> Tup - False -> case fixity of - Prefix -> Pref - Infix _ _ -> Inf (show (conName c)) - showBraces :: Type -> ShowS -> ShowS - showBraces Rec p = showChar '{' . p . showChar '}' - showBraces Tup p = showChar '(' . p . showChar ')' - showBraces Pref p = p - showBraces (Inf _) p = p - conIsTuple y = tupleName (conName y) where - tupleName ('(':',':_) = True - tupleName _ = False - -instance (Selector s, GShow' a) => GShow' (M1 S s a) where - gshowsPrec' t n s@(M1 x) | selName s == "" = --showParen (n > appPrec) - (gshowsPrec' t n x) - | otherwise = showString (selName s) - . showString " = " - . gshowsPrec' t 0 x - isNullary (M1 x) = isNullary x - -instance (GShow' a) => GShow' (M1 D d a) where - gshowsPrec' t n (M1 x) = gshowsPrec' t n x - -instance (GShow' a, GShow' b) => GShow' (a :+: b) where - gshowsPrec' t n (L1 x) = gshowsPrec' t n x - gshowsPrec' t n (R1 x) = gshowsPrec' t n x - -instance (GShow' a, GShow' b) => GShow' (a :*: b) where - gshowsPrec' t@Rec n (a :*: b) = - gshowsPrec' t n a . showString ", " . gshowsPrec' t n b - gshowsPrec' t@(Inf s) n (a :*: b) = - gshowsPrec' t n a . showString s . gshowsPrec' t n b - gshowsPrec' t@Tup n (a :*: b) = - gshowsPrec' t n a . showChar ',' . gshowsPrec' t n b - gshowsPrec' t@Pref n (a :*: b) = - gshowsPrec' t (n+1) a . showChar ' ' . gshowsPrec' t (n+1) b - - -- If we have a product then it is not a nullary constructor - isNullary _ = False - --- Unboxed types -instance GShow' UChar where - gshowsPrec' _ _ (UChar c) = showsPrec 0 (C# c) . showChar '#' -instance GShow' UDouble where - gshowsPrec' _ _ (UDouble d) = showsPrec 0 (D# d) . showString "##" -instance GShow' UFloat where - gshowsPrec' _ _ (UFloat f) = showsPrec 0 (F# f) . showChar '#' -instance GShow' UInt where - gshowsPrec' _ _ (UInt i) = showsPrec 0 (I# i) . showChar '#' -instance GShow' UWord where - gshowsPrec' _ _ (UWord w) = showsPrec 0 (W# w) . showString "##" - - -class GShow a where - gshowsPrec :: Int -> a -> ShowS - gshows :: a -> ShowS - gshows = gshowsPrec 0 - gshow :: a -> String - gshow x = gshows x "" -#if __GLASGOW_HASKELL__ >= 701 - default gshowsPrec :: (Generic a, GShow' (Rep a)) - => Int -> a -> ShowS - gshowsPrec = gshowsPrecdefault -#endif - -gshowsPrecdefault :: (Generic a, GShow' (Rep a)) - => Int -> a -> ShowS -gshowsPrecdefault n = gshowsPrec' Pref n . from - - --- Base types instances --- Base types instances -instance GShow () where - gshowsPrec = gshowsPrecdefault - -instance (GShow a, GShow b) => GShow (a, b) where - gshowsPrec = gshowsPrecdefault - -instance (GShow a, GShow b, GShow c) => GShow (a, b, c) where - gshowsPrec = gshowsPrecdefault - -instance (GShow a, GShow b, GShow c, GShow d) => GShow (a, b, c, d) where - gshowsPrec = gshowsPrecdefault - -instance (GShow a, GShow b, GShow c, GShow d, GShow e) => GShow (a, b, c, d, e) where - gshowsPrec = gshowsPrecdefault - -instance (GShow a, GShow b, GShow c, GShow d, GShow e, GShow f) - => GShow (a, b, c, d, e, f) where - gshowsPrec = gshowsPrecdefault - -instance (GShow a, GShow b, GShow c, GShow d, GShow e, GShow f, GShow g) - => GShow (a, b, c, d, e, f, g) where - gshowsPrec = gshowsPrecdefault - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPABLE #-} -#endif - (GShow a) => GShow [a] where - gshowsPrec _ l = showChar '[' - . foldr (.) id - (intersperse (showChar ',') (map (gshowsPrec 0) l)) - . showChar ']' - -instance (GShow (f p), GShow (g p)) => GShow ((f :+: g) p) where - gshowsPrec = gshowsPrecdefault - -instance (GShow (f p), GShow (g p)) => GShow ((f :*: g) p) where - gshowsPrec = gshowsPrecdefault - -instance GShow (f (g p)) => GShow ((f :.: g) p) where - gshowsPrec = gshowsPrecdefault - -instance GShow All where - gshowsPrec = gshowsPrecdefault - -#if MIN_VERSION_base(4,8,0) -instance GShow (f a) => GShow (Alt f a) where - gshowsPrec = gshowsPrecdefault -#endif - -instance GShow Any where - gshowsPrec = gshowsPrecdefault - -instance GShow Arity where - gshowsPrec = gshowsPrecdefault - -instance GShow Associativity where - gshowsPrec = gshowsPrecdefault - -instance GShow Bool where - gshowsPrec = gshowsPrecdefault - -instance GShow BufferMode where - gshowsPrec = showsPrec - -#if defined(HTYPE_CC_T) -instance GShow CCc where - gshowsPrec = showsPrec -#endif - -instance GShow CChar where - gshowsPrec = showsPrec - -instance GShow CClock where - gshowsPrec = showsPrec - -#if defined(HTYPE_DEV_T) -instance GShow CDev where - gshowsPrec = showsPrec -#endif - -instance GShow CDouble where - gshowsPrec = showsPrec - -instance GShow CFloat where - gshowsPrec = showsPrec - -#if defined(HTYPE_GID_T) -instance GShow CGid where - gshowsPrec = showsPrec -#endif - -instance GShow Char where - gshowsPrec = showsPrec - -#if defined(HTYPE_INO_T) -instance GShow CIno where - gshowsPrec = showsPrec -#endif - -instance GShow CInt where - gshowsPrec = showsPrec - -instance GShow CIntMax where - gshowsPrec = showsPrec - -instance GShow CIntPtr where - gshowsPrec = showsPrec - -instance GShow CLLong where - gshowsPrec = showsPrec - -instance GShow CLong where - gshowsPrec = showsPrec - -#if defined(HTYPE_MODE_T) -instance GShow CMode where - gshowsPrec = showsPrec -#endif - -#if defined(HTYPE_NLINK_T) -instance GShow CNlink where - gshowsPrec = showsPrec -#endif - -#if defined(HTYPE_OFF_T) -instance GShow COff where - gshowsPrec = showsPrec -#endif - -instance GShow a => GShow (Const a b) where - gshowsPrec = gshowsPrecdefault - -#if defined(HTYPE_PID_T) -instance GShow CPid where - gshowsPrec = showsPrec -#endif - -instance GShow CPtrdiff where - gshowsPrec = showsPrec - -#if defined(HTYPE_RLIM_T) -instance GShow CRLim where - gshowsPrec = showsPrec -#endif - -instance GShow CSChar where - gshowsPrec = showsPrec - -#if defined(HTYPE_SPEED_T) -instance GShow CSpeed where - gshowsPrec = showsPrec -#endif - -#if MIN_VERSION_base(4,4,0) -instance GShow CSUSeconds where - gshowsPrec = showsPrec -#endif - -instance GShow CShort where - gshowsPrec = showsPrec - -instance GShow CSigAtomic where - gshowsPrec = showsPrec - -instance GShow CSize where - gshowsPrec = showsPrec - -#if defined(HTYPE_SSIZE_T) -instance GShow CSsize where - gshowsPrec = showsPrec -#endif - -#if defined(HTYPE_TCFLAG_T) -instance GShow CTcflag where - gshowsPrec = showsPrec -#endif - -instance GShow CTime where - gshowsPrec = showsPrec - -instance GShow CUChar where - gshowsPrec = showsPrec - -#if defined(HTYPE_UID_T) -instance GShow CUid where - gshowsPrec = showsPrec -#endif - -instance GShow CUInt where - gshowsPrec = showsPrec - -instance GShow CUIntMax where - gshowsPrec = showsPrec - -instance GShow CUIntPtr where - gshowsPrec = showsPrec - -instance GShow CULLong where - gshowsPrec = showsPrec - -instance GShow CULong where - gshowsPrec = showsPrec - -#if MIN_VERSION_base(4,4,0) -instance GShow CUSeconds where - gshowsPrec = showsPrec -#endif - -instance GShow CUShort where - gshowsPrec = showsPrec - -instance GShow CWchar where - gshowsPrec = showsPrec - -instance GShow Double where - gshowsPrec = showsPrec - -instance GShow a => GShow (Dual a) where - gshowsPrec = gshowsPrecdefault - -instance (GShow a, GShow b) => GShow (Either a b) where - gshowsPrec = gshowsPrecdefault - -instance GShow ExitCode where - gshowsPrec = showsPrec - -instance GShow Fd where - gshowsPrec = showsPrec - -instance GShow a => GShow (First a) where - gshowsPrec = gshowsPrecdefault - -instance GShow Fixity where - gshowsPrec = gshowsPrecdefault - -instance GShow Float where - gshowsPrec = showsPrec - -instance GShow (ForeignPtr a) where - gshowsPrec = showsPrec - -instance GShow (FunPtr a) where - gshowsPrec = showsPrec - -instance GShow GeneralCategory where - gshowsPrec = showsPrec - -instance GShow Handle where - gshowsPrec = showsPrec - -instance GShow HandlePosn where - gshowsPrec = showsPrec - -#if MIN_VERSION_base(4,8,0) -instance GShow a => GShow (Identity a) where - gshowsPrec = gshowsPrecdefault -#endif - -instance GShow Int where - gshowsPrec = showsPrec - -instance GShow Int8 where - gshowsPrec = showsPrec - -instance GShow Int16 where - gshowsPrec = showsPrec - -instance GShow Int32 where - gshowsPrec = showsPrec - -instance GShow Int64 where - gshowsPrec = showsPrec - -instance GShow Integer where - gshowsPrec = showsPrec - -instance GShow IntPtr where - gshowsPrec = showsPrec - -instance GShow IOError where - gshowsPrec = showsPrec - -instance GShow IOErrorType where - gshowsPrec = showsPrec - -instance GShow IOMode where - gshowsPrec = showsPrec - -instance GShow c => GShow (K1 i c p) where - gshowsPrec = gshowsPrecdefault - -instance GShow a => GShow (Last a) where - gshowsPrec = gshowsPrecdefault - -instance GShow (f p) => GShow (M1 i c f p) where - gshowsPrec = gshowsPrecdefault - -instance GShow a => GShow (Maybe a) where - gshowsPrec = gshowsPrecdefault - -#if MIN_VERSION_base(4,8,0) -instance GShow Natural where - gshowsPrec = showsPrec -#endif - -instance GShow Ordering where - gshowsPrec = gshowsPrecdefault - -instance GShow p => GShow (Par1 p) where - gshowsPrec = gshowsPrecdefault - -instance GShow a => GShow (Product a) where - gshowsPrec = gshowsPrecdefault - -#if MIN_VERSION_base(4,7,0) -instance GShow (Proxy s) where - gshowsPrec = gshowsPrecdefault -#endif - -instance GShow (Ptr a) where - gshowsPrec = showsPrec - -instance GShow (f p) => GShow (Rec1 f p) where - gshowsPrec = gshowsPrecdefault - -instance GShow SeekMode where - gshowsPrec = showsPrec - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPING #-} -#endif - GShow String where - gshowsPrec = showsPrec - -instance GShow a => GShow (Sum a) where - gshowsPrec = gshowsPrecdefault - -instance GShow (U1 p) where - gshowsPrec = gshowsPrecdefault - -#if MIN_VERSION_base(4,8,0) -instance GShow Void where - gshowsPrec = showsPrec -#endif - -instance GShow Word where - gshowsPrec = showsPrec - -instance GShow Word8 where - gshowsPrec = showsPrec - -instance GShow Word16 where - gshowsPrec = showsPrec - -instance GShow Word32 where - gshowsPrec = showsPrec - -instance GShow Word64 where - gshowsPrec = showsPrec - -instance GShow WordPtr where - gshowsPrec = showsPrec - -instance GShow a => GShow (ZipList a) where - gshowsPrec = gshowsPrecdefault +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE 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 diff --git a/src/Generics/Deriving/Traversable.hs b/src/Generics/Deriving/Traversable.hs index c07d0ad..19d6682 100644 --- a/src/Generics/Deriving/Traversable.hs +++ b/src/Generics/Deriving/Traversable.hs @@ -1,101 +1,101 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeOperators #-} -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -module Generics.Deriving.Traversable ( - -- * GTraversable class - GTraversable(..) - - -- * Default method - , gtraversedefault - - ) where - -import Control.Applicative - -import Generics.Deriving.Base -import Generics.Deriving.Foldable -import Generics.Deriving.Functor -import Generics.Deriving.Instances () - -#if MIN_VERSION_base(4,8,0) -import Data.Functor.Identity (Identity) -#endif - --------------------------------------------------------------------------------- --- Generic traverse --------------------------------------------------------------------------------- - -class GTraversable' t where - gtraverse' :: Applicative f => (a -> f b) -> t a -> f (t b) - -instance GTraversable' U1 where - gtraverse' _ U1 = pure U1 - -instance GTraversable' Par1 where - gtraverse' f (Par1 a) = Par1 <$> f a - -instance GTraversable' (K1 i c) where - gtraverse' _ (K1 a) = pure (K1 a) - -instance (GTraversable f) => GTraversable' (Rec1 f) where - gtraverse' f (Rec1 a) = Rec1 <$> gtraverse f a - -instance (GTraversable' f) => GTraversable' (M1 i c f) where - gtraverse' f (M1 a) = M1 <$> gtraverse' f a - -instance (GTraversable' f, GTraversable' g) => GTraversable' (f :+: g) where - gtraverse' f (L1 a) = L1 <$> gtraverse' f a - gtraverse' f (R1 a) = R1 <$> gtraverse' f a - -instance (GTraversable' f, GTraversable' g) => GTraversable' (f :*: g) where - gtraverse' f (a :*: b) = (:*:) <$> gtraverse' f a <*> gtraverse' f b - -instance (GTraversable f, GTraversable' g) => GTraversable' (f :.: g) where - gtraverse' f (Comp1 x) = Comp1 <$> gtraverse (gtraverse' f) x - - -class (GFunctor t, GFoldable t) => GTraversable t where - gtraverse :: Applicative f => (a -> f b) -> t a -> f (t b) -#if __GLASGOW_HASKELL__ >= 701 - default gtraverse :: (Generic1 t, GTraversable' (Rep1 t), Applicative f) - => (a -> f b) -> t a -> f (t b) - gtraverse = gtraversedefault -#endif - - gsequenceA :: Applicative f => t (f a) -> f (t a) - gsequenceA = gtraverse id - - gmapM :: Monad m => (a -> m b) -> t a -> m (t b) - gmapM f = unwrapMonad . gtraverse (WrapMonad . f) - - gsequence :: Monad m => t (m a) -> m (t a) - gsequence = gmapM id - -gtraversedefault :: (Generic1 t, GTraversable' (Rep1 t), Applicative f) - => (a -> f b) -> t a -> f (t b) -gtraversedefault f x = to1 <$> gtraverse' f (from1 x) - --- Base types instances -instance GTraversable [] where - gtraverse = gtraversedefault - -instance GTraversable ((,) a) where - gtraverse = gtraversedefault - -instance GTraversable (Const m) where - gtraverse = gtraversedefault - -instance GTraversable (Either a) where - gtraverse = gtraversedefault - -#if MIN_VERSION_base(4,8,0) -instance GTraversable Identity where - gtraverse = gtraversedefault -#endif - -instance GTraversable Maybe where - gtraverse = gtraversedefault +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE 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 diff --git a/src/Generics/Deriving/Uniplate.hs b/src/Generics/Deriving/Uniplate.hs index 537abce..f00a04c 100644 --- a/src/Generics/Deriving/Uniplate.hs +++ b/src/Generics/Deriving/Uniplate.hs @@ -1,383 +1,383 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} - -#if __GLASGOW_HASKELL__ >= 701 -{-# LANGUAGE DefaultSignatures #-} -#endif - -#if __GLASGOW_HASKELL__ < 709 -{-# LANGUAGE OverlappingInstances #-} -#endif - --------------------------------------------------------------------------------- --- | --- Module : Generics.Deriving.Uniplate --- Copyright : 2011-2012 Universiteit Utrecht, University of Oxford --- License : BSD3 --- --- Maintainer : generics@haskell.org --- Stability : experimental --- Portability : non-portable --- --- Summary: Functions inspired by the Uniplate generic programming library, --- mostly implemented by Sean Leather. --------------------------------------------------------------------------------- - -module Generics.Deriving.Uniplate ( - Uniplate(..) - - -- * Derived functions - , uniplate - , universe - , rewrite - , rewriteM - , contexts - , holes - , para - - -- * Default definitions - , childrendefault - , contextdefault - , descenddefault - , descendMdefault - , transformdefault - , transformMdefault - - ) where - - -import Generics.Deriving.Base -import Generics.Deriving.Instances () - -import Control.Monad (liftM, liftM2) -import GHC.Exts (build) - --------------------------------------------------------------------------------- --- Generic Uniplate --------------------------------------------------------------------------------- - -class Uniplate' f b where - children' :: f a -> [b] - descend' :: (b -> b) -> f a -> f a - descendM' :: Monad m => (b -> m b) -> f a -> m (f a) - transform' :: (b -> b) -> f a -> f a - transformM' :: Monad m => (b -> m b) -> f a -> m (f a) - -instance Uniplate' U1 a where - children' U1 = [] - descend' _ U1 = U1 - descendM' _ U1 = return U1 - transform' _ U1 = U1 - transformM' _ U1 = return U1 - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPING #-} -#endif - (Uniplate a) => Uniplate' (K1 i a) a where - children' (K1 a) = [a] - descend' f (K1 a) = K1 (f a) - descendM' f (K1 a) = liftM K1 (f a) - transform' f (K1 a) = K1 (transform f a) - transformM' f (K1 a) = liftM K1 (transformM f a) - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPABLE #-} -#endif - Uniplate' (K1 i a) b where - children' (K1 _) = [] - descend' _ (K1 a) = K1 a - descendM' _ (K1 a) = return (K1 a) - transform' _ (K1 a) = K1 a - transformM' _ (K1 a) = return (K1 a) - -instance (Uniplate' f b) => Uniplate' (M1 i c f) b where - children' (M1 a) = children' a - descend' f (M1 a) = M1 (descend' f a) - descendM' f (M1 a) = liftM M1 (descendM' f a) - transform' f (M1 a) = M1 (transform' f a) - transformM' f (M1 a) = liftM M1 (transformM' f a) - -instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :+: g) b where - children' (L1 a) = children' a - children' (R1 a) = children' a - descend' f (L1 a) = L1 (descend' f a) - descend' f (R1 a) = R1 (descend' f a) - descendM' f (L1 a) = liftM L1 (descendM' f a) - descendM' f (R1 a) = liftM R1 (descendM' f a) - transform' f (L1 a) = L1 (transform' f a) - transform' f (R1 a) = R1 (transform' f a) - transformM' f (L1 a) = liftM L1 (transformM' f a) - transformM' f (R1 a) = liftM R1 (transformM' f a) - -instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :*: g) b where - children' (a :*: b) = children' a ++ children' b - descend' f (a :*: b) = descend' f a :*: descend' f b - descendM' f (a :*: b) = liftM2 (:*:) (descendM' f a) (descendM' f b) - transform' f (a :*: b) = transform' f a :*: transform' f b - transformM' f (a :*: b) = liftM2 (:*:) (transformM' f a) (transformM' f b) - - --- Context' is a separate class from Uniplate' since it uses special product --- instances, but the context function still appears in Uniplate. -class Context' f b where - context' :: f a -> [b] -> f a - -instance Context' U1 b where - context' U1 _ = U1 - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPING #-} -#endif - Context' (K1 i a) a where - context' _ [] = error "Generics.Deriving.Uniplate.context: empty list" - context' (K1 _) (c:_) = K1 c - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPABLE #-} -#endif - Context' (K1 i a) b where - context' (K1 a) _ = K1 a - -instance (Context' f b) => Context' (M1 i c f) b where - context' (M1 a) cs = M1 (context' a cs) - -instance (Context' f b, Context' g b) => Context' (f :+: g) b where - context' (L1 a) cs = L1 (context' a cs) - context' (R1 a) cs = R1 (context' a cs) - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPING #-} -#endif - (Context' g a) => Context' (M1 i c (K1 j a) :*: g) a where - context' _ [] = error "Generics.Deriving.Uniplate.context: empty list" - context' (M1 (K1 _) :*: b) (c:cs) = M1 (K1 c) :*: context' b cs - -instance -#if __GLASGOW_HASKELL__ >= 709 - {-# OVERLAPPABLE #-} -#endif - (Context' g b) => Context' (f :*: g) b where - context' (a :*: b) cs = a :*: context' b cs - - -class Uniplate a where - children :: a -> [a] -#if __GLASGOW_HASKELL__ >= 701 - default children :: (Generic a, Uniplate' (Rep a) a) => a -> [a] - children = childrendefault -#endif - - context :: a -> [a] -> a -#if __GLASGOW_HASKELL__ >= 701 - default context :: (Generic a, Context' (Rep a) a) => a -> [a] -> a - context = contextdefault -#endif - - descend :: (a -> a) -> a -> a -#if __GLASGOW_HASKELL__ >= 701 - default descend :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a - descend = descenddefault -#endif - - descendM :: Monad m => (a -> m a) -> a -> m a -#if __GLASGOW_HASKELL__ >= 701 - default descendM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a - descendM = descendMdefault -#endif - - transform :: (a -> a) -> a -> a -#if __GLASGOW_HASKELL__ >= 701 - default transform :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a - transform = transformdefault -#endif - - transformM :: Monad m => (a -> m a) -> a -> m a -#if __GLASGOW_HASKELL__ >= 701 - default transformM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a - transformM = transformMdefault -#endif - -childrendefault :: (Generic a, Uniplate' (Rep a) a) => a -> [a] -childrendefault = children' . from - -contextdefault :: (Generic a, Context' (Rep a) a) => a -> [a] -> a -contextdefault x cs = to (context' (from x) cs) - -descenddefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a -descenddefault f = to . descend' f . from - -descendMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a -descendMdefault f = liftM to . descendM' f . from - -transformdefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a -transformdefault f = f . to . transform' f . from - -transformMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a -transformMdefault f = liftM to . transformM' f . from - - --- Derived functions (mostly copied from Neil Michell's code) - -uniplate :: Uniplate a => a -> ([a], [a] -> a) -uniplate a = (children a, context a) - -universe :: Uniplate a => a -> [a] -universe a = build (go a) - where - go x cons nil = cons x $ foldr ($) nil $ map (\c -> go c cons) $ children x - -rewrite :: Uniplate a => (a -> Maybe a) -> a -> a -rewrite f = transform g - where - g x = maybe x (rewrite f) (f x) - -rewriteM :: (Monad m, Uniplate a) => (a -> m (Maybe a)) -> a -> m a -rewriteM f = transformM g - where - g x = f x >>= maybe (return x) (rewriteM f) - -contexts :: Uniplate a => a -> [(a, a -> a)] -contexts a = (a, id) : f (holes a) - where - f xs = [ (ch2, ctx1 . ctx2) - | (ch1, ctx1) <- xs - , (ch2, ctx2) <- contexts ch1] - -holes :: Uniplate a => a -> [(a, a -> a)] -holes a = uncurry f (uniplate a) - where - f [] _ = [] - f (x:xs) gen = (x, gen . (:xs)) : f xs (gen . (x:)) - -para :: Uniplate a => (a -> [r] -> r) -> a -> r -para f x = f x $ map (para f) $ children x - - --- Base types instances -instance Uniplate Bool where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate Char where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate Double where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate Float where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate Int where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate () where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return - --- Tuple instances -instance Uniplate (b,c) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (b,c,d) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (b,c,d,e) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (b,c,d,e,f) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (b,c,d,e,f,g) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (b,c,d,e,f,g,h) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return - --- Parameterized type instances -instance Uniplate (Maybe a) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return -instance Uniplate (Either a b) where - children _ = [] - context x _ = x - descend _ = id - descendM _ = return - transform = id - transformM _ = return - -instance Uniplate [a] where - children [] = [] - children (_:t) = [t] - context _ [] = error "Generics.Deriving.Uniplate.context: empty list" - context [] _ = [] - context (h:_) (t:_) = h:t - descend _ [] = [] - descend f (h:t) = h:f t - descendM _ [] = return [] - descendM f (h:t) = f t >>= \t' -> return (h:t') - transform f [] = f [] - transform f (h:t) = f (h:transform f t) - transformM f [] = f [] - transformM f (h:t) = transformM f t >>= \t' -> f (h:t') - +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} + +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE DefaultSignatures #-} +#endif + +#if __GLASGOW_HASKELL__ < 709 +{-# LANGUAGE OverlappingInstances #-} +#endif + +-------------------------------------------------------------------------------- +-- | +-- Module : Generics.Deriving.Uniplate +-- Copyright : 2011-2012 Universiteit Utrecht, University of Oxford +-- License : BSD3 +-- +-- Maintainer : generics@haskell.org +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Functions inspired by the Uniplate generic programming library, +-- mostly implemented by Sean Leather. +-------------------------------------------------------------------------------- + +module Generics.Deriving.Uniplate ( + Uniplate(..) + + -- * Derived functions + , uniplate + , universe + , rewrite + , rewriteM + , contexts + , holes + , para + + -- * Default definitions + , childrendefault + , contextdefault + , descenddefault + , descendMdefault + , transformdefault + , transformMdefault + + ) where + + +import Generics.Deriving.Base +import Generics.Deriving.Instances () + +import Control.Monad (liftM, liftM2) +import GHC.Exts (build) + +-------------------------------------------------------------------------------- +-- Generic Uniplate +-------------------------------------------------------------------------------- + +class Uniplate' f b where + children' :: f a -> [b] + descend' :: (b -> b) -> f a -> f a + descendM' :: Monad m => (b -> m b) -> f a -> m (f a) + transform' :: (b -> b) -> f a -> f a + transformM' :: Monad m => (b -> m b) -> f a -> m (f a) + +instance Uniplate' U1 a where + children' U1 = [] + descend' _ U1 = U1 + descendM' _ U1 = return U1 + transform' _ U1 = U1 + transformM' _ U1 = return U1 + +instance +#if __GLASGOW_HASKELL__ >= 709 + {-# OVERLAPPING #-} +#endif + (Uniplate a) => Uniplate' (K1 i a) a where + children' (K1 a) = [a] + descend' f (K1 a) = K1 (f a) + descendM' f (K1 a) = liftM K1 (f a) + transform' f (K1 a) = K1 (transform f a) + transformM' f (K1 a) = liftM K1 (transformM f a) + +instance +#if __GLASGOW_HASKELL__ >= 709 + {-# OVERLAPPABLE #-} +#endif + Uniplate' (K1 i a) b where + children' (K1 _) = [] + descend' _ (K1 a) = K1 a + descendM' _ (K1 a) = return (K1 a) + transform' _ (K1 a) = K1 a + transformM' _ (K1 a) = return (K1 a) + +instance (Uniplate' f b) => Uniplate' (M1 i c f) b where + children' (M1 a) = children' a + descend' f (M1 a) = M1 (descend' f a) + descendM' f (M1 a) = liftM M1 (descendM' f a) + transform' f (M1 a) = M1 (transform' f a) + transformM' f (M1 a) = liftM M1 (transformM' f a) + +instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :+: g) b where + children' (L1 a) = children' a + children' (R1 a) = children' a + descend' f (L1 a) = L1 (descend' f a) + descend' f (R1 a) = R1 (descend' f a) + descendM' f (L1 a) = liftM L1 (descendM' f a) + descendM' f (R1 a) = liftM R1 (descendM' f a) + transform' f (L1 a) = L1 (transform' f a) + transform' f (R1 a) = R1 (transform' f a) + transformM' f (L1 a) = liftM L1 (transformM' f a) + transformM' f (R1 a) = liftM R1 (transformM' f a) + +instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :*: g) b where + children' (a :*: b) = children' a ++ children' b + descend' f (a :*: b) = descend' f a :*: descend' f b + descendM' f (a :*: b) = liftM2 (:*:) (descendM' f a) (descendM' f b) + transform' f (a :*: b) = transform' f a :*: transform' f b + transformM' f (a :*: b) = liftM2 (:*:) (transformM' f a) (transformM' f b) + + +-- Context' is a separate class from Uniplate' since it uses special product +-- instances, but the context function still appears in Uniplate. +class Context' f b where + context' :: f a -> [b] -> f a + +instance Context' U1 b where + context' U1 _ = U1 + +instance +#if __GLASGOW_HASKELL__ >= 709 + {-# OVERLAPPING #-} +#endif + Context' (K1 i a) a where + context' _ [] = error "Generics.Deriving.Uniplate.context: empty list" + context' (K1 _) (c:_) = K1 c + +instance +#if __GLASGOW_HASKELL__ >= 709 + {-# OVERLAPPABLE #-} +#endif + Context' (K1 i a) b where + context' (K1 a) _ = K1 a + +instance (Context' f b) => Context' (M1 i c f) b where + context' (M1 a) cs = M1 (context' a cs) + +instance (Context' f b, Context' g b) => Context' (f :+: g) b where + context' (L1 a) cs = L1 (context' a cs) + context' (R1 a) cs = R1 (context' a cs) + +instance +#if __GLASGOW_HASKELL__ >= 709 + {-# OVERLAPPING #-} +#endif + (Context' g a) => Context' (M1 i c (K1 j a) :*: g) a where + context' _ [] = error "Generics.Deriving.Uniplate.context: empty list" + context' (M1 (K1 _) :*: b) (c:cs) = M1 (K1 c) :*: context' b cs + +instance +#if __GLASGOW_HASKELL__ >= 709 + {-# OVERLAPPABLE #-} +#endif + (Context' g b) => Context' (f :*: g) b where + context' (a :*: b) cs = a :*: context' b cs + + +class Uniplate a where + children :: a -> [a] +#if __GLASGOW_HASKELL__ >= 701 + default children :: (Generic a, Uniplate' (Rep a) a) => a -> [a] + children = childrendefault +#endif + + context :: a -> [a] -> a +#if __GLASGOW_HASKELL__ >= 701 + default context :: (Generic a, Context' (Rep a) a) => a -> [a] -> a + context = contextdefault +#endif + + descend :: (a -> a) -> a -> a +#if __GLASGOW_HASKELL__ >= 701 + default descend :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a + descend = descenddefault +#endif + + descendM :: Monad m => (a -> m a) -> a -> m a +#if __GLASGOW_HASKELL__ >= 701 + default descendM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a + descendM = descendMdefault +#endif + + transform :: (a -> a) -> a -> a +#if __GLASGOW_HASKELL__ >= 701 + default transform :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a + transform = transformdefault +#endif + + transformM :: Monad m => (a -> m a) -> a -> m a +#if __GLASGOW_HASKELL__ >= 701 + default transformM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a + transformM = transformMdefault +#endif + +childrendefault :: (Generic a, Uniplate' (Rep a) a) => a -> [a] +childrendefault = children' . from + +contextdefault :: (Generic a, Context' (Rep a) a) => a -> [a] -> a +contextdefault x cs = to (context' (from x) cs) + +descenddefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a +descenddefault f = to . descend' f . from + +descendMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a +descendMdefault f = liftM to . descendM' f . from + +transformdefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a +transformdefault f = f . to . transform' f . from + +transformMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a +transformMdefault f = liftM to . transformM' f . from + + +-- Derived functions (mostly copied from Neil Michell's code) + +uniplate :: Uniplate a => a -> ([a], [a] -> a) +uniplate a = (children a, context a) + +universe :: Uniplate a => a -> [a] +universe a = build (go a) + where + go x cons nil = cons x $ foldr ($) nil $ map (\c -> go c cons) $ children x + +rewrite :: Uniplate a => (a -> Maybe a) -> a -> a +rewrite f = transform g + where + g x = maybe x (rewrite f) (f x) + +rewriteM :: (Monad m, Uniplate a) => (a -> m (Maybe a)) -> a -> m a +rewriteM f = transformM g + where + g x = f x >>= maybe (return x) (rewriteM f) + +contexts :: Uniplate a => a -> [(a, a -> a)] +contexts a = (a, id) : f (holes a) + where + f xs = [ (ch2, ctx1 . ctx2) + | (ch1, ctx1) <- xs + , (ch2, ctx2) <- contexts ch1] + +holes :: Uniplate a => a -> [(a, a -> a)] +holes a = uncurry f (uniplate a) + where + f [] _ = [] + f (x:xs) gen = (x, gen . (:xs)) : f xs (gen . (x:)) + +para :: Uniplate a => (a -> [r] -> r) -> a -> r +para f x = f x $ map (para f) $ children x + + +-- Base types instances +instance Uniplate Bool where + children _ = [] + context x _ = x + descend _ = id + descendM _ = return + transform = id + transformM _ = return +instance Uniplate Char where + children _ = [] + context x _ = x + descend _ = id + descendM _ = return + transform = id + transformM _ = return +instance Uniplate Double where + children _ = [] + context x _ = x + descend _ = id + descendM _ = return + transform = id + transformM _ = return +instance Uniplate Float where + children _ = [] + context x _ = x + descend _ = id + descendM _ = return + transform = id + transformM _ = return +instance Uniplate Int where + children _ = [] + context x _ = x + descend _ = id + descendM _ = return + transform = id + transformM _ = return +instance Uniplate () where + children _ = [] + context x _ = x + descend _ = id + descendM _ = return + transform = id + transformM _ = return + +-- Tuple instances +instance Uniplate (b,c) where + children _ = [] + context x _ = x + descend _ = id + descendM _ = return + transform = id + transformM _ = return +instance Uniplate (b,c,d) where + children _ = [] + context x _ = x + descend _ = id + descendM _ = return + transform = id + transformM _ = return +instance Uniplate (b,c,d,e) where + children _ = [] + context x _ = x + descend _ = id + descendM _ = return + transform = id + transformM _ = return +instance Uniplate (b,c,d,e,f) where + children _ = [] + context x _ = x + descend _ = id + descendM _ = return + transform = id + transformM _ = return +instance Uniplate (b,c,d,e,f,g) where + children _ = [] + context x _ = x + descend _ = id + descendM _ = return + transform = id + transformM _ = return +instance Uniplate (b,c,d,e,f,g,h) where + children _ = [] + context x _ = x + descend _ = id + descendM _ = return + transform = id + transformM _ = return + +-- Parameterized type instances +instance Uniplate (Maybe a) where + children _ = [] + context x _ = x + descend _ = id + descendM _ = return + transform = id + transformM _ = return +instance Uniplate (Either a b) where + children _ = [] + context x _ = x + descend _ = id + descendM _ = return + transform = id + transformM _ = return + +instance Uniplate [a] where + children [] = [] + children (_:t) = [t] + context _ [] = error "Generics.Deriving.Uniplate.context: empty list" + context [] _ = [] + context (h:_) (t:_) = h:t + descend _ [] = [] + descend f (h:t) = h:f t + descendM _ [] = return [] + descendM f (h:t) = f t >>= \t' -> return (h:t') + transform f [] = f [] + transform f (h:t) = f (h:transform f t) + transformM f [] = f [] + transformM f (h:t) = transformM f t >>= \t' -> f (h:t') +