deriving-compat-0.3.4/0000755000000000000000000000000013002245656012777 5ustar0000000000000000deriving-compat-0.3.4/deriving-compat.cabal0000644000000000000000000001574013002245656017062 0ustar0000000000000000name: deriving-compat version: 0.3.4 synopsis: Backports of GHC deriving extensions description: Provides Template Haskell functions that mimic deriving extensions that were introduced or modified in recent versions of GHC. Currently, the following typeclasses/extensions are covered: . * Deriving @Bounded@ . * Deriving @Enum@ . * Deriving @Ix@ . * Deriving @Eq@, @Eq1@, and @Eq2@ . * Deriving @Ord@, @Ord1@, and @Ord2@ . * Deriving @Read@, @Read1@, and @Read2@ . * Deriving @Show@, @Show1@, and @Show2@ . * @DeriveFoldable@ . * @DeriveFunctor@ . * @DeriveTraversable@ . See the "Data.Deriving" module for a full list of backported changes. . Note that some recent GHC typeclasses/extensions are not covered by this package: . * @DeriveDataTypeable@ . * @DeriveGeneric@, which was introducted in GHC 7.2 for deriving @Generic@ instances, and modified in GHC 7.6 to allow derivation of @Generic1@ instances. Use @Generics.Deriving.TH@ from @@ to derive @Generic(1)@ using Template Haskell. . * @DeriveLift@, which was introduced in GHC 8.0 for deriving @Lift@ instances. Use @Language.Haskell.TH.Lift@ from @@ to derive @Lift@ using Template Haskell. . * The @Bifunctor@ typeclass, which was introduced in GHC 7.10, as well as the @Bifoldable@ and @Bitraversable@ typeclasses, which were introduced in GHC 8.2. Use @Data.Bifunctor.TH@ from @@ to derive these typeclasses using Template Haskell. homepage: https://github.com/haskell-compat/deriving-compat bug-reports: https://github.com/haskell-compat/deriving-compat/issues license: BSD3 license-file: LICENSE author: Ryan Scott maintainer: Ryan Scott stability: Experimental copyright: (C) 2015-2016 Ryan Scott category: Compatibility build-type: Simple extra-source-files: CHANGELOG.md, README.md 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 cabal-version: >=1.10 source-repository head type: git location: https://github.com/haskell-compat/deriving-compat flag base-4-9 description: Use base-4.9 or later. default: True flag template-haskell-2-11 description: Use template-haskell-2.11.0.0 or later. default: True flag new-functor-classes description: Use a version of transformers or transformers-compat with a modern-style Data.Functor.Classes module. This flag cannot be used when building with transformers-0.4, since it comes with a different version of Data.Functor.Classes. default: True library exposed-modules: Data.Deriving Data.Bounded.Deriving Data.Enum.Deriving Data.Eq.Deriving Data.Foldable.Deriving Data.Functor.Deriving Data.Ix.Deriving Data.Ord.Deriving Data.Traversable.Deriving Text.Read.Deriving Text.Show.Deriving other-modules: Data.Deriving.Internal Data.Bounded.Deriving.Internal Data.Enum.Deriving.Internal Data.Eq.Deriving.Internal Data.Functor.Deriving.Internal Data.Ix.Deriving.Internal Data.Ord.Deriving.Internal Text.Read.Deriving.Internal Text.Show.Deriving.Internal Paths_deriving_compat build-depends: containers >= 0.1 && < 0.6 , ghc-prim if flag(base-4-9) build-depends: base >= 4.9 && < 5 cpp-options: "-DNEW_FUNCTOR_CLASSES" else build-depends: base >= 4.3 && < 4.9 if flag(template-haskell-2-11) build-depends: template-haskell >= 2.11 && < 2.12 , ghc-boot-th else build-depends: template-haskell >= 2.5 && < 2.11 if flag(new-functor-classes) build-depends: transformers (>= 0.2 && < 0.4) || >= 0.5 , transformers-compat >= 0.5 cpp-options: "-DNEW_FUNCTOR_CLASSES" else build-depends: transformers == 0.4.* hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: BoundedEnumIxSpec EqSpec FunctorSpec OrdSpec ReadSpec ShowSpec Types.EqOrd Types.ReadShow build-depends: base-compat >= 0.8.1 && < 1 , base-orphans >= 0.5 && < 1 , deriving-compat == 0.3.4 , hspec >= 1.8 , QuickCheck >= 2 && < 3 , template-haskell >= 2.5 && < 2.12 if flag(base-4-9) build-depends: base >= 4.9 && < 5 cpp-options: "-DNEW_FUNCTOR_CLASSES" else build-depends: base >= 4.3 && < 4.9 if flag(new-functor-classes) build-depends: transformers (>= 0.2 && < 0.4) || (>= 0.5 && < 0.6) , transformers-compat >= 0.5 cpp-options: "-DNEW_FUNCTOR_CLASSES" else build-depends: transformers == 0.4.* hs-source-dirs: tests default-language: Haskell2010 ghc-options: -Wall -threaded -rtsopts deriving-compat-0.3.4/LICENSE0000644000000000000000000000276313002245656014014 0ustar0000000000000000Copyright (c) 2015-2016, Ryan Scott All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * 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. * Neither the name of Ryan Scott nor the names of other 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. deriving-compat-0.3.4/CHANGELOG.md0000644000000000000000000000340613002245656014613 0ustar0000000000000000### 0.3.4 [2016.10.20] * Fix bug in which infix record selectors weren't shown with parentheses in derived `Show` instances * Fix bug in which record selectors weren't parsed correctly in derived `Read` instances ### 0.3.3 [2016.09.11] * Add `Data.Bounded.Deriving`, which allows deriving `Bounded` with TH. * Add `Data.Enum.Deriving`, which allows deriving `Enum` with TH. * Add `Data.Ix.Deriving`, which allows deriving `Ix` with TH. * Fix bug in which derived `Show` instance would parenthesize the output too eagerly ### 0.3.2 * Incorporate a fix to GHC Trac #10858, which will be introduced in GHC 8.2 * Fix bug in which derived `Ord` instances accidentally swapped their less-than(-or-equal-to) and greater-than(-or-equal-to) methods * Fix GHC HEAD build ### 0.3.1 * Allow deriving `Functor` and `Foldable` instances for datatypes containing unboxed tuples * Microoptimization in derived instances of higher-order versions of `Eq`, `Ord`, `Read`, and `Show` ## 0.3 * Added `Data.Eq.Deriving`, which allows deriving `Eq`, `Eq1`, and `Eq2` with TH. * Added `Data.Ord.Deriving`, which allows deriving `Ord`, `Ord1`, and `Ord2` with TH. * Added `Data.Read.Deriving`, which allows deriving `Read`, `Read1`, and `Eq2` with TH. * Renamed `Text.Show.Deriving.Options` to `ShowOptions` so as to disambiguate it from the options datatypes in other `deriving-compat` modules. ### 0.2.2 * Fixed a bug in `Text.Show.Deriving`'s treatment of unlifted types ### 0.2.1 * Added `Text.Show.Deriving`, which allows deriving `Show`, `Show1`, and `Show2` with TH. ## 0.2 * Added support for GHC 8.0 * Added `Data.Functor.Deriving` and `Data.Traversable.Deriving`, which allow deriving `Functor` and `Traversable` with TH. * Added `Data.Deriving`, which reexports all other modules ## 0.1 * Initial commit deriving-compat-0.3.4/README.md0000644000000000000000000000446613002245656014270 0ustar0000000000000000# `deriving-compat` [![Hackage](https://img.shields.io/hackage/v/deriving-compat.svg)][Hackage: deriving-compat] [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/deriving-compat.svg)](http://packdeps.haskellers.com/reverse/deriving-compat) [![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/haskell-compat/deriving-compat.svg)](https://travis-ci.org/haskell-compat/deriving-compat) [Hackage: deriving-compat]: http://hackage.haskell.org/package/deriving-compat "deriving-compat 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)" Provides Template Haskell functions that mimic deriving extensions that were introduced or modified in recent versions of GHC. Currently, the following typeclasses/extensions are covered: * Deriving `Bounded` * Deriving `Enum` * Deriving `Ix` * Deriving `Eq`, `Eq1`, and `Eq2` * Deriving `Ord`, `Ord1`, and `Ord2` * Deriving `Read`, `Read1`, and `Read2` * Deriving `Show`, `Show1`, and `Show2` * `DeriveFoldable` * `DeriveFunctor` * `DeriveTraversable` See the `Data.Deriving` module for a full list of backported changes. Note that some recent GHC typeclasses/extensions are not covered by this package: * `DeriveDataTypeable` * `DeriveGeneric`, which was introducted in GHC 7.2 for deriving `Generic` instances, and modified in GHC 7.6 to allow derivation of `Generic1` instances. Use `Generics.Deriving.TH` from [`generic-deriving`](http://hackage.haskell.org/package/generic-deriving) to derive `Generic(1)` using Template Haskell. * `DeriveLift`, which was introduced in GHC 8.0 for deriving `Lift` instances. Use `Language.Haskell.TH.Lift` from [`th-lift`](http://hackage.haskell.org/package/th-lift) to derive `Lift` using Template Haskell. * The `Bifunctor` typeclass, which was introduced in GHC 7.10, as well as the `Bifoldable` and `Bitraversable` typeclasses, which were introduced in GHC 8.2. Use `Data.Bifunctor.TH` from [`bifunctors`](http://hackage.haskell.org/package/bifunctors) to derive these typeclasses using Template Haskell. deriving-compat-0.3.4/Setup.hs0000644000000000000000000000005613002245656014434 0ustar0000000000000000import Distribution.Simple main = defaultMain deriving-compat-0.3.4/tests/0000755000000000000000000000000013002245656014141 5ustar0000000000000000deriving-compat-0.3.4/tests/BoundedEnumIxSpec.hs0000644000000000000000000002210613002245656020017 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} #if __GLASGOW_HASKELL__ >= 706 {-# LANGUAGE PolyKinds #-} #endif {-| Module: BoundedEnumSpec Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell @hspec@ tests for derived 'Bounded', 'Enum', and 'Ix' instances. -} module BoundedEnumIxSpec where import Data.Deriving import GHC.Arr (Ix(..)) import Prelude () import Prelude.Compat import Test.Hspec ------------------------------------------------------------------------------- -- Plain data types data TyConEnum = TyConEnum1 | TyConEnum2 | TyConEnum3 deriving (Eq, Ord, Show) data TyConProduct a b c = TyConProduct a b c deriving (Eq, Ord, Show) data TyConUnit #if __GLASGOW_HASKELL__ >= 706 (f :: k -> *) (a :: k) #else (f :: * -> *) (a :: *) #endif = TyConUnit deriving (Eq, Ord, Show) data TyConExQuant a = Show a => TyConExQuant deriving instance Eq (TyConExQuant a) deriving instance Ord (TyConExQuant a) deriving instance Show (TyConExQuant a) data TyConGADT a where TyConGADT :: Show a => a -> TyConGADT a deriving instance Eq a => Eq (TyConGADT a) deriving instance Ord a => Ord (TyConGADT a) deriving instance Show a => Show (TyConGADT a) -- Data families data family TyFamilyEnum :: * data instance TyFamilyEnum = TyFamilyEnum1 | TyFamilyEnum2 | TyFamilyEnum3 deriving (Eq, Ord, Show) data family TyFamilyProduct x y z :: * data instance TyFamilyProduct a b c = TyFamilyProduct a b c deriving (Eq, Ord, Show) data family TyFamilyUnit #if __GLASGOW_HASKELL__ >= 706 (f :: k -> *) (a :: k) #else (f :: * -> *) (a :: *) #endif :: * data instance TyFamilyUnit f a = TyFamilyUnit deriving (Eq, Ord, Show) data family TyFamilyExQuant x :: * data instance TyFamilyExQuant a = Show a => TyFamilyExQuant deriving instance Eq (TyFamilyExQuant a) deriving instance Ord (TyFamilyExQuant a) deriving instance Show (TyFamilyExQuant a) data family TyFamilyGADT x :: * data instance TyFamilyGADT a where TyFamilyGADT :: Show a => a -> TyFamilyGADT a deriving instance Eq a => Eq (TyFamilyGADT a) deriving instance Ord a => Ord (TyFamilyGADT a) deriving instance Show a => Show (TyFamilyGADT a) ------------------------------------------------------------------------------- -- Plain data types $(deriveBounded ''TyConEnum) $(deriveBounded ''TyConProduct) instance Bounded (TyConUnit f a) where minBound = $(makeMinBound ''TyConUnit) maxBound = $(makeMaxBound ''TyConUnit) instance Show a => Bounded (TyConExQuant a) where minBound = $(makeMinBound ''TyConExQuant) maxBound = $(makeMaxBound ''TyConExQuant) instance (Bounded a, Show a) => Bounded (TyConGADT a) where minBound = $(makeMinBound ''TyConGADT) maxBound = $(makeMaxBound ''TyConGADT) $(deriveEnum ''TyConEnum) instance Enum (TyConUnit f a) where toEnum = $(makeToEnum ''TyConUnit) fromEnum = $(makeFromEnum ''TyConUnit) $(deriveIx ''TyConEnum) $(deriveIx ''TyConProduct) instance Ix (TyConUnit f a) where range = $(makeRange ''TyConUnit) unsafeIndex = $(makeUnsafeIndex ''TyConUnit) inRange = $(makeInRange ''TyConUnit) instance Ix (TyConExQuant a) where range = $(makeRange ''TyConExQuant) unsafeIndex = $(makeUnsafeIndex ''TyConExQuant) inRange = $(makeInRange ''TyConExQuant) instance Ix a => Ix (TyConGADT a) where range = $(makeRange ''TyConGADT) unsafeIndex = $(makeUnsafeIndex ''TyConGADT) inRange = $(makeInRange ''TyConGADT) #if MIN_VERSION_template_haskell(2,7,0) -- Data families $(deriveBounded 'TyFamilyEnum1) $(deriveBounded 'TyFamilyProduct) instance Bounded (TyFamilyUnit f a) where minBound = $(makeMinBound 'TyFamilyUnit) maxBound = $(makeMaxBound 'TyFamilyUnit) instance Show a => Bounded (TyFamilyExQuant a) where minBound = $(makeMinBound 'TyFamilyExQuant) maxBound = $(makeMaxBound 'TyFamilyExQuant) instance (Bounded a, Show a) => Bounded (TyFamilyGADT a) where minBound = $(makeMinBound 'TyFamilyGADT) maxBound = $(makeMaxBound 'TyFamilyGADT) $(deriveEnum 'TyFamilyEnum1) instance Enum (TyFamilyUnit f a) where toEnum = $(makeToEnum 'TyFamilyUnit) fromEnum = $(makeFromEnum 'TyFamilyUnit) $(deriveIx 'TyFamilyEnum1) $(deriveIx 'TyFamilyProduct) instance Ix (TyFamilyUnit f a) where range = $(makeRange 'TyFamilyUnit) unsafeIndex = $(makeUnsafeIndex 'TyFamilyUnit) inRange = $(makeInRange 'TyFamilyUnit) instance Ix (TyFamilyExQuant a) where range = $(makeRange 'TyFamilyExQuant) unsafeIndex = $(makeUnsafeIndex 'TyFamilyExQuant) inRange = $(makeInRange 'TyFamilyExQuant) instance Ix a => Ix (TyFamilyGADT a) where range = $(makeRange 'TyFamilyGADT) unsafeIndex = $(makeUnsafeIndex 'TyFamilyGADT) inRange = $(makeInRange 'TyFamilyGADT) #endif ------------------------------------------------------------------------------- -- | Verifies an 'Ix' instance satisfies the laws. ixLaws :: (Ix a, Show a) => a -> a -> a -> Expectation ixLaws l u i = do inRange (l,u) i `shouldBe` elem i (range (l,u)) range (l,u) !! index (l,u) i `shouldBe` i map (index (l,u)) (range (l,u)) `shouldBe` [0..rangeSize (l,u)-1] rangeSize (l,u) `shouldBe` length (range (l,u)) ------------------------------------------------------------------------------- main :: IO () main = hspec spec spec :: Spec spec = parallel $ do describe "TyConEnum" $ do it "has a sensible Bounded instance" $ do minBound `shouldBe` TyConEnum1 maxBound `shouldBe` TyConEnum3 it "has a sensible Enum instance" $ [minBound .. maxBound] `shouldBe` [TyConEnum1, TyConEnum2, TyConEnum3] it "has a sensible Ix instance" $ ixLaws minBound maxBound TyConEnum2 describe "TyConProduct Bool Bool Bool" $ do it "has a sensible Bounded instance" $ do minBound `shouldBe` TyConProduct False False False maxBound `shouldBe` TyConProduct True True True it "has a sensible Ix instance" $ ixLaws minBound maxBound (TyConProduct False False False) describe "TyConUnit Maybe Bool" $ do it "has a sensible Bounded instance" $ do minBound `shouldBe` TyConUnit maxBound `shouldBe` TyConUnit it "has a sensible Enum instance" $ [minBound .. maxBound] `shouldBe` [TyConUnit] it "has a sensible Ix instance" $ ixLaws minBound maxBound TyConUnit describe "TyConExQuant Bool" $ do it "has a sensible Bounded instance" $ do minBound `shouldBe` (TyConExQuant :: TyConExQuant Bool) maxBound `shouldBe` (TyConExQuant :: TyConExQuant Bool) it "has a sensible Ix instance" $ ixLaws minBound maxBound (TyConExQuant :: TyConExQuant Bool) describe "TyConGADT Bool" $ do it "has a sensible Bounded instance" $ do minBound `shouldBe` TyConGADT False maxBound `shouldBe` TyConGADT True it "has a sensible Ix instance" $ ixLaws minBound maxBound (TyConGADT False) #if MIN_VERSION_template_haskell(2,7,0) describe "TyFamilyEnum" $ do it "has a sensible Bounded instance" $ do minBound `shouldBe` TyFamilyEnum1 maxBound `shouldBe` TyFamilyEnum3 it "has a sensible Enum instance" $ [minBound .. maxBound] `shouldBe` [TyFamilyEnum1, TyFamilyEnum2, TyFamilyEnum3] it "has a sensible Ix instance" $ ixLaws minBound maxBound TyFamilyEnum2 describe "TyFamilyProduct Bool Bool Bool" $ do it "has a sensible Bounded instance" $ do minBound `shouldBe` TyFamilyProduct False False False maxBound `shouldBe` TyFamilyProduct True True True it "has a sensible Ix instance" $ ixLaws minBound maxBound (TyFamilyProduct False False False) describe "TyFamilyUnit Maybe Bool" $ do it "has a sensible Bounded instance" $ do minBound `shouldBe` TyFamilyUnit maxBound `shouldBe` TyFamilyUnit it "has a sensible Enum instance" $ [minBound .. maxBound] `shouldBe` [TyFamilyUnit] it "has a sensible Ix instance" $ ixLaws minBound maxBound TyFamilyUnit describe "TyFamilyExQuant Bool" $ do it "has a sensible Bounded instance" $ do minBound `shouldBe` (TyFamilyExQuant :: TyFamilyExQuant Bool) maxBound `shouldBe` (TyFamilyExQuant :: TyFamilyExQuant Bool) it "has a sensible Ix instance" $ ixLaws minBound maxBound (TyFamilyExQuant :: TyFamilyExQuant Bool) describe "TyFamilyGADT Bool" $ do it "has a sensible Bounded instance" $ do minBound `shouldBe` TyFamilyGADT False maxBound `shouldBe` TyFamilyGADT True it "has a sensible Ix instance" $ ixLaws minBound maxBound (TyFamilyGADT False) #endif deriving-compat-0.3.4/tests/FunctorSpec.hs0000644000000000000000000002630513002245656016736 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} #if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -Wno-unused-foralls #-} #endif {-| Module: FunctorSpec Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell @hspec@ tests for derived 'Functor', 'Foldable', and 'Traversable' instances. -} module FunctorSpec where import Data.Char (chr) import Data.Deriving import Data.Foldable (fold) import Data.Functor.Classes (Eq1) import Data.Functor.Compose (Compose(..)) import Data.Functor.Identity (Identity(..)) import Data.Monoid import Data.Orphans () import GHC.Exts (Int#) import Prelude () import Prelude.Compat import Test.Hspec import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Arbitrary) ------------------------------------------------------------------------------- -- Adapted from the test cases from -- https://ghc.haskell.org/trac/ghc/attachment/ticket/2953/deriving-functor-tests.patch -- Plain data types data Strange a b c = T1 a b c | T2 [a] [b] [c] -- lists | T3 [[a]] [[b]] [[c]] -- nested lists | T4 (c,(b,b),(c,c)) -- tuples | T5 ([c],Strange a b c) -- tycons type IntFun a b = (b -> Int) -> a data StrangeFunctions a b c = T6 (a -> c) -- function types | T7 (a -> (c,a)) -- functions and tuples | T8 ((b -> a) -> c) -- continuation | T9 (IntFun b c) -- type synonyms data StrangeGADT a b where T10 :: Ord d => d -> StrangeGADT c d T11 :: Int -> StrangeGADT e Int T12 :: c ~ Int => c -> StrangeGADT f Int T13 :: i ~ Int => Int -> StrangeGADT h i T14 :: k ~ Int => k -> StrangeGADT j k T15 :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADT m n data NotPrimitivelyRecursive a b = S1 (NotPrimitivelyRecursive (a,a) (b, a)) | S2 a | S3 b newtype OneTwoCompose f g a b = OneTwoCompose (Either (f (g a)) (f (g b))) deriving (Arbitrary, Eq, Show) newtype ComplexConstraint f g a b = ComplexConstraint (f Int Int (g a,a,b)) data Universal a b = Universal (forall b. (b,[a])) | Universal2 (forall f. Functor (f a) => f a b) | Universal3 (forall a. Maybe a) -- reuse a | NotReallyUniversal (forall b. a) data Existential a b = forall a. ExistentialList [a] | forall f. Traversable (f a) => ExistentialFunctor (f a b) | forall b. SneakyUseSameName (Maybe b) data IntHash a b = IntHash Int# Int# | IntHashTuple Int# a b (a, b, Int, IntHash Int (a, b, Int)) data IntHashFun a b = IntHashFun ((((a -> Int#) -> b) -> Int#) -> a) -- Data families data family StrangeFam x y z data instance StrangeFam a b c = T1Fam a b c | T2Fam [a] [b] [c] -- lists | T3Fam [[a]] [[b]] [[c]] -- nested lists | T4Fam (c,(b,b),(c,c)) -- tuples | T5Fam ([c],Strange a b c) -- tycons data family StrangeFunctionsFam x y z data instance StrangeFunctionsFam a b c = T6Fam (a -> c) -- function types | T7Fam (a -> (c,a)) -- functions and tuples | T8Fam ((b -> a) -> c) -- continuation | T9Fam (IntFun b c) -- type synonyms data family StrangeGADTFam x y data instance StrangeGADTFam a b where T10Fam :: Ord d => d -> StrangeGADTFam c d T11Fam :: Int -> StrangeGADTFam e Int T12Fam :: c ~ Int => c -> StrangeGADTFam f Int T13Fam :: i ~ Int => Int -> StrangeGADTFam h i T14Fam :: k ~ Int => k -> StrangeGADTFam j k T15Fam :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADTFam m n data family NotPrimitivelyRecursiveFam x y data instance NotPrimitivelyRecursiveFam a b = S1Fam (NotPrimitivelyRecursive (a,a) (b, a)) | S2Fam a | S3Fam b data family OneTwoComposeFam (j :: * -> *) (k :: * -> *) x y newtype instance OneTwoComposeFam f g a b = OneTwoComposeFam (Either (f (g a)) (f (g b))) deriving (Arbitrary, Eq, Show) data family ComplexConstraintFam (j :: * -> * -> * -> *) (k :: * -> *) x y newtype instance ComplexConstraintFam f g a b = ComplexConstraintFam (f Int Int (g a,a,b)) data family UniversalFam x y data instance UniversalFam a b = UniversalFam (forall b. (b,[a])) | Universal2Fam (forall f. Functor (f a) => f a b) | Universal3Fam (forall a. Maybe a) -- reuse a | NotReallyUniversalFam (forall b. a) data family ExistentialFam x y data instance ExistentialFam a b = forall a. ExistentialListFam [a] | forall f. Traversable (f a) => ExistentialFunctorFam (f a b) | forall b. SneakyUseSameNameFam (Maybe b) data family IntHashFam x y data instance IntHashFam a b = IntHashFam Int# Int# | IntHashTupleFam Int# a b (a, b, Int, IntHashFam Int (a, b, Int)) data family IntHashFunFam x y data instance IntHashFunFam a b = IntHashFunFam ((((a -> Int#) -> b) -> Int#) -> a) ------------------------------------------------------------------------------- -- Plain data types $(deriveFunctor ''Strange) $(deriveFoldable ''Strange) $(deriveTraversable ''Strange) $(deriveFunctor ''StrangeFunctions) $(deriveFoldable ''StrangeGADT) $(deriveFunctor ''NotPrimitivelyRecursive) $(deriveFoldable ''NotPrimitivelyRecursive) $(deriveTraversable ''NotPrimitivelyRecursive) $(deriveFunctor ''OneTwoCompose) $(deriveFoldable ''OneTwoCompose) $(deriveTraversable ''OneTwoCompose) instance Functor (f Int Int) => Functor (ComplexConstraint f g a) where fmap = $(makeFmap ''ComplexConstraint) instance Foldable (f Int Int) => Foldable (ComplexConstraint f g a) where foldr = $(makeFoldr ''ComplexConstraint) foldMap = $(makeFoldMap ''ComplexConstraint) fold = $(makeFold ''ComplexConstraint) foldl = $(makeFoldl ''ComplexConstraint) instance Traversable (f Int Int) => Traversable (ComplexConstraint f g a) where traverse = $(makeTraverse ''ComplexConstraint) sequenceA = $(makeSequenceA ''ComplexConstraint) mapM = $(makeMapM ''ComplexConstraint) sequence = $(makeSequence ''ComplexConstraint) $(deriveFunctor ''Universal) $(deriveFunctor ''Existential) $(deriveFoldable ''Existential) $(deriveTraversable ''Existential) $(deriveFunctor ''IntHash) $(deriveFoldable ''IntHash) $(deriveTraversable ''IntHash) $(deriveFunctor ''IntHashFun) #if MIN_VERSION_template_haskell(2,7,0) -- Data families $(deriveFunctor 'T1Fam) $(deriveFoldable 'T2Fam) $(deriveTraversable 'T3Fam) $(deriveFunctor 'T6Fam) $(deriveFoldable 'T10Fam) $(deriveFunctor 'S1Fam) $(deriveFoldable 'S2Fam) $(deriveTraversable 'S3Fam) $(deriveFunctor 'OneTwoComposeFam) $(deriveFoldable 'OneTwoComposeFam) $(deriveTraversable 'OneTwoComposeFam) instance Functor (f Int Int) => Functor (ComplexConstraintFam f g a) where fmap = $(makeFmap 'ComplexConstraintFam) instance Foldable (f Int Int) => Foldable (ComplexConstraintFam f g a) where foldr = $(makeFoldr 'ComplexConstraintFam) foldMap = $(makeFoldMap 'ComplexConstraintFam) fold = $(makeFold 'ComplexConstraintFam) foldl = $(makeFoldl 'ComplexConstraintFam) instance Traversable (f Int Int) => Traversable (ComplexConstraintFam f g a) where traverse = $(makeTraverse 'ComplexConstraintFam) sequenceA = $(makeSequenceA 'ComplexConstraintFam) mapM = $(makeMapM 'ComplexConstraintFam) sequence = $(makeSequence 'ComplexConstraintFam) $(deriveFunctor 'UniversalFam) $(deriveFunctor 'ExistentialListFam) $(deriveFoldable 'ExistentialFunctorFam) $(deriveTraversable 'SneakyUseSameNameFam) $(deriveFunctor 'IntHashFam) $(deriveFoldable 'IntHashTupleFam) $(deriveTraversable 'IntHashFam) $(deriveFunctor 'IntHashFunFam) #endif ------------------------------------------------------------------------------- prop_FunctorLaws :: (Functor f, Eq (f a), Eq (f c)) => (b -> c) -> (a -> b) -> f a -> Bool prop_FunctorLaws f g x = fmap id x == x && fmap (f . g) x == (fmap f . fmap g) x prop_FunctorEx :: (Functor f, Eq (f [Int])) => f [Int] -> Bool prop_FunctorEx = prop_FunctorLaws reverse (++ [42]) prop_FoldableLaws :: (Eq a, Eq b, Eq z, Monoid a, Monoid b, Foldable f) => (a -> b) -> (a -> z -> z) -> z -> f a -> Bool prop_FoldableLaws f h z x = fold x == foldMap id x && foldMap f x == foldr (mappend . f) mempty x && foldr h z x == appEndo (foldMap (Endo . h) x) z prop_FoldableEx :: Foldable f => f [Int] -> Bool prop_FoldableEx = prop_FoldableLaws reverse ((+) . length) 0 prop_TraversableLaws :: forall t f g a b c. (Applicative f, Applicative g, Traversable t, Eq (t (f a)), Eq (g (t a)), Eq (g (t b)), Eq (t a), Eq (t c), Eq1 f, Eq1 g) => (a -> f b) -> (b -> f c) -> (forall x. f x -> g x) -> t a -> Bool prop_TraversableLaws f g t x = (t . traverse f) x == traverse (t . f) x && traverse Identity x == Identity x && traverse (Compose . fmap g . f) x == (Compose . fmap (traverse g) . traverse f) x && (t . sequenceA) y == (sequenceA . fmap t) y && (sequenceA . fmap Identity) y == Identity y && (sequenceA . fmap Compose) z == (Compose . fmap sequenceA . sequenceA) z where y :: t (f a) y = fmap pure x z :: t (f (g a)) z = fmap (fmap pure) y prop_TraversableEx :: (Traversable t, Eq (t [[Int]]), Eq (t [Int]), Eq (t String), Eq (t Char)) => t [Int] -> Bool prop_TraversableEx = prop_TraversableLaws (replicate 2 . map (chr . abs)) (++ "Hello") reverse ------------------------------------------------------------------------------- main :: IO () main = hspec spec spec :: Spec spec = parallel $ do describe "OneTwoCompose Maybe ((,) Bool) [Int] [Int]" $ do prop "satisfies the Functor laws" (prop_FunctorEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool) prop "satisfies the Foldable laws" (prop_FoldableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool) prop "satisfies the Traversable laws" (prop_TraversableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Bool) #if MIN_VERSION_template_haskell(2,7,0) describe "OneTwoComposeFam Maybe ((,) Bool) [Int] [Int]" $ do prop "satisfies the Functor laws" (prop_FunctorEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Bool) prop "satisfies the Foldable laws" (prop_FoldableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Bool) prop "satisfies the Traversable laws" (prop_TraversableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Bool) #endif deriving-compat-0.3.4/tests/ShowSpec.hs0000644000000000000000000000634613002245656016241 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-| Module: ShowSpec Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell @hspec@ tests for derived 'Show', 'Show1', and 'Show2' instances. -} module ShowSpec where import Data.Deriving import GHC.Exts (Char#, Double#, Float#, Int#, Word#) import Prelude () import Prelude.Compat import Test.Hspec import Types.ReadShow () ------------------------------------------------------------------------------- -- Plain data types data TyCon# a b = TyCon# { tcA :: a , tcB :: b , tcInt# :: Int# , tcFloat# :: Float# , tcDouble# :: Double# , tcChar# :: Char# , tcWord# :: Word# } data TyCon2 a b c d where TyConClassConstraints :: (Ord m, Ord n, Ord o, Ord p) => m -> n -> o -> p -> TyCon2 m n o p TyConEqualityConstraints :: (e ~ g, f ~ h, e ~ f) => e -> f -> g -> h -> TyCon2 e f g h TyConTypeRefinement1, TyConTypeRefinement2 :: Int -> z -> TyCon2 Int Int z z TyConForalls :: forall p q r s t u. (Show p, Show q) => p -> q -> u -> t -> TyCon2 r s t u -- Data families data family TyFamily# y z :: * data instance TyFamily# a b = TyFamily# { tfA :: a , tfB :: b , tfInt# :: Int# , tfFloat# :: Float# , tfDouble# :: Double# , tfChar# :: Char# , tfWord# :: Word# } data family TyFamily2 w x y z :: * data instance TyFamily2 a b c d where TyFamilyClassConstraints :: (Ord m, Ord n, Ord o, Ord p) => m -> n -> o -> p -> TyFamily2 m n o p TyFamilyEqualityConstraints :: (e ~ g, f ~ h, e ~ f) => e -> f -> g -> h -> TyFamily2 e f g h TyFamilyTypeRefinement1, TyFamilyTypeRefinement2 :: Int -> z -> TyFamily2 Int Int z z TyFamilyForalls :: forall p q r s t u. (Show p, Show q) => p -> q -> u -> t -> TyFamily2 r s t u ------------------------------------------------------------------------------- -- Plain data types $(deriveShow ''TyCon#) $(deriveShow ''TyCon2) $(deriveShow1 ''TyCon#) $(deriveShow1 ''TyCon2) #if defined(NEW_FUNCTOR_CLASSES) $(deriveShow2 ''TyCon#) $(deriveShow2 ''TyCon2) #endif #if MIN_VERSION_template_haskell(2,7,0) -- Data families $(deriveShow 'TyFamily#) $(deriveShow 'TyFamilyClassConstraints) $(deriveShow1 'TyFamily#) $(deriveShow1 'TyFamilyEqualityConstraints) # if defined(NEW_FUNCTOR_CLASSES) $(deriveShow2 'TyFamily#) $(deriveShow2 'TyFamilyTypeRefinement1) # endif #endif ------------------------------------------------------------------------------- main :: IO () main = hspec spec spec :: Spec spec = pure () deriving-compat-0.3.4/tests/ReadSpec.hs0000644000000000000000000000247013002245656016166 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-| Module: ReadSpec Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell @hspec@ tests for derived 'Read', 'Read1', and 'Read2' instances. -} module ReadSpec where import Data.Deriving import Prelude () import Prelude.Compat import Test.Hspec import Types.ReadShow () ------------------------------------------------------------------------------- -- Plain data types data TyCon# a b = TyCon# { tcA# :: a , tcB# :: b } -- Data families data family TyFamily# y z :: * data instance TyFamily# a b = TyFamily# { tfA# :: a , tfB# :: b } ------------------------------------------------------------------------------- -- Plain data types $(deriveRead ''TyCon#) $(deriveRead1 ''TyCon#) #if defined(NEW_FUNCTOR_CLASSES) $(deriveRead2 ''TyCon#) #endif #if MIN_VERSION_template_haskell(2,7,0) -- Data families $(deriveRead 'TyFamily#) $(deriveRead1 'TyFamily#) # if defined(NEW_FUNCTOR_CLASSES) $(deriveRead2 'TyFamily#) # endif #endif ------------------------------------------------------------------------------- main :: IO () main = hspec spec spec :: Spec spec = pure () deriving-compat-0.3.4/tests/EqSpec.hs0000644000000000000000000000073013002245656015655 0ustar0000000000000000{-| Module: EqSpec Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell @hspec@ tests for derived 'Eq', 'Eq1', and 'Eq2' instances. -} module EqSpec where import Prelude () import Prelude.Compat import Test.Hspec import Types.EqOrd () ------------------------------------------------------------------------------- main :: IO () main = hspec spec spec :: Spec spec = pure () deriving-compat-0.3.4/tests/OrdSpec.hs0000644000000000000000000000073613002245656016042 0ustar0000000000000000{-| Module: OrdSpec Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell @hspec@ tests for derived 'Ord', 'Ord1', and 'Ord2' instances. -} module OrdSpec where import Prelude () import Prelude.Compat import Test.Hspec import Types.EqOrd () ------------------------------------------------------------------------------- main :: IO () main = hspec spec spec :: Spec spec = pure () deriving-compat-0.3.4/tests/Spec.hs0000644000000000000000000000005413002245656015366 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} deriving-compat-0.3.4/tests/Types/0000755000000000000000000000000013002245656015245 5ustar0000000000000000deriving-compat-0.3.4/tests/Types/ReadShow.hs0000644000000000000000000001343213002245656017320 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-| Module: Types.ReadShow Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Shared datatypes between "ReadSpec" and "ShowSpec". -} module Types.ReadShow where #if !defined(NEW_FUNCTOR_CLASSES) import Data.Functor.Classes (Read1(..), Show1(..)) #endif import Data.Deriving import Text.Read (Read(..), readListPrecDefault) ------------------------------------------------------------------------------- -- Plain data types infixl 4 :@: data TyCon1 a b = TyConPrefix { tc1 :: a, tc2 :: b } | (:@:) { tc3 :: b, (##) :: a } infixl 3 :!!: infix 4 :@@: infixr 5 `TyConPlain` infixr 6 `TyConFakeInfix` data TyConPlain a b = (:!!:) a b | a :@@: b | a `TyConPlain` b | TyConFakeInfix a b data TyConGADT a b where (:.) :: c -> d -> TyConGADT c d (:..) :: e -> f -> TyConGADT e f (:...) :: g -> h -> Int -> TyConGADT g h (:....) :: { tcg1 :: i, tcg2 :: j } -> TyConGADT i j data TyConWrap f g h a = TyConWrap1 (f a) | TyConWrap2 (f (g a)) | TyConWrap3 (f (g (h a))) data TC# a b = MkTC1# a b | MkTC2# { getTC2# :: b, (#~#) :: a } | a `MkTC3#` b -- Data families data family TyFamily1 y z :: * infixl 4 :!: data instance TyFamily1 a b = TyFamilyPrefix { tf1 :: a, tf2 :: b } | (:!:) { tf3 :: b, (###) :: a } data family TyFamilyPlain y z :: * infixl 3 :#: infix 4 :$: infixr 5 `TyFamilyPlain` infixr 6 `TyFamilyFakeInfix` data instance TyFamilyPlain a b = (:#:) a b | a :$: b | a `TyFamilyPlain` b | TyFamilyFakeInfix a b data family TyFamilyGADT y z :: * infixr 1 :*, :***, :**** data instance TyFamilyGADT a b where (:*) :: c -> d -> TyFamilyGADT c d (:**) :: e -> f -> TyFamilyGADT e f (:***) :: g -> h -> Int -> TyFamilyGADT g h (:****) :: { tfg1 :: i, tfg2 :: j } -> TyFamilyGADT i j data family TyFamilyWrap (w :: * -> *) (x :: * -> *) (y :: * -> *) z :: * data instance TyFamilyWrap f g h a = TyFamilyWrap1 (f a) | TyFamilyWrap2 (f (g a)) | TyFamilyWrap3 (f (g (h a))) data family TF# y z :: * data instance TF# a b = MkTF1# a b | MkTF2# { getTF2# :: b, (#~~#) :: a } | a `MkTF3#` b ------------------------------------------------------------------------------- -- Plain data types $(deriveRead ''TyCon1) $(deriveRead ''TyConPlain) $(deriveRead ''TyConGADT) instance (Read (f a), Read (f (g a)), Read (f (g (h a)))) => Read (TyConWrap f g h a) where readPrec = $(makeReadPrec ''TyConWrap) readListPrec = readListPrecDefault $(deriveRead ''TC#) $(deriveRead1 ''TyCon1) $(deriveRead1 ''TyConPlain) $(deriveRead1 ''TyConGADT) $(deriveRead1 ''TC#) $(deriveShow ''TyCon1) $(deriveShow ''TyConPlain) $(deriveShow ''TyConGADT) instance (Show (f a), Show (f (g a)), Show (f (g (h a)))) => Show (TyConWrap f g h a) where showsPrec = $(makeShowsPrec ''TyConWrap) show = $(makeShow ''TyConWrap) showList = $(makeShowList ''TyConWrap) $(deriveShow ''TC#) $(deriveShow1 ''TyCon1) $(deriveShow1 ''TyConPlain) $(deriveShow1 ''TyConGADT) $(deriveShow1 ''TC#) #if defined(NEW_FUNCTOR_CLASSES) $(deriveRead1 ''TyConWrap) $(deriveShow1 ''TyConWrap) #else instance (Read1 f, Functor f, Read1 g, Functor g, Read1 h) => Read1 (TyConWrap f g h) where readsPrec1 = $(makeReadsPrec1 ''TyConWrap) instance (Show1 f, Functor f, Show1 g, Functor g, Show1 h) => Show1 (TyConWrap f g h) where showsPrec1 = $(makeShowsPrec1 ''TyConWrap) #endif #if defined(NEW_FUNCTOR_CLASSES) $(deriveRead2 ''TyCon1) $(deriveRead2 ''TyConPlain) $(deriveRead2 ''TyConGADT) $(deriveRead2 ''TC#) $(deriveShow2 ''TyCon1) $(deriveShow2 ''TyConPlain) $(deriveShow2 ''TyConGADT) $(deriveShow2 ''TC#) #endif #if MIN_VERSION_template_haskell(2,7,0) -- Data families $(deriveRead 'TyFamilyPrefix) $(deriveRead '(:#:)) $(deriveRead '(:*)) instance (Read (f a), Read (f (g a)), Read (f (g (h a)))) => Read (TyFamilyWrap f g h a) where readsPrec = $(makeReadsPrec 'TyFamilyWrap1) $(deriveRead 'MkTF1#) $(deriveRead1 '(:!:)) $(deriveRead1 '(:$:)) $(deriveRead1 '(:**)) $(deriveRead1 'MkTF2#) $(deriveShow 'TyFamilyPrefix) $(deriveShow '(:#:)) $(deriveShow '(:*)) instance (Show (f a), Show (f (g a)), Show (f (g (h a)))) => Show (TyFamilyWrap f g h a) where showsPrec = $(makeShowsPrec 'TyFamilyWrap1) show = $(makeShow 'TyFamilyWrap1) showList = $(makeShowList 'TyFamilyWrap1) $(deriveShow 'MkTF3#) $(deriveShow1 '(:!:)) $(deriveShow1 '(:$:)) $(deriveShow1 '(:**)) $(deriveShow1 'MkTF1#) # if defined(NEW_FUNCTOR_CLASSES) $(deriveRead1 'TyFamilyWrap2) $(deriveShow1 'TyFamilyWrap2) # else instance (Read1 f, Functor f, Read1 g, Functor g, Read1 h) => Read1 (TyFamilyWrap f g h) where readsPrec1 = $(makeReadsPrec1 'TyFamilyWrap3) instance (Show1 f, Functor f, Show1 g, Functor g, Show1 h) => Show1 (TyFamilyWrap f g h) where showsPrec1 = $(makeShowsPrec1 'TyFamilyWrap3) # endif # if defined(NEW_FUNCTOR_CLASSES) $(deriveRead2 'TyFamilyPrefix) $(deriveRead2 'TyFamilyPlain) $(deriveRead2 '(:***)) $(deriveRead2 'MkTF2#) $(deriveShow2 'TyFamilyPrefix) $(deriveShow2 'TyFamilyPlain) $(deriveShow2 '(:***)) $(deriveShow2 'MkTF3#) # endif #endif deriving-compat-0.3.4/tests/Types/EqOrd.hs0000644000000000000000000001352413002245656016620 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-| Module: Types.EqOrd Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Shared datatypes between "EqSpec" and "OrdSpec". -} module Types.EqOrd where #if !defined(NEW_FUNCTOR_CLASSES) import Data.Functor.Classes (Eq1(..), Ord1(..)) #endif import Data.Deriving import GHC.Exts (Addr#, Char#, Double#, Float#, Int#, Word#) -- Plain data types data TyCon1 a m = TyCon1A a | TyCon1B | TyCon1C | TyCon1D | TyCon1E | TyCon1F | TyCon1G | TyCon1H | TyCon1I | TyCon1J | TyCon1K | TyCon1L | TyCon1M m data TyCon# a b = TyCon# { tcA :: a , tcB :: b , tcAddr# :: Addr# , tcInt# :: Int# , tcFloat# :: Float# , tcDouble# :: Double# , tcChar# :: Char# , tcWord# :: Word# } data TyCon2 a b c d where TyConClassConstraints :: (Show m, Show n, Show o, Show p) => m -> n -> o -> p -> TyCon2 m n o p TyConEqualityConstraints :: (e ~ g, f ~ h, e ~ f) => e -> f -> g -> h -> TyCon2 e f g h TyConTypeRefinement1, TyConTypeRefinement2 :: Int -> z -> TyCon2 Int Int z z data TyConWrap f g h a = TyConWrap1 (f a) | TyConWrap2 (f (g a)) | TyConWrap3 (f (g (h a))) -- Data families data family TyFamily1 y z :: * data instance TyFamily1 a m = TyFamily1A a | TyFamily1B | TyFamily1C | TyFamily1D | TyFamily1E | TyFamily1F | TyFamily1G | TyFamily1H | TyFamily1I | TyFamily1J | TyFamily1K | TyFamily1L | TyFamily1M m data family TyFamily# y z :: * data instance TyFamily# a b = TyFamily# { tfA :: a , tfB :: b , tfInt# :: Int# , tfFloat# :: Float# , tfDouble# :: Double# , tfChar# :: Char# , tfWord# :: Word# } data family TyFamily2 w x y z :: * data instance TyFamily2 a b c d where TyFamilyClassConstraints :: (Show m, Show n, Show o, Show p) => m -> n -> o -> p -> TyFamily2 m n o p TyFamilyEqualityConstraints :: (e ~ g, f ~ h, e ~ f) => e -> f -> g -> h -> TyFamily2 e f g h TyFamilyTypeRefinement1, TyFamilyTypeRefinement2 :: Int -> z -> TyFamily2 Int Int z z data family TyFamilyWrap (w :: * -> *) (x :: * -> *) (y :: * -> *) z :: * data instance TyFamilyWrap f g h a = TyFamilyWrap1 (f a) | TyFamilyWrap2 (f (g a)) | TyFamilyWrap3 (f (g (h a))) ------------------------------------------------------------------------------- -- Plain data types $(deriveEq ''TyCon1) $(deriveEq ''TyCon#) $(deriveEq ''TyCon2) instance (Eq (f a), Eq (f (g a)), Eq (f (g (h a)))) => Eq (TyConWrap f g h a) where (==) = $(makeEq ''TyConWrap) (/=) = $(makeNotEq ''TyConWrap) $(deriveEq1 ''TyCon1) $(deriveEq1 ''TyCon#) $(deriveEq1 ''TyCon2) $(deriveOrd ''TyCon1) $(deriveOrd ''TyCon#) $(deriveOrd ''TyCon2) instance (Ord (f a), Ord (f (g a)), Ord (f (g (h a)))) => Ord (TyConWrap f g h a) where compare = $(makeCompare ''TyConWrap) (>) = $(makeLT ''TyConWrap) (>=) = $(makeLE ''TyConWrap) (<) = $(makeGT ''TyConWrap) (<=) = $(makeGE ''TyConWrap) max = $(makeMax ''TyConWrap) min = $(makeMin ''TyConWrap) $(deriveOrd1 ''TyCon1) $(deriveOrd1 ''TyCon#) $(deriveOrd1 ''TyCon2) #if defined(NEW_FUNCTOR_CLASSES) $(deriveEq1 ''TyConWrap) $(deriveOrd1 ''TyConWrap) #else instance (Eq1 f, Functor f, Eq1 g, Functor g, Eq1 h) => Eq1 (TyConWrap f g h) where eq1 = $(makeEq1 ''TyConWrap) instance (Ord1 f, Functor f, Ord1 g, Functor g, Ord1 h) => Ord1 (TyConWrap f g h) where compare1 = $(makeCompare1 ''TyConWrap) #endif #if defined(NEW_FUNCTOR_CLASSES) $(deriveEq2 ''TyCon1) $(deriveEq2 ''TyCon#) $(deriveEq2 ''TyCon2) $(deriveOrd2 ''TyCon1) $(deriveOrd2 ''TyCon#) $(deriveOrd2 ''TyCon2) #endif #if MIN_VERSION_template_haskell(2,7,0) -- Data families $(deriveEq 'TyFamily1A) $(deriveEq 'TyFamily#) $(deriveEq 'TyFamilyClassConstraints) instance (Eq (f a), Eq (f (g a)), Eq (f (g (h a)))) => Eq (TyFamilyWrap f g h a) where (==) = $(makeEq 'TyFamilyWrap1) (/=) = $(makeNotEq 'TyFamilyWrap1) $(deriveEq1 'TyFamily1B) $(deriveEq1 'TyFamily#) $(deriveEq1 'TyFamilyEqualityConstraints) $(deriveOrd 'TyFamily1A) $(deriveOrd 'TyFamily#) $(deriveOrd 'TyFamilyClassConstraints) instance (Ord (f a), Ord (f (g a)), Ord (f (g (h a)))) => Ord (TyFamilyWrap f g h a) where compare = $(makeCompare 'TyFamilyWrap1) (>) = $(makeLT 'TyFamilyWrap1) (>=) = $(makeLE 'TyFamilyWrap1) (<) = $(makeGT 'TyFamilyWrap1) (<=) = $(makeGE 'TyFamilyWrap1) max = $(makeMax 'TyFamilyWrap1) min = $(makeMin 'TyFamilyWrap1) $(deriveOrd1 'TyFamily1B) $(deriveOrd1 'TyFamily#) $(deriveOrd1 'TyFamilyEqualityConstraints) #if defined(NEW_FUNCTOR_CLASSES) $(deriveEq1 'TyFamilyWrap2) $(deriveOrd1 'TyFamilyWrap2) #else instance (Eq1 f, Functor f, Eq1 g, Functor g, Eq1 h) => Eq1 (TyFamilyWrap f g h) where eq1 = $(makeEq1 'TyFamilyWrap3) instance (Ord1 f, Functor f, Ord1 g, Functor g, Ord1 h) => Ord1 (TyFamilyWrap f g h) where compare1 = $(makeCompare1 'TyFamilyWrap3) #endif # if defined(NEW_FUNCTOR_CLASSES) $(deriveEq2 'TyFamily1C) $(deriveEq2 'TyFamily#) $(deriveEq2 'TyFamilyTypeRefinement1) $(deriveOrd2 'TyFamily1C) $(deriveOrd2 'TyFamily#) $(deriveOrd2 'TyFamilyTypeRefinement1) # endif #endif deriving-compat-0.3.4/src/0000755000000000000000000000000013002245656013566 5ustar0000000000000000deriving-compat-0.3.4/src/Text/0000755000000000000000000000000013002245656014512 5ustar0000000000000000deriving-compat-0.3.4/src/Text/Read/0000755000000000000000000000000013002245656015365 5ustar0000000000000000deriving-compat-0.3.4/src/Text/Read/Deriving.hs0000644000000000000000000000576213002245656017502 0ustar0000000000000000{-# LANGUAGE CPP #-} {-| Module: Text.Read.Deriving Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Exports functions to mechanically derive 'Read', 'Read1', and 'Read2' instances. -} module Text.Read.Deriving ( -- * 'Read' deriveRead , deriveReadOptions , makeReadsPrec -- , makeReadsPrecOptions -- , makeReadList -- , makeReadListOptions , makeReadPrec -- , makeReadPrecOptions -- , makeReadListPrec -- , makeReadListPrecOptions -- * 'Read1' , deriveRead1 , deriveRead1Options #if defined(NEW_FUNCTOR_CLASSES) , makeLiftReadsPrec -- , makeLiftReadsPrecOptions -- , makeLiftReadList -- , makeLiftReadListOptions # if __GLASGOW_HASKELL__ >= 801 , makeLiftReadPrec -- , makeLiftReadPrecOptions -- , makeLiftReadListPrec -- , makeLiftReadListPrecOptions , makeReadPrec1 -- , makeReadPrec1Options # endif #endif , makeReadsPrec1 -- , makeReadsPrec1Options #if defined(NEW_FUNCTOR_CLASSES) -- * 'Read2' , deriveRead2 , deriveRead2Options , makeLiftReadsPrec2 -- , makeLiftReadsPrec2Options -- , makeLiftReadList2 -- , makeLiftReadList2Options # if __GLASGOW_HASKELL__ >= 801 , makeLiftReadPrec2 -- , makeLiftReadPrec2Options -- , makeLiftReadListPrec2 -- , makeLiftReadListPrec2Options , makeReadPrec2 -- , makeReadPrec2Options # endif , makeReadsPrec2 -- , makeReadsPrec2Options #endif -- * 'ReadOptions' , ReadOptions(..) , defaultReadOptions -- * 'deriveRead' limitations -- $constraints ) where import Text.Read.Deriving.Internal {- $constraints Be aware of the following potential gotchas: * Type variables of kind @*@ are assumed to have 'Read' constraints. Type variables of kind @* -> *@ are assumed to have 'Read1' constraints. Type variables of kind @* -> * -> *@ are assumed to have 'Read2' constraints. If this is not desirable, use 'makeReadsPrec' or one of its cousins. * The 'Read1' class had a different definition in @transformers-0.4@, and as a result, 'deriveRead1' implements different instances for the @transformers-0.4@ 'Read1' than it otherwise does. Also, 'makeLiftReadsPrec' and 'makeLiftReadList' are not available when this library is built against @transformers-0.4@, only 'makeReadsPrec1. * The 'Read2' class is not available in @transformers-0.4@, and as a result, neither are Template Haskell functions that deal with 'Read2' when this library is built against @transformers-0.4@. * The 'Read1' and 'Read2' classes have new methods ('liftReadPrec'/'liftReadListPrec' and 'liftReadPrec2'/'liftReadListPrec2', respectively) that were introduced in @base-4.10@. For now, these methods are only defined when deriving 'Read1'/'Read2' if built against @base-4.10@ (until @transformers-compat@ catches up), and the corresponding @make-@ functions are also only available when built against @base-4.10@. -} deriving-compat-0.3.4/src/Text/Read/Deriving/0000755000000000000000000000000013002245656017134 5ustar0000000000000000deriving-compat-0.3.4/src/Text/Read/Deriving/Internal.hs0000644000000000000000000010264113002245656021250 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-| Module: Text.Read.Deriving Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Exports functions to mechanically derive 'Read', 'Read1', and 'Read2' instances. -} module Text.Read.Deriving.Internal ( -- * 'Read' deriveRead , deriveReadOptions , makeReadsPrec -- , makeReadsPrecOptions -- , makeReadList -- , makeReadListOptions , makeReadPrec -- , makeReadPrecOptions -- , makeReadListPrec -- , makeReadListPrecOptions -- * 'Read1' , deriveRead1 , deriveRead1Options #if defined(NEW_FUNCTOR_CLASSES) , makeLiftReadsPrec -- , makeLiftReadsPrecOptions -- , makeLiftReadList -- , makeLiftReadListOptions # if __GLASGOW_HASKELL__ >= 801 , makeLiftReadPrec -- , makeLiftReadPrecOptions -- , makeLiftReadListPrec -- , makeLiftReadListPrecOptions , makeReadPrec1 -- , makeReadPrec1Options # endif #endif , makeReadsPrec1 -- , makeReadsPrec1Options #if defined(NEW_FUNCTOR_CLASSES) -- * 'Read2' , deriveRead2 , deriveRead2Options , makeLiftReadsPrec2 -- , makeLiftReadsPrec2Options -- , makeLiftReadList2 -- , makeLiftReadList2Options # if __GLASGOW_HASKELL__ >= 801 , makeLiftReadPrec2 -- , makeLiftReadPrec2Options -- , makeLiftReadListPrec2 -- , makeLiftReadListPrec2Options , makeReadPrec2 -- , makeReadPrec2Options # endif , makeReadsPrec2 -- , makeReadsPrec2Options #endif -- * 'ReadOptions' , ReadOptions(..) , defaultReadOptions ) where #if MIN_VERSION_template_haskell(2,11,0) import Control.Monad ((<=<)) import Data.Maybe (fromMaybe, isJust) #endif import Data.Deriving.Internal import Data.List (intersperse, partition) import qualified Data.Map as Map import GHC.Show (appPrec, appPrec1) import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax -- | Options that further configure how the functions in "Text.Read.Deriving" -- should behave. newtype ReadOptions = ReadOptions { useReadPrec :: Bool -- ^ If 'True': -- -- * Derived 'Read' instances will implement 'readPrec', not 'readsPrec', and -- will provide a default implementation of 'readListPrec' in terms of -- 'readPrec'. -- -- * If built against @base-4.10@ or later, derived 'Read1'/'Read2' -- instances will implement 'liftReadPrec'/'liftReadPrec2', not -- 'liftReadsPrec'/'liftReadsPrec2', and will provide default implementations -- of 'liftReadListPrec'/'liftReadListPrec2' in terms of -- 'liftReadPrec'/'liftReadPrec2'. If built against an earlier version of -- @base@, derived 'Read1'/'Read2' instances are not affected, so they will -- act as if this flag were 'False'. -- -- If 'False': -- -- * Derived 'Read' instances will implement 'readsPrec'. -- -- * Derived 'Read1' instances will implement 'readsPrec1' (if built against -- @transformers-0.4@) or 'liftReadsPrec' (otherwise). If not built against -- @transformers-0.4@, derived 'Read2' instances will implement -- 'liftReadsPrec2'. -- -- It's generally a good idea to enable this option, since 'readPrec' and -- friends are more efficient than 'readsPrec' and friends, since the former -- use the efficient 'ReadPrec' parser datatype while the latter use the -- slower, list-based 'ReadS' type. } deriving (Eq, Ord, Read, Show) -- | 'ReadOptions' that favor 'readPrec' over 'readsPrec'. defaultReadOptions :: ReadOptions defaultReadOptions = ReadOptions { useReadPrec = True } -- | Generates a 'Read' instance declaration for the given data type or data -- family instance. deriveRead :: Name -> Q [Dec] deriveRead = deriveReadOptions defaultReadOptions -- | Like 'deriveRead', but takes a 'ReadOptions' argument. deriveReadOptions :: ReadOptions -> Name -> Q [Dec] deriveReadOptions = deriveReadClass Read -- | Generates a lambda expression which behaves like 'readsPrec' (without -- requiring a 'Read' instance). makeReadsPrec :: Name -> Q Exp makeReadsPrec = makeReadPrecClass Read False -- -- | Like 'readsPrec', but takes a 'ReadOptions' argument. -- makeReadsPrecOptions :: ReadOptions -> Name -> Q Exp -- makeReadsPrecOptions _ = makeReadPrecClass Read False -- -- -- | Generates a lambda expression which behaves like 'readList' (without -- -- requiring a 'Read' instance). -- makeReadList :: Name -> Q Exp -- makeReadList = makeReadListOptions defaultReadOptions -- -- -- | Like 'readList', but takes a 'ReadOptions' argument. -- makeReadListOptions :: ReadOptions -> Name -> Q Exp -- makeReadListOptions opts name = -- if shouldDefineReadPrec Read opts -- then varE readPrec_to_SValName -- `appE` makeReadListPrecOptions opts name -- `appE` integerE 0 -- else varE readPrec_to_SValName -- `appE` (varE listValName `appE` makeReadPrecOptions opts name) -- `appE` integerE 0 -- | Generates a lambda expression which behaves like 'readPrec' (without -- requiring a 'Read' instance). makeReadPrec :: Name -> Q Exp makeReadPrec = makeReadPrecClass Read True -- -- | Like 'readPrec', but takes a 'ReadOptions' argument. -- makeReadPrecOptions :: ReadOptions -> Name -> Q Exp -- makeReadPrecOptions _ = makeReadPrecClass Read True -- -- -- | Generates a lambda expression which behaves like 'readListPrec' (without -- -- requiring a 'Read' instance). -- makeReadListPrec :: Name -> Q Exp -- makeReadListPrec = makeReadListPrecOptions defaultReadOptions -- -- -- | Like 'readListPrec', but takes a 'ReadOptions' argument. -- makeReadListPrecOptions :: ReadOptions -> Name -> Q Exp -- makeReadListPrecOptions opts name = -- if shouldDefineReadPrec Read opts -- then varE listValName `appE` makeReadPrecOptions opts name -- else varE readS_to_PrecValName -- `appE` (varE constValName `appE` makeReadListOptions opts name) -- | Generates a 'Read1' instance declaration for the given data type or data -- family instance. deriveRead1 :: Name -> Q [Dec] deriveRead1 = deriveRead1Options defaultReadOptions -- | Like 'deriveRead1', but takes a 'ReadOptions' argument. deriveRead1Options :: ReadOptions -> Name -> Q [Dec] deriveRead1Options = deriveReadClass Read1 -- -- | Generates a lambda expression which behaves like 'readsPrec1' (without -- -- requiring a 'Read1' instance). -- makeReadsPrec1 :: Name -> Q Exp -- makeReadsPrec1 = makeReadsPrec1Options defaultReadOptions #if defined(NEW_FUNCTOR_CLASSES) -- | Generates a lambda expression which behaves like 'liftReadsPrec' (without -- requiring a 'Read1' instance). -- -- This function is not available with @transformers-0.4@. makeLiftReadsPrec :: Name -> Q Exp makeLiftReadsPrec = makeReadPrecClass Read1 False -- -- | Like 'makeLiftReadsPrec', but takes a 'ReadOptions' argument. -- -- -- -- This function is not available with @transformers-0.4@. -- makeLiftReadsPrecOptions :: ReadOptions -> Name -> Q Exp -- makeLiftReadsPrecOptions _ = makeReadPrecClass Read1 False -- -- -- | Generates a lambda expression which behaves like 'liftReadList' (without -- -- requiring a 'Read1' instance). -- -- -- -- This function is not available with @transformers-0.4@. -- makeLiftReadList :: Name -> Q Exp -- makeLiftReadList = makeLiftReadListOptions defaultReadOptions -- -- -- | Like 'makeLiftReadList', but takes a 'ReadOptions' argument. -- -- -- -- This function is not available with @transformers-0.4@. -- makeLiftReadListOptions :: ReadOptions -> Name -> Q Exp -- makeLiftReadListOptions = undefined # if __GLASGOW_HASKELL__ >= 801 -- | Generates a lambda expression which behaves like 'liftReadPrec' (without -- requiring a 'Read1' instance). -- -- This function is only available with @base-4.10@ or later. makeLiftReadPrec :: Name -> Q Exp makeLiftReadPrec = makeReadPrecClass Read1 True -- -- | Like 'makeLiftReadPrec', but takes a 'ReadOptions' argument. -- -- -- -- This function is only available with @base-4.10@ or later. -- makeLiftReadPrecOptions :: ReadOptions -> Name -> Q Exp -- makeLiftReadPrecOptions _ = makeReadPrecClass Read1 True -- -- -- | Generates a lambda expression which behaves like 'liftReadListPrec' (without -- -- requiring a 'Read1' instance). -- -- -- -- This function is only available with @base-4.10@ or later. -- makeLiftReadListPrec :: Name -> Q Exp -- makeLiftReadListPrec = makeLiftReadListPrecOptions defaultReadOptions -- -- -- | Like 'makeLiftReadListPrec', but takes a 'ReadOptions' argument. -- -- -- -- This function is only available with @base-4.10@ or later. -- makeLiftReadListPrecOptions :: ReadOptions -> Name -> Q Exp -- makeLiftReadListPrecOptions = undefined -- | Generates a lambda expression which behaves like 'readPrec1' (without -- requiring a 'Read1' instance). -- -- This function is only available with @base-4.10@ or later. makeReadPrec1 :: Name -> Q Exp makeReadPrec1 name = makeLiftReadPrec name `appE` varE readPrecValName `appE` varE readListPrecValName -- -- | Like 'makeReadPrec1', but takes a 'ReadOptions' argument. -- -- -- -- This function is only available with @base-4.10@ or later. -- makeReadPrec1Options :: ReadOptions -> Name -> Q Exp -- makeReadPrec1Options opts name = makeLiftReadPrecOptions opts name -- `appE` varE readPrecValName -- `appE` varE readListPrecValName # endif -- | Generates a lambda expression which behaves like 'readsPrec1' (without -- requiring a 'Read1' instance). makeReadsPrec1 :: Name -> Q Exp makeReadsPrec1 name = makeLiftReadsPrec name `appE` varE readsPrecValName `appE` varE readListValName -- -- | Like 'makeReadsPrec1Options', but takes a 'ReadOptions' argument. -- makeReadsPrec1Options :: ReadOptions -> Name -> Q Exp -- makeReadsPrec1Options opts name = makeLiftReadsPrecOptions opts name -- `appE` varE readsPrecValName -- `appE` varE readListValName #else -- | Generates a lambda expression which behaves like 'readsPrec1' (without -- requiring a 'Read1' instance). makeReadsPrec1 :: Name -> Q Exp makeReadsPrec1 = makeReadPrecClass Read1 False -- -- | Like 'makeReadsPrec1Options', but takes a 'ReadOptions' argument. -- makeReadsPrec1Options :: ReadOptions -> Name -> Q Exp -- makeReadsPrec1Options _ = makeReadPrecClass Read1 False #endif #if defined(NEW_FUNCTOR_CLASSES) -- | Generates a 'Read2' instance declaration for the given data type or data -- family instance. -- -- This function is not available with @transformers-0.4@. deriveRead2 :: Name -> Q [Dec] deriveRead2 = deriveRead2Options defaultReadOptions -- | Like 'deriveRead2', but takes a 'ReadOptions' argument. -- -- This function is not available with @transformers-0.4@. deriveRead2Options :: ReadOptions -> Name -> Q [Dec] deriveRead2Options = deriveReadClass Read2 -- | Generates a lambda expression which behaves like 'liftReadsPrec2' (without -- requiring a 'Read2' instance). -- -- This function is not available with @transformers-0.4@. makeLiftReadsPrec2 :: Name -> Q Exp makeLiftReadsPrec2 = makeReadPrecClass Read2 False -- -- | Like 'makeLiftReadsPrec2', but takes a 'ReadOptions' argument. -- -- -- -- This function is not available with @transformers-0.4@. -- makeLiftReadsPrec2Options :: ReadOptions -> Name -> Q Exp -- makeLiftReadsPrec2Options _ = makeReadPrecClass Read2 False -- -- -- | Generates a lambda expression which behaves like 'liftReadList2' (without -- -- requiring a 'Read2' instance). -- -- -- -- This function is not available with @transformers-0.4@. -- makeLiftReadList2 :: Name -> Q Exp -- makeLiftReadList2 = makeLiftReadList2Options defaultReadOptions -- -- -- | Like 'makeLiftReadList2', but takes a 'ReadOptions' argument. -- -- -- -- This function is not available with @transformers-0.4@. -- makeLiftReadList2Options :: ReadOptions -> Name -> Q Exp -- makeLiftReadList2Options opts name = do -- let rp1Expr = VarE `fmap` newName "rp1'" -- rl1Expr = VarE `fmap` newName "rl1'" -- rp2Expr = VarE `fmap` newName "rp2'" -- rl2Expr = VarE `fmap` newName "rl2'" -- let rp2sExpr = varE readPrec_to_SValName -- rs2pExpr = varE readS_to_PrecValName -- constExpr = varE constValName -- if shouldDefineReadPrec Read2 opts -- then rp2sExpr -- `appE` (makeLiftReadListPrec2Options opts name -- `appE` (rs2pExpr `appE` rp1Expr) -- `appE` (rs2pExpr `appE` (constExpr `appE` rl1Expr)) -- `appE` (rs2pExpr `appE` rp2Expr) -- `appE` (rs2pExpr `appE` (constExpr `appE` rl2Expr))) -- `appE` integerE 0 -- else rp2sExpr `appE` (varE listValName -- `appE` (makeLiftReadPrec2Options opts name -- `appE` (rs2pExpr `appE` rp1Expr) -- `appE` (rs2pExpr `appE` (constExpr `appE` rl1Expr)) -- `appE` (rs2pExpr `appE` rp2Expr) -- `appE` (rs2pExpr `appE` (constExpr `appE` rl2Expr)))) -- `appE` integerE 0 # if __GLASGOW_HASKELL__ >= 801 -- | Generates a lambda expression which behaves like 'liftReadPrec2' (without -- requiring a 'Read2' instance). -- -- This function is only available with @base-4.10@ or later. makeLiftReadPrec2 :: Name -> Q Exp makeLiftReadPrec2 = makeReadPrecClass Read2 True -- -- | Like 'makeLiftReadPrec2', but takes a 'ReadOptions' argument. -- -- -- -- This function is only available with @base-4.10@ or later. -- makeLiftReadPrec2Options :: ReadOptions -> Name -> Q Exp -- makeLiftReadPrec2Options _ = makeReadPrecClass Read2 True -- -- -- | Generates a lambda expression which behaves like 'liftReadListPrec2' (without -- -- requiring a 'Read2' instance). -- -- -- -- This function is only available with @base-4.10@ or later. -- makeLiftReadListPrec2 :: Name -> Q Exp -- makeLiftReadListPrec2 = makeLiftReadListPrec2Options defaultReadOptions -- -- -- | Like 'makeLiftReadListPrec2', but takes a 'ReadOptions' argument. -- -- -- -- This function is only available with @base-4.10@ or later. -- makeLiftReadListPrec2Options :: ReadOptions -> Name -> Q Exp -- makeLiftReadListPrec2Options = undefined -- | Generates a lambda expression which behaves like 'readPrec2' (without -- requiring a 'Read2' instance). -- -- This function is only available with @base-4.10@ or later. makeReadPrec2 :: Name -> Q Exp makeReadPrec2 name = makeLiftReadPrec2 name `appE` varE readPrecValName `appE` varE readListPrecValName `appE` varE readPrecValName `appE` varE readListPrecValName -- -- | Like 'makeReadPrec2', but takes a 'ReadOptions' argument. -- -- -- -- This function is only available with @base-4.10@ or later. -- makeReadPrec2Options :: ReadOptions -> Name -> Q Exp -- makeReadPrec2Options opts name = makeLiftReadPrec2Options opts name -- `appE` varE readPrecValName -- `appE` varE readListPrecValName -- `appE` varE readPrecValName -- `appE` varE readListPrecValName # endif -- | Generates a lambda expression which behaves like 'readsPrec2' (without -- requiring a 'Read2' instance). -- -- This function is not available with @transformers-0.4@. makeReadsPrec2 :: Name -> Q Exp makeReadsPrec2 name = makeLiftReadsPrec2 name `appE` varE readsPrecValName `appE` varE readListValName `appE` varE readsPrecValName `appE` varE readListValName -- -- | Like 'makeReadsPrec2', but takes a 'ReadOptions' argument. -- -- -- -- This function is not available with @transformers-0.4@. -- makeReadsPrec2Options :: ReadOptions -> Name -> Q Exp -- makeReadsPrec2Options opts name = makeLiftReadsPrec2Options opts name -- `appE` varE readsPrecValName -- `appE` varE readListValName -- `appE` varE readsPrecValName -- `appE` varE readListValName #endif ------------------------------------------------------------------------------- -- Code generation ------------------------------------------------------------------------------- -- | Derive a Read(1)(2) instance declaration (depending on the ReadClass -- argument's value). deriveReadClass :: ReadClass -> ReadOptions -> Name -> Q [Dec] deriveReadClass rClass opts name = withType name fromCons where fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do (instanceCxt, instanceType) <- buildTypeInstance rClass name' ctxt tvbs mbTys instanceD (return instanceCxt) (return instanceType) (readPrecDecs rClass opts cons) -- | Generates a declaration defining the primary function corresponding to a -- particular class (read(s)Prec for Read, liftRead(s)Prec for Read1, and -- liftRead(s)Prec2 for Read2). readPrecDecs :: ReadClass -> ReadOptions -> [Con] -> [Q Dec] readPrecDecs rClass opts cons = [ funD ((if defineReadPrec then readPrecName else readsPrecName) rClass) [ clause [] (normalB $ makeReadForCons rClass defineReadPrec cons) [] ] ] ++ if defineReadPrec then [ funD (readListPrecName rClass) [ clause [] (normalB . varE $ readListPrecDefaultName rClass) [] ] ] else [] where defineReadPrec :: Bool defineReadPrec = shouldDefineReadPrec rClass opts -- | Generates a lambda expression which behaves like read(s)Prec (for Read), -- liftRead(s)Prec (for Read1), or liftRead(s)Prec2 (for Read2). makeReadPrecClass :: ReadClass -> Bool -> Name -> Q Exp makeReadPrecClass rClass urp name = withType name fromCons where fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp fromCons name' ctxt tvbs cons mbTys = -- We force buildTypeInstance here since it performs some checks for whether -- or not the provided datatype can actually have -- read(s)Prec/liftRead(s)Prec/etc. implemented for it, and produces errors -- if it can't. buildTypeInstance rClass name' ctxt tvbs mbTys `seq` makeReadForCons rClass urp cons -- | Generates a lambda expression for read(s)Prec/liftRead(s)Prec/etc. for the -- given constructors. All constructors must be from the same type. makeReadForCons :: ReadClass -> Bool -> [Con] -> Q Exp makeReadForCons rClass urp cons = do p <- newName "p" rps <- newNameList "rp" $ arity rClass rls <- newNameList "rl" $ arity rClass let rpls = zip rps rls _rpsAndRls = interleave rps rls let nullaryCons, nonNullaryCons :: [Con] (nullaryCons, nonNullaryCons) = partition isNullaryCon cons readConsExpr :: Q Exp readConsExpr | null cons = varE pfailValName | otherwise = do readNonNullaryCons <- concatMapM (makeReadForCon rClass urp rpls) nonNullaryCons foldr1 mkAlt (readNullaryCons ++ map return readNonNullaryCons) readNullaryCons :: [Q Exp] readNullaryCons = case nullaryCons of [] -> [] [con] | nameBase (constructorName con) == "()" -> [varE parenValName `appE` mkDoStmts [] (varE returnValName `appE` tupE [])] | otherwise -> [mkDoStmts (matchCon con) (resultExpr (constructorName con) [])] _ -> [varE chooseValName `appE` listE (map mkPair nullaryCons)] mkAlt :: Q Exp -> Q Exp -> Q Exp mkAlt e1 e2 = infixApp e1 (varE altValName) e2 mkPair :: Con -> Q Exp mkPair con = tupE [ stringE $ dataConStr con , resultExpr (constructorName con) [] ] matchCon :: Con -> [Q Stmt] matchCon con | isSym conStr = [symbolPat conStr] | otherwise = identHPat conStr where conStr = dataConStr con mainRhsExpr :: Q Exp mainRhsExpr = varE parensValName `appE` readConsExpr lamE (map varP $ #if defined(NEW_FUNCTOR_CLASSES) _rpsAndRls ++ #endif if urp then [] else [p] ) . appsE $ [ varE $ (if urp then readPrecConstName else readsPrecConstName) rClass , if urp then mainRhsExpr else varE readPrec_to_SValName `appE` mainRhsExpr `appE` varE p ] #if defined(NEW_FUNCTOR_CLASSES) ++ map varE _rpsAndRls #endif ++ if urp then [] else [varE p] makeReadForCon :: ReadClass -> Bool -> [(Name, Name)] -> Con -> Q [Exp] makeReadForCon rClass urp rpls (NormalC conName _) = do (argTys, tvMap) <- reifyConTys2 rClass rpls conName args <- newNameList "arg" $ length argTys let conStr = nameBase conName isTup = isNonUnitTupleString conStr (readStmts, varExps) <- zipWithAndUnzipM (makeReadForArg rClass isTup urp tvMap conName) argTys args let body = resultExpr conName varExps e <- if isTup then let tupleStmts = intersperse (readPunc ",") readStmts in varE parenValName `appE` mkDoStmts tupleStmts body else let prefixStmts = readPrefixCon conStr ++ readStmts in mkParser appPrec prefixStmts body return [e] makeReadForCon rClass urp rpls (RecC conName ts) = do (argTys, tvMap) <- reifyConTys2 rClass rpls conName args <- newNameList "arg" $ length argTys (readStmts, varExps) <- zipWith3AndUnzipM (\(argName, _, _) argTy arg -> makeReadForField rClass urp tvMap conName (nameBase argName) argTy arg) ts argTys args let body = resultExpr conName varExps conStr = nameBase conName recordStmts = readPrefixCon conStr ++ [readPunc "{"] ++ concat (intersperse [readPunc ","] readStmts) ++ [readPunc "}"] e <- mkParser appPrec1 recordStmts body return [e] makeReadForCon rClass urp rpls (InfixC _ conName _) = do ([alTy, arTy], tvMap) <- reifyConTys2 rClass rpls conName al <- newName "argL" ar <- newName "argR" ([readStmt1, readStmt2], varExps) <- zipWithAndUnzipM (makeReadForArg rClass False urp tvMap conName) [alTy, arTy] [al, ar] info <- reify conName #if MIN_VERSION_template_haskell(2,11,0) conPrec <- case info of DataConI{} -> do fi <- fromMaybe defaultFixity <$> reifyFixity conName case fi of Fixity prec _ -> return prec #else let conPrec = case info of DataConI _ _ _ (Fixity prec _) -> prec #endif _ -> error $ "Text.Read.Deriving.Internal.makeReadForCon: Unsupported type: " ++ show info let body = resultExpr conName varExps conStr = nameBase conName readInfixCon | isSym conStr = [symbolPat conStr] | otherwise = [readPunc "`"] ++ identHPat conStr ++ [readPunc "`"] infixStmts = [readStmt1] ++ readInfixCon ++ [readStmt2] e <- mkParser conPrec infixStmts body return [e] makeReadForCon rClass urp rpls (ForallC _ _ con) = makeReadForCon rClass urp rpls con #if MIN_VERSION_template_haskell(2,11,0) makeReadForCon rClass urp rpls (GadtC conNames ts _) = let con :: Name -> Q Con con conName = do mbFi <- reifyFixity conName return $ if isInfixDataCon (nameBase conName) && length ts == 2 && isJust mbFi then let [t1, t2] = ts in InfixC t1 conName t2 else NormalC conName ts in concatMapM (makeReadForCon rClass urp rpls <=< con) conNames makeReadForCon rClass urp rpls (RecGadtC conNames ts _) = concatMapM (makeReadForCon rClass urp rpls . flip RecC ts) conNames #endif makeReadForArg :: ReadClass -> Bool -> Bool -> TyVarMap2 -> Name -> Type -> Name -> Q (Q Stmt, Exp) makeReadForArg rClass isTup urp tvMap conName ty tyExpName = do (rExp, varExp) <- makeReadForType rClass urp tvMap conName tyExpName False ty let readStmt = bindS (varP tyExpName) $ (if (not isTup) then appE (varE stepValName) else id) $ wrapReadS urp (return rExp) return (readStmt, varExp) makeReadForField :: ReadClass -> Bool -> TyVarMap2 -> Name -> String -> Type -> Name -> Q ([Q Stmt], Exp) makeReadForField rClass urp tvMap conName lblStr ty tyExpName = do (rExp, varExp) <- makeReadForType rClass urp tvMap conName tyExpName False ty let readStmt = bindS (varP tyExpName) $ varE resetValName `appE` wrapReadS urp (return rExp) return (readLbl ++ [readPunc "=", readStmt], varExp) where readLbl | isSym lblStr = [readPunc "(", symbolPat lblStr, readPunc ")"] | otherwise = identHPat lblStr makeReadForType :: ReadClass -> Bool -> TyVarMap2 -> Name -> Name -> Bool -> Type -> Q (Exp, Exp) #if defined(NEW_FUNCTOR_CLASSES) makeReadForType _ urp tvMap _ tyExpName rl (VarT tyName) = let tyExp = VarE tyExpName in return $ case Map.lookup tyName tvMap of Just (TwoNames rpExp rlExp) -> (VarE $ if rl then rlExp else rpExp, tyExp) Nothing -> (VarE $ readsOrReadName urp rl Read, tyExp) #else makeReadForType _ urp _ _ tyExpName _ VarT{} = return (VarE $ readsOrReadName urp False Read, VarE tyExpName) #endif makeReadForType rClass urp tvMap conName tyExpName rl (SigT ty _) = makeReadForType rClass urp tvMap conName tyExpName rl ty makeReadForType rClass urp tvMap conName tyExpName rl (ForallT _ _ ty) = makeReadForType rClass urp tvMap conName tyExpName rl ty #if defined(NEW_FUNCTOR_CLASSES) makeReadForType rClass urp tvMap conName tyExpName rl ty = do let tyCon :: Type tyArgs :: [Type] tyCon:tyArgs = unapplyTy ty numLastArgs :: Int numLastArgs = min (arity rClass) (length tyArgs) lhsArgs, rhsArgs :: [Type] (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs tyVarNames :: [Name] tyVarNames = Map.keys tvMap itf <- isTyFamily tyCon if any (`mentionsName` tyVarNames) lhsArgs || itf && any (`mentionsName` tyVarNames) tyArgs then outOfPlaceTyVarError rClass conName else if any (`mentionsName` tyVarNames) rhsArgs then do readExp <- appsE $ [ varE . readsOrReadName urp rl $ toEnum numLastArgs] ++ zipWith (\b -> fmap fst . makeReadForType rClass urp tvMap conName tyExpName b) (cycle [False,True]) (interleave rhsArgs rhsArgs) return (readExp, VarE tyExpName) else return (VarE $ readsOrReadName urp rl Read, VarE tyExpName) #else makeReadForType rClass urp tvMap conName tyExpName _ ty = do let varNames = Map.keys tvMap rpExpr = VarE $ readsOrReadName urp False Read rp1Expr = VarE $ readsOrReadName urp False Read1 tyExpr = VarE tyExpName case varNames of [] -> return (rpExpr, tyExpr) varName:_ -> do if mentionsName ty varNames then do applyExp <- makeFmapApplyPos rClass conName ty varName return (rp1Expr, applyExp `AppE` tyExpr) else return (rpExpr, tyExpr) #endif ------------------------------------------------------------------------------- -- Class-specific constants ------------------------------------------------------------------------------- -- | A representation of which @Read@ variant is being derived. data ReadClass = Read | Read1 #if defined(NEW_FUNCTOR_CLASSES) | Read2 #endif deriving (Bounded, Enum) instance ClassRep ReadClass where arity = fromEnum allowExQuant _ = False fullClassName Read = readTypeName fullClassName Read1 = read1TypeName #if defined(NEW_FUNCTOR_CLASSES) fullClassName Read2 = read2TypeName #endif classConstraint rClass i | rMin <= i && i <= rMax = Just $ fullClassName (toEnum i :: ReadClass) | otherwise = Nothing where rMin, rMax :: Int rMin = fromEnum (minBound :: ReadClass) rMax = fromEnum rClass readsPrecConstName :: ReadClass -> Name readsPrecConstName Read = readsPrecConstValName #if defined(NEW_FUNCTOR_CLASSES) readsPrecConstName Read1 = liftReadsPrecConstValName readsPrecConstName Read2 = liftReadsPrec2ConstValName #else readsPrecConstName Read1 = readsPrec1ConstValName #endif readPrecConstName :: ReadClass -> Name readPrecConstName Read = readPrecConstValName readPrecConstName Read1 = liftReadPrecConstValName #if defined(NEW_FUNCTOR_CLASSES) readPrecConstName Read2 = liftReadPrec2ConstValName #endif readsPrecName :: ReadClass -> Name readsPrecName Read = readsPrecValName #if defined(NEW_FUNCTOR_CLASSES) readsPrecName Read1 = liftReadsPrecValName readsPrecName Read2 = liftReadsPrec2ValName #else readsPrecName Read1 = readsPrec1ValName #endif readPrecName :: ReadClass -> Name readPrecName Read = readPrecValName readPrecName Read1 = liftReadPrecValName #if defined(NEW_FUNCTOR_CLASSES) readPrecName Read2 = liftReadPrec2ValName #endif readListPrecDefaultName :: ReadClass -> Name readListPrecDefaultName Read = readListPrecDefaultValName readListPrecDefaultName Read1 = liftReadListPrecDefaultValName #if defined(NEW_FUNCTOR_CLASSES) readListPrecDefaultName Read2 = liftReadListPrec2DefaultValName #endif readListPrecName :: ReadClass -> Name readListPrecName Read = readListPrecValName readListPrecName Read1 = liftReadListPrecValName #if defined(NEW_FUNCTOR_CLASSES) readListPrecName Read2 = liftReadListPrec2ValName #endif readListName :: ReadClass -> Name readListName Read = readListValName #if defined(NEW_FUNCTOR_CLASSES) readListName Read1 = liftReadListValName readListName Read2 = liftReadList2ValName #else readListName Read1 = error "Text.Read.Deriving.Internal.readListName" #endif readsPrecOrListName :: Bool -- ^ readsListName if True, readsPrecName if False -> ReadClass -> Name readsPrecOrListName False = readsPrecName readsPrecOrListName True = readListName readPrecOrListName :: Bool -- ^ readListPrecName if True, readPrecName if False -> ReadClass -> Name readPrecOrListName False = readPrecName readPrecOrListName True = readListPrecName readsOrReadName :: Bool -- ^ readPrecOrListName if True, readsPrecOrListName if False -> Bool -- ^ read(s)List(Prec)Name if True, read(s)PrecName if False -> ReadClass -> Name readsOrReadName False = readsPrecOrListName readsOrReadName True = readPrecOrListName ------------------------------------------------------------------------------- -- Assorted utilities ------------------------------------------------------------------------------- mkParser :: Int -> [Q Stmt] -> Q Exp -> Q Exp mkParser p ss b = varE precValName `appE` integerE p `appE` mkDoStmts ss b mkDoStmts :: [Q Stmt] -> Q Exp -> Q Exp mkDoStmts ss b = doE (ss ++ [noBindS b]) resultExpr :: Name -> [Exp] -> Q Exp resultExpr conName as = varE returnValName `appE` conApp where conApp :: Q Exp conApp = appsE $ conE conName : map return as identHPat :: String -> [Q Stmt] identHPat s | Just (ss, '#') <- snocView s = [identPat ss, symbolPat "#"] | otherwise = [identPat s] bindLex :: Q Exp -> Q Stmt bindLex pat = noBindS $ varE expectPValName `appE` pat identPat :: String -> Q Stmt identPat s = bindLex $ conE identDataName `appE` stringE s symbolPat :: String -> Q Stmt symbolPat s = bindLex $ conE symbolDataName `appE` stringE s readPunc :: String -> Q Stmt readPunc c = bindLex $ conE puncDataName `appE` stringE c snocView :: [a] -> Maybe ([a],a) -- Split off the last element snocView [] = Nothing snocView xs = go [] xs where -- Invariant: second arg is non-empty go acc [a] = Just (reverse acc, a) go acc (a:as) = go (a:acc) as go _ [] = error "Util: snocView" dataConStr :: Con -> String dataConStr = nameBase . constructorName readPrefixCon :: String -> [Q Stmt] readPrefixCon conStr | isSym conStr = [readPunc "(", symbolPat conStr, readPunc ")"] | otherwise = identHPat conStr wrapReadS :: Bool -> Q Exp -> Q Exp wrapReadS urp e = if urp then e else varE readS_to_PrecValName `appE` e shouldDefineReadPrec :: ReadClass -> ReadOptions -> Bool shouldDefineReadPrec rClass opts = useReadPrec opts && baseCompatible where base4'10OrLater :: Bool #if __GLASGOW_HASKELL__ >= 801 base4'10OrLater = True #else base4'10OrLater = False #endif baseCompatible :: Bool baseCompatible = case rClass of Read -> True Read1 -> base4'10OrLater #if defined(NEW_FUNCTOR_CLASSES) Read2 -> base4'10OrLater #endif deriving-compat-0.3.4/src/Text/Show/0000755000000000000000000000000013002245656015432 5ustar0000000000000000deriving-compat-0.3.4/src/Text/Show/Deriving.hs0000644000000000000000000000411313002245656017534 0ustar0000000000000000{-# LANGUAGE CPP #-} {-| Module: Text.Show.Deriving Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Exports functions to mechanically derive 'Show', 'Show1', and 'Show2' instances. -} module Text.Show.Deriving ( -- * 'Show' deriveShow , deriveShowOptions , makeShowsPrec , makeShowsPrecOptions , makeShow , makeShowOptions , makeShowList , makeShowListOptions -- * 'Show1' , deriveShow1 , deriveShow1Options #if defined(NEW_FUNCTOR_CLASSES) , makeLiftShowsPrec , makeLiftShowsPrecOptions , makeLiftShowList , makeLiftShowListOptions #endif , makeShowsPrec1 , makeShowsPrec1Options #if defined(NEW_FUNCTOR_CLASSES) -- * 'Show2' , deriveShow2 , deriveShow2Options , makeLiftShowsPrec2 , makeLiftShowsPrec2Options , makeLiftShowList2 , makeLiftShowList2Options , makeShowsPrec2 , makeShowsPrec2Options #endif -- * 'ShowOptions' , ShowOptions(..) , defaultShowOptions , legacyShowOptions -- * 'deriveShow' limitations -- $constraints ) where import Text.Show.Deriving.Internal {- $constraints Be aware of the following potential gotchas: * Type variables of kind @*@ are assumed to have 'Show' constraints. Type variables of kind @* -> *@ are assumed to have 'Show1' constraints. Type variables of kind @* -> * -> *@ are assumed to have 'Show2' constraints. If this is not desirable, use 'makeShowsPrec' or one of its cousins. * The 'Show1' class had a different definition in @transformers-0.4@, and as a result, 'deriveShow1' implements different instances for the @transformers-0.4@ 'Show1' than it otherwise does. Also, 'makeLiftShowsPrec' and 'makeLiftShowList' are not available when this library is built against @transformers-0.4@, only 'makeShowsPrec1. * The 'Show2' class is not available in @transformers-0.4@, and as a result, neither are Template Haskell functions that deal with 'Show2' when this library is built against @transformers-0.4@. -} deriving-compat-0.3.4/src/Text/Show/Deriving/0000755000000000000000000000000013002245656017201 5ustar0000000000000000deriving-compat-0.3.4/src/Text/Show/Deriving/Internal.hs0000644000000000000000000006237213002245656021323 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-| Module: Text.Show.Deriving.Internal Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Exports functions to mechanically derive 'Show', 'Show1', and 'Show2' instances. -} module Text.Show.Deriving.Internal ( -- * 'Show' deriveShow , deriveShowOptions , makeShowsPrec , makeShowsPrecOptions , makeShow , makeShowOptions , makeShowList , makeShowListOptions -- * 'Show1' , deriveShow1 , deriveShow1Options #if defined(NEW_FUNCTOR_CLASSES) , makeLiftShowsPrec , makeLiftShowsPrecOptions , makeLiftShowList , makeLiftShowListOptions #endif , makeShowsPrec1 , makeShowsPrec1Options #if defined(NEW_FUNCTOR_CLASSES) -- * 'Show2' , deriveShow2 , deriveShow2Options , makeLiftShowsPrec2 , makeLiftShowsPrec2Options , makeLiftShowList2 , makeLiftShowList2Options , makeShowsPrec2 , makeShowsPrec2Options #endif -- * 'ShowOptions' , ShowOptions(..) , defaultShowOptions , legacyShowOptions ) where #if MIN_VERSION_template_haskell(2,11,0) import Control.Monad ((<=<)) import Data.Maybe (fromMaybe, isJust) #endif import Data.Deriving.Internal import Data.List import qualified Data.Map as Map import GHC.Show (appPrec, appPrec1) import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax -- | Options that further configure how the functions in "Text.Show.Deriving" -- should behave. newtype ShowOptions = ShowOptions { ghc8ShowBehavior :: Bool -- ^ If 'True', the derived 'Show', 'Show1', or 'Show2' instance will not -- surround the output of showing fields of unlifted types with parentheses, -- and the output will be suffixed with hash signs (@#@). } deriving (Eq, Ord, Read, Show) -- | 'ShowOptions' that match the behavior of the most recent GHC release. defaultShowOptions :: ShowOptions defaultShowOptions = ShowOptions { ghc8ShowBehavior = True } -- | 'ShowOptions' that match the behavior of the installed version of GHC. legacyShowOptions :: ShowOptions legacyShowOptions = ShowOptions { ghc8ShowBehavior = #if __GLASGOW_HASKELL__ >= 711 True #else False #endif } -- | Generates a 'Show' instance declaration for the given data type or data -- family instance. deriveShow :: Name -> Q [Dec] deriveShow = deriveShowOptions defaultShowOptions -- | Like 'deriveShow', but takes a 'ShowOptions' argument. deriveShowOptions :: ShowOptions -> Name -> Q [Dec] deriveShowOptions = deriveShowClass Show -- | Generates a lambda expression which behaves like 'show' (without -- requiring a 'Show' instance). makeShow :: Name -> Q Exp makeShow = makeShowOptions defaultShowOptions -- | Like 'makeShow', but takes a 'ShowOptions' argument. makeShowOptions :: ShowOptions -> Name -> Q Exp makeShowOptions opts name = do x <- newName "x" lam1E (varP x) $ makeShowsPrecOptions opts name `appE` integerE 0 `appE` varE x `appE` stringE "" -- | Generates a lambda expression which behaves like 'showsPrec' (without -- requiring a 'Show' instance). makeShowsPrec :: Name -> Q Exp makeShowsPrec = makeShowsPrecOptions defaultShowOptions -- | Like 'makeShowsPrec', but takes a 'ShowOptions' argument. makeShowsPrecOptions :: ShowOptions -> Name -> Q Exp makeShowsPrecOptions = makeShowsPrecClass Show -- | Generates a lambda expression which behaves like 'showList' (without -- requiring a 'Show' instance). makeShowList :: Name -> Q Exp makeShowList = makeShowListOptions defaultShowOptions -- | Like 'makeShowList', but takes a 'ShowOptions' argument. makeShowListOptions :: ShowOptions -> Name -> Q Exp makeShowListOptions opts name = varE showListWithValName `appE` (makeShowsPrecOptions opts name `appE` integerE 0) -- | Generates a 'Show1' instance declaration for the given data type or data -- family instance. deriveShow1 :: Name -> Q [Dec] deriveShow1 = deriveShow1Options defaultShowOptions -- | Like 'deriveShow1', but takes a 'ShowOptions' argument. deriveShow1Options :: ShowOptions -> Name -> Q [Dec] deriveShow1Options = deriveShowClass Show1 -- | Generates a lambda expression which behaves like 'showsPrec1' (without -- requiring a 'Show1' instance). makeShowsPrec1 :: Name -> Q Exp makeShowsPrec1 = makeShowsPrec1Options defaultShowOptions #if defined(NEW_FUNCTOR_CLASSES) -- | Generates a lambda expression which behaves like 'liftShowsPrec' (without -- requiring a 'Show1' instance). -- -- This function is not available with @transformers-0.4@. makeLiftShowsPrec :: Name -> Q Exp makeLiftShowsPrec = makeLiftShowsPrecOptions defaultShowOptions -- | Like 'makeLiftShowsPrec', but takes a 'ShowOptions' argument. -- -- This function is not available with @transformers-0.4@. makeLiftShowsPrecOptions :: ShowOptions -> Name -> Q Exp makeLiftShowsPrecOptions = makeShowsPrecClass Show1 -- | Generates a lambda expression which behaves like 'liftShowList' (without -- requiring a 'Show' instance). -- -- This function is not available with @transformers-0.4@. makeLiftShowList :: Name -> Q Exp makeLiftShowList = makeLiftShowListOptions defaultShowOptions -- | Like 'makeLiftShowList', but takes a 'ShowOptions' argument. -- -- This function is not available with @transformers-0.4@. makeLiftShowListOptions :: ShowOptions -> Name -> Q Exp makeLiftShowListOptions opts name = do sp' <- newName "sp'" sl' <- newName "sl'" lamE [varP sp', varP sl'] $ varE showListWithValName `appE` (makeLiftShowsPrecOptions opts name `appE` varE sp' `appE` varE sl' `appE` integerE 0) -- | Like 'makeShowsPrec1', but takes a 'ShowOptions' argument. makeShowsPrec1Options :: ShowOptions -> Name -> Q Exp makeShowsPrec1Options opts name = makeLiftShowsPrecOptions opts name `appE` varE showsPrecValName `appE` varE showListValName #else -- | Like 'makeShowsPrec1', but takes a 'ShowOptions' argument. makeShowsPrec1Options :: ShowOptions -> Name -> Q Exp makeShowsPrec1Options = makeShowsPrecClass Show1 #endif #if defined(NEW_FUNCTOR_CLASSES) -- | Generates a 'Show2' instance declaration for the given data type or data -- family instance. -- -- This function is not available with @transformers-0.4@. deriveShow2 :: Name -> Q [Dec] deriveShow2 = deriveShow2Options defaultShowOptions -- | Like 'deriveShow2', but takes a 'ShowOptions' argument. -- -- This function is not available with @transformers-0.4@. deriveShow2Options :: ShowOptions -> Name -> Q [Dec] deriveShow2Options = deriveShowClass Show2 -- | Generates a lambda expression which behaves like 'liftShowsPrec2' (without -- requiring a 'Show2' instance). -- -- This function is not available with @transformers-0.4@. makeLiftShowsPrec2 :: Name -> Q Exp makeLiftShowsPrec2 = makeLiftShowsPrec2Options defaultShowOptions -- | Like 'makeLiftShowsPrec2', but takes a 'ShowOptions' argument. -- -- This function is not available with @transformers-0.4@. makeLiftShowsPrec2Options :: ShowOptions -> Name -> Q Exp makeLiftShowsPrec2Options = makeShowsPrecClass Show2 -- | Generates a lambda expression which behaves like 'liftShowList2' (without -- requiring a 'Show' instance). -- -- This function is not available with @transformers-0.4@. makeLiftShowList2 :: Name -> Q Exp makeLiftShowList2 = makeLiftShowList2Options defaultShowOptions -- | Like 'makeLiftShowList2', but takes a 'ShowOptions' argument. -- -- This function is not available with @transformers-0.4@. makeLiftShowList2Options :: ShowOptions -> Name -> Q Exp makeLiftShowList2Options opts name = do sp1' <- newName "sp1'" sl1' <- newName "sl1'" sp2' <- newName "sp2'" sl2' <- newName "sl2'" lamE [varP sp1', varP sl1', varP sp2', varP sl2'] $ varE showListWithValName `appE` (makeLiftShowsPrec2Options opts name `appE` varE sp1' `appE` varE sl1' `appE` varE sp2' `appE` varE sl2' `appE` integerE 0) -- | Generates a lambda expression which behaves like 'showsPrec2' (without -- requiring a 'Show2' instance). -- -- This function is not available with @transformers-0.4@. makeShowsPrec2 :: Name -> Q Exp makeShowsPrec2 = makeShowsPrec2Options defaultShowOptions -- | Like 'makeShowsPrec2', but takes a 'ShowOptions' argument. -- -- This function is not available with @transformers-0.4@. makeShowsPrec2Options :: ShowOptions -> Name -> Q Exp makeShowsPrec2Options opts name = makeLiftShowsPrec2Options opts name `appE` varE showsPrecValName `appE` varE showListValName `appE` varE showsPrecValName `appE` varE showListValName #endif ------------------------------------------------------------------------------- -- Code generation ------------------------------------------------------------------------------- -- | Derive a Show(1)(2) instance declaration (depending on the ShowClass -- argument's value). deriveShowClass :: ShowClass -> ShowOptions -> Name -> Q [Dec] deriveShowClass sClass opts name = withType name fromCons where fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do (instanceCxt, instanceType) <- buildTypeInstance sClass name' ctxt tvbs mbTys instanceD (return instanceCxt) (return instanceType) (showsPrecDecs sClass opts cons) -- | Generates a declaration defining the primary function corresponding to a -- particular class (showsPrec for Show, liftShowsPrec for Show1, and -- liftShowsPrec2 for Show2). showsPrecDecs :: ShowClass -> ShowOptions -> [Con] -> [Q Dec] showsPrecDecs sClass opts cons = [ funD (showsPrecName sClass) [ clause [] (normalB $ makeShowForCons sClass opts cons) [] ] ] -- | Generates a lambda expression which behaves like showsPrec (for Show), -- liftShowsPrec (for Show1), or liftShowsPrec2 (for Show2). makeShowsPrecClass :: ShowClass -> ShowOptions -> Name -> Q Exp makeShowsPrecClass sClass opts name = withType name fromCons where fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp fromCons name' ctxt tvbs cons mbTys = -- We force buildTypeInstance here since it performs some checks for whether -- or not the provided datatype can actually have showsPrec/liftShowsPrec/etc. -- implemented for it, and produces errors if it can't. buildTypeInstance sClass name' ctxt tvbs mbTys `seq` makeShowForCons sClass opts cons -- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for the -- given constructors. All constructors must be from the same type. makeShowForCons :: ShowClass -> ShowOptions -> [Con] -> Q Exp makeShowForCons _ _ [] = noConstructorsError makeShowForCons sClass opts cons = do p <- newName "p" value <- newName "value" sps <- newNameList "sp" $ arity sClass sls <- newNameList "sl" $ arity sClass let spls = zip sps sls _spsAndSls = interleave sps sls matches <- concatMapM (makeShowForCon p sClass opts spls) cons lamE (map varP $ #if defined(NEW_FUNCTOR_CLASSES) _spsAndSls ++ #endif [p, value]) . appsE $ [ varE $ showsPrecConstName sClass , caseE (varE value) (map return matches) ] #if defined(NEW_FUNCTOR_CLASSES) ++ map varE _spsAndSls #endif ++ [varE p, varE value] -- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for a -- single constructor. makeShowForCon :: Name -> ShowClass -> ShowOptions -> [(Name, Name)] -> Con -> Q [Match] makeShowForCon _ sClass _ spls (NormalC conName []) = do ([], _) <- reifyConTys2 sClass spls conName m <- match (conP conName []) (normalB $ varE showStringValName `appE` stringE (parenInfixConName conName "")) [] return [m] makeShowForCon p sClass opts spls (NormalC conName [_]) = do ([argTy], tvMap) <- reifyConTys2 sClass spls conName arg <- newName "arg" let showArg = makeShowForArg appPrec1 sClass opts conName tvMap argTy arg namedArg = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " ")) (varE composeValName) showArg m <- match (conP conName [varP arg]) (normalB $ varE showParenValName `appE` infixApp (varE p) (varE gtValName) (integerE appPrec) `appE` namedArg) [] return [m] makeShowForCon p sClass opts spls (NormalC conName _) = do (argTys, tvMap) <- reifyConTys2 sClass spls conName args <- newNameList "arg" $ length argTys m <- if isNonUnitTuple conName then do let showArgs = zipWith (makeShowForArg 0 sClass opts conName tvMap) argTys args parenCommaArgs = (varE showCharValName `appE` charE '(') : intersperse (varE showCharValName `appE` charE ',') showArgs mappendArgs = foldr (`infixApp` varE composeValName) (varE showCharValName `appE` charE ')') parenCommaArgs match (conP conName $ map varP args) (normalB mappendArgs) [] else do let showArgs = zipWith (makeShowForArg appPrec1 sClass opts conName tvMap) argTys args mappendArgs = foldr1 (\v q -> infixApp v (varE composeValName) (infixApp (varE showSpaceValName) (varE composeValName) q)) showArgs namedArgs = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " ")) (varE composeValName) mappendArgs match (conP conName $ map varP args) (normalB $ varE showParenValName `appE` infixApp (varE p) (varE gtValName) (integerE appPrec) `appE` namedArgs) [] return [m] makeShowForCon p sClass opts spls (RecC conName []) = makeShowForCon p sClass opts spls $ NormalC conName [] makeShowForCon p sClass opts spls (RecC conName ts) = do (argTys, tvMap) <- reifyConTys2 sClass spls conName args <- newNameList "arg" $ length argTys let showArgs = concatMap (\((argName, _, _), argTy, arg) -> let argNameBase = nameBase argName infixRec = showParen (isSym argNameBase) (showString argNameBase) "" in [ varE showStringValName `appE` stringE (infixRec ++ " = ") , makeShowForArg 0 sClass opts conName tvMap argTy arg , varE showStringValName `appE` stringE ", " ] ) (zip3 ts argTys args) braceCommaArgs = (varE showCharValName `appE` charE '{') : take (length showArgs - 1) showArgs mappendArgs = foldr (`infixApp` varE composeValName) (varE showCharValName `appE` charE '}') braceCommaArgs namedArgs = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " ")) (varE composeValName) mappendArgs m <- match (conP conName $ map varP args) (normalB $ varE showParenValName `appE` infixApp (varE p) (varE gtValName) (integerE appPrec) `appE` namedArgs) [] return [m] makeShowForCon p sClass opts spls (InfixC _ conName _) = do ([alTy, arTy], tvMap) <- reifyConTys2 sClass spls conName al <- newName "argL" ar <- newName "argR" info <- reify conName #if MIN_VERSION_template_haskell(2,11,0) conPrec <- case info of DataConI{} -> do fi <- fromMaybe defaultFixity <$> reifyFixity conName case fi of Fixity prec _ -> return prec #else let conPrec = case info of DataConI _ _ _ (Fixity prec _) -> prec #endif _ -> error $ "Text.Show.Deriving.Internal.makeShowForCon: Unsupported type: " ++ show info let opName = nameBase conName infixOpE = appE (varE showStringValName) . stringE $ if isInfixDataCon opName then " " ++ opName ++ " " else " `" ++ opName ++ "` " m <- match (infixP (varP al) conName (varP ar)) (normalB $ (varE showParenValName `appE` infixApp (varE p) (varE gtValName) (integerE conPrec)) `appE` (infixApp (makeShowForArg (conPrec + 1) sClass opts conName tvMap alTy al) (varE composeValName) (infixApp infixOpE (varE composeValName) (makeShowForArg (conPrec + 1) sClass opts conName tvMap arTy ar))) ) [] return [m] makeShowForCon p sClass opts spls (ForallC _ _ con) = makeShowForCon p sClass opts spls con #if MIN_VERSION_template_haskell(2,11,0) makeShowForCon p sClass opts spls (GadtC conNames ts _) = let con :: Name -> Q Con con conName = do mbFi <- reifyFixity conName return $ if isInfixDataCon (nameBase conName) && length ts == 2 && isJust mbFi then let [t1, t2] = ts in InfixC t1 conName t2 else NormalC conName ts in concatMapM (makeShowForCon p sClass opts spls <=< con) conNames makeShowForCon p sClass opts spls (RecGadtC conNames ts _) = concatMapM (makeShowForCon p sClass opts spls . flip RecC ts) conNames #endif -- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for an -- argument of a constructor. makeShowForArg :: Int -> ShowClass -> ShowOptions -> Name -> TyVarMap2 -> Type -> Name -> Q Exp makeShowForArg p _ opts _ _ (ConT tyName) tyExpName = showE where tyVarE :: Q Exp tyVarE = varE tyExpName showE :: Q Exp showE | tyName == charHashTypeName = showPrimE cHashDataName oneHashE | tyName == doubleHashTypeName = showPrimE dHashDataName twoHashE | tyName == floatHashTypeName = showPrimE fHashDataName oneHashE | tyName == intHashTypeName = showPrimE iHashDataName oneHashE | tyName == wordHashTypeName = showPrimE wHashDataName twoHashE | otherwise = varE showsPrecValName `appE` integerE p `appE` tyVarE -- Starting with GHC 7.10, data types containing unlifted types with derived Show -- instances show hashed literals with actual hash signs, and negative hashed -- literals are not surrounded with parentheses. showPrimE :: Name -> Q Exp -> Q Exp showPrimE con hashE | ghc8ShowBehavior opts = infixApp (varE showsPrecValName `appE` integerE 0 `appE` (conE con `appE` tyVarE)) (varE composeValName) hashE | otherwise = varE showsPrecValName `appE` integerE p `appE` (conE con `appE` tyVarE) oneHashE, twoHashE :: Q Exp oneHashE = varE showCharValName `appE` charE '#' twoHashE = varE showStringValName `appE` stringE "##" makeShowForArg p sClass _ conName tvMap ty tyExpName = makeShowForType sClass conName tvMap False ty `appE` integerE p `appE` varE tyExpName -- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for a -- specific type. The generated expression depends on the number of type variables. -- -- 1. If the type is of kind * (T), apply showsPrec. -- 2. If the type is of kind * -> * (T a), apply liftShowsPrec $(makeShowForType a) -- 3. If the type is of kind * -> * -> * (T a b), apply -- liftShowsPrec2 $(makeShowForType a) $(makeShowForType b) makeShowForType :: ShowClass -> Name -> TyVarMap2 -> Bool -- ^ True if we are using the function of type ([a] -> ShowS), -- False if we are using the function of type (Int -> a -> ShowS). -> Type -> Q Exp #if defined(NEW_FUNCTOR_CLASSES) makeShowForType _ _ tvMap sl (VarT tyName) = varE $ case Map.lookup tyName tvMap of Just (TwoNames spExp slExp) -> if sl then slExp else spExp Nothing -> if sl then showListValName else showsPrecValName #else makeShowForType _ _ _ _ VarT{} = varE showsPrecValName #endif makeShowForType sClass conName tvMap sl (SigT ty _) = makeShowForType sClass conName tvMap sl ty makeShowForType sClass conName tvMap sl (ForallT _ _ ty) = makeShowForType sClass conName tvMap sl ty #if defined(NEW_FUNCTOR_CLASSES) makeShowForType sClass conName tvMap sl ty = do let tyCon :: Type tyArgs :: [Type] tyCon:tyArgs = unapplyTy ty numLastArgs :: Int numLastArgs = min (arity sClass) (length tyArgs) lhsArgs, rhsArgs :: [Type] (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs tyVarNames :: [Name] tyVarNames = Map.keys tvMap itf <- isTyFamily tyCon if any (`mentionsName` tyVarNames) lhsArgs || itf && any (`mentionsName` tyVarNames) tyArgs then outOfPlaceTyVarError sClass conName else if any (`mentionsName` tyVarNames) rhsArgs then appsE $ [ varE . showsPrecOrListName sl $ toEnum numLastArgs] ++ zipWith (makeShowForType sClass conName tvMap) (cycle [False,True]) (interleave rhsArgs rhsArgs) else varE $ if sl then showListValName else showsPrecValName #else makeShowForType sClass conName tvMap _ ty = do let varNames = Map.keys tvMap p' <- newName "p'" value' <- newName "value'" case varNames of [] -> varE showsPrecValName varName:_ -> if mentionsName ty varNames then lamE [varP p', varP value'] $ varE showsPrec1ValName `appE` varE p' `appE` (makeFmapApplyNeg sClass conName ty varName `appE` varE value') else varE showsPrecValName #endif ------------------------------------------------------------------------------- -- Class-specific constants ------------------------------------------------------------------------------- -- | A representation of which @Show@ variant is being derived. data ShowClass = Show | Show1 #if defined(NEW_FUNCTOR_CLASSES) | Show2 #endif deriving (Bounded, Enum) instance ClassRep ShowClass where arity = fromEnum allowExQuant _ = True fullClassName Show = showTypeName fullClassName Show1 = show1TypeName #if defined(NEW_FUNCTOR_CLASSES) fullClassName Show2 = show2TypeName #endif classConstraint sClass i | sMin <= i && i <= sMax = Just $ fullClassName (toEnum i :: ShowClass) | otherwise = Nothing where sMin, sMax :: Int sMin = fromEnum (minBound :: ShowClass) sMax = fromEnum sClass showsPrecConstName :: ShowClass -> Name showsPrecConstName Show = showsPrecConstValName #if defined(NEW_FUNCTOR_CLASSES) showsPrecConstName Show1 = liftShowsPrecConstValName showsPrecConstName Show2 = liftShowsPrec2ConstValName #else showsPrecConstName Show1 = showsPrec1ConstValName #endif showsPrecName :: ShowClass -> Name showsPrecName Show = showsPrecValName #if defined(NEW_FUNCTOR_CLASSES) showsPrecName Show1 = liftShowsPrecValName showsPrecName Show2 = liftShowsPrec2ValName #else showsPrecName Show1 = showsPrec1ValName #endif #if defined(NEW_FUNCTOR_CLASSES) showListName :: ShowClass -> Name showListName Show = showListValName showListName Show1 = liftShowListValName showListName Show2 = liftShowList2ValName showsPrecOrListName :: Bool -- ^ showListName if True, showsPrecName if False -> ShowClass -> Name showsPrecOrListName False = showsPrecName showsPrecOrListName True = showListName #endif ------------------------------------------------------------------------------- -- Assorted utilities ------------------------------------------------------------------------------- -- | Parenthesize an infix constructor name if it is being applied as a prefix -- function (e.g., data Amp a = (:&) a a) parenInfixConName :: Name -> ShowS parenInfixConName conName = let conNameBase = nameBase conName in showParen (isInfixDataCon conNameBase) $ showString conNameBase charE :: Char -> Q Exp charE = litE . charL deriving-compat-0.3.4/src/Data/0000755000000000000000000000000013002245656014437 5ustar0000000000000000deriving-compat-0.3.4/src/Data/Deriving.hs0000644000000000000000000002066713002245656016555 0ustar0000000000000000{-| Module: Data.Deriving Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell This module reexports all of the functionality of the other modules in this library. It also provides a high-level tutorial on @deriving-compat@'s naming conventions and best practices. Typeclass-specific information can be found in their respective modules. -} module Data.Deriving ( -- * Backported changes -- $changes -- * @derive@- functions -- $derive -- * @make@- functions -- $make module Exports ) where import Data.Bounded.Deriving as Exports import Data.Enum.Deriving as Exports import Data.Eq.Deriving as Exports import Data.Foldable.Deriving as Exports import Data.Functor.Deriving as Exports import Data.Ix.Deriving as Exports import Data.Ord.Deriving as Exports import Data.Traversable.Deriving as Exports import Text.Read.Deriving as Exports import Text.Show.Deriving as Exports {- $changes The following changes have been backported: * In GHC 7.2, deriving 'Read' was changed so that constructors that use @MagicHash@ now parse correctly. * In GHC 7.8, deriving standalone 'Read' instances was fixed to avoid crashing on datatypes with no constructors. Derived 'Read' instances were also changed so as to compile more quickly. * In GHC 7.10, deriving standalone 'Read' and 'Show' instances were fixed to ensure that they use the correct fixity information for a particular datatype. * In GHC 8.0, @DeriveFoldable@ was changed to allow folding over data types with existential constraints. * In GHC 8.0, @DeriveFoldable@ and @DeriveTraversable@ were changed so as not to generate superfluous 'mempty' or 'pure' expressions in generated code. As a result, this allows deriving 'Traversable' instances for datatypes with unlifted argument types. * In GHC 8.0, deriving 'Ix' was changed to use @('&&')@ instead of @if@, as the latter interacts poorly with @RebindableSyntax@. A bug was also fixed so that standalone-derived 'Ix' instances for single-constructor GADTs do not crash GHC. * In GHC 8.0, deriving 'Show' was changed so that constructor fields with unlifted types are no longer shown with parentheses, and the output of showing an unlifted type is suffixed with the same number of hash signs as the corresponding primitive literals. * In GHC 8.2, deriving 'Ord' was changed so that it generates concrete @if@-expressions that are not subject to @RebindableSyntax@. It was also changed so that derived @('<=')@, @('>')@, and @('>=')@ methods are expressed through @('<')@, which avoids generating a substantial amount of code. -} {- $derive Functions with the @derive@- prefix can be used to automatically generate an instance of a typeclass for a given datatype 'Name'. Some examples: @ {-# LANGUAGE TemplateHaskell #-} import Data.Deriving data Pair a = Pair a a $('deriveFunctor' ''Pair) -- instance Functor Pair where ... data Product f g a = Product (f a) (g a) $('deriveFoldable' ''Product) -- instance (Foldable f, Foldable g) => Foldable (Pair f g) where ... @ If you are using @template-haskell-2.7.0.0@ or later (i.e., GHC 7.4 or later), then @derive@-functions can be used with data family instances (which requires the @-XTypeFamilies@ extension). To do so, pass the 'Name' of a data or newtype instance constructor (NOT a data family name!) to @deriveFoldable@. Note that the generated code may require the @-XFlexibleInstances@ extension. Example: @ {-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-} import Data.Deriving class AssocClass a b where data AssocData a b instance AssocClass Int b where data AssocData Int b = AssocDataInt1 Int | AssocDataInt2 b $('deriveFunctor' 'AssocDataInt1) -- instance Functor (AssocData Int) where ... -- Alternatively, one could use $(deriveFunctor 'AssocDataInt2) @ @derive@-functions in @deriving-compat@ fall into one of three categories: * Category 0: Typeclasses with an argument of kind @*@. ('deriveBounded', 'deriveEnum', 'deriveEq', 'deriveIx', 'deriveOrd', 'deriveRead', 'deriveShow') * Category 1: Typeclasses with an argument of kind @* -> *@, That is, a datatype with such an instance must have at least one type variable, and the last type variable must be of kind @*@. ('deriveEq1', 'deriveFoldable', 'deriveFunctor', 'deriveOrd1', 'deriveRead1', 'deriveShow1', 'deriveTraversable') * Category 2: Typeclasses with an argument of kind @* -> * -> *@. That is, a datatype with such an instance must have at least two type variables, and the last two type variables must be of kind @*@. ('deriveEq2', 'deriveOrd2', 'deriveRead2', 'deriveShow2') Note that there are some limitations to @derive@-functions: * The 'Name' argument must not be of a type synonym. * Type variables (other than the last ones) are assumed to require typeclass constraints. The constraints are different depending on the category. For example, for Category 0 functions, other type variables of kind @*@ are assumed to be constrained by that typeclass. As an example: @ data Foo a = Foo a $(deriveEq ''Foo) @ will result in a generated instance of: @ instance Eq a => Eq (Foo a) where ... @ If you do not want this behavior, use a @make@- function instead. * For Category 1 and 2 functions, if you are using the @-XDatatypeContexts@ extension, a constraint cannot mention the last type variables. For example, @data Illegal a where I :: Ord a => a -> Illegal a@ cannot have a derived 'Functor' instance. * For Category 1 and 2 functions, if one of the last type variables is used within a constructor field's type, it must only be used in the last type arguments. For example, @data Legal a = Legal (Either Int a)@ can have a derived 'Functor' instance, but @data Illegal a = Illegal (Either a Int)@ cannot. * For Category 1 and 2 functions, data family instances must be able to eta-reduce the last type variables. In other words, if you have a instance of the form: @ data family Family a1 ... an t1 ... tn data instance Family e1 ... e2 v1 ... vn = ... @ where @t1@, ..., @tn@ are the last type variables, then the following conditions must hold: 1. @v1@, ..., @vn@ must be type variables. 2. @v1@, ..., @vn@ must not be mentioned in any of @e1@, ..., @e2@. -} {- $make Functions prefixed with @make@- are similar to @derive@-functions in that they also generate code, but @make@-functions in particular generate the expression for a particular typeclass method. For example: @ {-# LANGUAGE TemplateHaskell #-} import Data.Deriving data Pair a = Pair a a instance Functor Pair where fmap = $('makeFmap' ''Pair) @ In this example, 'makeFmap' will splice in the appropriate lambda expression which implements 'fmap' for @Pair@. @make@-functions are subject to all the restrictions of @derive@-functions listed above save for one exception: the datatype need not be an instance of a particular typeclass. There are some scenarios where this might be preferred over using a @derive@-function. For example, you might want to map over a @Pair@ value without explicitly having to make it an instance of 'Functor'. Another use case for @make@-functions is sophisticated data types—that is, an expression for which a @derive@-function would infer the wrong instance context. Consider the following example: @ data Proxy a = Proxy $('deriveEq' ''Proxy) @ This would result in a generated instance of: @ instance Eq a => Eq (Proxy a) where ... @ This compiles, but is not what we want, since the @Eq a@ constraint is completely unnecessary. Another scenario in which @derive@-functions fail is when you have something like this: @ newtype HigherKinded f a b = HigherKinded (f a b) $('deriveFunctor' ''HigherKinded) @ Ideally, this would produce @HigherKinded (f a)@ as its instance context, but sadly, the Template Haskell type inference machinery used in @deriving-compat@ is not smart enough to figure that out. Nevertheless, @make@-functions provide a valuable backdoor for these sorts of scenarios: @ {-# LANGUAGE FlexibleContexts, TemplateHaskell #-} import Data.Foldable.Deriving data Proxy a = Proxy newtype HigherKinded f a b = HigherKinded (f a b) instance Eq (Proxy a) where (==) = $('makeEq' ''Proxy) instance Functor (f a) => Functor (HigherKinded f a) where fmap = $('makeFmap' ''HigherKinded) @ -} deriving-compat-0.3.4/src/Data/Deriving/0000755000000000000000000000000013002245656016206 5ustar0000000000000000deriving-compat-0.3.4/src/Data/Deriving/Internal.hs0000644000000000000000000023030313002245656020317 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MagicHash #-} #if !(MIN_VERSION_base(4,9,0)) # if __GLASGOW_HASKELL__ >= 800 {-# LANGUAGE TemplateHaskellQuotes #-} # else {-# LANGUAGE TemplateHaskell #-} # endif #endif {-| Module: Data.Deriving.Internal Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Template Haskell-related utilities. -} module Data.Deriving.Internal where import Control.Applicative (liftA2) import Control.Monad (liftM, when, unless) import Data.Foldable (foldr') #if !(MIN_VERSION_base(4,9,0)) import Data.Functor.Classes (Eq1(..), Ord1(..), Read1(..), Show1(..)) # if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) import Data.Functor.Classes (Eq2(..), Ord2(..), Read2(..), Show2(..)) # endif #endif import Data.List import qualified Data.Map as Map import Data.Map (Map) import Data.Maybe import qualified Data.Set as Set import Data.Set (Set) import Text.ParserCombinators.ReadPrec (ReadPrec) #if !(MIN_VERSION_base(4,7,0)) import GHC.Read (lexP) import Text.Read (pfail) import Text.Read.Lex (Lexeme) #endif #if MIN_VERSION_ghc_prim(0,3,1) import GHC.Prim (Int#, tagToEnum#) #endif #if defined(MIN_VERSION_ghc_boot_th) import GHC.Lexeme (startsConSym, startsVarSym) #else import Data.Char (isSymbol, ord) #endif import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr (pprint) import Language.Haskell.TH.Syntax -- Ensure, beyond a shadow of a doubt, that the instances are in-scope import Data.Functor () import Data.Functor.Classes () import Data.Foldable () import Data.Traversable () #ifndef CURRENT_PACKAGE_KEY import Data.Version (showVersion) import Paths_deriving_compat (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 un vs un (PlainTV v) = v un (KindedTV v _) = v 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 ------------------------------------------------------------------------------- -- Type-specialized const functions ------------------------------------------------------------------------------- fmapConst :: f b -> (a -> b) -> f a -> f b fmapConst x _ _ = x {-# INLINE fmapConst #-} foldrConst :: b -> (a -> b -> b) -> b -> t a -> b foldrConst x _ _ _ = x {-# INLINE foldrConst #-} foldMapConst :: m -> (a -> m) -> t a -> m foldMapConst x _ _ = x {-# INLINE foldMapConst #-} traverseConst :: f (t b) -> (a -> f b) -> t a -> f (t b) traverseConst x _ _ = x {-# INLINE traverseConst #-} eqConst :: Bool -> a -> a -> Bool eqConst x _ _ = x {-# INLINE eqConst #-} eq1Const :: Bool -> f a -> f a-> Bool eq1Const x _ _ = x {-# INLINE eq1Const #-} liftEqConst :: Bool -> (a -> b -> Bool) -> f a -> f b -> Bool liftEqConst x _ _ _ = x {-# INLINE liftEqConst #-} liftEq2Const :: Bool -> (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool liftEq2Const x _ _ _ _ = x {-# INLINE liftEq2Const #-} compareConst :: Ordering -> a -> a -> Ordering compareConst x _ _ = x {-# INLINE compareConst #-} ltConst :: Bool -> a -> a -> Bool ltConst x _ _ = x {-# INLINE ltConst #-} compare1Const :: Ordering -> f a -> f a -> Ordering compare1Const x _ _ = x {-# INLINE compare1Const #-} liftCompareConst :: Ordering -> (a -> b -> Ordering) -> f a -> f b -> Ordering liftCompareConst x _ _ _ = x {-# INLINE liftCompareConst #-} liftCompare2Const :: Ordering -> (a -> b -> Ordering) -> (c -> d -> Ordering) -> f a c -> f b d -> Ordering liftCompare2Const x _ _ _ _ = x {-# INLINE liftCompare2Const #-} readsPrecConst :: ReadS a -> Int -> ReadS a readsPrecConst x _ = x {-# INLINE readsPrecConst #-} -- This isn't really necessary, but it makes for an easier implementation readPrecConst :: ReadPrec a -> ReadPrec a readPrecConst x = x {-# INLINE readPrecConst #-} readsPrec1Const :: ReadS (f a) -> Int -> ReadS (f a) readsPrec1Const x _ = x {-# INLINE readsPrec1Const #-} liftReadsPrecConst :: ReadS (f a) -> (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a) liftReadsPrecConst x _ _ _ = x {-# INLINE liftReadsPrecConst #-} liftReadPrecConst :: ReadPrec (f a) -> ReadPrec a -> ReadPrec [a] -> ReadPrec (f a) liftReadPrecConst x _ _ = x {-# INLINE liftReadPrecConst #-} liftReadsPrec2Const :: ReadS (f a b) -> (Int -> ReadS a) -> ReadS [a] -> (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b) liftReadsPrec2Const x _ _ _ _ _ = x {-# INLINE liftReadsPrec2Const #-} liftReadPrec2Const :: ReadPrec (f a b) -> ReadPrec a -> ReadPrec [a] -> ReadPrec b -> ReadPrec [b] -> ReadPrec (f a b) liftReadPrec2Const x _ _ _ _ = x {-# INLINE liftReadPrec2Const #-} showsPrecConst :: ShowS -> Int -> a -> ShowS showsPrecConst x _ _ = x {-# INLINE showsPrecConst #-} showsPrec1Const :: ShowS -> Int -> f a -> ShowS showsPrec1Const x _ _ = x {-# INLINE showsPrec1Const #-} liftShowsPrecConst :: ShowS -> (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS liftShowsPrecConst x _ _ _ _ = x {-# INLINE liftShowsPrecConst #-} liftShowsPrec2Const :: ShowS -> (Int -> a -> ShowS) -> ([a] -> ShowS) -> (Int -> b -> ShowS) -> ([b] -> ShowS) -> Int -> f a b -> ShowS liftShowsPrec2Const x _ _ _ _ _ _ = x {-# INLINE liftShowsPrec2Const #-} ------------------------------------------------------------------------------- -- 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 ------------------------------------------------------------------------------- -- ClassRep ------------------------------------------------------------------------------- class ClassRep a where arity :: a -> Int allowExQuant :: a -> Bool fullClassName :: a -> Name classConstraint :: a -> Int -> Maybe Name ------------------------------------------------------------------------------- -- Template Haskell reifying and AST manipulation ------------------------------------------------------------------------------- -- | 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. withType :: Name -> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a) -> Q a withType name f = do info <- reify name case info of TyConI dec -> case dec of DataD ctxt _ tvbs #if MIN_VERSION_template_haskell(2,11,0) _ #endif cons _ -> f name ctxt tvbs cons Nothing NewtypeD ctxt _ tvbs #if MIN_VERSION_template_haskell(2,11,0) _ #endif con _ -> f name ctxt tvbs [con] Nothing _ -> fail $ 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 case parentInfo of # if MIN_VERSION_template_haskell(2,11,0) FamilyI (DataFamilyD _ tvbs _) decs -> # else FamilyI (FamilyD DataFam _ tvbs _) decs -> # endif let instDec = flip find decs $ \dec -> case dec of DataInstD _ _ _ # if MIN_VERSION_template_haskell(2,11,0) _ # endif cons _ -> any ((name ==) . constructorName) cons NewtypeInstD _ _ _ # if MIN_VERSION_template_haskell(2,11,0) _ # endif con _ -> name == constructorName con _ -> error $ ns ++ "Must be a data or newtype instance." in case instDec of Just (DataInstD ctxt _ instTys # if MIN_VERSION_template_haskell(2,11,0) _ # endif cons _) -> f parentName ctxt tvbs cons $ Just instTys Just (NewtypeInstD ctxt _ instTys # if MIN_VERSION_template_haskell(2,11,0) _ # endif con _) -> f parentName ctxt tvbs [con] $ Just instTys _ -> fail $ ns ++ "Could not find data or newtype instance constructor." _ -> fail $ 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 fail $ ns ++ "Cannot use a data family name. Use a data family instance constructor instead." _ -> fail $ ns ++ "The name must be of a plain data type constructor, " ++ "or a data family instance constructor." #else DataConI{} -> dataConIError _ -> fail $ ns ++ "The name must be of a plain type constructor." #endif where ns :: String ns = "Data.Deriving.Internal.withType: " -- | Deduces the instance context and head for an instance. buildTypeInstance :: ClassRep a => a -- ^ The typeclass for which an instance should be derived -> Name -- ^ The type constructor or data family name -> Cxt -- ^ The datatype context -> [TyVarBndr] -- ^ The type variables from the data type/data family declaration -> Maybe [Type] -- ^ 'Just' the types used to instantiate a data family instance, -- or 'Nothing' if it's a plain data type -> Q (Cxt, Type) -- Plain data type/newtype case buildTypeInstance cRep tyConName dataCxt tvbs Nothing = let varTys :: [Type] varTys = map tvbToType tvbs in buildTypeInstanceFromTys cRep tyConName dataCxt varTys False -- 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 cRep parentName dataCxt tvbs (Just 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 . tvbKind) 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] xTys = map VarT xTypeNames -- ^ 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). 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 cRep parentName dataCxt instTys True -- For the given Types, generate an instance context and head. 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 :: ClassRep a => a -- ^ The typeclass for which an instance should be derived -> Name -- ^ The type constructor or data family name -> Cxt -- ^ The datatype context -> [Type] -- ^ The types to instantiate the instance with -> Bool -- ^ True if it's a data family, False otherwise -> Q (Cxt, Type) buildTypeInstanceFromTys cRep tyConName dataCxt varTysOrig isDataFamily = 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 - arity cRep 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 cRep tyConName let droppedKindVarNames :: [Name] droppedKindVarNames = catKindVarNames droppedStarKindStati -- Substitute kind * for any dropped kind variables varTysExpSubst :: [Type] varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp remainingTysExpSubst, droppedTysExpSubst :: [Type] (remainingTysExpSubst, droppedTysExpSubst) = splitAt remainingLength varTysExpSubst -- All of the type variables mentioned in the dropped types -- (post-synonym expansion) droppedTyVarNames :: [Name] droppedTyVarNames = concatMap tyVarNamesOfType droppedTysExpSubst -- If any of the dropped types were polykinded, ensure that they are of kind * -- after substituting * for the dropped kind variables. If not, throw an error. unless (all hasKindStar droppedTysExpSubst) $ derivingKindError cRep tyConName let preds :: [Maybe Pred] kvNames :: [[Name]] kvNames' :: [Name] -- Derive instance constraints (and any kind variables which are specialized -- to * in those constraints) (preds, kvNames) = unzip $ map (deriveConstraint cRep) remainingTysExpSubst kvNames' = concat kvNames -- Substitute the kind variables specialized in the constraints with * remainingTysExpSubst' :: [Type] remainingTysExpSubst' = map (substNamesWithKindStar kvNames') remainingTysExpSubst -- 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]) remainingTysOrigSubst :: [Type] remainingTysOrigSubst = map (substNamesWithKindStar (union droppedKindVarNames kvNames')) $ take remainingLength varTysOrig remainingTysOrigSubst' :: [Type] -- See Note [Kind signatures in derived instances] for an explanation -- of the isDataFamily check. remainingTysOrigSubst' = if isDataFamily then remainingTysOrigSubst else map unSigT remainingTysOrigSubst instanceCxt :: Cxt instanceCxt = catMaybes preds instanceType :: Type instanceType = AppT (ConT (fullClassName cRep)) $ applyTyCon tyConName remainingTysOrigSubst' -- If the datatype context mentions any of the dropped type variables, -- we can't derive an instance, so throw an error. when (any (`predMentionsName` droppedTyVarNames) dataCxt) $ datatypeContextError tyConName instanceType -- Also ensure the dropped types can be safely eta-reduced. Otherwise, -- throw an error. unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $ etaReductionError instanceType return (instanceCxt, instanceType) -- | Attempt to derive a constraint on a Type. If successful, return -- Just the constraint and any kind variable names constrained to *. -- Otherwise, return Nothing and the empty list. -- -- See Note [Type inference in derived instances] for the heuristics used to -- come up with constraints. deriveConstraint :: ClassRep a => a -> Type -> (Maybe Pred, [Name]) deriveConstraint cRep t | not (isTyVar t) = (Nothing, []) | hasKindStar t = ((`applyClass` tName) `fmap` classConstraint cRep 0, []) | otherwise = case hasKindVarChain 1 t of Just ns | cRepArity >= 1 -> ((`applyClass` tName) `fmap` classConstraint cRep 1, ns) _ -> case hasKindVarChain 2 t of Just ns | cRepArity == 2 -> ((`applyClass` tName) `fmap` classConstraint cRep 2, ns) _ -> (Nothing, []) where tName :: Name tName = varTToName t cRepArity :: Int cRepArity = arity cRep {- 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It is possible to put explicit kind signatures into the derived instances, e.g., instance C a => C (Data (f :: * -> *)) where ... But it is preferable to avoid this if possible. If we come up with an incorrect kind signature (which is entirely possible, since our type inferencer is pretty unsophisticated - see Note [Type inference in derived instances]), then GHC will flat-out reject the instance, which is quite unfortunate. Plain old datatypes have the advantage that you can avoid using any kind signatures at all in their instances. This is because a datatype declaration uses all type variables, so the types that we use in a derived instance uniquely determine their kinds. As long as we plug in the right types, the kind inferencer can do the rest of the work. For this reason, we use unSigT to remove all kind signatures before splicing in the instance context and head. Data family instances are trickier, since a data family can have two instances that are distinguished by kind alone, e.g., data family Fam (a :: k) data instance Fam (a :: * -> *) data instance Fam (a :: *) If we dropped the kind signatures for C (Fam a), then GHC will have no way of knowing which instance we are talking about. To avoid this scenario, we always include explicit kind signatures in data family instances. There is a chance that the inferred kind signatures will be incorrect, but if so, we can always fall back on the make- functions. Note [Type inference in derived instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Type inference is can be tricky to get right, and we want to avoid recreating the entirety of GHC's type inferencer in Template Haskell. For this reason, we will probably never come up with derived instance contexts that are as accurate as GHC's. But that doesn't mean we can't do anything! There are a couple of simple things we can do to make instance contexts that work for 80% of use cases: 1. If one of the last type parameters is polykinded, then its kind will be specialized to * in the derived instance. We note what kind variable the type parameter had and substitute it with * in the other types as well. For example, imagine you had data Data (a :: k) (b :: k) Then you'd want to derived instance to be: instance C (Data (a :: *)) Not: instance C (Data (a :: k)) 2. We naïvely come up with instance constraints using the following criteria, using Show(1)(2) as the example typeclasses: (i) If there's a type parameter n of kind *, generate a Show n constraint. (ii) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind variables), then generate a Show1 n constraint, and if k1/k2 are kind variables, then substitute k1/k2 with * elsewhere in the types. We must consider the case where they are kind variables because you might have a scenario like this: newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1) = Compose (f (g a)) Which would have a derived Show1 instance of: instance (Show1 f, Show1 g) => Show1 (Compose f g) where ... (iii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are * or kind variables), then generate a Show2 constraint and perform kind substitution as in the other cases. -} -- Determines the types of a constructor's arguments as well as the last type -- parameters (mapped to their auxiliary functions), expanding through any type synonyms. -- The type parameters are determined on a constructor-by-constructor basis since -- they may be refined to be particular types in a GADT. reifyConTys :: ClassRep a => a -> [OneOrTwoNames b] -> Name -> Q ([Type], TyVarMap b) reifyConTys cRep auxs conName = do info <- reify conName (ctxt, uncTy) <- case info of DataConI _ ty _ #if !(MIN_VERSION_template_haskell(2,11,0)) _ #endif -> fmap uncurryTy (expandSyn ty) _ -> error "Must be a data constructor" let (argTys, [resTy]) = splitAt (length uncTy - 1) uncTy unapResTy = unapplyTy resTy cRepArity = arity cRep -- If one of the last type variables is refined to a particular type -- (i.e., not truly polymorphic), we mark it with Nothing and filter -- it out later, since we only apply auxiliary functions to arguments of -- a type that it (1) one of the last type variables, and (2) -- of a truly polymorphic type. mbTvNames = map varTToName_maybe $ drop (length unapResTy - cRepArity) unapResTy -- We use Map.fromList to ensure that if there are any duplicate type -- variables (as can happen in a GADT), the rightmost type variable gets -- associated with the auxiliary function. -- -- See Note [Matching functions with GADT type variables] tvMap = Map.fromList . catMaybes -- Drop refined types $ zipWith (\mbTvName aux -> fmap (\tvName -> (tvName, aux)) mbTvName) mbTvNames auxs if (any (`predMentionsName` Map.keys tvMap) ctxt || Map.size tvMap < cRepArity) && not (allowExQuant cRep) then existentialContextError conName else return (argTys, tvMap) reifyConTys1 :: ClassRep a => a -> [Name] -> Name -> Q ([Type], TyVarMap1) reifyConTys1 cRep auxs = reifyConTys cRep (map OneName auxs) reifyConTys2 :: ClassRep a => a -> [(Name, Name)] -> Name -> Q ([Type], TyVarMap2) reifyConTys2 cRep auxs = reifyConTys cRep (map (\(x, y) -> TwoNames x y) auxs) {- Note [Matching functions with GADT type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When deriving category-2 classes like Show2, there is a tricky corner case to consider: data Both a b where BothCon :: x -> x -> Both x x Which show functions should be applied to which arguments of BothCon? We have a choice, since both the function of type (Int -> a -> ShowS) and of type (Int -> b -> ShowS) can be applied to either argument. In such a scenario, the second show function takes precedence over the first show function, so the derived Show2 instance would be: instance Show2 Both where liftShowsPrec2 sp1 sp2 p (BothCon x1 x2) = showsParen (p > appPrec) $ showString "BothCon " . sp2 appPrec1 x1 . showSpace . sp2 appPrec1 x2 This is not an arbitrary choice, as this definition ensures that liftShowsPrec2 showsPrec = liftShowsPrec for a derived Show1 instance for Both. -} ------------------------------------------------------------------------------- -- Error messages ------------------------------------------------------------------------------- -- | The given datatype has no constructors, and we don't know what to do with it. noConstructorsError :: Q a noConstructorsError = fail "Must have at least one data constructor" -- | 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 :: ClassRep a => a -> Name -> Q b derivingKindError cRep tyConName = fail . showString "Cannot derive well-kinded instance of form ‘" . showString className . showChar ' ' . showParen True ( showString (nameBase tyConName) . showString " ..." ) . showString "‘\n\tClass " . showString className . showString " expects an argument of kind " . showString (pprint . createKindChain $ arity cRep) $ "" where className :: String className = nameBase $ fullClassName cRep -- | The last type variable appeared in a contravariant position -- when deriving Functor. contravarianceError :: Name -> Q a contravarianceError conName = fail . showString "Constructor ‘" . showString (nameBase conName) . showString "‘ must not use the last type variable in a function argument" $ "" -- | A constructor has a function argument in a derived Foldable or Traversable -- instance. noFunctionsError :: Name -> Q a noFunctionsError conName = fail . showString "Constructor ‘" . showString (nameBase conName) . showString "‘ must not contain function types" $ "" -- | One of the last type variables cannot be eta-reduced (see the canEtaReduce -- function for the criteria it would have to meet). etaReductionError :: Type -> Q a etaReductionError instanceType = fail $ "Cannot eta-reduce to an instance of form \n\tinstance (...) => " ++ pprint instanceType -- | The data type has a DatatypeContext which mentions one of the eta-reduced -- type variables. datatypeContextError :: Name -> Type -> Q a datatypeContextError dataName instanceType = fail . showString "Can't make a derived instance of ‘" . showString (pprint instanceType) . showString "‘:\n\tData type ‘" . showString (nameBase dataName) . showString "‘ must not have a class context involving the last type argument(s)" $ "" -- | The data type has an existential constraint which mentions one of the -- eta-reduced type variables. existentialContextError :: Name -> Q a existentialContextError conName = fail . showString "Constructor ‘" . showString (nameBase conName) . showString "‘ must be truly polymorphic in the last argument(s) of the data type" $ "" -- | The data type mentions one of the n eta-reduced type variables in a place other -- than the last nth positions of a data type in a constructor's field. outOfPlaceTyVarError :: ClassRep a => a -> Name -> Q b outOfPlaceTyVarError cRep conName = fail . showString "Constructor ‘" . showString (nameBase conName) . showString "‘ must only use its last " . shows n . showString " type variable(s) within the last " . shows n . showString " argument(s) of a data type" $ "" where n :: Int n = arity cRep -- | Template Haskell didn't list all of a data family's instances upon reification -- until template-haskell-2.7.0.0, which is necessary for a derived instance to work. dataConIError :: Q a dataConIError = fail . showString "Cannot use a data constructor." . showString "\n\t(Note: if you are trying to derive for a data family instance," . showString "\n\tuse GHC >= 7.4 instead.)" $ "" enumerationError :: String -> Q a enumerationError = fail . enumerationErrorStr enumerationOrProductError :: String -> Q a enumerationOrProductError nb = fail $ unlines [ enumerationErrorStr nb , "\tor a product type (precisely one constructor)" ] enumerationErrorStr :: String -> String enumerationErrorStr nb = '\'':nb ++ "’ must be an enumeration type" ++ " (one or more nullary, non-GADT constructors)" ------------------------------------------------------------------------------- -- Assorted utilities ------------------------------------------------------------------------------- -- | A mapping of type variable Names to their auxiliary function Names. type TyVarMap a = Map Name (OneOrTwoNames a) type TyVarMap1 = TyVarMap One type TyVarMap2 = TyVarMap Two data OneOrTwoNames a where OneName :: Name -> OneOrTwoNames One TwoNames :: Name -> Name -> OneOrTwoNames Two data One data Two interleave :: [a] -> [a] -> [a] interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s interleave _ _ = [] #if MIN_VERSION_ghc_prim(0,3,1) isTrue# :: Int# -> Bool isTrue# x = tagToEnum# x #else isTrue# :: Bool -> Bool isTrue# x = x #endif {-# INLINE isTrue# #-} -- isRight and fromEither taken from the extra package (BSD3-licensed) -- | Test if an 'Either' value is the 'Right' constructor. -- Provided as standard with GHC 7.8 and above. isRight :: Either l r -> Bool isRight Right{} = True; isRight _ = False -- | Pull the value out of an 'Either' where both alternatives -- have the same type. -- -- > \x -> fromEither (Left x ) == x -- > \x -> fromEither (Right x) == x fromEither :: Either a a -> a fromEither = either id id -- filterByList, filterByLists, and partitionByList taken from GHC (BSD3-licensed) -- | 'filterByList' takes a list of Bools and a list of some elements and -- filters out these elements for which the corresponding value in the list of -- Bools is False. This function does not check whether the lists have equal -- length. filterByList :: [Bool] -> [a] -> [a] filterByList (True:bs) (x:xs) = x : filterByList bs xs filterByList (False:bs) (_:xs) = filterByList bs xs filterByList _ _ = [] -- | 'filterByLists' takes a list of Bools and two lists as input, and -- outputs a new list consisting of elements from the last two input lists. For -- each Bool in the list, if it is 'True', then it takes an element from the -- former list. If it is 'False', it takes an element from the latter list. -- The elements taken correspond to the index of the Bool in its list. -- For example: -- -- @ -- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\" -- @ -- -- This function does not check whether the lists have equal length. filterByLists :: [Bool] -> [a] -> [a] -> [a] filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys filterByLists _ _ _ = [] -- | 'partitionByList' takes a list of Bools and a list of some elements and -- partitions the list according to the list of Bools. Elements corresponding -- to 'True' go to the left; elements corresponding to 'False' go to the right. -- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@ -- This function does not check whether the lists have equal -- length. partitionByList :: [Bool] -> [a] -> ([a], [a]) partitionByList = go [] [] where go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs go trues falses _ _ = (reverse trues, reverse falses) -- | Apply an @Either Exp Exp@ expression to an 'Exp' expression, -- preserving the 'Either'-ness. appEitherE :: Q (Either Exp Exp) -> Q Exp -> Q (Either Exp Exp) appEitherE e1Q e2Q = do e2 <- e2Q let e2' :: Exp -> Exp e2' = (`AppE` e2) either (Left . e2') (Right . e2') `fmap` e1Q integerE :: Int -> Q Exp integerE = litE . integerL . fromIntegral -- | 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 -- Returns True is a kind is equal to *, or if it is a kind variable. isStarOrVar :: Kind -> Bool #if MIN_VERSION_template_haskell(2,8,0) isStarOrVar StarT = True isStarOrVar VarT{} = True #else isStarOrVar StarK = True #endif isStarOrVar _ = 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 type/kind variable names mentioned somewhere in a Kind. tyVarNamesOfKind :: Kind -> [Name] #if MIN_VERSION_template_haskell(2,8,0) tyVarNamesOfKind = tyVarNamesOfType #else tyVarNamesOfKind _ = [] -- There are no kind variables #endif -- | @hasKindVarChain n kind@ Checks if @kind@ is of the form -- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or -- kind variables. hasKindVarChain :: Int -> Type -> Maybe [Name] hasKindVarChain kindArrows t = let uk = uncurryKind (tyKind t) in if (length uk - 1 == kindArrows) && all isStarOrVar uk then Just (concatMap tyVarNamesOfKind uk) else Nothing -- | If a Type is a SigT, returns its kind signature. Otherwise, return *. tyKind :: Type -> Kind tyKind (SigT _ k) = k tyKind _ = starK -- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr. stealKindForType :: TyVarBndr -> Type -> Type stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb) stealKindForType _ t = t -- | Monadic version of concatMap concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] concatMapM f xs = concat `liftM` mapM f xs zipWithAndUnzipM :: Monad m => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d]) zipWithAndUnzipM f (x:xs) (y:ys) = do (c, d) <- f x y (cs, ds) <- zipWithAndUnzipM f xs ys return (c:cs, d:ds) zipWithAndUnzipM _ _ _ = return ([], []) {-# INLINE zipWithAndUnzipM #-} zipWith3AndUnzipM :: Monad m => (a -> b -> c -> m (d, e)) -> [a] -> [b] -> [c] -> m ([d], [e]) zipWith3AndUnzipM f (x:xs) (y:ys) (z:zs) = do (d, e) <- f x y z (ds, es) <- zipWith3AndUnzipM f xs ys zs return (d:ds, e:es) zipWith3AndUnzipM _ _ _ _ = return ([], []) {-# INLINE zipWith3AndUnzipM #-} thd3 :: (a, b, c) -> c thd3 (_, _, c) = c -- | 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 isNullaryCon :: Con -> Bool isNullaryCon (NormalC _ []) = True isNullaryCon (RecC _ []) = True isNullaryCon InfixC{} = False isNullaryCon (ForallC _ _ con) = isNullaryCon con #if MIN_VERSION_template_haskell(2,11,0) isNullaryCon (GadtC _ [] _) = True isNullaryCon (RecGadtC _ [] _) = True #endif isNullaryCon _ = False -- | Returns the number of fields for the constructor. conArity :: Con -> Int conArity (NormalC _ tys) = length tys conArity (RecC _ tys) = length tys conArity InfixC{} = 2 conArity (ForallC _ _ con) = conArity con #if MIN_VERSION_template_haskell(2,11,0) conArity (GadtC _ tys _) = length tys conArity (RecGadtC _ tys _) = length tys #endif -- | Returns 'True' if it's a datatype with exactly one, non-existential constructor. isProductType :: [Con] -> Bool isProductType [con] = case con of ForallC tvbs _ _ -> null tvbs _ -> True isProductType _ = False -- | Returns 'True' if it's a datatype with one or more nullary, non-GADT -- constructors. isEnumerationType :: [Con] -> Bool isEnumerationType cons@(_:_) = all (liftA2 (&&) isNullaryCon isVanillaCon) cons isEnumerationType _ = False -- | Returns 'False' if we're dealing with existential quantification or GADTs. isVanillaCon :: Con -> Bool isVanillaCon NormalC{} = True isVanillaCon RecC{} = True isVanillaCon InfixC{} = True isVanillaCon ForallC{} = False #if MIN_VERSION_template_haskell(2,11,0) isVanillaCon GadtC{} = False isVanillaCon RecGadtC{} = False #endif -- | 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] -- | Extracts the kind from a TyVarBndr. tvbKind :: TyVarBndr -> Kind tvbKind (PlainTV _) = starK tvbKind (KindedTV _ k) = k -- | Convert a TyVarBndr to a Type. tvbToType :: TyVarBndr -> Type tvbToType (PlainTV n) = VarT n tvbToType (KindedTV n k) = SigT (VarT n) k -- | Applies a typeclass constraint to a type. applyClass :: Name -> Name -> Pred #if MIN_VERSION_template_haskell(2,10,0) applyClass con t = AppT (ConT con) (VarT t) #else applyClass con t = ClassP con [VarT t] #endif createKindChain :: Int -> Kind createKindChain = go starK where go :: Kind -> Int -> Kind go k !0 = k #if MIN_VERSION_template_haskell(2,8,0) go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1) #else go k !n = go (ArrowK StarK k) (n - 1) #endif -- | Checks to see if the last types in a data family instance can be safely eta- -- reduced (i.e., dropped), given the other types. This checks for three conditions: -- -- (1) All of the dropped types are type variables -- (2) All of the dropped types are distinct -- (3) None of the remaining types mention any of the dropped types canEtaReduce :: [Type] -> [Type] -> Bool canEtaReduce remaining dropped = all isTyVar dropped && allDistinct droppedNames -- Make sure not to pass something of type [Type], since Type -- didn't have an Ord instance until template-haskell-2.10.0.0 && not (any (`mentionsName` droppedNames) remaining) where droppedNames :: [Name] droppedNames = map varTToName dropped -- | Extract the Name from a type constructor. If the argument Type is not a -- type variable, throw an error. conTToName :: Type -> Name conTToName (ConT n) = n conTToName (SigT t _) = conTToName t conTToName _ = error "Not a type constructor!" -- | Extract Just the Name from a type variable. If the argument Type is not a -- type variable, return Nothing. varTToName_maybe :: Type -> Maybe Name varTToName_maybe (VarT n) = Just n varTToName_maybe (SigT t _) = varTToName_maybe t varTToName_maybe _ = Nothing -- | Extract the Name from a type variable. If the argument Type is not a -- type variable, throw an error. varTToName :: Type -> Name varTToName = fromMaybe (error "Not a type variable!") . varTToName_maybe -- | Peel off a kind signature from a Type (if it has one). unSigT :: Type -> Type unSigT (SigT t _) = t unSigT t = t -- | Is the given type a variable? isTyVar :: Type -> Bool isTyVar (VarT _) = True isTyVar (SigT t _) = isTyVar t isTyVar _ = False -- | 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 -- | 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 -- | 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 -- | Does an instance predicate mention any of the Names in the list? predMentionsName :: Pred -> [Name] -> Bool #if MIN_VERSION_template_haskell(2,10,0) predMentionsName = mentionsName #else predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names #endif -- | Construct a type via curried application. applyTy :: Type -> [Type] -> Type applyTy = foldl' AppT -- | Fully applies a type constructor to its type variables. applyTyCon :: Name -> [Type] -> Type applyTyCon = applyTy . 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) => (a -> b) -> Char -> () -- @ -- -- would split to this: -- -- @ -- (a ~ b, [a -> b, Char, ()]) -- @ uncurryTy :: Type -> (Cxt, [Type]) uncurryTy (AppT (AppT ArrowT t1) t2) = let (ctxt, tys) = uncurryTy t2 in (ctxt, t1:tys) uncurryTy (SigT t _) = uncurryTy t uncurryTy (ForallT _ ctxt t) = let (ctxt', tys) = uncurryTy t in (ctxt ++ ctxt', tys) uncurryTy t = ([], [t]) -- | Like uncurryType, except on a kind level. uncurryKind :: Kind -> [Kind] #if MIN_VERSION_template_haskell(2,8,0) uncurryKind = snd . uncurryTy #else uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2 uncurryKind k = [k] #endif untagExpr :: [(Name, Name)] -> Q Exp -> Q Exp untagExpr [] e = e untagExpr ((untagThis, putTagHere) : more) e = caseE (varE getTagValName `appE` varE untagThis) [match (varP putTagHere) (normalB $ untagExpr more e) []] tag2ConExpr :: Type -> Q Exp tag2ConExpr ty = do iHash <- newName "i#" ty' <- freshenType ty lam1E (conP iHashDataName [varP iHash]) $ varE tagToEnumHashValName `appE` varE iHash `sigE` return (ForallT (requiredTyVarsOfType ty') [] ty') -- tagToEnum# is a hack, and won't typecheck unless it's in the -- immediate presence of a type ascription like so: -- -- tagToEnum# x :: Foo -- -- We have to be careful when dealing with datatypes with type -- variables, since Template Haskell might reject the type variables -- we use for being out-of-scope. To avoid this, we explicitly -- collect the type variable binders with requiredTyVarsOfType -- and shove them into a ForallT. Also make sure to freshen the -- bound type variables to avoid shadowed variable warnings when -- -Wall is enabled. -- -- Note that we do NOT collect the kind variable binders, since -- a type signature like `forall k a. Foo (a :: k)` won't typecheck -- unless TypeInType is enabled (i.e., if GHC 8.0 or later is being -- used). Luckily, GHC seems to just accept kind variables, even if -- they aren't actually bound in a ForallT. removeClassApp :: Type -> Type removeClassApp (AppT _ t2) = t2 removeClassApp t = t -- This is an ugly, but unfortunately necessary hack on older versions of GHC which -- don't have a properly working newName. On those GHCs, even running newName on a -- variable isn't enought to avoid shadowed variable warnings, so we "fix" the issue by -- appending an uncommonly used string to the end of the name. This isn't foolproof, -- since a user could freshen a variable named x and still have another x_' variable in -- scope, but at least it's unlikely. freshen :: Name -> Q Name freshen n = newName (nameBase n ++ "_'") freshenType :: Type -> Q Type freshenType (AppT t1 t2) = do t1' <- freshenType t1 t2' <- freshenType t2 return $ AppT t1' t2' freshenType (SigT t k) = do t' <- freshenType t return $ SigT t' k freshenType (VarT n) = fmap VarT $ freshen n freshenType t = return t -- | Gets all of the required type variable binders mentioned in a Type. requiredTyVarsOfType :: Type -> [TyVarBndr] requiredTyVarsOfType = go where go :: Type -> [TyVarBndr] go (AppT t1 t2) = go t1 ++ go t2 go (SigT t _) = go t go (VarT n) = [PlainTV n] go _ = [] enumFromToExpr :: Q Exp -> Q Exp -> Q Exp enumFromToExpr f t = varE enumFromToValName `appE` f `appE` t primOpAppExpr :: Q Exp -> Name -> Q Exp -> Q Exp primOpAppExpr e1 op e2 = varE isTrueHashValName `appE` infixApp e1 (varE op) e2 -- | Checks if a 'Name' represents a tuple type constructor (other than '()') isNonUnitTuple :: Name -> Bool isNonUnitTuple = isNonUnitTupleString . nameBase -- | Checks if a 'String' represents a tuple (other than '()') isNonUnitTupleString :: String -> Bool isNonUnitTupleString ('(':',':_) = True isNonUnitTupleString _ = False -- | Checks if a 'String' names a valid Haskell infix data constructor (i.e., does -- it begin with a colon?). isInfixDataCon :: String -> Bool isInfixDataCon (':':_) = True isInfixDataCon _ = False isSym :: String -> Bool isSym "" = False isSym (c : _) = startsVarSym c || startsConSym c #if !defined(MIN_VERSION_ghc_boot_th) startsVarSym, startsConSym :: Char -> Bool startsVarSym c = startsVarSymASCII c || (ord c > 0x7f && isSymbol c) -- Infix Ids startsConSym c = c == ':' -- Infix data constructors startsVarSymASCII :: Char -> Bool startsVarSymASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" #endif ------------------------------------------------------------------------------- -- Manually quoted names ------------------------------------------------------------------------------- -- By manually generating these names we avoid needing to use the -- TemplateHaskell language extension when compiling the deriving-compat library. -- This allows the library to be used in stage1 cross-compilers. derivingCompatPackageKey :: String #ifdef CURRENT_PACKAGE_KEY derivingCompatPackageKey = CURRENT_PACKAGE_KEY #else derivingCompatPackageKey = "deriving-compat-" ++ showVersion version #endif mkDerivingCompatName_v :: String -> Name mkDerivingCompatName_v = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" isTrueHashValName :: Name isTrueHashValName = mkDerivingCompatName_v "isTrue#" fmapConstValName :: Name fmapConstValName = mkDerivingCompatName_v "fmapConst" foldrConstValName :: Name foldrConstValName = mkDerivingCompatName_v "foldrConst" foldMapConstValName :: Name foldMapConstValName = mkDerivingCompatName_v "foldMapConst" traverseConstValName :: Name traverseConstValName = mkDerivingCompatName_v "traverseConst" eqConstValName :: Name eqConstValName = mkDerivingCompatName_v "eqConst" eq1ConstValName :: Name eq1ConstValName = mkDerivingCompatName_v "eq1Const" liftEqConstValName :: Name liftEqConstValName = mkDerivingCompatName_v "liftEqConst" liftEq2ConstValName :: Name liftEq2ConstValName = mkDerivingCompatName_v "liftEq2Const" compareConstValName :: Name compareConstValName = mkDerivingCompatName_v "compareConst" ltConstValName :: Name ltConstValName = mkDerivingCompatName_v "ltConst" compare1ConstValName :: Name compare1ConstValName = mkDerivingCompatName_v "compare1Const" liftCompareConstValName :: Name liftCompareConstValName = mkDerivingCompatName_v "liftCompareConst" liftCompare2ConstValName :: Name liftCompare2ConstValName = mkDerivingCompatName_v "liftCompare2Const" readsPrecConstValName :: Name readsPrecConstValName = mkDerivingCompatName_v "readsPrecConst" readPrecConstValName :: Name readPrecConstValName = mkDerivingCompatName_v "readPrecConst" readsPrec1ConstValName :: Name readsPrec1ConstValName = mkDerivingCompatName_v "readsPrec1Const" liftReadsPrecConstValName :: Name liftReadsPrecConstValName = mkDerivingCompatName_v "liftReadsPrecConst" liftReadPrecConstValName :: Name liftReadPrecConstValName = mkDerivingCompatName_v "liftReadPrecConst" liftReadsPrec2ConstValName :: Name liftReadsPrec2ConstValName = mkDerivingCompatName_v "liftReadsPrec2Const" liftReadPrec2ConstValName :: Name liftReadPrec2ConstValName = mkDerivingCompatName_v "liftReadPrec2Const" showsPrecConstValName :: Name showsPrecConstValName = mkDerivingCompatName_v "showsPrecConst" showsPrec1ConstValName :: Name showsPrec1ConstValName = mkDerivingCompatName_v "showsPrec1Const" liftShowsPrecConstValName :: Name liftShowsPrecConstValName = mkDerivingCompatName_v "liftShowsPrecConst" liftShowsPrec2ConstValName :: Name liftShowsPrec2ConstValName = mkDerivingCompatName_v "liftShowsPrec2Const" cHashDataName :: Name cHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "C#" dHashDataName :: Name dHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "D#" dualDataName :: Name dualDataName = mkNameG_d "base" "Data.Monoid" "Dual" endoDataName :: Name endoDataName = mkNameG_d "base" "Data.Monoid" "Endo" fHashDataName :: Name fHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "F#" identDataName :: Name identDataName = mkNameG_d "base" "Text.Read.Lex" "Ident" iHashDataName :: Name iHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "I#" puncDataName :: Name puncDataName = mkNameG_d "base" "Text.Read.Lex" "Punc" symbolDataName :: Name symbolDataName = mkNameG_d "base" "Text.Read.Lex" "Symbol" wrapMonadDataName :: Name wrapMonadDataName = mkNameG_d "base" "Control.Applicative" "WrapMonad" addrHashTypeName :: Name addrHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Addr#" boundedTypeName :: Name boundedTypeName = mkNameG_tc "base" "GHC.Enum" "Bounded" charHashTypeName :: Name charHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Char#" doubleHashTypeName :: Name doubleHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Double#" enumTypeName :: Name enumTypeName = mkNameG_tc "base" "GHC.Enum" "Enum" floatHashTypeName :: Name floatHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Float#" foldableTypeName :: Name foldableTypeName = mkNameG_tc "base" "Data.Foldable" "Foldable" functorTypeName :: Name functorTypeName = mkNameG_tc "base" "GHC.Base" "Functor" intTypeName :: Name intTypeName = mkNameG_tc "ghc-prim" "GHC.Types" "Int" intHashTypeName :: Name intHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Int#" ixTypeName :: Name ixTypeName = mkNameG_tc "base" "GHC.Arr" "Ix" readTypeName :: Name readTypeName = mkNameG_tc "base" "GHC.Read" "Read" showTypeName :: Name showTypeName = mkNameG_tc "base" "GHC.Show" "Show" traversableTypeName :: Name traversableTypeName = mkNameG_tc "base" "Data.Traversable" "Traversable" wordHashTypeName :: Name wordHashTypeName = mkNameG_tc "ghc-prim" "GHC.Prim" "Word#" altValName :: Name altValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "+++" appEndoValName :: Name appEndoValName = mkNameG_v "base" "Data.Monoid" "appEndo" appendValName :: Name appendValName = mkNameG_v "base" "GHC.Base" "++" chooseValName :: Name chooseValName = mkNameG_v "base" "GHC.Read" "choose" composeValName :: Name composeValName = mkNameG_v "base" "GHC.Base" "." constValName :: Name constValName = mkNameG_v "base" "GHC.Base" "const" enumFromValName :: Name enumFromValName = mkNameG_v "base" "GHC.Enum" "enumFrom" enumFromThenValName :: Name enumFromThenValName = mkNameG_v "base" "GHC.Enum" "enumFromThen" enumFromThenToValName :: Name enumFromThenToValName = mkNameG_v "base" "GHC.Enum" "enumFromThenTo" enumFromToValName :: Name enumFromToValName = mkNameG_v "base" "GHC.Enum" "enumFromTo" eqAddrHashValName :: Name eqAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqAddr#" eqCharHashValName :: Name eqCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqChar#" eqDoubleHashValName :: Name eqDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "==##" eqFloatHashValName :: Name eqFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqFloat#" eqIntHashValName :: Name eqIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "==#" eqWordHashValName :: Name eqWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "eqWord#" errorValName :: Name errorValName = mkNameG_v "base" "GHC.Err" "error" flipValName :: Name flipValName = mkNameG_v "base" "GHC.Base" "flip" fmapValName :: Name fmapValName = mkNameG_v "base" "GHC.Base" "fmap" foldrValName :: Name foldrValName = mkNameG_v "base" "Data.Foldable" "foldr" foldMapValName :: Name foldMapValName = mkNameG_v "base" "Data.Foldable" "foldMap" fromEnumValName :: Name fromEnumValName = mkNameG_v "base" "GHC.Enum" "fromEnum" geAddrHashValName :: Name geAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geAddr#" geCharHashValName :: Name geCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geChar#" geDoubleHashValName :: Name geDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">=##" geFloatHashValName :: Name geFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geFloat#" geIntHashValName :: Name geIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">=#" getDualValName :: Name getDualValName = mkNameG_v "base" "Data.Monoid" "getDual" getTagValName :: Name getTagValName = mkNameG_v "base" "GHC.Base" "getTag" geWordHashValName :: Name geWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "geWord#" gtAddrHashValName :: Name gtAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtAddr#" gtCharHashValName :: Name gtCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtChar#" gtDoubleHashValName :: Name gtDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">##" gtFloatHashValName :: Name gtFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtFloat#" gtIntHashValName :: Name gtIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" ">#" gtWordHashValName :: Name gtWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "gtWord#" idValName :: Name idValName = mkNameG_v "base" "GHC.Base" "id" indexValName :: Name indexValName = mkNameG_v "base" "GHC.Arr" "index" inRangeValName :: Name inRangeValName = mkNameG_v "base" "GHC.Arr" "inRange" leAddrHashValName :: Name leAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leAddr#" leCharHashValName :: Name leCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leChar#" leDoubleHashValName :: Name leDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<=##" leFloatHashValName :: Name leFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leFloat#" leIntHashValName :: Name leIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<=#" leWordHashValName :: Name leWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "leWord#" liftReadListPrecDefaultValName :: Name liftReadListPrecDefaultValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrecDefault" liftReadListPrec2DefaultValName :: Name liftReadListPrec2DefaultValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec2Default" liftReadListPrecValName :: Name liftReadListPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec" liftReadListPrec2ValName :: Name liftReadListPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadListPrec2" liftReadPrecValName :: Name liftReadPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadPrec" liftReadPrec2ValName :: Name liftReadPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadPrec2" listValName :: Name listValName = mkNameG_v "base" "GHC.Read" "list" ltAddrHashValName :: Name ltAddrHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltAddr#" ltCharHashValName :: Name ltCharHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltChar#" ltDoubleHashValName :: Name ltDoubleHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<##" ltFloatHashValName :: Name ltFloatHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltFloat#" ltIntHashValName :: Name ltIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "<#" ltWordHashValName :: Name ltWordHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "ltWord#" minBoundValName :: Name minBoundValName = mkNameG_v "base" "GHC.Enum" "minBound" mapValName :: Name mapValName = mkNameG_v "base" "GHC.Base" "map" maxBoundValName :: Name maxBoundValName = mkNameG_v "base" "GHC.Enum" "maxBound" minusIntHashValName :: Name minusIntHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "-#" parenValName :: Name parenValName = mkNameG_v "base" "GHC.Read" "paren" parensValName :: Name parensValName = mkNameG_v "base" "GHC.Read" "parens" pfailValName :: Name pfailValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "pfail" plusValName :: Name plusValName = mkNameG_v "base" "GHC.Num" "+" precValName :: Name precValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "prec" predValName :: Name predValName = mkNameG_v "base" "GHC.Enum" "pred" rangeSizeValName :: Name rangeSizeValName = mkNameG_v "base" "GHC.Arr" "rangeSize" rangeValName :: Name rangeValName = mkNameG_v "base" "GHC.Arr" "range" readListValName :: Name readListValName = mkNameG_v "base" "GHC.Read" "readList" readListPrecDefaultValName :: Name readListPrecDefaultValName = mkNameG_v "base" "GHC.Read" "readListPrecDefault" readListPrecValName :: Name readListPrecValName = mkNameG_v "base" "GHC.Read" "readListPrec" readPrec_to_SValName :: Name readPrec_to_SValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "readPrec_to_S" readPrecValName :: Name readPrecValName = mkNameG_v "base" "GHC.Read" "readPrec" readS_to_PrecValName :: Name readS_to_PrecValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "readS_to_Prec" readsPrecValName :: Name readsPrecValName = mkNameG_v "base" "GHC.Read" "readsPrec" resetValName :: Name resetValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "reset" returnValName :: Name returnValName = mkNameG_v "base" "GHC.Base" "return" showCharValName :: Name showCharValName = mkNameG_v "base" "GHC.Show" "showChar" showListValName :: Name showListValName = mkNameG_v "base" "GHC.Show" "showList" showListWithValName :: Name showListWithValName = mkNameG_v "base" "Text.Show" "showListWith" showParenValName :: Name showParenValName = mkNameG_v "base" "GHC.Show" "showParen" showsPrecValName :: Name showsPrecValName = mkNameG_v "base" "GHC.Show" "showsPrec" showSpaceValName :: Name showSpaceValName = mkNameG_v "base" "GHC.Show" "showSpace" showStringValName :: Name showStringValName = mkNameG_v "base" "GHC.Show" "showString" stepValName :: Name stepValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "step" succValName :: Name succValName = mkNameG_v "base" "GHC.Enum" "succ" tagToEnumHashValName :: Name tagToEnumHashValName = mkNameG_v "ghc-prim" "GHC.Prim" "tagToEnum#" timesValName :: Name timesValName = mkNameG_v "base" "GHC.Num" "*" toEnumValName :: Name toEnumValName = mkNameG_v "base" "GHC.Enum" "toEnum" traverseValName :: Name traverseValName = mkNameG_v "base" "Data.Traversable" "traverse" unsafeIndexValName :: Name unsafeIndexValName = mkNameG_v "base" "GHC.Arr" "unsafeIndex" unsafeRangeSizeValName :: Name unsafeRangeSizeValName = mkNameG_v "base" "GHC.Arr" "unsafeRangeSize" unwrapMonadValName :: Name unwrapMonadValName = mkNameG_v "base" "Control.Applicative" "unwrapMonad" #if MIN_VERSION_base(4,4,0) boolTypeName :: Name boolTypeName = mkNameG_tc "ghc-prim" "GHC.Types" "Bool" falseDataName :: Name falseDataName = mkNameG_v "ghc-prim" "GHC.Types" "False" trueDataName :: Name trueDataName = mkNameG_v "ghc-prim" "GHC.Types" "True" #else boolTypeName :: Name boolTypeName = mkNameG_tc "ghc-prim" "GHC.Bool" "Bool" falseDataName :: Name falseDataName = mkNameG_v "ghc-prim" "GHC.Bool" "False" trueDataName :: Name trueDataName = mkNameG_v "ghc-prim" "GHC.Bool" "True" #endif #if MIN_VERSION_base(4,5,0) eqDataName :: Name eqDataName = mkNameG_d "ghc-prim" "GHC.Types" "EQ" gtDataName :: Name gtDataName = mkNameG_d "ghc-prim" "GHC.Types" "GT" ltDataName :: Name ltDataName = mkNameG_d "ghc-prim" "GHC.Types" "LT" eqTypeName :: Name eqTypeName = mkNameG_tc "ghc-prim" "GHC.Classes" "Eq" ordTypeName :: Name ordTypeName = mkNameG_tc "ghc-prim" "GHC.Classes" "Ord" andValName :: Name andValName = mkNameG_v "ghc-prim" "GHC.Classes" "&&" compareValName :: Name compareValName = mkNameG_v "ghc-prim" "GHC.Classes" "compare" eqValName :: Name eqValName = mkNameG_v "ghc-prim" "GHC.Classes" "==" geValName :: Name geValName = mkNameG_v "ghc-prim" "GHC.Classes" ">=" gtValName :: Name gtValName = mkNameG_v "ghc-prim" "GHC.Classes" ">" leValName :: Name leValName = mkNameG_v "ghc-prim" "GHC.Classes" "<=" ltValName :: Name ltValName = mkNameG_v "ghc-prim" "GHC.Classes" "<" notValName :: Name notValName = mkNameG_v "ghc-prim" "GHC.Classes" "not" #else eqDataName :: Name eqDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "EQ" gtDataName :: Name gtDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "GT" ltDataName :: Name ltDataName = mkNameG_d "ghc-prim" "GHC.Ordering" "LT" eqTypeName :: Name eqTypeName = mkNameG_tc "base" "GHC.Classes" "Eq" ordTypeName :: Name ordTypeName = mkNameG_tc "base" "GHC.Classes" "Ord" andValName :: Name andValName = mkNameG_v "base" "GHC.Classes" "&&" compareValName :: Name compareValName = mkNameG_v "base" "GHC.Classes" "compare" eqValName :: Name eqValName = mkNameG_v "base" "GHC.Classes" "==" geValName :: Name geValName = mkNameG_v "base" "GHC.Classes" ">=" gtValName :: Name gtValName = mkNameG_v "base" "GHC.Classes" ">" leValName :: Name leValName = mkNameG_v "base" "GHC.Classes" "<=" ltValName :: Name ltValName = mkNameG_v "base" "GHC.Classes" "<" notValName :: Name notValName = mkNameG_v "base" "GHC.Classes" "not" #endif #if MIN_VERSION_base(4,6,0) wHashDataName :: Name wHashDataName = mkNameG_d "ghc-prim" "GHC.Types" "W#" #else wHashDataName :: Name wHashDataName = mkNameG_d "base" "GHC.Word" "W#" #endif #if MIN_VERSION_base(4,6,0) && !(MIN_VERSION_base(4,9,0)) starKindName :: Name starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*" #endif #if MIN_VERSION_base(4,7,0) expectPValName :: Name expectPValName = mkNameG_v "base" "GHC.Read" "expectP" #else expectP :: Lexeme -> ReadPrec () expectP lexeme = do thing <- lexP if thing == lexeme then return () else pfail expectPValName :: Name expectPValName = mkDerivingCompatName_v "expectP" #endif #if MIN_VERSION_base(4,8,0) pureValName :: Name pureValName = mkNameG_v "base" "GHC.Base" "pure" apValName :: Name apValName = mkNameG_v "base" "GHC.Base" "<*>" mappendValName :: Name mappendValName = mkNameG_v "base" "GHC.Base" "mappend" memptyValName :: Name memptyValName = mkNameG_v "base" "GHC.Base" "mempty" #else pureValName :: Name pureValName = mkNameG_v "base" "Control.Applicative" "pure" apValName :: Name apValName = mkNameG_v "base" "Control.Applicative" "<*>" mappendValName :: Name mappendValName = mkNameG_v "base" "Data.Monoid" "mappend" memptyValName :: Name memptyValName = mkNameG_v "base" "Data.Monoid" "mempty" #endif #if MIN_VERSION_base(4,9,0) eq1TypeName :: Name eq1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Eq1" eq2TypeName :: Name eq2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Eq2" liftEqValName :: Name liftEqValName = mkNameG_v "base" "Data.Functor.Classes" "liftEq" liftEq2ValName :: Name liftEq2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftEq2" ord1TypeName :: Name ord1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Ord1" ord2TypeName :: Name ord2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Ord2" liftCompareValName :: Name liftCompareValName = mkNameG_v "base" "Data.Functor.Classes" "liftCompare" liftCompare2ValName :: Name liftCompare2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftCompare2" read1TypeName :: Name read1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Read1" read2TypeName :: Name read2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Read2" liftReadsPrecValName :: Name liftReadsPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadsPrec" liftReadListValName :: Name liftReadListValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadList" liftReadsPrec2ValName :: Name liftReadsPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadsPrec2" liftReadList2ValName :: Name liftReadList2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftReadList2" show1TypeName :: Name show1TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Show1" show2TypeName :: Name show2TypeName = mkNameG_tc "base" "Data.Functor.Classes" "Show2" liftShowListValName :: Name liftShowListValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowList" liftShowsPrecValName :: Name liftShowsPrecValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowsPrec" liftShowList2ValName :: Name liftShowList2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowList2" liftShowsPrec2ValName :: Name liftShowsPrec2ValName = mkNameG_v "base" "Data.Functor.Classes" "liftShowsPrec2" #else -- If Data.Functor.Classes isn't located in base, then sadly we can't refer to -- Names from that module without using -XTemplateHaskell. # if !(MIN_VERSION_transformers(0,4,0)) || MIN_VERSION_transformers(0,5,0) eq1TypeName :: Name eq1TypeName = ''Eq1 eq2TypeName :: Name eq2TypeName = ''Eq2 liftEqValName :: Name liftEqValName = 'liftEq liftEq2ValName :: Name liftEq2ValName = 'liftEq2 ord1TypeName :: Name ord1TypeName = ''Ord1 ord2TypeName :: Name ord2TypeName = ''Ord2 liftCompareValName :: Name liftCompareValName = 'liftCompare liftCompare2ValName :: Name liftCompare2ValName = 'liftCompare2 read1TypeName :: Name read1TypeName = ''Read1 read2TypeName :: Name read2TypeName = ''Read2 liftReadsPrecValName :: Name liftReadsPrecValName = 'liftReadsPrec liftReadListValName :: Name liftReadListValName = 'liftReadList liftReadsPrec2ValName :: Name liftReadsPrec2ValName = 'liftReadsPrec2 liftReadList2ValName :: Name liftReadList2ValName = 'liftReadList2 show1TypeName :: Name show1TypeName = ''Show1 show2TypeName :: Name show2TypeName = ''Show2 liftShowListValName :: Name liftShowListValName = 'liftShowList liftShowsPrecValName :: Name liftShowsPrecValName = 'liftShowsPrec liftShowList2ValName :: Name liftShowList2ValName = 'liftShowList2 liftShowsPrec2ValName :: Name liftShowsPrec2ValName = 'liftShowsPrec2 # else eq1TypeName :: Name eq1TypeName = ''Eq1 eq1ValName :: Name eq1ValName = 'eq1 ord1TypeName :: Name ord1TypeName = ''Ord1 compare1ValName :: Name compare1ValName = 'compare1 read1TypeName :: Name read1TypeName = ''Read1 readsPrec1ValName :: Name readsPrec1ValName = 'readsPrec1 show1TypeName :: Name show1TypeName = ''Show1 showsPrec1ValName :: Name showsPrec1ValName = 'showsPrec1 newtype Apply f a = Apply { unApply :: f a } instance (Eq1 f, Eq a) => Eq (Apply f a) where Apply x == Apply y = eq1 x y instance (Ord1 g, Ord a) => Ord (Apply g a) where compare (Apply x) (Apply y) = compare1 x y instance (Read1 f, Read a) => Read (Apply f a) where readsPrec d s = [(Apply a, t) | (a, t) <- readsPrec1 d s] instance (Show1 f, Show a) => Show (Apply f a) where showsPrec p (Apply x) = showsPrec1 p x makeFmapApplyNeg :: ClassRep a => a -> Name -> Type -> Name -> Q Exp makeFmapApplyNeg = makeFmapApply False makeFmapApplyPos :: ClassRep a => a -> Name -> Type -> Name -> Q Exp makeFmapApplyPos = makeFmapApply True makeFmapApply :: ClassRep a => Bool -> a -> Name -> Type -> Name -> Q Exp makeFmapApply pos cRep conName (SigT ty _) name = makeFmapApply pos cRep conName ty name makeFmapApply pos cRep conName t name = do let tyCon :: Type tyArgs :: [Type] tyCon:tyArgs = unapplyTy t numLastArgs :: Int numLastArgs = min (arity cRep) (length tyArgs) lhsArgs, rhsArgs :: [Type] (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs inspectTy :: Type -> Q Exp inspectTy (SigT ty _) = inspectTy ty inspectTy (VarT a) | a == name = varE idValName inspectTy beta = varE fmapValName `appE` infixApp (if pos then makeFmapApply pos cRep conName beta name else conE applyDataName) (varE composeValName) (if pos then varE unApplyValName else makeFmapApply pos cRep conName beta name) itf <- isTyFamily tyCon if any (`mentionsName` [name]) lhsArgs || itf && any (`mentionsName` [name]) tyArgs then outOfPlaceTyVarError cRep conName else inspectTy (head rhsArgs) applyDataName :: Name applyDataName = mkNameG_d derivingCompatPackageKey "Data.Deriving.Internal" "Apply" unApplyValName :: Name unApplyValName = mkNameG_v derivingCompatPackageKey "Data.Deriving.Internal" "unApply" # endif #endif deriving-compat-0.3.4/src/Data/Functor/0000755000000000000000000000000013002245656016057 5ustar0000000000000000deriving-compat-0.3.4/src/Data/Functor/Deriving.hs0000644000000000000000000000141013002245656020156 0ustar0000000000000000{-| Module: Data.Functor.Deriving Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Exports functions to mechanically derive 'Functor' instances. For more info on how deriving @Functor@ works, see . -} module Data.Functor.Deriving ( -- * 'Functor' deriveFunctor , makeFmap -- * 'deriveFunctor' limitations -- $constraints ) where import Data.Functor.Deriving.Internal {- $constraints Be aware of the following potential gotchas: * Type variables of kind @* -> *@ are assumed to have 'Functor' constraints. If this is not desirable, use 'makeFmap'. -} deriving-compat-0.3.4/src/Data/Functor/Deriving/0000755000000000000000000000000013002245656017626 5ustar0000000000000000deriving-compat-0.3.4/src/Data/Functor/Deriving/Internal.hs0000644000000000000000000004257013002245656021746 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-| Module: Data.Functor.Deriving.Internal Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell The machinery needed to derive 'Foldable', 'Functor', and 'Traversable' instances. For more info on how deriving @Functor@ works, see . -} module Data.Functor.Deriving.Internal ( -- * 'Foldable' deriveFoldable , makeFoldMap , makeFoldr , makeFold , makeFoldl -- * 'Functor' , deriveFunctor , makeFmap -- * 'Traversable' , deriveTraversable , makeTraverse , makeSequenceA , makeMapM , makeSequence ) where import Control.Monad (guard, zipWithM) import Data.Deriving.Internal import Data.Either (rights) import Data.List import qualified Data.Map as Map (keys, lookup) import Data.Maybe import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax -- | Generates a 'Foldable' instance declaration for the given data type or data -- family instance. deriveFoldable :: Name -> Q [Dec] deriveFoldable = deriveFunctorClass Foldable -- | Generates a lambda expression which behaves like 'foldMap' (without requiring a -- 'Foldable' instance). makeFoldMap :: Name -> Q Exp makeFoldMap = makeFunctorFun FoldMap -- | Generates a lambda expression which behaves like 'foldr' (without requiring a -- 'Foldable' instance). makeFoldr :: Name -> Q Exp makeFoldr = makeFunctorFun Foldr -- | Generates a lambda expression which behaves like 'fold' (without requiring a -- 'Foldable' instance). makeFold :: Name -> Q Exp makeFold name = makeFoldMap name `appE` varE idValName -- | Generates a lambda expression which behaves like 'foldl' (without requiring a -- 'Foldable' instance). makeFoldl :: Name -> Q Exp makeFoldl name = do f <- newName "f" z <- newName "z" t <- newName "t" lamE [varP f, varP z, varP t] $ appsE [ varE appEndoValName , appsE [ varE getDualValName , appsE [ makeFoldMap name, foldFun f, varE t] ] , varE z ] where foldFun :: Name -> Q Exp foldFun n = infixApp (conE dualDataName) (varE composeValName) (infixApp (conE endoDataName) (varE composeValName) (varE flipValName `appE` varE n) ) -- | Generates a 'Functor' instance declaration for the given data type or data -- family instance. deriveFunctor :: Name -> Q [Dec] deriveFunctor = deriveFunctorClass Functor -- | Generates a lambda expression which behaves like 'fmap' (without requiring a -- 'Functor' instance). makeFmap :: Name -> Q Exp makeFmap = makeFunctorFun Fmap -- | Generates a 'Traversable' instance declaration for the given data type or data -- family instance. deriveTraversable :: Name -> Q [Dec] deriveTraversable = deriveFunctorClass Traversable -- | Generates a lambda expression which behaves like 'traverse' (without requiring a -- 'Traversable' instance). makeTraverse :: Name -> Q Exp makeTraverse = makeFunctorFun Traverse -- | Generates a lambda expression which behaves like 'sequenceA' (without requiring a -- 'Traversable' instance). makeSequenceA :: Name -> Q Exp makeSequenceA name = makeTraverse name `appE` varE idValName -- | Generates a lambda expression which behaves like 'mapM' (without requiring a -- 'Traversable' instance). makeMapM :: Name -> Q Exp makeMapM name = do f <- newName "f" lam1E (varP f) . infixApp (varE unwrapMonadValName) (varE composeValName) $ makeTraverse name `appE` wrapMonadExp f where wrapMonadExp :: Name -> Q Exp wrapMonadExp n = infixApp (conE wrapMonadDataName) (varE composeValName) (varE n) -- | Generates a lambda expression which behaves like 'sequence' (without requiring a -- 'Traversable' instance). makeSequence :: Name -> Q Exp makeSequence name = makeMapM name `appE` varE idValName ------------------------------------------------------------------------------- -- Code generation ------------------------------------------------------------------------------- -- | Derive a class instance declaration (depending on the FunctorClass argument's value). deriveFunctorClass :: FunctorClass -> Name -> Q [Dec] deriveFunctorClass fc name = withType name fromCons where fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do (instanceCxt, instanceType) <- buildTypeInstance fc name' ctxt tvbs mbTys instanceD (return instanceCxt) (return instanceType) (functorFunDecs fc cons) -- | Generates a declaration defining the primary function(s) corresponding to a -- particular class (fmap for Functor, foldr and foldMap for Foldable, and -- traverse for Traversable). -- -- For why both foldr and foldMap are derived for Foldable, see Trac #7436. functorFunDecs :: FunctorClass -> [Con] -> [Q Dec] functorFunDecs fc cons = map makeFunD $ functorClassToFuns fc where makeFunD :: FunctorFun -> Q Dec makeFunD ff = funD (functorFunName ff) [ clause [] (normalB $ makeFunctorFunForCons ff cons) [] ] -- | Generates a lambda expression which behaves like the FunctorFun argument. makeFunctorFun :: FunctorFun -> Name -> Q Exp makeFunctorFun ff name = withType name fromCons where fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp fromCons name' ctxt tvbs cons mbTys = -- We force buildTypeInstance here since it performs some checks for whether -- or not the provided datatype can actually have fmap/foldr/traverse/etc. -- implemented for it, and produces errors if it can't. buildTypeInstance (functorFunToClass ff) name' ctxt tvbs mbTys `seq` makeFunctorFunForCons ff cons -- | Generates a lambda expression for the given constructors. -- All constructors must be from the same type. makeFunctorFunForCons :: FunctorFun -> [Con] -> Q Exp makeFunctorFunForCons ff cons = do argNames <- mapM newName $ catMaybes [ Just "f" , guard (ff == Foldr) >> Just "z" , Just "value" ] let mapFun:others = argNames z = head others -- If we're deriving foldr, this will be well defined -- and useful. Otherwise, it'll be ignored. value = last others lamE (map varP argNames) . appsE $ [ varE $ functorFunConstName ff , if null cons then appE (varE errorValName) (stringE $ "Void " ++ nameBase (functorFunName ff)) else caseE (varE value) (map (makeFunctorFunForCon ff z mapFun) cons) ] ++ map varE argNames -- | Generates a lambda expression for a single constructor. makeFunctorFunForCon :: FunctorFun -> Name -> Name -> Con -> Q Match makeFunctorFunForCon ff z mapFun con = do let conName = constructorName con (ts, tvMap) <- reifyConTys1 (functorFunToClass ff) [mapFun] conName argNames <- newNameList "_arg" $ length ts makeFunctorFunForArgs ff z tvMap conName ts argNames -- | Generates a lambda expression for a single constructor's arguments. makeFunctorFunForArgs :: FunctorFun -> Name -> TyVarMap1 -> Name -> [Type] -> [Name] -> Q Match makeFunctorFunForArgs ff z tvMap conName tys args = match (conP conName $ map varP args) (normalB $ functorFunCombine ff conName z args mappedArgs) [] where mappedArgs :: Q [Either Exp Exp] mappedArgs = zipWithM (makeFunctorFunForArg ff tvMap conName) tys args -- | Generates a lambda expression for a single argument of a constructor. -- The returned value is 'Right' if its type mentions the last type -- parameter. Otherwise, it is 'Left'. makeFunctorFunForArg :: FunctorFun -> TyVarMap1 -> Name -> Type -> Name -> Q (Either Exp Exp) makeFunctorFunForArg ff tvMap conName ty tyExpName = makeFunctorFunForType ff tvMap conName True ty `appEitherE` varE tyExpName -- | Generates a lambda expression for a specific type. The returned value is -- 'Right' if its type mentions the last type parameter. Otherwise, -- it is 'Left'. makeFunctorFunForType :: FunctorFun -> TyVarMap1 -> Name -> Bool -> Type -> Q (Either Exp Exp) makeFunctorFunForType ff tvMap conName covariant (VarT tyName) = case Map.lookup tyName tvMap of Just (OneName mapName) -> fmap Right $ if covariant then varE mapName else contravarianceError conName -- Invariant: this should only happen when deriving fmap Nothing -> fmap Left $ functorFunTriv ff makeFunctorFunForType ff tvMap conName covariant (SigT ty _) = makeFunctorFunForType ff tvMap conName covariant ty makeFunctorFunForType ff tvMap conName covariant (ForallT _ _ ty) = makeFunctorFunForType ff tvMap conName covariant ty makeFunctorFunForType ff tvMap conName covariant ty = let tyCon :: Type tyArgs :: [Type] tyCon:tyArgs = unapplyTy ty numLastArgs :: Int numLastArgs = min 1 $ length tyArgs lhsArgs, rhsArgs :: [Type] (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs tyVarNames :: [Name] tyVarNames = Map.keys tvMap mentionsTyArgs :: Bool mentionsTyArgs = any (`mentionsName` tyVarNames) tyArgs makeFunctorFunTuple :: ([Q Pat] -> Q Pat) -> (Int -> Name) -> Int -> Q (Either Exp Exp) makeFunctorFunTuple mkTupP mkTupleDataName n = do args <- mapM newName $ catMaybes [ Just "x" , guard (ff == Foldr) >> Just "z" ] xs <- newNameList "_tup" n let x = head args z = last args fmap Right $ lamE (map varP args) $ caseE (varE x) [ match (mkTupP $ map varP xs) (normalB $ functorFunCombine ff (mkTupleDataName n) z xs (zipWithM makeFunctorFunTupleField tyArgs xs) ) [] ] makeFunctorFunTupleField :: Type -> Name -> Q (Either Exp Exp) makeFunctorFunTupleField fieldTy fieldName = makeFunctorFunForType ff tvMap conName covariant fieldTy `appEitherE` varE fieldName fc :: FunctorClass fc = functorFunToClass ff in case tyCon of ArrowT | not (allowFunTys fc) -> noFunctionsError conName | mentionsTyArgs, [argTy, resTy] <- tyArgs -> do x <- newName "x" b <- newName "b" fmap Right . lamE [varP x, varP b] $ covFunctorFun covariant resTy `appE` (varE x `appE` (covFunctorFun (not covariant) argTy `appE` varE b)) where covFunctorFun :: Bool -> Type -> Q Exp covFunctorFun cov = fmap fromEither . makeFunctorFunForType ff tvMap conName cov #if MIN_VERSION_template_haskell(2,6,0) UnboxedTupleT n | n > 0 && mentionsTyArgs -> makeFunctorFunTuple unboxedTupP unboxedTupleDataName n #endif TupleT n | n > 0 && mentionsTyArgs -> makeFunctorFunTuple tupP tupleDataName n _ -> do itf <- isTyFamily tyCon if any (`mentionsName` tyVarNames) lhsArgs || (itf && mentionsTyArgs) then outOfPlaceTyVarError fc conName else if any (`mentionsName` tyVarNames) rhsArgs then fmap Right . functorFunApp ff . appsE $ ( varE (functorFunName ff) : map (fmap fromEither . makeFunctorFunForType ff tvMap conName covariant) rhsArgs ) else fmap Left $ functorFunTriv ff ------------------------------------------------------------------------------- -- Class-specific constants ------------------------------------------------------------------------------- -- | A representation of which class is being derived. data FunctorClass = Functor | Foldable | Traversable instance ClassRep FunctorClass where arity _ = 1 allowExQuant Foldable = True allowExQuant _ = False fullClassName Functor = functorTypeName fullClassName Foldable = foldableTypeName fullClassName Traversable = traversableTypeName classConstraint fClass 1 = Just $ fullClassName fClass classConstraint _ _ = Nothing -- | A representation of which function is being generated. data FunctorFun = Fmap | Foldr | FoldMap | Traverse deriving Eq instance Show FunctorFun where showsPrec _ Fmap = showString "fmap" showsPrec _ Foldr = showString "foldr" showsPrec _ FoldMap = showString "foldMap" showsPrec _ Traverse = showString "traverse" functorFunConstName :: FunctorFun -> Name functorFunConstName Fmap = fmapConstValName functorFunConstName Foldr = foldrConstValName functorFunConstName FoldMap = foldMapConstValName functorFunConstName Traverse = traverseConstValName functorFunName :: FunctorFun -> Name functorFunName Fmap = fmapValName functorFunName Foldr = foldrValName functorFunName FoldMap = foldMapValName functorFunName Traverse = traverseValName functorClassToFuns :: FunctorClass -> [FunctorFun] functorClassToFuns Functor = [Fmap] functorClassToFuns Foldable = [Foldr, FoldMap] functorClassToFuns Traversable = [Traverse] functorFunToClass :: FunctorFun -> FunctorClass functorFunToClass Fmap = Functor functorFunToClass Foldr = Foldable functorFunToClass FoldMap = Foldable functorFunToClass Traverse = Traversable allowFunTys :: FunctorClass -> Bool allowFunTys Functor = True allowFunTys _ = False ------------------------------------------------------------------------------- -- Assorted utilities ------------------------------------------------------------------------------- -- See Trac #7436 for why explicit lambdas are used functorFunTriv :: FunctorFun -> Q Exp functorFunTriv Fmap = do x <- newName "x" lam1E (varP x) $ varE x -- We filter out trivial expressions from derived foldr, foldMap, and traverse -- implementations, so if we attempt to call functorFunTriv on one of those -- methods, we've done something wrong. functorFunTriv ff = return . error $ "functorFunTriv: " ++ show ff functorFunApp :: FunctorFun -> Q Exp -> Q Exp functorFunApp Foldr e = do x <- newName "x" z <- newName "z" lamE [varP x, varP z] $ appsE [e, varE z, varE x] functorFunApp _ e = e functorFunCombine :: FunctorFun -> Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp functorFunCombine Fmap = fmapCombine functorFunCombine Foldr = foldrCombine functorFunCombine FoldMap = foldMapCombine functorFunCombine Traverse = traverseCombine fmapCombine :: Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp fmapCombine conName _ _ = fmap (foldl' AppE (ConE conName) . fmap fromEither) -- foldr, foldMap, and traverse are handled differently from fmap, since -- they filter out subexpressions whose types do not mention the last -- type parameter. See -- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor#AlternativestrategyforderivingFoldableandTraversable -- for further discussion. foldrCombine :: Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp foldrCombine _ zName _ = fmap (foldr AppE (VarE zName) . rights) foldMapCombine :: Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp foldMapCombine _ _ _ = fmap (go . rights) where go :: [Exp] -> Exp go [] = VarE memptyValName go es = foldr1 (AppE . AppE (VarE mappendValName)) es traverseCombine :: Name -> Name -> [Name] -> Q [Either Exp Exp] -> Q Exp traverseCombine conName _ args essQ = do ess <- essQ let argTysTyVarInfo :: [Bool] argTysTyVarInfo = map isRight ess argsWithTyVar, argsWithoutTyVar :: [Name] (argsWithTyVar, argsWithoutTyVar) = partitionByList argTysTyVarInfo args conExpQ :: Q Exp conExpQ | null argsWithTyVar = appsE (conE conName:map varE argsWithoutTyVar) | otherwise = do bs <- newNameList "b" $ length args let bs' = filterByList argTysTyVarInfo bs vars = filterByLists argTysTyVarInfo (map varE bs) (map varE args) lamE (map varP bs') (appsE (conE conName:vars)) conExp <- conExpQ let go :: [Exp] -> Exp go [] = VarE pureValName `AppE` conExp go (e:es) = foldl' (\e1 e2 -> InfixE (Just e1) (VarE apValName) (Just e2)) (VarE fmapValName `AppE` conExp `AppE` e) es return . go . rights $ ess deriving-compat-0.3.4/src/Data/Eq/0000755000000000000000000000000013002245656015004 5ustar0000000000000000deriving-compat-0.3.4/src/Data/Eq/Deriving.hs0000644000000000000000000000274713002245656017121 0ustar0000000000000000{-# LANGUAGE CPP #-} {-| Module: Data.Eq.Deriving Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Exports functions to mechanically derive 'Eq', 'Eq1', and 'Eq2' instances. -} module Data.Eq.Deriving ( -- * 'Eq' deriveEq , makeEq , makeNotEq -- * 'Eq1' , deriveEq1 #if defined(NEW_FUNCTOR_CLASSES) , makeLiftEq #endif , makeEq1 #if defined(NEW_FUNCTOR_CLASSES) -- * 'Eq2' , deriveEq2 , makeLiftEq2 , makeEq2 #endif -- * 'deriveEq' limitations -- $constraints ) where import Data.Eq.Deriving.Internal {- $constraints Be aware of the following potential gotchas: * Type variables of kind @*@ are assumed to have 'Eq' constraints. Type variables of kind @* -> *@ are assumed to have 'Eq1' constraints. Type variables of kind @* -> * -> *@ are assumed to have 'Eq2' constraints. If this is not desirable, use 'makeEq' or one of its cousins. * The 'Eq1' class had a different definition in @transformers-0.4@, and as a result, 'deriveEq1' implements different instances for the @transformers-0.4@ 'Eq1' than it otherwise does. Also, 'makeLiftEq' is not available when this library is built against @transformers-0.4@, only 'makeEq1. * The 'Eq2' class is not available in @transformers-0.4@, and as a result, neither are Template Haskell functions that deal with 'Eq2' when this library is built against @transformers-0.4@. -} deriving-compat-0.3.4/src/Data/Eq/Deriving/0000755000000000000000000000000013002245656016553 5ustar0000000000000000deriving-compat-0.3.4/src/Data/Eq/Deriving/Internal.hs0000644000000000000000000002640413002245656020671 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-| Module: Data.Eq.Deriving.Internal Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Exports functions to mechanically derive 'Eq', 'Eq1', and 'Eq2' instances. -} module Data.Eq.Deriving.Internal ( -- * 'Eq' deriveEq , makeEq , makeNotEq -- * 'Eq1' , deriveEq1 #if defined(NEW_FUNCTOR_CLASSES) , makeLiftEq #endif , makeEq1 #if defined(NEW_FUNCTOR_CLASSES) -- * 'Eq2' , deriveEq2 , makeLiftEq2 , makeEq2 #endif ) where import Data.Deriving.Internal import Data.List (foldl1', partition) import qualified Data.Map as Map import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax -- | Generates an 'Eq' instance declaration for the given data type or data -- family instance. deriveEq :: Name -> Q [Dec] deriveEq = deriveEqClass Eq -- | Generates a lambda expression which behaves like '(==)' (without -- requiring an 'Eq' instance). makeEq :: Name -> Q Exp makeEq = makeEqClass Eq -- | Generates a lambda expression which behaves like '(/=)' (without -- requiring an 'Eq' instance). makeNotEq :: Name -> Q Exp makeNotEq name = do x1 <- newName "x1" x2 <- newName "x2" lamE [varP x1, varP x2] $ varE notValName `appE` (makeEq name `appE` varE x1 `appE` varE x2) -- | Generates an 'Eq1' instance declaration for the given data type or data -- family instance. deriveEq1 :: Name -> Q [Dec] deriveEq1 = deriveEqClass Eq1 #if defined(NEW_FUNCTOR_CLASSES) -- | Generates a lambda expression which behaves like 'liftEq' (without -- requiring an 'Eq1' instance). -- -- This function is not available with @transformers-0.4@. makeLiftEq :: Name -> Q Exp makeLiftEq = makeEqClass Eq1 -- | Generates a lambda expression which behaves like 'eq1' (without -- requiring an 'Eq1' instance). makeEq1 :: Name -> Q Exp makeEq1 name = makeLiftEq name `appE` varE eqValName #else -- | Generates a lambda expression which behaves like 'eq1' (without -- requiring an 'Eq1' instance). makeEq1 :: Name -> Q Exp makeEq1 = makeEqClass Eq1 #endif #if defined(NEW_FUNCTOR_CLASSES) -- | Generates an 'Eq2' instance declaration for the given data type or data -- family instance. -- -- This function is not available with @transformers-0.4@. deriveEq2 :: Name -> Q [Dec] deriveEq2 = deriveEqClass Eq2 -- | Generates a lambda expression which behaves like 'liftEq2' (without -- requiring an 'Eq2' instance). -- -- This function is not available with @transformers-0.4@. makeLiftEq2 :: Name -> Q Exp makeLiftEq2 = makeEqClass Eq2 -- | Generates a lambda expression which behaves like 'eq2' (without -- requiring an 'Eq2' instance). -- -- This function is not available with @transformers-0.4@. makeEq2 :: Name -> Q Exp makeEq2 name = makeLiftEq name `appE` varE eqValName `appE` varE eqValName #endif ------------------------------------------------------------------------------- -- Code generation ------------------------------------------------------------------------------- -- | Derive an Eq(1)(2) instance declaration (depending on the EqClass -- argument's value). deriveEqClass :: EqClass -> Name -> Q [Dec] deriveEqClass eClass name = withType name fromCons where fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do (instanceCxt, instanceType) <- buildTypeInstance eClass name' ctxt tvbs mbTys instanceD (return instanceCxt) (return instanceType) (eqDecs eClass cons) -- | Generates a declaration defining the primary function corresponding to a -- particular class ((==) for Eq, liftEq for Eq1, and -- liftEq2 for Eq2). eqDecs :: EqClass -> [Con] -> [Q Dec] eqDecs eClass cons = [ funD (eqName eClass) [ clause [] (normalB $ makeEqForCons eClass cons) [] ] ] -- | Generates a lambda expression which behaves like (==) (for Eq), -- liftEq (for Eq1), or liftEq2 (for Eq2). makeEqClass :: EqClass -> Name -> Q Exp makeEqClass eClass name = withType name fromCons where fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp fromCons name' ctxt tvbs cons mbTys = -- We force buildTypeInstance here since it performs some checks for whether -- or not the provided datatype can actually have (==)/liftEq/etc. -- implemented for it, and produces errors if it can't. buildTypeInstance eClass name' ctxt tvbs mbTys `seq` makeEqForCons eClass cons -- | Generates a lambda expression for (==)/liftEq/etc. for the -- given constructors. All constructors must be from the same type. makeEqForCons :: EqClass -> [Con] -> Q Exp makeEqForCons _ [] = noConstructorsError makeEqForCons eClass cons = do value1 <- newName "value1" value2 <- newName "value2" eqDefn <- newName "eqDefn" eqs <- newNameList "eq" $ arity eClass lamE (map varP $ #if defined(NEW_FUNCTOR_CLASSES) eqs ++ #endif [value1, value2] ) . appsE $ [ varE $ eqConstName eClass , letE [ funD eqDefn $ map (makeCaseForCon eClass eqs) patMatchCons ++ fallThroughCase ] $ varE eqDefn `appE` varE value1 `appE` varE value2 ] #if defined(NEW_FUNCTOR_CLASSES) ++ map varE eqs #endif ++ [varE value1, varE value2] where nullaryCons, nonNullaryCons :: [Con] (nullaryCons, nonNullaryCons) = partition isNullaryCon cons tagMatchCons, patMatchCons :: [Con] (tagMatchCons, patMatchCons) | length nullaryCons > 10 = (nullaryCons, nonNullaryCons) | otherwise = ([], cons) fallThroughCase :: [Q Clause] fallThroughCase | null tagMatchCons = case patMatchCons of [] -> [] [_] -> [] _ -> [makeFallThroughCase] | otherwise = [makeTagCase] makeTagCase :: Q Clause makeTagCase = do a <- newName "a" aHash <- newName "a#" b <- newName "b" bHash <- newName "b#" clause (map varP [a,b]) (normalB $ untagExpr [(a, aHash), (b, bHash)] $ primOpAppExpr (varE aHash) eqIntHashValName (varE bHash)) [] makeFallThroughCase :: Q Clause makeFallThroughCase = clause [wildP, wildP] (normalB $ conE falseDataName) [] makeCaseForCon :: EqClass -> [Name] -> Con -> Q Clause makeCaseForCon eClass eqs con = do let conName = constructorName con (ts, tvMap) <- reifyConTys1 eClass eqs conName let tsLen = length ts as <- newNameList "a" tsLen bs <- newNameList "b" tsLen clause [conP conName (map varP as), conP conName (map varP bs)] (normalB $ makeCaseForArgs eClass tvMap conName ts as bs) [] makeCaseForArgs :: EqClass -> TyVarMap1 -> Name -> [Type] -> [Name] -> [Name] -> Q Exp makeCaseForArgs _ _ _ [] [] [] = conE trueDataName makeCaseForArgs eClass tvMap conName tys as bs = foldl1' (\q e -> infixApp q (varE andValName) e) (zipWith3 (makeCaseForArg eClass tvMap conName) tys as bs) makeCaseForArg :: EqClass -> TyVarMap1 -> Name -> Type -> Name -> Name -> Q Exp makeCaseForArg _ _ _ (ConT tyName) a b = primEqExpr where aExpr, bExpr :: Q Exp aExpr = varE a bExpr = varE b makePrimEqExpr :: Name -> Q Exp makePrimEqExpr n = primOpAppExpr aExpr n bExpr primEqExpr :: Q Exp primEqExpr | tyName == addrHashTypeName = makePrimEqExpr eqAddrHashValName | tyName == charHashTypeName = makePrimEqExpr eqCharHashValName | tyName == doubleHashTypeName = makePrimEqExpr eqDoubleHashValName | tyName == floatHashTypeName = makePrimEqExpr eqFloatHashValName | tyName == intHashTypeName = makePrimEqExpr eqIntHashValName | tyName == wordHashTypeName = makePrimEqExpr eqWordHashValName | otherwise = infixApp aExpr (varE eqValName) bExpr makeCaseForArg eClass tvMap conName ty a b = makeCaseForType eClass tvMap conName ty `appE` varE a `appE` varE b makeCaseForType :: EqClass -> TyVarMap1 -> Name -> Type -> Q Exp #if defined(NEW_FUNCTOR_CLASSES) makeCaseForType _ tvMap _ (VarT tyName) = varE $ case Map.lookup tyName tvMap of Just (OneName eq) -> eq Nothing -> eqValName #else makeCaseForType _ _ _ VarT{} = varE eqValName #endif makeCaseForType eClass tvMap conName (SigT ty _) = makeCaseForType eClass tvMap conName ty makeCaseForType eClass tvMap conName (ForallT _ _ ty) = makeCaseForType eClass tvMap conName ty #if defined(NEW_FUNCTOR_CLASSES) makeCaseForType eClass tvMap conName ty = do let tyCon :: Type tyArgs :: [Type] tyCon:tyArgs = unapplyTy ty numLastArgs :: Int numLastArgs = min (arity eClass) (length tyArgs) lhsArgs, rhsArgs :: [Type] (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs tyVarNames :: [Name] tyVarNames = Map.keys tvMap itf <- isTyFamily tyCon if any (`mentionsName` tyVarNames) lhsArgs || itf && any (`mentionsName` tyVarNames) tyArgs then outOfPlaceTyVarError eClass conName else if any (`mentionsName` tyVarNames) rhsArgs then appsE $ [ varE . eqName $ toEnum numLastArgs] ++ map (makeCaseForType eClass tvMap conName) rhsArgs else varE eqValName #else makeCaseForType eClass tvMap conName ty = do let varNames = Map.keys tvMap a' <- newName "a'" b' <- newName "b'" case varNames of [] -> varE eqValName varName:_ -> if mentionsName ty varNames then lamE (map varP [a',b']) $ varE eq1ValName `appE` (makeFmapApplyNeg eClass conName ty varName `appE` varE a') `appE` (makeFmapApplyNeg eClass conName ty varName `appE` varE b') else varE eqValName #endif ------------------------------------------------------------------------------- -- Class-specific constants ------------------------------------------------------------------------------- -- | A representation of which @Eq@ variant is being derived. data EqClass = Eq | Eq1 #if defined(NEW_FUNCTOR_CLASSES) | Eq2 #endif deriving (Bounded, Enum) instance ClassRep EqClass where arity = fromEnum allowExQuant _ = True fullClassName Eq = eqTypeName fullClassName Eq1 = eq1TypeName #if defined(NEW_FUNCTOR_CLASSES) fullClassName Eq2 = eq2TypeName #endif classConstraint eClass i | eMin <= i && i <= eMax = Just $ fullClassName (toEnum i :: EqClass) | otherwise = Nothing where eMin, eMax :: Int eMin = fromEnum (minBound :: EqClass) eMax = fromEnum eClass eqConstName :: EqClass -> Name eqConstName Eq = eqConstValName #if defined(NEW_FUNCTOR_CLASSES) eqConstName Eq1 = liftEqConstValName eqConstName Eq2 = liftEq2ConstValName #else eqConstName Eq1 = eq1ConstValName #endif eqName :: EqClass -> Name eqName Eq = eqValName #if defined(NEW_FUNCTOR_CLASSES) eqName Eq1 = liftEqValName eqName Eq2 = liftEq2ValName #else eqName Eq1 = eq1ValName #endif deriving-compat-0.3.4/src/Data/Ord/0000755000000000000000000000000013002245656015163 5ustar0000000000000000deriving-compat-0.3.4/src/Data/Ord/Deriving.hs0000644000000000000000000000314413002245656017270 0ustar0000000000000000{-# LANGUAGE CPP #-} {-| Module: Data.Ord.Deriving Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Exports functions to mechanically derive 'Ord', 'Ord1', and 'Ord2' instances. -} module Data.Ord.Deriving ( -- * 'Ord' deriveOrd , makeCompare , makeLT , makeLE , makeGT , makeGE , makeMax , makeMin -- * 'Ord1' , deriveOrd1 #if defined(NEW_FUNCTOR_CLASSES) , makeLiftCompare #endif , makeCompare1 #if defined(NEW_FUNCTOR_CLASSES) -- * 'Ord2' , deriveOrd2 , makeLiftCompare2 , makeCompare2 #endif -- * 'deriveOrd' limitations -- $constraints ) where import Data.Ord.Deriving.Internal {- $constraints Be aware of the following potential gotchas: * Type variables of kind @*@ are assumed to have 'Ord' constraints. Type variables of kind @* -> *@ are assumed to have 'Ord1' constraints. Type variables of kind @* -> * -> *@ are assumed to have 'Ord2' constraints. If this is not desirable, use 'makeCompare' or one of its cousins. * The 'Ord1' class had a different definition in @transformers-0.4@, and as a result, 'deriveOrd1' implements different instances for the @transformers-0.4@ 'Ord1' than it otherwise does. Also, 'makeLiftCompare' is not available when this library is built against @transformers-0.4@, only 'makeCompare1. * The 'Ord2' class is not available in @transformers-0.4@, and as a result, neither are Template Haskell functions that deal with 'Ord2' when this library is built against @transformers-0.4@. -} deriving-compat-0.3.4/src/Data/Ord/Deriving/0000755000000000000000000000000013002245656016732 5ustar0000000000000000deriving-compat-0.3.4/src/Data/Ord/Deriving/Internal.hs0000644000000000000000000006103313002245656021045 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-| Module: Data.Ord.Deriving.Internal Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Exports functions to mechanically derive 'Ord', 'Ord1', and 'Ord2' instances. -} module Data.Ord.Deriving.Internal ( -- * 'Ord' deriveOrd , makeCompare , makeLE , makeLT , makeGT , makeGE , makeMax , makeMin -- * 'Ord1' , deriveOrd1 #if defined(NEW_FUNCTOR_CLASSES) , makeLiftCompare #endif , makeCompare1 #if defined(NEW_FUNCTOR_CLASSES) -- * 'Ord2' , deriveOrd2 , makeLiftCompare2 , makeCompare2 #endif ) where import Data.Deriving.Internal import Data.List (partition) import qualified Data.Map as Map import Data.Maybe (isJust) import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax -- | Generates an 'Ord' instance declaration for the given data type or data -- family instance. deriveOrd :: Name -> Q [Dec] deriveOrd = deriveOrdClass Ord -- | Generates a lambda expression which behaves like 'compare' (without -- requiring an 'Ord' instance). makeCompare :: Name -> Q Exp makeCompare = makeOrdFun OrdCompare (error "This shouldn't happen") -- | Generates a lambda expression which behaves like '(<)' (without -- requiring an 'Ord' instance). makeLT :: Name -> Q Exp makeLT = makeOrdFun OrdLT [ match (conP ltDataName []) (normalB $ conE trueDataName) [] , match wildP (normalB $ conE falseDataName) [] ] -- | Generates a lambda expression which behaves like '(<=)' (without -- requiring an 'Ord' instance). makeLE :: Name -> Q Exp makeLE = makeOrdFun OrdLE [ match (conP gtDataName []) (normalB $ conE falseDataName) [] , match wildP (normalB $ conE trueDataName) [] ] -- | Generates a lambda expression which behaves like '(>)' (without -- requiring an 'Ord' instance). makeGT :: Name -> Q Exp makeGT = makeOrdFun OrdGT [ match (conP gtDataName []) (normalB $ conE trueDataName) [] , match wildP (normalB $ conE falseDataName) [] ] -- | Generates a lambda expression which behaves like '(>=)' (without -- requiring an 'Ord' instance). makeGE :: Name -> Q Exp makeGE = makeOrdFun OrdGE [ match (conP ltDataName []) (normalB $ conE falseDataName) [] , match wildP (normalB $ conE trueDataName) [] ] -- | Generates a lambda expression which behaves like 'max' (without -- requiring an 'Ord' instance). makeMax :: Name -> Q Exp makeMax = makeMinMax flip -- | Generates a lambda expression which behaves like 'min' (without -- requiring an 'Ord' instance). makeMin :: Name -> Q Exp makeMin = makeMinMax id makeMinMax :: ((Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp) -> Name -> Q Exp makeMinMax f name = do x <- newName "x" y <- newName "y" let xExpr = varE x yExpr = varE y lamE [varP x, varP y] $ f (condE $ makeLE name `appE` xExpr `appE` yExpr) xExpr yExpr -- | Generates an 'Ord1' instance declaration for the given data type or data -- family instance. deriveOrd1 :: Name -> Q [Dec] deriveOrd1 = deriveOrdClass Ord1 #if defined(NEW_FUNCTOR_CLASSES) -- | Generates a lambda expression which behaves like 'liftCompare' (without -- requiring an 'Ord1' instance). -- -- This function is not available with @transformers-0.4@. makeLiftCompare :: Name -> Q Exp makeLiftCompare = makeOrdFun Ord1LiftCompare (error "This shouldn't happen") -- | Generates a lambda expression which behaves like 'compare1' (without -- requiring an 'Ord1' instance). makeCompare1 :: Name -> Q Exp makeCompare1 name = makeLiftCompare name `appE` varE compareValName #else -- | Generates a lambda expression which behaves like 'compare1' (without -- requiring an 'Ord1' instance). makeCompare1 :: Name -> Q Exp makeCompare1 = makeOrdFun Ord1Compare1 (error "This shouldn't happen") #endif #if defined(NEW_FUNCTOR_CLASSES) -- | Generates an 'Ord2' instance declaration for the given data type or data -- family instance. -- -- This function is not available with @transformers-0.4@. deriveOrd2 :: Name -> Q [Dec] deriveOrd2 = deriveOrdClass Ord2 -- | Generates a lambda expression which behaves like 'liftCompare2' (without -- requiring an 'Ord2' instance). -- -- This function is not available with @transformers-0.4@. makeLiftCompare2 :: Name -> Q Exp makeLiftCompare2 = makeOrdFun Ord2LiftCompare2 (error "This shouldn't happen") -- | Generates a lambda expression which behaves like 'compare2' (without -- requiring an 'Ord2' instance). -- -- This function is not available with @transformers-0.4@. makeCompare2 :: Name -> Q Exp makeCompare2 name = makeLiftCompare name `appE` varE compareValName `appE` varE compareValName #endif ------------------------------------------------------------------------------- -- Code generation ------------------------------------------------------------------------------- -- | Derive an Ord(1)(2) instance declaration (depending on the OrdClass -- argument's value). deriveOrdClass :: OrdClass -> Name -> Q [Dec] deriveOrdClass oClass name = withType name fromCons where fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do (instanceCxt, instanceType) <- buildTypeInstance oClass name' ctxt tvbs mbTys instanceD (return instanceCxt) (return instanceType) (ordFunDecs oClass cons) -- | Generates a declaration defining the primary function(s) corresponding to a -- particular class (compare for Ord, liftCompare for Ord1, and -- liftCompare2 for Ord2). ordFunDecs :: OrdClass -> [Con] -> [Q Dec] ordFunDecs oClass cons = map makeFunD $ ordClassToCompare oClass : otherFuns oClass cons where makeFunD :: OrdFun -> Q Dec makeFunD oFun = funD (ordFunName oFun $ arity oClass) [ clause [] (normalB $ dispatchFun oFun) [] ] negateExpr :: Q Exp -> Q Exp negateExpr = appE (varE notValName) dispatchLT :: (Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp dispatchLT f = do x <- newName "x" y <- newName "y" lamE [varP x, varP y] $ f (varE ltValName) (varE x) (varE y) dispatchFun :: OrdFun -> Q Exp dispatchFun oFun | oFun `elem` [ OrdCompare, OrdLT -- OrdLT is included to mirror the fix to -- GHC Trac #10858. #if defined(NEW_FUNCTOR_CLASSES) , Ord1LiftCompare, Ord2LiftCompare2 #else , Ord1Compare1 #endif ] = makeOrdFunForCons oFun cons dispatchFun OrdLE = dispatchLT $ \lt x y -> negateExpr $ lt `appE` y `appE` x dispatchFun OrdGT = dispatchLT $ \lt x y -> lt `appE` y `appE` x dispatchFun OrdGE = dispatchLT $ \lt x y -> negateExpr $ lt `appE` x `appE` y dispatchFun _ = fail "ordFunDecs" -- | Generates a lambda expression which behaves like the OrdFun value. This -- function uses heuristics to determine whether to implement the OrdFun from -- scratch or define it in terms of compare. makeOrdFun :: OrdFun -> [Q Match] -> Name -> Q Exp makeOrdFun oFun matches name = withType name fromCons where fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp fromCons name' ctxt tvbs cons mbTys = do let oClass = ordFunToClass oFun others = otherFuns oClass cons -- We force buildTypeInstance here since it performs some checks for whether -- or not the provided datatype can actually have compare/liftCompare/etc. -- implemented for it, and produces errors if it can't. buildTypeInstance oClass name' ctxt tvbs mbTys `seq` if oFun `elem` compareFuns || oFun `elem` others then makeOrdFunForCons oFun cons else do x <- newName "x" y <- newName "y" lamE [varP x, varP y] $ caseE (makeOrdFunForCons (ordClassToCompare oClass) cons `appE` varE x `appE` varE y) matches compareFuns :: [OrdFun] compareFuns = [ OrdCompare #if defined(NEW_FUNCTOR_CLASSES) , Ord1LiftCompare , Ord2LiftCompare2 #else , Ord1Compare1 #endif ] -- | Generates a lambda expression for the given constructors. -- All constructors must be from the same type. makeOrdFunForCons :: OrdFun -> [Con] -> Q Exp makeOrdFunForCons _ [] = noConstructorsError makeOrdFunForCons oFun cons = do let oClass = ordFunToClass oFun v1 <- newName "v1" v2 <- newName "v2" v1Hash <- newName "v1#" v2Hash <- newName "v2#" ords <- newNameList "ord" $ arity oClass let nullaryCons, nonNullaryCons :: [Con] (nullaryCons, nonNullaryCons) = partition isNullaryCon cons singleConType :: Bool singleConType = isSingleton cons firstConName, lastConName :: Name firstConName = constructorName $ head cons lastConName = constructorName $ last cons -- I think these should always be the case... firstTag, lastTag :: Int firstTag = 0 lastTag = length cons - 1 ordMatches :: Int -> Con -> Q Match ordMatches = makeOrdFunForCon oFun v2 v2Hash ords singleConType firstTag firstConName lastTag lastConName ordFunRhs :: Q Exp ordFunRhs | length nullaryCons <= 2 = caseE (varE v1) $ zipWith ordMatches [0..] cons | null nonNullaryCons = mkTagCmp | otherwise = caseE (varE v1) $ zipWith ordMatches [0..] nonNullaryCons ++ [match wildP (normalB mkTagCmp) []] mkTagCmp :: Q Exp mkTagCmp = untagExpr [(v1, v1Hash), (v2, v2Hash)] $ unliftedOrdFun intHashTypeName oFun v1Hash v2Hash lamE (map varP $ #if defined(NEW_FUNCTOR_CLASSES) ords ++ #endif [v1, v2]) . appsE $ [ varE $ compareConstName oFun , ordFunRhs ] #if defined(NEW_FUNCTOR_CLASSES) ++ map varE ords #endif ++ [varE v1, varE v2] makeOrdFunForCon :: OrdFun -> Name -> Name -> [Name] -> Bool -> Int -> Name -> Int -> Name -> Int -> Con -> Q Match makeOrdFunForCon oFun v2 v2Hash ords singleConType firstTag firstConName lastTag lastConName tag con = do let conName = constructorName con (ts, tvMap) <- reifyConTys1 (ordFunToClass oFun) ords conName let tsLen = length ts as <- newNameList "a" tsLen bs <- newNameList "b" tsLen let innerRhs :: Q Exp innerRhs | singleConType = caseE (varE v2) [innerEqAlt] | tag == firstTag = caseE (varE v2) [innerEqAlt, match wildP (normalB $ ltResult oFun) []] | tag == lastTag = caseE (varE v2) [innerEqAlt, match wildP (normalB $ gtResult oFun) []] | tag == firstTag + 1 = caseE (varE v2) [ match (recP firstConName []) (normalB $ gtResult oFun) [] , innerEqAlt , match wildP (normalB $ ltResult oFun) [] ] | tag == lastTag - 1 = caseE (varE v2) [ match (recP lastConName []) (normalB $ ltResult oFun) [] , innerEqAlt , match wildP (normalB $ gtResult oFun) [] ] | tag > lastTag `div` 2 = untagExpr [(v2, v2Hash)] $ condE (primOpAppExpr (varE v2Hash) ltIntHashValName tagLit) (gtResult oFun) $ caseE (varE v2) [innerEqAlt, match wildP (normalB $ ltResult oFun) []] | otherwise = untagExpr [(v2, v2Hash)] $ condE (primOpAppExpr (varE v2Hash) gtIntHashValName tagLit) (ltResult oFun) $ caseE (varE v2) [innerEqAlt, match wildP (normalB $ gtResult oFun) []] innerEqAlt :: Q Match innerEqAlt = match (conP conName $ map varP bs) (normalB $ makeOrdFunForFields oFun tvMap conName ts as bs) [] tagLit :: Q Exp tagLit = litE . integerL $ fromIntegral tag match (conP conName $ map varP as) (normalB innerRhs) [] makeOrdFunForFields :: OrdFun -> TyVarMap1 -> Name -> [Type] -> [Name] -> [Name] -> Q Exp makeOrdFunForFields oFun tvMap conName = go where go :: [Type] -> [Name] -> [Name] -> Q Exp go [] _ _ = eqResult oFun go [ty] [a] [b] | isSupportedUnliftedType ty = unliftedOrdFun (conTToName ty) oFun a b | otherwise = makeOrdFunForType oFun tvMap conName ty `appE` varE a `appE` varE b go (ty:tys) (a:as) (b:bs) = mkCompare ty a b (ltResult oFun) (go tys as bs) (gtResult oFun) go _ _ _ = fail "Data.Ord.Deriving.Internal.makeOrdFunForFields" mkCompare :: Type -> Name -> Name -> Q Exp -> Q Exp -> Q Exp -> Q Exp mkCompare ty a b lt eq gt | isSupportedUnliftedType ty = let (ltFun, _, eqFun, _, _) = primOrdFuns $ conTToName ty in unliftedCompare ltFun eqFun aExpr bExpr lt eq gt | otherwise = caseE (makeOrdFunForType (ordClassToCompare $ ordFunToClass oFun) tvMap conName ty `appE` aExpr `appE` bExpr) [ match (conP ltDataName []) (normalB lt) [] , match (conP eqDataName []) (normalB eq) [] , match (conP gtDataName []) (normalB gt) [] ] where aExpr, bExpr :: Q Exp aExpr = varE a bExpr = varE b makeOrdFunForType :: OrdFun -> TyVarMap1 -> Name -> Type -> Q Exp #if defined(NEW_FUNCTOR_CLASSES) makeOrdFunForType oFun tvMap _ (VarT tyName) = varE $ case Map.lookup tyName tvMap of Just (OneName ord) -> ord Nothing -> ordFunName oFun 0 #else makeOrdFunForType oFun _ _ VarT{} = varE $ ordFunName oFun 0 #endif makeOrdFunForType oFun tvMap conName (SigT ty _) = makeOrdFunForType oFun tvMap conName ty makeOrdFunForType oFun tvMap conName (ForallT _ _ ty) = makeOrdFunForType oFun tvMap conName ty #if defined(NEW_FUNCTOR_CLASSES) makeOrdFunForType oFun tvMap conName ty = do let oClass :: OrdClass oClass = ordFunToClass oFun tyCon :: Type tyArgs :: [Type] tyCon:tyArgs = unapplyTy ty numLastArgs :: Int numLastArgs = min (arity oClass) (length tyArgs) lhsArgs, rhsArgs :: [Type] (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs tyVarNames :: [Name] tyVarNames = Map.keys tvMap itf <- isTyFamily tyCon if any (`mentionsName` tyVarNames) lhsArgs || itf && any (`mentionsName` tyVarNames) tyArgs then outOfPlaceTyVarError oClass conName else if any (`mentionsName` tyVarNames) rhsArgs then appsE $ [ varE . ordFunName oFun $ toEnum numLastArgs] ++ map (makeOrdFunForType oFun tvMap conName) rhsArgs else varE $ ordFunName oFun 0 #else makeOrdFunForType oFun tvMap conName ty = do let varNames = Map.keys tvMap oClass = ordFunToClass oFun a' <- newName "a'" b' <- newName "b'" case varNames of [] -> varE $ ordFunName oFun 0 varName:_ -> if mentionsName ty varNames then lamE (map varP [a',b']) $ varE (ordFunName oFun 1) `appE` (makeFmapApplyNeg oClass conName ty varName `appE` varE a') `appE` (makeFmapApplyNeg oClass conName ty varName `appE` varE b') else varE $ ordFunName oFun 0 #endif ------------------------------------------------------------------------------- -- Class-specific constants ------------------------------------------------------------------------------- -- | A representation of which @Ord@ variant is being derived. data OrdClass = Ord | Ord1 #if defined(NEW_FUNCTOR_CLASSES) | Ord2 #endif deriving (Bounded, Enum) instance ClassRep OrdClass where arity = fromEnum allowExQuant _ = True fullClassName Ord = ordTypeName fullClassName Ord1 = ord1TypeName #if defined(NEW_FUNCTOR_CLASSES) fullClassName Ord2 = ord2TypeName #endif classConstraint oClass i | oMin <= i && i <= oMax = Just $ fullClassName (toEnum i :: OrdClass) | otherwise = Nothing where oMin, oMax :: Int oMin = fromEnum (minBound :: OrdClass) oMax = fromEnum oClass compareConstName :: OrdFun -> Name compareConstName OrdCompare = compareConstValName compareConstName OrdLT = ltConstValName compareConstName OrdLE = ltConstValName compareConstName OrdGT = ltConstValName compareConstName OrdGE = ltConstValName #if defined(NEW_FUNCTOR_CLASSES) compareConstName Ord1LiftCompare = liftCompareConstValName compareConstName Ord2LiftCompare2 = liftCompare2ConstValName #else compareConstName Ord1Compare1 = compare1ConstValName #endif ordClassToCompare :: OrdClass -> OrdFun ordClassToCompare Ord = OrdCompare #if defined(NEW_FUNCTOR_CLASSES) ordClassToCompare Ord1 = Ord1LiftCompare ordClassToCompare Ord2 = Ord2LiftCompare2 #else ordClassToCompare Ord1 = Ord1Compare1 #endif data OrdFun = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT #if defined(NEW_FUNCTOR_CLASSES) | Ord1LiftCompare | Ord2LiftCompare2 #else | Ord1Compare1 #endif deriving Eq ordFunName :: OrdFun -> Int -> Name ordFunName OrdCompare 0 = compareValName ordFunName OrdLT 0 = ltValName ordFunName OrdLE 0 = leValName ordFunName OrdGE 0 = geValName ordFunName OrdGT 0 = gtValName #if defined(NEW_FUNCTOR_CLASSES) ordFunName Ord1LiftCompare 0 = ordFunName OrdCompare 0 ordFunName Ord1LiftCompare 1 = liftCompareValName ordFunName Ord2LiftCompare2 0 = ordFunName OrdCompare 0 ordFunName Ord2LiftCompare2 1 = ordFunName Ord1LiftCompare 1 ordFunName Ord2LiftCompare2 2 = liftCompare2ValName #else ordFunName Ord1Compare1 0 = ordFunName OrdCompare 0 ordFunName Ord1Compare1 1 = compare1ValName #endif ordFunName _ _ = error "Data.Ord.Deriving.Internal.ordFunName" ordFunToClass :: OrdFun -> OrdClass ordFunToClass OrdCompare = Ord ordFunToClass OrdLT = Ord ordFunToClass OrdLE = Ord ordFunToClass OrdGE = Ord ordFunToClass OrdGT = Ord #if defined(NEW_FUNCTOR_CLASSES) ordFunToClass Ord1LiftCompare = Ord1 ordFunToClass Ord2LiftCompare2 = Ord2 #else ordFunToClass Ord1Compare1 = Ord1 #endif eqResult :: OrdFun -> Q Exp eqResult OrdCompare = eqTagExpr eqResult OrdLT = falseExpr eqResult OrdLE = trueExpr eqResult OrdGE = trueExpr eqResult OrdGT = falseExpr #if defined(NEW_FUNCTOR_CLASSES) eqResult Ord1LiftCompare = eqTagExpr eqResult Ord2LiftCompare2 = eqTagExpr #else eqResult Ord1Compare1 = eqTagExpr #endif gtResult :: OrdFun -> Q Exp gtResult OrdCompare = gtTagExpr gtResult OrdLT = falseExpr gtResult OrdLE = falseExpr gtResult OrdGE = trueExpr gtResult OrdGT = trueExpr #if defined(NEW_FUNCTOR_CLASSES) gtResult Ord1LiftCompare = gtTagExpr gtResult Ord2LiftCompare2 = gtTagExpr #else gtResult Ord1Compare1 = gtTagExpr #endif ltResult :: OrdFun -> Q Exp ltResult OrdCompare = ltTagExpr ltResult OrdLT = trueExpr ltResult OrdLE = trueExpr ltResult OrdGE = falseExpr ltResult OrdGT = falseExpr #if defined(NEW_FUNCTOR_CLASSES) ltResult Ord1LiftCompare = ltTagExpr ltResult Ord2LiftCompare2 = ltTagExpr #else ltResult Ord1Compare1 = ltTagExpr #endif ------------------------------------------------------------------------------- -- Assorted utilities ------------------------------------------------------------------------------- ltTagExpr, eqTagExpr, gtTagExpr, falseExpr, trueExpr :: Q Exp ltTagExpr = conE ltDataName eqTagExpr = conE eqDataName gtTagExpr = conE gtDataName falseExpr = conE falseDataName trueExpr = conE trueDataName -- Besides compare, that is otherFuns :: OrdClass -> [Con] -> [OrdFun] otherFuns oClass cons = case oClass of Ord1 -> [] #if defined(NEW_FUNCTOR_CLASSES) Ord2 -> [] #endif Ord | (lastTag - firstTag) <= 2 || null nonNullaryCons -> [OrdLT, OrdLE, OrdGE, OrdGT] | otherwise -> [] where firstTag, lastTag :: Int firstTag = 0 lastTag = length cons - 1 nonNullaryCons :: [Con] nonNullaryCons = filterOut isNullaryCon cons unliftedOrdFun :: Name -> OrdFun -> Name -> Name -> Q Exp unliftedOrdFun tyName oFun a b = case oFun of OrdCompare -> unliftedCompareExpr OrdLT -> wrap ltFun OrdLE -> wrap leFun OrdGE -> wrap geFun OrdGT -> wrap gtFun #if defined(NEW_FUNCTOR_CLASSES) Ord1LiftCompare -> unliftedCompareExpr Ord2LiftCompare2 -> unliftedCompareExpr #else Ord1Compare1 -> unliftedCompareExpr #endif where unliftedCompareExpr :: Q Exp unliftedCompareExpr = unliftedCompare ltFun eqFun aExpr bExpr ltTagExpr eqTagExpr gtTagExpr ltFun, leFun, eqFun, geFun, gtFun :: Name (ltFun, leFun, eqFun, geFun, gtFun) = primOrdFuns tyName wrap :: Name -> Q Exp wrap primFun = primOpAppExpr aExpr primFun bExpr aExpr, bExpr :: Q Exp aExpr = varE a bExpr = varE b unliftedCompare :: Name -> Name -> Q Exp -> Q Exp -- What to compare -> Q Exp -> Q Exp -> Q Exp -- Three results -> Q Exp unliftedCompare ltFun eqFun aExpr bExpr lt eq gt = condE (ascribeBool $ primOpAppExpr aExpr ltFun bExpr) lt $ condE (ascribeBool $ primOpAppExpr aExpr eqFun bExpr) eq gt where ascribeBool :: Q Exp -> Q Exp ascribeBool e = sigE e $ conT boolTypeName primOrdFuns :: Name -> (Name, Name, Name, Name, Name) primOrdFuns tyName = case lookup tyName primOrdFunTbl of Just names -> names Nothing -> error $ nameBase tyName ++ " is not supported." primOrdFunTbl :: [(Name, (Name, Name, Name, Name, Name))] primOrdFunTbl = [ (addrHashTypeName, ( ltAddrHashValName , leAddrHashValName , eqAddrHashValName , geAddrHashValName , gtAddrHashValName )) , (charHashTypeName, ( ltCharHashValName , leCharHashValName , eqCharHashValName , geCharHashValName , gtCharHashValName )) , (doubleHashTypeName, ( ltDoubleHashValName , leDoubleHashValName , eqDoubleHashValName , geDoubleHashValName , gtDoubleHashValName )) , (floatHashTypeName, ( ltFloatHashValName , leFloatHashValName , eqFloatHashValName , geFloatHashValName , gtFloatHashValName )) , (intHashTypeName, ( ltIntHashValName , leIntHashValName , eqIntHashValName , geIntHashValName , gtIntHashValName )) , (wordHashTypeName, ( ltWordHashValName , leWordHashValName , eqWordHashValName , geWordHashValName , gtWordHashValName )) ] isSupportedUnliftedType :: Type -> Bool isSupportedUnliftedType (ConT tyName) = isJust $ lookup tyName primOrdFunTbl isSupportedUnliftedType _ = False isSingleton :: [a] -> Bool isSingleton [_] = True isSingleton _ = False -- | Like 'filter', only it reverses the sense of the test filterOut :: (a -> Bool) -> [a] -> [a] filterOut _ [] = [] filterOut p (x:xs) | p x = filterOut p xs | otherwise = x : filterOut p xs deriving-compat-0.3.4/src/Data/Traversable/0000755000000000000000000000000013002245656016711 5ustar0000000000000000deriving-compat-0.3.4/src/Data/Traversable/Deriving.hs0000644000000000000000000000326213002245656021017 0ustar0000000000000000{-| Module: Data.Traversable.Deriving Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Exports functions to mechanically derive 'Traversable' instances in a way that mimics how the @-XDeriveTraversable@ extension works since GHC 8.0. Derived 'Traversable' instances from this module do not generate superfluous 'pure' expressions in its implementation of 'traverse'. One can verify this by compiling a module that uses 'deriveTraversable' with the @-ddump-splices@ GHC flag. These changes make it possible to derive @Traversable@ instances for data types with unlifted argument types, e.g., @ data IntHash a = IntHash Int# a deriving instance Traversable IntHash -- On GHC 8.0 on later $(deriveTraversable ''IntHash) -- On GHC 7.10 and earlier @ For more info on these changes, see . -} module Data.Traversable.Deriving ( -- * 'Traversable' deriveTraversable , makeTraverse , makeSequenceA , makeMapM , makeSequence -- * 'deriveTraversable' limitations -- $constraints ) where import Data.Functor.Deriving.Internal {- $constraints Be aware of the following potential gotchas: * If you are using the @-XGADTs@ or @-XExistentialQuantification@ extensions, an existential constraint cannot mention the last type variable. For example, @data Illegal a = forall a. Show a => Illegal a@ cannot have a derived 'Traversable' instance. * Type variables of kind @* -> *@ are assumed to have 'Traversable' constraints. If this is not desirable, use 'makeTraverse'. -} deriving-compat-0.3.4/src/Data/Ix/0000755000000000000000000000000013002245656015017 5ustar0000000000000000deriving-compat-0.3.4/src/Data/Ix/Deriving.hs0000644000000000000000000000121113002245656017115 0ustar0000000000000000{-| Module: Data.Ix.Deriving Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Exports functions to mechanically derive 'Ix' instances. -} module Data.Ix.Deriving ( -- * 'Ix' deriveIx , makeRange , makeUnsafeIndex , makeInRange -- * 'deriveIx' limitations -- $constraints ) where import Data.Ix.Deriving.Internal {- $constraints Be aware of the following potential gotchas: * Type variables of kind @*@ are assumed to have 'Ix' constraints. If this is not desirable, use 'makeRange' or one of its cousins. -} deriving-compat-0.3.4/src/Data/Ix/Deriving/0000755000000000000000000000000013002245656016566 5ustar0000000000000000deriving-compat-0.3.4/src/Data/Ix/Deriving/Internal.hs0000644000000000000000000001726713002245656020713 0ustar0000000000000000{-| Module: Data.Ix.Deriving.Internal Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Exports functions to mechanically derive 'Ix' instances. -} module Data.Ix.Deriving.Internal ( -- * 'Ix' deriveIx , makeRange , makeUnsafeIndex , makeInRange ) where import Data.Deriving.Internal import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax ------------------------------------------------------------------------------- -- Code generation ------------------------------------------------------------------------------- -- | Generates a 'Ix' instance declaration for the given data type or data -- family instance. deriveIx :: Name -> Q [Dec] deriveIx name = withType name fromCons where fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do (instanceCxt, instanceType) <- buildTypeInstance IxClass name' ctxt tvbs mbTys instanceD (return instanceCxt) (return instanceType) (ixFunDecs name' instanceType cons) -- | Generates a lambda expression which behaves like 'range' (without -- requiring an 'Ix' instance). makeRange :: Name -> Q Exp makeRange = makeIxFun Range -- | Generates a lambda expression which behaves like 'unsafeIndex' (without -- requiring an 'Ix' instance). makeUnsafeIndex :: Name -> Q Exp makeUnsafeIndex = makeIxFun UnsafeIndex -- | Generates a lambda expression which behaves like 'inRange' (without -- requiring an 'Ix' instance). makeInRange :: Name -> Q Exp makeInRange = makeIxFun InRange -- | Generates method declarations for an 'Ix' instance. ixFunDecs :: Name -> Type -> [Con] -> [Q Dec] ixFunDecs tyName ty cons = [ makeFunD Range , makeFunD UnsafeIndex , makeFunD InRange ] where makeFunD :: IxFun -> Q Dec makeFunD ixf = funD (ixFunName ixf) [ clause [] (normalB $ makeIxFunForCons ixf tyName ty cons) [] ] -- | Generates a lambda expression which behaves like the IxFun argument. makeIxFun :: IxFun -> Name -> Q Exp makeIxFun ixf name = withType name fromCons where fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp fromCons name' ctxt tvbs cons mbTys = do (_, instanceType) <- buildTypeInstance IxClass name' ctxt tvbs mbTys makeIxFunForCons ixf name' instanceType cons -- | Generates a lambda expression for an 'Ix' method for the -- given constructors. All constructors must be from the same type. makeIxFunForCons :: IxFun -> Name -> Type -> [Con] -> Q Exp makeIxFunForCons _ _ _ [] = noConstructorsError makeIxFunForCons ixf tyName ty cons | not (isProduct || isEnumeration) = enumerationOrProductError $ nameBase tyName | isEnumeration = case ixf of Range -> do a <- newName "a" aHash <- newName "a#" b <- newName "b" bHash <- newName "b#" lamE [tupP [varP a, varP b]] $ untagExpr [(a, aHash)] $ untagExpr [(b, bHash)] $ appE (varE mapValName `appE` tag2Con) $ enumFromToExpr (conE iHashDataName `appE` varE aHash) (conE iHashDataName `appE` varE bHash) UnsafeIndex -> do a <- newName "a" aHash <- newName "a#" c <- newName "c" cHash <- newName "c#" dHash <- newName "d#" lamE [tupP [varP a, wildP], varP c] $ untagExpr [(a, aHash)] $ untagExpr [(c, cHash)] $ caseE (infixApp (varE cHash) (varE minusIntHashValName) (varE aHash)) [ match (varP dHash) (normalB $ conE iHashDataName `appE` varE dHash) [] ] InRange -> do a <- newName "a" aHash <- newName "a#" b <- newName "b" bHash <- newName "b#" c <- newName "c" cHash <- newName "c#" lamE [tupP [varP a, varP b], varP c] $ untagExpr [(a, aHash)] $ untagExpr [(b, bHash)] $ untagExpr [(c, cHash)] $ appsE [ varE andValName , primOpAppExpr (varE cHash) geIntHashValName (varE aHash) , primOpAppExpr (varE cHash) leIntHashValName (varE bHash) ] | otherwise -- It's a product type = do let con :: Con [con] = cons conName :: Name conName = constructorName con conFields :: Int conFields = conArity con as <- newNameList "a" conFields bs <- newNameList "b" conFields cs <- newNameList "c" conFields let conPat :: [Name] -> Q Pat conPat = conP conName . map varP conExpr :: Q Exp conExpr = appsE $ conE conName : map varE cs case ixf of Range -> lamE [tupP [conPat as, conPat bs]] $ compE $ stmts ++ [noBindS conExpr] where stmts :: [Q Stmt] stmts = zipWith3 mkQual as bs cs mkQual :: Name -> Name -> Name -> Q Stmt mkQual a b c = bindS (varP c) $ varE rangeValName `appE` tupE [varE a, varE b] UnsafeIndex -> lamE [tupP [conPat as, conPat bs], conPat cs] $ mkUnsafeIndex $ reverse $ zip3 as bs cs where mkUnsafeIndex :: [(Name, Name, Name)] -> Q Exp mkUnsafeIndex [] = integerE 0 mkUnsafeIndex [(l, u, i)] = mkOne l u i mkUnsafeIndex ((l, u, i):rest) = infixApp (mkOne l u i) (varE plusValName) (infixApp (varE unsafeRangeSizeValName `appE` tupE [varE l, varE u]) (varE timesValName) (mkUnsafeIndex rest)) mkOne :: Name -> Name -> Name -> Q Exp mkOne l u i = varE unsafeIndexValName `appE` tupE [varE l, varE u] `appE` varE i InRange -> lamE [tupP [conPat as, conPat bs], conPat cs] $ if conFields == 0 then conE trueDataName else foldl1 andExpr $ zipWith3 mkInRange as bs cs where andExpr :: Q Exp -> Q Exp -> Q Exp andExpr a b = infixApp a (varE andValName) b mkInRange :: Name -> Name -> Name -> Q Exp mkInRange a b c = varE inRangeValName `appE` tupE [varE a, varE b] `appE` varE c where isProduct, isEnumeration :: Bool isProduct = isProductType cons isEnumeration = isEnumerationType cons tag2Con :: Q Exp tag2Con = tag2ConExpr $ removeClassApp ty ------------------------------------------------------------------------------- -- Class-specific constants ------------------------------------------------------------------------------- -- There's only one Ix variant! data IxClass = IxClass instance ClassRep IxClass where arity _ = 0 allowExQuant _ = True fullClassName _ = ixTypeName classConstraint _ 0 = Just ixTypeName classConstraint _ _ = Nothing -- | A representation of which function is being generated. data IxFun = Range | UnsafeIndex | InRange deriving Show ixFunName :: IxFun -> Name ixFunName Range = rangeValName ixFunName UnsafeIndex = unsafeIndexValName ixFunName InRange = inRangeValName deriving-compat-0.3.4/src/Data/Foldable/0000755000000000000000000000000013002245656016147 5ustar0000000000000000deriving-compat-0.3.4/src/Data/Foldable/Deriving.hs0000644000000000000000000000330313002245656020251 0ustar0000000000000000{-| Module: Data.Foldable.Deriving Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Exports functions to mechanically derive 'Foldable' instances in a way that mimics how the @-XDeriveFoldable@ extension works since GHC 8.0. These changes make it possible to derive @Foldable@ instances for data types with existential constraints, e.g., @ data WrappedSet a where WrapSet :: Ord a => a -> WrappedSet a deriving instance Foldable WrappedSet -- On GHC 8.0 on later $(deriveFoldable ''WrappedSet) -- On GHC 7.10 and earlier @ In addition, derived 'Foldable' instances from this module do not generate superfluous 'mempty' expressions in its implementation of 'foldMap'. One can verify this by compiling a module that uses 'deriveFoldable' with the @-ddump-splices@ GHC flag. For more info on these changes, see . -} module Data.Foldable.Deriving ( -- * 'Foldable' deriveFoldable , makeFoldMap , makeFoldr , makeFold , makeFoldl -- * 'deriveFoldable' limitations -- $constraints ) where import Data.Functor.Deriving.Internal {- $constraints Be aware of the following potential gotchas: * If you are using the @-XGADTs@ or @-XExistentialQuantification@ extensions, an existential constraint cannot mention the last type variable. For example, @data Illegal a = forall a. Show a => Illegal a@ cannot have a derived 'Functor' instance. * Type variables of kind @* -> *@ are assumed to have 'Foldable' constraints. If this is not desirable, use 'makeFoldr' or 'makeFoldMap'. -} deriving-compat-0.3.4/src/Data/Bounded/0000755000000000000000000000000013002245656016017 5ustar0000000000000000deriving-compat-0.3.4/src/Data/Bounded/Deriving.hs0000644000000000000000000000124213002245656020121 0ustar0000000000000000{-| Module: Data.Bounded.Deriving Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Exports functions to mechanically derive 'Bounded' instances. -} module Data.Bounded.Deriving ( -- * 'Bounded' deriveBounded , makeMinBound , makeMaxBound -- * 'deriveBounded' limitations -- $constraints ) where import Data.Bounded.Deriving.Internal {- $constraints Be aware of the following potential gotchas: * Type variables of kind @*@ are assumed to have 'Bounded' constraints. If this is not desirable, use 'makeMinBound' or one of its cousins. -} deriving-compat-0.3.4/src/Data/Bounded/Deriving/0000755000000000000000000000000013002245656017566 5ustar0000000000000000deriving-compat-0.3.4/src/Data/Bounded/Deriving/Internal.hs0000644000000000000000000001026213002245656021677 0ustar0000000000000000{-# LANGUAGE CPP #-} {-| Module: Data.Bounded.Deriving.Internal Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Exports functions to mechanically derive 'Bounded' instances. -} module Data.Bounded.Deriving.Internal ( -- * 'Bounded' deriveBounded , makeMinBound , makeMaxBound ) where import Data.Deriving.Internal import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax ------------------------------------------------------------------------------- -- Code generation ------------------------------------------------------------------------------- -- | Generates a 'Bounded' instance declaration for the given data type or data -- family instance. deriveBounded :: Name -> Q [Dec] deriveBounded name = withType name fromCons where fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do (instanceCxt, instanceType) <- buildTypeInstance BoundedClass name' ctxt tvbs mbTys instanceD (return instanceCxt) (return instanceType) (boundedFunDecs name' cons) -- | Generates a lambda expression which behaves like 'minBound' (without -- requiring a 'Bounded' instance). makeMinBound :: Name -> Q Exp makeMinBound = makeBoundedFun MinBound -- | Generates a lambda expression which behaves like 'maxBound' (without -- requiring a 'Bounded' instance). makeMaxBound :: Name -> Q Exp makeMaxBound = makeBoundedFun MaxBound -- | Generates 'minBound' and 'maxBound' method declarations. boundedFunDecs :: Name -> [Con] -> [Q Dec] boundedFunDecs tyName cons = [makeFunD MinBound, makeFunD MaxBound] where makeFunD :: BoundedFun -> Q Dec makeFunD bf = funD (boundedFunName bf) [ clause [] (normalB $ makeBoundedFunForCons bf tyName cons) [] ] -- | Generates a lambda expression which behaves like the BoundedFun argument. makeBoundedFun :: BoundedFun -> Name -> Q Exp makeBoundedFun bf name = withType name fromCons where fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp fromCons name' ctxt tvbs cons mbTys = -- We force buildTypeInstance here since it performs some checks for whether -- or not the provided datatype can actually have minBound/maxBound -- implemented for it, and produces errors if it can't. buildTypeInstance BoundedClass name' ctxt tvbs mbTys `seq` makeBoundedFunForCons bf name' cons -- | Generates a lambda expression for minBound/maxBound. for the -- given constructors. All constructors must be from the same type. makeBoundedFunForCons :: BoundedFun -> Name -> [Con] -> Q Exp makeBoundedFunForCons _ _ [] = noConstructorsError makeBoundedFunForCons bf tyName cons | not (isProduct || isEnumeration) = enumerationOrProductError $ nameBase tyName | isEnumeration = pickCon | otherwise -- It's a product type = pickConApp where isProduct, isEnumeration :: Bool isProduct = isProductType cons isEnumeration = isEnumerationType cons con1, conN :: Q Exp con1 = conE $ constructorName $ head cons conN = conE $ constructorName $ last cons pickCon :: Q Exp pickCon = case bf of MinBound -> con1 MaxBound -> conN pickConApp :: Q Exp pickConApp = appsE $ pickCon : map varE (replicate (conArity $ head cons) (boundedFunName bf)) ------------------------------------------------------------------------------- -- Class-specific constants ------------------------------------------------------------------------------- -- There's only one Bounded variant! data BoundedClass = BoundedClass instance ClassRep BoundedClass where arity _ = 0 allowExQuant _ = True fullClassName _ = boundedTypeName classConstraint _ 0 = Just $ boundedTypeName classConstraint _ _ = Nothing -- | A representation of which function is being generated. data BoundedFun = MinBound | MaxBound boundedFunName :: BoundedFun -> Name boundedFunName MinBound = minBoundValName boundedFunName MaxBound = maxBoundValName deriving-compat-0.3.4/src/Data/Enum/0000755000000000000000000000000013002245656015343 5ustar0000000000000000deriving-compat-0.3.4/src/Data/Enum/Deriving.hs0000644000000000000000000000131613002245656017447 0ustar0000000000000000{-| Module: Data.Enum.Deriving Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Exports functions to mechanically derive 'Enum' instances. -} module Data.Enum.Deriving ( -- * 'Enum' deriveEnum , makeSucc , makePred , makeToEnum , makeFromEnum , makeEnumFrom , makeEnumFromThen -- * 'deriveEnum' limitations -- $constraints ) where import Data.Enum.Deriving.Internal {- $constraints Be aware of the following potential gotchas: * Type variables of kind @*@ are assumed to have 'Enum' constraints. If this is not desirable, use 'makeToEnum' or one of its cousins. -} deriving-compat-0.3.4/src/Data/Enum/Deriving/0000755000000000000000000000000013002245656017112 5ustar0000000000000000deriving-compat-0.3.4/src/Data/Enum/Deriving/Internal.hs0000644000000000000000000002037013002245656021224 0ustar0000000000000000{-| Module: Data.Enum.Deriving.Internal Copyright: (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Ryan Scott Portability: Template Haskell Exports functions to mechanically derive 'Enum' instances. -} module Data.Enum.Deriving.Internal ( -- * 'Enum' deriveEnum , makeSucc , makePred , makeToEnum , makeFromEnum , makeEnumFrom , makeEnumFromThen ) where import Data.Deriving.Internal import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax ------------------------------------------------------------------------------- -- Code generation ------------------------------------------------------------------------------- -- | Generates an 'Enum' instance declaration for the given data type or data -- family instance. deriveEnum :: Name -> Q [Dec] deriveEnum name = withType name fromCons where fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do (instanceCxt, instanceType) <- buildTypeInstance EnumClass name' ctxt tvbs mbTys instanceD (return instanceCxt) (return instanceType) (enumFunDecs name' instanceType cons) -- | Generates a lambda expression which behaves like 'succ' (without -- requiring an 'Enum' instance). makeSucc :: Name -> Q Exp makeSucc = makeEnumFun Succ -- | Generates a lambda expression which behaves like 'pred' (without -- requiring an 'Enum' instance). makePred :: Name -> Q Exp makePred = makeEnumFun Pred -- | Generates a lambda expression which behaves like 'toEnum' (without -- requiring an 'Enum' instance). makeToEnum :: Name -> Q Exp makeToEnum = makeEnumFun ToEnum -- | Generates a lambda expression which behaves like 'fromEnum' (without -- requiring an 'Enum' instance). makeFromEnum :: Name -> Q Exp makeFromEnum = makeEnumFun FromEnum -- | Generates a lambda expression which behaves like 'enumFrom' (without -- requiring an 'Enum' instance). makeEnumFrom :: Name -> Q Exp makeEnumFrom = makeEnumFun EnumFrom -- | Generates a lambda expression which behaves like 'enumFromThen' (without -- requiring an 'Enum' instance). makeEnumFromThen :: Name -> Q Exp makeEnumFromThen = makeEnumFun EnumFromThen -- | Generates method declarations for an 'Enum' instance. enumFunDecs :: Name -> Type -> [Con] -> [Q Dec] enumFunDecs tyName ty cons = map makeFunD [ Succ , Pred , ToEnum , EnumFrom , EnumFromThen , FromEnum ] where makeFunD :: EnumFun -> Q Dec makeFunD ef = funD (enumFunName ef) [ clause [] (normalB $ makeEnumFunForCons ef tyName ty cons) [] ] -- | Generates a lambda expression which behaves like the EnumFun argument. makeEnumFun :: EnumFun -> Name -> Q Exp makeEnumFun ef name = withType name fromCons where fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp fromCons name' ctxt tvbs cons mbTys = do (_, instanceType) <- buildTypeInstance EnumClass name' ctxt tvbs mbTys makeEnumFunForCons ef name' instanceType cons -- | Generates a lambda expression for fromEnum/toEnum/etc. for the -- given constructors. All constructors must be from the same type. makeEnumFunForCons :: EnumFun -> Name -> Type -> [Con] -> Q Exp makeEnumFunForCons _ _ _ [] = noConstructorsError makeEnumFunForCons ef tyName ty cons | not $ isEnumerationType cons = enumerationError tyNameBase | otherwise = case ef of Succ -> lamOneHash $ \aHash -> condE (varE eqValName `appE` maxTagExpr `appE` (conE iHashDataName `appE` varE aHash)) (illegalExpr "succ" tyNameBase "tried to take `succ' of last tag in enumeration") (tag2Con `appE` (varE plusValName `appE` (conE iHashDataName `appE` varE aHash) `appE` integerE 1)) Pred -> lamOneHash $ \aHash -> condE (varE eqValName `appE` integerE 0 `appE` (conE iHashDataName `appE` varE aHash)) (illegalExpr "pred" tyNameBase "tried to take `pred' of first tag in enumeration") (tag2Con `appE` (varE plusValName `appE` (conE iHashDataName `appE` varE aHash) `appE` integerE (-1))) ToEnum -> lamOne $ \a -> condE (appsE [ varE andValName , varE geValName `appE` varE a `appE` integerE 0 , varE leValName `appE` varE a `appE` maxTagExpr ]) (tag2Con `appE` varE a) (illegalToEnumTag tyNameBase maxTagExpr a) EnumFrom -> lamOneHash $ \aHash -> appsE [ varE mapValName , tag2Con , enumFromToExpr (conE iHashDataName `appE` varE aHash) maxTagExpr ] EnumFromThen -> do a <- newName "a" aHash <- newName "a#" b <- newName "b" bHash <- newName "b#" lamE [varP a, varP b] $ untagExpr [(a, aHash), (b, bHash)] $ appE (varE mapValName `appE` tag2Con) $ enumFromThenToExpr (conE iHashDataName `appE` varE aHash) (conE iHashDataName `appE` varE bHash) (condE (appsE [ varE gtValName , conE iHashDataName `appE` varE aHash , conE iHashDataName `appE` varE bHash ]) (integerE 0) maxTagExpr) FromEnum -> lamOneHash $ \aHash -> conE iHashDataName `appE` varE aHash where tyNameBase :: String tyNameBase = nameBase tyName maxTagExpr :: Q Exp maxTagExpr = integerE (length cons - 1) `sigE` conT intTypeName lamOne :: (Name -> Q Exp) -> Q Exp lamOne f = do a <- newName "a" lam1E (varP a) $ f a lamOneHash :: (Name -> Q Exp) -> Q Exp lamOneHash f = lamOne $ \a -> do aHash <- newName "a#" untagExpr [(a, aHash)] $ f aHash tag2Con :: Q Exp tag2Con = tag2ConExpr $ removeClassApp ty ------------------------------------------------------------------------------- -- Class-specific constants ------------------------------------------------------------------------------- -- There's only one Enum variant! data EnumClass = EnumClass instance ClassRep EnumClass where arity _ = 0 allowExQuant _ = True fullClassName _ = enumTypeName classConstraint _ 0 = Just $ enumTypeName classConstraint _ _ = Nothing -- | A representation of which function is being generated. data EnumFun = Succ | Pred | ToEnum | FromEnum | EnumFrom | EnumFromThen deriving Show enumFunName :: EnumFun -> Name enumFunName Succ = succValName enumFunName Pred = predValName enumFunName ToEnum = toEnumValName enumFunName FromEnum = fromEnumValName enumFunName EnumFrom = enumFromValName enumFunName EnumFromThen = enumFromThenValName ------------------------------------------------------------------------------- -- Assorted utilities ------------------------------------------------------------------------------- enumFromThenToExpr :: Q Exp -> Q Exp -> Q Exp -> Q Exp enumFromThenToExpr f t1 t2 = varE enumFromThenToValName `appE` f `appE` t1 `appE` t2 illegalExpr :: String -> String -> String -> Q Exp illegalExpr meth tp msg = varE errorValName `appE` stringE (meth ++ '{':tp ++ "}: " ++ msg) illegalToEnumTag :: String -> Q Exp -> Name -> Q Exp illegalToEnumTag tp maxtag a = appE (varE errorValName) (appE (appE (varE appendValName) (stringE ("toEnum{" ++ tp ++ "}: tag("))) (appE (appE (appE (varE showsPrecValName) (integerE 0)) (varE a)) (appE (appE (varE appendValName) (stringE ") is outside of enumeration's range (0,")) (appE (appE (appE (varE showsPrecValName) (integerE 0)) maxtag) (stringE ")")))))