├── cabal.project ├── Setup.hs ├── tests ├── Spec.hs ├── EqSpec.hs ├── GH24Spec.hs ├── GH27Spec.hs ├── GH6Spec.hs ├── OrdSpec.hs ├── GH31Spec.hs ├── DerivingViaSpec.hs ├── ReadSpec.hs ├── ShowSpec.hs ├── Types │ ├── ReadShow.hs │ └── EqOrd.hs ├── BoundedEnumIxSpec.hs └── FunctorSpec.hs ├── cabal.haskell-ci ├── .gitignore ├── src ├── Data │ ├── Bounded │ │ ├── Deriving.hs │ │ └── Deriving │ │ │ └── Internal.hs │ ├── Ix │ │ ├── Deriving.hs │ │ └── Deriving │ │ │ └── Internal.hs │ ├── Enum │ │ ├── Deriving.hs │ │ └── Deriving │ │ │ └── Internal.hs │ ├── Functor │ │ └── Deriving.hs │ ├── Eq │ │ ├── Deriving.hs │ │ └── Deriving │ │ │ └── Internal.hs │ ├── Ord │ │ ├── Deriving.hs │ │ └── Deriving │ │ │ └── Internal.hs │ ├── Traversable │ │ └── Deriving.hs │ ├── Foldable │ │ └── Deriving.hs │ ├── Deriving │ │ ├── Via.hs │ │ └── Via │ │ │ └── Internal.hs │ └── Deriving.hs └── Text │ ├── Show │ └── Deriving.hs │ └── Read │ └── Deriving.hs ├── LICENSE ├── README.md ├── deriving-compat.cabal ├── CHANGELOG.md └── .github └── workflows └── haskell-ci.yml /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /tests/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | distribution: jammy 2 | no-tests-no-benchmarks: False 3 | unconstrained: False 4 | local-ghc-options: -Werror 5 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | cabal.project.local~ 21 | .HTF/ 22 | .ghc.environment.* 23 | -------------------------------------------------------------------------------- /tests/EqSpec.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: EqSpec 3 | Copyright: (C) 2015-2017 Ryan Scott 4 | License: BSD-style (see the file LICENSE) 5 | Maintainer: Ryan Scott 6 | Portability: Template Haskell 7 | 8 | @hspec@ tests for derived 'Eq', 'Eq1', and 'Eq2' instances. 9 | -} 10 | module EqSpec where 11 | 12 | import Test.Hspec 13 | 14 | import Types.EqOrd () 15 | 16 | ------------------------------------------------------------------------------- 17 | 18 | main :: IO () 19 | main = hspec spec 20 | 21 | spec :: Spec 22 | spec = pure () 23 | -------------------------------------------------------------------------------- /src/Data/Bounded/Deriving.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Data.Bounded.Deriving 3 | Copyright: (C) 2015-2017 Ryan Scott 4 | License: BSD-style (see the file LICENSE) 5 | Maintainer: Ryan Scott 6 | Portability: Template Haskell 7 | 8 | Exports functions to mechanically derive 'Bounded' instances. 9 | -} 10 | module Data.Bounded.Deriving ( 11 | -- * 'Bounded' 12 | deriveBounded 13 | , makeMinBound 14 | , makeMaxBound 15 | -- * 'deriveBounded' limitations 16 | -- $constraints 17 | ) where 18 | 19 | import Data.Bounded.Deriving.Internal 20 | 21 | {- $constraints 22 | 23 | Be aware of the following potential gotchas: 24 | 25 | * Type variables of kind @*@ are assumed to have 'Bounded' constraints. 26 | If this is not desirable, use 'makeMinBound' or one of its cousins. 27 | -} 28 | -------------------------------------------------------------------------------- /tests/GH24Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | #if __GLASGOW_HASKELL__ < 806 7 | {-# LANGUAGE TypeInType #-} 8 | #endif 9 | 10 | {-| 11 | Module: GH24Spec 12 | Copyright: (C) 2019 Ryan Scott 13 | License: BSD-style (see the file LICENSE) 14 | Maintainer: Ryan Scott 15 | Portability: Template Haskell 16 | 17 | A regression test for 18 | https://github.com/haskell-compat/deriving-compat/issues/24. 19 | -} 20 | module GH24Spec (main, spec) where 21 | 22 | import Data.Deriving 23 | 24 | import Test.Hspec 25 | 26 | data family P (a :: j) (b :: k) 27 | data instance P (a :: k) k = MkP deriving (Eq, Ord) 28 | 29 | $(deriveEnum 'MkP) 30 | $(deriveIx 'MkP) 31 | 32 | main :: IO () 33 | main = hspec spec 34 | 35 | spec :: Spec 36 | spec = pure () 37 | -------------------------------------------------------------------------------- /tests/GH27Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | #if MIN_VERSION_template_haskell(2,12,0) 7 | {-# LANGUAGE InstanceSigs #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | #endif 10 | 11 | {-| 12 | Module: GH27Spec 13 | Copyright: (C) 2019 Ryan Scott 14 | License: BSD-style (see the file LICENSE) 15 | Maintainer: Ryan Scott 16 | Portability: Template Haskell 17 | 18 | A regression test for 19 | https://github.com/haskell-compat/deriving-compat/issues/27. 20 | -} 21 | module GH27Spec where 22 | 23 | import Test.Hspec 24 | 25 | #if MIN_VERSION_template_haskell(2,12,0) 26 | import Data.Deriving.Via 27 | import Data.Functor.Const 28 | 29 | newtype Age = MkAge Int 30 | $(deriveVia [t| forall a. Show Age `Via` Const Int a |]) 31 | #endif 32 | 33 | main :: IO () 34 | main = hspec spec 35 | 36 | spec :: Spec 37 | spec = pure () 38 | -------------------------------------------------------------------------------- /src/Data/Ix/Deriving.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Data.Ix.Deriving 3 | Copyright: (C) 2015-2017 Ryan Scott 4 | License: BSD-style (see the file LICENSE) 5 | Maintainer: Ryan Scott 6 | Portability: Template Haskell 7 | 8 | Exports functions to mechanically derive 'Ix' instances. 9 | -} 10 | module Data.Ix.Deriving ( 11 | -- * 'Ix' 12 | deriveIx 13 | , makeRange 14 | , makeUnsafeIndex 15 | , makeInRange 16 | -- * 'deriveIx' limitations 17 | -- $constraints 18 | ) where 19 | 20 | import Data.Ix.Deriving.Internal 21 | 22 | {- $constraints 23 | 24 | Be aware of the following potential gotchas: 25 | 26 | * Type variables of kind @*@ are assumed to have 'Ix' constraints. 27 | If this is not desirable, use 'makeRange' or one of its cousins. 28 | 29 | * Generated 'Ix' instances for poly-kinded data family instances are likely 30 | to require the use of the @TypeInType@ extension on GHC 8.0, 8.2, or 8.4. 31 | -} 32 | -------------------------------------------------------------------------------- /src/Data/Enum/Deriving.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Data.Enum.Deriving 3 | Copyright: (C) 2015-2017 Ryan Scott 4 | License: BSD-style (see the file LICENSE) 5 | Maintainer: Ryan Scott 6 | Portability: Template Haskell 7 | 8 | Exports functions to mechanically derive 'Enum' instances. 9 | -} 10 | module Data.Enum.Deriving ( 11 | -- * 'Enum' 12 | deriveEnum 13 | , makeSucc 14 | , makePred 15 | , makeToEnum 16 | , makeFromEnum 17 | , makeEnumFrom 18 | , makeEnumFromThen 19 | -- * 'deriveEnum' limitations 20 | -- $constraints 21 | ) where 22 | 23 | import Data.Enum.Deriving.Internal 24 | 25 | {- $constraints 26 | 27 | Be aware of the following potential gotchas: 28 | 29 | * Type variables of kind @*@ are assumed to have 'Enum' constraints. 30 | If this is not desirable, use 'makeToEnum' or one of its cousins. 31 | 32 | * Generated 'Enum' instances for poly-kinded data family instances are likely 33 | to require the use of the @TypeInType@ extension on GHC 8.0, 8.2, or 8.4. 34 | -} 35 | -------------------------------------------------------------------------------- /tests/GH6Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | {-| 4 | Module: GH6Spec 5 | Copyright: (C) 2015-2017 Ryan Scott 6 | License: BSD-style (see the file LICENSE) 7 | Maintainer: Ryan Scott 8 | Portability: Template Haskell 9 | 10 | A regression test for 11 | https://github.com/haskell-compat/deriving-compat/issues/6. 12 | -} 13 | module GH6Spec (main, spec) where 14 | 15 | import Data.Deriving (deriveEq1, deriveOrd1) 16 | import Data.Proxy (Proxy(..)) 17 | 18 | import OrdSpec (ordSpec) 19 | 20 | import Test.Hspec (Spec, describe, hspec, parallel) 21 | import Test.QuickCheck (Arbitrary(..), oneof) 22 | 23 | data Foo a 24 | = Foo1 a 25 | | Foo2 a 26 | | Foo3 a 27 | | Foo4 a 28 | | Foo5 a 29 | deriving (Eq, Ord, Show) 30 | 31 | deriveEq1 ''Foo 32 | deriveOrd1 ''Foo 33 | 34 | instance Arbitrary a => Arbitrary (Foo a) where 35 | arbitrary = oneof $ map (<$> arbitrary) [Foo1, Foo2, Foo3, Foo4, Foo5] 36 | 37 | main :: IO () 38 | main = hspec spec 39 | 40 | spec :: Spec 41 | spec = parallel $ describe "GH6" $ ordSpec (Proxy :: Proxy (Foo Int)) 42 | -------------------------------------------------------------------------------- /src/Data/Functor/Deriving.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Data.Functor.Deriving 3 | Copyright: (C) 2015-2017 Ryan Scott 4 | License: BSD-style (see the file LICENSE) 5 | Maintainer: Ryan Scott 6 | Portability: Template Haskell 7 | 8 | Exports functions to mechanically derive 'Functor' instances. 9 | 10 | For more info on how deriving @Functor@ works, see 11 | . 12 | -} 13 | module Data.Functor.Deriving ( 14 | -- * 'Functor' 15 | deriveFunctor 16 | , deriveFunctorOptions 17 | , makeFmap 18 | , makeFmapOptions 19 | , makeReplace 20 | , makeReplaceOptions 21 | -- * 'FFTOptions' 22 | , FFTOptions(..) 23 | , defaultFFTOptions 24 | -- * 'deriveFunctor' limitations 25 | -- $constraints 26 | ) where 27 | 28 | import Data.Functor.Deriving.Internal 29 | 30 | {- $constraints 31 | 32 | Be aware of the following potential gotchas: 33 | 34 | * Type variables of kind @* -> *@ are assumed to have 'Functor' constraints. 35 | If this is not desirable, use 'makeFmap'. 36 | -} 37 | -------------------------------------------------------------------------------- /tests/OrdSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | {-| 4 | Module: OrdSpec 5 | Copyright: (C) 2015-2017 Ryan Scott 6 | License: BSD-style (see the file LICENSE) 7 | Maintainer: Ryan Scott 8 | Portability: Template Haskell 9 | 10 | @hspec@ tests for derived 'Ord', 'Ord1', and 'Ord2' instances. 11 | -} 12 | module OrdSpec where 13 | 14 | import Data.Functor.Classes 15 | 16 | import Test.Hspec 17 | import Test.Hspec.QuickCheck (prop) 18 | import Test.QuickCheck (Arbitrary) 19 | 20 | import Types.EqOrd () 21 | 22 | ------------------------------------------------------------------------------- 23 | 24 | prop_Ord :: (Ord a, Ord (f a), Ord1 f) => f a -> f a -> Expectation 25 | prop_Ord x y = compare x y `shouldBe` compare1 x y 26 | 27 | ordSpec :: forall proxy f a. (Arbitrary (f a), Show (f a), 28 | Ord a, Ord (f a), Ord1 f) 29 | => proxy (f a) -> Spec 30 | ordSpec _ = prop "has a valid Ord1 instance" (prop_Ord :: f a -> f a -> Expectation) 31 | 32 | ------------------------------------------------------------------------------- 33 | 34 | main :: IO () 35 | main = hspec spec 36 | 37 | spec :: Spec 38 | spec = pure () 39 | -------------------------------------------------------------------------------- /tests/GH31Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | {-| 4 | Module: GH31Spec 5 | Copyright: (C) 2020 Ryan Scott 6 | License: BSD-style (see the file LICENSE) 7 | Maintainer: Ryan Scott 8 | Portability: Template Haskell 9 | 10 | A regression test for 11 | https://github.com/haskell-compat/deriving-compat/issues/31. 12 | -} 13 | module GH31Spec (main, spec) where 14 | 15 | import Data.Deriving (deriveEq1, deriveOrd1) 16 | import Data.Functor.Classes (compare1) 17 | import Data.Proxy (Proxy(..)) 18 | import Data.Void (Void) 19 | 20 | import OrdSpec (ordSpec) 21 | 22 | import Test.Hspec (Spec, describe, hspec, it, parallel, shouldBe) 23 | import Test.QuickCheck (Arbitrary(..), oneof) 24 | 25 | data T a 26 | = A 27 | | B Int 28 | | C Int 29 | | D 30 | | E Int 31 | | F 32 | deriving (Eq, Ord, Show) 33 | 34 | deriveEq1 ''T 35 | deriveOrd1 ''T 36 | 37 | instance Arbitrary (T a) where 38 | arbitrary = oneof [ pure A 39 | , B <$> arbitrary 40 | , C <$> arbitrary 41 | , pure D 42 | , E <$> arbitrary 43 | , pure F 44 | ] 45 | 46 | main :: IO () 47 | main = hspec spec 48 | 49 | spec :: Spec 50 | spec = parallel $ 51 | describe "GH31" $ do 52 | ordSpec (Proxy :: Proxy (T Void)) 53 | it "obeys reflexivity" $ 54 | let x :: T Void 55 | x = E 0 56 | in compare1 x x `shouldBe` EQ 57 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015-2017, Ryan Scott 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Ryan Scott nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /src/Data/Eq/Deriving.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Data.Eq.Deriving 3 | Copyright: (C) 2015-2017 Ryan Scott 4 | License: BSD-style (see the file LICENSE) 5 | Maintainer: Ryan Scott 6 | Portability: Template Haskell 7 | 8 | Exports functions to mechanically derive 'Eq', 'Eq1', and 'Eq2' instances. 9 | Note that upstream GHC does not have the ability to derive 'Eq1' or 'Eq2' 10 | instances, but since the functionality to derive 'Eq' extends very naturally 11 | 'Eq1' and 'Eq2', the ability to derive the latter two classes is provided as a 12 | convenience. 13 | -} 14 | module Data.Eq.Deriving ( 15 | -- * 'Eq' 16 | deriveEq 17 | , makeEq 18 | , makeNotEq 19 | -- * 'Eq1' 20 | , deriveEq1 21 | , makeLiftEq 22 | , makeEq1 23 | -- * 'Eq2' 24 | , deriveEq2 25 | , makeLiftEq2 26 | , makeEq2 27 | -- * 'deriveEq' limitations 28 | -- $constraints 29 | ) where 30 | 31 | import Data.Eq.Deriving.Internal 32 | 33 | {- $constraints 34 | 35 | Be aware of the following potential gotchas: 36 | 37 | * Type variables of kind @*@ are assumed to have 'Eq' constraints. 38 | Type variables of kind @* -> *@ are assumed to have 'Eq1' constraints. 39 | Type variables of kind @* -> * -> *@ are assumed to have 'Eq2' constraints. 40 | If this is not desirable, use 'makeEq' or one of its cousins. 41 | 42 | * The 'Eq1' class had a different definition in @transformers-0.4@, and as a result, 43 | 'deriveEq1' implements different instances for the @transformers-0.4@ 'Eq1' than 44 | it otherwise does. Also, 'makeLiftEq' is not available 45 | when this library is built against @transformers-0.4@, only 'makeEq1. 46 | 47 | * The 'Eq2' class is not available in @transformers-0.4@, and as a 48 | result, neither are Template Haskell functions that deal with 'Eq2' when this 49 | library is built against @transformers-0.4@. 50 | -} 51 | -------------------------------------------------------------------------------- /src/Data/Ord/Deriving.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Data.Ord.Deriving 3 | Copyright: (C) 2015-2017 Ryan Scott 4 | License: BSD-style (see the file LICENSE) 5 | Maintainer: Ryan Scott 6 | Portability: Template Haskell 7 | 8 | Exports functions to mechanically derive 'Ord', 'Ord1', and 'Ord2' instances. 9 | Note that upstream GHC does not have the ability to derive 'Ord1' or 'Ord2' 10 | instances, but since the functionality to derive 'Ord' extends very naturally 11 | 'Ord1' and 'Ord2', the ability to derive the latter two classes is provided as a 12 | convenience. 13 | -} 14 | module Data.Ord.Deriving ( 15 | -- * 'Ord' 16 | deriveOrd 17 | , makeCompare 18 | , makeLT 19 | , makeLE 20 | , makeGT 21 | , makeGE 22 | , makeMax 23 | , makeMin 24 | -- * 'Ord1' 25 | , deriveOrd1 26 | , makeLiftCompare 27 | , makeCompare1 28 | -- * 'Ord2' 29 | , deriveOrd2 30 | , makeLiftCompare2 31 | , makeCompare2 32 | -- * 'deriveOrd' limitations 33 | -- $constraints 34 | ) where 35 | 36 | import Data.Ord.Deriving.Internal 37 | 38 | {- $constraints 39 | 40 | Be aware of the following potential gotchas: 41 | 42 | * Type variables of kind @*@ are assumed to have 'Ord' constraints. 43 | Type variables of kind @* -> *@ are assumed to have 'Ord1' constraints. 44 | Type variables of kind @* -> * -> *@ are assumed to have 'Ord2' constraints. 45 | If this is not desirable, use 'makeCompare' or one of its cousins. 46 | 47 | * The 'Ord1' class had a different definition in @transformers-0.4@, and as a result, 48 | 'deriveOrd1' implements different instances for the @transformers-0.4@ 'Ord1' than 49 | it otherwise does. Also, 'makeLiftCompare' is not available 50 | when this library is built against @transformers-0.4@, only 'makeCompare1. 51 | 52 | * The 'Ord2' class is not available in @transformers-0.4@, and as a 53 | result, neither are Template Haskell functions that deal with 'Ord2' when this 54 | library is built against @transformers-0.4@. 55 | -} 56 | -------------------------------------------------------------------------------- /src/Data/Traversable/Deriving.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Data.Traversable.Deriving 3 | Copyright: (C) 2015-2017 Ryan Scott 4 | License: BSD-style (see the file LICENSE) 5 | Maintainer: Ryan Scott 6 | Portability: Template Haskell 7 | 8 | Exports functions to mechanically derive 'Traversable' instances in a way that mimics 9 | how the @-XDeriveTraversable@ extension works since GHC 8.0. 10 | 11 | Derived 'Traversable' instances from this module do not generate 12 | superfluous 'pure' expressions in its implementation of 'traverse'. One can 13 | verify this by compiling a module that uses 'deriveTraversable' with the 14 | @-ddump-splices@ GHC flag. 15 | 16 | These changes make it possible to derive @Traversable@ instances for data types with 17 | unlifted argument types, e.g., 18 | 19 | @ 20 | data IntHash a = IntHash Int# a 21 | 22 | deriving instance Traversable IntHash -- On GHC 8.0 on later 23 | $(deriveTraversable ''IntHash) -- On GHC 7.10 and earlier 24 | @ 25 | 26 | For more info on these changes, see 27 | . 28 | -} 29 | module Data.Traversable.Deriving ( 30 | -- * 'Traversable' 31 | deriveTraversable 32 | , deriveTraversableOptions 33 | , makeTraverse 34 | , makeTraverseOptions 35 | , makeSequenceA 36 | , makeSequenceAOptions 37 | , makeMapM 38 | , makeMapMOptions 39 | , makeSequence 40 | , makeSequenceOptions 41 | -- * 'FFTOptions' 42 | , FFTOptions(..) 43 | , defaultFFTOptions 44 | -- * 'deriveTraversable' limitations 45 | -- $constraints 46 | ) where 47 | 48 | import Data.Functor.Deriving.Internal 49 | 50 | {- $constraints 51 | 52 | Be aware of the following potential gotchas: 53 | 54 | * If you are using the @-XGADTs@ or @-XExistentialQuantification@ extensions, an 55 | existential constraint cannot mention the last type variable. For example, 56 | @data Illegal a = forall a. Show a => Illegal a@ cannot have a derived 57 | 'Traversable' instance. 58 | 59 | * Type variables of kind @* -> *@ are assumed to have 'Traversable' constraints. 60 | If this is not desirable, use 'makeTraverse'. 61 | -} 62 | -------------------------------------------------------------------------------- /src/Data/Foldable/Deriving.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Data.Foldable.Deriving 3 | Copyright: (C) 2015-2017 Ryan Scott 4 | License: BSD-style (see the file LICENSE) 5 | Maintainer: Ryan Scott 6 | Portability: Template Haskell 7 | 8 | Exports functions to mechanically derive 'Foldable' instances in a way that mimics 9 | how the @-XDeriveFoldable@ extension works since GHC 8.0. 10 | 11 | These changes make it possible to derive @Foldable@ instances for data types with 12 | existential constraints, e.g., 13 | 14 | @ 15 | data WrappedSet a where 16 | WrapSet :: Ord a => a -> WrappedSet a 17 | 18 | deriving instance Foldable WrappedSet -- On GHC 8.0 on later 19 | $(deriveFoldable ''WrappedSet) -- On GHC 7.10 and earlier 20 | @ 21 | 22 | In addition, derived 'Foldable' instances from this module do not generate 23 | superfluous 'mempty' expressions in its implementation of 'foldMap'. One can 24 | verify this by compiling a module that uses 'deriveFoldable' with the 25 | @-ddump-splices@ GHC flag. 26 | 27 | For more info on these changes, see 28 | . 29 | -} 30 | module Data.Foldable.Deriving ( 31 | -- * 'Foldable' 32 | deriveFoldable 33 | , deriveFoldableOptions 34 | , makeFoldMap 35 | , makeFoldMapOptions 36 | , makeFoldr 37 | , makeFoldrOptions 38 | , makeFold 39 | , makeFoldOptions 40 | , makeFoldl 41 | , makeFoldlOptions 42 | , makeNull 43 | , makeNullOptions 44 | -- * 'FFTOptions' 45 | , FFTOptions(..) 46 | , defaultFFTOptions 47 | -- * 'deriveFoldable' limitations 48 | -- $constraints 49 | ) where 50 | 51 | import Data.Functor.Deriving.Internal 52 | 53 | {- $constraints 54 | 55 | Be aware of the following potential gotchas: 56 | 57 | * If you are using the @-XGADTs@ or @-XExistentialQuantification@ extensions, an 58 | existential constraint cannot mention the last type variable. For example, 59 | @data Illegal a = forall a. Show a => Illegal a@ cannot have a derived 60 | 'Functor' instance. 61 | 62 | * Type variables of kind @* -> *@ are assumed to have 'Foldable' constraints. 63 | If this is not desirable, use 'makeFoldr' or 'makeFoldMap'. 64 | -} 65 | -------------------------------------------------------------------------------- /src/Data/Deriving/Via.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | {-| 4 | Module: Data.Deriving.Via 5 | Copyright: (C) 2015-2017 Ryan Scott 6 | License: BSD-style (see the file LICENSE) 7 | Maintainer: Ryan Scott 8 | Portability: Template Haskell 9 | 10 | On @template-haskell-2.12@ or later (i.e., GHC 8.2 or later), this module 11 | exports functionality which emulates the @GeneralizedNewtypeDeriving@ and 12 | @DerivingVia@ GHC extensions (the latter of which was introduced in GHC 8.6). 13 | 14 | On older versions of @template-haskell@/GHC, this module does not export 15 | anything. 16 | -} 17 | module Data.Deriving.Via ( 18 | #if !(MIN_VERSION_template_haskell(2,12,0)) 19 | ) where 20 | #else 21 | -- * @GeneralizedNewtypeDeriving@ 22 | deriveGND 23 | -- * @DerivingVia@ 24 | , deriveVia 25 | , Via 26 | -- * Limitations 27 | -- $constraints 28 | ) where 29 | 30 | import Data.Deriving.Internal (Via) 31 | import Data.Deriving.Via.Internal 32 | 33 | {- $constraints 34 | 35 | Be aware of the following potential gotchas: 36 | 37 | * Unlike every other module in this library, the functions exported by 38 | "Data.Deriving.Via" only support GHC 8.2 and later, as they require 39 | Template Haskell functionality not present in earlier GHCs. 40 | 41 | * Additionally, using the functions in "Data.Deriving.Via" will likely 42 | require you to enable some language extensions (besides @TemplateHaskell@). 43 | These may include: 44 | 45 | * @ImpredicativeTypes@ (if any class methods contain higher-rank types) 46 | 47 | * @InstanceSigs@ 48 | 49 | * @KindSignatures@ 50 | 51 | * @RankNTypes@ 52 | 53 | * @ScopedTypeVariables@ 54 | 55 | * @TypeApplications@ 56 | 57 | * @TypeOperators@ 58 | 59 | * @UndecidableInstances@ (if deriving an instance of a type class with 60 | associated type families) 61 | 62 | * The functions in "Data.Deriving.Via" are not terribly robust in the presence 63 | of @PolyKinds@. Alas, Template Haskell does not make this easy to fix. 64 | 65 | * The functions in "Data.Deriving.Via" make a best-effort attempt to derive 66 | instances for classes with associated type families. This is known not to 67 | work in all scenarios, however, especially when the last parameter to a type 68 | class appears as a kind variable in an associated type family. (See 69 | .) 70 | -} 71 | #endif 72 | -------------------------------------------------------------------------------- /src/Text/Show/Deriving.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Text.Show.Deriving 3 | Copyright: (C) 2015-2017 Ryan Scott 4 | License: BSD-style (see the file LICENSE) 5 | Maintainer: Ryan Scott 6 | Portability: Template Haskell 7 | 8 | Exports functions to mechanically derive 'Show', 'Show1', and 'Show2' instances. 9 | Note that upstream GHC does not have the ability to derive 'Show1' or 'Show2' 10 | instances, but since the functionality to derive 'Show' extends very naturally 11 | 'Show1' and 'Show2', the ability to derive the latter two classes is provided as a 12 | convenience. 13 | -} 14 | module Text.Show.Deriving ( 15 | -- * 'Show' 16 | deriveShow 17 | , deriveShowOptions 18 | , makeShowsPrec 19 | , makeShowsPrecOptions 20 | , makeShow 21 | , makeShowOptions 22 | , makeShowList 23 | , makeShowListOptions 24 | -- * 'Show1' 25 | , deriveShow1 26 | , deriveShow1Options 27 | , makeLiftShowsPrec 28 | , makeLiftShowsPrecOptions 29 | , makeLiftShowList 30 | , makeLiftShowListOptions 31 | , makeShowsPrec1 32 | , makeShowsPrec1Options 33 | -- * 'Show2' 34 | , deriveShow2 35 | , deriveShow2Options 36 | , makeLiftShowsPrec2 37 | , makeLiftShowsPrec2Options 38 | , makeLiftShowList2 39 | , makeLiftShowList2Options 40 | , makeShowsPrec2 41 | , makeShowsPrec2Options 42 | -- * 'ShowOptions' 43 | , ShowOptions(..) 44 | , defaultShowOptions 45 | , legacyShowOptions 46 | -- * 'deriveShow' limitations 47 | -- $constraints 48 | ) where 49 | 50 | import Text.Show.Deriving.Internal 51 | 52 | {- $constraints 53 | 54 | Be aware of the following potential gotchas: 55 | 56 | * Type variables of kind @*@ are assumed to have 'Show' constraints. 57 | Type variables of kind @* -> *@ are assumed to have 'Show1' constraints. 58 | Type variables of kind @* -> * -> *@ are assumed to have 'Show2' constraints. 59 | If this is not desirable, use 'makeShowsPrec' or one of its cousins. 60 | 61 | * The 'Show1' class had a different definition in @transformers-0.4@, and as a result, 62 | 'deriveShow1' implements different instances for the @transformers-0.4@ 'Show1' than 63 | it otherwise does. Also, 'makeLiftShowsPrec' and 'makeLiftShowList' are not available 64 | when this library is built against @transformers-0.4@, only 'makeShowsPrec1. 65 | 66 | * The 'Show2' class is not available in @transformers-0.4@, and as a 67 | result, neither are Template Haskell functions that deal with 'Show2' when this 68 | library is built against @transformers-0.4@. 69 | -} 70 | -------------------------------------------------------------------------------- /tests/DerivingViaSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | #if MIN_VERSION_template_haskell(2,12,0) 11 | {-# LANGUAGE ImpredicativeTypes #-} 12 | {-# LANGUAGE InstanceSigs #-} 13 | {-# LANGUAGE TypeApplications #-} 14 | #endif 15 | 16 | {-| 17 | Module: DerivingViaSpec 18 | Copyright: (C) 2015-2017 Ryan Scott 19 | License: BSD-style (see the file LICENSE) 20 | Maintainer: Ryan Scott 21 | Portability: Template Haskell 22 | 23 | @hspec@ tests for 'deriveGND' and 'deriveVia'. 24 | -} 25 | module DerivingViaSpec where 26 | 27 | import Test.Hspec 28 | 29 | #if MIN_VERSION_template_haskell(2,12,0) 30 | import Data.Deriving.Via 31 | 32 | class Container (f :: * -> *) where 33 | type Inside f a 34 | peekInside :: f a -> Inside f a 35 | 36 | instance Container (Either a) where 37 | type Inside (Either a) b = Maybe b 38 | peekInside (Left{}) = Nothing 39 | peekInside (Right x) = Just x 40 | 41 | newtype Down a = MkDown a deriving Show 42 | $(deriveGND [t| forall a. Eq a => Eq (Down a) |]) 43 | 44 | instance Ord a => Ord (Down a) where 45 | compare (MkDown x) (MkDown y) = y `compare` x 46 | 47 | newtype Id a = MkId a deriving Show 48 | $(deriveGND [t| forall a. Eq a => Eq (Id a) |]) 49 | $(deriveVia [t| forall a. Ord a => Ord (Id a) `Via` Down a |]) 50 | 51 | instance Container Id where 52 | type Inside Id a = a 53 | peekInside (MkId x) = x 54 | 55 | newtype MyEither a b = MkMyEither (Either a b) deriving Show 56 | $(deriveGND [t| forall a. Functor (MyEither a) |]) 57 | $(deriveVia [t| forall a b. (Eq a, Eq b) => Eq (MyEither a b) `Via` Id (Either a b) |]) 58 | $(deriveVia [t| forall a. Applicative (MyEither a) `Via` (Either a) |]) 59 | $(deriveVia [t| forall a. Container (MyEither a) `Via` (Either a) |]) 60 | 61 | newtype Wrap f a = MkWrap (f a) deriving Show 62 | $(deriveGND [t| forall f. Container f => Container (Wrap f) |]) 63 | 64 | class MFunctor (t :: (* -> *) -> * -> *) where 65 | hoist :: (forall a. m a -> n a) -> t m b -> t n b 66 | 67 | newtype TaggedTrans tag trans (m :: * -> *) a = MkTaggedTrans (trans m a) deriving Show 68 | $(deriveGND [t| forall tag trans. MFunctor trans => MFunctor (TaggedTrans tag trans) |]) 69 | #endif 70 | 71 | main :: IO () 72 | main = hspec spec 73 | 74 | spec :: Spec 75 | spec = parallel $ do 76 | #if MIN_VERSION_template_haskell(2,12,0) 77 | describe "Id" $ 78 | it "should compare items in reverse order" $ 79 | compare (MkId "hello") (MkId "world") `shouldBe` GT 80 | #endif 81 | pure () 82 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # `deriving-compat` 2 | [![Hackage](https://img.shields.io/hackage/v/deriving-compat.svg)][Hackage: deriving-compat] 3 | [![Hackage Dependencies](https://img.shields.io/hackage-deps/v/deriving-compat.svg)](http://packdeps.haskellers.com/reverse/deriving-compat) 4 | [![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] 5 | [![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3] 6 | [![Build Status](https://github.com/haskell-compat/deriving-compat/workflows/Haskell-CI/badge.svg)](https://github.com/haskell-compat/deriving-compat/actions?query=workflow%3AHaskell-CI) 7 | 8 | [Hackage: deriving-compat]: 9 | http://hackage.haskell.org/package/deriving-compat 10 | "deriving-compat package on Hackage" 11 | [Haskell.org]: 12 | http://www.haskell.org 13 | "The Haskell Programming Language" 14 | [tl;dr Legal: BSD3]: 15 | https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29 16 | "BSD 3-Clause License (Revised)" 17 | 18 | `deriving-compat` 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: 19 | 20 | * Deriving `Bounded` 21 | * Deriving `Enum` 22 | * Deriving `Ix` 23 | * Deriving `Eq` 24 | * Deriving `Ord` 25 | * Deriving `Read` 26 | * Deriving `Show` 27 | * `DeriveFoldable` 28 | * `DeriveFunctor` 29 | * `DeriveTraversable` 30 | * `GeneralizedNewtypeDeriving` (with GHC 8.2 or later) 31 | * `DerivingVia` (with GHC 8.2 or later) 32 | 33 | See the `Data.Deriving` module for a full list of backported changes. 34 | 35 | In addition, `deriving-compat` also provides some additional `deriving` functionality that has not yet been merged into upstream GHC. Aside from the GHC `deriving` extensions mentioned above, `deriving-compat` also permits deriving instances of classes in the `Data.Functor.Classes` module, covering the `Eq1`, `Eq2`, `Ord1`, `Ord2`, `Read1`, `Read2`, `Show1`, and `Show2` classes. This extra functionality is outside of the main scope of `deriving-compat`, as it does not backport extensions that exist in today's GHC. Nevertheless, the underlying Template Haskell machinery needed to derive `Eq` and friends extends very naturally to `Eq1` and friends, so this extra functionality is included in `deriving-compat` as a convenience. 36 | 37 | Note that some recent GHC typeclasses/extensions are not covered by this package: 38 | 39 | * `DeriveDataTypeable` 40 | * `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. 41 | * `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. 42 | * 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. 43 | -------------------------------------------------------------------------------- /tests/ReadSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE KindSignatures #-} 2 | {-# LANGUAGE MagicHash #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | 7 | {-| 8 | Module: ReadSpec 9 | Copyright: (C) 2015-2017 Ryan Scott 10 | License: BSD-style (see the file LICENSE) 11 | Maintainer: Ryan Scott 12 | Portability: Template Haskell 13 | 14 | @hspec@ tests for derived 'Read', 'Read1', and 'Read2' instances. 15 | -} 16 | module ReadSpec where 17 | 18 | import Data.Deriving 19 | import Data.Functor.Classes (Read1, readsPrec1) 20 | import Data.Proxy 21 | 22 | import Test.Hspec 23 | import Test.Hspec.QuickCheck (prop) 24 | import Test.QuickCheck (Arbitrary(..)) 25 | 26 | import Text.Read (minPrec) 27 | 28 | import Types.ReadShow () 29 | 30 | ------------------------------------------------------------------------------- 31 | 32 | -- Plain data types 33 | 34 | data TyCon# a b = TyCon# { 35 | tcA# :: a 36 | , tcB# :: b 37 | } deriving (Eq, Show) 38 | 39 | data Empty a b 40 | 41 | -- Data families 42 | 43 | data family TyFamily# y z :: * 44 | 45 | data instance TyFamily# a b = TyFamily# { 46 | tfA# :: a 47 | , tfB# :: b 48 | } deriving (Eq, Show) 49 | 50 | ------------------------------------------------------------------------------- 51 | 52 | -- Plain data types 53 | 54 | $(deriveRead ''TyCon#) 55 | $(deriveRead1 ''TyCon#) 56 | $(deriveRead2 ''TyCon#) 57 | 58 | instance (Arbitrary a, Arbitrary b) => Arbitrary (TyCon# a b) where 59 | arbitrary = TyCon# <$> arbitrary <*> arbitrary 60 | 61 | $(deriveRead ''Empty) 62 | $(deriveRead1 ''Empty) 63 | $(deriveRead2 ''Empty) 64 | 65 | -- Data families 66 | 67 | $(deriveRead 'TyFamily#) 68 | $(deriveRead1 'TyFamily#) 69 | $(deriveRead2 'TyFamily#) 70 | 71 | instance (Arbitrary a, Arbitrary b) => Arbitrary (TyFamily# a b) where 72 | arbitrary = TyFamily# <$> arbitrary <*> arbitrary 73 | 74 | ------------------------------------------------------------------------------- 75 | 76 | prop_Read :: forall f a. (Read a, Read (f a), Read1 f, 77 | Eq (f a), Show (f a)) 78 | => f a -> Expectation 79 | prop_Read x = readArb readsPrec `shouldBe` readArb readsPrec1 80 | where 81 | readArb :: (Int -> ReadS (f a)) -> f a 82 | readArb = read' (show x) 83 | 84 | readSpec :: forall f a. (Arbitrary (f a), Eq (f a), Show (f a), 85 | Read a, Read (f a), Read1 f) 86 | => Proxy (f a) -> Spec 87 | readSpec _ = prop "has a valid Read1 instance" (prop_Read :: f a -> Expectation) 88 | 89 | -- Adapted from the definition of readEither 90 | readEither' :: String -> (Int -> ReadS a) -> Either String a 91 | readEither' s rs = 92 | case [ x | (x,"") <- rs minPrec s ] of 93 | [x] -> Right x 94 | [] -> Left "Prelude.read: no parse" 95 | _ -> Left "Prelude.read: ambiguous parse" 96 | 97 | read' :: String -> (Int -> ReadS a) -> a 98 | read' s = either error id . readEither' s 99 | 100 | ------------------------------------------------------------------------------- 101 | 102 | main :: IO () 103 | main = hspec spec 104 | 105 | spec :: Spec 106 | spec = parallel $ do 107 | describe "TyCon#" $ 108 | readSpec (Proxy :: Proxy (TyCon# Char Int)) 109 | describe "TyFamily#" $ 110 | readSpec (Proxy :: Proxy (TyFamily# Char Int)) 111 | -------------------------------------------------------------------------------- /src/Text/Read/Deriving.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-| 3 | Module: Text.Read.Deriving 4 | Copyright: (C) 2015-2017 Ryan Scott 5 | License: BSD-style (see the file LICENSE) 6 | Maintainer: Ryan Scott 7 | Portability: Template Haskell 8 | 9 | Exports functions to mechanically derive 'Read', 'Read1', and 'Read2' instances. 10 | Note that upstream GHC does not have the ability to derive 'Read1' or 'Read2' 11 | instances, but since the functionality to derive 'Read' extends very naturally 12 | 'Read1' and 'Read2', the ability to derive the latter two classes is provided as a 13 | convenience. 14 | -} 15 | module Text.Read.Deriving ( 16 | -- * 'Read' 17 | deriveRead 18 | , deriveReadOptions 19 | , makeReadsPrec 20 | -- , makeReadsPrecOptions 21 | -- , makeReadList 22 | -- , makeReadListOptions 23 | , makeReadPrec 24 | -- , makeReadPrecOptions 25 | -- , makeReadListPrec 26 | -- , makeReadListPrecOptions 27 | -- * 'Read1' 28 | , deriveRead1 29 | , deriveRead1Options 30 | , makeLiftReadsPrec 31 | -- , makeLiftReadsPrecOptions 32 | -- , makeLiftReadList 33 | -- , makeLiftReadListOptions 34 | #if __GLASGOW_HASKELL__ >= 801 35 | , makeLiftReadPrec 36 | -- , makeLiftReadPrecOptions 37 | -- , makeLiftReadListPrec 38 | -- , makeLiftReadListPrecOptions 39 | , makeReadPrec1 40 | -- , makeReadPrec1Options 41 | #endif 42 | , makeReadsPrec1 43 | -- , makeReadsPrec1Options 44 | -- * 'Read2' 45 | , deriveRead2 46 | , deriveRead2Options 47 | , makeLiftReadsPrec2 48 | -- , makeLiftReadsPrec2Options 49 | -- , makeLiftReadList2 50 | -- , makeLiftReadList2Options 51 | #if __GLASGOW_HASKELL__ >= 801 52 | , makeLiftReadPrec2 53 | -- , makeLiftReadPrec2Options 54 | -- , makeLiftReadListPrec2 55 | -- , makeLiftReadListPrec2Options 56 | , makeReadPrec2 57 | -- , makeReadPrec2Options 58 | #endif 59 | , makeReadsPrec2 60 | -- , makeReadsPrec2Options 61 | -- * 'ReadOptions' 62 | , ReadOptions(..) 63 | , defaultReadOptions 64 | -- * 'deriveRead' limitations 65 | -- $constraints 66 | ) where 67 | 68 | import Text.Read.Deriving.Internal 69 | 70 | {- $constraints 71 | 72 | Be aware of the following potential gotchas: 73 | 74 | * Type variables of kind @*@ are assumed to have 'Read' constraints. 75 | Type variables of kind @* -> *@ are assumed to have 'Read1' constraints. 76 | Type variables of kind @* -> * -> *@ are assumed to have 'Read2' constraints. 77 | If this is not desirable, use 'makeReadsPrec' or one of its cousins. 78 | 79 | * The 'Read1' class had a different definition in @transformers-0.4@, and as a result, 80 | 'deriveRead1' implements different instances for the @transformers-0.4@ 'Read1' than 81 | it otherwise does. Also, 'makeLiftReadsPrec' and 'makeLiftReadList' are not available 82 | when this library is built against @transformers-0.4@, only 'makeReadsPrec1. 83 | 84 | * The 'Read2' class is not available in @transformers-0.4@, and as a 85 | result, neither are Template Haskell functions that deal with 'Read2' when this 86 | library is built against @transformers-0.4@. 87 | 88 | * The 'Read1' and 'Read2' classes have new methods ('liftReadPrec'/'liftReadListPrec' 89 | and 'liftReadPrec2'/'liftReadListPrec2', respectively) that were introduced in 90 | @base-4.10@. For now, these methods are only defined when deriving 'Read1'/'Read2' 91 | if built against @base-4.10@ (until @transformers-compat@ catches up), and 92 | the corresponding @make-@ functions are also only available when built against 93 | @base-4.10@. 94 | -} 95 | -------------------------------------------------------------------------------- /tests/ShowSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE EmptyCase #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE MagicHash #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | 11 | {-| 12 | Module: ShowSpec 13 | Copyright: (C) 2015-2017 Ryan Scott 14 | License: BSD-style (see the file LICENSE) 15 | Maintainer: Ryan Scott 16 | Portability: Template Haskell 17 | 18 | @hspec@ tests for derived 'Show', 'Show1', and 'Show2' instances. 19 | -} 20 | module ShowSpec where 21 | 22 | import Data.Deriving 23 | 24 | import GHC.Exts ( Char#, Double#, Float#, Int#, Word# 25 | #if MIN_VERSION_base(4,13,0) 26 | , Int8#, Int16#, Word8#, Word16# 27 | #endif 28 | #if MIN_VERSION_base(4,16,0) 29 | , Int32#, Word32# 30 | #endif 31 | ) 32 | 33 | import Test.Hspec 34 | 35 | import Types.ReadShow () 36 | 37 | ------------------------------------------------------------------------------- 38 | 39 | -- Plain data types 40 | 41 | data TyCon# a b = TyCon# { 42 | tcA :: a 43 | , tcB :: b 44 | , tcInt# :: Int# 45 | , tcFloat# :: Float# 46 | , tcDouble# :: Double# 47 | , tcChar# :: Char# 48 | , tcWord# :: Word# 49 | #if MIN_VERSION_base(4,13,0) 50 | , tcInt8# :: Int8# 51 | , tcInt16# :: Int16# 52 | , tcWord8# :: Word8# 53 | , tcWord16# :: Word16# 54 | #endif 55 | #if MIN_VERSION_base(4,16,0) 56 | , tcInt32# :: Int32# 57 | , tcWord32# :: Word32# 58 | #endif 59 | } 60 | 61 | data TyCon2 a b c d where 62 | TyConClassConstraints :: (Ord m, Ord n, Ord o, Ord p) 63 | => m -> n -> o -> p 64 | -> TyCon2 m n o p 65 | 66 | TyConEqualityConstraints :: (e ~ g, f ~ h, e ~ f) 67 | => e -> f -> g -> h 68 | -> TyCon2 e f g h 69 | 70 | TyConTypeRefinement1, 71 | TyConTypeRefinement2 :: Int -> z 72 | -> TyCon2 Int Int z z 73 | 74 | TyConForalls :: forall p q r s t u. 75 | (Show p, Show q) 76 | => p -> q -> u -> t 77 | -> TyCon2 r s t u 78 | 79 | data Empty1 a b 80 | data Empty2 a b 81 | 82 | -- Data families 83 | 84 | data family TyFamily# y z :: * 85 | 86 | data instance TyFamily# a b = TyFamily# { 87 | tfA :: a 88 | , tfB :: b 89 | , tfInt# :: Int# 90 | , tfFloat# :: Float# 91 | , tfDouble# :: Double# 92 | , tfChar# :: Char# 93 | , tfWord# :: Word# 94 | #if MIN_VERSION_base(4,13,0) 95 | , tfInt8# :: Int8# 96 | , tfInt16# :: Int16# 97 | , tfWord8# :: Word8# 98 | , tfWord16# :: Word16# 99 | #endif 100 | #if MIN_VERSION_base(4,16,0) 101 | , tfInt32# :: Int32# 102 | , tfWord32# :: Word32# 103 | #endif 104 | } 105 | 106 | data family TyFamily2 w x y z :: * 107 | 108 | data instance TyFamily2 a b c d where 109 | TyFamilyClassConstraints :: (Ord m, Ord n, Ord o, Ord p) 110 | => m -> n -> o -> p 111 | -> TyFamily2 m n o p 112 | 113 | TyFamilyEqualityConstraints :: (e ~ g, f ~ h, e ~ f) 114 | => e -> f -> g -> h 115 | -> TyFamily2 e f g h 116 | 117 | TyFamilyTypeRefinement1, 118 | TyFamilyTypeRefinement2 :: Int -> z 119 | -> TyFamily2 Int Int z z 120 | 121 | TyFamilyForalls :: forall p q r s t u. 122 | (Show p, Show q) 123 | => p -> q -> u -> t 124 | -> TyFamily2 r s t u 125 | 126 | ------------------------------------------------------------------------------- 127 | 128 | -- Plain data types 129 | 130 | $(deriveShow ''TyCon#) 131 | $(deriveShow ''TyCon2) 132 | $(deriveShow ''Empty1) 133 | 134 | $(deriveShow1 ''TyCon#) 135 | $(deriveShow1 ''TyCon2) 136 | $(deriveShow1 ''Empty1) 137 | 138 | $(deriveShow2 ''TyCon#) 139 | $(deriveShow2 ''TyCon2) 140 | $(deriveShow2 ''Empty1) 141 | 142 | -- Use EmptyCase here 143 | $(deriveShowOptions defaultShowOptions{ showEmptyCaseBehavior = True } ''Empty2) 144 | $(deriveShow1Options defaultShowOptions{ showEmptyCaseBehavior = True } ''Empty2) 145 | $(deriveShow2Options defaultShowOptions{ showEmptyCaseBehavior = True } ''Empty2) 146 | 147 | -- Data families 148 | 149 | $(deriveShow 'TyFamily#) 150 | $(deriveShow 'TyFamilyClassConstraints) 151 | 152 | $(deriveShow1 'TyFamily#) 153 | $(deriveShow1 'TyFamilyEqualityConstraints) 154 | 155 | $(deriveShow2 'TyFamily#) 156 | $(deriveShow2 'TyFamilyTypeRefinement1) 157 | 158 | ------------------------------------------------------------------------------- 159 | 160 | main :: IO () 161 | main = hspec spec 162 | 163 | spec :: Spec 164 | spec = pure () 165 | -------------------------------------------------------------------------------- /src/Data/Bounded/Deriving/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | {-| 4 | Module: Data.Bounded.Deriving.Internal 5 | Copyright: (C) 2015-2017 Ryan Scott 6 | License: BSD-style (see the file LICENSE) 7 | Maintainer: Ryan Scott 8 | Portability: Template Haskell 9 | 10 | Exports functions to mechanically derive 'Bounded' instances. 11 | 12 | Note: this is an internal module, and as such, the API presented here is not 13 | guaranteed to be stable, even between minor releases of this library. 14 | -} 15 | module Data.Bounded.Deriving.Internal ( 16 | -- * 'Bounded' 17 | deriveBounded 18 | , makeMinBound 19 | , makeMaxBound 20 | ) where 21 | 22 | import Data.Deriving.Internal 23 | import qualified Data.List.NonEmpty as NE 24 | import Data.List.NonEmpty (NonEmpty(..)) 25 | 26 | import Language.Haskell.TH.Datatype 27 | import Language.Haskell.TH.Lib 28 | import Language.Haskell.TH.Syntax 29 | 30 | ------------------------------------------------------------------------------- 31 | -- Code generation 32 | ------------------------------------------------------------------------------- 33 | 34 | -- | Generates a 'Bounded' instance declaration for the given data type or data 35 | -- family instance. 36 | deriveBounded :: Name -> Q [Dec] 37 | deriveBounded name = do 38 | info <- reifyDatatype name 39 | case info of 40 | DatatypeInfo { datatypeContext = ctxt 41 | , datatypeName = parentName 42 | , datatypeInstTypes = instTypes 43 | , datatypeVariant = variant 44 | , datatypeCons = cons 45 | } -> do 46 | (instanceCxt, instanceType) 47 | <- buildTypeInstance BoundedClass parentName ctxt instTypes variant 48 | (:[]) `fmap` instanceD (return instanceCxt) 49 | (return instanceType) 50 | (boundedFunDecs parentName cons) 51 | 52 | -- | Generates a lambda expression which behaves like 'minBound' (without 53 | -- requiring a 'Bounded' instance). 54 | makeMinBound :: Name -> Q Exp 55 | makeMinBound = makeBoundedFun MinBound 56 | 57 | -- | Generates a lambda expression which behaves like 'maxBound' (without 58 | -- requiring a 'Bounded' instance). 59 | makeMaxBound :: Name -> Q Exp 60 | makeMaxBound = makeBoundedFun MaxBound 61 | 62 | -- | Generates 'minBound' and 'maxBound' method declarations. 63 | boundedFunDecs :: Name -> [ConstructorInfo] -> [Q Dec] 64 | boundedFunDecs tyName cons = [makeFunD MinBound, makeFunD MaxBound] 65 | where 66 | makeFunD :: BoundedFun -> Q Dec 67 | makeFunD bf = 68 | funD (boundedFunName bf) 69 | [ clause [] 70 | (normalB $ makeBoundedFunForCons bf tyName cons) 71 | [] 72 | ] 73 | 74 | -- | Generates a lambda expression which behaves like the BoundedFun argument. 75 | makeBoundedFun :: BoundedFun -> Name -> Q Exp 76 | makeBoundedFun bf name = do 77 | info <- reifyDatatype name 78 | case info of 79 | DatatypeInfo { datatypeContext = ctxt 80 | , datatypeName = parentName 81 | , datatypeInstTypes = instTypes 82 | , datatypeVariant = variant 83 | , datatypeCons = cons 84 | } -> do 85 | -- We force buildTypeInstance here since it performs some checks for whether 86 | -- or not the provided datatype can actually have minBound/maxBound 87 | -- implemented for it, and produces errors if it can't. 88 | buildTypeInstance BoundedClass parentName ctxt instTypes variant 89 | >> makeBoundedFunForCons bf parentName cons 90 | 91 | -- | Generates a lambda expression for minBound/maxBound. for the 92 | -- given constructors. All constructors must be from the same type. 93 | makeBoundedFunForCons :: BoundedFun -> Name -> [ConstructorInfo] -> Q Exp 94 | makeBoundedFunForCons _ _ [] = noConstructorsError 95 | makeBoundedFunForCons bf tyName (con:cons') 96 | | not (isProduct || isEnumeration) 97 | = enumerationOrProductError $ nameBase tyName 98 | | isEnumeration 99 | = pickCon 100 | | otherwise -- It's a product type 101 | = pickConApp 102 | where 103 | isProduct, isEnumeration :: Bool 104 | isProduct = isProductType cons 105 | isEnumeration = isEnumerationType cons 106 | 107 | cons :: NonEmpty ConstructorInfo 108 | cons = con :| cons' 109 | 110 | con1, conN :: Q Exp 111 | con1 = conE $ constructorName con 112 | conN = conE $ constructorName $ NE.last cons 113 | 114 | pickCon :: Q Exp 115 | pickCon = case bf of 116 | MinBound -> con1 117 | MaxBound -> conN 118 | 119 | pickConApp :: Q Exp 120 | pickConApp = appsE 121 | $ pickCon 122 | : map varE (replicate (conArity con) (boundedFunName bf)) 123 | 124 | ------------------------------------------------------------------------------- 125 | -- Class-specific constants 126 | ------------------------------------------------------------------------------- 127 | 128 | -- There's only one Bounded variant! 129 | data BoundedClass = BoundedClass 130 | 131 | instance ClassRep BoundedClass where 132 | arity _ = 0 133 | 134 | allowExQuant _ = True 135 | 136 | fullClassName _ = boundedTypeName 137 | 138 | classConstraint _ 0 = Just $ boundedTypeName 139 | classConstraint _ _ = Nothing 140 | 141 | -- | A representation of which function is being generated. 142 | data BoundedFun = MinBound | MaxBound 143 | 144 | boundedFunName :: BoundedFun -> Name 145 | boundedFunName MinBound = minBoundValName 146 | boundedFunName MaxBound = maxBoundValName 147 | -------------------------------------------------------------------------------- /tests/Types/ReadShow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE MagicHash #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | {-| 9 | Module: Types.ReadShow 10 | Copyright: (C) 2015-2017 Ryan Scott 11 | License: BSD-style (see the file LICENSE) 12 | Maintainer: Ryan Scott 13 | Portability: Template Haskell 14 | 15 | Shared datatypes between "ReadSpec" and "ShowSpec". 16 | -} 17 | module Types.ReadShow where 18 | 19 | import Data.Deriving 20 | 21 | import Text.Read (Read(..), readListPrecDefault) 22 | 23 | ------------------------------------------------------------------------------- 24 | 25 | -- Plain data types 26 | 27 | infixl 4 :@: 28 | data TyCon1 a b = TyConPrefix { tc1 :: a, tc2 :: b } 29 | | (:@:) { tc3 :: b, (##) :: a } 30 | 31 | infixl 3 :!!: 32 | infix 4 :@@: 33 | infixr 5 `TyConPlain` 34 | infixr 6 `TyConFakeInfix` 35 | data TyConPlain a b = (:!!:) a b 36 | | a :@@: b 37 | | a `TyConPlain` b 38 | | TyConFakeInfix a b 39 | 40 | data TyConGADT a b where 41 | (:.) :: c -> d -> TyConGADT c d 42 | (:..) :: e -> f -> TyConGADT e f 43 | (:...) :: g -> h -> Int -> TyConGADT g h 44 | (:....) :: { tcg1 :: i, tcg2 :: j } -> TyConGADT i j 45 | 46 | data TyConWrap f g h a = TyConWrap1 (f a) 47 | | TyConWrap2 (f (g a)) 48 | | TyConWrap3 (f (g (h a))) 49 | 50 | data TC# a b = MkTC1# a b 51 | | MkTC2# { getTC2# :: b, (#~#) :: a } 52 | | a `MkTC3#` b 53 | 54 | -- Data families 55 | 56 | data family TyFamily1 y z :: * 57 | 58 | infixl 4 :!: 59 | data instance TyFamily1 a b = TyFamilyPrefix { tf1 :: a, tf2 :: b } 60 | | (:!:) { tf3 :: b, (###) :: a } 61 | 62 | data family TyFamilyPlain y z :: * 63 | 64 | infixl 3 :#: 65 | infix 4 :$: 66 | infixr 5 `TyFamilyPlain` 67 | infixr 6 `TyFamilyFakeInfix` 68 | data instance TyFamilyPlain a b = (:#:) a b 69 | | a :$: b 70 | | a `TyFamilyPlain` b 71 | | TyFamilyFakeInfix a b 72 | 73 | 74 | data family TyFamilyGADT y z :: * 75 | 76 | infixr 1 :*, :***, :**** 77 | data instance TyFamilyGADT a b where 78 | (:*) :: c -> d -> TyFamilyGADT c d 79 | (:**) :: e -> f -> TyFamilyGADT e f 80 | (:***) :: g -> h -> Int -> TyFamilyGADT g h 81 | (:****) :: { tfg1 :: i, tfg2 :: j } -> TyFamilyGADT i j 82 | 83 | data family TyFamilyWrap (w :: * -> *) (x :: * -> *) (y :: * -> *) z :: * 84 | 85 | data instance TyFamilyWrap f g h a = TyFamilyWrap1 (f a) 86 | | TyFamilyWrap2 (f (g a)) 87 | | TyFamilyWrap3 (f (g (h a))) 88 | 89 | data family TF# y z :: * 90 | 91 | data instance TF# a b = MkTF1# a b 92 | | MkTF2# { getTF2# :: b, (#~~#) :: a } 93 | | a `MkTF3#` b 94 | 95 | ------------------------------------------------------------------------------- 96 | 97 | -- Plain data types 98 | 99 | $(deriveRead ''TyCon1) 100 | $(deriveRead ''TyConPlain) 101 | $(deriveRead ''TyConGADT) 102 | instance (Read (f a), Read (f (g a)), Read (f (g (h a)))) 103 | => Read (TyConWrap f g h a) where 104 | readPrec = $(makeReadPrec ''TyConWrap) 105 | readListPrec = readListPrecDefault 106 | $(deriveRead ''TC#) 107 | 108 | $(deriveRead1 ''TyCon1) 109 | $(deriveRead1 ''TyConPlain) 110 | $(deriveRead1 ''TyConGADT) 111 | $(deriveRead1 ''TyConWrap) 112 | $(deriveRead1 ''TC#) 113 | 114 | $(deriveShow ''TyCon1) 115 | $(deriveShow ''TyConPlain) 116 | $(deriveShow ''TyConGADT) 117 | instance (Show (f a), Show (f (g a)), Show (f (g (h a)))) 118 | => Show (TyConWrap f g h a) where 119 | showsPrec = $(makeShowsPrec ''TyConWrap) 120 | show = $(makeShow ''TyConWrap) 121 | showList = $(makeShowList ''TyConWrap) 122 | $(deriveShow ''TC#) 123 | 124 | $(deriveShow1 ''TyCon1) 125 | $(deriveShow1 ''TyConPlain) 126 | $(deriveShow1 ''TyConGADT) 127 | $(deriveShow1 ''TyConWrap) 128 | $(deriveShow1 ''TC#) 129 | 130 | $(deriveRead2 ''TyCon1) 131 | $(deriveRead2 ''TyConPlain) 132 | $(deriveRead2 ''TyConGADT) 133 | $(deriveRead2 ''TC#) 134 | 135 | $(deriveShow2 ''TyCon1) 136 | $(deriveShow2 ''TyConPlain) 137 | $(deriveShow2 ''TyConGADT) 138 | $(deriveShow2 ''TC#) 139 | 140 | -- Data families 141 | 142 | $(deriveRead 'TyFamilyPrefix) 143 | $(deriveRead '(:#:)) 144 | $(deriveRead '(:*)) 145 | instance (Read (f a), Read (f (g a)), Read (f (g (h a)))) 146 | => Read (TyFamilyWrap f g h a) where 147 | readsPrec = $(makeReadsPrec 'TyFamilyWrap1) 148 | $(deriveRead 'MkTF1#) 149 | 150 | $(deriveRead1 '(:!:)) 151 | $(deriveRead1 '(:$:)) 152 | $(deriveRead1 '(:**)) 153 | $(deriveRead1 'TyFamilyWrap2) 154 | $(deriveRead1 'MkTF2#) 155 | 156 | $(deriveShow 'TyFamilyPrefix) 157 | $(deriveShow '(:#:)) 158 | $(deriveShow '(:*)) 159 | instance (Show (f a), Show (f (g a)), Show (f (g (h a)))) 160 | => Show (TyFamilyWrap f g h a) where 161 | showsPrec = $(makeShowsPrec 'TyFamilyWrap1) 162 | show = $(makeShow 'TyFamilyWrap1) 163 | showList = $(makeShowList 'TyFamilyWrap1) 164 | $(deriveShow 'MkTF3#) 165 | 166 | $(deriveShow1 '(:!:)) 167 | $(deriveShow1 '(:$:)) 168 | $(deriveShow1 '(:**)) 169 | $(deriveShow1 'TyFamilyWrap2) 170 | $(deriveShow1 'MkTF1#) 171 | 172 | $(deriveRead2 'TyFamilyPrefix) 173 | $(deriveRead2 'TyFamilyPlain) 174 | $(deriveRead2 '(:***)) 175 | $(deriveRead2 'MkTF2#) 176 | 177 | $(deriveShow2 'TyFamilyPrefix) 178 | $(deriveShow2 'TyFamilyPlain) 179 | $(deriveShow2 '(:***)) 180 | $(deriveShow2 'MkTF3#) 181 | -------------------------------------------------------------------------------- /tests/Types/EqOrd.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE MagicHash #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | 10 | {-| 11 | Module: Types.EqOrd 12 | Copyright: (C) 2015-2017 Ryan Scott 13 | License: BSD-style (see the file LICENSE) 14 | Maintainer: Ryan Scott 15 | Portability: Template Haskell 16 | 17 | Shared datatypes between "EqSpec" and "OrdSpec". 18 | -} 19 | module Types.EqOrd where 20 | 21 | import Data.Deriving 22 | 23 | import GHC.Exts ( Addr#, Char#, Double#, Float#, Int#, Word# 24 | #if MIN_VERSION_base(4,13,0) 25 | , Int8#, Int16#, Word8#, Word16# 26 | #endif 27 | #if MIN_VERSION_base(4,16,0) 28 | , Int32#, Word32# 29 | #endif 30 | ) 31 | 32 | -- Plain data types 33 | 34 | data TyCon1 a m = 35 | TyCon1A a 36 | | TyCon1B 37 | | TyCon1C 38 | | TyCon1D 39 | | TyCon1E 40 | | TyCon1F 41 | | TyCon1G 42 | | TyCon1H 43 | | TyCon1I 44 | | TyCon1J 45 | | TyCon1K 46 | | TyCon1L 47 | | TyCon1M m 48 | 49 | data TyCon# a b = TyCon# { 50 | tcA :: a 51 | , tcB :: b 52 | , tcAddr# :: Addr# 53 | , tcInt# :: Int# 54 | , tcFloat# :: Float# 55 | , tcDouble# :: Double# 56 | , tcChar# :: Char# 57 | , tcWord# :: Word# 58 | #if MIN_VERSION_base(4,13,0) 59 | , tcInt8# :: Int8# 60 | , tcInt16# :: Int16# 61 | , tcWord8# :: Word8# 62 | , tcWord16# :: Word16# 63 | #endif 64 | #if MIN_VERSION_base(4,16,0) 65 | , tcInt32# :: Int32# 66 | , tcWord32# :: Word32# 67 | #endif 68 | } 69 | 70 | data TyCon2 a b c d where 71 | TyConClassConstraints :: (Show m, Show n, Show o, Show p) 72 | => m -> n -> o -> p 73 | -> TyCon2 m n o p 74 | 75 | TyConEqualityConstraints :: (e ~ g, f ~ h, e ~ f) 76 | => e -> f -> g -> h 77 | -> TyCon2 e f g h 78 | 79 | TyConTypeRefinement1, 80 | TyConTypeRefinement2 :: Int -> z 81 | -> TyCon2 Int Int z z 82 | 83 | data TyConWrap f g h a = TyConWrap1 (f a) 84 | | TyConWrap2 (f (g a)) 85 | | TyConWrap3 (f (g (h a))) 86 | 87 | data Empty a b 88 | 89 | data TyConNullary a b 90 | = TyConNullary1 91 | | TyConNullary2 92 | | TyConNullary3 93 | 94 | -- Data families 95 | 96 | data family TyFamily1 y z :: * 97 | 98 | data instance TyFamily1 a m = 99 | TyFamily1A a 100 | | TyFamily1B 101 | | TyFamily1C 102 | | TyFamily1D 103 | | TyFamily1E 104 | | TyFamily1F 105 | | TyFamily1G 106 | | TyFamily1H 107 | | TyFamily1I 108 | | TyFamily1J 109 | | TyFamily1K 110 | | TyFamily1L 111 | | TyFamily1M m 112 | 113 | data family TyFamily# y z :: * 114 | 115 | data instance TyFamily# a b = TyFamily# { 116 | tfA :: a 117 | , tfB :: b 118 | , tfInt# :: Int# 119 | , tfFloat# :: Float# 120 | , tfDouble# :: Double# 121 | , tfChar# :: Char# 122 | , tfWord# :: Word# 123 | #if MIN_VERSION_base(4,13,0) 124 | , tfInt8# :: Int8# 125 | , tfInt16# :: Int16# 126 | , tfWord8# :: Word8# 127 | , tfWord16# :: Word16# 128 | #endif 129 | #if MIN_VERSION_base(4,16,0) 130 | , tfInt32# :: Int32# 131 | , tfWord32# :: Word32# 132 | #endif 133 | } 134 | 135 | data family TyFamily2 w x y z :: * 136 | 137 | data instance TyFamily2 a b c d where 138 | TyFamilyClassConstraints :: (Show m, Show n, Show o, Show p) 139 | => m -> n -> o -> p 140 | -> TyFamily2 m n o p 141 | 142 | TyFamilyEqualityConstraints :: (e ~ g, f ~ h, e ~ f) 143 | => e -> f -> g -> h 144 | -> TyFamily2 e f g h 145 | 146 | TyFamilyTypeRefinement1, 147 | TyFamilyTypeRefinement2 :: Int -> z 148 | -> TyFamily2 Int Int z z 149 | 150 | data family TyFamilyWrap (w :: * -> *) (x :: * -> *) (y :: * -> *) z :: * 151 | 152 | data instance TyFamilyWrap f g h a = TyFamilyWrap1 (f a) 153 | | TyFamilyWrap2 (f (g a)) 154 | | TyFamilyWrap3 (f (g (h a))) 155 | 156 | data family TyFamilyNullary x y :: * 157 | 158 | data instance TyFamilyNullary a b 159 | = TyFamilyNullary1 160 | | TyFamilyNullary2 161 | | TyFamilyNullary3 162 | 163 | ------------------------------------------------------------------------------- 164 | 165 | -- Plain data types 166 | 167 | $(deriveEq ''TyCon1) 168 | $(deriveEq ''TyCon#) 169 | $(deriveEq ''TyCon2) 170 | instance (Eq (f a), Eq (f (g a)), Eq (f (g (h a)))) 171 | => Eq (TyConWrap f g h a) where 172 | (==) = $(makeEq ''TyConWrap) 173 | (/=) = $(makeNotEq ''TyConWrap) 174 | $(deriveEq ''Empty) 175 | $(deriveEq ''TyConNullary) 176 | 177 | $(deriveEq1 ''TyCon1) 178 | $(deriveEq1 ''TyCon#) 179 | $(deriveEq1 ''TyCon2) 180 | $(deriveEq1 ''TyConWrap) 181 | $(deriveEq1 ''Empty) 182 | $(deriveEq1 ''TyConNullary) 183 | 184 | $(deriveOrd ''TyCon1) 185 | $(deriveOrd ''TyCon#) 186 | $(deriveOrd ''TyCon2) 187 | instance (Ord (f a), Ord (f (g a)), Ord (f (g (h a)))) 188 | => Ord (TyConWrap f g h a) where 189 | compare = $(makeCompare ''TyConWrap) 190 | (>) = $(makeLT ''TyConWrap) 191 | (>=) = $(makeLE ''TyConWrap) 192 | (<) = $(makeGT ''TyConWrap) 193 | (<=) = $(makeGE ''TyConWrap) 194 | max = $(makeMax ''TyConWrap) 195 | min = $(makeMin ''TyConWrap) 196 | $(deriveOrd ''Empty) 197 | $(deriveOrd ''TyConNullary) 198 | 199 | $(deriveOrd1 ''TyCon1) 200 | $(deriveOrd1 ''TyCon#) 201 | $(deriveOrd1 ''TyCon2) 202 | $(deriveOrd1 ''TyConWrap) 203 | $(deriveOrd1 ''Empty) 204 | $(deriveOrd1 ''TyConNullary) 205 | 206 | $(deriveEq2 ''TyCon1) 207 | $(deriveEq2 ''TyCon#) 208 | $(deriveEq2 ''TyCon2) 209 | $(deriveEq2 ''Empty) 210 | $(deriveEq2 ''TyConNullary) 211 | 212 | $(deriveOrd2 ''TyCon1) 213 | $(deriveOrd2 ''TyCon#) 214 | $(deriveOrd2 ''TyCon2) 215 | $(deriveOrd2 ''Empty) 216 | $(deriveOrd2 ''TyConNullary) 217 | 218 | -- Data families 219 | 220 | $(deriveEq 'TyFamily1A) 221 | $(deriveEq 'TyFamily#) 222 | $(deriveEq 'TyFamilyClassConstraints) 223 | instance (Eq (f a), Eq (f (g a)), Eq (f (g (h a)))) 224 | => Eq (TyFamilyWrap f g h a) where 225 | (==) = $(makeEq 'TyFamilyWrap1) 226 | (/=) = $(makeNotEq 'TyFamilyWrap1) 227 | $(deriveEq 'TyFamilyNullary1) 228 | 229 | $(deriveEq1 'TyFamily1B) 230 | $(deriveEq1 'TyFamily#) 231 | $(deriveEq1 'TyFamilyEqualityConstraints) 232 | $(deriveEq1 'TyFamilyNullary1) 233 | 234 | $(deriveOrd 'TyFamily1A) 235 | $(deriveOrd 'TyFamily#) 236 | $(deriveOrd 'TyFamilyClassConstraints) 237 | $(deriveEq1 'TyFamilyWrap2) 238 | instance (Ord (f a), Ord (f (g a)), Ord (f (g (h a)))) 239 | => Ord (TyFamilyWrap f g h a) where 240 | compare = $(makeCompare 'TyFamilyWrap1) 241 | (>) = $(makeLT 'TyFamilyWrap1) 242 | (>=) = $(makeLE 'TyFamilyWrap1) 243 | (<) = $(makeGT 'TyFamilyWrap1) 244 | (<=) = $(makeGE 'TyFamilyWrap1) 245 | max = $(makeMax 'TyFamilyWrap1) 246 | min = $(makeMin 'TyFamilyWrap1) 247 | $(deriveOrd 'TyFamilyNullary1) 248 | 249 | $(deriveOrd1 'TyFamily1B) 250 | $(deriveOrd1 'TyFamily#) 251 | $(deriveOrd1 'TyFamilyEqualityConstraints) 252 | $(deriveOrd1 'TyFamilyWrap2) 253 | $(deriveOrd1 'TyFamilyNullary1) 254 | 255 | $(deriveEq2 'TyFamily1C) 256 | $(deriveEq2 'TyFamily#) 257 | $(deriveEq2 'TyFamilyTypeRefinement1) 258 | $(deriveEq2 'TyFamilyNullary1) 259 | 260 | $(deriveOrd2 'TyFamily1C) 261 | $(deriveOrd2 'TyFamily#) 262 | $(deriveOrd2 'TyFamilyTypeRefinement1) 263 | $(deriveOrd2 'TyFamilyNullary1) 264 | -------------------------------------------------------------------------------- /deriving-compat.cabal: -------------------------------------------------------------------------------- 1 | name: deriving-compat 2 | version: 0.6.7 3 | synopsis: Backports of GHC deriving extensions 4 | description: @deriving-compat@ provides Template Haskell functions that 5 | mimic @deriving@ extensions that were introduced or modified 6 | in recent versions of GHC. Currently, the following 7 | typeclasses/extensions are covered: 8 | . 9 | * Deriving @Bounded@ 10 | . 11 | * Deriving @Enum@ 12 | . 13 | * Deriving @Ix@ 14 | . 15 | * Deriving @Eq@ 16 | . 17 | * Deriving @Ord@ 18 | . 19 | * Deriving @Read@ 20 | . 21 | * Deriving @Show@ 22 | . 23 | * @DeriveFoldable@ 24 | . 25 | * @DeriveFunctor@ 26 | . 27 | * @DeriveTraversable@ 28 | . 29 | * @GeneralizedNewtypeDeriving@ (with GHC 8.2 or later) 30 | . 31 | * @DerivingVia@ (with GHC 8.2 or later) 32 | . 33 | See the "Data.Deriving" module for a full list of backported changes. 34 | . 35 | In addition, @deriving-compat@ also provides some additional 36 | @deriving@ functionality that has not yet been merged into 37 | upstream GHC. Aside from the GHC @deriving@ extensions 38 | mentioned above, @deriving-compat@ also permits deriving 39 | instances of classes in the @Data.Functor.Classes@ module, 40 | covering the @Eq1@, @Eq2@, @Ord1@, @Ord2@, @Read1@, 41 | @Read2@, @Show1@, and @Show2@ classes. This extra 42 | functionality is outside of the main scope of 43 | @deriving-compat@, as it does not backport extensions that 44 | exist in today's GHC. Nevertheless, the underlying Template 45 | Haskell machinery needed to derive @Eq@ and friends 46 | extends very naturally to @Eq1@ and friends, so this extra 47 | functionality is included in @deriving-compat@ as a 48 | convenience. 49 | . 50 | Note that some recent GHC typeclasses/extensions are not covered by this package: 51 | . 52 | * @DeriveDataTypeable@ 53 | . 54 | * @DeriveGeneric@, which was introducted in GHC 7.2 for deriving 55 | @Generic@ instances, and modified in GHC 7.6 to allow derivation 56 | of @Generic1@ instances. Use @Generics.Deriving.TH@ from 57 | @@ 58 | to derive @Generic(1)@ using Template Haskell. 59 | . 60 | * @DeriveLift@, which was introduced in GHC 8.0 for deriving 61 | @Lift@ instances. Use @Language.Haskell.TH.Lift@ from 62 | @@ 63 | to derive @Lift@ using Template Haskell. 64 | . 65 | * The @Bifunctor@ typeclass, which was introduced in GHC 7.10, 66 | as well as the @Bifoldable@ and @Bitraversable@ typeclasses, which 67 | were introduced in GHC 8.2. Use @Data.Bifunctor.TH@ from 68 | @@ 69 | to derive these typeclasses using Template Haskell. 70 | homepage: https://github.com/haskell-compat/deriving-compat 71 | bug-reports: https://github.com/haskell-compat/deriving-compat/issues 72 | license: BSD3 73 | license-file: LICENSE 74 | author: Ryan Scott 75 | maintainer: Ryan Scott 76 | stability: Experimental 77 | copyright: (C) 2015-2017 Ryan Scott 78 | category: Compatibility 79 | build-type: Simple 80 | extra-source-files: CHANGELOG.md, README.md 81 | tested-with: GHC == 8.0.2 82 | , GHC == 8.2.2 83 | , GHC == 8.4.4 84 | , GHC == 8.6.5 85 | , GHC == 8.8.4 86 | , GHC == 8.10.7 87 | , GHC == 9.0.2 88 | , GHC == 9.2.8 89 | , GHC == 9.4.8 90 | , GHC == 9.6.6 91 | , GHC == 9.8.4 92 | , GHC == 9.10.1 93 | , GHC == 9.12.1 94 | cabal-version: >=1.10 95 | 96 | source-repository head 97 | type: git 98 | location: https://github.com/haskell-compat/deriving-compat 99 | 100 | library 101 | exposed-modules: Data.Deriving 102 | Data.Deriving.Internal 103 | 104 | Data.Bounded.Deriving 105 | Data.Bounded.Deriving.Internal 106 | Data.Deriving.Via 107 | Data.Deriving.Via.Internal 108 | Data.Enum.Deriving 109 | Data.Enum.Deriving.Internal 110 | Data.Eq.Deriving 111 | Data.Eq.Deriving.Internal 112 | Data.Foldable.Deriving 113 | Data.Functor.Deriving.Internal 114 | Data.Functor.Deriving 115 | Data.Ix.Deriving 116 | Data.Ix.Deriving.Internal 117 | Data.Ord.Deriving 118 | Data.Ord.Deriving.Internal 119 | Data.Traversable.Deriving 120 | Text.Read.Deriving 121 | Text.Read.Deriving.Internal 122 | Text.Show.Deriving 123 | Text.Show.Deriving.Internal 124 | build-depends: base >= 4.9 && < 5 125 | , containers >= 0.1 && < 0.9 126 | , ghc-boot-th 127 | , ghc-prim 128 | , template-haskell >= 2.11 && < 2.24 129 | , th-abstraction >= 0.5 && < 0.8 130 | , transformers >= 0.5 && < 0.7 131 | , transformers-compat >= 0.5 132 | 133 | hs-source-dirs: src 134 | default-language: Haskell2010 135 | ghc-options: -Wall 136 | 137 | test-suite spec 138 | type: exitcode-stdio-1.0 139 | main-is: Spec.hs 140 | other-modules: BoundedEnumIxSpec 141 | DerivingViaSpec 142 | EqSpec 143 | FunctorSpec 144 | OrdSpec 145 | ReadSpec 146 | ShowSpec 147 | GH6Spec 148 | GH24Spec 149 | GH27Spec 150 | GH31Spec 151 | 152 | Types.EqOrd 153 | Types.ReadShow 154 | build-depends: base >= 4.9 && < 5 155 | , base-orphans >= 0.5 && < 1 156 | , deriving-compat 157 | , hspec >= 1.8 158 | , QuickCheck >= 2 && < 3 159 | , tagged >= 0.7 && < 1 160 | , template-haskell >= 2.11 && < 2.24 161 | , transformers >= 0.5 && < 0.7 162 | , transformers-compat >= 0.5 163 | , void >= 0.5.10 && < 1 164 | build-tool-depends: hspec-discover:hspec-discover >= 1.8 165 | 166 | hs-source-dirs: tests 167 | default-language: Haskell2010 168 | ghc-options: -Wall -threaded -rtsopts 169 | if impl(ghc >= 8.6) 170 | ghc-options: -Wno-star-is-type 171 | if impl(ghc >= 9.0) 172 | ghc-options: -fenable-th-splice-warnings 173 | -------------------------------------------------------------------------------- /src/Data/Ix/Deriving/Internal.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Data.Ix.Deriving.Internal 3 | Copyright: (C) 2015-2017 Ryan Scott 4 | License: BSD-style (see the file LICENSE) 5 | Maintainer: Ryan Scott 6 | Portability: Template Haskell 7 | 8 | Exports functions to mechanically derive 'Ix' instances. 9 | 10 | Note: this is an internal module, and as such, the API presented here is not 11 | guaranteed to be stable, even between minor releases of this library. 12 | -} 13 | module Data.Ix.Deriving.Internal ( 14 | -- * 'Ix' 15 | deriveIx 16 | , makeRange 17 | , makeUnsafeIndex 18 | , makeInRange 19 | ) where 20 | 21 | import Data.Deriving.Internal 22 | import Data.List.NonEmpty (NonEmpty(..)) 23 | 24 | import Language.Haskell.TH.Datatype 25 | import Language.Haskell.TH.Lib 26 | import Language.Haskell.TH.Syntax 27 | 28 | ------------------------------------------------------------------------------- 29 | -- Code generation 30 | ------------------------------------------------------------------------------- 31 | 32 | -- | Generates a 'Ix' instance declaration for the given data type or data 33 | -- family instance. 34 | deriveIx :: Name -> Q [Dec] 35 | deriveIx name = do 36 | info <- reifyDatatype name 37 | case info of 38 | DatatypeInfo { datatypeContext = ctxt 39 | , datatypeName = parentName 40 | , datatypeInstTypes = instTypes 41 | , datatypeVariant = variant 42 | , datatypeCons = cons 43 | } -> do 44 | (instanceCxt, instanceType) 45 | <- buildTypeInstance IxClass parentName ctxt instTypes variant 46 | (:[]) `fmap` instanceD (return instanceCxt) 47 | (return instanceType) 48 | (ixFunDecs parentName instanceType cons) 49 | 50 | -- | Generates a lambda expression which behaves like 'range' (without 51 | -- requiring an 'Ix' instance). 52 | makeRange :: Name -> Q Exp 53 | makeRange = makeIxFun Range 54 | 55 | -- | Generates a lambda expression which behaves like 'unsafeIndex' (without 56 | -- requiring an 'Ix' instance). 57 | makeUnsafeIndex :: Name -> Q Exp 58 | makeUnsafeIndex = makeIxFun UnsafeIndex 59 | 60 | -- | Generates a lambda expression which behaves like 'inRange' (without 61 | -- requiring an 'Ix' instance). 62 | makeInRange :: Name -> Q Exp 63 | makeInRange = makeIxFun InRange 64 | 65 | -- | Generates method declarations for an 'Ix' instance. 66 | ixFunDecs :: Name -> Type -> [ConstructorInfo] -> [Q Dec] 67 | ixFunDecs tyName ty cons = 68 | [ makeFunD Range 69 | , makeFunD UnsafeIndex 70 | , makeFunD InRange 71 | ] 72 | where 73 | makeFunD :: IxFun -> Q Dec 74 | makeFunD ixf = 75 | funD (ixFunName ixf) 76 | [ clause [] 77 | (normalB $ makeIxFunForCons ixf tyName ty cons) 78 | [] 79 | ] 80 | 81 | -- | Generates a lambda expression which behaves like the IxFun argument. 82 | makeIxFun :: IxFun -> Name -> Q Exp 83 | makeIxFun ixf name = do 84 | info <- reifyDatatype name 85 | case info of 86 | DatatypeInfo { datatypeContext = ctxt 87 | , datatypeName = parentName 88 | , datatypeInstTypes = instTypes 89 | , datatypeVariant = variant 90 | , datatypeCons = cons 91 | } -> do 92 | (_, instanceType) <- buildTypeInstance IxClass parentName ctxt instTypes variant 93 | makeIxFunForCons ixf parentName instanceType cons 94 | 95 | -- | Generates a lambda expression for an 'Ix' method for the 96 | -- given constructors. All constructors must be from the same type. 97 | makeIxFunForCons :: IxFun -> Name -> Type -> [ConstructorInfo] -> Q Exp 98 | makeIxFunForCons _ _ _ [] = noConstructorsError 99 | makeIxFunForCons ixf tyName ty (con:cons') 100 | | not (isProduct || isEnumeration) 101 | = enumerationOrProductError $ nameBase tyName 102 | | isEnumeration 103 | = case ixf of 104 | Range -> do 105 | a <- newName "a" 106 | aHash <- newName "a#" 107 | b <- newName "b" 108 | bHash <- newName "b#" 109 | lamE [tupP [varP a, varP b]] $ 110 | untagExpr [(a, aHash)] $ 111 | untagExpr [(b, bHash)] $ 112 | appE (varE mapValName `appE` tag2Con) $ 113 | enumFromToExpr (conE iHashDataName `appE` varE aHash) 114 | (conE iHashDataName `appE` varE bHash) 115 | 116 | UnsafeIndex -> do 117 | a <- newName "a" 118 | aHash <- newName "a#" 119 | c <- newName "c" 120 | cHash <- newName "c#" 121 | dHash <- newName "d#" 122 | lamE [tupP [varP a, wildP], varP c] $ 123 | untagExpr [(a, aHash)] $ 124 | untagExpr [(c, cHash)] $ 125 | caseE (infixApp (varE cHash) (varE minusIntHashValName) (varE aHash)) 126 | [ match (varP dHash) 127 | (normalB $ conE iHashDataName `appE` varE dHash) 128 | [] 129 | ] 130 | 131 | InRange -> do 132 | a <- newName "a" 133 | aHash <- newName "a#" 134 | b <- newName "b" 135 | bHash <- newName "b#" 136 | c <- newName "c" 137 | cHash <- newName "c#" 138 | lamE [tupP [varP a, varP b], varP c] $ 139 | untagExpr [(a, aHash)] $ 140 | untagExpr [(b, bHash)] $ 141 | untagExpr [(c, cHash)] $ 142 | appsE [ varE andValName 143 | , primOpAppExpr (varE cHash) geIntHashValName (varE aHash) 144 | , primOpAppExpr (varE cHash) leIntHashValName (varE bHash) 145 | ] 146 | 147 | | otherwise -- It's a product type 148 | = do let conName :: Name 149 | conName = constructorName con 150 | 151 | conFields :: Int 152 | conFields = conArity con 153 | 154 | as <- newNameList "a" conFields 155 | bs <- newNameList "b" conFields 156 | cs <- newNameList "c" conFields 157 | 158 | let conPat :: [Name] -> Q Pat 159 | conPat = conP conName . map varP 160 | 161 | conExpr :: Q Exp 162 | conExpr = appsE $ conE conName : map varE cs 163 | 164 | case ixf of 165 | Range -> lamE [tupP [conPat as, conPat bs]] $ 166 | compE $ stmts ++ [noBindS conExpr] 167 | where 168 | stmts :: [Q Stmt] 169 | stmts = zipWith3 mkQual as bs cs 170 | 171 | mkQual :: Name -> Name -> Name -> Q Stmt 172 | mkQual a b c = bindS (varP c) $ 173 | varE rangeValName `appE` tupE [varE a, varE b] 174 | 175 | UnsafeIndex -> lamE [tupP [conPat as, conPat bs], conPat cs] $ 176 | mkUnsafeIndex $ reverse $ zip3 as bs cs 177 | where 178 | mkUnsafeIndex :: [(Name, Name, Name)] -> Q Exp 179 | mkUnsafeIndex [] = integerE 0 180 | mkUnsafeIndex [(l, u, i)] = mkOne l u i 181 | mkUnsafeIndex ((l, u, i):rest) = 182 | infixApp (mkOne l u i) 183 | (varE plusValName) 184 | (infixApp (varE unsafeRangeSizeValName 185 | `appE` tupE [varE l, varE u]) 186 | (varE timesValName) 187 | (mkUnsafeIndex rest)) 188 | 189 | mkOne :: Name -> Name -> Name -> Q Exp 190 | mkOne l u i = varE unsafeIndexValName `appE` tupE [varE l, varE u] 191 | `appE` varE i 192 | 193 | InRange -> lamE [tupP [conPat as, conPat bs], conPat cs] $ 194 | if conFields == 0 195 | then conE trueDataName 196 | else foldl1 andExpr $ zipWith3 mkInRange as bs cs 197 | where 198 | andExpr :: Q Exp -> Q Exp -> Q Exp 199 | andExpr a b = infixApp a (varE andValName) b 200 | 201 | mkInRange :: Name -> Name -> Name -> Q Exp 202 | mkInRange a b c = varE inRangeValName `appE` tupE [varE a, varE b] 203 | `appE` varE c 204 | where 205 | cons :: NonEmpty ConstructorInfo 206 | cons = con :| cons' 207 | 208 | isProduct, isEnumeration :: Bool 209 | isProduct = isProductType cons 210 | isEnumeration = isEnumerationType cons 211 | 212 | tag2Con :: Q Exp 213 | tag2Con = tag2ConExpr $ removeClassApp ty 214 | 215 | ------------------------------------------------------------------------------- 216 | -- Class-specific constants 217 | ------------------------------------------------------------------------------- 218 | 219 | -- There's only one Ix variant! 220 | data IxClass = IxClass 221 | 222 | instance ClassRep IxClass where 223 | arity _ = 0 224 | 225 | allowExQuant _ = True 226 | 227 | fullClassName _ = ixTypeName 228 | 229 | classConstraint _ 0 = Just ixTypeName 230 | classConstraint _ _ = Nothing 231 | 232 | -- | A representation of which function is being generated. 233 | data IxFun = Range 234 | | UnsafeIndex 235 | | InRange 236 | deriving Show 237 | 238 | ixFunName :: IxFun -> Name 239 | ixFunName Range = rangeValName 240 | ixFunName UnsafeIndex = unsafeIndexValName 241 | ixFunName InRange = inRangeValName 242 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ### 0.6.7 [2024.12.05] 2 | * Drop support for pre-8.0 versions of GHC. 3 | 4 | ### 0.6.6 [2024.03.19] 5 | * Support building with `template-haskell-2.22.*` (GHC 9.10). 6 | 7 | ### 0.6.5 [2023.08.06] 8 | * When generating `Show(1)(2)` instances with `Text.Show.Deriving` using GHC 9.8 9 | or later, data types that have fields of type `Int{8,16,32,64}#` or 10 | `Word{8,16,32,64}#` will be printed using extended literal syntax, mirroring 11 | corresponding changes introduced in GHC 9.8 (see 12 | https://github.com/ghc-proposals/ghc-proposals/pull/596). 13 | 14 | ### 0.6.4 [2023.08.06] 15 | * Support building with `template-haskell-2.21.*` (GHC 9.8). 16 | * The Template Haskell machinery now uses `TemplateHaskellQuotes` when building 17 | with GHC 8.0+ instead of manually constructing each Template Haskell `Name`. 18 | A consequence of this is that `deriving-compat` will now build with GHC 9.8, 19 | as `TemplateHaskellQuotes` abstracts over some internal Template Haskell 20 | changes introduced in 9.8. 21 | 22 | ### 0.6.3 [2023.02.27] 23 | * Support `th-abstraction-0.5.*`. 24 | 25 | ### 0.6.2 [2022.12.07] 26 | * Make the test suite build with GHC 9.6 or later. 27 | 28 | ### 0.6.1 [2022.05.07] 29 | * Backport [GHC!6955](https://gitlab.haskell.org/ghc/ghc/-/merge_requests/6955), 30 | which makes derived `Eq` instances check data constructor tags, which can 31 | improve runtime performance for data types with nullary constructors. 32 | * Allow building the test suite with `transformers-0.6.*`. 33 | 34 | ## 0.6 [2021.08.29] 35 | * Allow building with `template-haskell-2.18.0.0` (GHC 9.2). 36 | * Using `deriveEnum` and `deriveIx` on poly-kinded data family instances may 37 | now require the use of the `TypeInType` extension if using GHC 8.0, 8.2, or 38 | 8.4. (On later versions of GHC, `TypeInType`'s functionality has been folded 39 | into `PolyKinds`.) 40 | * Support deriving `Eq`, `Ord`, and `Show` instances for data types with fields 41 | of type `Int32#` or `Word32#` on GHC 9.2 or later. 42 | * `deriveVia` now instantiates "floating" `via` type variables (i.e., type 43 | variables mentioned in the `via` type that are not mentioned in the instance 44 | context or the first argument to `Via`) to `Any` in the generated code. As a 45 | result, `deriveVia` no longer generates code that produces `-Wunused-foralls` 46 | warnings. 47 | 48 | ### 0.5.10 [2020.09.30] 49 | * Allow building with `template-haskell-2.17.0.0` (GHC 9.0). 50 | 51 | ### 0.5.9 [2019.06.08] 52 | * Have `deriveFunctor` and `deriveFoldable` derive implementations of `(<$)` 53 | and `null`, which GHC starting doing in 8.2 and 8.4, respectively. 54 | * Fix a bug in which `deriveOrd{,1,2}` could generate incorrect code for data 55 | types with a combination of nullary and non-nullary constructors. 56 | * Fix a bug in which `deriveFunctor` would fail on sufficiently complex uses 57 | of rank-n types in constructor fields. 58 | * Fix a bug in which `deriveFunctor` and related functions would needlessly 59 | reject data types whose last type parameters appear as oversaturated 60 | arguments to a type family. 61 | 62 | ### 0.5.8 [2019.11.26] 63 | * Allow building with GHC 8.10. 64 | 65 | ### 0.5.7 [2019.08.27] 66 | * Permit `deriveVia` to use "floating" `via` type variables, such as the `a` 67 | in: 68 | 69 | ```hs 70 | deriveVia [t| forall a. Show MyInt `Via` Const Int a |] 71 | ``` 72 | 73 | ### 0.5.6 [2019.05.02] 74 | * Support deriving `Eq`, `Ord`, and `Show` instances for data types with fields 75 | of type `Int8#`, `Int16#`, `Word8#`, or `Word16#` on GHC 8.8 or later. 76 | 77 | ### 0.5.5 [2019.04.26] 78 | * Support `th-abstraction-0.3` or later. 79 | 80 | ### 0.5.4 [2019.01.21] 81 | * Expose `Internal` modules. 82 | 83 | ### 0.5.3 [2019.01.20] 84 | * Fix a bug in which `deriveEnum`/`deriveIx` would generate ill-scoped code 85 | for certain poly-kinded data types. 86 | 87 | ### 0.5.2 [2018.09.13] 88 | * Fix a bug (on GHC 8.7 and above) in which `deriveGND`/`deriveVia` would 89 | generate ill-scoped code. 90 | 91 | ### 0.5.1 [2018.07.11] 92 | * Have `deriveGND`/`deriveVia` throw an error if an incorrect number of 93 | arguments are supplied to the type class. 94 | 95 | ## 0.5 [2018.07.01] 96 | * Backport the changes to `GeneralizedNewtypeDeriving` and `DerivingVia` code 97 | generation from 98 | [Trac #15290](https://ghc.haskell.org/trac/ghc/ticket/15290). 99 | 100 | As a result, code generated by `deriveGND` or `deriveVia` now requires the 101 | `InstanceSigs` and `ScopedTypeVariables` language extensions. On the other 102 | hand, the generated code no longer requires the `ImpredicativeTypes` 103 | extension (unless any class methods use higher-rank types). 104 | * Allow building with `containers-0.6` and `template-haskell-2.14`. 105 | 106 | ### 0.4.3 [2018.06.16] 107 | * Fix a bug that caused debug-enabled GHC builds to panic when generating 108 | code from this library (see 109 | [Trac #15270](https://ghc.haskell.org/trac/ghc/ticket/15270)). 110 | The fix only affects the library's internals, so no changes are user-facing. 111 | 112 | ### 0.4.2 [2018.05.14] 113 | * Backport the fixes for GHC Trac 114 | [#14364](https://ghc.haskell.org/trac/ghc/ticket/14364) 115 | and 116 | [#14918](https://ghc.haskell.org/trac/ghc/ticket/14918), 117 | which significantly improve the compliation times of derived `Read` 118 | instances. 119 | 120 | ### 0.4.1 [2018.02.04] 121 | * Add `Data.Deriving.Via`, which allows emulating the behavior of the 122 | `GeneralizedNewtypeDeriving` and `DerivingVia` extensions. 123 | * Test suite fixes for GHC 8.4. 124 | 125 | ## 0.4 [2017.12.07] 126 | * Incorporate changes from the `EmptyDataDeriving` proposal (which is in GHC 127 | as of 8.4): 128 | * For derived `Eq` and `Ord` instances for empty data types, simply return 129 | `True` and `EQ`, respectively, without inspecting the arguments. 130 | * For derived `Read` instances for empty data types, simply return `pfail` 131 | (without `parens`). 132 | * For derived `Show` instances for empty data types, inspect the argument 133 | (instead of `error`ing). In addition, add `showEmptyCaseBehavior` to 134 | `ShowOptions`, which configures whether derived instances for empty data 135 | types should use the `EmptyCase` extension (this is disabled by default). 136 | * For derived `Functor` and `Traversable` instances for empty data 137 | types, make `fmap` and `traverse` strict in its argument. 138 | * For derived `Foldable` instances, do not error on empty data types. 139 | Instead, simply return the folded state (for `foldr`) or `mempty` (for 140 | `foldMap`), without inspecting the arguments. 141 | * Add `FFTOptions` (`Functor`/`Foldable`/`Traversable` options) to 142 | `Data.Functor.Deriving`, along with variants of existing functions that 143 | take `FFTOptions` as an argument. For now, the only configurable option is 144 | whether derived instances for empty data types should use the `EmptyCase` 145 | extension (this is disabled by default). 146 | * Backport the fix to #13328. That is, when deriving `Functor` or 147 | `Traversable` instances for data types where the last type variable is at 148 | phantom role, generated `fmap`/`traverse` implementations now use `coerce` 149 | for efficiency. 150 | * Rename `emptyCaseBehavior` from `Data.Functor.Deriving` to 151 | `fftEmptyCaseBehavior`. 152 | 153 | ### 0.3.6 [2017.04.10] 154 | * Make `deriveTraversable` use `liftA2` in derived implementations of 155 | `traverse` when possible, now that `liftA2` is a class method of 156 | `Applicative` (as of GHC 8.2) 157 | * Make `deriveShow` use `showCommaSpace`, a change introduced in GHC 8.2 158 | 159 | ### 0.3.5 [2016.12.12] 160 | * Fix bug in which derived `Ord` instances for datatypes with many constructors 161 | would fail to typecheck 162 | 163 | ### 0.3.4 [2016.10.20] 164 | * Fix bug in which infix record selectors weren't shown with parentheses in derived `Show` instances 165 | * Fix bug in which record selectors weren't parsed correctly in derived `Read` instances 166 | 167 | ### 0.3.3 [2016.09.11] 168 | * Add `Data.Bounded.Deriving`, which allows deriving `Bounded` with TH. 169 | * Add `Data.Enum.Deriving`, which allows deriving `Enum` with TH. 170 | * Add `Data.Ix.Deriving`, which allows deriving `Ix` with TH. 171 | * Fix bug in which derived `Show` instance would parenthesize the output too eagerly 172 | 173 | ### 0.3.2 174 | * Incorporate a fix to GHC Trac #10858, which will be introduced in GHC 8.2 175 | * Fix bug in which derived `Ord` instances accidentally swapped their less-than(-or-equal-to) and greater-than(-or-equal-to) methods 176 | * Fix GHC HEAD build 177 | 178 | ### 0.3.1 179 | * Allow deriving `Functor` and `Foldable` instances for datatypes containing unboxed tuples 180 | * Microoptimization in derived instances of higher-order versions of `Eq`, `Ord`, `Read`, and `Show` 181 | 182 | ## 0.3 183 | * Added `Data.Eq.Deriving`, which allows deriving `Eq`, `Eq1`, and `Eq2` with TH. 184 | * Added `Data.Ord.Deriving`, which allows deriving `Ord`, `Ord1`, and `Ord2` with TH. 185 | * Added `Data.Read.Deriving`, which allows deriving `Read`, `Read1`, and `Eq2` with TH. 186 | * Renamed `Text.Show.Deriving.Options` to `ShowOptions` so as to disambiguate it from the options datatypes in other `deriving-compat` modules. 187 | 188 | ### 0.2.2 189 | * Fixed a bug in `Text.Show.Deriving`'s treatment of unlifted types 190 | 191 | ### 0.2.1 192 | * Added `Text.Show.Deriving`, which allows deriving `Show`, `Show1`, and `Show2` with TH. 193 | 194 | ## 0.2 195 | * Added support for GHC 8.0 196 | * Added `Data.Functor.Deriving` and `Data.Traversable.Deriving`, which allow deriving `Functor` and `Traversable` with TH. 197 | * Added `Data.Deriving`, which reexports all other modules 198 | 199 | ## 0.1 200 | * Initial commit 201 | -------------------------------------------------------------------------------- /tests/BoundedEnumIxSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE KindSignatures #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | #if __GLASGOW_HASKELL__ < 806 11 | {-# LANGUAGE TypeInType #-} 12 | #endif 13 | 14 | {-| 15 | Module: BoundedEnumSpec 16 | Copyright: (C) 2015-2017 Ryan Scott 17 | License: BSD-style (see the file LICENSE) 18 | Maintainer: Ryan Scott 19 | Portability: Template Haskell 20 | 21 | @hspec@ tests for derived 'Bounded', 'Enum', and 'Ix' instances. 22 | -} 23 | module BoundedEnumIxSpec where 24 | 25 | import Data.Deriving 26 | #if __GLASGOW_HASKELL__ < 806 27 | import Data.Kind 28 | #endif 29 | 30 | import GHC.Arr (Ix(..)) 31 | 32 | import Test.Hspec 33 | 34 | ------------------------------------------------------------------------------- 35 | 36 | -- Plain data types 37 | 38 | data TyConEnum = TyConEnum1 | TyConEnum2 | TyConEnum3 39 | deriving (Eq, Ord, Show) 40 | 41 | data TyConProduct a b c = TyConProduct a b c 42 | deriving (Eq, Ord, Show) 43 | 44 | data TyConUnit (f :: k -> *) (a :: k) = TyConUnit 45 | deriving (Eq, Ord, Show) 46 | 47 | data TyConExQuant a = Show a => TyConExQuant 48 | deriving instance Eq (TyConExQuant a) 49 | deriving instance Ord (TyConExQuant a) 50 | deriving instance Show (TyConExQuant a) 51 | 52 | data TyConGADT a where 53 | TyConGADT :: Show a => a -> TyConGADT a 54 | deriving instance Eq a => Eq (TyConGADT a) 55 | deriving instance Ord a => Ord (TyConGADT a) 56 | deriving instance Show a => Show (TyConGADT a) 57 | 58 | -- Data families 59 | 60 | data family TyFamilyEnum :: * 61 | data instance TyFamilyEnum = TyFamilyEnum1 | TyFamilyEnum2 | TyFamilyEnum3 62 | deriving (Eq, Ord, Show) 63 | 64 | data family TyFamilyProduct x y z :: * 65 | data instance TyFamilyProduct a b c = TyFamilyProduct a b c 66 | deriving (Eq, Ord, Show) 67 | 68 | data family TyFamilyUnit (f :: k -> *) (a :: k) :: * 69 | data instance TyFamilyUnit f a = TyFamilyUnit 70 | deriving (Eq, Ord, Show) 71 | 72 | data family TyFamilyExQuant x :: * 73 | data instance TyFamilyExQuant a = Show a => TyFamilyExQuant 74 | deriving instance Eq (TyFamilyExQuant a) 75 | deriving instance Ord (TyFamilyExQuant a) 76 | deriving instance Show (TyFamilyExQuant a) 77 | 78 | data family TyFamilyGADT x :: * 79 | data instance TyFamilyGADT a where 80 | TyFamilyGADT :: Show a => a -> TyFamilyGADT a 81 | deriving instance Eq a => Eq (TyFamilyGADT a) 82 | deriving instance Ord a => Ord (TyFamilyGADT a) 83 | deriving instance Show a => Show (TyFamilyGADT a) 84 | 85 | ------------------------------------------------------------------------------- 86 | 87 | -- Plain data types 88 | 89 | $(deriveBounded ''TyConEnum) 90 | $(deriveBounded ''TyConProduct) 91 | instance Bounded (TyConUnit f a) where 92 | minBound = $(makeMinBound ''TyConUnit) 93 | maxBound = $(makeMaxBound ''TyConUnit) 94 | instance Show a => Bounded (TyConExQuant a) where 95 | minBound = $(makeMinBound ''TyConExQuant) 96 | maxBound = $(makeMaxBound ''TyConExQuant) 97 | instance (Bounded a, Show a) => Bounded (TyConGADT a) where 98 | minBound = $(makeMinBound ''TyConGADT) 99 | maxBound = $(makeMaxBound ''TyConGADT) 100 | 101 | $(deriveEnum ''TyConEnum) 102 | instance Enum (TyConUnit f a) where 103 | toEnum = $(makeToEnum ''TyConUnit) 104 | fromEnum = $(makeFromEnum ''TyConUnit) 105 | 106 | $(deriveIx ''TyConEnum) 107 | $(deriveIx ''TyConProduct) 108 | instance Ix (TyConUnit f a) where 109 | range = $(makeRange ''TyConUnit) 110 | unsafeIndex = $(makeUnsafeIndex ''TyConUnit) 111 | inRange = $(makeInRange ''TyConUnit) 112 | instance Ix (TyConExQuant a) where 113 | range = $(makeRange ''TyConExQuant) 114 | unsafeIndex = $(makeUnsafeIndex ''TyConExQuant) 115 | inRange = $(makeInRange ''TyConExQuant) 116 | instance Ix a => Ix (TyConGADT a) where 117 | range = $(makeRange ''TyConGADT) 118 | unsafeIndex = $(makeUnsafeIndex ''TyConGADT) 119 | inRange = $(makeInRange ''TyConGADT) 120 | 121 | -- Data families 122 | 123 | $(deriveBounded 'TyFamilyEnum1) 124 | $(deriveBounded 'TyFamilyProduct) 125 | instance Bounded (TyFamilyUnit f a) where 126 | minBound = $(makeMinBound 'TyFamilyUnit) 127 | maxBound = $(makeMaxBound 'TyFamilyUnit) 128 | instance Show a => Bounded (TyFamilyExQuant a) where 129 | minBound = $(makeMinBound 'TyFamilyExQuant) 130 | maxBound = $(makeMaxBound 'TyFamilyExQuant) 131 | instance (Bounded a, Show a) => Bounded (TyFamilyGADT a) where 132 | minBound = $(makeMinBound 'TyFamilyGADT) 133 | maxBound = $(makeMaxBound 'TyFamilyGADT) 134 | 135 | $(deriveEnum 'TyFamilyEnum1) 136 | instance Enum (TyFamilyUnit f a) where 137 | toEnum = $(makeToEnum 'TyFamilyUnit) 138 | fromEnum = $(makeFromEnum 'TyFamilyUnit) 139 | 140 | $(deriveIx 'TyFamilyEnum1) 141 | $(deriveIx 'TyFamilyProduct) 142 | instance Ix (TyFamilyUnit f a) where 143 | range = $(makeRange 'TyFamilyUnit) 144 | unsafeIndex = $(makeUnsafeIndex 'TyFamilyUnit) 145 | inRange = $(makeInRange 'TyFamilyUnit) 146 | instance Ix (TyFamilyExQuant a) where 147 | range = $(makeRange 'TyFamilyExQuant) 148 | unsafeIndex = $(makeUnsafeIndex 'TyFamilyExQuant) 149 | inRange = $(makeInRange 'TyFamilyExQuant) 150 | instance Ix a => Ix (TyFamilyGADT a) where 151 | range = $(makeRange 'TyFamilyGADT) 152 | unsafeIndex = $(makeUnsafeIndex 'TyFamilyGADT) 153 | inRange = $(makeInRange 'TyFamilyGADT) 154 | 155 | ------------------------------------------------------------------------------- 156 | 157 | -- | Verifies an 'Ix' instance satisfies the laws. 158 | ixLaws :: (Ix a, Show a) => a -> a -> a -> Expectation 159 | ixLaws l u i = do 160 | inRange (l,u) i `shouldBe` elem i (range (l,u)) 161 | range (l,u) !! index (l,u) i `shouldBe` i 162 | map (index (l,u)) (range (l,u)) `shouldBe` [0..rangeSize (l,u)-1] 163 | rangeSize (l,u) `shouldBe` length (range (l,u)) 164 | 165 | ------------------------------------------------------------------------------- 166 | 167 | main :: IO () 168 | main = hspec spec 169 | 170 | spec :: Spec 171 | spec = parallel $ do 172 | describe "TyConEnum" $ do 173 | it "has a sensible Bounded instance" $ do 174 | minBound `shouldBe` TyConEnum1 175 | maxBound `shouldBe` TyConEnum3 176 | 177 | it "has a sensible Enum instance" $ 178 | [minBound .. maxBound] `shouldBe` [TyConEnum1, TyConEnum2, TyConEnum3] 179 | 180 | it "has a sensible Ix instance" $ 181 | ixLaws minBound maxBound TyConEnum2 182 | describe "TyConProduct Bool Bool Bool" $ do 183 | it "has a sensible Bounded instance" $ do 184 | minBound `shouldBe` TyConProduct False False False 185 | maxBound `shouldBe` TyConProduct True True True 186 | 187 | it "has a sensible Ix instance" $ 188 | ixLaws minBound maxBound (TyConProduct False False False) 189 | describe "TyConUnit Maybe Bool" $ do 190 | it "has a sensible Bounded instance" $ do 191 | minBound `shouldBe` TyConUnit 192 | maxBound `shouldBe` TyConUnit 193 | 194 | it "has a sensible Enum instance" $ 195 | [minBound .. maxBound] `shouldBe` [TyConUnit] 196 | 197 | it "has a sensible Ix instance" $ 198 | ixLaws minBound maxBound TyConUnit 199 | describe "TyConExQuant Bool" $ do 200 | it "has a sensible Bounded instance" $ do 201 | minBound `shouldBe` (TyConExQuant :: TyConExQuant Bool) 202 | maxBound `shouldBe` (TyConExQuant :: TyConExQuant Bool) 203 | 204 | it "has a sensible Ix instance" $ 205 | ixLaws minBound maxBound (TyConExQuant :: TyConExQuant Bool) 206 | describe "TyConGADT Bool" $ do 207 | it "has a sensible Bounded instance" $ do 208 | minBound `shouldBe` TyConGADT False 209 | maxBound `shouldBe` TyConGADT True 210 | 211 | it "has a sensible Ix instance" $ 212 | ixLaws minBound maxBound (TyConGADT False) 213 | describe "TyFamilyEnum" $ do 214 | it "has a sensible Bounded instance" $ do 215 | minBound `shouldBe` TyFamilyEnum1 216 | maxBound `shouldBe` TyFamilyEnum3 217 | 218 | it "has a sensible Enum instance" $ 219 | [minBound .. maxBound] `shouldBe` [TyFamilyEnum1, TyFamilyEnum2, TyFamilyEnum3] 220 | 221 | it "has a sensible Ix instance" $ 222 | ixLaws minBound maxBound TyFamilyEnum2 223 | describe "TyFamilyProduct Bool Bool Bool" $ do 224 | it "has a sensible Bounded instance" $ do 225 | minBound `shouldBe` TyFamilyProduct False False False 226 | maxBound `shouldBe` TyFamilyProduct True True True 227 | 228 | it "has a sensible Ix instance" $ 229 | ixLaws minBound maxBound (TyFamilyProduct False False False) 230 | describe "TyFamilyUnit Maybe Bool" $ do 231 | it "has a sensible Bounded instance" $ do 232 | minBound `shouldBe` TyFamilyUnit 233 | maxBound `shouldBe` TyFamilyUnit 234 | 235 | it "has a sensible Enum instance" $ 236 | [minBound .. maxBound] `shouldBe` [TyFamilyUnit] 237 | 238 | it "has a sensible Ix instance" $ 239 | ixLaws minBound maxBound TyFamilyUnit 240 | describe "TyFamilyExQuant Bool" $ do 241 | it "has a sensible Bounded instance" $ do 242 | minBound `shouldBe` (TyFamilyExQuant :: TyFamilyExQuant Bool) 243 | maxBound `shouldBe` (TyFamilyExQuant :: TyFamilyExQuant Bool) 244 | 245 | it "has a sensible Ix instance" $ 246 | ixLaws minBound maxBound (TyFamilyExQuant :: TyFamilyExQuant Bool) 247 | describe "TyFamilyGADT Bool" $ do 248 | it "has a sensible Bounded instance" $ do 249 | minBound `shouldBe` TyFamilyGADT False 250 | maxBound `shouldBe` TyFamilyGADT True 251 | 252 | it "has a sensible Ix instance" $ 253 | ixLaws minBound maxBound (TyFamilyGADT False) 254 | -------------------------------------------------------------------------------- /src/Data/Enum/Deriving/Internal.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Data.Enum.Deriving.Internal 3 | Copyright: (C) 2015-2017 Ryan Scott 4 | License: BSD-style (see the file LICENSE) 5 | Maintainer: Ryan Scott 6 | Portability: Template Haskell 7 | 8 | Exports functions to mechanically derive 'Enum' instances. 9 | 10 | Note: this is an internal module, and as such, the API presented here is not 11 | guaranteed to be stable, even between minor releases of this library. 12 | -} 13 | module Data.Enum.Deriving.Internal ( 14 | -- * 'Enum' 15 | deriveEnum 16 | , makeSucc 17 | , makePred 18 | , makeToEnum 19 | , makeFromEnum 20 | , makeEnumFrom 21 | , makeEnumFromThen 22 | ) where 23 | 24 | import Data.Deriving.Internal 25 | import Data.List.NonEmpty (NonEmpty(..)) 26 | 27 | import Language.Haskell.TH.Datatype 28 | import Language.Haskell.TH.Lib 29 | import Language.Haskell.TH.Syntax 30 | 31 | ------------------------------------------------------------------------------- 32 | -- Code generation 33 | ------------------------------------------------------------------------------- 34 | 35 | -- | Generates an 'Enum' instance declaration for the given data type or data 36 | -- family instance. 37 | deriveEnum :: Name -> Q [Dec] 38 | deriveEnum name = do 39 | info <- reifyDatatype name 40 | case info of 41 | DatatypeInfo { datatypeContext = ctxt 42 | , datatypeName = parentName 43 | , datatypeInstTypes = instTypes 44 | , datatypeVariant = variant 45 | , datatypeCons = cons 46 | } -> do 47 | (instanceCxt, instanceType) 48 | <- buildTypeInstance EnumClass parentName ctxt instTypes variant 49 | (:[]) `fmap` instanceD (return instanceCxt) 50 | (return instanceType) 51 | (enumFunDecs parentName instanceType cons) 52 | 53 | -- | Generates a lambda expression which behaves like 'succ' (without 54 | -- requiring an 'Enum' instance). 55 | makeSucc :: Name -> Q Exp 56 | makeSucc = makeEnumFun Succ 57 | 58 | -- | Generates a lambda expression which behaves like 'pred' (without 59 | -- requiring an 'Enum' instance). 60 | makePred :: Name -> Q Exp 61 | makePred = makeEnumFun Pred 62 | 63 | -- | Generates a lambda expression which behaves like 'toEnum' (without 64 | -- requiring an 'Enum' instance). 65 | makeToEnum :: Name -> Q Exp 66 | makeToEnum = makeEnumFun ToEnum 67 | 68 | -- | Generates a lambda expression which behaves like 'fromEnum' (without 69 | -- requiring an 'Enum' instance). 70 | makeFromEnum :: Name -> Q Exp 71 | makeFromEnum = makeEnumFun FromEnum 72 | 73 | -- | Generates a lambda expression which behaves like 'enumFrom' (without 74 | -- requiring an 'Enum' instance). 75 | makeEnumFrom :: Name -> Q Exp 76 | makeEnumFrom = makeEnumFun EnumFrom 77 | 78 | -- | Generates a lambda expression which behaves like 'enumFromThen' (without 79 | -- requiring an 'Enum' instance). 80 | makeEnumFromThen :: Name -> Q Exp 81 | makeEnumFromThen = makeEnumFun EnumFromThen 82 | 83 | -- | Generates method declarations for an 'Enum' instance. 84 | enumFunDecs :: Name -> Type -> [ConstructorInfo] -> [Q Dec] 85 | enumFunDecs tyName ty cons = 86 | map makeFunD [ Succ 87 | , Pred 88 | , ToEnum 89 | , EnumFrom 90 | , EnumFromThen 91 | , FromEnum 92 | ] 93 | where 94 | makeFunD :: EnumFun -> Q Dec 95 | makeFunD ef = 96 | funD (enumFunName ef) 97 | [ clause [] 98 | (normalB $ makeEnumFunForCons ef tyName ty cons) 99 | [] 100 | ] 101 | 102 | -- | Generates a lambda expression which behaves like the EnumFun argument. 103 | makeEnumFun :: EnumFun -> Name -> Q Exp 104 | makeEnumFun ef name = do 105 | info <- reifyDatatype name 106 | case info of 107 | DatatypeInfo { datatypeContext = ctxt 108 | , datatypeName = parentName 109 | , datatypeInstTypes = instTypes 110 | , datatypeVariant = variant 111 | , datatypeCons = cons 112 | } -> do 113 | (_, instanceType) <- buildTypeInstance EnumClass parentName ctxt instTypes variant 114 | makeEnumFunForCons ef parentName instanceType cons 115 | 116 | -- | Generates a lambda expression for fromEnum/toEnum/etc. for the 117 | -- given constructors. All constructors must be from the same type. 118 | makeEnumFunForCons :: EnumFun -> Name -> Type -> [ConstructorInfo] -> Q Exp 119 | makeEnumFunForCons _ _ _ [] = noConstructorsError 120 | makeEnumFunForCons ef tyName ty (con:cons') 121 | | not $ isEnumerationType cons 122 | = enumerationError tyNameBase 123 | | otherwise = case ef of 124 | Succ -> lamOneHash $ \aHash -> 125 | condE (varE eqValName `appE` maxTagExpr `appE` 126 | (conE iHashDataName `appE` varE aHash)) 127 | (illegalExpr "succ" tyNameBase 128 | "tried to take `succ' of last tag in enumeration") 129 | (tag2Con `appE` (varE plusValName `appE` 130 | (conE iHashDataName `appE` varE aHash) `appE` integerE 1)) 131 | 132 | Pred -> lamOneHash $ \aHash -> 133 | condE (varE eqValName `appE` integerE 0 `appE` 134 | (conE iHashDataName `appE` varE aHash)) 135 | (illegalExpr "pred" tyNameBase 136 | "tried to take `pred' of first tag in enumeration") 137 | (tag2Con `appE` (varE plusValName `appE` 138 | (conE iHashDataName `appE` varE aHash) `appE` integerE (-1))) 139 | 140 | ToEnum -> lamOne $ \a -> 141 | condE (appsE [ varE andValName 142 | , varE geValName `appE` varE a `appE` integerE 0 143 | , varE leValName `appE` varE a `appE` maxTagExpr 144 | ]) 145 | (tag2Con `appE` varE a) 146 | (illegalToEnumTag tyNameBase maxTagExpr a) 147 | 148 | EnumFrom -> lamOneHash $ \aHash -> 149 | appsE [ varE mapValName 150 | , tag2Con 151 | , enumFromToExpr (conE iHashDataName `appE` varE aHash) maxTagExpr 152 | ] 153 | 154 | EnumFromThen -> do 155 | a <- newName "a" 156 | aHash <- newName "a#" 157 | b <- newName "b" 158 | bHash <- newName "b#" 159 | lamE [varP a, varP b] $ untagExpr [(a, aHash), (b, bHash)] $ 160 | appE (varE mapValName `appE` tag2Con) $ 161 | enumFromThenToExpr 162 | (conE iHashDataName `appE` varE aHash) 163 | (conE iHashDataName `appE` varE bHash) 164 | (condE (appsE [ varE gtValName 165 | , conE iHashDataName `appE` varE aHash 166 | , conE iHashDataName `appE` varE bHash 167 | ]) 168 | (integerE 0) maxTagExpr) 169 | 170 | FromEnum -> lamOneHash $ \aHash -> 171 | conE iHashDataName `appE` varE aHash 172 | 173 | where 174 | tyNameBase :: String 175 | tyNameBase = nameBase tyName 176 | 177 | cons :: NonEmpty ConstructorInfo 178 | cons = con :| cons' 179 | 180 | maxTagExpr :: Q Exp 181 | maxTagExpr = integerE (length cons') `sigE` conT intTypeName 182 | 183 | lamOne :: (Name -> Q Exp) -> Q Exp 184 | lamOne f = do 185 | a <- newName "a" 186 | lam1E (varP a) $ f a 187 | 188 | lamOneHash :: (Name -> Q Exp) -> Q Exp 189 | lamOneHash f = lamOne $ \a -> do 190 | aHash <- newName "a#" 191 | untagExpr [(a, aHash)] $ f aHash 192 | 193 | tag2Con :: Q Exp 194 | tag2Con = tag2ConExpr $ removeClassApp ty 195 | 196 | ------------------------------------------------------------------------------- 197 | -- Class-specific constants 198 | ------------------------------------------------------------------------------- 199 | 200 | -- There's only one Enum variant! 201 | data EnumClass = EnumClass 202 | 203 | instance ClassRep EnumClass where 204 | arity _ = 0 205 | 206 | allowExQuant _ = True 207 | 208 | fullClassName _ = enumTypeName 209 | 210 | classConstraint _ 0 = Just $ enumTypeName 211 | classConstraint _ _ = Nothing 212 | 213 | -- | A representation of which function is being generated. 214 | data EnumFun = Succ 215 | | Pred 216 | | ToEnum 217 | | FromEnum 218 | | EnumFrom 219 | | EnumFromThen 220 | deriving Show 221 | 222 | enumFunName :: EnumFun -> Name 223 | enumFunName Succ = succValName 224 | enumFunName Pred = predValName 225 | enumFunName ToEnum = toEnumValName 226 | enumFunName FromEnum = fromEnumValName 227 | enumFunName EnumFrom = enumFromValName 228 | enumFunName EnumFromThen = enumFromThenValName 229 | 230 | ------------------------------------------------------------------------------- 231 | -- Assorted utilities 232 | ------------------------------------------------------------------------------- 233 | 234 | enumFromThenToExpr :: Q Exp -> Q Exp -> Q Exp -> Q Exp 235 | enumFromThenToExpr f t1 t2 = varE enumFromThenToValName `appE` f `appE` t1 `appE` t2 236 | 237 | illegalExpr :: String -> String -> String -> Q Exp 238 | illegalExpr meth tp msg = 239 | varE errorValName `appE` stringE (meth ++ '{':tp ++ "}: " ++ msg) 240 | 241 | illegalToEnumTag :: String -> Q Exp -> Name -> Q Exp 242 | illegalToEnumTag tp maxtag a = 243 | appE (varE errorValName) 244 | (appE (appE (varE appendValName) 245 | (stringE ("toEnum{" ++ tp ++ "}: tag("))) 246 | (appE (appE (appE 247 | (varE showsPrecValName) 248 | (integerE 0)) 249 | (varE a)) 250 | (appE (appE 251 | (varE appendValName) 252 | (stringE ") is outside of enumeration's range (0,")) 253 | (appE (appE (appE 254 | (varE showsPrecValName) 255 | (integerE 0)) 256 | maxtag) 257 | (stringE ")"))))) 258 | -------------------------------------------------------------------------------- /src/Data/Deriving/Via/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE TemplateHaskellQuotes #-} 3 | {-# LANGUAGE TupleSections #-} 4 | 5 | {-| 6 | Module: Data.Deriving.Via.Internal 7 | Copyright: (C) 2015-2017 Ryan Scott 8 | License: BSD-style (see the file LICENSE) 9 | Maintainer: Ryan Scott 10 | Portability: Template Haskell 11 | 12 | On @template-haskell-2.12@ or later (i.e., GHC 8.2 or later), this module 13 | exports functionality which emulates the @GeneralizedNewtypeDeriving@ and 14 | @DerivingVia@ GHC extensions (the latter of which was introduced in GHC 8.6). 15 | 16 | On older versions of @template-haskell@/GHC, this module does not export 17 | anything. 18 | 19 | Note: this is an internal module, and as such, the API presented here is not 20 | guaranteed to be stable, even between minor releases of this library. 21 | -} 22 | module Data.Deriving.Via.Internal where 23 | 24 | #if MIN_VERSION_template_haskell(2,12,0) 25 | import Control.Monad ((<=<), unless) 26 | 27 | import Data.Deriving.Internal 28 | import qualified Data.List as L 29 | import qualified Data.Map as M 30 | import Data.Map (Map) 31 | import Data.Maybe (catMaybes) 32 | 33 | import GHC.Exts (Any) 34 | 35 | import Language.Haskell.TH 36 | import Language.Haskell.TH.Datatype 37 | import Language.Haskell.TH.Datatype.TyVarBndr 38 | 39 | ------------------------------------------------------------------------------- 40 | -- Code generation 41 | ------------------------------------------------------------------------------- 42 | 43 | {- | Generates an instance for a type class at a newtype by emulating the 44 | behavior of the @GeneralizedNewtypeDeriving@ extension. For example: 45 | 46 | @ 47 | newtype Foo a = MkFoo a 48 | $('deriveGND' [t| forall a. 'Eq' a => 'Eq' (Foo a) |]) 49 | @ 50 | -} 51 | deriveGND :: Q Type -> Q [Dec] 52 | deriveGND qty = do 53 | ty <- qty 54 | let (_instanceTvbs, instanceCxt, instanceTy) = decomposeType ty 55 | instanceTy' <- (resolveTypeSynonyms <=< resolveInfixT) instanceTy 56 | decs <- deriveViaDecs instanceTy' Nothing 57 | (:[]) `fmap` instanceD (return instanceCxt) 58 | (return instanceTy) 59 | (map return decs) 60 | 61 | {- | Generates an instance for a type class by emulating the behavior of the 62 | @DerivingVia@ extension. For example: 63 | 64 | @ 65 | newtype Foo a = MkFoo a 66 | $('deriveVia' [t| forall a. 'Ord' a => 'Ord' (Foo a) ``Via`` Down a |]) 67 | @ 68 | 69 | As shown in the example above, the syntax is a tad strange. One must specify 70 | the type by which to derive the instance using the 'Via' type. This 71 | requirement is in place to ensure that the type variables are scoped 72 | correctly across all the types being used (e.g., to make sure that the same 73 | @a@ is used in @'Ord' a@, @'Ord' (Foo a)@, and @Down a@). 74 | -} 75 | deriveVia :: Q Type -> Q [Dec] 76 | deriveVia qty = do 77 | ty <- qty 78 | let (_instanceTvbs, instanceCxt, viaApp) = decomposeType ty 79 | viaApp' <- (resolveTypeSynonyms <=< resolveInfixT) viaApp 80 | (instanceTy, viaTy) 81 | <- case unapplyTy viaApp' of 82 | (via, [instanceTy,viaTy]) 83 | | via == ConT viaTypeName 84 | -> return (instanceTy, viaTy) 85 | _ -> fail $ unlines 86 | [ "Failure to meet ‘deriveVia‘ specification" 87 | , "\tThe ‘Via‘ type must be used, e.g." 88 | , "\t[t| forall a. C (T a) `Via` V a |]" 89 | ] 90 | -- This is a stronger requirement than what GHC's implementation of 91 | -- DerivingVia imposes, but due to Template Haskell restrictions, we 92 | -- currently can't do better. See #27. 93 | let viaTyFVs = freeVariables viaTy 94 | otherFVs = concat [freeVariables instanceCxt, freeVariables instanceTy] 95 | floatingViaTyFVs = viaTyFVs L.\\ otherFVs 96 | floatingViaTySubst = M.fromList $ map (, ConT ''Any) floatingViaTyFVs 97 | viaTy' = applySubstitution floatingViaTySubst viaTy 98 | decs <- deriveViaDecs instanceTy (Just viaTy') 99 | (:[]) `fmap` instanceD (return instanceCxt) 100 | (return instanceTy) 101 | (map return decs) 102 | 103 | deriveViaDecs :: Type -- ^ The instance head (e.g., @Eq (Foo a)@) 104 | -> Maybe Type -- ^ If using 'deriveGND', this is 'Nothing. 105 | -- If using 'deriveVia', this is 'Just' the @via@ type. 106 | -> Q [Dec] 107 | deriveViaDecs instanceTy mbViaTy = do 108 | let (clsTy, clsArgs) = unapplyTy instanceTy 109 | case clsTy of 110 | ConT clsName -> do 111 | clsInfo <- reify clsName 112 | case clsInfo of 113 | ClassI (ClassD _ _ clsTvbs _ clsDecs) _ -> 114 | case (unsnoc clsArgs, unsnoc clsTvbs) of 115 | (Just (_, dataApp), Just (_, clsLastTvb)) -> do 116 | let (dataTy, dataArgs) = unapplyTy dataApp 117 | clsLastTvbKind = tvbKind clsLastTvb 118 | (_, kindList) = uncurryTy clsLastTvbKind 119 | numArgsToEtaReduce = length kindList - 1 120 | repTy <- 121 | case mbViaTy of 122 | Just viaTy -> return viaTy 123 | Nothing -> 124 | case dataTy of 125 | ConT dataName -> do 126 | DatatypeInfo { 127 | datatypeInstTypes = dataInstTypes 128 | , datatypeVariant = dv 129 | , datatypeCons = cons 130 | } <- reifyDatatype dataName 131 | case newtypeRepType dv cons of 132 | Just newtypeRepTy -> 133 | case etaReduce numArgsToEtaReduce newtypeRepTy of 134 | Just etaRepTy -> 135 | let repTySubst = 136 | M.fromList $ 137 | zipWith (\var arg -> (varTToName var, arg)) 138 | dataInstTypes dataArgs 139 | in return $ applySubstitution repTySubst etaRepTy 140 | Nothing -> etaReductionError instanceTy 141 | Nothing -> fail $ "Not a newtype: " ++ nameBase dataName 142 | _ -> fail $ "Not a data type: " ++ pprint dataTy 143 | concat . catMaybes <$> traverse (deriveViaDecs' clsName clsTvbs clsArgs repTy) clsDecs 144 | (_, _) -> fail $ "Cannot derive instance for nullary class " ++ pprint clsTy 145 | _ -> fail $ "Not a type class: " ++ pprint clsTy 146 | _ -> fail $ "Malformed instance: " ++ pprint instanceTy 147 | 148 | deriveViaDecs' :: Name -> [TyVarBndr_ flag] -> [Type] -> Type -> Dec -> Q (Maybe [Dec]) 149 | deriveViaDecs' clsName clsTvbs clsArgs repTy dec = do 150 | let numExpectedArgs = length clsTvbs 151 | numActualArgs = length clsArgs 152 | unless (numExpectedArgs == numActualArgs) $ 153 | fail $ "Mismatched number of class arguments" 154 | ++ "\n\tThe class " ++ nameBase clsName ++ " expects " ++ show numExpectedArgs ++ " argument(s)," 155 | ++ "\n\tbut was provided " ++ show numActualArgs ++ " argument(s)." 156 | go dec 157 | where 158 | go :: Dec -> Q (Maybe [Dec]) 159 | 160 | go (OpenTypeFamilyD (TypeFamilyHead tfName tfTvbs _ _)) = do 161 | let lhsSubst = zipTvbSubst clsTvbs clsArgs 162 | rhsSubst = zipTvbSubst clsTvbs $ changeLast clsArgs repTy 163 | tfTvbTys = map tvbToType tfTvbs 164 | tfLHSTys = map (applySubstitution lhsSubst) tfTvbTys 165 | tfRHSTys = map (applySubstitution rhsSubst) tfTvbTys 166 | tfRHSTy = applyTy (ConT tfName) tfRHSTys 167 | tfInst <- tySynInstDCompat tfName Nothing 168 | (map pure tfLHSTys) (pure tfRHSTy) 169 | pure (Just [tfInst]) 170 | 171 | go (SigD methName methTy) = 172 | let (fromTy, toTy) = mkCoerceClassMethEqn clsTvbs clsArgs repTy $ 173 | stripOuterForallT methTy 174 | fromTau = stripOuterForallT fromTy 175 | toTau = stripOuterForallT toTy 176 | rhsExpr = VarE coerceValName `AppTypeE` fromTau 177 | `AppTypeE` toTau 178 | `AppE` VarE methName 179 | sig = SigD methName toTy 180 | meth = ValD (VarP methName) 181 | (NormalB rhsExpr) 182 | [] 183 | in return (Just [sig, meth]) 184 | 185 | go _ = return Nothing 186 | 187 | mkCoerceClassMethEqn :: [TyVarBndr_ flag] -> [Type] -> Type -> Type -> (Type, Type) 188 | mkCoerceClassMethEqn clsTvbs clsArgs repTy methTy 189 | = ( applySubstitution rhsSubst methTy 190 | , applySubstitution lhsSubst methTy 191 | ) 192 | where 193 | lhsSubst = zipTvbSubst clsTvbs clsArgs 194 | rhsSubst = zipTvbSubst clsTvbs $ changeLast clsArgs repTy 195 | 196 | zipTvbSubst :: [TyVarBndr_ flag] -> [Type] -> Map Name Type 197 | zipTvbSubst tvbs = M.fromList . zipWith (\tvb ty -> (tvName tvb, ty)) tvbs 198 | 199 | -- | Replace the last element of a list with another element. 200 | changeLast :: [a] -> a -> [a] 201 | changeLast [] _ = error "changeLast" 202 | changeLast [_] x = [x] 203 | changeLast (x:xs) x' = x : changeLast xs x' 204 | 205 | stripOuterForallT :: Type -> Type 206 | #if __GLASGOW_HASKELL__ < 807 207 | -- Before GHC 8.7, TH-reified classes would put a redundant forall/class 208 | -- context in front of each method's type signature, so we have to strip them 209 | -- off here. 210 | stripOuterForallT (ForallT _ _ ty) = ty 211 | #endif 212 | stripOuterForallT ty = ty 213 | 214 | decomposeType :: Type -> ([TyVarBndrSpec], Cxt, Type) 215 | decomposeType (ForallT tvbs ctxt ty) = (tvbs, ctxt, ty) 216 | decomposeType ty = ([], [], ty) 217 | 218 | newtypeRepType :: DatatypeVariant -> [ConstructorInfo] -> Maybe Type 219 | newtypeRepType dv cons = do 220 | checkIfNewtype 221 | case cons of 222 | [ConstructorInfo { constructorVars = [] 223 | , constructorContext = [] 224 | , constructorFields = [repTy] 225 | }] -> Just repTy 226 | _ -> Nothing 227 | where 228 | checkIfNewtype :: Maybe () 229 | checkIfNewtype 230 | | Newtype <- dv = Just () 231 | | NewtypeInstance <- dv = Just () 232 | | otherwise = Nothing 233 | 234 | etaReduce :: Int -> Type -> Maybe Type 235 | etaReduce num ty = 236 | let (tyHead, tyArgs) = unapplyTy ty 237 | (tyArgsRemaining, tyArgsDropped) = splitAt (length tyArgs - num) tyArgs 238 | in if canEtaReduce tyArgsRemaining tyArgsDropped 239 | then Just $ applyTy tyHead tyArgsRemaining 240 | else Nothing 241 | #endif 242 | -------------------------------------------------------------------------------- /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' '--config=cabal.haskell-ci' 'cabal.project' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20241202 12 | # 13 | # REGENDATA ("0.19.20241202",["github","--config=cabal.haskell-ci","cabal.project"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-20.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:jammy 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.12.0.20241128 32 | compilerKind: ghc 33 | compilerVersion: 9.12.0.20241128 34 | setup-method: ghcup-prerelease 35 | allow-failure: false 36 | - compiler: ghc-9.10.1 37 | compilerKind: ghc 38 | compilerVersion: 9.10.1 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-9.8.4 42 | compilerKind: ghc 43 | compilerVersion: 9.8.4 44 | setup-method: ghcup 45 | allow-failure: false 46 | - compiler: ghc-9.6.6 47 | compilerKind: ghc 48 | compilerVersion: 9.6.6 49 | setup-method: ghcup 50 | allow-failure: false 51 | - compiler: ghc-9.4.8 52 | compilerKind: ghc 53 | compilerVersion: 9.4.8 54 | setup-method: ghcup 55 | allow-failure: false 56 | - compiler: ghc-9.2.8 57 | compilerKind: ghc 58 | compilerVersion: 9.2.8 59 | setup-method: ghcup 60 | allow-failure: false 61 | - compiler: ghc-9.0.2 62 | compilerKind: ghc 63 | compilerVersion: 9.0.2 64 | setup-method: ghcup 65 | allow-failure: false 66 | - compiler: ghc-8.10.7 67 | compilerKind: ghc 68 | compilerVersion: 8.10.7 69 | setup-method: ghcup 70 | allow-failure: false 71 | - compiler: ghc-8.8.4 72 | compilerKind: ghc 73 | compilerVersion: 8.8.4 74 | setup-method: ghcup 75 | allow-failure: false 76 | - compiler: ghc-8.6.5 77 | compilerKind: ghc 78 | compilerVersion: 8.6.5 79 | setup-method: ghcup 80 | allow-failure: false 81 | - compiler: ghc-8.4.4 82 | compilerKind: ghc 83 | compilerVersion: 8.4.4 84 | setup-method: ghcup 85 | allow-failure: false 86 | - compiler: ghc-8.2.2 87 | compilerKind: ghc 88 | compilerVersion: 8.2.2 89 | setup-method: ghcup 90 | allow-failure: false 91 | - compiler: ghc-8.0.2 92 | compilerKind: ghc 93 | compilerVersion: 8.0.2 94 | setup-method: ghcup 95 | allow-failure: false 96 | fail-fast: false 97 | steps: 98 | - name: apt-get install 99 | run: | 100 | apt-get update 101 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev 102 | - name: Install GHCup 103 | run: | 104 | mkdir -p "$HOME/.ghcup/bin" 105 | curl -sL https://downloads.haskell.org/ghcup/0.1.30.0/x86_64-linux-ghcup-0.1.30.0 > "$HOME/.ghcup/bin/ghcup" 106 | chmod a+x "$HOME/.ghcup/bin/ghcup" 107 | - name: Install cabal-install 108 | run: | 109 | "$HOME/.ghcup/bin/ghcup" install cabal 3.12.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) 110 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.12.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" 111 | - name: Install GHC (GHCup) 112 | if: matrix.setup-method == 'ghcup' 113 | run: | 114 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 115 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 116 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 117 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 118 | echo "HC=$HC" >> "$GITHUB_ENV" 119 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 120 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 121 | env: 122 | HCKIND: ${{ matrix.compilerKind }} 123 | HCNAME: ${{ matrix.compiler }} 124 | HCVER: ${{ matrix.compilerVersion }} 125 | - name: Install GHC (GHCup prerelease) 126 | if: matrix.setup-method == 'ghcup-prerelease' 127 | run: | 128 | "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml; 129 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 130 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 131 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 132 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 133 | echo "HC=$HC" >> "$GITHUB_ENV" 134 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 135 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 136 | env: 137 | HCKIND: ${{ matrix.compilerKind }} 138 | HCNAME: ${{ matrix.compiler }} 139 | HCVER: ${{ matrix.compilerVersion }} 140 | - name: Set PATH and environment variables 141 | run: | 142 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 143 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 144 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 145 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 146 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 147 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 148 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 149 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 150 | if [ $((HCNUMVER >= 91200)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi 151 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 152 | env: 153 | HCKIND: ${{ matrix.compilerKind }} 154 | HCNAME: ${{ matrix.compiler }} 155 | HCVER: ${{ matrix.compilerVersion }} 156 | - name: env 157 | run: | 158 | env 159 | - name: write cabal config 160 | run: | 161 | mkdir -p $CABAL_DIR 162 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 207 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 208 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 209 | rm -f cabal-plan.xz 210 | chmod a+x $HOME/.cabal/bin/cabal-plan 211 | cabal-plan --version 212 | - name: checkout 213 | uses: actions/checkout@v4 214 | with: 215 | path: source 216 | - name: initial cabal.project for sdist 217 | run: | 218 | touch cabal.project 219 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 220 | cat cabal.project 221 | - name: sdist 222 | run: | 223 | mkdir -p sdist 224 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 225 | - name: unpack 226 | run: | 227 | mkdir -p unpacked 228 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 229 | - name: generate cabal.project 230 | run: | 231 | PKGDIR_deriving_compat="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/deriving-compat-[0-9.]*')" 232 | echo "PKGDIR_deriving_compat=${PKGDIR_deriving_compat}" >> "$GITHUB_ENV" 233 | rm -f cabal.project cabal.project.local 234 | touch cabal.project 235 | touch cabal.project.local 236 | echo "packages: ${PKGDIR_deriving_compat}" >> cabal.project 237 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package deriving-compat" >> cabal.project ; fi 238 | if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi 239 | cat >> cabal.project <> cabal.project 245 | fi 246 | $HCPKG list --simple-output --names-only | perl -ne 'for (split /\s+/) { print "constraints: any.$_ installed\n" unless /^(deriving-compat)$/; }' >> cabal.project.local 247 | cat cabal.project 248 | cat cabal.project.local 249 | - name: dump install plan 250 | run: | 251 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 252 | cabal-plan 253 | - name: restore cache 254 | uses: actions/cache/restore@v4 255 | with: 256 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 257 | path: ~/.cabal/store 258 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 259 | - name: install dependencies 260 | run: | 261 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 262 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 263 | - name: build 264 | run: | 265 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 266 | - name: tests 267 | run: | 268 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 269 | - name: cabal check 270 | run: | 271 | cd ${PKGDIR_deriving_compat} || false 272 | ${CABAL} -vnormal check 273 | - name: haddock 274 | run: | 275 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 276 | - name: save cache 277 | if: always() 278 | uses: actions/cache/save@v4 279 | with: 280 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 281 | path: ~/.cabal/store 282 | -------------------------------------------------------------------------------- /src/Data/Deriving.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Module: Data.Deriving 3 | Copyright: (C) 2015-2017 Ryan Scott 4 | License: BSD-style (see the file LICENSE) 5 | Maintainer: Ryan Scott 6 | Portability: Template Haskell 7 | 8 | This module reexports all of the functionality of the other modules in this library 9 | (with the exception of "Data.Deriving.Via", which is only available on GHC 8.2 or 10 | later). This module also provides a high-level tutorial on @deriving-compat@'s 11 | naming conventions and best practices. Typeclass-specific information can be found 12 | in their respective modules. 13 | -} 14 | module Data.Deriving ( 15 | -- * Backported changes 16 | -- $changes 17 | 18 | -- * @derive@- functions 19 | -- $derive 20 | 21 | -- * @make@- functions 22 | -- $make 23 | module Exports 24 | ) where 25 | 26 | import Data.Bounded.Deriving as Exports 27 | import Data.Enum.Deriving as Exports 28 | import Data.Eq.Deriving as Exports 29 | import Data.Foldable.Deriving as Exports 30 | import Data.Functor.Deriving as Exports 31 | import Data.Ix.Deriving as Exports 32 | import Data.Ord.Deriving as Exports 33 | import Data.Traversable.Deriving as Exports 34 | import Text.Read.Deriving as Exports 35 | import Text.Show.Deriving as Exports 36 | 37 | {- $changes 38 | The following changes have been backported: 39 | 40 | * In GHC 7.2, deriving 'Read' was changed so that constructors that use 41 | @MagicHash@ now parse correctly. 42 | 43 | * In GHC 7.8, deriving standalone 'Read' instances was fixed to avoid crashing on 44 | datatypes with no constructors. Derived 'Read' instances were also changed so 45 | as to compile more quickly. 46 | 47 | * In GHC 7.10, deriving standalone 'Read' and 'Show' instances were fixed to ensure 48 | that they use the correct fixity information for a particular datatype. 49 | 50 | * In GHC 8.0, @DeriveFoldable@ was changed to allow folding over data types with 51 | existential constraints. 52 | 53 | * In GHC 8.0, @DeriveFoldable@ and @DeriveTraversable@ were changed so as not to 54 | generate superfluous 'mempty' or 'pure' expressions in generated code. As a result, 55 | this allows deriving 'Traversable' instances for datatypes with unlifted argument 56 | types. 57 | 58 | * In GHC 8.0, deriving 'Ix' was changed to use @('&&')@ instead of @if@, as the latter 59 | interacts poorly with @RebindableSyntax@. A bug was also fixed so that 60 | standalone-derived 'Ix' instances for single-constructor GADTs do not crash GHC. 61 | 62 | * In GHC 8.0, deriving 'Show' was changed so that constructor fields with unlifted 63 | types are no longer shown with parentheses, and the output of showing an unlifted 64 | type is suffixed with the same number of hash signs as the corresponding primitive 65 | literals. 66 | 67 | * In GHC 8.2, deriving 'Ord' was changed so that it generates concrete @if@-expressions 68 | that are not subject to @RebindableSyntax@. It was also changed so that derived 69 | @('<=')@, @('>')@, and @('>=')@ methods are expressed through @('<')@, which avoids 70 | generating a substantial amount of code. 71 | 72 | * In GHC 8.2, deriving 'Traversable' was changed so that it uses 'liftA2' to implement 73 | 'traverse' whenever possible. This was done since 'liftA2' was also made a class 74 | method of 'Applicative', so sometimes using 'liftA2' produces more efficient code. 75 | 76 | * In GHC 8.2, deriving 'Show' was changed so that it uses an explicit @showCommaSpace@ 77 | method, instead of repeating the code @showString \", \"@ in several places. 78 | 79 | * In GHC 8.2, @DeriveFunctor@ was changed so that it derives implementations of 80 | ('<$'). 81 | 82 | * In GHC 8.4, @DeriveFoldable@ was changed so that it derives implementations of 83 | 'null'. 84 | 85 | * In GHC 8.4, deriving 'Functor' and 'Traverable' was changed so that it uses 'coerce' 86 | for efficiency when the last parameter of the data type is at phantom role. 87 | 88 | * In GHC 8.4, the @EmptyDataDeriving@ proposal brought forth a slew of changes related 89 | to how instances for empty data types (i.e., no constructors) were derived. These 90 | changes include: 91 | 92 | * For derived 'Eq' and 'Ord' instances for empty data types, simply return 93 | 'True' and 'EQ', respectively, without inspecting the arguments. 94 | 95 | * For derived 'Read' instances for empty data types, simply return 'pfail' 96 | (without 'parens'). 97 | 98 | * For derived 'Show' instances for empty data types, inspect the argument 99 | (instead of 'error'ing). 100 | 101 | * For derived 'Functor' and 'Traversable' instances for empty data 102 | types, make 'fmap' and 'traverse' strict in its argument. 103 | 104 | * For derived 'Foldable' instances, do not error on empty data types. 105 | Instead, simply return the folded state (for 'foldr') or 'mempty' (for 106 | 'foldMap'), without inspecting the arguments. 107 | 108 | * In GHC 8.6, the @DerivingVia@ language extension was introduced. 109 | @deriving-compat@ provides an interface which attempts to mimic this 110 | extension (as well as @GeneralizedNewtypeDeriving@, which is a special case 111 | of @DerivingVia@) as closely as possible. 112 | 113 | Since the generated code requires the use of @TypeApplications@, this can 114 | only be backported back to GHC 8.2. 115 | 116 | * In GHC 8.6, deriving 'Read' was changed so as to factor out certain commonly 117 | used subexpressions, which significantly improve compliation times. 118 | 119 | * In GHC 8.10, @DerivingVia@ permits \"floating\" type variables in @via@ types, 120 | such as the @a@ in @'deriveVia' [t| forall a. Show MyInt ``Via`` Const Int a |]@. 121 | @deriving-compat@ does so by instantiating the @a@ to @GHC.Exts.Any@ in the 122 | generated instance. 123 | 124 | * In GHC 9.0, @DeriveFunctor@ was changed so that it works on more 125 | constructors with rank-n field types. 126 | 127 | * In GHC 9.4, deriving 'Eq' was changed so that it checks data constructor 128 | tags, which can improve runtime performance for data types with nullary 129 | constructors. 130 | -} 131 | 132 | {- $derive 133 | 134 | Functions with the @derive@- prefix can be used to automatically generate an instance 135 | of a typeclass for a given datatype 'Name'. Some examples: 136 | 137 | @ 138 | {-# LANGUAGE TemplateHaskell #-} 139 | import Data.Deriving 140 | 141 | data Pair a = Pair a a 142 | $('deriveFunctor' ''Pair) -- instance Functor Pair where ... 143 | 144 | data Product f g a = Product (f a) (g a) 145 | $('deriveFoldable' ''Product) 146 | -- instance (Foldable f, Foldable g) => Foldable (Pair f g) where ... 147 | @ 148 | 149 | If you are using @template-haskell-2.7.0.0@ or later (i.e., GHC 7.4 or later), 150 | then @derive@-functions can be used with data family instances (which requires the 151 | @-XTypeFamilies@ extension). To do so, pass the 'Name' of a data or newtype instance 152 | constructor (NOT a data family name!) to @deriveFoldable@. Note that the 153 | generated code may require the @-XFlexibleInstances@ extension. Example: 154 | 155 | @ 156 | {-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-} 157 | import Data.Deriving 158 | 159 | class AssocClass a b where 160 | data AssocData a b 161 | instance AssocClass Int b where 162 | data AssocData Int b = AssocDataInt1 Int 163 | | AssocDataInt2 b 164 | $('deriveFunctor' 'AssocDataInt1) -- instance Functor (AssocData Int) where ... 165 | -- Alternatively, one could use $(deriveFunctor 'AssocDataInt2) 166 | @ 167 | 168 | @derive@-functions in @deriving-compat@ fall into one of three categories: 169 | 170 | * Category 0: Typeclasses with an argument of kind @*@. 171 | ('deriveBounded', 'deriveEnum', 'deriveEq', 'deriveIx', 'deriveOrd', 'deriveRead', 'deriveShow') 172 | 173 | * Category 1: Typeclasses with an argument of kind @* -> *@, That is, a datatype 174 | with such an instance must have at least one type variable, and the last type 175 | variable must be of kind @*@. 176 | ('deriveEq1', 'deriveFoldable', 'deriveFunctor', 'deriveOrd1', 177 | 'deriveRead1', 'deriveShow1', 'deriveTraversable') 178 | 179 | * Category 2: Typeclasses with an argument of kind @* -> * -> *@. That is, a datatype 180 | with such an instance must have at least two type variables, and the last two type 181 | variables must be of kind @*@. 182 | ('deriveEq2', 'deriveOrd2', 'deriveRead2', 'deriveShow2') 183 | 184 | Note that there are some limitations to @derive@-functions: 185 | 186 | * The 'Name' argument must not be of a type synonym. 187 | 188 | * Type variables (other than the last ones) are assumed to require typeclass 189 | constraints. The constraints are different depending on the category. For example, 190 | for Category 0 functions, other type variables of kind @*@ are assumed to be 191 | constrained by that typeclass. As an example: 192 | 193 | @ 194 | data Foo a = Foo a 195 | $(deriveEq ''Foo) 196 | @ 197 | 198 | will result in a generated instance of: 199 | 200 | @ 201 | instance Eq a => Eq (Foo a) where ... 202 | @ 203 | 204 | If you do not want this behavior, use a @make@- function instead. 205 | 206 | * For Category 1 and 2 functions, if you are using the @-XDatatypeContexts@ extension, 207 | a constraint cannot mention the last type variables. For example, 208 | @data Illegal a where I :: Ord a => a -> Illegal a@ cannot have a derived 'Functor' 209 | instance. 210 | 211 | * For Category 1 and 2 functions, if one of the last type variables is used within a 212 | constructor field's type, it must only be used in the last type arguments. For 213 | example, @data Legal a = Legal (Either Int a)@ can have a derived 'Functor' instance, 214 | but @data Illegal a = Illegal (Either a Int)@ cannot. 215 | 216 | * For Category 1 and 2 functions, data family instances must be able to eta-reduce the 217 | last type variables. In other words, if you have a instance of the form: 218 | 219 | @ 220 | data family Family a1 ... an t1 ... tn 221 | data instance Family e1 ... e2 v1 ... vn = ... 222 | @ 223 | 224 | where @t1@, ..., @tn@ are the last type variables, then the following conditions 225 | must hold: 226 | 227 | 1. @v1@, ..., @vn@ must be type variables. 228 | 2. @v1@, ..., @vn@ must not be mentioned in any of @e1@, ..., @e2@. 229 | 230 | -} 231 | 232 | {- $make 233 | 234 | Functions prefixed with @make@- are similar to @derive@-functions in that they also 235 | generate code, but @make@-functions in particular generate the expression for a 236 | particular typeclass method. For example: 237 | 238 | @ 239 | {-# LANGUAGE TemplateHaskell #-} 240 | import Data.Deriving 241 | 242 | data Pair a = Pair a a 243 | 244 | instance Functor Pair where 245 | fmap = $('makeFmap' ''Pair) 246 | @ 247 | 248 | In this example, 'makeFmap' will splice in the appropriate lambda expression which 249 | implements 'fmap' for @Pair@. 250 | 251 | @make@-functions are subject to all the restrictions of @derive@-functions listed 252 | above save for one exception: the datatype need not be an instance of a particular 253 | typeclass. There are some scenarios where this might be preferred over using a 254 | @derive@-function. For example, you might want to map over a @Pair@ value 255 | without explicitly having to make it an instance of 'Functor'. 256 | 257 | Another use case for @make@-functions is sophisticated data types—that is, an 258 | expression for which a @derive@-function would infer the wrong instance context. 259 | Consider the following example: 260 | 261 | @ 262 | data Proxy a = Proxy 263 | $('deriveEq' ''Proxy) 264 | @ 265 | 266 | This would result in a generated instance of: 267 | 268 | @ 269 | instance Eq a => Eq (Proxy a) where ... 270 | @ 271 | 272 | This compiles, but is not what we want, since the @Eq a@ constraint is completely 273 | unnecessary. Another scenario in which @derive@-functions fail is when you 274 | have something like this: 275 | 276 | @ 277 | newtype HigherKinded f a b = HigherKinded (f a b) 278 | $('deriveFunctor' ''HigherKinded) 279 | @ 280 | 281 | Ideally, this would produce @HigherKinded (f a)@ as its instance context, but sadly, 282 | the Template Haskell type inference machinery used in @deriving-compat@ is not smart 283 | enough to figure that out. Nevertheless, @make@-functions provide a valuable 284 | backdoor for these sorts of scenarios: 285 | 286 | @ 287 | {-# LANGUAGE FlexibleContexts, TemplateHaskell #-} 288 | import Data.Foldable.Deriving 289 | 290 | data Proxy a = Proxy 291 | newtype HigherKinded f a b = HigherKinded (f a b) 292 | 293 | instance Eq (Proxy a) where 294 | (==) = $('makeEq' ''Proxy) 295 | 296 | instance Functor (f a) => Functor (HigherKinded f a) where 297 | fmap = $('makeFmap' ''HigherKinded) 298 | @ 299 | 300 | -} 301 | -------------------------------------------------------------------------------- /src/Data/Eq/Deriving/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | {-| 4 | Module: Data.Eq.Deriving.Internal 5 | Copyright: (C) 2015-2017 Ryan Scott 6 | License: BSD-style (see the file LICENSE) 7 | Maintainer: Ryan Scott 8 | Portability: Template Haskell 9 | 10 | Exports functions to mechanically derive 'Eq', 'Eq1', and 'Eq2' instances. 11 | 12 | Note: this is an internal module, and as such, the API presented here is not 13 | guaranteed to be stable, even between minor releases of this library. 14 | -} 15 | module Data.Eq.Deriving.Internal ( 16 | -- * 'Eq' 17 | deriveEq 18 | , makeEq 19 | , makeNotEq 20 | -- * 'Eq1' 21 | , deriveEq1 22 | , makeLiftEq 23 | , makeEq1 24 | -- * 'Eq2' 25 | , deriveEq2 26 | , makeLiftEq2 27 | , makeEq2 28 | ) where 29 | 30 | import Data.Deriving.Internal 31 | import Data.List (foldl1') 32 | import qualified Data.Map as Map 33 | 34 | import Language.Haskell.TH.Datatype 35 | import Language.Haskell.TH.Lib 36 | import Language.Haskell.TH.Syntax 37 | 38 | -- | Generates an 'Eq' instance declaration for the given data type or data 39 | -- family instance. 40 | deriveEq :: Name -> Q [Dec] 41 | deriveEq = deriveEqClass Eq 42 | 43 | -- | Generates a lambda expression which behaves like '(==)' (without 44 | -- requiring an 'Eq' instance). 45 | makeEq :: Name -> Q Exp 46 | makeEq = makeEqClass Eq 47 | 48 | -- | Generates a lambda expression which behaves like '(/=)' (without 49 | -- requiring an 'Eq' instance). 50 | makeNotEq :: Name -> Q Exp 51 | makeNotEq name = do 52 | x1 <- newName "x1" 53 | x2 <- newName "x2" 54 | lamE [varP x1, varP x2] $ varE notValName `appE` 55 | (makeEq name `appE` varE x1 `appE` varE x2) 56 | 57 | -- | Generates an 'Eq1' instance declaration for the given data type or data 58 | -- family instance. 59 | deriveEq1 :: Name -> Q [Dec] 60 | deriveEq1 = deriveEqClass Eq1 61 | 62 | -- | Generates a lambda expression which behaves like 'liftEq' (without 63 | -- requiring an 'Eq1' instance). 64 | -- 65 | -- This function is not available with @transformers-0.4@. 66 | makeLiftEq :: Name -> Q Exp 67 | makeLiftEq = makeEqClass Eq1 68 | 69 | -- | Generates a lambda expression which behaves like 'eq1' (without 70 | -- requiring an 'Eq1' instance). 71 | makeEq1 :: Name -> Q Exp 72 | makeEq1 name = makeLiftEq name `appE` varE eqValName 73 | 74 | -- | Generates an 'Eq2' instance declaration for the given data type or data 75 | -- family instance. 76 | -- 77 | -- This function is not available with @transformers-0.4@. 78 | deriveEq2 :: Name -> Q [Dec] 79 | deriveEq2 = deriveEqClass Eq2 80 | 81 | -- | Generates a lambda expression which behaves like 'liftEq2' (without 82 | -- requiring an 'Eq2' instance). 83 | -- 84 | -- This function is not available with @transformers-0.4@. 85 | makeLiftEq2 :: Name -> Q Exp 86 | makeLiftEq2 = makeEqClass Eq2 87 | 88 | -- | Generates a lambda expression which behaves like 'eq2' (without 89 | -- requiring an 'Eq2' instance). 90 | -- 91 | -- This function is not available with @transformers-0.4@. 92 | makeEq2 :: Name -> Q Exp 93 | makeEq2 name = makeLiftEq name `appE` varE eqValName `appE` varE eqValName 94 | 95 | ------------------------------------------------------------------------------- 96 | -- Code generation 97 | ------------------------------------------------------------------------------- 98 | 99 | -- | Derive an Eq(1)(2) instance declaration (depending on the EqClass 100 | -- argument's value). 101 | deriveEqClass :: EqClass -> Name -> Q [Dec] 102 | deriveEqClass eClass name = do 103 | info <- reifyDatatype name 104 | case info of 105 | DatatypeInfo { datatypeContext = ctxt 106 | , datatypeName = parentName 107 | , datatypeInstTypes = instTypes 108 | , datatypeVariant = variant 109 | , datatypeCons = cons 110 | } -> do 111 | (instanceCxt, instanceType) 112 | <- buildTypeInstance eClass parentName ctxt instTypes variant 113 | (:[]) `fmap` instanceD (return instanceCxt) 114 | (return instanceType) 115 | (eqDecs eClass instTypes cons) 116 | 117 | -- | Generates a declaration defining the primary function corresponding to a 118 | -- particular class ((==) for Eq, liftEq for Eq1, and 119 | -- liftEq2 for Eq2). 120 | eqDecs :: EqClass -> [Type] -> [ConstructorInfo] -> [Q Dec] 121 | eqDecs eClass instTypes cons = 122 | [ funD (eqName eClass) 123 | [ clause [] 124 | (normalB $ makeEqForCons eClass instTypes cons) 125 | [] 126 | ] 127 | ] 128 | 129 | -- | Generates a lambda expression which behaves like (==) (for Eq), 130 | -- liftEq (for Eq1), or liftEq2 (for Eq2). 131 | makeEqClass :: EqClass -> Name -> Q Exp 132 | makeEqClass eClass name = do 133 | info <- reifyDatatype name 134 | case info of 135 | DatatypeInfo { datatypeContext = ctxt 136 | , datatypeName = parentName 137 | , datatypeInstTypes = instTypes 138 | , datatypeVariant = variant 139 | , datatypeCons = cons 140 | } -> do 141 | -- We force buildTypeInstance here since it performs some checks for whether 142 | -- or not the provided datatype can actually have (==)/liftEq/etc. 143 | -- implemented for it, and produces errors if it can't. 144 | buildTypeInstance eClass parentName ctxt instTypes variant 145 | >> makeEqForCons eClass instTypes cons 146 | 147 | -- | Generates a lambda expression for (==)/liftEq/etc. for the 148 | -- given constructors. All constructors must be from the same type. 149 | makeEqForCons :: EqClass -> [Type] -> [ConstructorInfo] -> Q Exp 150 | makeEqForCons eClass instTypes cons = do 151 | value1 <- newName "value1" 152 | value2 <- newName "value2" 153 | eqDefn <- newName "eqDefn" 154 | eqs <- newNameList "eq" $ arity eClass 155 | 156 | let lastTyVars = map varTToName $ drop (length instTypes - fromEnum eClass) instTypes 157 | tvMap = Map.fromList $ zipWith (\x y -> (x, OneName y)) lastTyVars eqs 158 | 159 | lamE (map varP $ eqs ++ [value1, value2] 160 | ) . appsE 161 | $ [ varE $ eqConstName eClass 162 | , letE [ funD eqDefn [eqClause tvMap] 163 | ] $ varE eqDefn `appE` varE value1 `appE` varE value2 164 | ] ++ map varE eqs 165 | ++ [varE value1, varE value2] 166 | where 167 | nonNullaryCons :: [ConstructorInfo] 168 | nonNullaryCons = filter (not . isNullaryCon) cons 169 | 170 | numNonNullaryCons :: Int 171 | numNonNullaryCons = length nonNullaryCons 172 | 173 | eqClause :: TyVarMap1 -> Q Clause 174 | eqClause tvMap 175 | | null cons 176 | = makeFallThroughCaseTrue 177 | -- Tag checking is redundant when there is only one data constructor 178 | | [con] <- cons 179 | = makeCaseForCon eClass tvMap con 180 | -- This is an enum (all constructors are nullary) - just do a simple tag check 181 | | all isNullaryCon cons 182 | = makeTagCase 183 | | otherwise 184 | = do abNames@(a, _, b, _) <- newABNames 185 | clause (map varP [a,b]) 186 | (normalB $ eqExprWithTagCheck tvMap abNames) 187 | [] 188 | 189 | eqExprWithTagCheck :: TyVarMap1 -> (Name, Name, Name, Name) -> Q Exp 190 | eqExprWithTagCheck tvMap (a, aHash, b, bHash) = 191 | condE (untagExpr [(a, aHash), (b, bHash)] 192 | (primOpAppExpr (varE aHash) neqIntHashValName (varE bHash))) 193 | (conE falseDataName) 194 | (caseE (varE a) 195 | (map (mkNestedMatchesForCon eClass tvMap b) nonNullaryCons 196 | ++ [ makeFallThroughMatchTrue 197 | | 0 < numNonNullaryCons && numNonNullaryCons < length cons 198 | ])) 199 | 200 | newABNames :: Q (Name, Name, Name, Name) 201 | newABNames = do 202 | a <- newName "a" 203 | aHash <- newName "a#" 204 | b <- newName "b" 205 | bHash <- newName "b#" 206 | return (a, aHash, b, bHash) 207 | 208 | makeTagCase :: Q Clause 209 | makeTagCase = do 210 | (a, aHash, b, bHash) <- newABNames 211 | clause (map varP [a,b]) 212 | (normalB $ untagExpr [(a, aHash), (b, bHash)] $ 213 | primOpAppExpr (varE aHash) eqIntHashValName (varE bHash)) [] 214 | 215 | makeFallThroughCaseTrue :: Q Clause 216 | makeFallThroughCaseTrue = clause [wildP, wildP] (normalB $ conE trueDataName) [] 217 | 218 | makeFallThroughMatchFalse, makeFallThroughMatchTrue :: Q Match 219 | makeFallThroughMatchFalse = makeFallThroughMatch falseDataName 220 | makeFallThroughMatchTrue = makeFallThroughMatch trueDataName 221 | 222 | makeFallThroughMatch :: Name -> Q Match 223 | makeFallThroughMatch dataName = match wildP (normalB $ conE dataName) [] 224 | 225 | makeCaseForCon :: EqClass -> TyVarMap1 -> ConstructorInfo -> Q Clause 226 | makeCaseForCon eClass tvMap 227 | (ConstructorInfo { constructorName = conName, constructorFields = ts }) = do 228 | ts' <- mapM resolveTypeSynonyms ts 229 | let tsLen = length ts' 230 | as <- newNameList "a" tsLen 231 | bs <- newNameList "b" tsLen 232 | clause [conP conName (map varP as), conP conName (map varP bs)] 233 | (normalB $ makeCaseForArgs eClass tvMap conName ts' as bs) 234 | [] 235 | 236 | mkNestedMatchesForCon :: EqClass -> TyVarMap1 -> Name -> ConstructorInfo -> Q Match 237 | mkNestedMatchesForCon eClass tvMap b 238 | (ConstructorInfo { constructorName = conName, constructorFields = ts }) = do 239 | ts' <- mapM resolveTypeSynonyms ts 240 | let tsLen = length ts' 241 | as <- newNameList "a" tsLen 242 | bs <- newNameList "b" tsLen 243 | match (conP conName (map varP as)) 244 | (normalB $ caseE (varE b) 245 | [ match (conP conName (map varP bs)) 246 | (normalB $ makeCaseForArgs eClass tvMap conName ts' as bs) 247 | [] 248 | , makeFallThroughMatchFalse 249 | ]) 250 | [] 251 | 252 | makeCaseForArgs :: EqClass 253 | -> TyVarMap1 254 | -> Name 255 | -> [Type] 256 | -> [Name] 257 | -> [Name] 258 | -> Q Exp 259 | makeCaseForArgs _ _ _ [] [] [] = conE trueDataName 260 | makeCaseForArgs eClass tvMap conName tys as bs = 261 | foldl1' (\q e -> infixApp q (varE andValName) e) 262 | (zipWith3 (makeCaseForArg eClass tvMap conName) tys as bs) 263 | 264 | makeCaseForArg :: EqClass 265 | -> TyVarMap1 266 | -> Name 267 | -> Type 268 | -> Name 269 | -> Name 270 | -> Q Exp 271 | makeCaseForArg _ _ _ (ConT tyName) a b = primEqExpr 272 | where 273 | aExpr, bExpr :: Q Exp 274 | aExpr = varE a 275 | bExpr = varE b 276 | 277 | makePrimEqExpr :: Name -> Q Exp 278 | makePrimEqExpr n = primOpAppExpr aExpr n bExpr 279 | 280 | primEqExpr :: Q Exp 281 | primEqExpr = 282 | case Map.lookup tyName primOrdFunTbl of 283 | Just (_, _, eq, _, _) -> makePrimEqExpr eq 284 | Nothing -> infixApp aExpr (varE eqValName) bExpr 285 | makeCaseForArg eClass tvMap conName ty a b = 286 | makeCaseForType eClass tvMap conName ty `appE` varE a `appE` varE b 287 | 288 | makeCaseForType :: EqClass 289 | -> TyVarMap1 290 | -> Name 291 | -> Type 292 | -> Q Exp 293 | makeCaseForType _ tvMap _ (VarT tyName) = 294 | varE $ case Map.lookup tyName tvMap of 295 | Just (OneName eq) -> eq 296 | Nothing -> eqValName 297 | makeCaseForType eClass tvMap conName (SigT ty _) = makeCaseForType eClass tvMap conName ty 298 | makeCaseForType eClass tvMap conName (ForallT _ _ ty) = makeCaseForType eClass tvMap conName ty 299 | makeCaseForType eClass tvMap conName ty = do 300 | let tyCon :: Type 301 | tyArgs :: [Type] 302 | (tyCon, tyArgs) = unapplyTy ty 303 | 304 | numLastArgs :: Int 305 | numLastArgs = min (arity eClass) (length tyArgs) 306 | 307 | lhsArgs, rhsArgs :: [Type] 308 | (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs 309 | 310 | tyVarNames :: [Name] 311 | tyVarNames = Map.keys tvMap 312 | 313 | itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs 314 | if any (`mentionsName` tyVarNames) lhsArgs 315 | || itf && any (`mentionsName` tyVarNames) tyArgs 316 | then outOfPlaceTyVarError eClass conName 317 | else if any (`mentionsName` tyVarNames) rhsArgs 318 | then appsE $ [ varE . eqName $ toEnum numLastArgs] 319 | ++ map (makeCaseForType eClass tvMap conName) rhsArgs 320 | else varE eqValName 321 | 322 | ------------------------------------------------------------------------------- 323 | -- Class-specific constants 324 | ------------------------------------------------------------------------------- 325 | 326 | -- | A representation of which @Eq@ variant is being derived. 327 | data EqClass = Eq 328 | | Eq1 329 | | Eq2 330 | deriving (Bounded, Enum) 331 | 332 | instance ClassRep EqClass where 333 | arity = fromEnum 334 | 335 | allowExQuant _ = True 336 | 337 | fullClassName Eq = eqTypeName 338 | fullClassName Eq1 = eq1TypeName 339 | fullClassName Eq2 = eq2TypeName 340 | 341 | classConstraint eClass i 342 | | eMin <= i && i <= eMax = Just $ fullClassName (toEnum i :: EqClass) 343 | | otherwise = Nothing 344 | where 345 | eMin, eMax :: Int 346 | eMin = fromEnum (minBound :: EqClass) 347 | eMax = fromEnum eClass 348 | 349 | eqConstName :: EqClass -> Name 350 | eqConstName Eq = eqConstValName 351 | eqConstName Eq1 = liftEqConstValName 352 | eqConstName Eq2 = liftEq2ConstValName 353 | 354 | eqName :: EqClass -> Name 355 | eqName Eq = eqValName 356 | eqName Eq1 = liftEqValName 357 | eqName Eq2 = liftEq2ValName 358 | -------------------------------------------------------------------------------- /tests/FunctorSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyCase #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE MagicHash #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE RoleAnnotations #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TemplateHaskell #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE TypeOperators #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | 15 | {-# OPTIONS_GHC -Wno-name-shadowing #-} 16 | {-# OPTIONS_GHC -Wno-unused-matches #-} 17 | {-# OPTIONS_GHC -Wno-unused-foralls #-} 18 | 19 | {-| 20 | Module: FunctorSpec 21 | Copyright: (C) 2015-2017 Ryan Scott 22 | License: BSD-style (see the file LICENSE) 23 | Maintainer: Ryan Scott 24 | Portability: Template Haskell 25 | 26 | @hspec@ tests for derived 'Functor', 'Foldable', and 'Traversable' instances. 27 | -} 28 | module FunctorSpec where 29 | 30 | import Data.Char (chr) 31 | import Data.Foldable (fold) 32 | import Data.Deriving 33 | import Data.Functor.Classes (Eq1, Show1) 34 | import Data.Functor.Compose (Compose(..)) 35 | import Data.Functor.Identity (Identity(..)) 36 | import Data.Monoid 37 | import Data.Orphans () 38 | 39 | import GHC.Exts (Int#) 40 | 41 | import Test.Hspec 42 | import Test.Hspec.QuickCheck (prop) 43 | import Test.QuickCheck (Arbitrary) 44 | 45 | ------------------------------------------------------------------------------- 46 | 47 | -- Adapted from the test cases from 48 | -- https://ghc.haskell.org/trac/ghc/attachment/ticket/2953/deriving-functor-tests.patch 49 | 50 | -- Plain data types 51 | 52 | data Strange a b c 53 | = T1 a b c 54 | | T2 [a] [b] [c] -- lists 55 | | T3 [[a]] [[b]] [[c]] -- nested lists 56 | | T4 (c,(b,b),(c,c)) -- tuples 57 | | T5 ([c],Strange a b c) -- tycons 58 | 59 | type IntFun a b = (b -> Int) -> a 60 | data StrangeFunctions a b c 61 | = T6 (a -> c) -- function types 62 | | T7 (a -> (c,a)) -- functions and tuples 63 | | T8 ((b -> a) -> c) -- continuation 64 | | T9 (IntFun b c) -- type synonyms 65 | 66 | data StrangeGADT a b where 67 | T10 :: Ord d => d -> StrangeGADT c d 68 | T11 :: Int -> StrangeGADT e Int 69 | T12 :: c ~ Int => c -> StrangeGADT f Int 70 | T13 :: i ~ Int => Int -> StrangeGADT h i 71 | T14 :: k ~ Int => k -> StrangeGADT j k 72 | T15 :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADT m n 73 | 74 | data NotPrimitivelyRecursive a b 75 | = S1 (NotPrimitivelyRecursive (a,a) (b, a)) 76 | | S2 a 77 | | S3 b 78 | 79 | newtype OneTwoCompose f g a b = OneTwoCompose (Either (f (g a)) (f (g b))) 80 | deriving (Arbitrary, Eq, Show) 81 | 82 | newtype ComplexConstraint f g a b = ComplexConstraint (f Int Int (g a,a,b)) 83 | 84 | data Universal a b 85 | = Universal (forall b. (b,[a])) 86 | | Universal2 (forall f. Functor (f a) => f a b) 87 | | Universal3 (forall a. Maybe a) -- reuse a 88 | | NotReallyUniversal (forall b. a) 89 | 90 | data Existential a b 91 | = forall a. ExistentialList [a] 92 | | forall f. Traversable (f a) => ExistentialFunctor (f a b) 93 | | forall b. SneakyUseSameName (Maybe b) 94 | 95 | data IntHash a b 96 | = IntHash Int# Int# 97 | | IntHashTuple Int# a b (a, b, Int, IntHash Int (a, b, Int)) 98 | 99 | data IntHashFun a b 100 | = IntHashFun ((((a -> Int#) -> b) -> Int#) -> a) 101 | 102 | data Empty1 a 103 | data Empty2 a 104 | type role Empty2 nominal 105 | 106 | data TyCon29 a 107 | = TyCon29a (forall b. b -> (forall c. a -> c) -> a) 108 | | TyCon29b (Int -> forall c. c -> a) 109 | 110 | type family F :: * -> * 111 | type instance F = Maybe 112 | 113 | data TyCon30 a = TyCon30 (F a) 114 | 115 | -- Data families 116 | 117 | data family StrangeFam x y z 118 | data instance StrangeFam a b c 119 | = T1Fam a b c 120 | | T2Fam [a] [b] [c] -- lists 121 | | T3Fam [[a]] [[b]] [[c]] -- nested lists 122 | | T4Fam (c,(b,b),(c,c)) -- tuples 123 | | T5Fam ([c],Strange a b c) -- tycons 124 | 125 | data family StrangeFunctionsFam x y z 126 | data instance StrangeFunctionsFam a b c 127 | = T6Fam (a -> c) -- function types 128 | | T7Fam (a -> (c,a)) -- functions and tuples 129 | | T8Fam ((b -> a) -> c) -- continuation 130 | | T9Fam (IntFun b c) -- type synonyms 131 | 132 | data family StrangeGADTFam x y 133 | data instance StrangeGADTFam a b where 134 | T10Fam :: Ord d => d -> StrangeGADTFam c d 135 | T11Fam :: Int -> StrangeGADTFam e Int 136 | T12Fam :: c ~ Int => c -> StrangeGADTFam f Int 137 | T13Fam :: i ~ Int => Int -> StrangeGADTFam h i 138 | T14Fam :: k ~ Int => k -> StrangeGADTFam j k 139 | T15Fam :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADTFam m n 140 | 141 | data family NotPrimitivelyRecursiveFam x y 142 | data instance NotPrimitivelyRecursiveFam a b 143 | = S1Fam (NotPrimitivelyRecursive (a,a) (b, a)) 144 | | S2Fam a 145 | | S3Fam b 146 | 147 | data family OneTwoComposeFam (j :: * -> *) (k :: * -> *) x y 148 | newtype instance OneTwoComposeFam f g a b = 149 | OneTwoComposeFam (Either (f (g a)) (f (g b))) 150 | deriving (Arbitrary, Eq, Show) 151 | 152 | data family ComplexConstraintFam (j :: * -> * -> * -> *) (k :: * -> *) x y 153 | newtype instance ComplexConstraintFam f g a b = ComplexConstraintFam (f Int Int (g a,a,b)) 154 | 155 | data family UniversalFam x y 156 | data instance UniversalFam a b 157 | = UniversalFam (forall b. (b,[a])) 158 | | Universal2Fam (forall f. Functor (f a) => f a b) 159 | | Universal3Fam (forall a. Maybe a) -- reuse a 160 | | NotReallyUniversalFam (forall b. a) 161 | 162 | data family ExistentialFam x y 163 | data instance ExistentialFam a b 164 | = forall a. ExistentialListFam [a] 165 | | forall f. Traversable (f a) => ExistentialFunctorFam (f a b) 166 | | forall b. SneakyUseSameNameFam (Maybe b) 167 | 168 | data family IntHashFam x y 169 | data instance IntHashFam a b 170 | = IntHashFam Int# Int# 171 | | IntHashTupleFam Int# a b (a, b, Int, IntHashFam Int (a, b, Int)) 172 | 173 | data family IntHashFunFam x y 174 | data instance IntHashFunFam a b 175 | = IntHashFunFam ((((a -> Int#) -> b) -> Int#) -> a) 176 | 177 | data family TyFamily29 x 178 | data instance TyFamily29 a 179 | = TyFamily29a (forall b. b -> (forall c. a -> c) -> a) 180 | | TyFamily29b (Int -> forall c. c -> a) 181 | 182 | data family TyFamily30 x 183 | data instance TyFamily30 a = TyFamily30 (F a) 184 | 185 | ------------------------------------------------------------------------------- 186 | 187 | -- Plain data types 188 | 189 | $(deriveFunctor ''Strange) 190 | $(deriveFoldable ''Strange) 191 | $(deriveTraversable ''Strange) 192 | 193 | $(deriveFunctor ''StrangeFunctions) 194 | $(deriveFoldable ''StrangeGADT) 195 | 196 | $(deriveFunctor ''NotPrimitivelyRecursive) 197 | $(deriveFoldable ''NotPrimitivelyRecursive) 198 | $(deriveTraversable ''NotPrimitivelyRecursive) 199 | 200 | $(deriveFunctor ''OneTwoCompose) 201 | $(deriveFoldable ''OneTwoCompose) 202 | $(deriveTraversable ''OneTwoCompose) 203 | 204 | instance Functor (f Int Int) => Functor (ComplexConstraint f g a) where 205 | fmap = $(makeFmap ''ComplexConstraint) 206 | (<$) = $(makeReplace ''ComplexConstraint) 207 | instance Foldable (f Int Int) => Foldable (ComplexConstraint f g a) where 208 | foldr = $(makeFoldr ''ComplexConstraint) 209 | foldMap = $(makeFoldMap ''ComplexConstraint) 210 | fold = $(makeFold ''ComplexConstraint) 211 | foldl = $(makeFoldl ''ComplexConstraint) 212 | null = $(makeNull ''ComplexConstraint) 213 | instance Traversable (f Int Int) => Traversable (ComplexConstraint f g a) where 214 | traverse = $(makeTraverse ''ComplexConstraint) 215 | sequenceA = $(makeSequenceA ''ComplexConstraint) 216 | mapM = $(makeMapM ''ComplexConstraint) 217 | sequence = $(makeSequence ''ComplexConstraint) 218 | 219 | $(deriveFunctor ''Universal) 220 | 221 | $(deriveFunctor ''Existential) 222 | $(deriveFoldable ''Existential) 223 | $(deriveTraversable ''Existential) 224 | 225 | $(deriveFunctor ''IntHash) 226 | $(deriveFoldable ''IntHash) 227 | $(deriveTraversable ''IntHash) 228 | 229 | $(deriveFunctor ''IntHashFun) 230 | 231 | $(deriveFunctor ''Empty1) 232 | $(deriveFoldable ''Empty1) 233 | $(deriveTraversable ''Empty1) 234 | 235 | -- Use EmptyCase here 236 | $(deriveFunctorOptions defaultFFTOptions{ fftEmptyCaseBehavior = True } ''Empty2) 237 | $(deriveFoldableOptions defaultFFTOptions{ fftEmptyCaseBehavior = True } ''Empty2) 238 | $(deriveTraversableOptions defaultFFTOptions{ fftEmptyCaseBehavior = True } ''Empty2) 239 | 240 | $(deriveFunctor ''TyCon29) 241 | 242 | $(deriveFunctor ''TyCon30) 243 | $(deriveFoldable ''TyCon30) 244 | $(deriveTraversable ''TyCon30) 245 | 246 | -- Data families 247 | 248 | $(deriveFunctor 'T1Fam) 249 | $(deriveFoldable 'T2Fam) 250 | $(deriveTraversable 'T3Fam) 251 | 252 | $(deriveFunctor 'T6Fam) 253 | $(deriveFoldable 'T10Fam) 254 | 255 | $(deriveFunctor 'S1Fam) 256 | $(deriveFoldable 'S2Fam) 257 | $(deriveTraversable 'S3Fam) 258 | 259 | $(deriveFunctor 'OneTwoComposeFam) 260 | $(deriveFoldable 'OneTwoComposeFam) 261 | $(deriveTraversable 'OneTwoComposeFam) 262 | 263 | instance Functor (f Int Int) => Functor (ComplexConstraintFam f g a) where 264 | fmap = $(makeFmap 'ComplexConstraintFam) 265 | (<$) = $(makeReplace 'ComplexConstraintFam) 266 | instance Foldable (f Int Int) => Foldable (ComplexConstraintFam f g a) where 267 | foldr = $(makeFoldr 'ComplexConstraintFam) 268 | foldMap = $(makeFoldMap 'ComplexConstraintFam) 269 | fold = $(makeFold 'ComplexConstraintFam) 270 | foldl = $(makeFoldl 'ComplexConstraintFam) 271 | null = $(makeNull 'ComplexConstraintFam) 272 | instance Traversable (f Int Int) => Traversable (ComplexConstraintFam f g a) where 273 | traverse = $(makeTraverse 'ComplexConstraintFam) 274 | sequenceA = $(makeSequenceA 'ComplexConstraintFam) 275 | mapM = $(makeMapM 'ComplexConstraintFam) 276 | sequence = $(makeSequence 'ComplexConstraintFam) 277 | 278 | $(deriveFunctor 'UniversalFam) 279 | 280 | $(deriveFunctor 'ExistentialListFam) 281 | $(deriveFoldable 'ExistentialFunctorFam) 282 | $(deriveTraversable 'SneakyUseSameNameFam) 283 | 284 | $(deriveFunctor 'IntHashFam) 285 | $(deriveFoldable 'IntHashTupleFam) 286 | $(deriveTraversable 'IntHashFam) 287 | 288 | $(deriveFunctor 'IntHashFunFam) 289 | 290 | $(deriveFunctor 'TyFamily29a) 291 | 292 | $(deriveFunctor 'TyFamily30) 293 | $(deriveFoldable 'TyFamily30) 294 | $(deriveTraversable 'TyFamily30) 295 | 296 | ------------------------------------------------------------------------------- 297 | 298 | prop_FunctorLaws :: (Functor f, Eq (f a), Eq (f c), Show (f a), Show (f c)) 299 | => (b -> c) -> (a -> b) -> f a -> Expectation 300 | prop_FunctorLaws f g x = do 301 | fmap id x `shouldBe` x 302 | fmap (f . g) x `shouldBe` (fmap f . fmap g) x 303 | 304 | prop_FunctorEx :: (Functor f, Eq (f [Int]), Show (f [Int])) => f [Int] -> Expectation 305 | prop_FunctorEx = prop_FunctorLaws reverse (++ [42]) 306 | 307 | prop_FoldableLaws :: (Eq a, Eq b, Eq z, Show a, Show b, Show z, 308 | Monoid a, Monoid b, Foldable f) 309 | => (a -> b) -> (a -> z -> z) -> z -> f a -> Expectation 310 | prop_FoldableLaws f h z x = do 311 | fold x `shouldBe` foldMap id x 312 | foldMap f x `shouldBe` foldr (mappend . f) mempty x 313 | foldr h z x `shouldBe` appEndo (foldMap (Endo . h) x) z 314 | 315 | prop_FoldableEx :: Foldable f => f [Int] -> Expectation 316 | prop_FoldableEx = prop_FoldableLaws reverse ((+) . length) 0 317 | 318 | prop_TraversableLaws :: forall t f g a b c. 319 | (Applicative f, Applicative g, Traversable t, 320 | Eq (t (f a)), Eq (g (t a)), Eq (g (t b)), 321 | Eq (t a), Eq (t c), Eq1 f, Eq1 g, 322 | Show (t (f a)), Show (g (t a)), Show (g (t b)), 323 | Show (t a), Show (t c), Show1 f, Show1 g) 324 | => (a -> f b) -> (b -> f c) 325 | -> (forall x. f x -> g x) -> t a -> Expectation 326 | prop_TraversableLaws f g t x = do 327 | (t . traverse f) x `shouldBe` traverse (t . f) x 328 | traverse Identity x `shouldBe` Identity x 329 | traverse (Compose . fmap g . f) x 330 | `shouldBe` (Compose . fmap (traverse g) . traverse f) x 331 | 332 | (t . sequenceA) y `shouldBe` (sequenceA . fmap t) y 333 | (sequenceA . fmap Identity) y `shouldBe` Identity y 334 | (sequenceA . fmap Compose) z 335 | `shouldBe` (Compose . fmap sequenceA . sequenceA) z 336 | where 337 | y :: t (f a) 338 | y = fmap pure x 339 | 340 | z :: t (f (g a)) 341 | z = fmap (fmap pure) y 342 | 343 | prop_TraversableEx :: (Traversable t, 344 | Eq (t [[Int]]), Eq (t [Int]), Eq (t String), Eq (t Char), 345 | Show (t [[Int]]), Show (t [Int]), Show (t String), Show (t Char)) 346 | => t [Int] -> Expectation 347 | prop_TraversableEx = prop_TraversableLaws 348 | (replicate 2 . map (chr . abs)) 349 | (++ "Hello") 350 | reverse 351 | 352 | ------------------------------------------------------------------------------- 353 | 354 | main :: IO () 355 | main = hspec spec 356 | 357 | spec :: Spec 358 | spec = parallel $ do 359 | describe "OneTwoCompose Maybe ((,) Bool) [Int] [Int]" $ do 360 | prop "satisfies the Functor laws" 361 | (prop_FunctorEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Expectation) 362 | prop "satisfies the Foldable laws" 363 | (prop_FoldableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Expectation) 364 | prop "satisfies the Traversable laws" 365 | (prop_TraversableEx :: OneTwoCompose Maybe ((,) Bool) [Int] [Int] -> Expectation) 366 | describe "OneTwoComposeFam Maybe ((,) Bool) [Int] [Int]" $ do 367 | prop "satisfies the Functor laws" 368 | (prop_FunctorEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Expectation) 369 | prop "satisfies the Foldable laws" 370 | (prop_FoldableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Expectation) 371 | prop "satisfies the Traversable laws" 372 | (prop_TraversableEx :: OneTwoComposeFam Maybe ((,) Bool) [Int] [Int] -> Expectation) 373 | -------------------------------------------------------------------------------- /src/Data/Ord/Deriving/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | {-| 4 | Module: Data.Ord.Deriving.Internal 5 | Copyright: (C) 2015-2017 Ryan Scott 6 | License: BSD-style (see the file LICENSE) 7 | Maintainer: Ryan Scott 8 | Portability: Template Haskell 9 | 10 | Exports functions to mechanically derive 'Ord', 'Ord1', and 'Ord2' instances. 11 | 12 | Note: this is an internal module, and as such, the API presented here is not 13 | guaranteed to be stable, even between minor releases of this library. 14 | -} 15 | module Data.Ord.Deriving.Internal ( 16 | -- * 'Ord' 17 | deriveOrd 18 | , makeCompare 19 | , makeLE 20 | , makeLT 21 | , makeGT 22 | , makeGE 23 | , makeMax 24 | , makeMin 25 | -- * 'Ord1' 26 | , deriveOrd1 27 | , makeLiftCompare 28 | , makeCompare1 29 | -- * 'Ord2' 30 | , deriveOrd2 31 | , makeLiftCompare2 32 | , makeCompare2 33 | ) where 34 | 35 | import Data.Deriving.Internal 36 | import Data.List (partition) 37 | import qualified Data.List.NonEmpty as NE 38 | import Data.List.NonEmpty (NonEmpty(..)) 39 | import qualified Data.Map as Map 40 | import Data.Map (Map) 41 | 42 | import Language.Haskell.TH.Datatype 43 | import Language.Haskell.TH.Lib 44 | import Language.Haskell.TH.Syntax 45 | 46 | -- | Generates an 'Ord' instance declaration for the given data type or data 47 | -- family instance. 48 | deriveOrd :: Name -> Q [Dec] 49 | deriveOrd = deriveOrdClass Ord 50 | 51 | -- | Generates a lambda expression which behaves like 'compare' (without 52 | -- requiring an 'Ord' instance). 53 | makeCompare :: Name -> Q Exp 54 | makeCompare = makeOrdFun OrdCompare (error "This shouldn't happen") 55 | 56 | -- | Generates a lambda expression which behaves like '(<)' (without 57 | -- requiring an 'Ord' instance). 58 | makeLT :: Name -> Q Exp 59 | makeLT = makeOrdFun OrdLT [ match (conP ltDataName []) (normalB $ conE trueDataName) [] 60 | , match wildP (normalB $ conE falseDataName) [] 61 | ] 62 | 63 | -- | Generates a lambda expression which behaves like '(<=)' (without 64 | -- requiring an 'Ord' instance). 65 | makeLE :: Name -> Q Exp 66 | makeLE = makeOrdFun OrdLE [ match (conP gtDataName []) (normalB $ conE falseDataName) [] 67 | , match wildP (normalB $ conE trueDataName) [] 68 | ] 69 | 70 | -- | Generates a lambda expression which behaves like '(>)' (without 71 | -- requiring an 'Ord' instance). 72 | makeGT :: Name -> Q Exp 73 | makeGT = makeOrdFun OrdGT [ match (conP gtDataName []) (normalB $ conE trueDataName) [] 74 | , match wildP (normalB $ conE falseDataName) [] 75 | ] 76 | 77 | -- | Generates a lambda expression which behaves like '(>=)' (without 78 | -- requiring an 'Ord' instance). 79 | makeGE :: Name -> Q Exp 80 | makeGE = makeOrdFun OrdGE [ match (conP ltDataName []) (normalB $ conE falseDataName) [] 81 | , match wildP (normalB $ conE trueDataName) [] 82 | ] 83 | 84 | -- | Generates a lambda expression which behaves like 'max' (without 85 | -- requiring an 'Ord' instance). 86 | makeMax :: Name -> Q Exp 87 | makeMax = makeMinMax flip 88 | 89 | -- | Generates a lambda expression which behaves like 'min' (without 90 | -- requiring an 'Ord' instance). 91 | makeMin :: Name -> Q Exp 92 | makeMin = makeMinMax id 93 | 94 | makeMinMax :: ((Q Exp -> Q Exp -> Q Exp) -> Q Exp -> Q Exp -> Q Exp) 95 | -> Name -> Q Exp 96 | makeMinMax f name = do 97 | x <- newName "x" 98 | y <- newName "y" 99 | let xExpr = varE x 100 | yExpr = varE y 101 | lamE [varP x, varP y] $ 102 | f (condE $ makeLE name `appE` xExpr `appE` yExpr) xExpr yExpr 103 | 104 | -- | Generates an 'Ord1' instance declaration for the given data type or data 105 | -- family instance. 106 | deriveOrd1 :: Name -> Q [Dec] 107 | deriveOrd1 = deriveOrdClass Ord1 108 | 109 | -- | Generates a lambda expression which behaves like 'liftCompare' (without 110 | -- requiring an 'Ord1' instance). 111 | -- 112 | -- This function is not available with @transformers-0.4@. 113 | makeLiftCompare :: Name -> Q Exp 114 | makeLiftCompare = makeOrdFun Ord1LiftCompare (error "This shouldn't happen") 115 | 116 | -- | Generates a lambda expression which behaves like 'compare1' (without 117 | -- requiring an 'Ord1' instance). 118 | makeCompare1 :: Name -> Q Exp 119 | makeCompare1 name = makeLiftCompare name `appE` varE compareValName 120 | 121 | -- | Generates an 'Ord2' instance declaration for the given data type or data 122 | -- family instance. 123 | -- 124 | -- This function is not available with @transformers-0.4@. 125 | deriveOrd2 :: Name -> Q [Dec] 126 | deriveOrd2 = deriveOrdClass Ord2 127 | 128 | -- | Generates a lambda expression which behaves like 'liftCompare2' (without 129 | -- requiring an 'Ord2' instance). 130 | -- 131 | -- This function is not available with @transformers-0.4@. 132 | makeLiftCompare2 :: Name -> Q Exp 133 | makeLiftCompare2 = makeOrdFun Ord2LiftCompare2 (error "This shouldn't happen") 134 | 135 | -- | Generates a lambda expression which behaves like 'compare2' (without 136 | -- requiring an 'Ord2' instance). 137 | -- 138 | -- This function is not available with @transformers-0.4@. 139 | makeCompare2 :: Name -> Q Exp 140 | makeCompare2 name = makeLiftCompare name 141 | `appE` varE compareValName 142 | `appE` varE compareValName 143 | 144 | ------------------------------------------------------------------------------- 145 | -- Code generation 146 | ------------------------------------------------------------------------------- 147 | 148 | -- | Derive an Ord(1)(2) instance declaration (depending on the OrdClass 149 | -- argument's value). 150 | deriveOrdClass :: OrdClass -> Name -> Q [Dec] 151 | deriveOrdClass oClass name = do 152 | info <- reifyDatatype name 153 | case info of 154 | DatatypeInfo { datatypeContext = ctxt 155 | , datatypeName = parentName 156 | , datatypeInstTypes = instTypes 157 | , datatypeVariant = variant 158 | , datatypeCons = cons 159 | } -> do 160 | (instanceCxt, instanceType) 161 | <- buildTypeInstance oClass parentName ctxt instTypes variant 162 | (:[]) `fmap` instanceD (return instanceCxt) 163 | (return instanceType) 164 | (ordFunDecs oClass instTypes cons) 165 | 166 | -- | Generates a declaration defining the primary function(s) corresponding to a 167 | -- particular class (compare for Ord, liftCompare for Ord1, and 168 | -- liftCompare2 for Ord2). 169 | ordFunDecs :: OrdClass -> [Type] -> [ConstructorInfo] -> [Q Dec] 170 | ordFunDecs oClass instTypes cons = 171 | map makeFunD $ ordClassToCompare oClass : otherFuns oClass cons 172 | where 173 | makeFunD :: OrdFun -> Q Dec 174 | makeFunD oFun = 175 | funD (ordFunName oFun $ arity oClass) 176 | [ clause [] 177 | (normalB $ dispatchFun oFun) 178 | [] 179 | ] 180 | 181 | negateExpr :: Q Exp -> Q Exp 182 | negateExpr = appE (varE notValName) 183 | 184 | dispatchLT :: (Q Exp -> Q Exp -> Q Exp -> Q Exp) -> Q Exp 185 | dispatchLT f = do 186 | x <- newName "x" 187 | y <- newName "y" 188 | lamE [varP x, varP y] $ f (varE ltValName) (varE x) (varE y) 189 | 190 | dispatchFun :: OrdFun -> Q Exp 191 | dispatchFun oFun | oFun `elem` [ OrdCompare, OrdLT 192 | -- OrdLT is included to mirror the fix to 193 | -- GHC Trac #10858. 194 | , Ord1LiftCompare, Ord2LiftCompare2 195 | ] 196 | = makeOrdFunForCons oFun instTypes cons 197 | dispatchFun OrdLE = dispatchLT $ \lt x y -> negateExpr $ lt `appE` y `appE` x 198 | dispatchFun OrdGT = dispatchLT $ \lt x y -> lt `appE` y `appE` x 199 | dispatchFun OrdGE = dispatchLT $ \lt x y -> negateExpr $ lt `appE` x `appE` y 200 | dispatchFun _ = fail "ordFunDecs" 201 | 202 | -- | Generates a lambda expression which behaves like the OrdFun value. This 203 | -- function uses heuristics to determine whether to implement the OrdFun from 204 | -- scratch or define it in terms of compare. 205 | makeOrdFun :: OrdFun -> [Q Match] -> Name -> Q Exp 206 | makeOrdFun oFun matches name = do 207 | info <- reifyDatatype name 208 | case info of 209 | DatatypeInfo { datatypeContext = ctxt 210 | , datatypeName = parentName 211 | , datatypeInstTypes = instTypes 212 | , datatypeVariant = variant 213 | , datatypeCons = cons 214 | } -> do 215 | let oClass = ordFunToClass oFun 216 | others = otherFuns oClass cons 217 | -- We force buildTypeInstance here since it performs some checks for whether 218 | -- or not the provided datatype can actually have compare/liftCompare/etc. 219 | -- implemented for it, and produces errors if it can't. 220 | buildTypeInstance oClass parentName ctxt instTypes variant >> 221 | if oFun `elem` compareFuns || oFun `elem` others 222 | then makeOrdFunForCons oFun instTypes cons 223 | else do 224 | x <- newName "x" 225 | y <- newName "y" 226 | lamE [varP x, varP y] $ 227 | caseE (makeOrdFunForCons (ordClassToCompare oClass) instTypes cons 228 | `appE` varE x `appE` varE y) 229 | matches 230 | where 231 | compareFuns :: [OrdFun] 232 | compareFuns = [ OrdCompare 233 | , Ord1LiftCompare 234 | , Ord2LiftCompare2 235 | ] 236 | 237 | -- | Generates a lambda expression for the given constructors. 238 | -- All constructors must be from the same type. 239 | makeOrdFunForCons :: OrdFun -> [Type] -> [ConstructorInfo] -> Q Exp 240 | makeOrdFunForCons oFun instTypes cons = do 241 | let oClass = ordFunToClass oFun 242 | v1 <- newName "v1" 243 | v2 <- newName "v2" 244 | v1Hash <- newName "v1#" 245 | v2Hash <- newName "v2#" 246 | ords <- newNameList "ord" $ arity oClass 247 | 248 | let lastTyVars :: [Name] 249 | lastTyVars = map varTToName $ drop (length instTypes - fromEnum oClass) instTypes 250 | 251 | tvMap :: TyVarMap1 252 | tvMap = Map.fromList $ zipWith (\x y -> (x, OneName y)) lastTyVars ords 253 | 254 | nullaryCons, nonNullaryCons :: [ConstructorInfo] 255 | (nullaryCons, nonNullaryCons) = partition isNullaryCon cons 256 | 257 | singleConType :: Bool 258 | singleConType = isSingleton cons 259 | 260 | -- Alternatively, we could look these up from dataConTagMap, but this 261 | -- is slightly faster due to the lack of Map lookups. 262 | firstTag, lastTag :: Int 263 | firstTag = 0 264 | lastTag = length cons - 1 265 | 266 | dataConTagMap :: Map Name Int 267 | dataConTagMap = Map.fromList $ zip (map constructorName cons) [0..] 268 | 269 | ordFunRhs :: Q Exp 270 | ordFunRhs = 271 | case cons of 272 | [] -> conE eqDataName 273 | c:cs -> ordFunRhsNonEmptyCons (c :| cs) 274 | 275 | ordFunRhsNonEmptyCons :: NonEmpty ConstructorInfo -> Q Exp 276 | ordFunRhsNonEmptyCons cs@(c :| _) 277 | | length nullaryCons <= 2 278 | = caseE (varE v1) $ map ordMatches $ NE.toList cs 279 | | null nonNullaryCons 280 | = mkTagCmp 281 | | otherwise 282 | = caseE (varE v1) $ map ordMatches nonNullaryCons 283 | ++ [match wildP (normalB mkTagCmp) []] 284 | where 285 | firstConName, lastConName :: Name 286 | firstConName = constructorName c 287 | lastConName = constructorName $ NE.last cs 288 | 289 | ordMatches :: ConstructorInfo -> Q Match 290 | ordMatches = makeOrdFunForCon oFun v2 v2Hash tvMap singleConType 291 | firstTag firstConName lastTag lastConName 292 | dataConTagMap 293 | 294 | mkTagCmp :: Q Exp 295 | mkTagCmp = untagExpr [(v1, v1Hash), (v2, v2Hash)] $ 296 | unliftedOrdFun intHashTypeName oFun v1Hash v2Hash 297 | 298 | lamE (map varP $ ords ++ [v1, v2]) 299 | . appsE 300 | $ [ varE $ compareConstName oFun 301 | , ordFunRhs 302 | ] ++ map varE ords 303 | ++ [varE v1, varE v2] 304 | 305 | makeOrdFunForCon :: OrdFun 306 | -> Name 307 | -> Name 308 | -> TyVarMap1 309 | -> Bool 310 | -> Int -> Name 311 | -> Int -> Name 312 | -> Map Name Int 313 | -> ConstructorInfo -> Q Match 314 | makeOrdFunForCon oFun v2 v2Hash tvMap singleConType 315 | firstTag firstConName lastTag lastConName dataConTagMap 316 | (ConstructorInfo { constructorName = conName, constructorFields = ts }) = do 317 | ts' <- mapM resolveTypeSynonyms ts 318 | let tsLen = length ts' 319 | as <- newNameList "a" tsLen 320 | bs <- newNameList "b" tsLen 321 | 322 | let innerRhs :: Q Exp 323 | innerRhs 324 | | singleConType 325 | = caseE (varE v2) [innerEqAlt] 326 | 327 | | tag == firstTag 328 | = caseE (varE v2) [innerEqAlt, match wildP (normalB $ ltResult oFun) []] 329 | 330 | | tag == lastTag 331 | = caseE (varE v2) [innerEqAlt, match wildP (normalB $ gtResult oFun) []] 332 | 333 | | tag == firstTag + 1 334 | = caseE (varE v2) [ match (recP firstConName []) (normalB $ gtResult oFun) [] 335 | , innerEqAlt 336 | , match wildP (normalB $ ltResult oFun) [] 337 | ] 338 | 339 | | tag == lastTag - 1 340 | = caseE (varE v2) [ match (recP lastConName []) (normalB $ ltResult oFun) [] 341 | , innerEqAlt 342 | , match wildP (normalB $ gtResult oFun) [] 343 | ] 344 | 345 | | tag > lastTag `div` 2 346 | = untagExpr [(v2, v2Hash)] $ 347 | condE (primOpAppExpr (varE v2Hash) ltIntHashValName tagLit) 348 | (gtResult oFun) $ 349 | caseE (varE v2) [innerEqAlt, match wildP (normalB $ ltResult oFun) []] 350 | 351 | | otherwise 352 | = untagExpr [(v2, v2Hash)] $ 353 | condE (primOpAppExpr (varE v2Hash) gtIntHashValName tagLit) 354 | (ltResult oFun) $ 355 | caseE (varE v2) [innerEqAlt, match wildP (normalB $ gtResult oFun) []] 356 | 357 | innerEqAlt :: Q Match 358 | innerEqAlt = match (conP conName $ map varP bs) 359 | (normalB $ makeOrdFunForFields oFun tvMap conName ts' as bs) 360 | [] 361 | 362 | tagLit :: Q Exp 363 | tagLit = litE . intPrimL $ fromIntegral tag 364 | 365 | match (conP conName $ map varP as) 366 | (normalB innerRhs) 367 | [] 368 | where 369 | tag = dataConTagMap Map.! conName 370 | 371 | makeOrdFunForFields :: OrdFun 372 | -> TyVarMap1 373 | -> Name 374 | -> [Type] 375 | -> [Name] 376 | -> [Name] 377 | -> Q Exp 378 | makeOrdFunForFields oFun tvMap conName = go 379 | where 380 | go :: [Type] -> [Name] -> [Name] -> Q Exp 381 | go [] _ _ = eqResult oFun 382 | go [ty] [a] [b] 383 | | isSupportedUnliftedType ty = unliftedOrdFun (conTToName ty) oFun a b 384 | | otherwise = makeOrdFunForType oFun tvMap conName ty 385 | `appE` varE a `appE` varE b 386 | go (ty:tys) (a:as) (b:bs) = 387 | mkCompare ty a b (ltResult oFun) (go tys as bs) (gtResult oFun) 388 | go _ _ _ = fail "Data.Ord.Deriving.Internal.makeOrdFunForFields" 389 | 390 | mkCompare :: Type -> Name -> Name -> Q Exp -> Q Exp -> Q Exp -> Q Exp 391 | mkCompare ty a b lt eq gt 392 | | isSupportedUnliftedType ty = 393 | let (ltFun, _, eqFun, _, _) = primOrdFuns $ conTToName ty 394 | in unliftedCompare ltFun eqFun aExpr bExpr lt eq gt 395 | | otherwise 396 | = caseE (makeOrdFunForType (ordClassToCompare $ ordFunToClass oFun) 397 | tvMap conName ty `appE` aExpr `appE` bExpr) 398 | [ match (conP ltDataName []) (normalB lt) [] 399 | , match (conP eqDataName []) (normalB eq) [] 400 | , match (conP gtDataName []) (normalB gt) [] 401 | ] 402 | where 403 | aExpr, bExpr :: Q Exp 404 | aExpr = varE a 405 | bExpr = varE b 406 | 407 | makeOrdFunForType :: OrdFun 408 | -> TyVarMap1 409 | -> Name 410 | -> Type 411 | -> Q Exp 412 | makeOrdFunForType oFun tvMap _ (VarT tyName) = 413 | varE $ case Map.lookup tyName tvMap of 414 | Just (OneName ord) -> ord 415 | Nothing -> ordFunName oFun 0 416 | makeOrdFunForType oFun tvMap conName (SigT ty _) = makeOrdFunForType oFun tvMap conName ty 417 | makeOrdFunForType oFun tvMap conName (ForallT _ _ ty) = makeOrdFunForType oFun tvMap conName ty 418 | makeOrdFunForType oFun tvMap conName ty = do 419 | let oClass :: OrdClass 420 | oClass = ordFunToClass oFun 421 | 422 | tyCon :: Type 423 | tyArgs :: [Type] 424 | (tyCon, tyArgs) = unapplyTy ty 425 | 426 | numLastArgs :: Int 427 | numLastArgs = min (arity oClass) (length tyArgs) 428 | 429 | lhsArgs, rhsArgs :: [Type] 430 | (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs 431 | 432 | tyVarNames :: [Name] 433 | tyVarNames = Map.keys tvMap 434 | 435 | itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs 436 | if any (`mentionsName` tyVarNames) lhsArgs 437 | || itf && any (`mentionsName` tyVarNames) tyArgs 438 | then outOfPlaceTyVarError oClass conName 439 | else if any (`mentionsName` tyVarNames) rhsArgs 440 | then appsE $ [ varE . ordFunName oFun $ toEnum numLastArgs] 441 | ++ map (makeOrdFunForType oFun tvMap conName) rhsArgs 442 | else varE $ ordFunName oFun 0 443 | 444 | ------------------------------------------------------------------------------- 445 | -- Class-specific constants 446 | ------------------------------------------------------------------------------- 447 | 448 | -- | A representation of which @Ord@ variant is being derived. 449 | data OrdClass = Ord 450 | | Ord1 451 | | Ord2 452 | deriving (Bounded, Enum) 453 | 454 | instance ClassRep OrdClass where 455 | arity = fromEnum 456 | 457 | allowExQuant _ = True 458 | 459 | fullClassName Ord = ordTypeName 460 | fullClassName Ord1 = ord1TypeName 461 | fullClassName Ord2 = ord2TypeName 462 | 463 | classConstraint oClass i 464 | | oMin <= i && i <= oMax = Just $ fullClassName (toEnum i :: OrdClass) 465 | | otherwise = Nothing 466 | where 467 | oMin, oMax :: Int 468 | oMin = fromEnum (minBound :: OrdClass) 469 | oMax = fromEnum oClass 470 | 471 | compareConstName :: OrdFun -> Name 472 | compareConstName OrdCompare = compareConstValName 473 | compareConstName OrdLT = ltConstValName 474 | compareConstName OrdLE = ltConstValName 475 | compareConstName OrdGT = ltConstValName 476 | compareConstName OrdGE = ltConstValName 477 | compareConstName Ord1LiftCompare = liftCompareConstValName 478 | compareConstName Ord2LiftCompare2 = liftCompare2ConstValName 479 | 480 | ordClassToCompare :: OrdClass -> OrdFun 481 | ordClassToCompare Ord = OrdCompare 482 | ordClassToCompare Ord1 = Ord1LiftCompare 483 | ordClassToCompare Ord2 = Ord2LiftCompare2 484 | 485 | data OrdFun = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT 486 | | Ord1LiftCompare | Ord2LiftCompare2 487 | deriving Eq 488 | 489 | ordFunName :: OrdFun -> Int -> Name 490 | ordFunName OrdCompare 0 = compareValName 491 | ordFunName OrdLT 0 = ltValName 492 | ordFunName OrdLE 0 = leValName 493 | ordFunName OrdGE 0 = geValName 494 | ordFunName OrdGT 0 = gtValName 495 | ordFunName Ord1LiftCompare 0 = ordFunName OrdCompare 0 496 | ordFunName Ord1LiftCompare 1 = liftCompareValName 497 | ordFunName Ord2LiftCompare2 0 = ordFunName OrdCompare 0 498 | ordFunName Ord2LiftCompare2 1 = ordFunName Ord1LiftCompare 1 499 | ordFunName Ord2LiftCompare2 2 = liftCompare2ValName 500 | ordFunName _ _ = error "Data.Ord.Deriving.Internal.ordFunName" 501 | 502 | ordFunToClass :: OrdFun -> OrdClass 503 | ordFunToClass OrdCompare = Ord 504 | ordFunToClass OrdLT = Ord 505 | ordFunToClass OrdLE = Ord 506 | ordFunToClass OrdGE = Ord 507 | ordFunToClass OrdGT = Ord 508 | ordFunToClass Ord1LiftCompare = Ord1 509 | ordFunToClass Ord2LiftCompare2 = Ord2 510 | 511 | eqResult :: OrdFun -> Q Exp 512 | eqResult OrdCompare = eqTagExpr 513 | eqResult OrdLT = falseExpr 514 | eqResult OrdLE = trueExpr 515 | eqResult OrdGE = trueExpr 516 | eqResult OrdGT = falseExpr 517 | eqResult Ord1LiftCompare = eqTagExpr 518 | eqResult Ord2LiftCompare2 = eqTagExpr 519 | 520 | gtResult :: OrdFun -> Q Exp 521 | gtResult OrdCompare = gtTagExpr 522 | gtResult OrdLT = falseExpr 523 | gtResult OrdLE = falseExpr 524 | gtResult OrdGE = trueExpr 525 | gtResult OrdGT = trueExpr 526 | gtResult Ord1LiftCompare = gtTagExpr 527 | gtResult Ord2LiftCompare2 = gtTagExpr 528 | 529 | ltResult :: OrdFun -> Q Exp 530 | ltResult OrdCompare = ltTagExpr 531 | ltResult OrdLT = trueExpr 532 | ltResult OrdLE = trueExpr 533 | ltResult OrdGE = falseExpr 534 | ltResult OrdGT = falseExpr 535 | ltResult Ord1LiftCompare = ltTagExpr 536 | ltResult Ord2LiftCompare2 = ltTagExpr 537 | 538 | ------------------------------------------------------------------------------- 539 | -- Assorted utilities 540 | ------------------------------------------------------------------------------- 541 | 542 | ltTagExpr, eqTagExpr, gtTagExpr, falseExpr, trueExpr :: Q Exp 543 | ltTagExpr = conE ltDataName 544 | eqTagExpr = conE eqDataName 545 | gtTagExpr = conE gtDataName 546 | falseExpr = conE falseDataName 547 | trueExpr = conE trueDataName 548 | 549 | -- Besides compare, that is 550 | otherFuns :: OrdClass -> [ConstructorInfo] -> [OrdFun] 551 | otherFuns _ [] = [] -- We only need compare for empty data types. 552 | otherFuns oClass cons = case oClass of 553 | Ord1 -> [] 554 | Ord2 -> [] 555 | Ord | (lastTag - firstTag) <= 2 || null nonNullaryCons 556 | -> [OrdLT, OrdLE, OrdGE, OrdGT] 557 | | otherwise 558 | -> [] 559 | where 560 | firstTag, lastTag :: Int 561 | firstTag = 0 562 | lastTag = length cons - 1 563 | 564 | nonNullaryCons :: [ConstructorInfo] 565 | nonNullaryCons = filterOut isNullaryCon cons 566 | 567 | unliftedOrdFun :: Name -> OrdFun -> Name -> Name -> Q Exp 568 | unliftedOrdFun tyName oFun a b = case oFun of 569 | OrdCompare -> unliftedCompareExpr 570 | OrdLT -> wrap ltFun 571 | OrdLE -> wrap leFun 572 | OrdGE -> wrap geFun 573 | OrdGT -> wrap gtFun 574 | Ord1LiftCompare -> unliftedCompareExpr 575 | Ord2LiftCompare2 -> unliftedCompareExpr 576 | where 577 | unliftedCompareExpr :: Q Exp 578 | unliftedCompareExpr = unliftedCompare ltFun eqFun aExpr bExpr 579 | ltTagExpr eqTagExpr gtTagExpr 580 | 581 | ltFun, leFun, eqFun, geFun, gtFun :: Name 582 | (ltFun, leFun, eqFun, geFun, gtFun) = primOrdFuns tyName 583 | 584 | wrap :: Name -> Q Exp 585 | wrap primFun = primOpAppExpr aExpr primFun bExpr 586 | 587 | aExpr, bExpr :: Q Exp 588 | aExpr = varE a 589 | bExpr = varE b 590 | 591 | unliftedCompare :: Name -> Name 592 | -> Q Exp -> Q Exp -- What to compare 593 | -> Q Exp -> Q Exp -> Q Exp -- Three results 594 | -> Q Exp 595 | unliftedCompare ltFun eqFun aExpr bExpr lt eq gt = 596 | condE (ascribeBool $ primOpAppExpr aExpr ltFun bExpr) lt $ 597 | condE (ascribeBool $ primOpAppExpr aExpr eqFun bExpr) eq gt 598 | where 599 | ascribeBool :: Q Exp -> Q Exp 600 | ascribeBool e = sigE e $ conT boolTypeName 601 | 602 | primOrdFuns :: Name -> (Name, Name, Name, Name, Name) 603 | primOrdFuns tyName = 604 | case Map.lookup tyName primOrdFunTbl of 605 | Just names -> names 606 | Nothing -> error $ nameBase tyName ++ " is not supported." 607 | 608 | isSupportedUnliftedType :: Type -> Bool 609 | isSupportedUnliftedType (ConT tyName) = Map.member tyName primOrdFunTbl 610 | isSupportedUnliftedType _ = False 611 | 612 | isSingleton :: [a] -> Bool 613 | isSingleton [_] = True 614 | isSingleton _ = False 615 | 616 | -- | Like 'filter', only it reverses the sense of the test 617 | filterOut :: (a -> Bool) -> [a] -> [a] 618 | filterOut _ [] = [] 619 | filterOut p (x:xs) | p x = filterOut p xs 620 | | otherwise = x : filterOut p xs 621 | --------------------------------------------------------------------------------