generic-deriving-1.11.1/0000755000000000000000000000000012765116254013213 5ustar0000000000000000generic-deriving-1.11.1/Setup.hs0000644000000000000000000000012712765116254014647 0ustar0000000000000000module Main (main) where import Distribution.Simple main :: IO () main = defaultMain generic-deriving-1.11.1/README.md0000644000000000000000000000270312765116254014474 0ustar0000000000000000## `generic-deriving`: Generic programming library for generalised deriving [![Hackage](https://img.shields.io/hackage/v/generic-deriving.svg)][Hackage: generic-deriving] [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/generic-deriving.svg)](http://packdeps.haskellers.com/reverse/generic-deriving) [![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] [![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3] [![Build](https://img.shields.io/travis/dreixel/generic-deriving.svg)](https://travis-ci.org/dreixel/generic-deriving) [Hackage: generic-deriving]: http://hackage.haskell.org/package/generic-deriving "generic-deriving package on Hackage" [Haskell.org]: http://www.haskell.org "The Haskell Programming Language" [tl;dr Legal: BSD3]: https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29 "BSD 3-Clause License (Revised)" This package provides functionality for generalising the deriving mechanism in Haskell to arbitrary classes. It was first described in the paper: * [A generic deriving mechanism for Haskell](http://dreixel.net/research/pdf/gdmh.pdf). Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh. Haskell'10. The current implementation integrates with the new GHC Generics. See http://www.haskell.org/haskellwiki/GHC.Generics for more information. Template Haskell code is provided for supporting older GHCs. generic-deriving-1.11.1/LICENSE0000644000000000000000000000274112765116254014224 0ustar0000000000000000Copyright (c) 2010 Universiteit Utrecht All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of Universiteit Utrecht nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. generic-deriving-1.11.1/generic-deriving.cabal0000644000000000000000000000714512765116254017427 0ustar0000000000000000name: generic-deriving version: 1.11.1 synopsis: Generic programming library for generalised deriving. description: This package provides functionality for generalising the deriving mechanism in Haskell to arbitrary classes. It was first described in the paper: . * /A generic deriving mechanism for Haskell/. Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh. Haskell'10. . The current implementation integrates with the new GHC Generics. See for more information. Template Haskell code is provided for supporting older GHCs. homepage: https://github.com/dreixel/generic-deriving bug-reports: https://github.com/dreixel/generic-deriving/issues category: Generics copyright: 2011-2013 Universiteit Utrecht, University of Oxford license: BSD3 license-file: LICENSE author: José Pedro Magalhães maintainer: generics@haskell.org stability: experimental build-type: Simple cabal-version: >= 1.10 tested-with: GHC == 7.0.4 , GHC == 7.2.2 , GHC == 7.4.2 , GHC == 7.6.3 , GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.1 extra-source-files: CHANGELOG.md , README.md source-repository head type: git location: https://github.com/dreixel/generic-deriving flag base-4-9 description: Use base-4.9 or later. This version of base uses a DataKinds-based encoding of GHC generics metadata. default: True library hs-source-dirs: src exposed-modules: Generics.Deriving Generics.Deriving.Base Generics.Deriving.Instances Generics.Deriving.Copoint Generics.Deriving.ConNames Generics.Deriving.Enum Generics.Deriving.Eq Generics.Deriving.Foldable Generics.Deriving.Functor Generics.Deriving.Monoid Generics.Deriving.Semigroup Generics.Deriving.Show Generics.Deriving.Traversable Generics.Deriving.Uniplate Generics.Deriving.TH other-modules: Generics.Deriving.Base.Internal Generics.Deriving.TH.Internal Paths_generic_deriving if flag(base-4-9) build-depends: base >= 4.9 && < 5 other-modules: Generics.Deriving.TH.Post4_9 else build-depends: base >= 4.3 && < 4.9 other-modules: Generics.Deriving.TH.Pre4_9 build-depends: containers >= 0.1 && < 0.6 , ghc-prim < 1 , template-haskell >= 2.4 && < 2.12 default-language: Haskell2010 ghc-options: -Wall test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: ExampleSpec TypeInTypeSpec build-depends: base >= 4.3 && < 5 , generic-deriving == 1.11.1 , hspec >= 2 && < 3 , template-haskell >= 2.4 && < 2.12 hs-source-dirs: tests default-language: Haskell2010 ghc-options: -Wall -threaded -rtsopts generic-deriving-1.11.1/CHANGELOG.md0000644000000000000000000001532012765116254015025 0ustar0000000000000000# 1.11.1 [2016.09.10] * Fix Template Haskell regression involving data families * Convert examples to test suite * Backport missing `Data` and `Typeable` instances for `Rec1`, `M1`, `(:*:)`, `(:+:)`, and `(:.:)` # 1.11 * The behavior of functions in `Generics.Deriving.TH` have changed with respect to when type synonyms are generated for `Rep(1)` definitions. In particular: * By default, `deriveRepresentable(1)` will no longer define its `Rep(1)` type family instance in terms of the type synonym that has to be generated with `deriveRep(1)`. Similarly, `deriveAll(1)` and `deriveAll0And1` will no longer generate a type synonym. Instead, they will generate `Generic(1)` instances that directly define the `Rep(1)` instance inline. If you wish to revert to the old behavior, you will need to use the variants of those functions suffixed with `-Options`. * New functions `makeRep0Inline` and `makeRep1Inline` have been added which, for most purposes, should replace uses of `makeRep0`/`makeRep0FromType` and `makeRep1`/`makeRep1FromType` (but see the next bullet point for a caveat). * The use of `deriveRep(1)`, `makeRep0`/`makeRep0FromType`, and `makeRep1`/`makeRep1FromType` are now discouraged, but those functions are still available. The reason is that on GHC 7.0/7.2/7.4, it is impossible to use `makeRep0Inline`/`makeRep1Inline` due to a GHC bug. Therefore, you must use `makeRep0`/`makeRep1` and `deriveRep(1)` on GHC 7.0/7.2/7.4 out of necessity. These changes make dealing with `Generic` instances that involve `PolyKinds` and `TypeInType` much easier. * All functions suffixed in `-WithKindSigs` in `Generics.Deriving.TH` have been removed in favor of a more sensible `-Options` suffixing scheme. The ability to toggle whether explicit kind signatures are used on type variable binders has been folded into `KindSigOptions`, which is an explicit argument to `deriveRep0Options`/`deriveRep1Options` and also a field in the more general 'Options' data type. * Furthermore, the behavior of derived instances' kind signatures has changed. By default, the TH code will now _always_ use explicit kind signatures whenever possible, regardless of whether you're working with plain data types or data family instances. This makes working with `TypeInType` less surprising, but at the cost of making it slightly more awkward to work with derived `Generic1` instances that constrain kinds to `*` by means of `(:.:)`. * Since `Generic1` is polykinded on GHC 8.2 and later, the functions in `Generics.Deriving.TH` will no longer unify the kind of the last type parameter to be `*`. * Fix a bug in which `makeRep` (and similarly named functions) would not check whether the argument type can actually have a well kinded `Generic(1)` instance. * Backport missing `Foldable` and `Traversable` instances for `Rec1` # 1.10.7 * Renamed internal modules to avoid using apostrophes (averting this bug: https://github.com/haskell/cabal/issues/3631) # 1.10.6 * A new `base-4-9` Cabal flag was added to more easily facilitate installing `generic-deriving` with manually installed versions of `template-haskell`. # 1.10.5 * Apply an optimization to generated `to(1)`/`from(1)` instances that factors out common occurrences of `M1`. See http://git.haskell.org/ghc.git/commit/9649fc0ae45e006c2ed54cc5ea2414158949fadb * Export internal typeclass names * Fix Haddock issues with GHC 7.8 # 1.10.4.1 * Fix Haddock parsing issue on GHC 8.0 # 1.10.4 * Backported `MonadPlus` and `MonadZip` instances for `U1`, and made the `Functor`, `Foldable`, `Traversable`, `Alternative`, and `Monad` instances for `U1` lazier to correspond with `base-4.9` # 1.10.3 * Backported `Enum`, `Bounded`, `Ix`, `Functor`, `Applicative`, `Monad`, `MonadFix`, `MonadPlus`, `MonadZip`, `Foldable`, `Traversable`, and `Data` instances (introduced in `base-4.9`) for datatypes in the `Generics.Deriving.Base` module # 1.10.2 * Fix TH regression on GHC 7.0 # 1.10.1 * Added `Generics.Deriving.Semigroup` * Added `GMonoid` instance for `Data.Monoid.Alt` * Fixed a bug in the `GEnum` instances for unsigned `Integral` types * Added `Safe`/`Trustworthy` pragmas * Made instances polykinded where possible # 1.10.0 * On GHC 8.0 and up, `Generics.Deriving.TH` uses the new type literal-based machinery * Rewrote the Template Haskell code to be robust. Among other things, this fixes a bug with deriving Generic1 instances on GHC 7.8, and makes it easier to derive Generic1 instances for datatypes that utilize GHC 8.0's `-XTypeInType` extension. * Added `deriveAll0` and `makeRep0` for symmetry with `deriveAll1` and `makeRep1` * Added`makeRep0FromType` and `makeRep1FromType` to make it easier to pass in the type instance (instead of having to pass each individual type variable, which can be error-prone) * Added functions with the suffix `-WithKindSigs` to allow generating type synonyms with explicit kind signatures in the presence of kind-polymorphic type variables. This is necessary for some datatypes that use `-XTypeInType` to have derived `Generic(1)` instances, but is not turned on by default since the TH kind inference is not perfect and would cause otherwise valid code to be rejected. Use only if you know what you are doing. * Fixed bug where a datatype with a single, nullary constructor would generate incorrect `Generic` instances * More sensible `GEnum` instances for fixed-size integral types * Added `GCopoint`, `GEnum`, `GEq`, `GFoldable`, `GFunctor`, `GMonoid`, `GShow`, and `GTraversable` instances for datatypes introduced in GHC 8.0 * Backported `Generic(1)` instances added in GHC 8.0. Specifically, `Generic` instances for `Complex` (`base-4.4` and later) `ExitCode`, and `Version`; and `Generic1` instances for `Complex` (`base-4.4` and later) and `Proxy` (`base-4.7` and later). Added `GEnum`, `GEq`, `GFoldable`, `GFunctor`, `GIx`, `GShow`, and `GTraversable` instances for these datatypes where appropriate. # 1.9.0 * Allow deriving of Generic1 using Template Haskell * Allow deriving of Generic(1) for data families * Allow deriving of Generic(1) for constructor-less plain datatypes (but not data families, due to technical restrictions) * Support for unboxed representation types on GHC 7.11+ * More `GCopoint`, `GEnum`, `GEq`, `GFoldable`, `GFunctor`, `GIx`, `GMonoid`, `GShow`, and `GTraversable` instances * The field accessors for the `(:+:)` type in `Generics.Deriving.Base` have been removed to be consistent with `GHC.Generics` * Ensure that TH generates definitions for isNewtype and packageName, if a recent-enough version of GHC is used * Ensure that TH-generated names are unique for a given data type's module and package (similar in spirit to Trac #10487) * Allow building on stage-1 compilers generic-deriving-1.11.1/tests/0000755000000000000000000000000012765116253014354 5ustar0000000000000000generic-deriving-1.11.1/tests/TypeInTypeSpec.hs0000644000000000000000000000117612765116253017602 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} #if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TypeInType #-} #endif module TypeInTypeSpec (main, spec) where import Test.Hspec #if __GLASGOW_HASKELL__ >= 800 import Data.Proxy (Proxy) import Generics.Deriving.TH data TyCon x (a :: x) (b :: k) = TyCon k x (Proxy a) (TyCon x a b) $(deriveAll0And1 ''TyCon) data family TyFam x (a :: x) (b :: k) data instance TyFam x (a :: x) (b :: k) = TyFam k x (Proxy a) (TyFam x a b) $(deriveAll0And1 'TyFam) #endif main :: IO () main = hspec spec spec :: Spec spec = return () generic-deriving-1.11.1/tests/Spec.hs0000644000000000000000000000005412765116253015601 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} generic-deriving-1.11.1/tests/ExampleSpec.hs0000644000000000000000000003261112765116253017121 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} #endif {-# OPTIONS_GHC -fno-warn-orphans #-} module ExampleSpec (main, spec) where import Generics.Deriving import Generics.Deriving.TH import GHC.Exts (Addr#, Char#, Double#, Float#, Int#, Word#) import Prelude hiding (Either(..)) import Test.Hspec (Spec, describe, hspec, it, parallel, shouldBe) import qualified Text.Read.Lex (Lexeme) main :: IO () main = hspec spec spec :: Spec spec = parallel $ do describe "[] and Maybe tests" $ do it "gshow hList" $ gshow hList `shouldBe` "[1,2,3,4,5,6,7,8,9,10]" it "gshow (children maybe2)" $ gshow (children maybe2) `shouldBe` "[]" it "gshow (transform (const \"abc\") [])" $ gshow (transform (const "abc") []) `shouldBe` "\"abc\"" it "gshow (transform double hList)" $ gshow (transform double hList) `shouldBe` "[1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,10,10]" it "gshow (geq hList hList)" $ gshow (geq hList hList) `shouldBe` "True" it "gshow (geq maybe1 maybe2)" $ gshow (geq maybe1 maybe2) `shouldBe` "False" it "gshow (take 5 genum)" $ gshow (take 5 (genum :: [Maybe Int])) `shouldBe` "[Nothing,Just 0,Just -1,Just 1,Just -2]" it "gshow (take 15 genum)" $ gshow (take 15 (genum :: [[Int]])) `shouldBe` "[[],[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]]" it "gshow (range ([0], [1]))" $ gshow (range ([0], [1::Int])) `shouldBe` "[[0],[0,0],[-1],[0,0,0],[-1,0]]" it "gshow (inRange ([0], [3,5]) hList)" $ gshow (inRange ([0], [3,5::Int]) hList) `shouldBe` "False" describe "Tests for Tree" $ do it "gshow tree" $ gshow tree `shouldBe` "Branch 2 Empty (Branch 1 Empty Empty)" it "gshow (children tree)" $ gshow (children tree) `shouldBe` "[Empty,Branch 1 Empty Empty]" it "gshow (descend (descend (\\_ -> Branch 0 Empty Empty)) tree)" $ gshow (descend (descend (\_ -> Branch 0 Empty Empty)) tree) `shouldBe` "Branch 2 Empty (Branch 1 (Branch 0 Empty Empty) (Branch 0 Empty Empty))" it "gshow (context tree [Branch 1 Empty Empty,Empty])" $ gshow (context tree [Branch 1 Empty Empty,Empty]) `shouldBe` "Branch 2 (Branch 1 Empty Empty) Empty" it "gshow (transform upgradeTree tree)" $ gshow (transform upgradeTree tree) `shouldBe` "Branch 3 (Branch 0 Empty Empty) (Branch 2 (Branch 0 Empty Empty) (Branch 0 Empty Empty))" it "gshow (take 10 genum)" $ do gshow (take 10 (genum :: [Tree])) `shouldBe` "[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)]" describe "Tests for List" $ do it "gshow (gmap fromEnum list)" $ gshow (gmap fromEnum list) `shouldBe` "Cons 112 (Cons 113 Nil)" it "gshow (gmap gshow listlist)" $ gshow (gmap gshow listlist) `shouldBe` "Cons \"Cons 'p' (Cons 'q' Nil)\" (Cons \"Nil\" Nil)" it "gshow list" $ gshow list `shouldBe` "Cons 'p' (Cons 'q' Nil)" it "gshow listlist" $ gshow listlist `shouldBe` "Cons (Cons 'p' (Cons 'q' Nil)) (Cons Nil Nil)" it "gshow (children list)" $ gshow (children list) `shouldBe` "[Cons 'q' Nil]" it "gshow (children listlist)" $ gshow (children listlist) `shouldBe` "[Cons Nil Nil]" describe "Tests for Rose" $ do it "gshow rose1" $ gshow rose1 `shouldBe` "Rose [1,2] [Rose [3,4] [],Rose [5] []]" it "gshow (gmap gshow rose1)" $ gshow (gmap gshow rose1) `shouldBe` "Rose [\"1\",\"2\"] [Rose [\"3\",\"4\"] [],Rose [\"5\"] []]" describe "Tests for GRose" $ do it "gshow grose1" $ gshow grose1 `shouldBe` "GRose [1,2] [GRose [3] [],GRose [] []]" it "gshow (gmap gshow grose1)" $ gshow (gmap gshow grose1) `shouldBe` "GRose [\"1\",\"2\"] [GRose [\"3\"] [],GRose [] []]" describe "Tests for Either" $ do it "gshow either1" $ gshow either1 `shouldBe` "Left Right 'p'" it "gshow (gmap gshow either1)" $ gshow (gmap gshow either1) `shouldBe` "Left Right \"'p'\"" describe "Tests for Nested" $ do it "gshow nested" $ gshow nested `shouldBe` "Nested {value = 1, rec = Nested {value = [2], rec = Nested {value = [[3],[4,5],[]], rec = Leaf}}}" it "gshow (gmap gshow nested)" $ gshow (gmap gshow nested) `shouldBe` "Nested {value = \"1\", rec = Nested {value = [\"2\"], rec = Nested {value = [[\"3\"],[\"4\",\"5\"],[]], rec = Leaf}}}" describe "Tests for Bush" $ do it "gshow bush1" $ gshow bush1 `shouldBe` "BushCons 0 (BushCons (BushCons 1 BushNil) BushNil)" it "gshow (gmap gshow bush1)" $ gshow (gmap gshow bush1) `shouldBe` "BushCons \"0\" (BushCons (BushCons \"1\" BushNil) BushNil)" ------------------------------------------------------------------------------- -- Example: Haskell's lists and Maybe ------------------------------------------------------------------------------- hList:: [Int] hList = [1..10] maybe1, maybe2 :: Maybe (Maybe Char) maybe1 = Nothing maybe2 = Just (Just 'p') double :: [Int] -> [Int] double [] = [] double (x:xs) = x:x:xs ------------------------------------------------------------------------------- -- Example: trees of integers (kind *) ------------------------------------------------------------------------------- data Tree = Empty | Branch Int Tree 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 upgradeTree :: Tree -> Tree upgradeTree Empty = Branch 0 Empty Empty upgradeTree (Branch n l r) = Branch (succ n) l r tree :: Tree tree = Branch 2 Empty (Branch 1 Empty Empty) ------------------------------------------------------------------------------- -- Example: lists (kind * -> *) ------------------------------------------------------------------------------- data List a = Nil | Cons a (List a) 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 list :: List Char list = Cons 'p' (Cons 'q' Nil) listlist :: List (List Char) listlist = Cons list (Cons Nil Nil) -- ["pq",""] ------------------------------------------------------------------------------- -- Example: Type composition ------------------------------------------------------------------------------- data Rose a = Rose [a] [Rose a] instance (GShow a) => GShow (Rose a) where gshowsPrec = gshowsPrecdefault instance GFunctor Rose where gmap = gmapdefault -- Example usage rose1 :: Rose Int rose1 = Rose [1,2] [Rose [3,4] [], Rose [5] []] ------------------------------------------------------------------------------- -- 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) 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 grose1 :: GRose [] Int grose1 = GRose [1,2] [GRose [3] [], GRose [] []] ------------------------------------------------------------------------------- -- Example: Two parameters, nested on other parameter ------------------------------------------------------------------------------- data Either a b = Left (Either [a] b) | Right b instance (GShow a, GShow b) => GShow (Either a b) where gshowsPrec = gshowsPrecdefault instance GFunctor (Either a) where gmap = gmapdefault either1 :: Either Int Char either1 = Left either2 either2 :: Either [Int] Char either2 = Right 'p' ------------------------------------------------------------------------------- -- Example: Nested datatype, record selectors ------------------------------------------------------------------------------- data Nested a = Leaf | Nested { value :: a, rec :: Nested [a] } deriving Functor instance (GShow a) => GShow (Nested a) where gshowsPrec = gshowsPrecdefault instance GFunctor Nested where gmap = gmapdefault nested :: Nested Int nested = Nested { value = 1, rec = Nested [2] (Nested [[3],[4,5],[]] Leaf) } ------------------------------------------------------------------------------- -- Example: Nested datatype Bush (minimal) ------------------------------------------------------------------------------- data Bush a = BushNil | BushCons a (Bush (Bush a)) deriving Functor instance GFunctor Bush where gmap = gmapdefault instance (GShow a) => GShow (Bush a) where gshowsPrec = gshowsPrecdefault bush1 :: Bush Int bush1 = BushCons 0 (BushCons (BushCons 1 BushNil) BushNil) ------------------------------------------------------------------------------- -- Example: Double type composition (minimal) ------------------------------------------------------------------------------- data Weird a = Weird [[[a]]] deriving Show instance GFunctor Weird where gmap = gmapdefault -------------------------------------------------------------------------------- -- Temporary tests for TH generation -------------------------------------------------------------------------------- data Empty a data (:/:) f a = MyType1Nil | MyType1Cons { _myType1Rec :: (f :/: a), _myType2Rec :: MyType2 } | MyType1Cons2 (f :/: a) Int a (f a) | (f :/: a) :/: MyType2 infixr 5 :!@!: data GADTSyntax a b where GADTPrefix :: d -> c -> GADTSyntax c d (:!@!:) :: e -> f -> GADTSyntax e f data MyType2 = MyType2 Float ([] :/: Int) data PlainHash a = Hash a Addr# Char# Double# Float# Int# Word# -- Test to see if generated names are unique data Lexeme = Lexeme #if MIN_VERSION_template_haskell(2,7,0) data family MyType3 # if __GLASGOW_HASKELL__ >= 705 (a :: v) (b :: w) (c :: x) (d :: y) (e :: z) # else (a :: *) (b :: *) (c :: * -> *) (d :: *) (e :: *) # endif newtype instance MyType3 (f p) (f p) f p q = MyType3Newtype q data instance MyType3 Bool () f p q = MyType3True | MyType3False data instance MyType3 Int () f p q = MyType3Hash q Addr# Char# Double# Float# Int# Word# #endif ------------------------------------------------------------------------------- -- Template Haskell bits ------------------------------------------------------------------------------- $(deriveAll0 ''Tree) $(deriveAll0And1 ''List) $(deriveAll0And1 ''Rose) $(deriveMeta ''GRose) $(deriveRepresentable0 ''GRose) $(deriveRep1 ''GRose) instance Functor f => Generic1 (GRose f) where type Rep1 (GRose f) = $(makeRep1 ''GRose) f from1 = $(makeFrom1 ''GRose) to1 = $(makeTo1 ''GRose) $(deriveAll0And1 ''Either) $(deriveAll0And1 ''Nested) $(deriveAll0And1 ''Bush) $(deriveAll0And1 ''Weird) $(deriveAll0And1 ''Empty) $(deriveAll0And1 ''(:/:)) $(deriveAll0And1 ''GADTSyntax) $(deriveAll0 ''MyType2) $(deriveAll0And1 ''PlainHash) $(deriveAll0 ''ExampleSpec.Lexeme) $(deriveAll0 ''Text.Read.Lex.Lexeme) #if MIN_VERSION_template_haskell(2,7,0) # if __GLASGOW_HASKELL__ < 705 -- We can't use deriveAll0And1 on GHC 7.4 due to an old bug :( $(deriveMeta 'MyType3Newtype) $(deriveRep0 'MyType3Newtype) $(deriveRep1 'MyType3Newtype) instance Generic (MyType3 (f p) (f p) f p q) where type Rep (MyType3 (f p) (f p) f p q) = $(makeRep0 'MyType3Newtype) f p q from = $(makeFrom0 'MyType3Newtype) to = $(makeTo0 'MyType3Newtype) instance Generic1 (MyType3 (f p) (f p) f p) where type Rep1 (MyType3 (f p) (f p) f p) = $(makeRep1 'MyType3Newtype) f p from1 = $(makeFrom1 'MyType3Newtype) to1 = $(makeTo1 'MyType3Newtype) # else $(deriveAll0And1 'MyType3Newtype) # endif $(deriveAll0And1 'MyType3False) $(deriveAll0And1 'MyType3Hash) #endif generic-deriving-1.11.1/src/0000755000000000000000000000000012765116253014001 5ustar0000000000000000generic-deriving-1.11.1/src/Generics/0000755000000000000000000000000012765116253015540 5ustar0000000000000000generic-deriving-1.11.1/src/Generics/Deriving.hs0000644000000000000000000000111012765116253017634 0ustar0000000000000000 module Generics.Deriving ( module Generics.Deriving.Base, module Generics.Deriving.Copoint, module Generics.Deriving.ConNames, module Generics.Deriving.Enum, module Generics.Deriving.Eq, module Generics.Deriving.Functor, module Generics.Deriving.Show, module Generics.Deriving.Uniplate ) where import Generics.Deriving.Base import Generics.Deriving.Copoint import Generics.Deriving.ConNames import Generics.Deriving.Enum import Generics.Deriving.Eq import Generics.Deriving.Functor import Generics.Deriving.Show import Generics.Deriving.Uniplate generic-deriving-1.11.1/src/Generics/Deriving/0000755000000000000000000000000012765116253017307 5ustar0000000000000000generic-deriving-1.11.1/src/Generics/Deriving/Uniplate.hs0000644000000000000000000002431012765116253021424 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #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 ( -- * Generic Uniplate class Uniplate(..) -- * Derived functions , uniplate , universe , rewrite , rewriteM , contexts , holes , para -- * Default definitions , childrendefault , contextdefault , descenddefault , descendMdefault , transformdefault , transformMdefault -- * Internal Uniplate class , Uniplate'(..) ) where import Generics.Deriving.Base import Control.Monad (liftM, liftM2) import GHC.Exts (build) -------------------------------------------------------------------------------- -- Generic Uniplate -------------------------------------------------------------------------------- class Uniplate' f b where children' :: f a -> [b] descend' :: (b -> b) -> f a -> f a descendM' :: Monad m => (b -> m b) -> f a -> m (f a) transform' :: (b -> b) -> f a -> f a transformM' :: Monad m => (b -> m b) -> f a -> m (f a) instance Uniplate' U1 a where children' U1 = [] descend' _ U1 = U1 descendM' _ U1 = return U1 transform' _ U1 = U1 transformM' _ U1 = return U1 instance #if __GLASGOW_HASKELL__ >= 709 {-# OVERLAPPING #-} #endif (Uniplate a) => Uniplate' (K1 i a) a where children' (K1 a) = [a] descend' f (K1 a) = K1 (f a) descendM' f (K1 a) = liftM K1 (f a) transform' f (K1 a) = K1 (transform f a) transformM' f (K1 a) = liftM K1 (transformM f a) instance #if __GLASGOW_HASKELL__ >= 709 {-# OVERLAPPABLE #-} #endif Uniplate' (K1 i a) b where children' (K1 _) = [] descend' _ (K1 a) = K1 a descendM' _ (K1 a) = return (K1 a) transform' _ (K1 a) = K1 a transformM' _ (K1 a) = return (K1 a) instance (Uniplate' f b) => Uniplate' (M1 i c f) b where children' (M1 a) = children' a descend' f (M1 a) = M1 (descend' f a) descendM' f (M1 a) = liftM M1 (descendM' f a) transform' f (M1 a) = M1 (transform' f a) transformM' f (M1 a) = liftM M1 (transformM' f a) instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :+: g) b where children' (L1 a) = children' a children' (R1 a) = children' a descend' f (L1 a) = L1 (descend' f a) descend' f (R1 a) = R1 (descend' f a) descendM' f (L1 a) = liftM L1 (descendM' f a) descendM' f (R1 a) = liftM R1 (descendM' f a) transform' f (L1 a) = L1 (transform' f a) transform' f (R1 a) = R1 (transform' f a) transformM' f (L1 a) = liftM L1 (transformM' f a) transformM' f (R1 a) = liftM R1 (transformM' f a) instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :*: g) b where children' (a :*: b) = children' a ++ children' b descend' f (a :*: b) = descend' f a :*: descend' f b descendM' f (a :*: b) = liftM2 (:*:) (descendM' f a) (descendM' f b) transform' f (a :*: b) = transform' f a :*: transform' f b transformM' f (a :*: b) = liftM2 (:*:) (transformM' f a) (transformM' f b) -- Context' is a separate class from Uniplate' since it uses special product -- instances, but the context function still appears in Uniplate. class Context' f b where context' :: f a -> [b] -> f a instance Context' U1 b where context' U1 _ = U1 instance #if __GLASGOW_HASKELL__ >= 709 {-# OVERLAPPING #-} #endif Context' (K1 i a) a where context' _ [] = error "Generics.Deriving.Uniplate.context: empty list" context' (K1 _) (c:_) = K1 c instance #if __GLASGOW_HASKELL__ >= 709 {-# OVERLAPPABLE #-} #endif Context' (K1 i a) b where context' (K1 a) _ = K1 a instance (Context' f b) => Context' (M1 i c f) b where context' (M1 a) cs = M1 (context' a cs) instance (Context' f b, Context' g b) => Context' (f :+: g) b where context' (L1 a) cs = L1 (context' a cs) context' (R1 a) cs = R1 (context' a cs) instance #if __GLASGOW_HASKELL__ >= 709 {-# OVERLAPPING #-} #endif (Context' g a) => Context' (M1 i c (K1 j a) :*: g) a where context' _ [] = error "Generics.Deriving.Uniplate.context: empty list" context' (M1 (K1 _) :*: b) (c:cs) = M1 (K1 c) :*: context' b cs instance #if __GLASGOW_HASKELL__ >= 709 {-# OVERLAPPABLE #-} #endif (Context' g b) => Context' (f :*: g) b where context' (a :*: b) cs = a :*: context' b cs class Uniplate a where children :: a -> [a] #if __GLASGOW_HASKELL__ >= 701 default children :: (Generic a, Uniplate' (Rep a) a) => a -> [a] children = childrendefault #endif context :: a -> [a] -> a #if __GLASGOW_HASKELL__ >= 701 default context :: (Generic a, Context' (Rep a) a) => a -> [a] -> a context = contextdefault #endif descend :: (a -> a) -> a -> a #if __GLASGOW_HASKELL__ >= 701 default descend :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a descend = descenddefault #endif descendM :: Monad m => (a -> m a) -> a -> m a #if __GLASGOW_HASKELL__ >= 701 default descendM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a descendM = descendMdefault #endif transform :: (a -> a) -> a -> a #if __GLASGOW_HASKELL__ >= 701 default transform :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a transform = transformdefault #endif transformM :: Monad m => (a -> m a) -> a -> m a #if __GLASGOW_HASKELL__ >= 701 default transformM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a transformM = transformMdefault #endif childrendefault :: (Generic a, Uniplate' (Rep a) a) => a -> [a] childrendefault = children' . from contextdefault :: (Generic a, Context' (Rep a) a) => a -> [a] -> a contextdefault x cs = to (context' (from x) cs) descenddefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a descenddefault f = to . descend' f . from descendMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a descendMdefault f = liftM to . descendM' f . from transformdefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a transformdefault f = f . to . transform' f . from transformMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a transformMdefault f = liftM to . transformM' f . from -- Derived functions (mostly copied from Neil Michell's code) uniplate :: Uniplate a => a -> ([a], [a] -> a) uniplate a = (children a, context a) universe :: Uniplate a => a -> [a] universe a = build (go a) where go x cons nil = cons x $ foldr ($) nil $ map (\c -> go c cons) $ children x rewrite :: Uniplate a => (a -> Maybe a) -> a -> a rewrite f = transform g where g x = maybe x (rewrite f) (f x) rewriteM :: (Monad m, Uniplate a) => (a -> m (Maybe a)) -> a -> m a rewriteM f = transformM g where g x = f x >>= maybe (return x) (rewriteM f) contexts :: Uniplate a => a -> [(a, a -> a)] contexts a = (a, id) : f (holes a) where f xs = [ (ch2, ctx1 . ctx2) | (ch1, ctx1) <- xs , (ch2, ctx2) <- contexts ch1] holes :: Uniplate a => a -> [(a, a -> a)] holes a = uncurry f (uniplate a) where f [] _ = [] f (x:xs) gen = (x, gen . (:xs)) : f xs (gen . (x:)) para :: Uniplate a => (a -> [r] -> r) -> a -> r para f x = f x $ map (para f) $ children x -- Base types instances instance Uniplate Bool where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate Char where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate Double where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate Float where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate Int where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate () where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return -- Tuple instances instance Uniplate (b,c) where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate (b,c,d) where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate (b,c,d,e) where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate (b,c,d,e,f) where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate (b,c,d,e,f,g) where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate (b,c,d,e,f,g,h) where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return -- Parameterized type instances instance Uniplate (Maybe a) where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate (Either a b) where children _ = [] context x _ = x descend _ = id descendM _ = return transform = id transformM _ = return instance Uniplate [a] where children [] = [] children (_:t) = [t] context _ [] = error "Generics.Deriving.Uniplate.context: empty list" context [] _ = [] context (h:_) (t:_) = h:t descend _ [] = [] descend f (h:t) = h:f t descendM _ [] = return [] descendM f (h:t) = f t >>= \t' -> return (h:t') transform f [] = f [] transform f (h:t) = f (h:transform f t) transformM f [] = f [] transformM f (h:t) = transformM f t >>= \t' -> f (h:t') generic-deriving-1.11.1/src/Generics/Deriving/Traversable.hs0000644000000000000000000001351212765116253022117 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE Safe #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif module Generics.Deriving.Traversable ( -- * Generic Traversable class GTraversable(..) -- * Default method , gtraversedefault -- * Internal Traversable class , GTraversable'(..) ) where import Control.Applicative (Const, WrappedMonad(..), ZipList) #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative (Applicative(..), (<$>)) #endif import qualified Data.Monoid as Monoid (First, Last, Product, Sum) import Data.Monoid (Dual) import Generics.Deriving.Base import Generics.Deriving.Foldable import Generics.Deriving.Functor #if MIN_VERSION_base(4,4,0) import Data.Complex (Complex) #endif #if MIN_VERSION_base(4,7,0) import Data.Proxy (Proxy) #endif #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity) #endif #if MIN_VERSION_base(4,9,0) import qualified Data.Functor.Product as Functor (Product) import qualified Data.Functor.Sum as Functor (Sum) import Data.List.NonEmpty (NonEmpty) import qualified Data.Semigroup as Semigroup (First, Last) import Data.Semigroup (Arg, Max, Min, Option, WrappedMonoid) #endif -------------------------------------------------------------------------------- -- Generic traverse -------------------------------------------------------------------------------- class GTraversable' t where gtraverse' :: Applicative f => (a -> f b) -> t a -> f (t b) instance GTraversable' U1 where gtraverse' _ U1 = pure U1 instance GTraversable' Par1 where gtraverse' f (Par1 a) = Par1 <$> f a instance GTraversable' (K1 i c) where gtraverse' _ (K1 a) = pure (K1 a) instance (GTraversable f) => GTraversable' (Rec1 f) where gtraverse' f (Rec1 a) = Rec1 <$> gtraverse f a instance (GTraversable' f) => GTraversable' (M1 i c f) where gtraverse' f (M1 a) = M1 <$> gtraverse' f a instance (GTraversable' f, GTraversable' g) => GTraversable' (f :+: g) where gtraverse' f (L1 a) = L1 <$> gtraverse' f a gtraverse' f (R1 a) = R1 <$> gtraverse' f a instance (GTraversable' f, GTraversable' g) => GTraversable' (f :*: g) where gtraverse' f (a :*: b) = (:*:) <$> gtraverse' f a <*> gtraverse' f b instance (GTraversable f, GTraversable' g) => GTraversable' (f :.: g) where gtraverse' f (Comp1 x) = Comp1 <$> gtraverse (gtraverse' f) x instance GTraversable' UAddr where gtraverse' _ (UAddr a) = pure (UAddr a) instance GTraversable' UChar where gtraverse' _ (UChar c) = pure (UChar c) instance GTraversable' UDouble where gtraverse' _ (UDouble d) = pure (UDouble d) instance GTraversable' UFloat where gtraverse' _ (UFloat f) = pure (UFloat f) instance GTraversable' UInt where gtraverse' _ (UInt i) = pure (UInt i) instance GTraversable' UWord where gtraverse' _ (UWord w) = pure (UWord w) class (GFunctor t, GFoldable t) => GTraversable t where gtraverse :: Applicative f => (a -> f b) -> t a -> f (t b) #if __GLASGOW_HASKELL__ >= 701 default gtraverse :: (Generic1 t, GTraversable' (Rep1 t), Applicative f) => (a -> f b) -> t a -> f (t b) gtraverse = gtraversedefault #endif gsequenceA :: Applicative f => t (f a) -> f (t a) gsequenceA = gtraverse id gmapM :: Monad m => (a -> m b) -> t a -> m (t b) gmapM f = unwrapMonad . gtraverse (WrapMonad . f) gsequence :: Monad m => t (m a) -> m (t a) gsequence = gmapM id gtraversedefault :: (Generic1 t, GTraversable' (Rep1 t), Applicative f) => (a -> f b) -> t a -> f (t b) gtraversedefault f x = to1 <$> gtraverse' f (from1 x) -- Base types instances instance GTraversable ((,) a) where gtraverse = gtraversedefault instance GTraversable [] where gtraverse = gtraversedefault #if MIN_VERSION_base(4,9,0) instance GTraversable (Arg a) where gtraverse = gtraversedefault #endif #if MIN_VERSION_base(4,4,0) instance GTraversable Complex where gtraverse = gtraversedefault #endif instance GTraversable (Const m) where gtraverse = gtraversedefault instance GTraversable Dual where gtraverse = gtraversedefault instance GTraversable (Either a) where gtraverse = gtraversedefault instance GTraversable Monoid.First where gtraverse = gtraversedefault #if MIN_VERSION_base(4,9,0) instance GTraversable (Semigroup.First) where gtraverse = gtraversedefault #endif #if MIN_VERSION_base(4,8,0) instance GTraversable Identity where gtraverse = gtraversedefault #endif instance GTraversable Monoid.Last where gtraverse = gtraversedefault #if MIN_VERSION_base(4,9,0) instance GTraversable Semigroup.Last where gtraverse = gtraversedefault instance GTraversable Max where gtraverse = gtraversedefault #endif instance GTraversable Maybe where gtraverse = gtraversedefault #if MIN_VERSION_base(4,9,0) instance GTraversable Min where gtraverse = gtraversedefault instance GTraversable NonEmpty where gtraverse = gtraversedefault instance GTraversable Option where gtraverse = gtraversedefault #endif instance GTraversable Monoid.Product where gtraverse = gtraversedefault #if MIN_VERSION_base(4,9,0) instance (GTraversable f, GTraversable g) => GTraversable (Functor.Product f g) where gtraverse = gtraversedefault #endif #if MIN_VERSION_base(4,7,0) instance GTraversable Proxy where gtraverse = gtraversedefault #endif instance GTraversable Monoid.Sum where gtraverse = gtraversedefault #if MIN_VERSION_base(4,9,0) instance (GTraversable f, GTraversable g) => GTraversable (Functor.Sum f g) where gtraverse = gtraversedefault instance GTraversable WrappedMonoid where gtraverse = gtraversedefault #endif instance GTraversable ZipList where gtraverse = gtraversedefault generic-deriving-1.11.1/src/Generics/Deriving/TH.hs0000644000000000000000000014635112765116253020170 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {- | Module : Generics.Deriving.TH Copyright : (c) 2008--2009 Universiteit Utrecht License : BSD3 Maintainer : generics@haskell.org Stability : experimental Portability : non-portable This module contains Template Haskell code that can be used to automatically generate the boilerplate code for the generic deriving library. To use these functions, pass the name of a data type as an argument: @ {-# LANGUAGE TemplateHaskell #-} data Example a = Example Int Char a $('deriveAll0' ''Example) -- Derives Generic instance $('deriveAll1' ''Example) -- Derives Generic1 instance $('deriveAll0And1' ''Example) -- Derives Generic and Generic1 instances @ On GHC 7.4 or later, this code can also be used with data families. To derive for a data family instance, pass the name of one of the instance's constructors: @ {-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-} data family Family a b newtype instance Family Char x = FamilyChar Char data instance Family Bool x = FamilyTrue | FamilyFalse $('deriveAll0' 'FamilyChar) -- instance Generic (Family Char b) where ... $('deriveAll1' 'FamilyTrue) -- instance Generic1 (Family Bool) where ... -- Alternatively, one could type $(deriveAll1 'FamilyFalse) @ -} -- Adapted from Generics.Regular.TH module Generics.Deriving.TH ( -- * @derive@- functions deriveMeta , deriveData , deriveConstructors , deriveSelectors , deriveAll , deriveAll0 , deriveAll1 , deriveAll0And1 , deriveRepresentable0 , deriveRepresentable1 , deriveRep0 , deriveRep1 , simplInstance -- * @make@- functions -- $make , makeRep0Inline , makeRep0 , makeRep0FromType , makeFrom , makeFrom0 , makeTo , makeTo0 , makeRep1Inline , makeRep1 , makeRep1FromType , makeFrom1 , makeTo1 -- * Options -- $options -- ** Option types , Options(..) , defaultOptions , RepOptions(..) , defaultRepOptions , KindSigOptions , defaultKindSigOptions -- ** Functions with optional arguments , deriveAll0Options , deriveAll1Options , deriveAll0And1Options , deriveRepresentable0Options , deriveRepresentable1Options , deriveRep0Options , deriveRep1Options ) where import Control.Monad ((>=>), unless, when) #if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0)) import Data.Foldable (foldr') #endif import Data.List (nub) import qualified Data.Map as Map (fromList) import Data.Maybe (catMaybes) import Generics.Deriving.TH.Internal #if MIN_VERSION_base(4,9,0) import Generics.Deriving.TH.Post4_9 #else import Generics.Deriving.TH.Pre4_9 #endif import Language.Haskell.TH.Lib import Language.Haskell.TH {- $options 'Options' gives you a way to further tweak derived 'Generic' and 'Generic1' instances: * 'RepOptions': By default, all derived 'Rep' and 'Rep1' type instances emit the code directly (the 'InlineRep' option). One can also choose to emit a separate type synonym for the 'Rep' type (this is the functionality of 'deriveRep0' and 'deriveRep1') and define a 'Rep' instance in terms of that type synonym (the 'TypeSynonymRep' option). * 'KindSigOptions': By default, all derived instances will use explicit kind signatures (when the 'KindSigOptions' is 'True'). You might wish to set the 'KindSigOptions' to 'False' if you want a 'Generic'/'Generic1' instance at a particular kind that GHC will infer correctly, but the functions in this module won't guess correctly. For example, the following example will only compile with 'KindSigOptions' set to 'False': @ newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) = Compose (f (g a)) $('deriveAll1Options' False ''Compose) @ -} -- | Given the names of a generic class, a type to instantiate, a function in -- the class and the default implementation, generates the code for a basic -- generic instance. simplInstance :: Name -> Name -> Name -> Name -> Q [Dec] simplInstance cl ty fn df = do x <- newName "x" let typ = ForallT [PlainTV x] [] ((foldl (\a -> AppT a . VarT . tyVarBndrName) (ConT (genRepName Generic DataPlain ty)) []) `AppT` (VarT x)) fmap (: []) $ instanceD (cxt []) (conT cl `appT` conT ty) [funD fn [clause [] (normalB (varE df `appE` (sigE (varE undefinedValName) (return typ)))) []]] -- | Additional options for configuring derived 'Generic'/'Generic1' instances -- using Template Haskell. data Options = Options { repOptions :: RepOptions , kindSigOptions :: KindSigOptions } deriving (Eq, Ord, Read, Show) -- | Sensible default 'Options' ('defaultRepOptions' and 'defaultKindSigOptions'). defaultOptions :: Options defaultOptions = Options { repOptions = defaultRepOptions , kindSigOptions = defaultKindSigOptions } -- | Configures whether 'Rep'/'Rep1' type instances should be defined inline in a -- derived 'Generic'/'Generic1' instance ('InlineRep') or defined in terms of a -- type synonym ('TypeSynonymRep'). data RepOptions = InlineRep | TypeSynonymRep deriving (Eq, Ord, Read, Show) -- | 'InlineRep', a sensible default 'RepOptions'. defaultRepOptions :: RepOptions defaultRepOptions = InlineRep -- | 'True' if explicit kind signatures should be used in derived -- 'Generic'/'Generic1' instances, 'False' otherwise. type KindSigOptions = Bool -- | 'True', a sensible default 'KindSigOptions'. defaultKindSigOptions :: KindSigOptions defaultKindSigOptions = True -- | A backwards-compatible synonym for 'deriveAll0'. deriveAll :: Name -> Q [Dec] deriveAll = deriveAll0 -- | Given the type and the name (as string) for the type to derive, -- generate the 'Data' instance, the 'Constructor' instances, the 'Selector' -- instances, and the 'Representable0' instance. deriveAll0 :: Name -> Q [Dec] deriveAll0 = deriveAll0Options defaultOptions -- | Like 'deriveAll0', but takes an 'Options' argument. deriveAll0Options :: Options -> Name -> Q [Dec] deriveAll0Options = deriveAllCommon True False -- | Given the type and the name (as string) for the type to derive, -- generate the 'Data' instance, the 'Constructor' instances, the 'Selector' -- instances, and the 'Representable1' instance. deriveAll1 :: Name -> Q [Dec] deriveAll1 = deriveAll1Options defaultOptions -- | Like 'deriveAll1', but takes an 'Options' argument. deriveAll1Options :: Options -> Name -> Q [Dec] deriveAll1Options = deriveAllCommon False True -- | Given the type and the name (as string) for the type to derive, -- generate the 'Data' instance, the 'Constructor' instances, the 'Selector' -- instances, the 'Representable0' instance, and the 'Representable1' instance. deriveAll0And1 :: Name -> Q [Dec] deriveAll0And1 = deriveAll0And1Options defaultOptions -- | Like 'deriveAll0And1', but takes an 'Options' argument. deriveAll0And1Options :: Options -> Name -> Q [Dec] deriveAll0And1Options = deriveAllCommon True True deriveAllCommon :: Bool -> Bool -> Options -> Name -> Q [Dec] deriveAllCommon generic generic1 opts n = do a <- deriveMeta n b <- if generic then deriveRepresentableCommon Generic opts n else return [] c <- if generic1 then deriveRepresentableCommon Generic1 opts n else return [] return (a ++ b ++ c) -- | Given the type and the name (as string) for the Representable0 type -- synonym to derive, generate the 'Representable0' instance. deriveRepresentable0 :: Name -> Q [Dec] deriveRepresentable0 = deriveRepresentable0Options defaultOptions -- | Like 'deriveRepresentable0', but takes an 'Options' argument. deriveRepresentable0Options :: Options -> Name -> Q [Dec] deriveRepresentable0Options = deriveRepresentableCommon Generic -- | Given the type and the name (as string) for the Representable1 type -- synonym to derive, generate the 'Representable1' instance. deriveRepresentable1 :: Name -> Q [Dec] deriveRepresentable1 = deriveRepresentable1Options defaultOptions -- | Like 'deriveRepresentable1', but takes an 'Options' argument. deriveRepresentable1Options :: Options -> Name -> Q [Dec] deriveRepresentable1Options = deriveRepresentableCommon Generic1 deriveRepresentableCommon :: GenericClass -> Options -> Name -> Q [Dec] deriveRepresentableCommon gClass opts n = do rep <- if repOptions opts == InlineRep then return [] else deriveRepCommon gClass (kindSigOptions opts) n inst <- deriveInst gClass opts n return (rep ++ inst) -- | Derive only the 'Rep0' type synonym. Not needed if 'deriveRepresentable0' -- is used. deriveRep0 :: Name -> Q [Dec] deriveRep0 = deriveRep0Options defaultKindSigOptions -- | Like 'deriveRep0', but takes an 'KindSigOptions' argument. deriveRep0Options :: KindSigOptions -> Name -> Q [Dec] deriveRep0Options = deriveRepCommon Generic -- | Derive only the 'Rep1' type synonym. Not needed if 'deriveRepresentable1' -- is used. deriveRep1 :: Name -> Q [Dec] deriveRep1 = deriveRep1Options defaultKindSigOptions -- | Like 'deriveRep1', but takes an 'KindSigOptions' argument. deriveRep1Options :: KindSigOptions -> Name -> Q [Dec] deriveRep1Options = deriveRepCommon Generic1 deriveRepCommon :: GenericClass -> KindSigOptions -> Name -> Q [Dec] deriveRepCommon gClass useKindSigs n = do i <- reifyDataInfo n let (name, isNT, declTvbs, cons, dv) = either error id i -- See Note [Forcing buildTypeInstance] !_ <- buildTypeInstance gClass useKindSigs name declTvbs dv tySynVars <- grabTyVarsFromCons gClass cons -- See Note [Kind signatures in derived instances] let tySynVars' = if useKindSigs then tySynVars else map unSigT tySynVars fmap (:[]) $ tySynD (genRepName gClass dv name) (catMaybes $ map typeToTyVarBndr tySynVars') (repType gClass dv name isNT cons tySynVars) deriveInst :: GenericClass -> Options -> Name -> Q [Dec] deriveInst Generic = deriveInstCommon genericTypeName repTypeName Generic fromValName toValName deriveInst Generic1 = deriveInstCommon generic1TypeName rep1TypeName Generic1 from1ValName to1ValName deriveInstCommon :: Name -> Name -> GenericClass -> Name -> Name -> Options -> Name -> Q [Dec] deriveInstCommon genericName repName gClass fromName toName opts n = do i <- reifyDataInfo n let (name, isNT, allTvbs, cons, dv) = either error id i useKindSigs = kindSigOptions opts -- See Note [Forcing buildTypeInstance] !(origTy, origKind) <- buildTypeInstance gClass useKindSigs name allTvbs dv tyInsRHS <- if repOptions opts == InlineRep then makeRepInline gClass dv name isNT cons origTy else makeRepTySynApp gClass dv name cons origTy let origSigTy = if useKindSigs then SigT origTy origKind else origTy tyIns = TySynInstD repName #if MIN_VERSION_template_haskell(2,9,0) (TySynEqn [origSigTy] tyInsRHS) #else [origSigTy] tyInsRHS #endif mkBody maker = [clause [] (normalB $ mkCaseExp gClass name cons maker) []] fcs = mkBody mkFrom tcs = mkBody mkTo fmap (:[]) $ instanceD (cxt []) (conT genericName `appT` return origSigTy) [return tyIns, funD fromName fcs, funD toName tcs] {- $make There are some data types for which the Template Haskell deriver functions in this module are not sophisticated enough to infer the correct 'Generic' or 'Generic1' instances. As an example, consider this data type: @ newtype Fix f a = Fix (f (Fix f a)) @ A proper 'Generic1' instance would look like this: @ instance Functor f => Generic1 (Fix f) where ... @ Unfortunately, 'deriveRepresentable1' cannot infer the @Functor f@ constraint. One can still define a 'Generic1' instance for @Fix@, however, by using the functions in this module that are prefixed with @make@-. For example: @ $('deriveMeta' ''Fix) $('deriveRep1' ''Fix) instance Functor f => Generic1 (Fix f) where type Rep1 (Fix f) = $('makeRep1Inline' ''Fix [t| Fix f |]) from1 = $('makeFrom1' ''Fix) to1 = $('makeTo1' ''Fix) @ Note that due to the lack of type-level lambdas in Haskell, one must manually apply @'makeRep1Inline' ''Fix@ to the type @Fix f@. Be aware that there is a bug on GHC 7.0, 7.2, and 7.4 which might prevent you from using 'makeRep0Inline' and 'makeRep1Inline'. In the @Fix@ example above, you would experience the following error: @ Kinded thing `f' used as a type In the Template Haskell quotation [t| Fix f |] @ Then a workaround is to use 'makeRep1' instead, which requires you to: 1. Invoke 'deriveRep1' beforehand 2. Pass as arguments the type variables that occur in the instance, in order from left to right, topologically sorted, excluding duplicates. (Normally, 'makeRep1Inline' would figure this out for you.) Using the above example: @ $('deriveMeta' ''Fix) $('deriveRep1' ''Fix) instance Functor f => Generic1 (Fix f) where type Rep1 (Fix f) = $('makeRep1' ''Fix) f from1 = $('makeFrom1' ''Fix) to1 = $('makeTo1' ''Fix) @ On GHC 7.4, you might encounter more complicated examples involving data families. For instance: @ data family Fix a b c d newtype instance Fix b (f c) (g b) a = Fix (f (Fix b (f c) (g b) a)) $('deriveMeta' ''Fix) $('deriveRep1' ''Fix) instance Functor f => Generic1 (Fix b (f c) (g b)) where type Rep1 (Fix b (f c) (g b)) = $('makeRep1' 'Fix) b f c g from1 = $('makeFrom1' 'Fix) to1 = $('makeTo1' 'Fix) @ Note that you don't pass @b@ twice, only once. -} -- | Generates the full 'Rep' type inline. Since this type can be quite -- large, it is recommended you only use this to define 'Rep', e.g., -- -- @ -- type Rep (Foo (a :: k) b) = $('makeRep0Inline' ''Foo [t| Foo (a :: k) b |]) -- @ -- -- You can then simply refer to @Rep (Foo a b)@ elsewhere. -- -- Note that the type passed as an argument to 'makeRep0Inline' must match the -- type argument of 'Rep' exactly, even up to including the explicit kind -- signature on @a@. This is due to a limitation of Template Haskell—without -- the kind signature, 'makeRep0Inline' has no way of figuring out the kind of -- @a@, and the generated type might be completely wrong as a result! makeRep0Inline :: Name -> Q Type -> Q Type makeRep0Inline n = makeRepCommon Generic InlineRep n . Just -- | Generates the full 'Rep1' type inline. Since this type can be quite -- large, it is recommended you only use this to define 'Rep1', e.g., -- -- @ -- type Rep1 (Foo (a :: k)) = $('makeRep0Inline' ''Foo [t| Foo (a :: k) |]) -- @ -- -- You can then simply refer to @Rep1 (Foo a)@ elsewhere. -- -- Note that the type passed as an argument to 'makeRep1Inline' must match the -- type argument of 'Rep1' exactly, even up to including the explicit kind -- signature on @a@. This is due to a limitation of Template Haskell—without -- the kind signature, 'makeRep1Inline' has no way of figuring out the kind of -- @a@, and the generated type might be completely wrong as a result! makeRep1Inline :: Name -> Q Type -> Q Type makeRep1Inline n = makeRepCommon Generic1 InlineRep n . Just -- | Generates the 'Rep' type synonym constructor (as opposed to 'deriveRep0', -- which generates the type synonym declaration). After splicing it into -- Haskell source, it expects types as arguments. For example: -- -- @ -- type Rep (Foo a b) = $('makeRep0' ''Foo) a b -- @ -- -- The use of 'makeRep0' is generally discouraged, as it can sometimes be -- difficult to predict the order in which you are expected to pass type -- variables. As a result, 'makeRep0Inline' is recommended instead. However, -- 'makeRep0Inline' is not usable on GHC 7.0, 7.2, or 7.4 due to a GHC bug, -- so 'makeRep0' still exists for GHC 7.0, 7.2, and 7.4 users. makeRep0 :: Name -> Q Type makeRep0 n = makeRepCommon Generic TypeSynonymRep n Nothing -- | Generates the 'Rep1' type synonym constructor (as opposed to 'deriveRep1', -- which generates the type synonym declaration). After splicing it into -- Haskell source, it expects types as arguments. For example: -- -- @ -- type Rep1 (Foo a) = $('makeRep1' ''Foo) a -- @ -- -- The use of 'makeRep1' is generally discouraged, as it can sometimes be -- difficult to predict the order in which you are expected to pass type -- variables. As a result, 'makeRep1Inline' is recommended instead. However, -- 'makeRep1Inline' is not usable on GHC 7.0, 7.2, or 7.4 due to a GHC bug, -- so 'makeRep1' still exists for GHC 7.0, 7.2, and 7.4 users. makeRep1 :: Name -> Q Type makeRep1 n = makeRepCommon Generic1 TypeSynonymRep n Nothing -- | Generates the 'Rep' type synonym constructor (as opposed to 'deriveRep0', -- which generates the type synonym declaration) applied to its type arguments. -- Unlike 'makeRep0', this also takes a quoted 'Type' as an argument, e.g., -- -- @ -- type Rep (Foo (a :: k) b) = $('makeRep0FromType' ''Foo [t| Foo (a :: k) b |]) -- @ -- -- Note that the type passed as an argument to 'makeRep0FromType' must match the -- type argument of 'Rep' exactly, even up to including the explicit kind -- signature on @a@. This is due to a limitation of Template Haskell—without -- the kind signature, 'makeRep0FromType' has no way of figuring out the kind of -- @a@, and the generated type might be completely wrong as a result! -- -- The use of 'makeRep0FromType' is generally discouraged, since 'makeRep0Inline' -- does exactly the same thing but without having to go through an intermediate -- type synonym, and as a result, 'makeRep0Inline' tends to be less buggy. makeRep0FromType :: Name -> Q Type -> Q Type makeRep0FromType n = makeRepCommon Generic TypeSynonymRep n . Just -- | Generates the 'Rep1' type synonym constructor (as opposed to 'deriveRep1', -- which generates the type synonym declaration) applied to its type arguments. -- Unlike 'makeRep1', this also takes a quoted 'Type' as an argument, e.g., -- -- @ -- type Rep1 (Foo (a :: k)) = $('makeRep1FromType' ''Foo [t| Foo (a :: k) |]) -- @ -- -- Note that the type passed as an argument to 'makeRep1FromType' must match the -- type argument of 'Rep' exactly, even up to including the explicit kind -- signature on @a@. This is due to a limitation of Template Haskell—without -- the kind signature, 'makeRep1FromType' has no way of figuring out the kind of -- @a@, and the generated type might be completely wrong as a result! -- -- The use of 'makeRep1FromType' is generally discouraged, since 'makeRep1Inline' -- does exactly the same thing but without having to go through an intermediate -- type synonym, and as a result, 'makeRep1Inline' tends to be less buggy. makeRep1FromType :: Name -> Q Type -> Q Type makeRep1FromType n = makeRepCommon Generic1 TypeSynonymRep n . Just makeRepCommon :: GenericClass -> RepOptions -> Name -> Maybe (Q Type) -> Q Type makeRepCommon gClass repOpts n mbQTy = do i <- reifyDataInfo n let (name, isNT, declTvbs, cons, dv) = either error id i -- See Note [Forcing buildTypeInstance] !_ <- buildTypeInstance gClass False name declTvbs dv case (mbQTy, repOpts) of (Just qTy, TypeSynonymRep) -> qTy >>= makeRepTySynApp gClass dv name cons (Just qTy, InlineRep) -> qTy >>= makeRepInline gClass dv name isNT cons (Nothing, TypeSynonymRep) -> conT $ genRepName gClass dv name (Nothing, InlineRep) -> fail "makeRepCommon" makeRepInline :: GenericClass -> DataVariety -> Name -> Bool -> [Con] -> Type -> Q Type makeRepInline gClass dv name isNT cons ty = do let instVars = map tyVarBndrToType $ requiredTyVarsOfType ty repType gClass dv name isNT cons instVars makeRepTySynApp :: GenericClass -> DataVariety -> Name -> [Con] -> Type -> Q Type makeRepTySynApp gClass dv name cons ty = do -- Here, we figure out the distinct type variables (in order from left-to-right) -- of the LHS of the Rep(1) instance. We call unKindedTV because the kind -- inferencer can figure out the kinds perfectly well, so we don't need to -- give anything here explicit kind signatures. let instTvbs = map unKindedTV $ requiredTyVarsOfType ty -- We grab the type variables from the first constructor's type signature. -- Or, if there are no constructors, we grab no type variables. The latter -- is okay because we use zipWith to ensure that we never pass more type -- variables than the generated type synonym can accept. -- See Note [Arguments to generated type synonyms] tySynVars <- grabTyVarsFromCons gClass cons return . applyTyToTvbs (genRepName gClass dv name) $ zipWith const instTvbs tySynVars -- | A backwards-compatible synonym for 'makeFrom0'. makeFrom :: Name -> Q Exp makeFrom = makeFrom0 -- | Generates a lambda expression which behaves like 'from'. makeFrom0 :: Name -> Q Exp makeFrom0 = makeFunCommon mkFrom Generic -- | A backwards-compatible synonym for 'makeTo0'. makeTo :: Name -> Q Exp makeTo = makeTo0 -- | Generates a lambda expression which behaves like 'to'. makeTo0 :: Name -> Q Exp makeTo0 = makeFunCommon mkTo Generic -- | Generates a lambda expression which behaves like 'from1'. makeFrom1 :: Name -> Q Exp makeFrom1 = makeFunCommon mkFrom Generic1 -- | Generates a lambda expression which behaves like 'to1'. makeTo1 :: Name -> Q Exp makeTo1 = makeFunCommon mkTo Generic1 makeFunCommon :: (GenericClass -> Int -> Int -> Name -> [Con] -> Q Match) -> GenericClass -> Name -> Q Exp makeFunCommon maker gClass n = do i <- reifyDataInfo n let (name, _, allTvbs, cons, dv) = either error id i -- See Note [Forcing buildTypeInstance] buildTypeInstance gClass False name allTvbs dv `seq` mkCaseExp gClass name cons maker genRepName :: GenericClass -> DataVariety -> Name -> Name genRepName gClass dv n = mkName . showsDataVariety dv . (("Rep" ++ show (fromEnum gClass)) ++) . ((showNameQual n ++ "_") ++) . sanitizeName $ nameBase n repType :: GenericClass -> DataVariety -> Name -> Bool -> [Con] -> [Type] -> Q Type repType gClass dv dt isNT cs tySynVars = conT d1TypeName `appT` mkMetaDataType dv dt isNT `appT` foldr1' sum' (conT v1TypeName) (map (repCon gClass dv dt tySynVars) cs) where sum' :: Q Type -> Q Type -> Q Type sum' a b = conT sumTypeName `appT` a `appT` b repCon :: GenericClass -> DataVariety -> Name -> [Type] -> Con -> Q Type repCon gClass dv dt tySynVars (NormalC n bts) = do let bangs = map fst bts ssis <- reifySelStrictInfo n bangs repConWith gClass dv dt n tySynVars Nothing ssis False False repCon gClass dv dt tySynVars (RecC n vbts) = do let (selNames, bangs, _) = unzip3 vbts ssis <- reifySelStrictInfo n bangs repConWith gClass dv dt n tySynVars (Just selNames) ssis True False repCon gClass dv dt tySynVars (InfixC t1 n t2) = do let bangs = map fst [t1, t2] ssis <- reifySelStrictInfo n bangs repConWith gClass dv dt n tySynVars Nothing ssis False True repCon _ _ _ _ con = gadtError con repConWith :: GenericClass -> DataVariety -> Name -> Name -> [Type] -> Maybe [Name] -> [SelStrictInfo] -> Bool -> Bool -> Q Type repConWith gClass dv dt n tySynVars mbSelNames ssis isRecord isInfix = do (conVars, ts, gk) <- reifyConTys gClass n let structureType :: Q Type structureType = case ssis of [] -> conT u1TypeName _ -> foldr1 prodT f -- See Note [Substituting types in a constructor type signature] typeSubst :: TypeSubst typeSubst = Map.fromList $ zip (nub $ concatMap tyVarNamesOfType conVars) (nub $ concatMap (map VarT . tyVarNamesOfType) tySynVars) f :: [Q Type] f = case mbSelNames of Just selNames -> zipWith3 (repField gk dv dt n typeSubst . Just) selNames ssis ts Nothing -> zipWith (repField gk dv dt n typeSubst Nothing) ssis ts conT c1TypeName `appT` mkMetaConsType dv dt n isRecord isInfix `appT` structureType prodT :: Q Type -> Q Type -> Q Type prodT a b = conT productTypeName `appT` a `appT` b repField :: GenericKind -> DataVariety -> Name -> Name -> TypeSubst -> Maybe Name -> SelStrictInfo -> Type -> Q Type repField gk dv dt ns typeSubst mbF ssi t = conT s1TypeName `appT` mkMetaSelType dv dt ns mbF ssi `appT` (repFieldArg gk =<< expandSyn t'') where -- See Note [Substituting types in constructor type signatures] t', t'' :: Type t' = case gk of Gen1 _ (Just _kvName) -> -- See Note [Generic1 is polykinded on GHC 8.2] #if __GLASGOW_HASKELL__ >= 801 t #else substNameWithKind _kvName starK t #endif _ -> t t'' = substType typeSubst t' repFieldArg :: GenericKind -> Type -> Q Type repFieldArg _ ForallT{} = rankNError repFieldArg gk (SigT t _) = repFieldArg gk t repFieldArg Gen0 t = boxT t repFieldArg (Gen1 name _) (VarT t) | t == name = conT par1TypeName repFieldArg gk@(Gen1 name _) t = do let tyHead:tyArgs = unapplyTy t numLastArgs = min 1 $ length tyArgs (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs rec0Type = boxT t phiType = return $ applyTyToTys tyHead lhsArgs inspectTy :: Type -> Q Type inspectTy (VarT a) | a == name = conT rec1TypeName `appT` phiType inspectTy (SigT ty _) = inspectTy ty inspectTy beta | not (ground beta name) = conT composeTypeName `appT` phiType `appT` repFieldArg gk beta inspectTy _ = rec0Type itf <- isTyFamily tyHead if any (not . (`ground` name)) lhsArgs || any (not . (`ground` name)) tyArgs && itf then outOfPlaceTyVarError else case rhsArgs of [] -> rec0Type ty:_ -> inspectTy ty boxT :: Type -> Q Type boxT ty = case unboxedRepNames ty of Just (boxTyName, _, _) -> conT boxTyName Nothing -> conT rec0TypeName `appT` return ty mkCaseExp :: GenericClass -> Name -> [Con] -> (GenericClass -> Int -> Int -> Name -> [Con] -> Q Match) -> Q Exp mkCaseExp gClass dt cs matchmaker = do val <- newName "val" lam1E (varP val) $ caseE (varE val) [matchmaker gClass 1 0 dt cs] mkFrom :: GenericClass -> Int -> Int -> Name -> [Con] -> Q Match mkFrom gClass m i dt cs = do y <- newName "y" match (varP y) (normalB $ conE m1DataName `appE` caseE (varE y) cases) [] where cases = case cs of [] -> [errorFrom dt] _ -> zipWith (fromCon gClass wrapE (length cs)) [0..] cs wrapE e = lrE m i e errorFrom :: Name -> Q Match errorFrom dt = match wildP (normalB $ varE errorValName `appE` stringE ("No generic representation for empty datatype " ++ nameBase dt)) [] errorTo :: Name -> Q Match errorTo dt = match wildP (normalB $ varE errorValName `appE` stringE ("No values for empty datatype " ++ nameBase dt)) [] mkTo :: GenericClass -> Int -> Int -> Name -> [Con] -> Q Match mkTo gClass m i dt cs = do y <- newName "y" match (conP m1DataName [varP y]) (normalB $ caseE (varE y) cases) [] where cases = case cs of [] -> [errorTo dt] _ -> zipWith (toCon gClass wrapP (length cs)) [0..] cs wrapP p = lrP m i p fromCon :: GenericClass -> (Q Exp -> Q Exp) -> Int -> Int -> Con -> Q Match fromCon _ wrap m i (NormalC cn []) = match (conP cn []) (normalB $ wrap $ lrE m i $ conE m1DataName `appE` (conE u1DataName)) [] fromCon gClass wrap m i (NormalC cn _) = do (ts, gk) <- fmap shrink $ reifyConTys gClass cn fNames <- newNameList "f" $ length ts match (conP cn (map varP fNames)) (normalB $ wrap $ lrE m i $ conE m1DataName `appE` foldr1 prodE (zipWith (fromField gk) fNames ts)) [] fromCon _ wrap m i (RecC cn []) = match (conP cn []) (normalB $ wrap $ lrE m i $ conE m1DataName `appE` (conE u1DataName)) [] fromCon gClass wrap m i (RecC cn _) = do (ts, gk) <- fmap shrink $ reifyConTys gClass cn fNames <- newNameList "f" $ length ts match (conP cn (map varP fNames)) (normalB $ wrap $ lrE m i $ conE m1DataName `appE` foldr1 prodE (zipWith (fromField gk) fNames ts)) [] fromCon gClass wrap m i (InfixC t1 cn t2) = fromCon gClass wrap m i (NormalC cn [t1,t2]) fromCon _ _ _ _ con = gadtError con prodE :: Q Exp -> Q Exp -> Q Exp prodE x y = conE productDataName `appE` x `appE` y fromField :: GenericKind -> Name -> Type -> Q Exp fromField gk nr t = conE m1DataName `appE` (fromFieldWrap gk nr =<< expandSyn t) fromFieldWrap :: GenericKind -> Name -> Type -> Q Exp fromFieldWrap _ _ ForallT{} = rankNError fromFieldWrap gk nr (SigT t _) = fromFieldWrap gk nr t fromFieldWrap Gen0 nr t = conE (boxRepName t) `appE` varE nr fromFieldWrap (Gen1 name _) nr t = wC t name `appE` varE nr wC :: Type -> Name -> Q Exp wC (VarT t) name | t == name = conE par1DataName wC t name | ground t name = conE $ boxRepName t | otherwise = do let tyHead:tyArgs = unapplyTy t numLastArgs = min 1 $ length tyArgs (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs inspectTy :: Type -> Q Exp inspectTy ForallT{} = rankNError inspectTy (SigT ty _) = inspectTy ty inspectTy (VarT a) | a == name = conE rec1DataName inspectTy beta = infixApp (conE comp1DataName) (varE composeValName) (varE fmapValName `appE` wC beta name) itf <- isTyFamily tyHead if any (not . (`ground` name)) lhsArgs || any (not . (`ground` name)) tyArgs && itf then outOfPlaceTyVarError else case rhsArgs of [] -> conE $ boxRepName t ty:_ -> inspectTy ty boxRepName :: Type -> Name boxRepName = maybe k1DataName snd3 . unboxedRepNames toCon :: GenericClass -> (Q Pat -> Q Pat) -> Int -> Int -> Con -> Q Match toCon _ wrap m i (NormalC cn []) = match (wrap $ lrP m i $ conP m1DataName [conP u1DataName []]) (normalB $ conE cn) [] toCon gClass wrap m i (NormalC cn _) = do (ts, gk) <- fmap shrink $ reifyConTys gClass cn fNames <- newNameList "f" $ length ts match (wrap $ lrP m i $ conP m1DataName [foldr1 prod (zipWith (toField gk) fNames ts)]) (normalB $ foldl appE (conE cn) (zipWith (\nr -> expandSyn >=> toConUnwC gk nr) fNames ts)) [] where prod x y = conP productDataName [x,y] toCon _ wrap m i (RecC cn []) = match (wrap $ lrP m i $ conP m1DataName [conP u1DataName []]) (normalB $ conE cn) [] toCon gClass wrap m i (RecC cn _) = do (ts, gk) <- fmap shrink $ reifyConTys gClass cn fNames <- newNameList "f" $ length ts match (wrap $ lrP m i $ conP m1DataName [foldr1 prod (zipWith (toField gk) fNames ts)]) (normalB $ foldl appE (conE cn) (zipWith (\nr -> expandSyn >=> toConUnwC gk nr) fNames ts)) [] where prod x y = conP productDataName [x,y] toCon gk wrap m i (InfixC t1 cn t2) = toCon gk wrap m i (NormalC cn [t1,t2]) toCon _ _ _ _ con = gadtError con toConUnwC :: GenericKind -> Name -> Type -> Q Exp toConUnwC Gen0 nr _ = varE nr toConUnwC (Gen1 name _) nr t = unwC t name `appE` varE nr toField :: GenericKind -> Name -> Type -> Q Pat toField gk nr t = conP m1DataName [toFieldWrap gk nr t] toFieldWrap :: GenericKind -> Name -> Type -> Q Pat toFieldWrap Gen0 nr t = conP (boxRepName t) [varP nr] toFieldWrap Gen1{} nr _ = varP nr unwC :: Type -> Name -> Q Exp unwC (SigT t _) name = unwC t name unwC (VarT t) name | t == name = varE unPar1ValName unwC t name | ground t name = varE $ unboxRepName t | otherwise = do let tyHead:tyArgs = unapplyTy t numLastArgs = min 1 $ length tyArgs (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs inspectTy :: Type -> Q Exp inspectTy ForallT{} = rankNError inspectTy (SigT ty _) = inspectTy ty inspectTy (VarT a) | a == name = varE unRec1ValName inspectTy beta = infixApp (varE fmapValName `appE` unwC beta name) (varE composeValName) (varE unComp1ValName) itf <- isTyFamily tyHead if any (not . (`ground` name)) lhsArgs || any (not . (`ground` name)) tyArgs && itf then outOfPlaceTyVarError else case rhsArgs of [] -> varE $ unboxRepName t ty:_ -> inspectTy ty unboxRepName :: Type -> Name unboxRepName = maybe unK1ValName trd3 . unboxedRepNames lrP :: Int -> Int -> (Q Pat -> Q Pat) lrP 1 0 p = p lrP _ 0 p = conP l1DataName [p] lrP m i p = conP r1DataName [lrP (m-1) (i-1) p] lrE :: Int -> Int -> (Q Exp -> Q Exp) lrE 1 0 e = e lrE _ 0 e = conE l1DataName `appE` e lrE m i e = conE r1DataName `appE` lrE (m-1) (i-1) e unboxedRepNames :: Type -> Maybe (Name, Name, Name) unboxedRepNames ty | ty == ConT addrHashTypeName = Just (uAddrTypeName, uAddrDataName, uAddrHashValName) | ty == ConT charHashTypeName = Just (uCharTypeName, uCharDataName, uCharHashValName) | ty == ConT doubleHashTypeName = Just (uDoubleTypeName, uDoubleDataName, uDoubleHashValName) | ty == ConT floatHashTypeName = Just (uFloatTypeName, uFloatDataName, uFloatHashValName) | ty == ConT intHashTypeName = Just (uIntTypeName, uIntDataName, uIntHashValName) | ty == ConT wordHashTypeName = Just (uWordTypeName, uWordDataName, uWordHashValName) | otherwise = Nothing -- | Deduces the instance type (and kind) to use for a Generic(1) instance. buildTypeInstance :: GenericClass -- ^ Generic or Generic1 -> KindSigOptions -- ^ Whether or not to use explicit kind signatures in the instance type -> Name -- ^ The type constructor or data family name -> [TyVarBndr] -- ^ The type variables from the data type/data family declaration -> DataVariety -- ^ If using a data family instance, provides the types used -- to instantiate the instance -> Q (Type, Kind) -- Plain data type/newtype case buildTypeInstance gClass useKindSigs tyConName tvbs DataPlain = let varTys :: [Type] varTys = map tyVarBndrToType tvbs in buildTypeInstanceFromTys gClass useKindSigs tyConName varTys -- Data family instance case -- -- The CPP is present to work around a couple of annoying old GHC bugs. -- See Note [Polykinded data families in Template Haskell] buildTypeInstance gClass useKindSigs parentName tvbs (DataFamily _ instTysAndKinds) = do #if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0) let instTys :: [Type] instTys = zipWith stealKindForType tvbs instTysAndKinds #else let kindVarNames :: [Name] kindVarNames = nub $ concatMap (tyVarNamesOfType . tyVarBndrKind) tvbs numKindVars :: Int numKindVars = length kindVarNames givenKinds, givenKinds' :: [Kind] givenTys :: [Type] (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds givenKinds' = map sanitizeStars givenKinds -- A GHC 7.6-specific bug requires us to replace all occurrences of -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it. -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot. sanitizeStars :: Kind -> Kind sanitizeStars = go where go :: Kind -> Kind go (AppT t1 t2) = AppT (go t1) (go t2) go (SigT t k) = SigT (go t) (go k) go (ConT n) | n == starKindName = StarT go t = t -- If we run this code with GHC 7.8, we might have to generate extra type -- variables to compensate for any type variables that Template Haskell -- eta-reduced away. -- See Note [Polykinded data families in Template Haskell] xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys) let xTys :: [Type] -- Because these type variables were eta-reduced away, we can only -- determine their kind by using stealKindForType. Therefore, we mark -- them as VarT to ensure they will be given an explicit kind annotation -- (and so the kind inference machinery has the right information). xTys = map VarT xTypeNames substNamesWithKinds :: [(Name, Kind)] -> Type -> Type substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks -- The types from the data family instance might not have explicit kind -- annotations, which the kind machinery needs to work correctly. To -- compensate, we use stealKindForType to explicitly annotate any -- types without kind annotations. instTys :: [Type] instTys = map (substNamesWithKinds (zip kindVarNames givenKinds')) -- Note that due to a GHC 7.8-specific bug -- (see Note [Polykinded data families in Template Haskell]), -- there may be more kind variable names than there are kinds -- to substitute. But this is OK! If a kind is eta-reduced, it -- means that is was not instantiated to something more specific, -- so we need not substitute it. Using stealKindForType will -- grab the correct kind. $ zipWith stealKindForType tvbs (givenTys ++ xTys) #endif buildTypeInstanceFromTys gClass useKindSigs parentName instTys -- For the given Types, deduces the instance type (and kind) to use for a -- Generic(1) instance. Coming up with the instance type isn't as simple as -- dropping the last types, as you need to be wary of kinds being instantiated -- with *. -- See Note [Type inference in derived instances] buildTypeInstanceFromTys :: GenericClass -- ^ Generic or Generic1 -> KindSigOptions -- ^ Whether or not to use explicit kind signatures in the instance type -> Name -- ^ The type constructor or data family name -> [Type] -- ^ The types to instantiate the instance with -> Q (Type, Kind) buildTypeInstanceFromTys gClass useKindSigs tyConName varTysOrig = do -- Make sure to expand through type/kind synonyms! Otherwise, the -- eta-reduction check might get tripped up over type variables in a -- synonym that are actually dropped. -- (See GHC Trac #11416 for a scenario where this actually happened.) varTysExp <- mapM expandSyn varTysOrig let remainingLength :: Int remainingLength = length varTysOrig - fromEnum gClass droppedTysExp :: [Type] droppedTysExp = drop remainingLength varTysExp droppedStarKindStati :: [StarKindStatus] droppedStarKindStati = map canRealizeKindStar droppedTysExp -- Check there are enough types to drop and that all of them are either of -- kind * or kind k (for some kind variable k). If not, throw an error. when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $ derivingKindError tyConName -- Substitute kind * for any dropped kind variables let varTysExpSubst :: [Type] -- See Note [Generic1 is polykinded on GHC 8.2] #if __GLASGOW_HASKELL__ >= 801 varTysExpSubst = varTysExp #else varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp droppedKindVarNames :: [Name] droppedKindVarNames = catKindVarNames droppedStarKindStati #endif let remainingTysExpSubst, droppedTysExpSubst :: [Type] (remainingTysExpSubst, droppedTysExpSubst) = splitAt remainingLength varTysExpSubst -- See Note [Generic1 is polykinded on GHC 8.2] #if __GLASGOW_HASKELL__ < 801 -- If any of the dropped types were polykinded, ensure that there are of -- kind * after substituting * for the dropped kind variables. If not, -- throw an error. unless (all hasKindStar droppedTysExpSubst) $ derivingKindError tyConName #endif -- We now substitute all of the specialized-to-* kind variable names -- with *, but in the original types, not the synonym-expanded types. The reason -- we do this is a superficial one: we want the derived instance to resemble -- the datatype written in source code as closely as possible. For example, -- for the following data family instance: -- -- data family Fam a -- newtype instance Fam String = Fam String -- -- We'd want to generate the instance: -- -- instance C (Fam String) -- -- Not: -- -- instance C (Fam [Char]) let varTysOrigSubst :: [Type] varTysOrigSubst = -- See Note [Generic1 is polykinded on GHC 8.2] #if __GLASGOW_HASKELL__ >= 801 id #else map (substNamesWithKindStar droppedKindVarNames) #endif $ varTysOrig remainingTysOrigSubst, droppedTysOrigSubst :: [Type] (remainingTysOrigSubst, droppedTysOrigSubst) = splitAt remainingLength varTysOrigSubst remainingTysOrigSubst' :: [Type] -- See Note [Kind signatures in derived instances] for an explanation -- of the useKindSigs check. remainingTysOrigSubst' = if useKindSigs then remainingTysOrigSubst else map unSigT remainingTysOrigSubst instanceType :: Type instanceType = applyTyToTys (ConT tyConName) remainingTysOrigSubst' -- See Note [Kind signatures in derived instances] instanceKind :: Kind instanceKind = makeFunKind (map typeKind droppedTysOrigSubst) starK -- Ensure the dropped types can be safely eta-reduced. Otherwise, -- throw an error. unless (canEtaReduce remainingTysExpSubst droppedTysExpSubst) $ etaReductionError instanceType return (instanceType, instanceKind) -- See Note [Arguments to generated type synonyms] grabTyVarsFromCons :: GenericClass -> [Con] -> Q [Type] grabTyVarsFromCons _ [] = return [] grabTyVarsFromCons gClass (con:_) = fmap fst3 $ reifyConTys gClass (constructorName con) {- Note [Forcing buildTypeInstance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Sometimes, we don't explicitly need to generate a Generic(1) type instance, but we force buildTypeInstance nevertheless. This is because it performs some checks for whether or not the provided datatype can actually have Generic(1) implemented for it, and produces errors if it can't. Otherwise, laziness would cause these checks to be skipped entirely, which could result in some indecipherable type errors down the road. Note [Substituting types in constructor type signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ While reifyConTys gives you the type variables of a constructor, they may not be the same of the data declaration's type variables. The classic example of this is GADTs: data GADT a b where GADTCon :: e -> f -> GADT e f The type variables of GADTCon are completely different from the declaration's, which can cause a problem when generating a Rep instance: type Rep (GADT a b) = Rec0 e :*: Rec0 f Naïvely, we would generate something like this, since traversing the constructor would give us precisely those arguments. Not good. We need to perform a type substitution to ensure that e maps to a, and f maps to b. This turns out to be surprisingly simple. Whenever you have a constructor type signature like (e -> f -> GADT e f), take the result type, collect all of its distinct type variables in order from left-to-right, and then map them to their corresponding type variables from the data declaration. There is another obscure case where we need to do a type subtitution. With -XTypeInType enabled on GHC 8.0, you might have something like this: data Proxy (a :: k) (b :: k) = Proxy k deriving Generic1 Then k gets specialized to *, which means that k should NOT show up in the RHS of a Rep1 type instance! To avoid this, make sure to substitute k with *. See also Note [Generic1 is polykinded on GHC 8.2]. Note [Arguments to generated type synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A surprisingly difficult component of generating the type synonyms for Rep/Rep1 is coming up with the type synonym variable arguments, since they have to be just the right name and kind to work. The type signature of a constructor does a remarkably good job of coming up with these type variables for us, so if at least one constructor exists, we simply steal the type variables from that constructor's type signature for use in the generated type synonym. We also count the number of type variables that the first constructor's type signature has in order to determine how many type variables we should give it as arguments in the generated (type Rep (Foo ...) = ...) code. This leads one to ask: what if there are no constructors? If that's the case, then we're OK, since that means no type variables can possibly appear on the RHS of the type synonym! In such a special case, we're perfectly justified in making the type synonym not have any type variable arguments, and similarly, we don't apply any arguments to it in the generated (type Rep Foo = ) code. Note [Polykinded data families in Template Haskell] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In order to come up with the correct instance context and head for an instance, e.g., instance C a => C (Data a) where ... We need to know the exact types and kinds used to instantiate the instance. For plain old datatypes, this is simple: every type must be a type variable, and Template Haskell reliably tells us the type variables and their kinds. Doing the same for data families proves to be much harder for three reasons: 1. On any version of Template Haskell, it may not tell you what an instantiated type's kind is. For instance, in the following data family instance: data family Fam (f :: * -> *) (a :: *) data instance Fam f a Then if we use TH's reify function, it would tell us the TyVarBndrs of the data family declaration are: [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT] and the instantiated types of the data family instance are: [VarT f1,VarT a1] We can't just pass [VarT f1,VarT a1] to buildTypeInstanceFromTys, since we have no way of knowing their kinds. Luckily, the TyVarBndrs tell us what the kind is in case an instantiated type isn't a SigT, so we use the stealKindForType function to ensure all of the instantiated types are SigTs before passing them to buildTypeInstanceFromTys. 2. On GHC 7.6 and 7.8, a bug is present in which Template Haskell lists all of the specified kinds of a data family instance efore any of the instantiated types. Fortunately, this is easy to deal with: you simply count the number of distinct kind variables in the data family declaration, take that many elements from the front of the Types list of the data family instance, substitute the kind variables with their respective instantiated kinds (which you took earlier), and proceed as normal. 3. On GHC 7.8, an even uglier bug is present (GHC Trac #9692) in which Template Haskell might not even list all of the Types of a data family instance, since they are eta-reduced away! And yes, kinds can be eta-reduced too. The simplest workaround is to count how many instantiated types are missing from the list and generate extra type variables to use in their place. Luckily, we needn't worry much if its kind was eta-reduced away, since using stealKindForType will get it back. Note [Kind signatures in derived instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We generally include explicit type signatures in derived instances. One reason for doing so is that in the case of certain data family instances, not including kind signatures can result in ambiguity. For example, consider the following two data family instances that are distinguished by their kinds: data family Fam (a :: k) data instance Fam (a :: * -> *) data instance Fam (a :: *) If we dropped the kind signature for a in a derived instance for Fam a, then GHC would have no way of knowing which instance we are talking about. Another motivation for explicit kind signatures is the -XTypeInType extension. With -XTypeInType, dropping kind signatures can completely change the meaning of some data types. For example, there is a substantial difference between these two data types: data T k (a :: k) = T k data T k a = T k In addition to using explicit kind signatures on type variables, we also put explicit return kinds in the instance head, so generated instances will look something like this: data S (a :: k) = S k instance Generic1 (S :: k -> *) where type Rep1 (S :: k -> *) = ... (Rec0 k) Why do we do this? Imagine what the instance would be without the explicit return kind: instance Generic1 S where type Rep1 S = ... (Rec0 k) This is an error, since the variable k is now out-of-scope! Although explicit kind signatures are the right thing to do in most cases, there are sadly some degenerate cases where this isn't true. Consider this example: newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) = Compose (f (g a)) The Rep1 type instance in a Generic1 instance for Compose would involve the type (f :.: Rec1 g), which forces (f :: * -> *). But this library doesn't have very sophisticated kind inference machinery (other than what is mentioned in Note [Substituting types in constructor type signatures]), so at the moment we have no way of actually unifying k1 with *. So the naïve generated Generic1 instance would be: instance Generic1 (Compose (f :: k2 -> *) (g :: k1 -> k2)) where type Rep1 (Compose f g) = ... (f :.: Rec1 g) This is wrong, since f's kind is overly generalized. To get around this issue, there are variants of the TH functions that allow you to configure the KindSigOptions. If KindSigOptions is set to False, then generated instances will not include explicit kind signatures, leaving it up to GHC's kind inference machinery to figure out the correct kinds. Note [Generic1 is polykinded on GHC 8.2] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Prior to GHC 8.2, Generic1 :: (* -> *) -> Constraint. This means that if a Generic1 instance is defined for a polykinded data type like so: data Proxy k (a :: k) = Proxy Then k is unified with *, and this has an effect on the generated Generic1 instance: instance Generic1 (Proxy *) where ... We must take great care to ensure that all occurrences of k are substituted with *, or else the generated instance will be ill kinded. On GHC 8.2 and later, Generic1 :: (k -> *) -> Constraint. This means we don't have to do this kind unification anymore! Hooray! -} generic-deriving-1.11.1/src/Generics/Deriving/Show.hs0000644000000000000000000003540112765116253020566 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ < 709 {-# LANGUAGE OverlappingInstances #-} #endif module Generics.Deriving.Show ( -- * Generic show class GShow(..) -- * Default definition , gshowsPrecdefault -- * Internal show class , GShow'(..) ) where import Control.Applicative (Const, ZipList) import Data.Char (GeneralCategory) import Data.Int import Data.Monoid (All, Any, Dual, Product, Sum) import qualified Data.Monoid as Monoid (First, Last) import Data.Version (Version) import Data.Word import Foreign.C.Types import Foreign.ForeignPtr (ForeignPtr) import Foreign.Ptr import Generics.Deriving.Base import GHC.Exts hiding (Any) import System.Exit (ExitCode) import System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode) import System.IO.Error (IOErrorType) import System.Posix.Types #if MIN_VERSION_base(4,4,0) import Data.Complex (Complex) #endif #if MIN_VERSION_base(4,7,0) import Data.Proxy (Proxy) #endif #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity) import Data.Monoid (Alt) import Data.Void (Void) import Numeric.Natural (Natural) #endif #if MIN_VERSION_base(4,9,0) import Data.List.NonEmpty (NonEmpty) import qualified Data.Semigroup as Semigroup (First, Last) import Data.Semigroup (Arg, Max, Min, Option, WrappedMonoid) #endif -------------------------------------------------------------------------------- -- Generic show -------------------------------------------------------------------------------- intersperse :: a -> [a] -> [a] intersperse _ [] = [] intersperse _ [h] = [h] intersperse x (h:t) = h : x : (intersperse x t) appPrec :: Int appPrec = 2 data Type = Rec | Tup | Pref | Inf String class GShow' f where gshowsPrec' :: Type -> Int -> f a -> ShowS isNullary :: f a -> Bool isNullary = error "generic show (isNullary): unnecessary case" instance GShow' U1 where gshowsPrec' _ _ U1 = id isNullary _ = True instance (GShow c) => GShow' (K1 i c) where gshowsPrec' _ n (K1 a) = gshowsPrec n a isNullary _ = False -- No instances for P or Rec because gshow is only applicable to types of kind * instance (GShow' a, Constructor c) => GShow' (M1 C c a) where gshowsPrec' _ n c@(M1 x) = case fixity of Prefix -> showParen (n > appPrec && not (isNullary x)) ( showString (conName c) . if (isNullary x) then id else showChar ' ' . showBraces t (gshowsPrec' t appPrec x)) Infix _ m -> showParen (n > m) (showBraces t (gshowsPrec' t m x)) where fixity = conFixity c t = if (conIsRecord c) then Rec else case (conIsTuple c) of True -> Tup False -> case fixity of Prefix -> Pref Infix _ _ -> Inf (show (conName c)) showBraces :: Type -> ShowS -> ShowS showBraces Rec p = showChar '{' . p . showChar '}' showBraces Tup p = showChar '(' . p . showChar ')' showBraces Pref p = p showBraces (Inf _) p = p conIsTuple :: C1 c f p -> Bool conIsTuple y = tupleName (conName y) where tupleName ('(':',':_) = True tupleName _ = False instance (Selector s, GShow' a) => GShow' (M1 S s a) where gshowsPrec' t n s@(M1 x) | selName s == "" = --showParen (n > appPrec) (gshowsPrec' t n x) | otherwise = showString (selName s) . showString " = " . gshowsPrec' t 0 x isNullary (M1 x) = isNullary x instance (GShow' a) => GShow' (M1 D d a) where gshowsPrec' t n (M1 x) = gshowsPrec' t n x instance (GShow' a, GShow' b) => GShow' (a :+: b) where gshowsPrec' t n (L1 x) = gshowsPrec' t n x gshowsPrec' t n (R1 x) = gshowsPrec' t n x instance (GShow' a, GShow' b) => GShow' (a :*: b) where gshowsPrec' t@Rec n (a :*: b) = gshowsPrec' t n a . showString ", " . gshowsPrec' t n b gshowsPrec' t@(Inf s) n (a :*: b) = gshowsPrec' t n a . showString s . gshowsPrec' t n b gshowsPrec' t@Tup n (a :*: b) = gshowsPrec' t n a . showChar ',' . gshowsPrec' t n b gshowsPrec' t@Pref n (a :*: b) = gshowsPrec' t (n+1) a . showChar ' ' . gshowsPrec' t (n+1) b -- If we have a product then it is not a nullary constructor isNullary _ = False -- Unboxed types instance GShow' UChar where gshowsPrec' _ _ (UChar c) = showsPrec 0 (C# c) . showChar '#' instance GShow' UDouble where gshowsPrec' _ _ (UDouble d) = showsPrec 0 (D# d) . showString "##" instance GShow' UFloat where gshowsPrec' _ _ (UFloat f) = showsPrec 0 (F# f) . showChar '#' instance GShow' UInt where gshowsPrec' _ _ (UInt i) = showsPrec 0 (I# i) . showChar '#' instance GShow' UWord where gshowsPrec' _ _ (UWord w) = showsPrec 0 (W# w) . showString "##" class GShow a where gshowsPrec :: Int -> a -> ShowS gshows :: a -> ShowS gshows = gshowsPrec 0 gshow :: a -> String gshow x = gshows x "" #if __GLASGOW_HASKELL__ >= 701 default gshowsPrec :: (Generic a, GShow' (Rep a)) => Int -> a -> ShowS gshowsPrec = gshowsPrecdefault #endif gshowsPrecdefault :: (Generic a, GShow' (Rep a)) => Int -> a -> ShowS gshowsPrecdefault n = gshowsPrec' Pref n . from -- Base types instances -- Base types instances instance GShow () where gshowsPrec = gshowsPrecdefault instance (GShow a, GShow b) => GShow (a, b) where gshowsPrec = gshowsPrecdefault instance (GShow a, GShow b, GShow c) => GShow (a, b, c) where gshowsPrec = gshowsPrecdefault instance (GShow a, GShow b, GShow c, GShow d) => GShow (a, b, c, d) where gshowsPrec = gshowsPrecdefault instance (GShow a, GShow b, GShow c, GShow d, GShow e) => GShow (a, b, c, d, e) where gshowsPrec = gshowsPrecdefault instance (GShow a, GShow b, GShow c, GShow d, GShow e, GShow f) => GShow (a, b, c, d, e, f) where gshowsPrec = gshowsPrecdefault instance (GShow a, GShow b, GShow c, GShow d, GShow e, GShow f, GShow g) => GShow (a, b, c, d, e, f, g) where gshowsPrec = gshowsPrecdefault instance #if __GLASGOW_HASKELL__ >= 709 {-# OVERLAPPABLE #-} #endif (GShow a) => GShow [a] where gshowsPrec _ l = showChar '[' . foldr (.) id (intersperse (showChar ',') (map (gshowsPrec 0) l)) . showChar ']' instance (GShow (f p), GShow (g p)) => GShow ((f :+: g) p) where gshowsPrec = gshowsPrecdefault instance (GShow (f p), GShow (g p)) => GShow ((f :*: g) p) where gshowsPrec = gshowsPrecdefault instance GShow (f (g p)) => GShow ((f :.: g) p) where gshowsPrec = gshowsPrecdefault instance GShow All where gshowsPrec = gshowsPrecdefault #if MIN_VERSION_base(4,8,0) instance GShow (f a) => GShow (Alt f a) where gshowsPrec = gshowsPrecdefault #endif instance GShow Any where gshowsPrec = gshowsPrecdefault #if MIN_VERSION_base(4,9,0) instance (GShow a, GShow b) => GShow (Arg a b) where gshowsPrec = gshowsPrecdefault #endif #if !(MIN_VERSION_base(4,9,0)) instance GShow Arity where gshowsPrec = gshowsPrecdefault #endif instance GShow Associativity where gshowsPrec = gshowsPrecdefault instance GShow Bool where gshowsPrec = gshowsPrecdefault instance GShow BufferMode where gshowsPrec = showsPrec #if defined(HTYPE_CC_T) instance GShow CCc where gshowsPrec = showsPrec #endif instance GShow CChar where gshowsPrec = showsPrec instance GShow CClock where gshowsPrec = showsPrec #if defined(HTYPE_DEV_T) instance GShow CDev where gshowsPrec = showsPrec #endif instance GShow CDouble where gshowsPrec = showsPrec instance GShow CFloat where gshowsPrec = showsPrec #if defined(HTYPE_GID_T) instance GShow CGid where gshowsPrec = showsPrec #endif instance GShow Char where gshowsPrec = showsPrec #if defined(HTYPE_INO_T) instance GShow CIno where gshowsPrec = showsPrec #endif instance GShow CInt where gshowsPrec = showsPrec instance GShow CIntMax where gshowsPrec = showsPrec instance GShow CIntPtr where gshowsPrec = showsPrec instance GShow CLLong where gshowsPrec = showsPrec instance GShow CLong where gshowsPrec = showsPrec #if defined(HTYPE_MODE_T) instance GShow CMode where gshowsPrec = showsPrec #endif #if defined(HTYPE_NLINK_T) instance GShow CNlink where gshowsPrec = showsPrec #endif #if defined(HTYPE_OFF_T) instance GShow COff where gshowsPrec = showsPrec #endif #if MIN_VERSION_base(4,4,0) instance GShow a => GShow (Complex a) where gshowsPrec = gshowsPrecdefault #endif instance GShow a => GShow (Const a b) where gshowsPrec = gshowsPrecdefault #if defined(HTYPE_PID_T) instance GShow CPid where gshowsPrec = showsPrec #endif instance GShow CPtrdiff where gshowsPrec = showsPrec #if defined(HTYPE_RLIM_T) instance GShow CRLim where gshowsPrec = showsPrec #endif instance GShow CSChar where gshowsPrec = showsPrec #if defined(HTYPE_SPEED_T) instance GShow CSpeed where gshowsPrec = showsPrec #endif #if MIN_VERSION_base(4,4,0) instance GShow CSUSeconds where gshowsPrec = showsPrec #endif instance GShow CShort where gshowsPrec = showsPrec instance GShow CSigAtomic where gshowsPrec = showsPrec instance GShow CSize where gshowsPrec = showsPrec #if defined(HTYPE_SSIZE_T) instance GShow CSsize where gshowsPrec = showsPrec #endif #if defined(HTYPE_TCFLAG_T) instance GShow CTcflag where gshowsPrec = showsPrec #endif instance GShow CTime where gshowsPrec = showsPrec instance GShow CUChar where gshowsPrec = showsPrec #if defined(HTYPE_UID_T) instance GShow CUid where gshowsPrec = showsPrec #endif instance GShow CUInt where gshowsPrec = showsPrec instance GShow CUIntMax where gshowsPrec = showsPrec instance GShow CUIntPtr where gshowsPrec = showsPrec instance GShow CULLong where gshowsPrec = showsPrec instance GShow CULong where gshowsPrec = showsPrec #if MIN_VERSION_base(4,4,0) instance GShow CUSeconds where gshowsPrec = showsPrec #endif instance GShow CUShort where gshowsPrec = showsPrec instance GShow CWchar where gshowsPrec = showsPrec instance GShow Double where gshowsPrec = showsPrec instance GShow a => GShow (Dual a) where gshowsPrec = gshowsPrecdefault instance (GShow a, GShow b) => GShow (Either a b) where gshowsPrec = gshowsPrecdefault instance GShow ExitCode where gshowsPrec = gshowsPrecdefault instance GShow Fd where gshowsPrec = showsPrec instance GShow a => GShow (Monoid.First a) where gshowsPrec = gshowsPrecdefault #if MIN_VERSION_base(4,9,0) instance GShow a => GShow (Semigroup.First a) where gshowsPrec = gshowsPrecdefault #endif instance GShow Fixity where gshowsPrec = gshowsPrecdefault instance GShow Float where gshowsPrec = showsPrec instance GShow (ForeignPtr a) where gshowsPrec = showsPrec instance GShow (FunPtr a) where gshowsPrec = showsPrec instance GShow GeneralCategory where gshowsPrec = showsPrec instance GShow Handle where gshowsPrec = showsPrec instance GShow HandlePosn where gshowsPrec = showsPrec #if MIN_VERSION_base(4,8,0) instance GShow a => GShow (Identity a) where gshowsPrec = gshowsPrecdefault #endif instance GShow Int where gshowsPrec = showsPrec instance GShow Int8 where gshowsPrec = showsPrec instance GShow Int16 where gshowsPrec = showsPrec instance GShow Int32 where gshowsPrec = showsPrec instance GShow Int64 where gshowsPrec = showsPrec instance GShow Integer where gshowsPrec = showsPrec instance GShow IntPtr where gshowsPrec = showsPrec instance GShow IOError where gshowsPrec = showsPrec instance GShow IOErrorType where gshowsPrec = showsPrec instance GShow IOMode where gshowsPrec = showsPrec instance GShow c => GShow (K1 i c p) where gshowsPrec = gshowsPrecdefault instance GShow a => GShow (Monoid.Last a) where gshowsPrec = gshowsPrecdefault #if MIN_VERSION_base(4,9,0) instance GShow a => GShow (Semigroup.Last a) where gshowsPrec = gshowsPrecdefault #endif instance GShow (f p) => GShow (M1 i c f p) where gshowsPrec = gshowsPrecdefault #if MIN_VERSION_base(4,9,0) instance GShow a => GShow (Max a) where gshowsPrec = gshowsPrecdefault #endif instance GShow a => GShow (Maybe a) where gshowsPrec = gshowsPrecdefault #if MIN_VERSION_base(4,9,0) instance GShow a => GShow (Min a) where gshowsPrec = gshowsPrecdefault #endif #if MIN_VERSION_base(4,8,0) instance GShow Natural where gshowsPrec = showsPrec #endif #if MIN_VERSION_base(4,9,0) instance GShow a => GShow (NonEmpty a) where gshowsPrec = gshowsPrecdefault instance GShow a => GShow (Option a) where gshowsPrec = gshowsPrecdefault #endif instance GShow Ordering where gshowsPrec = gshowsPrecdefault instance GShow p => GShow (Par1 p) where gshowsPrec = gshowsPrecdefault instance GShow a => GShow (Product a) where gshowsPrec = gshowsPrecdefault #if MIN_VERSION_base(4,7,0) instance GShow (Proxy s) where gshowsPrec = gshowsPrecdefault #endif instance GShow (Ptr a) where gshowsPrec = showsPrec instance GShow (f p) => GShow (Rec1 f p) where gshowsPrec = gshowsPrecdefault instance GShow SeekMode where gshowsPrec = showsPrec instance #if __GLASGOW_HASKELL__ >= 709 {-# OVERLAPPING #-} #endif GShow String where gshowsPrec = showsPrec instance GShow a => GShow (Sum a) where gshowsPrec = gshowsPrecdefault instance GShow (U1 p) where gshowsPrec = gshowsPrecdefault instance GShow (UChar p) where gshowsPrec = gshowsPrecdefault instance GShow (UDouble p) where gshowsPrec = gshowsPrecdefault instance GShow (UFloat p) where gshowsPrec = gshowsPrecdefault instance GShow (UInt p) where gshowsPrec = gshowsPrecdefault instance GShow (UWord p) where gshowsPrec = gshowsPrecdefault instance GShow Version where gshowsPrec = gshowsPrecdefault #if MIN_VERSION_base(4,8,0) instance GShow Void where gshowsPrec = showsPrec #endif instance GShow Word where gshowsPrec = showsPrec instance GShow Word8 where gshowsPrec = showsPrec instance GShow Word16 where gshowsPrec = showsPrec instance GShow Word32 where gshowsPrec = showsPrec instance GShow Word64 where gshowsPrec = showsPrec instance GShow WordPtr where gshowsPrec = showsPrec #if MIN_VERSION_base(4,9,0) instance GShow m => GShow (WrappedMonoid m) where gshowsPrec = gshowsPrecdefault #endif instance GShow a => GShow (ZipList a) where gshowsPrec = gshowsPrecdefault generic-deriving-1.11.1/src/Generics/Deriving/Semigroup.hs0000644000000000000000000001472612765116253021627 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE Safe #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif module Generics.Deriving.Semigroup ( -- * Generic semigroup class GSemigroup(..) -- * Default definition , gsappenddefault -- * Internal semigroup class , GSemigroup'(..) ) where import Control.Applicative import Data.Monoid as Monoid #if MIN_VERSION_base(4,5,0) hiding ((<>)) #endif import Generics.Deriving.Base #if MIN_VERSION_base(4,7,0) import Data.Proxy (Proxy) #endif #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity) import Data.Void (Void) #endif #if MIN_VERSION_base(4,9,0) import Data.List.NonEmpty (NonEmpty(..)) import Data.Semigroup as Semigroup import Generics.Deriving.Monoid (GMonoid(..)) #endif ------------------------------------------------------------------------------- infixr 6 `gsappend'` class GSemigroup' f where gsappend' :: f x -> f x -> f x instance GSemigroup' U1 where gsappend' U1 U1 = U1 instance GSemigroup a => GSemigroup' (K1 i a) where gsappend' (K1 x) (K1 y) = K1 (gsappend x y) instance GSemigroup' f => GSemigroup' (M1 i c f) where gsappend' (M1 x) (M1 y) = M1 (gsappend' x y) instance (GSemigroup' f, GSemigroup' g) => GSemigroup' (f :*: g) where gsappend' (x1 :*: y1) (x2 :*: y2) = gsappend' x1 x2 :*: gsappend' y1 y2 ------------------------------------------------------------------------------- infixr 6 `gsappend` class GSemigroup a where gsappend :: a -> a -> a #if __GLASGOW_HASKELL__ >= 701 default gsappend :: (Generic a, GSemigroup' (Rep a)) => a -> a -> a gsappend = gsappenddefault #endif gstimes :: Integral b => b -> a -> a gstimes y0 x0 | y0 <= 0 = error "gstimes: positive multiplier expected" | otherwise = f x0 y0 where f x y | even y = f (gsappend x x) (y `quot` 2) | y == 1 = x | otherwise = g (gsappend x x) (pred y `quot` 2) x g x y z | even y = g (gsappend x x) (y `quot` 2) z | y == 1 = gsappend x z | otherwise = g (gsappend x x) (pred y `quot` 2) (gsappend x z) #if MIN_VERSION_base(4,9,0) -- | Only available with @base-4.9@ or later gsconcat :: NonEmpty a -> a gsconcat (a :| as) = go a as where go b (c:cs) = gsappend b (go c cs) go b [] = b #endif infixr 6 `gsappenddefault` gsappenddefault :: (Generic a, GSemigroup' (Rep a)) => a -> a -> a gsappenddefault x y = to (gsappend' (from x) (from y)) ------------------------------------------------------------------------------- -- Instances that reuse Monoid instance GSemigroup Ordering where gsappend = mappend instance GSemigroup () where gsappend = mappend instance GSemigroup Any where gsappend = mappend instance GSemigroup All where gsappend = mappend instance GSemigroup (Monoid.First a) where gsappend = mappend instance GSemigroup (Monoid.Last a) where gsappend = mappend instance Num a => GSemigroup (Sum a) where gsappend = mappend instance Num a => GSemigroup (Product a) where gsappend = mappend instance GSemigroup [a] where gsappend = mappend instance GSemigroup (Endo a) where gsappend = mappend #if MIN_VERSION_base(4,8,0) instance Alternative f => GSemigroup (Alt f a) where gsappend = mappend #endif -- Handwritten instances instance GSemigroup a => GSemigroup (Dual a) where gsappend (Dual x) (Dual y) = Dual (gsappend y x) instance GSemigroup a => GSemigroup (Maybe a) where gsappend Nothing x = x gsappend x Nothing = x gsappend (Just x) (Just y) = Just (gsappend x y) instance GSemigroup b => GSemigroup (a -> b) where gsappend f g x = gsappend (f x) (g x) instance GSemigroup a => GSemigroup (Const a b) where gsappend = gsappenddefault instance GSemigroup (Either a b) where gsappend Left{} b = b gsappend a _ = a #if MIN_VERSION_base(4,7,0) instance GSemigroup # if MIN_VERSION_base(4,9,0) (Proxy s) # else (Proxy (s :: *)) # endif where gsappend = gsappenddefault #endif #if MIN_VERSION_base(4,8,0) instance GSemigroup a => GSemigroup (Identity a) where gsappend = gsappenddefault instance GSemigroup Void where gsappend a _ = a #endif #if MIN_VERSION_base(4,9,0) instance GSemigroup (Semigroup.First a) where gsappend = (<>) instance GSemigroup (Semigroup.Last a) where gsappend = (<>) instance Ord a => GSemigroup (Max a) where gsappend = (<>) instance Ord a => GSemigroup (Min a) where gsappend = (<>) instance GSemigroup (NonEmpty a) where gsappend = (<>) instance GSemigroup a => GSemigroup (Option a) where gsappend (Option a) (Option b) = Option (gsappend a b) instance GMonoid m => GSemigroup (WrappedMonoid m) where gsappend (WrapMonoid a) (WrapMonoid b) = WrapMonoid (gmappend a b) #endif -- Tuple instances instance (GSemigroup a,GSemigroup b) => GSemigroup (a,b) where gsappend (a1,b1) (a2,b2) = (gsappend a1 a2,gsappend b1 b2) instance (GSemigroup a,GSemigroup b,GSemigroup c) => GSemigroup (a,b,c) where gsappend (a1,b1,c1) (a2,b2,c2) = (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2) instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d) => GSemigroup (a,b,c,d) where gsappend (a1,b1,c1,d1) (a2,b2,c2,d2) = (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2) instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e) => GSemigroup (a,b,c,d,e) where gsappend (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) = (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2) instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e,GSemigroup f) => GSemigroup (a,b,c,d,e,f) where gsappend (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) = (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2,gsappend f1 f2) instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e,GSemigroup f,GSemigroup g) => GSemigroup (a,b,c,d,e,f,g) where gsappend (a1,b1,c1,d1,e1,f1,g1) (a2,b2,c2,d2,e2,f2,g2) = (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2,gsappend f1 f2,gsappend g1 g2) instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e,GSemigroup f,GSemigroup g,GSemigroup h) => GSemigroup (a,b,c,d,e,f,g,h) where gsappend (a1,b1,c1,d1,e1,f1,g1,h1) (a2,b2,c2,d2,e2,f2,g2,h2) = (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2,gsappend f1 f2,gsappend g1 g2,gsappend h1 h2) generic-deriving-1.11.1/src/Generics/Deriving/Monoid.hs0000644000000000000000000001774012765116253021101 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE Safe #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif {- | This module provides two main features: 1. 'GMonoid', a generic version of the 'Monoid' type class, including instances of the types from "Data.Monoid" 2. Default generic definitions for the 'Monoid' methods 'mempty' and 'mappend' The generic defaults only work for types without alternatives (i.e. they have only one constructor). We cannot in general know how to deal with different constructors. -} module Generics.Deriving.Monoid ( -- * GMonoid type class GMonoid(..), -- * Default definitions -- ** GMonoid gmemptydefault, gmappenddefault, -- * Internal auxiliary class for GMonoid GMonoid'(..), -- ** Monoid {- | These functions can be used in a 'Monoid' instance. For example: @ -- LANGUAGE DeriveGeneric import Generics.Deriving.Base (Generic) import Generics.Deriving.Monoid data T a = C a (Maybe a) deriving Generic instance Monoid a => Monoid (T a) where mempty = memptydefault mappend = mappenddefault @ -} memptydefault, mappenddefault, -- * Internal auxiliary class for Monoid Monoid'(..), -- * The Monoid module -- | This is exported for convenient access to the various wrapper types. module Data.Monoid, ) where -------------------------------------------------------------------------------- import Control.Applicative import Data.Monoid import Generics.Deriving.Base #if MIN_VERSION_base(4,7,0) import Data.Proxy (Proxy) #endif #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity) #endif #if MIN_VERSION_base(4,9,0) import Data.Semigroup (WrappedMonoid) #endif -------------------------------------------------------------------------------- class GMonoid' f where gmempty' :: f x gmappend' :: f x -> f x -> f x instance GMonoid' U1 where gmempty' = U1 gmappend' U1 U1 = U1 instance GMonoid a => GMonoid' (K1 i a) where gmempty' = K1 gmempty gmappend' (K1 x) (K1 y) = K1 (x `gmappend` y) instance GMonoid' f => GMonoid' (M1 i c f) where gmempty' = M1 gmempty' gmappend' (M1 x) (M1 y) = M1 (x `gmappend'` y) instance (GMonoid' f, GMonoid' h) => GMonoid' (f :*: h) where gmempty' = gmempty' :*: gmempty' gmappend' (x1 :*: y1) (x2 :*: y2) = gmappend' x1 x2 :*: gmappend' y1 y2 -------------------------------------------------------------------------------- gmemptydefault :: (Generic a, GMonoid' (Rep a)) => a gmemptydefault = to gmempty' gmappenddefault :: (Generic a, GMonoid' (Rep a)) => a -> a -> a gmappenddefault x y = to (gmappend' (from x) (from y)) -------------------------------------------------------------------------------- class Monoid' f where mempty' :: f x mappend' :: f x -> f x -> f x instance Monoid' U1 where mempty' = U1 mappend' U1 U1 = U1 instance Monoid a => Monoid' (K1 i a) where mempty' = K1 mempty mappend' (K1 x) (K1 y) = K1 (x `mappend` y) instance Monoid' f => Monoid' (M1 i c f) where mempty' = M1 mempty' mappend' (M1 x) (M1 y) = M1 (x `mappend'` y) instance (Monoid' f, Monoid' h) => Monoid' (f :*: h) where mempty' = mempty' :*: mempty' mappend' (x1 :*: y1) (x2 :*: y2) = mappend' x1 x2 :*: mappend' y1 y2 -------------------------------------------------------------------------------- memptydefault :: (Generic a, Monoid' (Rep a)) => a memptydefault = to mempty' mappenddefault :: (Generic a, Monoid' (Rep a)) => a -> a -> a mappenddefault x y = to (mappend' (from x) (from y)) -------------------------------------------------------------------------------- class GMonoid a where -- | Generic 'mempty' gmempty :: a -- | Generic 'mappend' gmappend :: a -> a -> a -- | Generic 'mconcat' gmconcat :: [a] -> a gmconcat = foldr gmappend gmempty #if __GLASGOW_HASKELL__ >= 701 default gmempty :: (Generic a, GMonoid' (Rep a)) => a gmempty = to gmempty' default gmappend :: (Generic a, GMonoid' (Rep a)) => a -> a -> a gmappend x y = to (gmappend' (from x) (from y)) #endif -------------------------------------------------------------------------------- -- Instances that reuse Monoid instance GMonoid Ordering where gmempty = mempty gmappend = mappend instance GMonoid () where gmempty = mempty gmappend = mappend instance GMonoid Any where gmempty = mempty gmappend = mappend instance GMonoid All where gmempty = mempty gmappend = mappend instance GMonoid (First a) where gmempty = mempty gmappend = mappend instance GMonoid (Last a) where gmempty = mempty gmappend = mappend instance Num a => GMonoid (Sum a) where gmempty = mempty gmappend = mappend instance Num a => GMonoid (Product a) where gmempty = mempty gmappend = mappend instance GMonoid [a] where gmempty = mempty gmappend = mappend instance GMonoid (Endo a) where gmempty = mempty gmappend = mappend #if MIN_VERSION_base(4,8,0) instance Alternative f => GMonoid (Alt f a) where gmempty = mempty gmappend = mappend #endif -- Handwritten instances instance GMonoid a => GMonoid (Dual a) where gmempty = Dual gmempty gmappend (Dual x) (Dual y) = Dual (gmappend y x) instance GMonoid a => GMonoid (Maybe a) where gmempty = Nothing gmappend Nothing x = x gmappend x Nothing = x gmappend (Just x) (Just y) = Just (gmappend x y) instance GMonoid b => GMonoid (a -> b) where gmempty _ = gmempty gmappend f g x = gmappend (f x) (g x) instance GMonoid a => GMonoid (Const a b) where gmempty = gmemptydefault gmappend = gmappenddefault #if MIN_VERSION_base(4,7,0) instance GMonoid # if MIN_VERSION_base(4,9,0) (Proxy s) # else (Proxy (s :: *)) # endif where gmempty = memptydefault gmappend = mappenddefault #endif #if MIN_VERSION_base(4,8,0) instance GMonoid a => GMonoid (Identity a) where gmempty = gmemptydefault gmappend = gmappenddefault #endif #if MIN_VERSION_base(4,9,0) instance GMonoid m => GMonoid (WrappedMonoid m) where gmempty = gmemptydefault gmappend = gmappenddefault #endif -- Tuple instances instance (GMonoid a,GMonoid b) => GMonoid (a,b) where gmempty = (gmempty,gmempty) gmappend (a1,b1) (a2,b2) = (gmappend a1 a2,gmappend b1 b2) instance (GMonoid a,GMonoid b,GMonoid c) => GMonoid (a,b,c) where gmempty = (gmempty,gmempty,gmempty) gmappend (a1,b1,c1) (a2,b2,c2) = (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2) instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d) => GMonoid (a,b,c,d) where gmempty = (gmempty,gmempty,gmempty,gmempty) gmappend (a1,b1,c1,d1) (a2,b2,c2,d2) = (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2) instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e) => GMonoid (a,b,c,d,e) where gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty) gmappend (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) = (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2) instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f) => GMonoid (a,b,c,d,e,f) where gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty) gmappend (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) = (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2) instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f,GMonoid g) => GMonoid (a,b,c,d,e,f,g) where gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty) gmappend (a1,b1,c1,d1,e1,f1,g1) (a2,b2,c2,d2,e2,f2,g2) = (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2,gmappend g1 g2) instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f,GMonoid g,GMonoid h) => GMonoid (a,b,c,d,e,f,g,h) where gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty) gmappend (a1,b1,c1,d1,e1,f1,g1,h1) (a2,b2,c2,d2,e2,f2,g2,h2) = (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2,gmappend g1 g2,gmappend h1 h2) generic-deriving-1.11.1/src/Generics/Deriving/Instances.hs0000644000000000000000000013127212765116253021600 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 711 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif {-# OPTIONS_GHC -fno-warn-orphans #-} module Generics.Deriving.Instances ( -- Only instances from Generics.Deriving.Base -- and the Generic1 instances #if !(MIN_VERSION_base(4,9,0)) Rep0ExitCode , Rep0Version , Rep1ConSum , Rep1ConProduct , Rep1ConCompose , Rep1K1 , Rep1M1 , Rep1Par1 , Rep1Rec1 , Rep1U1 , Rep0V1 , Rep1V1 , Rep0UAddr , Rep1UAddr , Rep0UChar , Rep1UChar , Rep0UDouble , Rep1UDouble , Rep0UFloat , Rep1UFloat , Rep0UInt , Rep1UInt , Rep0UWord , Rep1UWord # if MIN_VERSION_base(4,4,0) , Rep0Complex , Rep1Complex # endif # if MIN_VERSION_base(4,7,0) , Rep1Proxy # endif #endif #if !(MIN_VERSION_base(4,7,0)) , 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 !(MIN_VERSION_base(4,6,0)) , Rep1Either , Rep1List , Rep1Maybe , Rep1Tuple2 , Rep1Tuple3 , Rep1Tuple4 , Rep1Tuple5 , Rep1Tuple6 , Rep1Tuple7 #endif #if !(MIN_VERSION_base(4,4,0)) , Rep0Bool , Rep0Char , Rep0Double , Rep0Either , Rep0Int , Rep0Float , Rep0List , Rep0Maybe , Rep0Ordering , Rep0Tuple2 , Rep0Tuple3 , Rep0Tuple4 , Rep0Tuple5 , Rep0Tuple6 , Rep0Tuple7 , Rep0Unit #endif ) where #if !(MIN_VERSION_base(4,7,0)) import Control.Applicative import Data.Monoid #endif #if MIN_VERSION_base(4,4,0) && !(MIN_VERSION_base(4,9,0)) import Data.Complex (Complex(..)) #endif #if MIN_VERSION_base(4,7,0) && !(MIN_VERSION_base(4,9,0)) import Data.Proxy (Proxy(..)) #endif #if !(MIN_VERSION_base(4,9,0)) import Data.Version (Version(..)) import Generics.Deriving.Base.Internal import System.Exit (ExitCode(..)) #endif #if !(MIN_VERSION_base(4,9,0)) type Rep0ExitCode = D1 D1ExitCode (C1 C1_0ExitCode U1 :+: C1 C1_1ExitCode (S1 NoSelector (Rec0 Int))) instance Generic ExitCode where type Rep ExitCode = Rep0ExitCode from x = M1 (case x of ExitSuccess -> L1 (M1 U1) ExitFailure g -> R1 (M1 (M1 (K1 g)))) to (M1 x) = case x of L1 (M1 U1) -> ExitSuccess R1 (M1 (M1 (K1 g))) -> ExitFailure g data D1ExitCode data C1_0ExitCode data C1_1ExitCode instance Datatype D1ExitCode where datatypeName _ = "ExitCode" moduleName _ = "GHC.IO.Exception" instance Constructor C1_0ExitCode where conName _ = "ExitSuccess" instance Constructor C1_1ExitCode where conName _ = "ExitFailure" ----- type Rep0Version = D1 D1Version (C1 C1_0Version (S1 S1_0_0Version (Rec0 [Int]) :*: S1 S1_0_1Version (Rec0 [String]))) instance Generic Version where type Rep Version = Rep0Version from (Version b t) = M1 (M1 (M1 (K1 b) :*: M1 (K1 t))) to (M1 (M1 (M1 (K1 b) :*: M1 (K1 t)))) = Version b t data D1Version data C1_0Version data S1_0_0Version data S1_0_1Version instance Datatype D1Version where datatypeName _ = "Version" moduleName _ = "Data.Version" instance Constructor C1_0Version where conName _ = "Version" conIsRecord _ = True instance Selector S1_0_0Version where selName _ = "versionBranch" instance Selector S1_0_1Version where selName _ = "versionTags" ----- type Rep1ConSum f g = D1 D1ConSum (C1 C1_0ConSum (S1 NoSelector (Rec1 f)) :+: C1 C1_1ConSum (S1 NoSelector (Rec1 g))) instance Generic1 (f :+: g) where type Rep1 (f :+: g) = Rep1ConSum f g from1 x = M1 (case x of L1 l -> L1 (M1 (M1 (Rec1 l))) R1 r -> R1 (M1 (M1 (Rec1 r)))) to1 (M1 x) = case x of L1 (M1 (M1 l)) -> L1 (unRec1 l) R1 (M1 (M1 r)) -> R1 (unRec1 r) data D1ConSum data C1_0ConSum data C1_1ConSum instance Datatype D1ConSum where datatypeName _ = ":+:" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" # endif instance Constructor C1_0ConSum where conName _ = "L1" instance Constructor C1_1ConSum where conName _ = "R1" ----- type Rep1ConProduct f g = D1 D1ConProduct (C1 C1_ConProduct (S1 NoSelector (Rec1 f) :*: S1 NoSelector (Rec1 g))) instance Generic1 (f :*: g) where type Rep1 (f :*: g) = Rep1ConProduct f g from1 (f :*: g) = M1 (M1 (M1 (Rec1 f) :*: M1 (Rec1 g))) to1 (M1 (M1 (M1 f :*: M1 g))) = unRec1 f :*: unRec1 g data D1ConProduct data C1_ConProduct instance Datatype D1ConProduct where datatypeName _ = ":*:" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" # endif instance Constructor C1_ConProduct where conName _ = ":*:" conFixity _ = Infix RightAssociative 6 ----- type Rep1ConCompose f g = D1 D1ConCompose (C1 C1_0ConCompose (S1 S1_0_0ConCompose (f :.: Rec1 g))) instance Functor f => Generic1 (f :.: g) where type Rep1 (f :.: g) = Rep1ConCompose f g from1 (Comp1 c) = M1 (M1 (M1 (Comp1 (fmap Rec1 c)))) to1 (M1 (M1 (M1 c))) = Comp1 (fmap unRec1 (unComp1 c)) data D1ConCompose data C1_0ConCompose data S1_0_0ConCompose instance Datatype D1ConCompose where datatypeName _ = ":.:" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" # endif instance Constructor C1_0ConCompose where conName _ = "Comp1" conIsRecord _ = True instance Selector S1_0_0ConCompose where selName _ = "unComp1" ----- type Rep1K1 i c = D1 D1K1 (C1 C1_0K1 (S1 S1_0_0K1 (Rec0 c))) instance Generic1 (K1 i c) where type Rep1 (K1 i c) = Rep1K1 i c from1 (K1 c) = M1 (M1 (M1 (K1 c))) to1 (M1 (M1 (M1 c))) = K1 (unK1 c) data D1K1 data C1_0K1 data S1_0_0K1 instance Datatype D1K1 where datatypeName _ = "K1" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" # endif instance Constructor C1_0K1 where conName _ = "K1" conIsRecord _ = True instance Selector S1_0_0K1 where selName _ = "unK1" ----- type Rep1M1 i c f = D1 D1M1 (C1 C1_0M1 (S1 S1_0_0M1 (Rec1 f))) instance Generic1 (M1 i c f) where type Rep1 (M1 i c f) = Rep1M1 i c f from1 (M1 m) = M1 (M1 (M1 (Rec1 m))) to1 (M1 (M1 (M1 m))) = M1 (unRec1 m) data D1M1 data C1_0M1 data S1_0_0M1 instance Datatype D1M1 where datatypeName _ = "M1" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" # endif instance Constructor C1_0M1 where conName _ = "M1" conIsRecord _ = True instance Selector S1_0_0M1 where selName _ = "unM1" ----- type Rep1Par1 = D1 D1Par1 (C1 C1_0Par1 (S1 S1_0_0Par1 Par1)) instance Generic1 Par1 where type Rep1 Par1 = Rep1Par1 from1 (Par1 p) = M1 (M1 (M1 (Par1 p))) to1 (M1 (M1 (M1 p))) = Par1 (unPar1 p) data D1Par1 data C1_0Par1 data S1_0_0Par1 instance Datatype D1Par1 where datatypeName _ = "Par1" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" # endif instance Constructor C1_0Par1 where conName _ = "Par1" conIsRecord _ = True instance Selector S1_0_0Par1 where selName _ = "unPar1" ----- type Rep1Rec1 f = D1 D1Rec1 (C1 C1_0Rec1 (S1 S1_0_0Rec1 (Rec1 f))) instance Generic1 (Rec1 f) where type Rep1 (Rec1 f) = Rep1Rec1 f from1 (Rec1 r) = M1 (M1 (M1 (Rec1 r))) to1 (M1 (M1 (M1 r))) = Rec1 (unRec1 r) data D1Rec1 data C1_0Rec1 data S1_0_0Rec1 instance Datatype D1Rec1 where datatypeName _ = "Rec1" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" # endif instance Constructor C1_0Rec1 where conName _ = "Rec1" conIsRecord _ = True instance Selector S1_0_0Rec1 where selName _ = "unRec1" ----- type Rep1U1 = D1 D1U1 (C1 C1_0U1 U1) instance Generic1 U1 where type Rep1 U1 = Rep1U1 from1 U1 = M1 (M1 U1) to1 (M1 (M1 U1)) = U1 data D1U1 data C1_0U1 instance Datatype D1U1 where datatypeName _ = "U1" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" # endif instance Constructor C1_0U1 where conName _ = "U1" ----- type Rep0V1 p = D1 D1V1 V1 type Rep1V1 = D1 D1V1 V1 instance Generic (V1 p) where type Rep (V1 p) = Rep0V1 p from _ = M1 (error "No generic representation for empty datatype V1") to (M1 _) = error "No values for empty datatype V1" instance Generic1 V1 where type Rep1 V1 = Rep1V1 from1 _ = M1 (error "No generic representation for empty datatype V1") to1 (M1 _) = error "No values for empty datatype V1" data D1V1 instance Datatype D1V1 where datatypeName _ = "V1" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # else moduleName _ = "GHC.Generics" # endif ----- type Rep0UAddr p = D1 D1UAddr (C1 C1_0UAddr (S1 S1_0_0UAddr UAddr)) type Rep1UAddr = 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 instance Generic1 UAddr where type Rep1 UAddr = Rep1UAddr from1 (UAddr a) = M1 (M1 (M1 (UAddr a))) to1 (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.Internal" 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)) type Rep1UChar = 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 instance Generic1 UChar where type Rep1 UChar = Rep1UChar from1 (UChar c) = M1 (M1 (M1 (UChar c))) to1 (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.Internal" 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)) type Rep1UDouble = 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 instance Generic1 UDouble where type Rep1 UDouble = Rep1UDouble from1 (UDouble d) = M1 (M1 (M1 (UDouble d))) to1 (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.Internal" 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)) type Rep1UFloat = 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 instance Generic1 UFloat where type Rep1 UFloat = Rep1UFloat from1 (UFloat f) = M1 (M1 (M1 (UFloat f))) to1 (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.Internal" 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)) type Rep1UInt = 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 instance Generic1 UInt where type Rep1 UInt = Rep1UInt from1 (UInt i) = M1 (M1 (M1 (UInt i))) to1 (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.Internal" 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)) type Rep1UWord = 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 instance Generic1 UWord where type Rep1 UWord = Rep1UWord from1 (UWord w) = M1 (M1 (M1 (UWord w))) to1 (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.Internal" instance Constructor C1_0UWord where conName _ = "UWord" conIsRecord _ = True instance Selector S1_0_0UWord where selName _ = "uWord#" ----- # if MIN_VERSION_base(4,4,0) type Rep0Complex a = D1 D1Complex (C1 C1_0Complex (S1 NoSelector (Rec0 a) :*: S1 NoSelector (Rec0 a))) type Rep1Complex = D1 D1Complex (C1 C1_0Complex (S1 NoSelector Par1 :*: S1 NoSelector Par1)) instance Generic (Complex a) where type Rep (Complex a) = Rep0Complex a from (a :+ b) = M1 (M1 (M1 (K1 a) :*: M1 (K1 b))) to (M1 (M1 (M1 (K1 a) :*: M1 (K1 b)))) = a :+ b instance Generic1 Complex where type Rep1 Complex = Rep1Complex from1 (a :+ b) = M1 (M1 (M1 (Par1 a) :*: M1 (Par1 b))) to1 (M1 (M1 (M1 a :*: M1 b))) = unPar1 a :+ unPar1 b data D1Complex data C1_0Complex instance Datatype D1Complex where datatypeName _ = "Complex" moduleName _ = "Data.Complex" instance Constructor C1_0Complex where conName _ = ":+" conFixity _ = Infix LeftAssociative 9 # endif ----- # if MIN_VERSION_base(4,7,0) type Rep1Proxy = D1 D1Proxy (C1 C1_0Proxy U1) instance Generic1 Proxy where type Rep1 Proxy = Rep1Proxy from1 Proxy = M1 (M1 U1) to1 (M1 (M1 U1)) = Proxy data D1Proxy data C1_0Proxy instance Datatype D1Proxy where datatypeName _ = "Proxy" moduleName _ = "Data.Proxy" instance Constructor C1_0Proxy where conName _ = "Proxy" # endif #endif ----- #if !(MIN_VERSION_base(4,7,0)) -------------------------------------------------------------------------------- -- 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 x = M1 (case x of NoArity -> L1 (M1 U1) Arity a -> R1 (M1 (M1 (K1 a)))) to (M1 x) = case x of L1 (M1 U1) -> NoArity R1 (M1 (M1 (K1 a))) -> Arity a data D1Arity data C1_0Arity data C1_1Arity instance Datatype D1Arity where datatypeName _ = "Arity" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # 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 x = M1 (case x of LeftAssociative -> L1 (M1 U1) RightAssociative -> R1 (L1 (M1 U1)) NotAssociative -> R1 (R1 (M1 U1))) to (M1 x) = case x of L1 (M1 U1) -> LeftAssociative R1 (L1 (M1 U1)) -> RightAssociative R1 (R1 (M1 U1)) -> NotAssociative data D1Associativity data C1_0Associativity data C1_1Associativity data C1_2Associativity instance Datatype D1Associativity where datatypeName _ = "Associativity" # if !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # 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 x = M1 (case x of Prefix -> L1 (M1 U1) Infix a i -> R1 (M1 (M1 (K1 a) :*: M1 (K1 i)))) to (M1 x) = case x of L1 (M1 U1) -> Prefix 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 !(MIN_VERSION_base(4,4,0)) moduleName _ = "Generics.Deriving.Base.Internal" # 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 ----- 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 ----- 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 ----- 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 ----- 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 ----- 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 x = M1 (case x of L1 l -> L1 (M1 (M1 (K1 l))) R1 r -> R1 (M1 (M1 (K1 r)))) to (M1 x) = case x of L1 (M1 (M1 (K1 l))) -> L1 l R1 (M1 (M1 (K1 r))) -> R1 r ----- 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 ----- 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 #endif ----- #if !(MIN_VERSION_base(4,6,0)) type Rep1List = D1 D1List (C1 C1_0List U1 :+: C1 C1_1List (S1 NoSelector Par1 :*: S1 NoSelector (Rec1 []))) instance Generic1 [] where type Rep1 [] = Rep1List from1 x = M1 (case x of [] -> L1 (M1 U1) h:t -> R1 (M1 (M1 (Par1 h) :*: M1 (Rec1 t)))) to1 (M1 x) = case x of L1 (M1 U1) -> [] 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 x = M1 (case x of Left l -> L1 (M1 (M1 (K1 l))) Right r -> R1 (M1 (M1 (Par1 r)))) to1 (M1 x) = case x of L1 (M1 (M1 (K1 l))) -> Left l 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 x = M1 (case x of Nothing -> L1 (M1 U1) Just j -> R1 (M1 (M1 (Par1 j)))) to1 (M1 x) = case x of L1 (M1 U1) -> Nothing 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 !(MIN_VERSION_base(4,4,0)) type Rep0Bool = D1 D1Bool (C1 C1_0Bool U1 :+: C1 C1_1Bool U1) instance Generic Bool where type Rep Bool = Rep0Bool from x = M1 (case x of False -> L1 (M1 U1) True -> R1 (M1 U1)) to (M1 x) = case x of L1 (M1 U1) -> False 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 x = M1 (case x of Left l -> L1 (M1 (M1 (K1 l))) Right r -> R1 (M1 (M1 (K1 r)))) to (M1 x) = case x of L1 (M1 (M1 (K1 l))) -> Left l 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 x = M1 (case x of [] -> L1 (M1 U1) h:t -> R1 (M1 (M1 (K1 h) :*: M1 (K1 t)))) to (M1 x) = case x of L1 (M1 U1) -> [] 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 x = M1 (case x of Nothing -> L1 (M1 U1) Just j -> R1 (M1 (M1 (K1 j)))) to (M1 x) = case x of L1 (M1 U1) -> Nothing 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 x = M1 (case x of LT -> L1 (M1 U1) EQ -> R1 (L1 (M1 U1)) GT -> R1 (R1 (M1 U1))) to (M1 x) = case x of L1 (M1 U1) -> LT R1 (L1 (M1 U1)) -> EQ R1 (R1 (M1 U1)) -> GT data D1Ordering data C1_0Ordering data C1_1Ordering data C1_2Ordering instance Datatype D1Ordering where datatypeName _ = "Ordering" moduleName _ = "GHC.Ordering" instance Constructor C1_0Ordering where conName _ = "LT" instance Constructor C1_1Ordering where conName _ = "EQ" instance Constructor C1_2Ordering where conName _ = "GT" ----- type Rep0Unit = D1 D1Unit (C1 C1_0Unit U1) instance Generic () where type Rep () = Rep0Unit from () = M1 (M1 U1) to (M1 (M1 U1)) = () data D1Unit data C1_0Unit instance Datatype D1Unit where datatypeName _ = "()" moduleName _ = "GHC.Tuple" instance Constructor C1_0Unit where conName _ = "()" ----- type Rep0Tuple2 a b = D1 D1Tuple2 (C1 C1_0Tuple2 (S1 NoSelector (Rec0 a) :*: S1 NoSelector (Rec0 b))) instance Generic (a, b) where type Rep (a, b) = Rep0Tuple2 a b from (a, b) = M1 (M1 (M1 (K1 a) :*: M1 (K1 b))) to (M1 (M1 (M1 (K1 a) :*: M1 (K1 b)))) = (a, b) ----- type Rep0Tuple3 a b c = D1 D1Tuple3 (C1 C1_0Tuple3 (S1 NoSelector (Rec0 a) :*: (S1 NoSelector (Rec0 b) :*: S1 NoSelector (Rec0 c)))) instance Generic (a, b, c) where type Rep (a, b, c) = Rep0Tuple3 a b c from (a, b, c) = M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c)))) to (M1 (M1 (M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))))) = (a, b, c) ----- type Rep0Tuple4 a b c d = D1 D1Tuple4 (C1 C1_0Tuple4 ((S1 NoSelector (Rec0 a) :*: S1 NoSelector (Rec0 b)) :*: (S1 NoSelector (Rec0 c) :*: S1 NoSelector (Rec0 d)))) instance Generic (a, b, c, d) where type Rep (a, b, c, d) = Rep0Tuple4 a b c d from (a, b, c, d) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) :*: (M1 (K1 c) :*: M1 (K1 d)))) to (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) :*: (M1 (K1 c) :*: M1 (K1 d))))) = (a, b, c, d) ----- type Rep0Tuple5 a b c d e = D1 D1Tuple5 (C1 C1_0Tuple5 ((S1 NoSelector (Rec0 a) :*: S1 NoSelector (Rec0 b)) :*: (S1 NoSelector (Rec0 c) :*: (S1 NoSelector (Rec0 d) :*: S1 NoSelector (Rec0 e))))) instance Generic (a, b, c, d, e) where type Rep (a, b, c, d, e) = Rep0Tuple5 a b c d e from (a, b, c, d, e) = M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (K1 e))))) to (M1 (M1 ((M1 (K1 a) :*: M1 (K1 b)) :*: (M1 (K1 c) :*: (M1 (K1 d) :*: M1 (K1 e)))))) = (a, b, c, d, e) ----- type Rep0Tuple6 a b c d e f = D1 D1Tuple6 (C1 C1_0Tuple6 ((S1 NoSelector (Rec0 a) :*: (S1 NoSelector (Rec0 b) :*: S1 NoSelector (Rec0 c))) :*: (S1 NoSelector (Rec0 d) :*: (S1 NoSelector (Rec0 e) :*: S1 NoSelector (Rec0 f))))) instance Generic (a, b, c, d, e, f) where type Rep (a, b, c, d, e, f) = Rep0Tuple6 a b c d e f from (a, b, c, d, e, f) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (K1 f))))) to (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) :*: (M1 (K1 d) :*: (M1 (K1 e) :*: M1 (K1 f)))))) = (a, b, c, d, e, f) ----- type Rep0Tuple7 a b c d e f g = D1 D1Tuple7 (C1 C1_0Tuple7 ((S1 NoSelector (Rec0 a) :*: (S1 NoSelector (Rec0 b) :*: S1 NoSelector (Rec0 c))) :*: ((S1 NoSelector (Rec0 d) :*: S1 NoSelector (Rec0 e)) :*: (S1 NoSelector (Rec0 f) :*: S1 NoSelector (Rec0 g))))) instance Generic (a, b, c, d, e, f, g) where type Rep (a, b, c, d, e, f, g) = Rep0Tuple7 a b c d e f g from (a, b, c, d, e, f, g) = M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (K1 g))))) to (M1 (M1 ((M1 (K1 a) :*: (M1 (K1 b) :*: M1 (K1 c))) :*: ((M1 (K1 d) :*: M1 (K1 e)) :*: (M1 (K1 f) :*: M1 (K1 g)))))) = (a, b, c, d, e, f, g) #endif generic-deriving-1.11.1/src/Generics/Deriving/Functor.hs0000644000000000000000000001142212765116253021263 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE Safe #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif module Generics.Deriving.Functor ( -- * Generic Functor class GFunctor(..) -- * Default method , gmapdefault -- * Internal Functor class , GFunctor'(..) ) where import Control.Applicative (Const, ZipList) import qualified Data.Monoid as Monoid (First, Last, Product, Sum) import Data.Monoid (Dual) import Generics.Deriving.Base #if MIN_VERSION_base(4,4,0) import Data.Complex (Complex) #endif #if MIN_VERSION_base(4,7,0) import Data.Proxy (Proxy) #endif #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity) import Data.Monoid (Alt) #endif #if MIN_VERSION_base(4,9,0) import qualified Data.Functor.Product as Functor (Product) import qualified Data.Functor.Sum as Functor (Sum) import Data.List.NonEmpty (NonEmpty) import qualified Data.Semigroup as Semigroup (First, Last) import Data.Semigroup (Arg, Max, Min, Option, WrappedMonoid) #endif -------------------------------------------------------------------------------- -- Generic fmap -------------------------------------------------------------------------------- class GFunctor' f where gmap' :: (a -> b) -> f a -> f b instance GFunctor' U1 where gmap' _ U1 = U1 instance GFunctor' Par1 where gmap' f (Par1 a) = Par1 (f a) instance GFunctor' (K1 i c) where gmap' _ (K1 a) = K1 a instance (GFunctor f) => GFunctor' (Rec1 f) where gmap' f (Rec1 a) = Rec1 (gmap f a) instance (GFunctor' f) => GFunctor' (M1 i c f) where gmap' f (M1 a) = M1 (gmap' f a) instance (GFunctor' f, GFunctor' g) => GFunctor' (f :+: g) where gmap' f (L1 a) = L1 (gmap' f a) gmap' f (R1 a) = R1 (gmap' f a) instance (GFunctor' f, GFunctor' g) => GFunctor' (f :*: g) where gmap' f (a :*: b) = gmap' f a :*: gmap' f b instance (GFunctor f, GFunctor' g) => GFunctor' (f :.: g) where gmap' f (Comp1 x) = Comp1 (gmap (gmap' f) x) instance GFunctor' UAddr where gmap' _ (UAddr a) = UAddr a instance GFunctor' UChar where gmap' _ (UChar c) = UChar c instance GFunctor' UDouble where gmap' _ (UDouble d) = UDouble d instance GFunctor' UFloat where gmap' _ (UFloat f) = UFloat f instance GFunctor' UInt where gmap' _ (UInt i) = UInt i instance GFunctor' UWord where gmap' _ (UWord w) = UWord w class GFunctor f where gmap :: (a -> b) -> f a -> f b #if __GLASGOW_HASKELL__ >= 701 default gmap :: (Generic1 f, GFunctor' (Rep1 f)) => (a -> b) -> f a -> f b gmap = gmapdefault #endif gmapdefault :: (Generic1 f, GFunctor' (Rep1 f)) => (a -> b) -> f a -> f b gmapdefault f = to1 . gmap' f . from1 -- Base types instances instance GFunctor ((->) r) where gmap = fmap instance GFunctor ((,) a) where gmap = gmapdefault instance GFunctor [] where gmap = gmapdefault #if MIN_VERSION_base(4,8,0) instance GFunctor f => GFunctor (Alt f) where gmap = gmapdefault #endif #if MIN_VERSION_base(4,9,0) instance GFunctor (Arg a) where gmap = gmapdefault #endif #if MIN_VERSION_base(4,4,0) instance GFunctor Complex where gmap = gmapdefault #endif instance GFunctor (Const m) where gmap = gmapdefault instance GFunctor Dual where gmap = gmapdefault instance GFunctor (Either a) where gmap = gmapdefault instance GFunctor Monoid.First where gmap = gmapdefault #if MIN_VERSION_base(4,9,0) instance GFunctor (Semigroup.First) where gmap = gmapdefault #endif #if MIN_VERSION_base(4,8,0) instance GFunctor Identity where gmap = gmapdefault #endif instance GFunctor IO where gmap = fmap instance GFunctor Monoid.Last where gmap = gmapdefault #if MIN_VERSION_base(4,9,0) instance GFunctor Semigroup.Last where gmap = gmapdefault instance GFunctor Max where gmap = gmapdefault #endif instance GFunctor Maybe where gmap = gmapdefault #if MIN_VERSION_base(4,9,0) instance GFunctor Min where gmap = gmapdefault instance GFunctor NonEmpty where gmap = gmapdefault instance GFunctor Option where gmap = gmapdefault #endif instance GFunctor Monoid.Product where gmap = gmapdefault #if MIN_VERSION_base(4,9,0) instance (GFunctor f, GFunctor g) => GFunctor (Functor.Product f g) where gmap = gmapdefault #endif #if MIN_VERSION_base(4,7,0) instance GFunctor Proxy where gmap = gmapdefault #endif instance GFunctor Monoid.Sum where gmap = gmapdefault #if MIN_VERSION_base(4,9,0) instance (GFunctor f, GFunctor g) => GFunctor (Functor.Sum f g) where gmap = gmapdefault instance GFunctor WrappedMonoid where gmap = gmapdefault #endif instance GFunctor ZipList where gmap = gmapdefault generic-deriving-1.11.1/src/Generics/Deriving/Foldable.hs0000644000000000000000000001721412765116253021360 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE Safe #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif module Generics.Deriving.Foldable ( -- * Generic Foldable class GFoldable(..) -- * Default method , gfoldMapdefault -- * Derived functions , gtoList , gconcat , gconcatMap , gand , gor , gany , gall , gsum , gproduct , gmaximum , gmaximumBy , gminimum , gminimumBy , gelem , gnotElem , gfind -- * Internal Foldable class , GFoldable'(..) ) where import Control.Applicative (Const, ZipList) import Data.Maybe import qualified Data.Monoid as Monoid (First, Last, Product(..), Sum(..)) import Data.Monoid (All(..), Any(..), Dual(..), Endo(..)) #if !(MIN_VERSION_base(4,8,0)) import Data.Monoid (Monoid(..)) #endif import Generics.Deriving.Base #if MIN_VERSION_base(4,4,0) import Data.Complex (Complex) #endif #if MIN_VERSION_base(4,7,0) import Data.Proxy (Proxy) #endif #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity) #endif #if MIN_VERSION_base(4,9,0) import qualified Data.Functor.Product as Functor (Product) import qualified Data.Functor.Sum as Functor (Sum) import Data.List.NonEmpty (NonEmpty) import qualified Data.Semigroup as Semigroup (First, Last) import Data.Semigroup (Arg, Max, Min, Option, WrappedMonoid) #endif -------------------------------------------------------------------------------- -- Generic fold -------------------------------------------------------------------------------- class GFoldable' t where gfoldMap' :: Monoid m => (a -> m) -> t a -> m instance GFoldable' U1 where gfoldMap' _ U1 = mempty instance GFoldable' Par1 where gfoldMap' f (Par1 a) = f a instance GFoldable' (K1 i c) where gfoldMap' _ (K1 _) = mempty instance (GFoldable f) => GFoldable' (Rec1 f) where gfoldMap' f (Rec1 a) = gfoldMap f a instance (GFoldable' f) => GFoldable' (M1 i c f) where gfoldMap' f (M1 a) = gfoldMap' f a instance (GFoldable' f, GFoldable' g) => GFoldable' (f :+: g) where gfoldMap' f (L1 a) = gfoldMap' f a gfoldMap' f (R1 a) = gfoldMap' f a instance (GFoldable' f, GFoldable' g) => GFoldable' (f :*: g) where gfoldMap' f (a :*: b) = mappend (gfoldMap' f a) (gfoldMap' f b) instance (GFoldable f, GFoldable' g) => GFoldable' (f :.: g) where gfoldMap' f (Comp1 x) = gfoldMap (gfoldMap' f) x instance GFoldable' UAddr where gfoldMap' _ (UAddr _) = mempty instance GFoldable' UChar where gfoldMap' _ (UChar _) = mempty instance GFoldable' UDouble where gfoldMap' _ (UDouble _) = mempty instance GFoldable' UFloat where gfoldMap' _ (UFloat _) = mempty instance GFoldable' UInt where gfoldMap' _ (UInt _) = mempty instance GFoldable' UWord where gfoldMap' _ (UWord _) = mempty class GFoldable t where gfoldMap :: Monoid m => (a -> m) -> t a -> m #if __GLASGOW_HASKELL__ >= 701 default gfoldMap :: (Generic1 t, GFoldable' (Rep1 t), Monoid m) => (a -> m) -> t a -> m gfoldMap = gfoldMapdefault #endif gfold :: Monoid m => t m -> m gfold = gfoldMap id gfoldr :: (a -> b -> b) -> b -> t a -> b gfoldr f z t = appEndo (gfoldMap (Endo . f) t) z gfoldr' :: (a -> b -> b) -> b -> t a -> b gfoldr' f z0 xs = gfoldl f' id xs z0 where f' k x z = k $! f x z gfoldl :: (a -> b -> a) -> a -> t b -> a gfoldl f z t = appEndo (getDual (gfoldMap (Dual . Endo . flip f) t)) z gfoldl' :: (a -> b -> a) -> a -> t b -> a gfoldl' f z0 xs = gfoldr f' id xs z0 where f' x k z = k $! f z x gfoldr1 :: (a -> a -> a) -> t a -> a gfoldr1 f xs = fromMaybe (error "gfoldr1: empty structure") (gfoldr mf Nothing xs) where mf x Nothing = Just x mf x (Just y) = Just (f x y) gfoldl1 :: (a -> a -> a) -> t a -> a gfoldl1 f xs = fromMaybe (error "foldl1: empty structure") (gfoldl mf Nothing xs) where mf Nothing y = Just y mf (Just x) y = Just (f x y) gfoldMapdefault :: (Generic1 t, GFoldable' (Rep1 t), Monoid m) => (a -> m) -> t a -> m gfoldMapdefault f x = gfoldMap' f (from1 x) -- Base types instances instance GFoldable ((,) a) where gfoldMap = gfoldMapdefault instance GFoldable [] where gfoldMap = gfoldMapdefault #if MIN_VERSION_base(4,9,0) instance GFoldable (Arg a) where gfoldMap = gfoldMapdefault #endif #if MIN_VERSION_base(4,4,0) instance GFoldable Complex where gfoldMap = gfoldMapdefault #endif instance GFoldable (Const m) where gfoldMap = gfoldMapdefault instance GFoldable Dual where gfoldMap = gfoldMapdefault instance GFoldable (Either a) where gfoldMap = gfoldMapdefault instance GFoldable Monoid.First where gfoldMap = gfoldMapdefault #if MIN_VERSION_base(4,9,0) instance GFoldable (Semigroup.First) where gfoldMap = gfoldMapdefault #endif #if MIN_VERSION_base(4,8,0) instance GFoldable Identity where gfoldMap = gfoldMapdefault #endif instance GFoldable Monoid.Last where gfoldMap = gfoldMapdefault #if MIN_VERSION_base(4,9,0) instance GFoldable Semigroup.Last where gfoldMap = gfoldMapdefault instance GFoldable Max where gfoldMap = gfoldMapdefault #endif instance GFoldable Maybe where gfoldMap = gfoldMapdefault #if MIN_VERSION_base(4,9,0) instance GFoldable Min where gfoldMap = gfoldMapdefault instance GFoldable NonEmpty where gfoldMap = gfoldMapdefault instance GFoldable Option where gfoldMap = gfoldMapdefault #endif instance GFoldable Monoid.Product where gfoldMap = gfoldMapdefault #if MIN_VERSION_base(4,9,0) instance (GFoldable f, GFoldable g) => GFoldable (Functor.Product f g) where gfoldMap = gfoldMapdefault #endif #if MIN_VERSION_base(4,7,0) instance GFoldable Proxy where gfoldMap = gfoldMapdefault #endif instance GFoldable Monoid.Sum where gfoldMap = gfoldMapdefault #if MIN_VERSION_base(4,9,0) instance (GFoldable f, GFoldable g) => GFoldable (Functor.Sum f g) where gfoldMap = gfoldMapdefault instance GFoldable WrappedMonoid where gfoldMap = gfoldMapdefault #endif instance GFoldable ZipList where gfoldMap = gfoldMapdefault gtoList :: GFoldable t => t a -> [a] gtoList = gfoldr (:) [] gconcat :: GFoldable t => t [a] -> [a] gconcat = gfold gconcatMap :: GFoldable t => (a -> [b]) -> t a -> [b] gconcatMap = gfoldMap gand :: GFoldable t => t Bool -> Bool gand = getAll . gfoldMap All gor :: GFoldable t => t Bool -> Bool gor = getAny . gfoldMap Any gany :: GFoldable t => (a -> Bool) -> t a -> Bool gany p = getAny . gfoldMap (Any . p) gall :: GFoldable t => (a -> Bool) -> t a -> Bool gall p = getAll . gfoldMap (All . p) gsum :: (GFoldable t, Num a) => t a -> a gsum = Monoid.getSum . gfoldMap Monoid.Sum gproduct :: (GFoldable t, Num a) => t a -> a gproduct = Monoid.getProduct . gfoldMap Monoid.Product gmaximum :: (GFoldable t, Ord a) => t a -> a gmaximum = gfoldr1 max gmaximumBy :: GFoldable t => (a -> a -> Ordering) -> t a -> a gmaximumBy cmp = gfoldr1 max' where max' x y = case cmp x y of GT -> x _ -> y gminimum :: (GFoldable t, Ord a) => t a -> a gminimum = gfoldr1 min gminimumBy :: GFoldable t => (a -> a -> Ordering) -> t a -> a gminimumBy cmp = gfoldr1 min' where min' x y = case cmp x y of GT -> y _ -> x gelem :: (GFoldable t, Eq a) => a -> t a -> Bool gelem = gany . (==) gnotElem :: (GFoldable t, Eq a) => a -> t a -> Bool gnotElem x = not . gelem x gfind :: GFoldable t => (a -> Bool) -> t a -> Maybe a gfind p = listToMaybe . gconcatMap (\ x -> if p x then [x] else []) generic-deriving-1.11.1/src/Generics/Deriving/Eq.hs0000644000000000000000000002515212765116253020215 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MagicHash #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif #include "HsBaseConfig.h" module Generics.Deriving.Eq ( -- * Generic Eq class GEq(..) -- * Default definition , geqdefault -- * Internal Eq class , GEq'(..) ) where import Control.Applicative (Const, ZipList) import Data.Char (GeneralCategory) import Data.Int import qualified Data.Monoid as Monoid (First, Last) import Data.Monoid (All, Any, Dual, Product, Sum) import Data.Version (Version) import Data.Word import Foreign.C.Error import Foreign.C.Types import Foreign.ForeignPtr (ForeignPtr) import Foreign.Ptr import Foreign.StablePtr (StablePtr) import Generics.Deriving.Base import GHC.Exts hiding (Any) import System.Exit (ExitCode) import System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode) import System.IO.Error (IOErrorType) import System.Posix.Types #if MIN_VERSION_base(4,4,0) import Data.Complex (Complex) #endif #if MIN_VERSION_base(4,7,0) import Data.Proxy (Proxy) #endif #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity) import Data.Monoid (Alt) import Data.Void (Void) import Numeric.Natural (Natural) #endif #if MIN_VERSION_base(4,9,0) import Data.List.NonEmpty (NonEmpty) import qualified Data.Semigroup as Semigroup (First, Last) import Data.Semigroup (Arg(..), Max, Min, Option, WrappedMonoid) #endif -------------------------------------------------------------------------------- -- Generic show -------------------------------------------------------------------------------- class GEq' f where geq' :: f a -> f a -> Bool instance GEq' U1 where geq' _ _ = True instance (GEq c) => GEq' (K1 i c) where geq' (K1 a) (K1 b) = geq a b -- No instances for P or Rec because geq is only applicable to types of kind * instance (GEq' a) => GEq' (M1 i c a) where geq' (M1 a) (M1 b) = geq' a b instance (GEq' a, GEq' b) => GEq' (a :+: b) where geq' (L1 a) (L1 b) = geq' a b geq' (R1 a) (R1 b) = geq' a b geq' _ _ = False instance (GEq' a, GEq' b) => GEq' (a :*: b) where geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2 -- Unboxed types instance GEq' UAddr where geq' (UAddr a1) (UAddr a2) = isTrue# (eqAddr# a1 a2) instance GEq' UChar where geq' (UChar c1) (UChar c2) = isTrue# (eqChar# c1 c2) instance GEq' UDouble where geq' (UDouble d1) (UDouble d2) = isTrue# (d1 ==## d2) instance GEq' UFloat where geq' (UFloat f1) (UFloat f2) = isTrue# (eqFloat# f1 f2) instance GEq' UInt where geq' (UInt i1) (UInt i2) = isTrue# (i1 ==# i2) instance GEq' UWord where geq' (UWord w1) (UWord w2) = isTrue# (eqWord# w1 w2) #if !(MIN_VERSION_base(4,7,0)) isTrue# :: Bool -> Bool isTrue# = id #endif class GEq a where geq :: a -> a -> Bool #if __GLASGOW_HASKELL__ >= 701 default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool geq = geqdefault #endif geqdefault :: (Generic a, GEq' (Rep a)) => a -> a -> Bool geqdefault x y = geq' (from x) (from y) -- Base types instances instance GEq () where geq = geqdefault instance (GEq a, GEq b) => GEq (a, b) where geq = geqdefault instance (GEq a, GEq b, GEq c) => GEq (a, b, c) where geq = geqdefault instance (GEq a, GEq b, GEq c, GEq d) => GEq (a, b, c, d) where geq = geqdefault instance (GEq a, GEq b, GEq c, GEq d, GEq e) => GEq (a, b, c, d, e) where geq = geqdefault instance (GEq a, GEq b, GEq c, GEq d, GEq e, GEq f) => GEq (a, b, c, d, e, f) where geq = geqdefault instance (GEq a, GEq b, GEq c, GEq d, GEq e, GEq f, GEq g) => GEq (a, b, c, d, e, f, g) where geq = geqdefault instance GEq a => GEq [a] where geq = geqdefault instance (GEq (f p), GEq (g p)) => GEq ((f :+: g) p) where geq = geqdefault instance (GEq (f p), GEq (g p)) => GEq ((f :*: g) p) where geq = geqdefault instance GEq (f (g p)) => GEq ((f :.: g) p) where geq = geqdefault instance GEq All where geq = geqdefault #if MIN_VERSION_base(4,8,0) instance GEq (f a) => GEq (Alt f a) where geq = geqdefault #endif instance GEq Any where geq = geqdefault #if !(MIN_VERSION_base(4,9,0)) instance GEq Arity where geq = geqdefault #endif #if MIN_VERSION_base(4,9,0) instance GEq a => GEq (Arg a b) where geq (Arg a _) (Arg b _) = geq a b #endif instance GEq Associativity where geq = geqdefault instance GEq Bool where geq = geqdefault instance GEq BufferMode where geq = (==) #if defined(HTYPE_CC_T) instance GEq CCc where geq = (==) #endif instance GEq CChar where geq = (==) instance GEq CClock where geq = (==) #if defined(HTYPE_DEV_T) instance GEq CDev where geq = (==) #endif instance GEq CDouble where geq = (==) instance GEq CFloat where geq = (==) #if defined(HTYPE_GID_T) instance GEq CGid where geq = (==) #endif instance GEq Char where geq = (==) #if defined(HTYPE_INO_T) instance GEq CIno where geq = (==) #endif instance GEq CInt where geq = (==) instance GEq CIntMax where geq = (==) instance GEq CIntPtr where geq = (==) instance GEq CLLong where geq = (==) instance GEq CLong where geq = (==) #if defined(HTYPE_MODE_T) instance GEq CMode where geq = (==) #endif #if defined(HTYPE_NLINK_T) instance GEq CNlink where geq = (==) #endif #if defined(HTYPE_OFF_T) instance GEq COff where geq = (==) #endif #if MIN_VERSION_base(4,4,0) instance GEq a => GEq (Complex a) where geq = geqdefault #endif instance GEq a => GEq (Const a b) where geq = geqdefault #if defined(HTYPE_PID_T) instance GEq CPid where geq = (==) #endif instance GEq CPtrdiff where geq = (==) #if defined(HTYPE_RLIM_T) instance GEq CRLim where geq = (==) #endif instance GEq CSChar where geq = (==) #if defined(HTYPE_SPEED_T) instance GEq CSpeed where geq = (==) #endif #if MIN_VERSION_base(4,4,0) instance GEq CSUSeconds where geq = (==) #endif instance GEq CShort where geq = (==) instance GEq CSigAtomic where geq = (==) instance GEq CSize where geq = (==) #if defined(HTYPE_SSIZE_T) instance GEq CSsize where geq = (==) #endif #if defined(HTYPE_TCFLAG_T) instance GEq CTcflag where geq = (==) #endif instance GEq CTime where geq = (==) instance GEq CUChar where geq = (==) #if defined(HTYPE_UID_T) instance GEq CUid where geq = (==) #endif instance GEq CUInt where geq = (==) instance GEq CUIntMax where geq = (==) instance GEq CUIntPtr where geq = (==) instance GEq CULLong where geq = (==) instance GEq CULong where geq = (==) #if MIN_VERSION_base(4,4,0) instance GEq CUSeconds where geq = (==) #endif instance GEq CUShort where geq = (==) instance GEq CWchar where geq = (==) #if MIN_VERSION_base(4,9,0) instance GEq DecidedStrictness where geq = geqdefault #endif instance GEq Double where geq = (==) instance GEq a => GEq (Dual a) where geq = geqdefault instance (GEq a, GEq b) => GEq (Either a b) where geq = geqdefault instance GEq Errno where geq = (==) instance GEq ExitCode where geq = geqdefault instance GEq Fd where geq = (==) instance GEq a => GEq (Monoid.First a) where geq = geqdefault #if MIN_VERSION_base(4,9,0) instance GEq a => GEq (Semigroup.First a) where geq = geqdefault #endif instance GEq Fixity where geq = geqdefault instance GEq Float where geq = (==) instance GEq (ForeignPtr a) where geq = (==) instance GEq (FunPtr a) where geq = (==) instance GEq GeneralCategory where geq = (==) instance GEq Handle where geq = (==) instance GEq HandlePosn where geq = (==) #if MIN_VERSION_base(4,8,0) instance GEq a => GEq (Identity a) where geq = geqdefault #endif instance GEq Int where geq = (==) instance GEq Int8 where geq = (==) instance GEq Int16 where geq = (==) instance GEq Int32 where geq = (==) instance GEq Int64 where geq = (==) instance GEq Integer where geq = (==) instance GEq IntPtr where geq = (==) instance GEq IOError where geq = (==) instance GEq IOErrorType where geq = (==) instance GEq IOMode where geq = (==) instance GEq c => GEq (K1 i c p) where geq = geqdefault instance GEq a => GEq (Monoid.Last a) where geq = geqdefault #if MIN_VERSION_base(4,9,0) instance GEq a => GEq (Semigroup.Last a) where geq = geqdefault #endif instance GEq (f p) => GEq (M1 i c f p) where geq = geqdefault instance GEq a => GEq (Maybe a) where geq = geqdefault #if MIN_VERSION_base(4,9,0) instance GEq a => GEq (Max a) where geq = geqdefault instance GEq a => GEq (Min a) where geq = geqdefault #endif #if MIN_VERSION_base(4,8,0) instance GEq Natural where geq = (==) #endif #if MIN_VERSION_base(4,9,0) instance GEq a => GEq (NonEmpty a) where geq = geqdefault instance GEq a => GEq (Option a) where geq = geqdefault #endif instance GEq Ordering where geq = geqdefault instance GEq p => GEq (Par1 p) where geq = geqdefault instance GEq a => GEq (Product a) where geq = geqdefault #if MIN_VERSION_base(4,7,0) instance GEq # if MIN_VERSION_base(4,9,0) (Proxy s) # else (Proxy (s :: *)) # endif where geq = geqdefault #endif instance GEq (Ptr a) where geq = (==) instance GEq (f p) => GEq (Rec1 f p) where geq = geqdefault instance GEq SeekMode where geq = (==) instance GEq (StablePtr a) where geq = (==) #if MIN_VERSION_base(4,9,0) instance GEq SourceStrictness where geq = geqdefault instance GEq SourceUnpackedness where geq = geqdefault #endif instance GEq a => GEq (Sum a) where geq = geqdefault instance GEq (U1 p) where geq = geqdefault instance GEq (UAddr p) where geq = geqdefault instance GEq (UChar p) where geq = geqdefault instance GEq (UDouble p) where geq = geqdefault instance GEq (UFloat p) where geq = geqdefault instance GEq (UInt p) where geq = geqdefault instance GEq (UWord p) where geq = geqdefault instance GEq Version where geq = (==) #if MIN_VERSION_base(4,8,0) instance GEq Void where geq = (==) #endif instance GEq Word where geq = (==) instance GEq Word8 where geq = (==) instance GEq Word16 where geq = (==) instance GEq Word32 where geq = (==) instance GEq Word64 where geq = (==) instance GEq WordPtr where geq = (==) #if MIN_VERSION_base(4,9,0) instance GEq m => GEq (WrappedMonoid m) where geq = geqdefault #endif instance GEq a => GEq (ZipList a) where geq = geqdefault generic-deriving-1.11.1/src/Generics/Deriving/Enum.hs0000644000000000000000000006135312765116253020557 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE Trustworthy #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif #include "HsBaseConfig.h" module Generics.Deriving.Enum ( -- * Generic enum class GEnum(..) -- * Default definitions for GEnum , genumDefault, toEnumDefault, fromEnumDefault -- * Internal enum class , Enum'(..) -- * Generic Ix class , GIx(..) -- * Default definitions for GIx , rangeDefault, indexDefault, inRangeDefault ) where import Control.Applicative (Const, ZipList) import Data.Int import Data.Monoid (All, Any, Dual, Product, Sum) import qualified Data.Monoid as Monoid (First, Last) import Data.Word import Foreign.C.Types import Foreign.Ptr import Generics.Deriving.Base import Generics.Deriving.Eq import System.Exit (ExitCode) import System.Posix.Types #if MIN_VERSION_base(4,4,0) import Data.Complex (Complex) #endif #if MIN_VERSION_base(4,7,0) import Data.Coerce (coerce) import Data.Proxy (Proxy) #else import Unsafe.Coerce (unsafeCoerce) #endif #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity) import Data.Monoid (Alt) import Numeric.Natural (Natural) #endif #if MIN_VERSION_base(4,9,0) import Data.List.NonEmpty (NonEmpty) import qualified Data.Semigroup as Semigroup (First, Last) import Data.Semigroup (Arg, Max, Min, Option, WrappedMonoid) #endif ----------------------------------------------------------------------------- -- Utility functions for Enum' ----------------------------------------------------------------------------- infixr 5 ||| -- | Interleave elements from two lists. Similar to (++), but swap left and -- right arguments on every recursive application. -- -- From Mark Jones' talk at AFP2008 (|||) :: [a] -> [a] -> [a] [] ||| ys = ys (x:xs) ||| ys = x : ys ||| xs -- | Diagonalization of nested lists. Ensure that some elements from every -- sublist will be included. Handles infinite sublists. -- -- From Mark Jones' talk at AFP2008 diag :: [[a]] -> [a] diag = concat . foldr skew [] . map (map (\x -> [x])) skew :: [[a]] -> [[a]] -> [[a]] skew [] ys = ys skew (x:xs) ys = x : combine (++) xs ys combine :: (a -> a -> a) -> [a] -> [a] -> [a] combine _ xs [] = xs combine _ [] ys = ys combine f (x:xs) (y:ys) = f x y : combine f xs ys findIndex :: (a -> Bool) -> [a] -> Maybe Int findIndex p xs = let l = [ i | (y,i) <- zip xs [(0::Int)..], p y] in if (null l) then Nothing else Just (head l) -------------------------------------------------------------------------------- -- Generic enum -------------------------------------------------------------------------------- class Enum' f where enum' :: [f a] instance Enum' U1 where enum' = [U1] instance (GEnum c) => Enum' (K1 i c) where enum' = map K1 genum instance (Enum' f) => Enum' (M1 i c f) where enum' = map M1 enum' instance (Enum' f, Enum' g) => Enum' (f :+: g) where enum' = map L1 enum' ||| map R1 enum' instance (Enum' f, Enum' g) => Enum' (f :*: g) where enum' = diag [ [ x :*: y | y <- enum' ] | x <- enum' ] genumDefault :: (Generic a, Enum' (Rep a)) => [a] genumDefault = map to enum' toEnumDefault :: (Generic a, Enum' (Rep a)) => Int -> a toEnumDefault i = let l = enum' in if (length l > i) then to (l !! i) else error "toEnum: invalid index" fromEnumDefault :: (GEq a, Generic a, Enum' (Rep a)) => a -> Int fromEnumDefault x = case findIndex (geq x) (map to enum') of Nothing -> error "fromEnum: no corresponding index" Just i -> i class GEnum a where genum :: [a] #if __GLASGOW_HASKELL__ >= 701 default genum :: (Generic a, Enum' (Rep a)) => [a] genum = genumDefault #endif genumNumUnbounded :: Num a => [a] genumNumUnbounded = pos 0 ||| neg 0 where pos n = n : pos (n + 1) neg n = (n-1) : neg (n - 1) genumNumSigned :: (Bounded a, Enum a, Num a) => [a] genumNumSigned = [0 .. maxBound] ||| [-1, -2 .. minBound] genumNumUnsigned :: (Enum a, Num a) => [a] genumNumUnsigned = [0 ..] #if !(MIN_VERSION_base(4,7,0)) coerce :: a -> b coerce = unsafeCoerce #endif -- Base types instances instance GEnum () where genum = genumDefault instance (GEnum a, GEnum b) => GEnum (a, b) where genum = genumDefault instance (GEnum a, GEnum b, GEnum c) => GEnum (a, b, c) where genum = genumDefault instance (GEnum a, GEnum b, GEnum c, GEnum d) => GEnum (a, b, c, d) where genum = genumDefault instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e) => GEnum (a, b, c, d, e) where genum = genumDefault instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f) => GEnum (a, b, c, d, e, f) where genum = genumDefault instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f, GEnum g) => GEnum (a, b, c, d, e, f, g) where genum = genumDefault instance GEnum a => GEnum [a] where genum = genumDefault instance (GEnum (f p), GEnum (g p)) => GEnum ((f :+: g) p) where genum = genumDefault instance (GEnum (f p), GEnum (g p)) => GEnum ((f :*: g) p) where genum = genumDefault instance GEnum (f (g p)) => GEnum ((f :.: g) p) where genum = genumDefault instance GEnum All where genum = genumDefault #if MIN_VERSION_base(4,8,0) instance GEnum (f a) => GEnum (Alt f a) where genum = genumDefault #endif instance GEnum Any where genum = genumDefault #if MIN_VERSION_base(4,9,0) instance (GEnum a, GEnum b) => GEnum (Arg a b) where genum = genumDefault #endif #if !(MIN_VERSION_base(4,9,0)) instance GEnum Arity where genum = genumDefault #endif instance GEnum Associativity where genum = genumDefault instance GEnum Bool where genum = genumDefault #if defined(HTYPE_CC_T) instance GEnum CCc where genum = coerce (genum :: [HTYPE_CC_T]) #endif instance GEnum CChar where genum = coerce (genum :: [HTYPE_CHAR]) instance GEnum CClock where genum = coerce (genum :: [HTYPE_CLOCK_T]) #if defined(HTYPE_DEV_T) instance GEnum CDev where genum = coerce (genum :: [HTYPE_DEV_T]) #endif instance GEnum CDouble where genum = coerce (genum :: [HTYPE_DOUBLE]) instance GEnum CFloat where genum = coerce (genum :: [HTYPE_FLOAT]) #if defined(HTYPE_GID_T) instance GEnum CGid where genum = coerce (genum :: [HTYPE_GID_T]) #endif #if defined(HTYPE_INO_T) instance GEnum CIno where genum = coerce (genum :: [HTYPE_INO_T]) #endif instance GEnum CInt where genum = coerce (genum :: [HTYPE_INT]) instance GEnum CIntMax where genum = coerce (genum :: [HTYPE_INTMAX_T]) instance GEnum CIntPtr where genum = coerce (genum :: [HTYPE_INTPTR_T]) instance GEnum CLLong where genum = coerce (genum :: [HTYPE_LONG_LONG]) instance GEnum CLong where genum = coerce (genum :: [HTYPE_LONG]) #if defined(HTYPE_MODE_T) instance GEnum CMode where genum = coerce (genum :: [HTYPE_MODE_T]) #endif #if defined(HTYPE_NLINK_T) instance GEnum CNlink where genum = coerce (genum :: [HTYPE_NLINK_T]) #endif #if defined(HTYPE_OFF_T) instance GEnum COff where genum = coerce (genum :: [HTYPE_OFF_T]) #endif #if MIN_VERSION_base(4,4,0) instance GEnum a => GEnum (Complex a) where genum = genumDefault #endif instance GEnum a => GEnum (Const a b) where genum = genumDefault #if defined(HTYPE_PID_T) instance GEnum CPid where genum = coerce (genum :: [HTYPE_PID_T]) #endif instance GEnum CPtrdiff where genum = coerce (genum :: [HTYPE_PTRDIFF_T]) #if defined(HTYPE_RLIM_T) instance GEnum CRLim where genum = coerce (genum :: [HTYPE_RLIM_T]) #endif instance GEnum CSChar where genum = coerce (genum :: [HTYPE_SIGNED_CHAR]) #if defined(HTYPE_SPEED_T) instance GEnum CSpeed where genum = coerce (genum :: [HTYPE_SPEED_T]) #endif #if MIN_VERSION_base(4,4,0) instance GEnum CSUSeconds where genum = coerce (genum :: [HTYPE_SUSECONDS_T]) #endif instance GEnum CShort where genum = coerce (genum :: [HTYPE_SHORT]) instance GEnum CSigAtomic where genum = coerce (genum :: [HTYPE_SIG_ATOMIC_T]) instance GEnum CSize where genum = coerce (genum :: [HTYPE_SIZE_T]) #if defined(HTYPE_SSIZE_T) instance GEnum CSsize where genum = coerce (genum :: [HTYPE_SSIZE_T]) #endif #if defined(HTYPE_TCFLAG_T) instance GEnum CTcflag where genum = coerce (genum :: [HTYPE_TCFLAG_T]) #endif instance GEnum CTime where genum = coerce (genum :: [HTYPE_TIME_T]) instance GEnum CUChar where genum = coerce (genum :: [HTYPE_UNSIGNED_CHAR]) #if defined(HTYPE_UID_T) instance GEnum CUid where genum = coerce (genum :: [HTYPE_UID_T]) #endif instance GEnum CUInt where genum = coerce (genum :: [HTYPE_UNSIGNED_INT]) instance GEnum CUIntMax where genum = coerce (genum :: [HTYPE_UINTMAX_T]) instance GEnum CUIntPtr where genum = coerce (genum :: [HTYPE_UINTPTR_T]) instance GEnum CULLong where genum = coerce (genum :: [HTYPE_UNSIGNED_LONG_LONG]) instance GEnum CULong where genum = coerce (genum :: [HTYPE_UNSIGNED_LONG]) #if MIN_VERSION_base(4,4,0) instance GEnum CUSeconds where genum = coerce (genum :: [HTYPE_USECONDS_T]) #endif instance GEnum CUShort where genum = coerce (genum :: [HTYPE_UNSIGNED_SHORT]) instance GEnum CWchar where genum = coerce (genum :: [HTYPE_WCHAR_T]) instance GEnum Double where genum = genumNumUnbounded instance GEnum a => GEnum (Dual a) where genum = genumDefault instance (GEnum a, GEnum b) => GEnum (Either a b) where genum = genumDefault instance GEnum ExitCode where genum = genumDefault instance GEnum Fd where genum = coerce (genum :: [CInt]) instance GEnum a => GEnum (Monoid.First a) where genum = genumDefault #if MIN_VERSION_base(4,9,0) instance GEnum a => GEnum (Semigroup.First a) where genum = genumDefault #endif instance GEnum Fixity where genum = genumDefault instance GEnum Float where genum = genumNumUnbounded #if MIN_VERSION_base(4,8,0) instance GEnum a => GEnum (Identity a) where genum = genumDefault #endif instance GEnum Int where genum = genumNumSigned instance GEnum Int8 where genum = genumNumSigned instance GEnum Int16 where genum = genumNumSigned instance GEnum Int32 where genum = genumNumSigned instance GEnum Int64 where genum = genumNumSigned instance GEnum Integer where genum = genumNumUnbounded instance GEnum IntPtr where genum = genumNumSigned instance GEnum c => GEnum (K1 i c p) where genum = genumDefault instance GEnum a => GEnum (Monoid.Last a) where genum = genumDefault #if MIN_VERSION_base(4,9,0) instance GEnum a => GEnum (Semigroup.Last a) where genum = genumDefault #endif instance GEnum (f p) => GEnum (M1 i c f p) where genum = genumDefault #if MIN_VERSION_base(4,9,0) instance GEnum a => GEnum (Max a) where genum = genumDefault #endif instance GEnum a => GEnum (Maybe a) where genum = genumDefault #if MIN_VERSION_base(4,9,0) instance GEnum a => GEnum (Min a) where genum = genumDefault #endif #if MIN_VERSION_base(4,8,0) instance GEnum Natural where genum = genumNumUnsigned #endif #if MIN_VERSION_base(4,9,0) instance GEnum a => GEnum (NonEmpty a) where genum = genumDefault instance GEnum a => GEnum (Option a) where genum = genumDefault #endif instance GEnum Ordering where genum = genumDefault instance GEnum p => GEnum (Par1 p) where genum = genumDefault instance GEnum a => GEnum (Product a) where genum = genumDefault #if MIN_VERSION_base(4,7,0) instance GEnum # if MIN_VERSION_base(4,9,0) (Proxy s) # else (Proxy (s :: *)) # endif 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 = genumNumUnsigned instance GEnum Word8 where genum = genumNumUnsigned instance GEnum Word16 where genum = genumNumUnsigned instance GEnum Word32 where genum = genumNumUnsigned instance GEnum Word64 where genum = genumNumUnsigned instance GEnum WordPtr where genum = genumNumUnsigned #if MIN_VERSION_base(4,9,0) instance GEnum m => GEnum (WrappedMonoid m) where genum = genumDefault #endif instance GEnum a => GEnum (ZipList a) where genum = genumDefault -------------------------------------------------------------------------------- -- Generic Ix -------------------------------------------------------------------------------- -- Minimal complete instance: 'range', 'index' and 'inRange'. class (Ord a) => GIx a where -- | The list of values in the subrange defined by a bounding pair. range :: (a,a) -> [a] -- | The position of a subscript in the subrange. index :: (a,a) -> a -> Int -- | Returns 'True' the given subscript lies in the range defined -- the bounding pair. inRange :: (a,a) -> a -> Bool #if __GLASGOW_HASKELL__ >= 701 default range :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> [a] range = rangeDefault default index :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Int index = indexDefault default inRange :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Bool inRange = inRangeDefault #endif rangeDefault :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> [a] rangeDefault = t (map to enum') where t l (x,y) = case (findIndex (geq x) l, findIndex (geq y) l) of (Nothing, _) -> error "rangeDefault: no corresponding index" (_, Nothing) -> error "rangeDefault: no corresponding index" (Just i, Just j) -> take (j-i) (drop i l) indexDefault :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Int indexDefault = t (map to enum') where t l (x,y) z = case (findIndex (geq x) l, findIndex (geq y) l) of (Nothing, _) -> error "indexDefault: no corresponding index" (_, Nothing) -> error "indexDefault: no corresponding index" (Just i, Just j) -> case findIndex (geq z) (take (j-i) (drop i l)) of Nothing -> error "indexDefault: index out of range" Just k -> k inRangeDefault :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Bool inRangeDefault = t (map to enum') where t l (x,y) z = case (findIndex (geq x) l, findIndex (geq y) l) of (Nothing, _) -> error "indexDefault: no corresponding index" (_, Nothing) -> error "indexDefault: no corresponding index" (Just i, Just j) -> maybe False (const True) (findIndex (geq z) (take (j-i) (drop i l))) rangeEnum :: Enum a => (a, a) -> [a] rangeEnum (m,n) = [m..n] indexIntegral :: Integral a => (a, a) -> a -> Int indexIntegral (m,_n) i = fromIntegral (i - m) inRangeOrd :: Ord a => (a, a) -> a -> Bool inRangeOrd (m,n) i = m <= i && i <= n -- Base types instances instance GIx () where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (a, b) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c) => GIx (a, b, c) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, GEq d, GEnum d, GIx d) => GIx (a, b, c, d) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e) => GIx (a, b, c, d, e) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f) => GIx (a, b, c, d, e, f) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c, GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f, GEq g, GEnum g, GIx g) => GIx (a, b, c, d, e, f, g) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a) => GIx [a] where range = rangeDefault index = indexDefault inRange = inRangeDefault instance GIx All where range = rangeDefault index = indexDefault inRange = inRangeDefault #if MIN_VERSION_base(4,8,0) instance (GEq (f a), GEnum (f a), GIx (f a)) => GIx (Alt f a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif instance GIx Any where range = rangeDefault index = indexDefault inRange = inRangeDefault #if MIN_VERSION_base(4,9,0) instance (GEq a, GEnum a, GIx a, GEnum b) => GIx (Arg a b) where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif #if !(MIN_VERSION_base(4,9,0)) instance GIx Arity where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif instance GIx Associativity where range = rangeDefault index = indexDefault inRange = inRangeDefault instance GIx Bool where range = rangeDefault index = indexDefault inRange = inRangeDefault instance GIx CChar where range = rangeEnum index = indexIntegral inRange = inRangeOrd #if defined(HTYPE_GID_T) instance GIx CGid where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif #if defined(HTYPE_INO_T) instance GIx CIno where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif instance GIx CInt where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CIntMax where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CIntPtr where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CLLong where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CLong where range = rangeEnum index = indexIntegral inRange = inRangeOrd #if defined(HTYPE_MODE_T) instance GIx CMode where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif #if defined(HTYPE_NLINK_T) instance GIx CNlink where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif #if defined(HTYPE_OFF_T) instance GIx COff where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif #if defined(HTYPE_PID_T) instance GIx CPid where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif instance GIx CPtrdiff where range = rangeEnum index = indexIntegral inRange = inRangeOrd #if defined(HTYPE_RLIM_T) instance GIx CRLim where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif instance GIx CSChar where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CShort where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CSigAtomic where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CSize where range = rangeEnum index = indexIntegral inRange = inRangeOrd #if defined(HTYPE_SSIZE_T) instance GIx CSsize where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif #if defined(HTYPE_TCFLAG_T) instance GIx CTcflag where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif instance GIx CUChar where range = rangeEnum index = indexIntegral inRange = inRangeOrd #if defined(HTYPE_UID_T) instance GIx CUid where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif instance GIx CUInt where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CUIntMax where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CUIntPtr where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CULLong where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CULong where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CUShort where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx CWchar where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance (GEq a, GEnum a, GIx a) => GIx (Dual a) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (Either a b) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance GIx ExitCode where range = rangeDefault index = indexDefault inRange = inRangeDefault instance GIx Fd where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance (GEq a, GEnum a, GIx a) => GIx (Monoid.First a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #if MIN_VERSION_base(4,9,0) instance (GEq a, GEnum a, GIx a) => GIx (Semigroup.First a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif instance GIx Fixity where range = rangeDefault index = indexDefault inRange = inRangeDefault #if MIN_VERSION_base(4,8,0) instance (GEq a, GEnum a, GIx a) => GIx (Identity a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif instance GIx Int where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx Int8 where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx Int16 where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx Int32 where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx Int64 where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx Integer where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx IntPtr where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance (GEq a, GEnum a, GIx a) => GIx (Monoid.Last a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #if MIN_VERSION_base(4,9,0) instance (GEq a, GEnum a, GIx a) => GIx (Semigroup.Last a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif #if MIN_VERSION_base(4,9,0) instance (GEq a, GEnum a, GIx a) => GIx (Max a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif instance (GEq a, GEnum a, GIx a) => GIx (Maybe a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #if MIN_VERSION_base(4,9,0) instance (GEq a, GEnum a, GIx a) => GIx (Min a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif #if MIN_VERSION_base(4,8,0) instance GIx Natural where range = rangeEnum index = indexIntegral inRange = inRangeOrd #endif #if MIN_VERSION_base(4,9,0) instance (GEq a, GEnum a, GIx a) => GIx (NonEmpty a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif #if MIN_VERSION_base(4,9,0) instance (GEq a, GEnum a, GIx a) => GIx (Option a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif instance GIx Ordering where range = rangeDefault index = indexDefault inRange = inRangeDefault instance (GEq a, GEnum a, GIx a) => GIx (Product a) where range = rangeDefault index = indexDefault inRange = inRangeDefault #if MIN_VERSION_base(4,7,0) instance GIx # if MIN_VERSION_base(4,9,0) (Proxy s) # else (Proxy (s :: *)) # endif where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif instance (GEq a, GEnum a, GIx a) => GIx (Sum a) where range = rangeDefault index = indexDefault inRange = inRangeDefault instance GIx Word where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx Word8 where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx Word16 where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx Word32 where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx Word64 where range = rangeEnum index = indexIntegral inRange = inRangeOrd instance GIx WordPtr where range = rangeEnum index = indexIntegral inRange = inRangeOrd #if MIN_VERSION_base(4,9,0) instance (GEq m, GEnum m, GIx m) => GIx (WrappedMonoid m) where range = rangeDefault index = indexDefault inRange = inRangeDefault #endif generic-deriving-1.11.1/src/Generics/Deriving/Copoint.hs0000644000000000000000000000765612765116253021274 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeOperators #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE Safe #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif module Generics.Deriving.Copoint ( -- * GCopoint class GCopoint(..) -- * Default method , gcopointdefault -- * Internal class , GCopoint'(..) ) where import Control.Applicative (WrappedMonad) import Data.Monoid (Dual) import qualified Data.Monoid as Monoid (Sum) import Generics.Deriving.Base #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity) import Data.Monoid (Alt) #endif #if MIN_VERSION_base(4,9,0) import qualified Data.Functor.Sum as Functor (Sum) import Data.Semigroup (Arg, First, Last, Max, Min, WrappedMonoid) #endif -------------------------------------------------------------------------------- -- Generic copoint -------------------------------------------------------------------------------- -- General copoint may return 'Nothing' class GCopoint' t where gcopoint' :: t a -> Maybe a instance GCopoint' U1 where gcopoint' U1 = Nothing instance GCopoint' Par1 where gcopoint' (Par1 a) = Just a instance GCopoint' (K1 i c) where gcopoint' _ = Nothing instance GCopoint' f => GCopoint' (M1 i c f) where gcopoint' (M1 a) = gcopoint' a instance (GCopoint' f, GCopoint' g) => GCopoint' (f :+: g) where gcopoint' (L1 a) = gcopoint' a gcopoint' (R1 a) = gcopoint' a -- Favours left "hole" for copoint instance (GCopoint' f, GCopoint' g) => GCopoint' (f :*: g) where gcopoint' (a :*: b) = case (gcopoint' a) of Just x -> Just x Nothing -> gcopoint' b instance (GCopoint f) => GCopoint' (Rec1 f) where gcopoint' (Rec1 a) = Just $ gcopoint a instance (GCopoint f, GCopoint' g) => GCopoint' (f :.: g) where gcopoint' (Comp1 x) = gcopoint' . gcopoint $ x class GCopoint d where gcopoint :: d a -> a #if __GLASGOW_HASKELL__ >= 701 default gcopoint :: (Generic1 d, GCopoint' (Rep1 d)) => (d a -> a) gcopoint = gcopointdefault #endif gcopointdefault :: (Generic1 d, GCopoint' (Rep1 d)) => d a -> a gcopointdefault x = case (gcopoint' . from1 $ x) of Just x' -> x' Nothing -> error "Data type is not copointed" -- instance (Generic1 d, GCopoint' (Rep1 d)) => GCopoint d -- Base types instances instance GCopoint ((,) a) where gcopoint = gcopointdefault instance GCopoint ((,,) a b) where gcopoint = gcopointdefault instance GCopoint ((,,,) a b c) where gcopoint = gcopointdefault instance GCopoint ((,,,,) a b c d) where gcopoint = gcopointdefault instance GCopoint ((,,,,,) a b c d e) where gcopoint = gcopointdefault instance GCopoint ((,,,,,,) a b c d e f) where gcopoint = gcopointdefault #if MIN_VERSION_base(4,8,0) instance GCopoint f => GCopoint (Alt f) where gcopoint = gcopointdefault #endif #if MIN_VERSION_base(4,9,0) instance GCopoint (Arg a) where gcopoint = gcopointdefault #endif instance GCopoint Dual where gcopoint = gcopointdefault #if MIN_VERSION_base(4,9,0) instance GCopoint First where gcopoint = gcopointdefault #endif #if MIN_VERSION_base(4,8,0) instance GCopoint Identity where gcopoint = gcopointdefault #endif #if MIN_VERSION_base(4,9,0) instance GCopoint Last where gcopoint = gcopointdefault instance GCopoint Max where gcopoint = gcopointdefault instance GCopoint Min where gcopoint = gcopointdefault instance (GCopoint f, GCopoint g) => GCopoint (Functor.Sum f g) where gcopoint = gcopointdefault #endif instance GCopoint Monoid.Sum where gcopoint = gcopointdefault instance GCopoint m => GCopoint (WrappedMonad m) where gcopoint = gcopointdefault #if MIN_VERSION_base(4,9,0) instance GCopoint WrappedMonoid where gcopoint = gcopointdefault #endif generic-deriving-1.11.1/src/Generics/Deriving/ConNames.hs0000644000000000000000000000350512765116253021351 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Safe #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif {- | Module : Generics.Deriving.ConNames Copyright : (c) 2012 University of Oxford License : BSD3 Maintainer : generics@haskell.org Stability : experimental Portability : non-portable Summary: Return the name of all the constructors of a type. -} module Generics.Deriving.ConNames ( -- * Functionality for retrieving the names of the possible contructors -- of a type or the constructor name of a given value ConNames(..), conNames, conNameOf ) where import Generics.Deriving.Base class ConNames f where gconNames :: f a -> [String] gconNameOf :: f a -> String instance (ConNames f, ConNames g) => ConNames (f :+: g) where gconNames (_ :: (f :+: g) a) = gconNames (undefined :: f a) ++ gconNames (undefined :: g a) gconNameOf (L1 x) = gconNameOf x gconNameOf (R1 x) = gconNameOf x instance (ConNames f) => ConNames (D1 c f) where gconNames (_ :: (D1 c f) a) = gconNames (undefined :: f a) gconNameOf (M1 x) = gconNameOf x instance (Constructor c) => ConNames (C1 c f) where gconNames x = [conName x] gconNameOf x = conName x -- We should never need any other instances. -- | Return the name of all the constructors of the type of the given term. conNames :: (Generic a, ConNames (Rep a)) => a -> [String] conNames x = gconNames (undefined `asTypeOf` (from x)) -- | Return the name of the constructor of the given term conNameOf :: (ConNames (Rep a), Generic a) => a -> String conNameOf x = gconNameOf (from x) generic-deriving-1.11.1/src/Generics/Deriving/Base.hs0000644000000000000000000000035612765116253020521 0ustar0000000000000000{-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Safe #-} #endif module Generics.Deriving.Base (module Generics.Deriving.Base.Internal) where import Generics.Deriving.Base.Internal import Generics.Deriving.Instances () generic-deriving-1.11.1/src/Generics/Deriving/TH/0000755000000000000000000000000012765116253017622 5ustar0000000000000000generic-deriving-1.11.1/src/Generics/Deriving/TH/Pre4_9.hs0000644000000000000000000001545012765116253021225 0ustar0000000000000000{-# LANGUAGE CPP #-} {- | Module : Generics.Deriving.TH.Pre4_9 Copyright : (c) 2008--2009 Universiteit Utrecht License : BSD3 Maintainer : generics@haskell.org Stability : experimental Portability : non-portable Template Haskell machinery for the proxy datatype variant of GHC generics used up until @base-4.9@. -} module Generics.Deriving.TH.Pre4_9 ( deriveMeta , deriveData , deriveConstructors , deriveSelectors , mkMetaDataType , mkMetaConsType , mkMetaSelType , SelStrictInfo , reifySelStrictInfo ) where import Data.List (intercalate) import Data.Maybe (fromMaybe) import Generics.Deriving.TH.Internal import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax -- | Given the type and the name (as string) for the type to derive, -- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector' -- instances. deriveMeta :: Name -> Q [Dec] deriveMeta n = do a <- deriveData n b <- deriveConstructors n c <- deriveSelectors n return (a ++ b ++ c) -- | Given a datatype name, derive a datatype and instance of class 'Datatype'. deriveData :: Name -> Q [Dec] deriveData = dataInstance -- | Given a datatype name, derive datatypes and -- instances of class 'Constructor'. deriveConstructors :: Name -> Q [Dec] deriveConstructors = constrInstance -- | Given a datatype name, derive datatypes and instances of class 'Selector'. deriveSelectors :: Name -> Q [Dec] deriveSelectors = selectInstance dataInstance :: Name -> Q [Dec] dataInstance n = do i <- reifyDataInfo n case i of Left _ -> return [] Right (n', isNT, _, _, dv) -> mkInstance n' dv isNT where mkInstance n' dv isNT = do ds <- mkDataData dv n' is <- mkDataInstance dv n' isNT return $ [ds,is] constrInstance :: Name -> Q [Dec] constrInstance n = do i <- reifyDataInfo n case i of Left _ -> return [] Right (n', _, _, cs, dv) -> mkInstance n' cs dv where mkInstance n' cs dv = do ds <- mapM (mkConstrData dv n') cs is <- mapM (mkConstrInstance dv n') cs return $ ds ++ is selectInstance :: Name -> Q [Dec] selectInstance n = do i <- reifyDataInfo n case i of Left _ -> return [] Right (n', _, _, cs, dv) -> mkInstance n' cs dv where mkInstance n' cs dv = do ds <- mapM (mkSelectData dv n') cs is <- mapM (mkSelectInstance dv n') cs return $ concat (ds ++ is) mkDataData :: DataVariety -> Name -> Q Dec mkDataData dv n = dataD (cxt []) (genName dv [n]) [] #if MIN_VERSION_template_haskell(2,11,0) Nothing [] (cxt []) #else [] [] #endif mkConstrData :: DataVariety -> Name -> Con -> Q Dec mkConstrData dv dt (NormalC n _) = dataD (cxt []) (genName dv [dt, n]) [] #if MIN_VERSION_template_haskell(2,11,0) Nothing [] (cxt []) #else [] [] #endif mkConstrData dv dt (RecC n f) = mkConstrData dv dt (NormalC n (map shrink f)) mkConstrData dv dt (InfixC t1 n t2) = mkConstrData dv dt (NormalC n [t1,t2]) mkConstrData _ _ con = gadtError con mkSelectData :: DataVariety -> Name -> Con -> Q [Dec] mkSelectData dv dt (RecC n fs) = return (map one fs) where one (f, _, _) = DataD [] (genName dv [dt, n, f]) [] #if MIN_VERSION_template_haskell(2,11,0) Nothing #endif [] [] mkSelectData _ _ _ = return [] mkDataInstance :: DataVariety -> Name -> Bool -> Q Dec mkDataInstance dv n isNewtype = instanceD (cxt []) (appT (conT datatypeTypeName) (mkMetaDataType dv n isNewtype)) $ [ funD datatypeNameValName [clause [wildP] (normalB (stringE (nameBase n))) []] , funD moduleNameValName [clause [wildP] (normalB (stringE name)) []] ] #if MIN_VERSION_base(4,7,0) ++ if isNewtype then [funD isNewtypeValName [clause [wildP] (normalB (conE trueDataName)) []]] else [] #endif where name = fromMaybe (error "Cannot fetch module name!") (nameModule n) liftFixity :: Fixity -> Q Exp liftFixity (Fixity n a) = conE infixDataName `appE` liftAssociativity a `appE` lift n liftAssociativity :: FixityDirection -> Q Exp liftAssociativity InfixL = conE leftAssociativeDataName liftAssociativity InfixR = conE rightAssociativeDataName liftAssociativity InfixN = conE notAssociativeDataName mkConstrInstance :: DataVariety -> Name -> Con -> Q Dec mkConstrInstance dv dt (NormalC n _) = mkConstrInstanceWith dv dt n False False [] mkConstrInstance dv dt (RecC n _) = mkConstrInstanceWith dv dt n True False [funD conIsRecordValName [clause [wildP] (normalB (conE trueDataName)) []]] mkConstrInstance dv dt (InfixC _ n _) = do i <- reify n #if MIN_VERSION_template_haskell(2,11,0) fi <- case i of DataConI{} -> fromMaybe defaultFixity `fmap` reifyFixity n #else let fi = case i of DataConI _ _ _ f -> f #endif _ -> error $ "Not a data constructor name: " ++ show n mkConstrInstanceWith dv dt n False True [funD conFixityValName [clause [wildP] (normalB (liftFixity fi)) []]] mkConstrInstance _ _ con = gadtError con mkConstrInstanceWith :: DataVariety -> Name -> Name -> Bool -> Bool -> [Q Dec] -> Q Dec mkConstrInstanceWith dv dt n isRecord isInfix extra = instanceD (cxt []) (appT (conT constructorTypeName) (mkMetaConsType dv dt n isRecord isInfix)) (funD conNameValName [clause [wildP] (normalB (stringE (nameBase n))) []] : extra) mkSelectInstance :: DataVariety -> Name -> Con -> Q [Dec] mkSelectInstance dv dt (RecC n fs) = mapM (one . fst3) fs where one :: Name -> Q Dec one f = instanceD (cxt []) (appT (conT selectorTypeName) (mkMetaSelType dv dt n (Just f) ())) [funD selNameValName [clause [wildP] (normalB (litE (stringL (nameBase f)))) []]] mkSelectInstance _ _ _ = return [] genName :: DataVariety -> [Name] -> Name genName dv ns = mkName . showsDataVariety dv . intercalate "_" . consQualName $ map (sanitizeName . nameBase) ns where consQualName :: [String] -> [String] consQualName = case ns of [] -> id n:_ -> (showNameQual n :) mkMetaDataType :: DataVariety -> Name -> Bool -> Q Type mkMetaDataType dv n _ = conT $ genName dv [n] mkMetaConsType :: DataVariety -> Name -> Name -> Bool -> Bool -> Q Type mkMetaConsType dv dt n _ _ = conT $ genName dv [dt, n] mkMetaSelType :: DataVariety -> Name -> Name -> Maybe Name -> SelStrictInfo -> Q Type mkMetaSelType dv dt n (Just f) () = conT $ genName dv [dt, n, f] mkMetaSelType _ _ _ Nothing () = conT noSelectorTypeName type SelStrictInfo = () reifySelStrictInfo :: Name -> [Strict] -> Q [SelStrictInfo] reifySelStrictInfo _ bangs = return (map (const ()) bangs) generic-deriving-1.11.1/src/Generics/Deriving/TH/Post4_9.hs0000644000000000000000000001172512765116253021425 0ustar0000000000000000{- | Module : Generics.Deriving.TH.Post4_9 Copyright : (c) 2008--2009 Universiteit Utrecht License : BSD3 Maintainer : generics@haskell.org Stability : experimental Portability : non-portable Template Haskell machinery for the type-literal-based variant of GHC generics introduced in @base-4.9@. -} module Generics.Deriving.TH.Post4_9 ( deriveMeta , deriveData , deriveConstructors , deriveSelectors , mkMetaDataType , mkMetaConsType , mkMetaSelType , SelStrictInfo(..) , reifySelStrictInfo ) where import Data.Maybe (fromMaybe) import Generics.Deriving.TH.Internal import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax mkMetaDataType :: DataVariety -> Name -> Bool -> Q Type mkMetaDataType _ n isNewtype = promotedT metaDataDataName `appT` litT (strTyLit (nameBase n)) `appT` litT (strTyLit m) `appT` litT (strTyLit pkg) `appT` promoteBool isNewtype where m, pkg :: String m = fromMaybe (error "Cannot fetch module name!") (nameModule n) pkg = fromMaybe (error "Cannot fetch package name!") (namePackage n) mkMetaConsType :: DataVariety -> Name -> Name -> Bool -> Bool -> Q Type mkMetaConsType _ _ n conIsRecord conIsInfix = do mbFi <- reifyFixity n promotedT metaConsDataName `appT` litT (strTyLit (nameBase n)) `appT` fixityIPromotedType mbFi conIsInfix `appT` promoteBool conIsRecord promoteBool :: Bool -> Q Type promoteBool True = promotedT trueDataName promoteBool False = promotedT falseDataName fixityIPromotedType :: Maybe Fixity -> Bool -> Q Type fixityIPromotedType mbFi True = promotedT infixIDataName `appT` promoteAssociativity a `appT` litT (numTyLit (toInteger n)) where Fixity n a = fromMaybe defaultFixity mbFi fixityIPromotedType _ False = promotedT prefixIDataName promoteAssociativity :: FixityDirection -> Q Type promoteAssociativity InfixL = promotedT leftAssociativeDataName promoteAssociativity InfixR = promotedT rightAssociativeDataName promoteAssociativity InfixN = promotedT notAssociativeDataName mkMetaSelType :: DataVariety -> Name -> Name -> Maybe Name -> SelStrictInfo -> Q Type mkMetaSelType _ _ _ mbF (SelStrictInfo su ss ds) = let mbSelNameT = case mbF of Just f -> promotedT justDataName `appT` litT (strTyLit (nameBase f)) Nothing -> promotedT nothingDataName in promotedT metaSelDataName `appT` mbSelNameT `appT` promoteSourceUnpackedness su `appT` promoteSourceStrictness ss `appT` promoteDecidedStrictness ds data SelStrictInfo = SelStrictInfo SourceUnpackedness SourceStrictness DecidedStrictness promoteSourceUnpackedness :: SourceUnpackedness -> Q Type promoteSourceUnpackedness NoSourceUnpackedness = promotedT noSourceUnpackednessDataName promoteSourceUnpackedness SourceNoUnpack = promotedT sourceNoUnpackDataName promoteSourceUnpackedness SourceUnpack = promotedT sourceUnpackDataName promoteSourceStrictness :: SourceStrictness -> Q Type promoteSourceStrictness NoSourceStrictness = promotedT noSourceStrictnessDataName promoteSourceStrictness SourceLazy = promotedT sourceLazyDataName promoteSourceStrictness SourceStrict = promotedT sourceStrictDataName promoteDecidedStrictness :: DecidedStrictness -> Q Type promoteDecidedStrictness DecidedLazy = promotedT decidedLazyDataName promoteDecidedStrictness DecidedStrict = promotedT decidedStrictDataName promoteDecidedStrictness DecidedUnpack = promotedT decidedUnpackDataName reifySelStrictInfo :: Name -> [Bang] -> Q [SelStrictInfo] reifySelStrictInfo conName bangs = do dcdStrs <- reifyConStrictness conName let (srcUnpks, srcStrs) = unzip $ map splitBang bangs return $ zipWith3 SelStrictInfo srcUnpks srcStrs dcdStrs splitBang :: Bang -> (SourceUnpackedness, SourceStrictness) splitBang (Bang su ss) = (su, ss) -- | Given the type and the name (as string) for the type to derive, -- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector' -- instances. -- -- On GHC 7.11 and up, this functionality is no longer used in GHC generics, -- so this function generates no declarations. deriveMeta :: Name -> Q [Dec] deriveMeta _ = return [] -- | Given a datatype name, derive a datatype and instance of class 'Datatype'. -- -- On GHC 7.11 and up, this functionality is no longer used in GHC generics, -- so this function generates no declarations. deriveData :: Name -> Q [Dec] deriveData _ = return [] -- | Given a datatype name, derive datatypes and -- instances of class 'Constructor'. -- -- On GHC 7.11 and up, this functionality is no longer used in GHC generics, -- so this function generates no declarations. deriveConstructors :: Name -> Q [Dec] deriveConstructors _ = return [] -- | Given a datatype name, derive datatypes and instances of class 'Selector'. -- -- On GHC 7.11 and up, this functionality is no longer used in GHC generics, -- so this function generates no declarations. deriveSelectors :: Name -> Q [Dec] deriveSelectors _ = return [] generic-deriving-1.11.1/src/Generics/Deriving/TH/Internal.hs0000644000000000000000000007771612765116253021754 0ustar0000000000000000{-# LANGUAGE CPP #-} {- | Module : Generics.Deriving.TH.Internal Copyright : (c) 2008--2009 Universiteit Utrecht License : BSD3 Maintainer : generics@haskell.org Stability : experimental Portability : non-portable Template Haskell-related utilities. -} module Generics.Deriving.TH.Internal where import Data.Char (isAlphaNum, ord) import Data.Foldable (foldr') import Data.List import qualified Data.Map as Map import Data.Map as Map (Map) import Data.Maybe (mapMaybe) import qualified Data.Set as Set import Data.Set (Set) import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr (pprint) import Language.Haskell.TH.Syntax #ifndef CURRENT_PACKAGE_KEY import Data.Version (showVersion) import Paths_generic_deriving (version) #endif ------------------------------------------------------------------------------- -- Expanding type synonyms ------------------------------------------------------------------------------- -- | Expands all type synonyms in a type. Written by Dan Rosén in the -- @genifunctors@ package (licensed under BSD3). expandSyn :: Type -> Q Type expandSyn (ForallT tvs ctx t) = fmap (ForallT tvs ctx) $ expandSyn t expandSyn t@AppT{} = expandSynApp t [] expandSyn t@ConT{} = expandSynApp t [] expandSyn (SigT t k) = do t' <- expandSyn t k' <- expandSynKind k return (SigT t' k') expandSyn t = return t expandSynKind :: Kind -> Q Kind #if MIN_VERSION_template_haskell(2,8,0) expandSynKind = expandSyn #else expandSynKind = return -- There are no kind synonyms to deal with #endif expandSynApp :: Type -> [Type] -> Q Type expandSynApp (AppT t1 t2) ts = do t2' <- expandSyn t2 expandSynApp t1 (t2':ts) expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts expandSynApp t@(ConT n) ts = do info <- reify n case info of TyConI (TySynD _ tvs rhs) -> let (ts', ts'') = splitAt (length tvs) ts subs = mkSubst tvs ts' rhs' = substType subs rhs in expandSynApp rhs' ts'' _ -> return $ foldl' AppT t ts expandSynApp t ts = do t' <- expandSyn t return $ foldl' AppT t' ts type TypeSubst = Map Name Type type KindSubst = Map Name Kind mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst mkSubst vs ts = let vs' = map tyVarBndrName vs in Map.fromList $ zip vs' ts substType :: TypeSubst -> Type -> Type substType subs (ForallT v c t) = ForallT v c $ substType subs t substType subs t@(VarT n) = Map.findWithDefault t n subs substType subs (AppT t1 t2) = AppT (substType subs t1) (substType subs t2) substType subs (SigT t k) = SigT (substType subs t) #if MIN_VERSION_template_haskell(2,8,0) (substType subs k) #else k #endif substType _ t = t substKind :: KindSubst -> Type -> Type #if MIN_VERSION_template_haskell(2,8,0) substKind = substType #else substKind _ = id -- There are no kind variables! #endif substNameWithKind :: Name -> Kind -> Type -> Type substNameWithKind n k = substKind (Map.singleton n k) substNamesWithKindStar :: [Name] -> Type -> Type substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns substTyVarBndrType :: TypeSubst -> TyVarBndr -> Type substTyVarBndrType subs = substType subs . tyVarBndrToType substTyVarBndrKind :: KindSubst -> TyVarBndr -> Type #if MIN_VERSION_template_haskell(2,8,0) substTyVarBndrKind = substTyVarBndrType #else substTyVarBndrKind _ = tyVarBndrToType #endif substNameWithKindStarInTyVarBndr :: Name -> TyVarBndr -> Type substNameWithKindStarInTyVarBndr n = substTyVarBndrKind (Map.singleton n starK) ------------------------------------------------------------------------------- -- StarKindStatus ------------------------------------------------------------------------------- -- | Whether a type is not of kind *, is of kind *, or is a kind variable. data StarKindStatus = NotKindStar | KindStar | IsKindVar Name deriving Eq -- | Does a Type have kind * or k (for some kind variable k)? canRealizeKindStar :: Type -> StarKindStatus canRealizeKindStar t | hasKindStar t = KindStar | otherwise = case t of #if MIN_VERSION_template_haskell(2,8,0) SigT _ (VarT k) -> IsKindVar k #endif _ -> NotKindStar -- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists. -- Otherwise, returns 'Nothing'. starKindStatusToName :: StarKindStatus -> Maybe Name starKindStatusToName (IsKindVar n) = Just n starKindStatusToName _ = Nothing -- | Concat together all of the StarKindStatuses that are IsKindVar and extract -- the kind variables' Names out. catKindVarNames :: [StarKindStatus] -> [Name] catKindVarNames = mapMaybe starKindStatusToName ------------------------------------------------------------------------------- -- Assorted utilities ------------------------------------------------------------------------------- -- | Returns True if a Type has kind *. hasKindStar :: Type -> Bool hasKindStar VarT{} = True #if MIN_VERSION_template_haskell(2,8,0) hasKindStar (SigT _ StarT) = True #else hasKindStar (SigT _ StarK) = True #endif hasKindStar _ = False -- | Gets all of the type/kind variable names mentioned somewhere in a Type. tyVarNamesOfType :: Type -> [Name] tyVarNamesOfType = go where go :: Type -> [Name] go (AppT t1 t2) = go t1 ++ go t2 go (SigT t _k) = go t #if MIN_VERSION_template_haskell(2,8,0) ++ go _k #endif go (VarT n) = [n] go _ = [] -- | Gets all of the required type/kind variable binders mentioned in a Type. -- This does not add separate items for kind variable binders (in contrast with -- the behavior of 'tyVarNamesOfType'). requiredTyVarsOfType :: Type -> [TyVarBndr] requiredTyVarsOfType = go where go :: Type -> [TyVarBndr] go (AppT t1 t2) = go t1 ++ go t2 go (SigT (VarT n) k) = [KindedTV n k] go (VarT n) = [PlainTV n] go _ = [] -- | Converts a VarT or a SigT into Just the corresponding TyVarBndr. -- Converts other Types to Nothing. typeToTyVarBndr :: Type -> Maybe TyVarBndr typeToTyVarBndr (VarT n) = Just (PlainTV n) typeToTyVarBndr (SigT (VarT n) k) = Just (KindedTV n k) typeToTyVarBndr _ = Nothing -- | If a Type is a SigT, returns its kind signature. Otherwise, return *. typeKind :: Type -> Kind typeKind (SigT _ k) = k typeKind _ = starK -- | Turns -- -- @ -- [a, b] c -- @ -- -- into -- -- @ -- a -> b -> c -- @ makeFunType :: [Type] -> Type -> Type makeFunType argTys resTy = foldr' (AppT . AppT ArrowT) resTy argTys -- | Turns -- -- @ -- [k1, k2] k3 -- @ -- -- into -- -- @ -- k1 -> k2 -> k3 -- @ makeFunKind :: [Kind] -> Kind -> Kind #if MIN_VERSION_template_haskell(2,8,0) makeFunKind = makeFunType #else makeFunKind argKinds resKind = foldr' ArrowK resKind argKinds #endif -- | Is the given type a type family constructor (and not a data family constructor)? isTyFamily :: Type -> Q Bool isTyFamily (ConT n) = do info <- reify n return $ case info of #if MIN_VERSION_template_haskell(2,11,0) FamilyI OpenTypeFamilyD{} _ -> True #elif MIN_VERSION_template_haskell(2,7,0) FamilyI (FamilyD TypeFam _ _ _) _ -> True #else TyConI (FamilyD TypeFam _ _ _) -> True #endif #if MIN_VERSION_template_haskell(2,9,0) FamilyI ClosedTypeFamilyD{} _ -> True #endif _ -> False isTyFamily _ = return False -- | True if the type does not mention the Name ground :: Type -> Name -> Bool ground (AppT t1 t2) name = ground t1 name && ground t2 name ground (SigT t _) name = ground t name ground (VarT t) name = t /= name ground ForallT{} _ = rankNError ground _ _ = True -- | Construct a type via curried application. applyTyToTys :: Type -> [Type] -> Type applyTyToTys = foldl' AppT -- | Apply a type constructor name to type variable binders. applyTyToTvbs :: Name -> [TyVarBndr] -> Type applyTyToTvbs = foldl' (\a -> AppT a . tyVarBndrToType) . ConT -- | Split an applied type into its individual components. For example, this: -- -- @ -- Either Int Char -- @ -- -- would split to this: -- -- @ -- [Either, Int, Char] -- @ unapplyTy :: Type -> [Type] unapplyTy = reverse . go where go :: Type -> [Type] go (AppT t1 t2) = t2 : go t1 go (SigT t _) = go t go (ForallT _ _ t) = go t go t = [t] -- | Split a type signature by the arrows on its spine. For example, this: -- -- @ -- forall a b. (a -> b) -> Char -> () -- @ -- -- would split to this: -- -- @ -- ([a, b], [a -> b, Char, ()]) -- @ uncurryTy :: Type -> ([TyVarBndr], [Type]) uncurryTy (AppT (AppT ArrowT t1) t2) = let (tvbs, tys) = uncurryTy t2 in (tvbs, t1:tys) uncurryTy (SigT t _) = uncurryTy t uncurryTy (ForallT tvbs _ t) = let (tvbs', tys) = uncurryTy t in (tvbs ++ tvbs', tys) uncurryTy t = ([], [t]) -- | Like uncurryType, except on a kind level. uncurryKind :: Kind -> ([TyVarBndr], [Kind]) #if MIN_VERSION_template_haskell(2,8,0) uncurryKind = uncurryTy #else uncurryKind (ArrowK k1 k2) = let (kvbs, ks) = uncurryKind k2 in (kvbs, k1:ks) uncurryKind k = ([], [k]) #endif tyVarBndrToType :: TyVarBndr -> Type tyVarBndrToType (PlainTV n) = VarT n tyVarBndrToType (KindedTV n k) = SigT (VarT n) k tyVarBndrName :: TyVarBndr -> Name tyVarBndrName (PlainTV name) = name tyVarBndrName (KindedTV name _) = name tyVarBndrKind :: TyVarBndr -> Kind tyVarBndrKind PlainTV{} = starK tyVarBndrKind (KindedTV _ k) = k -- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr. stealKindForType :: TyVarBndr -> Type -> Type stealKindForType tvb t@VarT{} = SigT t (tyVarBndrKind tvb) stealKindForType _ t = t -- | Generate a list of fresh names with a common prefix, and numbered suffixes. newNameList :: String -> Int -> Q [Name] newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n] -- | Checks to see if the last types in a data family instance can be safely eta- -- reduced (i.e., dropped), given the other types. This checks for three conditions: -- -- (1) All of the dropped types are type variables -- (2) All of the dropped types are distinct -- (3) None of the remaining types mention any of the dropped types canEtaReduce :: [Type] -> [Type] -> Bool canEtaReduce remaining dropped = all isTyVar dropped -- Make sure not to pass something of type [Type], since Type -- didn't have an Ord instance until template-haskell-2.10.0.0 && allDistinct droppedNames && not (any (`mentionsName` droppedNames) remaining) where droppedNames :: [Name] droppedNames = map varTToName dropped -- | Extract the Name from a type variable. If the argument Type is not a -- type variable, throw an error. varTToName :: Type -> Name varTToName (VarT n) = n varTToName (SigT t _) = varTToName t varTToName _ = error "Not a type variable!" -- | Is the given type a variable? isTyVar :: Type -> Bool isTyVar VarT{} = True isTyVar (SigT t _) = isTyVar t isTyVar _ = False -- | Is the given kind a variable? isKindVar :: Kind -> Bool #if MIN_VERSION_template_haskell(2,8,0) isKindVar = isTyVar #else isKindVar _ = False -- There are no kind variables #endif -- | Returns 'True' is a 'Type' contains no type variables. isTypeMonomorphic :: Type -> Bool isTypeMonomorphic = go where go :: Type -> Bool go (AppT t1 t2) = go t1 && go t2 go (SigT t _k) = go t #if MIN_VERSION_template_haskell(2,8,0) && go _k #endif go VarT{} = False go _ = True -- | Peel off a kind signature from a Type (if it has one). unSigT :: Type -> Type unSigT (SigT t _) = t unSigT t = t -- | Peel off a kind signature from a TyVarBndr (if it has one). unKindedTV :: TyVarBndr -> TyVarBndr unKindedTV (KindedTV n _) = PlainTV n unKindedTV tvb = tvb -- | Does the given type mention any of the Names in the list? mentionsName :: Type -> [Name] -> Bool mentionsName = go where go :: Type -> [Name] -> Bool go (AppT t1 t2) names = go t1 names || go t2 names go (SigT t _k) names = go t names #if MIN_VERSION_template_haskell(2,8,0) || go _k names #endif go (VarT n) names = n `elem` names go _ _ = False -- | Are all of the items in a list (which have an ordering) distinct? -- -- This uses Set (as opposed to nub) for better asymptotic time complexity. allDistinct :: Ord a => [a] -> Bool allDistinct = allDistinct' Set.empty where allDistinct' :: Ord a => Set a -> [a] -> Bool allDistinct' uniqs (x:xs) | x `Set.member` uniqs = False | otherwise = allDistinct' (Set.insert x uniqs) xs allDistinct' _ _ = True fst3 :: (a, b, c) -> a fst3 (a, _, _) = a snd3 :: (a, b, c) -> b snd3 (_, b, _) = b trd3 :: (a, b, c) -> c trd3 (_, _, c) = c shrink :: (a, b, c) -> (b, c) shrink (_, b, c) = (b, c) -- | Variant of foldr1 which returns a special element for empty lists foldr1' :: (a -> a -> a) -> a -> [a] -> a foldr1' _ x [] = x foldr1' _ _ [x] = x foldr1' f x (h:t) = f h (foldr1' f x t) -- | Extracts the name of a constructor. constructorName :: Con -> Name constructorName (NormalC name _ ) = name constructorName (RecC name _ ) = name constructorName (InfixC _ name _ ) = name constructorName (ForallC _ _ con) = constructorName con #if MIN_VERSION_template_haskell(2,11,0) constructorName (GadtC names _ _) = head names constructorName (RecGadtC names _ _) = head names #endif #if MIN_VERSION_template_haskell(2,7,0) -- | Extracts the constructors of a data or newtype declaration. dataDecCons :: Dec -> [Con] dataDecCons (DataInstD _ _ _ # if MIN_VERSION_template_haskell(2,11,0) _ # endif cons _) = cons dataDecCons (NewtypeInstD _ _ _ # if MIN_VERSION_template_haskell(2,11,0) _ # endif con _) = [con] dataDecCons _ = error "Must be a data or newtype declaration." #endif -- | Indicates whether Generic or Generic1 is being derived. data GenericClass = Generic | Generic1 deriving Enum -- | Like 'GenericArity', but bundling two things in the 'Gen1' case: -- -- 1. The 'Name' of the last type parameter. -- 2. If that last type parameter had kind k (where k is some kind variable), -- then it has 'Just' the kind variable 'Name'. Otherwise, it has 'Nothing'. data GenericKind = Gen0 | Gen1 Name (Maybe Name) -- Determines the universally quantified type variables (possibly after -- substituting * in the case of Generic1), the types of a constructor's -- arguments, and the last type parameter name (if there is one). reifyConTys :: GenericClass -> Name -> Q ([Type], [Type], GenericKind) reifyConTys gClass conName = do info <- reify conName let (tvbs, uncTy) = case info of DataConI _ ty _ #if !(MIN_VERSION_template_haskell(2,11,0)) _ #endif -> uncurryTy ty _ -> error "Must be a data constructor" let (argTys, [resTy]) = splitAt (length uncTy - 1) uncTy -- Make sure to expand through synonyms on the last type, or else you might -- have something like -- -- type Constant a b = a -- data Good a = Good (Constant a b) -- -- which you'd only be able to tell was legal if you expand Constant a b to a! resTyExp <- expandSyn resTy let numResTyVars = length . nub $ requiredTyVarsOfType resTyExp -- We need to grab a number of types from the constructor's -- type signature to re-use for the Rep(1) type synonym's type variable -- binders. As it turns out, that number is equal to the number of distinct -- type variables which appear in the result type. -- -- We assume that the required types all come last in the list -- of forall'd type variables. I suppose nothing guarantees this, but -- this seems to always be the case via experimentation. Fingers crossed. requiredTvbs = drop (length tvbs - numResTyVars) tvbs let (requiredTyVars', gk) = case gClass of Generic -> (map tyVarBndrToType requiredTvbs, Gen0) Generic1 -> -- If deriving Generic1 and the last type variable is polykinded, -- make sure to substitute that kind with * in the other type -- variable binders' kind signatures let headRequiredTvbs :: [TyVarBndr] lastRequiredTvb :: TyVarBndr (headRequiredTvbs, [lastRequiredTvb]) = splitAt (length requiredTvbs - 1) requiredTvbs mbLastArgKindName :: Maybe Name mbLastArgKindName = starKindStatusToName . canRealizeKindStar $ tyVarBndrToType lastRequiredTvb requiredTyVars :: [Type] requiredTyVars = case mbLastArgKindName of Nothing -> map tyVarBndrToType headRequiredTvbs Just _lakn -> -- See Note [Generic1 is polykinded on GHC 8.2] in Generics.Deriving.TH #if __GLASGOW_HASKELL__ >= 801 map tyVarBndrToType headRequiredTvbs #else map (substNameWithKindStarInTyVarBndr _lakn) headRequiredTvbs #endif in ( requiredTyVars , Gen1 (tyVarBndrName lastRequiredTvb) mbLastArgKindName ) return (requiredTyVars', argTys, gk) -- | Indicates whether Generic(1) is being derived for a plain data type (DataPlain) -- or a data family instance (DataFamily). DataFamily bundles the Name of the data -- family instance's first constructor (for Name-generation purposes) and the types -- used to instantiate the instance. data DataVariety = DataPlain | DataFamily Name [Type] showsDataVariety :: DataVariety -> ShowS showsDataVariety dv = (++ '_':label dv) where label DataPlain = "Plain" label (DataFamily n _) = "Family_" ++ sanitizeName (nameBase n) showNameQual :: Name -> String showNameQual = sanitizeName . showQual where showQual (Name _ (NameQ m)) = modString m showQual (Name _ (NameG _ pkg m)) = pkgString pkg ++ ":" ++ modString m showQual _ = "" -- | Credit to Víctor López Juan for this trick sanitizeName :: String -> String sanitizeName nb = 'N':( nb >>= \x -> case x of c | isAlphaNum c || c == '\''-> [c] '_' -> "__" c -> "_" ++ show (ord c)) -- | One of the last type variables cannot be eta-reduced (see the canEtaReduce -- function for the criteria it would have to meet). etaReductionError :: Type -> a etaReductionError instanceType = error $ "Cannot eta-reduce to an instance of form \n\tinstance (...) => " ++ pprint instanceType -- | Either the given data type doesn't have enough type variables, or one of -- the type variables to be eta-reduced cannot realize kind *. derivingKindError :: Name -> a derivingKindError tyConName = error . showString "Cannot derive well-kinded instance of form ‘Generic1 " . showParen True ( showString (nameBase tyConName) . showString " ..." ) . showString "‘\n\tClass Generic1 expects an argument of kind * -> *" $ "" outOfPlaceTyVarError :: a outOfPlaceTyVarError = error $ "Type applied to an argument involving the last parameter is not of kind * -> *" -- | Deriving Generic(1) doesn't work with ExistentialQuantification or GADTs gadtError :: Con -> a gadtError con = error $ nameBase (constructorName con) ++ " must be a vanilla data constructor" -- | Cannot have a constructor argument of form (forall a1 ... an. ) -- when deriving Generic(1) rankNError :: a rankNError = error "Cannot have polymorphic arguments" -- | Boilerplate for top level splices. -- -- The given Name must meet one of two criteria: -- -- 1. It must be the name of a type constructor of a plain data type or newtype. -- 2. It must be the name of a data family instance or newtype instance constructor. -- -- Any other value will result in an exception. reifyDataInfo :: Name -> Q (Either String (Name, Bool, [TyVarBndr], [Con], DataVariety)) reifyDataInfo name = do info <- reify name case info of TyConI dec -> return $ case dec of DataD ctxt _ tvbs #if MIN_VERSION_template_haskell(2,11,0) _ #endif cons _ -> Right $ checkDataContext name ctxt (name, False, tvbs, cons, DataPlain) NewtypeD ctxt _ tvbs #if MIN_VERSION_template_haskell(2,11,0) _ #endif con _ -> Right $ checkDataContext name ctxt (name, True, tvbs, [con], DataPlain) TySynD{} -> Left $ ns ++ "Type synonyms are not supported." _ -> Left $ ns ++ "Unsupported type: " ++ show dec #if MIN_VERSION_template_haskell(2,7,0) # if MIN_VERSION_template_haskell(2,11,0) DataConI _ _ parentName -> do # else DataConI _ _ parentName _ -> do # endif parentInfo <- reify parentName return $ case parentInfo of # if MIN_VERSION_template_haskell(2,11,0) FamilyI (DataFamilyD _ tvbs _) decs -> # else FamilyI (FamilyD DataFam _ tvbs _) decs -> # endif -- This isn't total, but the API requires that the data family instance have -- at least one constructor anyways, so this will always succeed. let instDec = flip find decs $ any ((name ==) . constructorName) . dataDecCons in case instDec of Just (DataInstD ctxt _ instTys # if MIN_VERSION_template_haskell(2,11,0) _ # endif cons _) -> Right $ checkDataContext parentName ctxt (parentName, False, tvbs, cons, DataFamily (constructorName $ head cons) instTys) Just (NewtypeInstD ctxt _ instTys # if MIN_VERSION_template_haskell(2,11,0) _ # endif con _) -> Right $ checkDataContext parentName ctxt (parentName, True, tvbs, [con], DataFamily (constructorName con) instTys) _ -> Left $ ns ++ "Could not find data or newtype instance constructor." _ -> Left $ ns ++ "Data constructor " ++ show name ++ " is not from a data family instance constructor." # if MIN_VERSION_template_haskell(2,11,0) FamilyI DataFamilyD{} _ -> # else FamilyI (FamilyD DataFam _ _ _) _ -> # endif return . Left $ ns ++ "Cannot use a data family name. Use a data family instance constructor instead." _ -> return . Left $ ns ++ "The name must be of a plain data type constructor, " ++ "or a data family instance constructor." #else DataConI{} -> return . Left $ ns ++ "Cannot use a data constructor." ++ "\n\t(Note: if you are trying to derive for a data family instance, use GHC >= 7.4 instead.)" _ -> return . Left $ ns ++ "The name must be of a plain type constructor." #endif where ns :: String ns = "Generics.Deriving.TH.reifyDataInfo: " -- | One cannot derive Generic(1) instance for anything that uses DatatypeContexts, -- so check to make sure the Cxt field of a datatype is null. checkDataContext :: Name -> Cxt -> a -> a checkDataContext _ [] x = x checkDataContext dataName _ _ = error $ nameBase dataName ++ " must not have a datatype context" ------------------------------------------------------------------------------- -- Manually quoted names ------------------------------------------------------------------------------- -- By manually generating these names we avoid needing to use the -- TemplateHaskell language extension when compiling the generic-deriving library. -- This allows the library to be used in stage1 cross-compilers. gdPackageKey :: String #ifdef CURRENT_PACKAGE_KEY gdPackageKey = CURRENT_PACKAGE_KEY #else gdPackageKey = "generic-deriving-" ++ showVersion version #endif mkGD4'4_d :: String -> Name #if MIN_VERSION_base(4,6,0) mkGD4'4_d = mkNameG_d "base" "GHC.Generics" #elif MIN_VERSION_base(4,4,0) mkGD4'4_d = mkNameG_d "ghc-prim" "GHC.Generics" #else mkGD4'4_d = mkNameG_d gdPackageKey "Generics.Deriving.Base.Internal" #endif mkGD4'9_d :: String -> Name #if MIN_VERSION_base(4,9,0) mkGD4'9_d = mkNameG_d "base" "GHC.Generics" #else mkGD4'9_d = mkNameG_d gdPackageKey "Generics.Deriving.Base.Internal" #endif mkGD4'4_tc :: String -> Name #if MIN_VERSION_base(4,6,0) mkGD4'4_tc = mkNameG_tc "base" "GHC.Generics" #elif MIN_VERSION_base(4,4,0) mkGD4'4_tc = mkNameG_tc "ghc-prim" "GHC.Generics" #else mkGD4'4_tc = mkNameG_tc gdPackageKey "Generics.Deriving.Base.Internal" #endif mkGD4'9_tc :: String -> Name #if MIN_VERSION_base(4,9,0) mkGD4'9_tc = mkNameG_tc "base" "GHC.Generics" #else mkGD4'9_tc = mkNameG_tc gdPackageKey "Generics.Deriving.Base.Internal" #endif mkGD4'4_v :: String -> Name #if MIN_VERSION_base(4,6,0) mkGD4'4_v = mkNameG_v "base" "GHC.Generics" #elif MIN_VERSION_base(4,4,0) mkGD4'4_v = mkNameG_v "ghc-prim" "GHC.Generics" #else mkGD4'4_v = mkNameG_v gdPackageKey "Generics.Deriving.Base.Internal" #endif mkGD4'9_v :: String -> Name #if MIN_VERSION_base(4,9,0) mkGD4'9_v = mkNameG_v "base" "GHC.Generics" #else mkGD4'9_v = mkNameG_v gdPackageKey "Generics.Deriving.Base.Internal" #endif mkBaseName_d :: String -> String -> Name mkBaseName_d = mkNameG_d "base" mkGHCPrimName_d :: String -> String -> Name mkGHCPrimName_d = mkNameG_d "ghc-prim" mkGHCPrimName_tc :: String -> String -> Name mkGHCPrimName_tc = mkNameG_tc "ghc-prim" comp1DataName :: Name comp1DataName = mkGD4'4_d "Comp1" infixDataName :: Name infixDataName = mkGD4'4_d "Infix" k1DataName :: Name k1DataName = mkGD4'4_d "K1" l1DataName :: Name l1DataName = mkGD4'4_d "L1" leftAssociativeDataName :: Name leftAssociativeDataName = mkGD4'4_d "LeftAssociative" m1DataName :: Name m1DataName = mkGD4'4_d "M1" notAssociativeDataName :: Name notAssociativeDataName = mkGD4'4_d "NotAssociative" par1DataName :: Name par1DataName = mkGD4'4_d "Par1" prefixDataName :: Name prefixDataName = mkGD4'4_d "Prefix" productDataName :: Name productDataName = mkGD4'4_d ":*:" r1DataName :: Name r1DataName = mkGD4'4_d "R1" rec1DataName :: Name rec1DataName = mkGD4'4_d "Rec1" rightAssociativeDataName :: Name rightAssociativeDataName = mkGD4'4_d "RightAssociative" u1DataName :: Name u1DataName = mkGD4'4_d "U1" uAddrDataName :: Name uAddrDataName = mkGD4'9_d "UAddr" uCharDataName :: Name uCharDataName = mkGD4'9_d "UChar" uDoubleDataName :: Name uDoubleDataName = mkGD4'9_d "UDouble" uFloatDataName :: Name uFloatDataName = mkGD4'9_d "UFloat" uIntDataName :: Name uIntDataName = mkGD4'9_d "UInt" uWordDataName :: Name uWordDataName = mkGD4'9_d "UWord" c1TypeName :: Name c1TypeName = mkGD4'4_tc "C1" composeTypeName :: Name composeTypeName = mkGD4'4_tc ":.:" constructorTypeName :: Name constructorTypeName = mkGD4'4_tc "Constructor" d1TypeName :: Name d1TypeName = mkGD4'4_tc "D1" genericTypeName :: Name genericTypeName = mkGD4'4_tc "Generic" generic1TypeName :: Name generic1TypeName = mkGD4'4_tc "Generic1" datatypeTypeName :: Name datatypeTypeName = mkGD4'4_tc "Datatype" noSelectorTypeName :: Name noSelectorTypeName = mkGD4'4_tc "NoSelector" par1TypeName :: Name par1TypeName = mkGD4'4_tc "Par1" productTypeName :: Name productTypeName = mkGD4'4_tc ":*:" rec0TypeName :: Name rec0TypeName = mkGD4'4_tc "Rec0" rec1TypeName :: Name rec1TypeName = mkGD4'4_tc "Rec1" repTypeName :: Name repTypeName = mkGD4'4_tc "Rep" rep1TypeName :: Name rep1TypeName = mkGD4'4_tc "Rep1" s1TypeName :: Name s1TypeName = mkGD4'4_tc "S1" selectorTypeName :: Name selectorTypeName = mkGD4'4_tc "Selector" sumTypeName :: Name sumTypeName = mkGD4'4_tc ":+:" u1TypeName :: Name u1TypeName = mkGD4'4_tc "U1" uAddrTypeName :: Name uAddrTypeName = mkGD4'9_tc "UAddr" uCharTypeName :: Name uCharTypeName = mkGD4'9_tc "UChar" uDoubleTypeName :: Name uDoubleTypeName = mkGD4'9_tc "UDouble" uFloatTypeName :: Name uFloatTypeName = mkGD4'9_tc "UFloat" uIntTypeName :: Name uIntTypeName = mkGD4'9_tc "UInt" uWordTypeName :: Name uWordTypeName = mkGD4'9_tc "UWord" v1TypeName :: Name v1TypeName = mkGD4'4_tc "V1" conFixityValName :: Name conFixityValName = mkGD4'4_v "conFixity" conIsRecordValName :: Name conIsRecordValName = mkGD4'4_v "conIsRecord" conNameValName :: Name conNameValName = mkGD4'4_v "conName" datatypeNameValName :: Name datatypeNameValName = mkGD4'4_v "datatypeName" isNewtypeValName :: Name isNewtypeValName = mkGD4'4_v "isNewtype" fromValName :: Name fromValName = mkGD4'4_v "from" from1ValName :: Name from1ValName = mkGD4'4_v "from1" moduleNameValName :: Name moduleNameValName = mkGD4'4_v "moduleName" selNameValName :: Name selNameValName = mkGD4'4_v "selName" toValName :: Name toValName = mkGD4'4_v "to" to1ValName :: Name to1ValName = mkGD4'4_v "to1" uAddrHashValName :: Name uAddrHashValName = mkGD4'9_v "uAddr#" uCharHashValName :: Name uCharHashValName = mkGD4'9_v "uChar#" uDoubleHashValName :: Name uDoubleHashValName = mkGD4'9_v "uDouble#" uFloatHashValName :: Name uFloatHashValName = mkGD4'9_v "uFloat#" uIntHashValName :: Name uIntHashValName = mkGD4'9_v "uInt#" uWordHashValName :: Name uWordHashValName = mkGD4'9_v "uWord#" unComp1ValName :: Name unComp1ValName = mkGD4'4_v "unComp1" unK1ValName :: Name unK1ValName = mkGD4'4_v "unK1" unPar1ValName :: Name unPar1ValName = mkGD4'4_v "unPar1" unRec1ValName :: Name unRec1ValName = mkGD4'4_v "unRec1" trueDataName, falseDataName :: Name #if MIN_VERSION_base(4,4,0) trueDataName = mkGHCPrimName_d "GHC.Types" "True" falseDataName = mkGHCPrimName_d "GHC.Types" "False" #else trueDataName = mkGHCPrimName_d "GHC.Bool" "True" falseDataName = mkGHCPrimName_d "GHC.Bool" "False" #endif nothingDataName, justDataName :: Name #if MIN_VERSION_base(4,8,0) nothingDataName = mkBaseName_d "GHC.Base" "Nothing" justDataName = mkBaseName_d "GHC.Base" "Just" #else nothingDataName = mkBaseName_d "Data.Maybe" "Nothing" justDataName = mkBaseName_d "Data.Maybe" "Just" #endif mkGHCPrim_tc :: String -> Name mkGHCPrim_tc = mkNameG_tc "ghc-prim" "GHC.Prim" addrHashTypeName :: Name addrHashTypeName = mkGHCPrim_tc "Addr#" charHashTypeName :: Name charHashTypeName = mkGHCPrim_tc "Char#" doubleHashTypeName :: Name doubleHashTypeName = mkGHCPrim_tc "Double#" floatHashTypeName :: Name floatHashTypeName = mkGHCPrim_tc "Float#" intHashTypeName :: Name intHashTypeName = mkGHCPrim_tc "Int#" wordHashTypeName :: Name wordHashTypeName = mkGHCPrim_tc "Word#" composeValName :: Name composeValName = mkNameG_v "base" "GHC.Base" "." errorValName :: Name errorValName = mkNameG_v "base" "GHC.Err" "error" fmapValName :: Name fmapValName = mkNameG_v "base" "GHC.Base" "fmap" undefinedValName :: Name undefinedValName = mkNameG_v "base" "GHC.Err" "undefined" starKindName :: Name starKindName = mkGHCPrimName_tc "GHC.Prim" "*" decidedLazyDataName :: Name decidedLazyDataName = mkGD4'9_d "DecidedLazy" decidedStrictDataName :: Name decidedStrictDataName = mkGD4'9_d "DecidedStrict" decidedUnpackDataName :: Name decidedUnpackDataName = mkGD4'9_d "DecidedUnpack" infixIDataName :: Name infixIDataName = mkGD4'9_d "InfixI" metaConsDataName :: Name metaConsDataName = mkGD4'9_d "MetaCons" metaDataDataName :: Name metaDataDataName = mkGD4'9_d "MetaData" metaNoSelDataName :: Name metaNoSelDataName = mkGD4'9_d "MetaNoSel" metaSelDataName :: Name metaSelDataName = mkGD4'9_d "MetaSel" noSourceStrictnessDataName :: Name noSourceStrictnessDataName = mkGD4'9_d "NoSourceStrictness" noSourceUnpackednessDataName :: Name noSourceUnpackednessDataName = mkGD4'9_d "NoSourceUnpackedness" prefixIDataName :: Name prefixIDataName = mkGD4'9_d "PrefixI" sourceLazyDataName :: Name sourceLazyDataName = mkGD4'9_d "SourceLazy" sourceNoUnpackDataName :: Name sourceNoUnpackDataName = mkGD4'9_d "SourceNoUnpack" sourceStrictDataName :: Name sourceStrictDataName = mkGD4'9_d "SourceStrict" sourceUnpackDataName :: Name sourceUnpackDataName = mkGD4'9_d "SourceUnpack" packageNameValName :: Name packageNameValName = mkGD4'4_v "packageName" generic-deriving-1.11.1/src/Generics/Deriving/Base/0000755000000000000000000000000012765116253020161 5ustar0000000000000000generic-deriving-1.11.1/src/Generics/Deriving/Base/Internal.hs0000644000000000000000000010323212765116253022272 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} #if __GLASGOW_HASKELL__ >= 711 {-# LANGUAGE Safe #-} #elif __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE Trustworthy #-} #endif module Generics.Deriving.Base.Internal ( -- * Introduction -- -- | -- -- Datatype-generic functions are are based on the idea of converting values of -- a datatype @T@ into corresponding values of a (nearly) isomorphic type @'Rep' T@. -- The type @'Rep' T@ is -- built from a limited set of type constructors, all provided by this module. A -- datatype-generic function is then an overloaded function with instances -- for most of these type constructors, together with a wrapper that performs -- the mapping between @T@ and @'Rep' T@. By using this technique, we merely need -- a few generic instances in order to implement functionality that works for any -- representable type. -- -- Representable types are collected in the 'Generic' class, which defines the -- associated type 'Rep' as well as conversion functions 'from' and 'to'. -- Typically, you will not define 'Generic' instances by hand, but have the compiler -- derive them for you. -- ** Representing datatypes -- -- | -- -- The key to defining your own datatype-generic functions is to understand how to -- represent datatypes using the given set of type constructors. -- -- Let us look at an example first: -- -- @ -- data Tree a = Leaf a | Node (Tree a) (Tree a) -- deriving 'Generic' -- @ -- -- The above declaration (which requires the language pragma @DeriveGeneric@) -- causes the following representation to be generated: -- -- @ -- class 'Generic' (Tree a) where -- type 'Rep' (Tree a) = -- 'D1' D1Tree -- ('C1' C1_0Tree -- ('S1' 'NoSelector' ('Par0' a)) -- ':+:' -- 'C1' C1_1Tree -- ('S1' 'NoSelector' ('Rec0' (Tree a)) -- ':*:' -- 'S1' 'NoSelector' ('Rec0' (Tree a)))) -- ... -- @ -- -- /Hint:/ You can obtain information about the code being generated from GHC by passing -- the @-ddump-deriv@ flag. In GHCi, you can expand a type family such as 'Rep' using -- the @:kind!@ command. -- #if 0 -- /TODO:/ Newer GHC versions abandon the distinction between 'Par0' and 'Rec0' and will -- use 'Rec0' everywhere. -- #endif -- This is a lot of information! However, most of it is actually merely meta-information -- that makes names of datatypes and constructors and more available on the type level. -- -- Here is a reduced representation for 'Tree' with nearly all meta-information removed, -- for now keeping only the most essential aspects: -- -- @ -- instance 'Generic' (Tree a) where -- type 'Rep' (Tree a) = -- 'Par0' a -- ':+:' -- ('Rec0' (Tree a) ':*:' 'Rec0' (Tree a)) -- @ -- -- The @Tree@ datatype has two constructors. The representation of individual constructors -- is combined using the binary type constructor ':+:'. -- -- The first constructor consists of a single field, which is the parameter @a@. This is -- represented as @'Par0' a@. -- -- The second constructor consists of two fields. Each is a recursive field of type @Tree a@, -- represented as @'Rec0' (Tree a)@. Representations of individual fields are combined using -- the binary type constructor ':*:'. -- -- Now let us explain the additional tags being used in the complete representation: -- -- * The @'S1' 'NoSelector'@ indicates that there is no record field selector associated with -- this field of the constructor. -- -- * The @'C1' C1_0Tree@ and @'C1' C1_1Tree@ invocations indicate that the enclosed part is -- the representation of the first and second constructor of datatype @Tree@, respectively. -- Here, @C1_0Tree@ and @C1_1Tree@ are datatypes generated by the compiler as part of -- @deriving 'Generic'@. These datatypes are proxy types with no values. They are useful -- because they are instances of the type class 'Constructor'. This type class can be used -- to obtain information about the constructor in question, such as its name -- or infix priority. -- -- * The @'D1' D1Tree@ tag indicates that the enclosed part is the representation of the -- datatype @Tree@. Again, @D1Tree@ is a datatype generated by the compiler. It is a -- proxy type, and is useful by being an instance of class 'Datatype', which -- can be used to obtain the name of a datatype, the module it has been defined in, and -- whether it has been defined using @data@ or @newtype@. -- ** Derived and fundamental representation types -- -- | -- -- There are many datatype-generic functions that do not distinguish between positions that -- are parameters or positions that are recursive calls. There are also many datatype-generic -- functions that do not care about the names of datatypes and constructors at all. To keep -- the number of cases to consider in generic functions in such a situation to a minimum, -- it turns out that many of the type constructors introduced above are actually synonyms, -- defining them to be variants of a smaller set of constructors. -- *** Individual fields of constructors: 'K1' -- -- | -- -- The type constructors 'Par0' and 'Rec0' are variants of 'K1': -- -- @ -- type 'Par0' = 'K1' 'P' -- type 'Rec0' = 'K1' 'R' -- @ -- -- Here, 'P' and 'R' are type-level proxies again that do not have any associated values. -- *** Meta information: 'M1' -- -- | -- -- The type constructors 'S1', 'C1' and 'D1' are all variants of 'M1': -- -- @ -- type 'S1' = 'M1' 'S' -- type 'C1' = 'M1' 'C' -- type 'D1' = 'M1' 'D' -- @ -- -- The types 'S', 'C' and 'R' are once again type-level proxies, just used to create -- several variants of 'M1'. -- *** Additional generic representation type constructors -- -- | -- -- Next to 'K1', 'M1', ':+:' and ':*:' there are a few more type constructors that occur -- in the representations of other datatypes. -- **** Empty datatypes: 'V1' -- -- | -- -- For empty datatypes, 'V1' is used as a representation. For example, -- -- @ -- data Empty deriving 'Generic' -- @ -- -- yields -- -- @ -- instance 'Generic' Empty where -- type 'Rep' Empty = 'D1' D1Empty 'V1' -- @ -- **** Constructors without fields: 'U1' -- -- | -- -- If a constructor has no arguments, then 'U1' is used as its representation. For example -- the representation of 'Bool' is -- -- @ -- instance 'Generic' Bool where -- type 'Rep' Bool = -- 'D1' D1Bool -- ('C1' C1_0Bool 'U1' ':+:' 'C1' C1_1Bool 'U1') -- @ -- *** Representation of types with many constructors or many fields -- -- | -- -- As ':+:' and ':*:' are just binary operators, one might ask what happens if the -- datatype has more than two constructors, or a constructor with more than two -- fields. The answer is simple: the operators are used several times, to combine -- all the constructors and fields as needed. However, users /should not rely on -- a specific nesting strategy/ for ':+:' and ':*:' being used. The compiler is -- free to choose any nesting it prefers. (In practice, the current implementation -- tries to produce a more or less balanced nesting, so that the traversal of the -- structure of the datatype from the root to a particular component can be performed -- in logarithmic rather than linear time.) -- ** Defining datatype-generic functions -- -- | -- -- A datatype-generic function comprises two parts: -- -- 1. /Generic instances/ for the function, implementing it for most of the representation -- type constructors introduced above. -- -- 2. A /wrapper/ that for any datatype that is in `Generic`, performs the conversion -- between the original value and its `Rep`-based representation and then invokes the -- generic instances. -- -- As an example, let us look at a function 'encode' that produces a naive, but lossless -- bit encoding of values of various datatypes. So we are aiming to define a function -- -- @ -- encode :: 'Generic' a => a -> [Bool] -- @ -- -- where we use 'Bool' as our datatype for bits. -- -- For part 1, we define a class @Encode'@. Perhaps surprisingly, this class is parameterized -- over a type constructor @f@ of kind @* -> *@. This is a technicality: all the representation -- type constructors operate with kind @* -> *@ as base kind. But the type argument is never -- being used. This may be changed at some point in the future. The class has a single method, -- and we use the type we want our final function to have, but we replace the occurrences of -- the generic type argument @a@ with @f p@ (where the @p@ is any argument; it will not be used). -- -- > class Encode' f where -- > encode' :: f p -> [Bool] -- -- With the goal in mind to make @encode@ work on @Tree@ and other datatypes, we now define -- instances for the representation type constructors 'V1', 'U1', ':+:', ':*:', 'K1', and 'M1'. -- *** Definition of the generic representation types -- -- | -- -- In order to be able to do this, we need to know the actual definitions of these types: -- -- @ -- data 'V1' p -- lifted version of Empty -- data 'U1' p = 'U1' -- lifted version of () -- data (':+:') f g p = 'L1' (f p) | 'R1' (g p) -- lifted version of 'Either' -- data (':*:') f g p = (f p) ':*:' (g p) -- lifted version of (,) -- newtype 'K1' i c p = 'K1' { 'unK1' :: c } -- a container for a c -- newtype 'M1' i t f p = 'M1' { 'unM1' :: f p } -- a wrapper -- @ -- -- So, 'U1' is just the unit type, ':+:' is just a binary choice like 'Either', -- ':*:' is a binary pair like the pair constructor @(,)@, and 'K1' is a value -- of a specific type @c@, and 'M1' wraps a value of the generic type argument, -- which in the lifted world is an @f p@ (where we do not care about @p@). -- *** Generic instances -- -- | -- -- The instance for 'V1' is slightly awkward (but also rarely used): -- -- @ -- instance Encode' 'V1' where -- encode' x = undefined -- @ -- -- There are no values of type @V1 p@ to pass (except undefined), so this is -- actually impossible. One can ask why it is useful to define an instance for -- 'V1' at all in this case? Well, an empty type can be used as an argument to -- a non-empty type, and you might still want to encode the resulting type. -- As a somewhat contrived example, consider @[Empty]@, which is not an empty -- type, but contains just the empty list. The 'V1' instance ensures that we -- can call the generic function on such types. -- -- There is exactly one value of type 'U1', so encoding it requires no -- knowledge, and we can use zero bits: -- -- @ -- instance Encode' 'U1' where -- encode' 'U1' = [] -- @ -- -- In the case for ':+:', we produce 'False' or 'True' depending on whether -- the constructor of the value provided is located on the left or on the right: -- -- @ -- instance (Encode' f, Encode' g) => Encode' (f ':+:' g) where -- encode' ('L1' x) = False : encode' x -- encode' ('R1' x) = True : encode' x -- @ -- -- In the case for ':*:', we append the encodings of the two subcomponents: -- -- @ -- instance (Encode' f, Encode' g) => Encode' (f ':*:' g) where -- encode' (x ':*:' y) = encode' x ++ encode' y -- @ -- -- The case for 'K1' is rather interesting. Here, we call the final function -- 'encode' that we yet have to define, recursively. We will use another type -- class 'Encode' for that function: -- -- @ -- instance (Encode c) => Encode' ('K1' i c) where -- encode' ('K1' x) = encode x -- @ -- -- Note how 'Par0' and 'Rec0' both being mapped to 'K1' allows us to define -- a uniform instance here. -- -- Similarly, we can define a uniform instance for 'M1', because we completely -- disregard all meta-information: -- -- @ -- instance (Encode' f) => Encode' ('M1' i t f) where -- encode' ('M1' x) = encode' x -- @ -- -- Unlike in 'K1', the instance for 'M1' refers to 'encode'', not 'encode'. -- *** The wrapper and generic default -- -- | -- -- We now define class 'Encode' for the actual 'encode' function: -- -- @ -- class Encode a where -- encode :: a -> [Bool] -- default encode :: ('Generic' a) => a -> [Bool] -- encode x = encode' ('from' x) -- @ -- -- The incoming 'x' is converted using 'from', then we dispatch to the -- generic instances using 'encode''. We use this as a default definition -- for 'encode'. We need the 'default encode' signature because ordinary -- Haskell default methods must not introduce additional class constraints, -- but our generic default does. -- -- Defining a particular instance is now as simple as saying -- -- @ -- instance (Encode a) => Encode (Tree a) -- @ -- #if 0 -- /TODO:/ Add usage example? -- #endif -- The generic default is being used. In the future, it will hopefully be -- possible to use @deriving Encode@ as well, but GHC does not yet support -- that syntax for this situation. -- -- Having 'Encode' as a class has the advantage that we can define -- non-generic special cases, which is particularly useful for abstract -- datatypes that have no structural representation. For example, given -- a suitable integer encoding function 'encodeInt', we can define -- -- @ -- instance Encode Int where -- encode = encodeInt -- @ -- *** Omitting generic instances -- -- | -- -- It is not always required to provide instances for all the generic -- representation types, but omitting instances restricts the set of -- datatypes the functions will work for: -- -- * If no ':+:' instance is given, the function may still work for -- empty datatypes or datatypes that have a single constructor, -- but will fail on datatypes with more than one constructor. -- -- * If no ':*:' instance is given, the function may still work for -- datatypes where each constructor has just zero or one field, -- in particular for enumeration types. -- -- * If no 'K1' instance is given, the function may still work for -- enumeration types, where no constructor has any fields. -- -- * If no 'V1' instance is given, the function may still work for -- any datatype that is not empty. -- -- * If no 'U1' instance is given, the function may still work for -- any datatype where each constructor has at least one field. -- -- An 'M1' instance is always required (but it can just ignore the -- meta-information, as is the case for 'encode' above). #if 0 -- *** Using meta-information -- -- | -- -- TODO #endif -- ** Generic constructor classes -- -- | -- -- Datatype-generic functions as defined above work for a large class -- of datatypes, including parameterized datatypes. (We have used 'Tree' -- as our example above, which is of kind @* -> *@.) However, the -- 'Generic' class ranges over types of kind @*@, and therefore, the -- resulting generic functions (such as 'encode') must be parameterized -- by a generic type argument of kind @*@. -- -- What if we want to define generic classes that range over type -- constructors (such as 'Functor', 'Traversable', or 'Foldable')? -- *** The 'Generic1' class -- -- | -- -- Like 'Generic', there is a class 'Generic1' that defines a -- representation 'Rep1' and conversion functions 'from1' and 'to1', -- only that 'Generic1' ranges over types of kind @* -> *@. -- The 'Generic1' class is also derivable. -- -- The representation 'Rep1' is ever so slightly different from 'Rep'. -- Let us look at 'Tree' as an example again: -- -- @ -- data Tree a = Leaf a | Node (Tree a) (Tree a) -- deriving 'Generic1' -- @ -- -- The above declaration causes the following representation to be generated: -- -- class 'Generic1' Tree where -- type 'Rep1' Tree = -- 'D1' D1Tree -- ('C1' C1_0Tree -- ('S1' 'NoSelector' 'Par1') -- ':+:' -- 'C1' C1_1Tree -- ('S1' 'NoSelector' ('Rec1' Tree) -- ':*:' -- 'S1' 'NoSelector' ('Rec1' Tree))) -- ... -- -- The representation reuses 'D1', 'C1', 'S1' (and thereby 'M1') as well -- as ':+:' and ':*:' from 'Rep'. (This reusability is the reason that we -- carry around the dummy type argument for kind-@*@-types, but there are -- already enough different names involved without duplicating each of -- these.) -- -- What's different is that we now use 'Par1' to refer to the parameter -- (and that parameter, which used to be @a@), is not mentioned explicitly -- by name anywhere; and we use 'Rec1' to refer to a recursive use of @Tree a@. -- *** Representation of @* -> *@ types -- -- | -- -- Unlike 'Par0' and 'Rec0', the 'Par1' and 'Rec1' type constructors do not -- map to 'K1'. They are defined directly, as follows: -- -- @ -- newtype 'Par1' p = 'Par1' { 'unPar1' :: p } -- gives access to parameter p -- newtype 'Rec1' f p = 'Rec1' { 'unRec1' :: f p } -- a wrapper -- @ -- -- In 'Par1', the parameter @p@ is used for the first time, whereas 'Rec1' simply -- wraps an application of @f@ to @p@. -- -- Note that 'K1' (in the guise of 'Rec0') can still occur in a 'Rep1' representation, -- namely when the datatype has a field that does not mention the parameter. -- -- The declaration -- -- @ -- data WithInt a = WithInt Int a -- deriving 'Generic1' -- @ -- -- yields -- -- @ -- class 'Rep1' WithInt where -- type 'Rep1' WithInt = -- 'D1' D1WithInt -- ('C1' C1_0WithInt -- ('S1' 'NoSelector' ('Rec0' Int) -- ':*:' -- 'S1' 'NoSelector' 'Par1')) -- @ -- -- If the parameter @a@ appears underneath a composition of other type constructors, -- then the representation involves composition, too: -- -- @ -- data Rose a = Fork a [Rose a] -- @ -- -- yields -- -- @ -- class 'Rep1' Rose where -- type 'Rep1' Rose = -- 'D1' D1Rose -- ('C1' C1_0Rose -- ('S1' 'NoSelector' 'Par1' -- ':*:' -- 'S1' 'NoSelector' ([] ':.:' 'Rec1' Rose) -- @ -- -- where -- -- @ -- newtype (':.:') f g p = 'Comp1' { 'unComp1' :: f (g p) } -- @ -- *** Representation of unlifted types -- -- | -- -- If one were to attempt to derive a Generic instance for a datatype with an -- unlifted argument (for example, 'Int#'), one might expect the occurrence of -- the 'Int#' argument to be marked with @'Rec0' 'Int#'@. This won't work, -- though, since 'Int#' is of kind @#@ and 'Rec0' expects a type of kind @*@. -- In fact, polymorphism over unlifted types is disallowed completely. -- -- One solution would be to represent an occurrence of 'Int#' with 'Rec0 Int' -- instead. With this approach, however, the programmer has no way of knowing -- whether the 'Int' is actually an 'Int#' in disguise. -- -- Instead of reusing 'Rec0', a separate data family 'URec' is used to mark -- occurrences of common unlifted types: -- -- @ -- data family URec a p -- -- data instance 'URec' ('Ptr' ()) p = 'UAddr' { 'uAddr#' :: 'Addr#' } -- data instance 'URec' 'Char' p = 'UChar' { 'uChar#' :: 'Char#' } -- data instance 'URec' 'Double' p = 'UDouble' { 'uDouble#' :: 'Double#' } -- data instance 'URec' 'Int' p = 'UFloat' { 'uFloat#' :: 'Float#' } -- data instance 'URec' 'Float' p = 'UInt' { 'uInt#' :: 'Int#' } -- data instance 'URec' 'Word' p = 'UWord' { 'uWord#' :: 'Word#' } -- @ -- -- Several type synonyms are provided for convenience: -- -- @ -- type 'UAddr' = 'URec' ('Ptr' ()) -- type 'UChar' = 'URec' 'Char' -- type 'UDouble' = 'URec' 'Double' -- type 'UFloat' = 'URec' 'Float' -- type 'UInt' = 'URec' 'Int' -- type 'UWord' = 'URec' 'Word' -- @ -- -- The declaration -- -- @ -- data IntHash = IntHash Int# -- deriving 'Generic' -- @ -- -- yields -- -- @ -- instance 'Generic' IntHash where -- type 'Rep' IntHash = -- 'D1' D1IntHash -- ('C1' C1_0IntHash -- ('S1' 'NoSelector' 'UInt')) -- @ -- -- Currently, only the six unlifted types listed above are generated, but this -- may be extended to encompass more unlifted types in the future. #if 0 -- *** Limitations -- -- | -- -- /TODO/ -- -- /TODO:/ Also clear up confusion about 'Rec0' and 'Rec1' not really indicating recursion. -- #endif #if !(MIN_VERSION_base(4,4,0)) -- * 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 !(MIN_VERSION_base(4,9,0)) -- ** Unboxed representation types URec(..), UAddr, UChar, UDouble, UFloat, UInt, UWord #endif ) where #if MIN_VERSION_base(4,4,0) import GHC.Generics #else import Control.Applicative ( Alternative(..) ) import Control.Monad ( MonadPlus(..) ) import Control.Monad.Fix ( MonadFix(..), fix ) import Data.Data ( Data ) import Data.Ix ( Ix ) import Text.ParserCombinators.ReadPrec (pfail) import Text.Read ( Read(..), parens, readListDefault, readListPrecDefault ) #endif #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative ( Applicative(..) ) import Data.Foldable ( Foldable(..) ) import Data.Monoid ( Monoid(..) ) import Data.Traversable ( Traversable(..) ) import Data.Word ( Word ) #endif #if !(MIN_VERSION_base(4,9,0)) import Data.Typeable import GHC.Prim ( Addr#, Char#, Double#, Float#, Int#, Word# ) import GHC.Ptr ( Ptr ) #endif #if !(MIN_VERSION_base(4,4,0)) -------------------------------------------------------------------------------- -- Representation types -------------------------------------------------------------------------------- -- | Void: used for datatypes without constructors data V1 p deriving (Functor, Foldable, Traversable, Typeable) deriving instance Eq (V1 p) deriving instance Data p => Data (V1 p) deriving instance Ord (V1 p) deriving instance Show (V1 p) -- Implement Read instance manually to get around an old GHC bug -- (Trac #7931) instance Read (V1 p) where readPrec = parens pfail readList = readListDefault readListPrec = readListPrecDefault -- | Unit: used for constructors without arguments data U1 p = U1 deriving (Eq, Ord, Read, Show, Data, Typeable) instance Functor U1 where fmap _ _ = U1 instance Applicative U1 where pure _ = U1 _ <*> _ = U1 instance Alternative U1 where empty = U1 _ <|> _ = U1 instance Monad U1 where return _ = U1 _ >>= _ = U1 instance MonadPlus U1 where mzero = U1 mplus _ _ = U1 instance Foldable U1 where foldMap _ _ = mempty {-# INLINE foldMap #-} fold _ = mempty {-# INLINE fold #-} foldr _ z _ = z {-# INLINE foldr #-} foldl _ z _ = z {-# INLINE foldl #-} foldl1 _ _ = error "foldl1: U1" foldr1 _ _ = error "foldr1: U1" instance Traversable U1 where traverse _ _ = pure U1 {-# INLINE traverse #-} sequenceA _ = pure U1 {-# INLINE sequenceA #-} mapM _ _ = return U1 {-# INLINE mapM #-} sequence _ = return U1 {-# INLINE sequence #-} -- | Used for marking occurrences of the parameter newtype Par1 p = Par1 { unPar1 :: p } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data, Typeable) instance Applicative Par1 where pure a = Par1 a Par1 f <*> Par1 x = Par1 (f x) instance Monad Par1 where return a = Par1 a Par1 x >>= f = f x instance MonadFix Par1 where mfix f = Par1 (fix (unPar1 . f)) -- | Recursive calls of kind * -> * newtype Rec1 f p = Rec1 { unRec1 :: f p } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data) instance Typeable1 f => Typeable1 (Rec1 f) where typeOf1 t = mkTyConApp rec1TyCon [typeOf1 (f t)] where f :: Rec1 f a -> f a f = undefined rec1TyCon :: TyCon rec1TyCon = mkTyCon "Generics.Deriving.Base.Internal.Rec1" instance Applicative f => Applicative (Rec1 f) where pure a = Rec1 (pure a) Rec1 f <*> Rec1 x = Rec1 (f <*> x) instance Alternative f => Alternative (Rec1 f) where empty = Rec1 empty Rec1 l <|> Rec1 r = Rec1 (l <|> r) instance Monad f => Monad (Rec1 f) where return a = Rec1 (return a) Rec1 x >>= f = Rec1 (x >>= \a -> unRec1 (f a)) instance MonadFix f => MonadFix (Rec1 f) where mfix f = Rec1 (mfix (unRec1 . f)) instance MonadPlus f => MonadPlus (Rec1 f) where mzero = Rec1 mzero mplus (Rec1 a) (Rec1 b) = Rec1 (mplus a b) -- | Constants, additional parameters and recursion of kind * newtype K1 i c p = K1 { unK1 :: c } deriving (Eq, Ord, Read, Show, Functor, Data, Typeable) instance Foldable (K1 i c) where foldr _ z K1{} = z foldMap _ K1{} = mempty instance Traversable (K1 i c) where traverse _ (K1 c) = pure (K1 c) -- | Meta-information (constructor names, etc.) newtype M1 i c f p = M1 { unM1 :: f p } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data) instance (Typeable i, Typeable c, Typeable1 f) => Typeable1 (M1 i c f) where typeOf1 t = mkTyConApp m1TyCon [typeOf (i t), typeOf (c t), typeOf1 (f t)] where i :: M1 i c f p -> i i = undefined c :: M1 i c f p -> c c = undefined f :: M1 i c f p -> f p f = undefined m1TyCon :: TyCon m1TyCon = mkTyCon "Generics.Deriving.Base.Internal.M1" instance Applicative f => Applicative (M1 i c f) where pure a = M1 (pure a) M1 f <*> M1 x = M1 (f <*> x) instance Alternative f => Alternative (M1 i c f) where empty = M1 empty M1 l <|> M1 r = M1 (l <|> r) instance Monad f => Monad (M1 i c f) where return a = M1 (return a) M1 x >>= f = M1 (x >>= \a -> unM1 (f a)) instance MonadPlus f => MonadPlus (M1 i c f) where mzero = M1 mzero mplus (M1 a) (M1 b) = M1 (mplus a b) instance MonadFix f => MonadFix (M1 i c f) where mfix f = M1 (mfix (unM1. f)) -- | Sums: encode choice between constructors infixr 5 :+: data (:+:) f g p = L1 (f p) | R1 (g p) deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data) instance (Typeable1 f, Typeable1 g) => Typeable1 (f :+: g) where typeOf1 t = mkTyConApp conSumTyCon [typeOf1 (f t), typeOf1 (g t)] where f :: (f :+: g) p -> f p f = undefined g :: (f :+: g) p -> g p g = undefined conSumTyCon :: TyCon conSumTyCon = mkTyCon "Generics.Deriving.Base.Internal.:+:" -- | Products: encode multiple arguments to constructors infixr 6 :*: data (:*:) f g p = f p :*: g p deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data) instance (Typeable1 f, Typeable1 g) => Typeable1 (f :*: g) where typeOf1 t = mkTyConApp conProductTyCon [typeOf1 (f t), typeOf1 (g t)] where f :: (f :*: g) p -> f p f = undefined g :: (f :*: g) p -> g p g = undefined conProductTyCon :: TyCon conProductTyCon = mkTyCon "Generics.Deriving.Base.Internal.:*:" instance (Applicative f, Applicative g) => Applicative (f :*: g) where pure a = pure a :*: pure a (f :*: g) <*> (x :*: y) = (f <*> x) :*: (g <*> y) instance (Alternative f, Alternative g) => Alternative (f :*: g) where empty = empty :*: empty (x1 :*: y1) <|> (x2 :*: y2) = (x1 <|> x2) :*: (y1 <|> y2) instance (Monad f, Monad g) => Monad (f :*: g) where return a = return a :*: return a (m :*: n) >>= f = (m >>= \a -> fstP (f a)) :*: (n >>= \a -> sndP (f a)) where fstP (a :*: _) = a sndP (_ :*: b) = b instance (MonadFix f, MonadFix g) => MonadFix (f :*: g) where mfix f = (mfix (fstP . f)) :*: (mfix (sndP . f)) where fstP (a :*: _) = a sndP (_ :*: b) = b instance (MonadPlus f, MonadPlus g) => MonadPlus (f :*: g) where mzero = mzero :*: mzero (x1 :*: y1) `mplus` (x2 :*: y2) = (x1 `mplus` x2) :*: (y1 `mplus` y2) -- | Composition of functors infixr 7 :.: newtype (:.:) f g p = Comp1 { unComp1 :: f (g p) } deriving (Eq, Ord, Read, Show, Functor, Foldable, Traversable, Data) instance (Typeable1 f, Typeable1 g) => Typeable1 (f :.: g) where typeOf1 t = mkTyConApp conComposeTyCon [typeOf1 (f t), typeOf1 (g t)] where f :: (f :.: g) p -> f p f = undefined g :: (f :.: g) p -> g p g = undefined conComposeTyCon :: TyCon conComposeTyCon = mkTyCon "Generics.Deriving.Base.Internal.:.:" instance (Applicative f, Applicative g) => Applicative (f :.: g) where pure x = Comp1 (pure (pure x)) Comp1 f <*> Comp1 x = Comp1 (fmap (<*>) f <*> x) instance (Alternative f, Applicative g) => Alternative (f :.: g) where empty = Comp1 empty Comp1 x <|> Comp1 y = Comp1 (x <|> y) -- | Tag for K1: recursion (of kind *) data R deriving Typeable -- | Tag for K1: parameters (other than the last) data P deriving Typeable -- | 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 deriving Typeable -- | Tag for M1: constructor data C deriving Typeable -- | Tag for M1: record selector data S deriving Typeable -- | 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 deriving Typeable 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, Typeable) -- | 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, Data, Typeable) -- | 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, Bounded, Enum, Ix, Data, Typeable) -- | 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 !(MIN_VERSION_base(4,9,0)) -- | Constants of kind @#@ data family URec (a :: *) (p :: *) # if MIN_VERSION_base(4,7,0) deriving instance Typeable URec # else instance Typeable2 URec where typeOf2 _ = # if MIN_VERSION_base(4,4,0) mkTyConApp (mkTyCon3 "generic-deriving" "Generics.Deriving.Base.Internal" "URec") [] # else mkTyConApp (mkTyCon "Generics.Deriving.Base.Internal.URec") [] # endif # endif -- | Used for marking occurrences of 'Addr#' data instance URec (Ptr ()) p = UAddr { uAddr# :: Addr# } deriving (Eq, Ord) instance Functor (URec (Ptr ())) where fmap _ (UAddr a) = UAddr a instance Foldable (URec (Ptr ())) where foldr _ z UAddr{} = z foldMap _ UAddr{} = mempty instance Traversable (URec (Ptr ())) where traverse _ (UAddr a) = pure (UAddr a) -- | Used for marking occurrences of 'Char#' data instance URec Char p = UChar { uChar# :: Char# } deriving (Eq, Ord, Show) instance Functor (URec Char) where fmap _ (UChar c) = UChar c instance Foldable (URec Char) where foldr _ z UChar{} = z foldMap _ UChar{} = mempty instance Traversable (URec Char) where traverse _ (UChar c) = pure (UChar c) -- | Used for marking occurrences of 'Double#' data instance URec Double p = UDouble { uDouble# :: Double# } deriving (Eq, Ord, Show) instance Functor (URec Double) where fmap _ (UDouble d) = UDouble d instance Foldable (URec Double) where foldr _ z UDouble{} = z foldMap _ UDouble{} = mempty instance Traversable (URec Double) where traverse _ (UDouble d) = pure (UDouble d) -- | Used for marking occurrences of 'Float#' data instance URec Float p = UFloat { uFloat# :: Float# } deriving (Eq, Ord, Show) instance Functor (URec Float) where fmap _ (UFloat f) = UFloat f instance Foldable (URec Float) where foldr _ z UFloat{} = z foldMap _ UFloat{} = mempty instance Traversable (URec Float) where traverse _ (UFloat f) = pure (UFloat f) -- | Used for marking occurrences of 'Int#' data instance URec Int p = UInt { uInt# :: Int# } deriving (Eq, Ord, Show) instance Functor (URec Int) where fmap _ (UInt i) = UInt i instance Foldable (URec Int) where foldr _ z UInt{} = z foldMap _ UInt{} = mempty instance Traversable (URec Int) where traverse _ (UInt i) = pure (UInt i) -- | Used for marking occurrences of 'Word#' data instance URec Word p = UWord { uWord# :: Word# } deriving (Eq, Ord, Show) instance Functor (URec Word) where fmap _ (UWord w) = UWord w instance Foldable (URec Word) where foldr _ z UWord{} = z foldMap _ UWord{} = mempty instance Traversable (URec Word) where traverse _ (UWord w) = pure (UWord w) -- | 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