linear-generics (empty) → 0.1.0.0
raw patch · 39 files changed
+7622/−0 lines, 39 filesdep +basedep +containersdep +ghc-primsetup-changed
Dependencies added: base, containers, ghc-prim, hspec, linear-generics, template-haskell, th-abstraction
Files
- CHANGELOG.md +2/−0
- LICENSE +28/−0
- README.md +62/−0
- Setup.hs +6/−0
- linear-generics.cabal +134/−0
- src/Generics/Linear.hs +22/−0
- src/Generics/Linear/Class.hs +370/−0
- src/Generics/Linear/Instances.hs +6/−0
- src/Generics/Linear/Instances/Base.hs +153/−0
- src/Generics/Linear/Instances/Containers.hs +18/−0
- src/Generics/Linear/Instances/Linear_generics.hs +18/−0
- src/Generics/Linear/Instances/Template_haskell.hs +62/−0
- src/Generics/Linear/TH.hs +588/−0
- src/Generics/Linear/TH/Insertions.hs +57/−0
- src/Generics/Linear/TH/Internal.hs +365/−0
- src/Generics/Linear/TH/MetaData.hs +108/−0
- src/Generics/Linear/Unsafe/ViaGHCGenerics.hs +180/−0
- tests/DefaultSpec.hs +161/−0
- tests/EmptyCaseSpec.hs +26/−0
- tests/ExampleSpec.hs +396/−0
- tests/Examples.hs +28/−0
- tests/Generics/Deriving/ConNames.hs +72/−0
- tests/Generics/Deriving/Copoint.hs +112/−0
- tests/Generics/Deriving/Default.hs +281/−0
- tests/Generics/Deriving/Enum.hs +1140/−0
- tests/Generics/Deriving/Eq.hs +626/−0
- tests/Generics/Deriving/Foldable.hs +327/−0
- tests/Generics/Deriving/Functor.hs +242/−0
- tests/Generics/Deriving/Monoid.hs +27/−0
- tests/Generics/Deriving/Monoid/Internal.hs +280/−0
- tests/Generics/Deriving/Semigroup.hs +20/−0
- tests/Generics/Deriving/Semigroup/Internal.hs +218/−0
- tests/Generics/Deriving/Show.hs +666/−0
- tests/Generics/Deriving/Traversable.hs +155/−0
- tests/Generics/Deriving/TraversableConf.hs +209/−0
- tests/Generics/Deriving/Uniplate.hs +391/−0
- tests/Spec.hs +1/−0
- tests/T68Spec.hs +24/−0
- tests/TypeInTypeSpec.hs +41/−0
+ CHANGELOG.md view
@@ -0,0 +1,2 @@+# 0.1.0.0+* Initial fork from `generic-deriving`.
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2010 Universiteit Utrecht+All rights reserved.++Redistribution and use in source and binary forms, with or without modification,+are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++3. Neither the name of Universiteit Utrecht nor the names of its contributors+ may be used to endorse or promote products derived from this software without+ specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ README.md view
@@ -0,0 +1,62 @@+## `linear-generics`: Generic programming library with linearity support+[][Hackage: linear-generics]+[](http://packdeps.haskellers.com/reverse/linear-generics)+[][Haskell.org]+[][tl;dr Legal: BSD3]+[](https://github.com/dreixel/linear-generics/actions?query=workflow%3AHaskell-CI)++[Hackage: linear-generics]:+ http://hackage.haskell.org/package/linear-generics+ "linear-generics package on Hackage"+[Haskell.org]:+ http://www.haskell.org+ "The Haskell Programming Language"+[tl;dr Legal: BSD3]:+ https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29+ "BSD 3-Clause License (Revised)"++This package offers a version of+[`GHC.Generics`](https://hackage.haskell.org/package/base/docs/GHC-Generics.html)+with two important improvements:++1. The `to`, `from`, `to1`, and `from1` methods have multiplicity-polymorphic+ types, allowing them to be used with either traditional Haskell code or+ linearly typed code.++2. The representations used for `Generic1` are modified slightly.++ - Composition associates to the left in the generic representation. As a result,+ `to1` and `from1` never need to use `fmap`. This can+ [greatly improve performance](https://gitlab.haskell.org/ghc/ghc/-/issues/15969),+ and it is necessary to support multiplicity polymorphism,+ [as discussed here](https://github.com/tweag/linear-base/pull/316).+ - Generic representations no longer use `Rec1 f`, they use `Par1 :.: f` instead,+ [as proposed by spl](https://gitlab.haskell.org/ghc/ghc/-/issues/7492).+ This way you no longer need to write `Rec1` instances for your derivers.++ For more details, see the `Generics.Linear` documentation.++This library is organized as follows:++* `Generics.Linear` defines the core functionality for generics,+ including the multiplicity-polymorphic `Generic(1)` classes and+ a replacement for the `:.:` composition type.++* `Generics.Linear.TH` implements Template Haskell functionality for+ deriving instances of `Generic(1)`.++* `Generics.Linear.Unsafe.ViaGHCGenerics` offers `DerivingVia` targets to+ derive `Generic` and (some) `Generic1` instances from their+ `GHC.Generics` counterparts. Because these instances necessarily+ use unsafe coercions, their use will likely inhibit full optimization+ of code using them (see+ [this wiki page](https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/multiplicity-evidence)+ for more on the GHC internals, along with commentary in `Unsafe.Coerce`).++Educational code: the educational modules exported by+[`generic-deriving`](https://hackage.haskell.org/package/generic-deriving)+have been copied into the `tests/Generic/Deriving` directory+in this repository, with the very few modifications required to+accommodate the differences between the `Generic1` representations+here and in `base`. All the same caveats apply as in the originals;+see that package's `README`.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ linear-generics.cabal view
@@ -0,0 +1,134 @@+name: linear-generics+version: 0.1.0.0+synopsis: Generic programming library for generalised deriving.+description:+ This package offers a version of+ <https://hackage.haskell.org/package/base/docs/GHC-Generics.html GHC.Generics>+ with two important improvements:+ .+ 1. The @to@, @from@, @to1@, and @from1@ methods have multiplicity-polymorphic+ types, allowing them to be used with either traditional Haskell code or+ linearly typed code.+ .+ 2. The representations used for @Generic1@ are modified slightly. As a result,+ @to1@ and @from1@ never need to use @fmap@. This can+ <https://gitlab.haskell.org/ghc/ghc/-/issues/15969 greatly improve performance>,+ and it is + <https://github.com/tweag/linear-base/pull/316 necessary to support multiplicity polymorphism>.+ A smaller change, approximately+ <https://gitlab.haskell.org/ghc/ghc/-/issues/7492 as proposed by spl>,+ reduces the number of instances that must be written to actually use @Generic1@+ for deriving instances of other classes.+ .+ For more details, see the "Generics.Linear" documentation.+ .+ This library is organized as follows:+ .+ * "Generics.Linear" defines the core functionality for generics,+ including the multiplicity-polymorphic @Generic(1)@ classes and+ a replacement for the @:.:@ composition type.+ .+ * "Generics.Linear.TH" implements Template Haskell functionality for+ deriving instances of @Generic(1)@.+ .+ * "Generics.Linear.Unsafe.ViaGHCGenerics" offers @DerivingVia@ targets to+ derive @Generic@ and (some) @Generic1@ instances from their+ "GHC.Generics" counterparts. Because these instances necessarily+ use unsafe coercions, their use will likely inhibit full optimization+ of code using them.+ .+ Educational code: the educational modules exported by+ <https://hackage.haskell.org/package/generic-deriving generic-deriving>+ have been copied into the @tests\/Generic\/Deriving@ directory+ in this repository, with the very few modifications required to+ accommodate the differences between the @Generic1@ representations+ here and in @base@. All the same caveats apply as in the originals;+ see that package's @README@.++homepage: https://github.com/linear-generics/linear-generics+bug-reports: https://github.com/linear-generics/linear-generics/issues+category: Generics+copyright: 2011-2013 Universiteit Utrecht,+ University of Oxford,+ Ryan Scott,+ 2021 David Feuer+license: BSD3+license-file: LICENSE+author: José Pedro Magalhães+maintainer: David.Feuer@gmail.com+stability: experimental+build-type: Simple+cabal-version: >= 1.10+tested-with: GHC == 9.0.1+ , GHC == 9.2.*+extra-source-files: CHANGELOG.md+ , README.md++source-repository head+ type: git+ location: https://github.com/linear-generics/linear-generics++library+ hs-source-dirs: src+ exposed-modules:+ Generics.Linear+ Generics.Linear.Unsafe.ViaGHCGenerics++ Generics.Linear.TH+ Generics.Linear.TH.Insertions++ other-modules:+ Generics.Linear.Instances+ Generics.Linear.Class+ Generics.Linear.TH.Internal+ Generics.Linear.TH.MetaData+ Generics.Linear.Instances.Base+ Generics.Linear.Instances.Containers+ Generics.Linear.Instances.Linear_generics+ Generics.Linear.Instances.Template_haskell++ build-depends: base >= 4.15 && < 5+ , containers >= 0.5.9 && < 0.7+ , ghc-prim < 1+ , template-haskell >= 2.16 && < 2.19+ , th-abstraction >= 0.4 && < 0.5++ default-language: Haskell2010+ default-extensions: KindSignatures+ , TypeFamilies+ , DataKinds+ ghc-options: -Wall++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ DefaultSpec+ EmptyCaseSpec+ ExampleSpec+ T68Spec+ TypeInTypeSpec+ Examples+ Generics.Deriving.ConNames+ Generics.Deriving.Copoint+ Generics.Deriving.Default+ Generics.Deriving.Enum+ Generics.Deriving.Eq+ Generics.Deriving.Foldable+ Generics.Deriving.Functor+ Generics.Deriving.Monoid+ Generics.Deriving.Monoid.Internal+ Generics.Deriving.Semigroup+ Generics.Deriving.Semigroup.Internal+ Generics.Deriving.Show+ Generics.Deriving.Traversable+ Generics.Deriving.TraversableConf+ Generics.Deriving.Uniplate+ build-depends: base >= 4.15 && < 5+ , linear-generics+ , hspec >= 2 && < 3+ , template-haskell >= 2.16 && < 2.19+ build-tool-depends: hspec-discover:hspec-discover+ hs-source-dirs: tests+ default-language: Haskell2010+ ghc-options: -Wall -threaded -rtsopts
+ src/Generics/Linear.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE Safe #-}++-- | Multiplicity polymorphic versions of @"GHC.Generics".'G.Generic'@ and+-- @"GHC.Generics".'G.Generic1'@. 'Generic' is otherwise identical to the+-- standard version. 'Generic1' is similar, but with modifications that+-- make it more efficient, as well as supporting linearity.+--+-- This module re-exports everything in "GHC.Generics" except 'G.Generic',+-- 'G.Generic1', 'G.Rec1', and 'G.:.:'. The 'Generic1' representations here+-- don't need 'G.Rec1'. We expose our own, identical, ':.:'. This allows+-- users to instantiate their 'Generic1'-based generic-deriving classes so+-- they can be used with /both/ "GHC.Generics" and this package.+--+-- In addition to the usual generic types, we export one called 'MP1' for+-- use with nonlinear and multiplicity polymorphic fields. Nonlinear+-- generic-deriving classes should almost always handle 'MP1' without+-- restriction. Some linear generic-deriving classes will need to constrain+-- its @m@ parameter to be ''GHC.Types.One'.+module Generics.Linear (module Generics.Linear.Class) where++import Generics.Linear.Class+import Generics.Linear.Instances ()
+ src/Generics/Linear/Class.hs view
@@ -0,0 +1,370 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE GADTSyntax #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- | The definitions of 'Generic', 'Generic1', 'MP1', 'unMP1', and ':.:'.+-- Users should import 'Generics.Linear' instead.+module Generics.Linear.Class+ ( Generic (..)+ , Generic1 (..)+ , (:.:)(..)+ , MP1 (..)+ , unMP1+ , module GHC.Generics+ ) where+import Control.Applicative+import Data.Foldable (Foldable (..))+import Data.Functor.Classes+import Data.Functor.Contravariant+import GHC.Generics hiding (Generic (..), Generic1 (..), (:.:)(..), Rec1 (..))+import qualified GHC.Generics as G+import Control.Monad (MonadPlus (..))+import GHC.Types (Multiplicity (..))+import Data.Kind (Constraint, Type)+import Data.Data (Data)+import qualified Data.Data as D+import Data.Semigroup (Semigroup (..))+import Data.Typeable (Typeable, gcast1)++-- | @Generic@ is exactly the same as @"GHC.Generics".'Generic'@+-- except that `to` and `from` are multiplicity polymorphic. This+-- means they will work equally well in traditional Haskell code+-- and in linearly typed code.+type Generic :: Type -> Constraint+class Generic a where+ type family Rep a :: Type -> Type++ to :: forall p m. Rep a p %m-> a+ from :: forall p m. a %m-> Rep a p++-- | @Generic1@ is similar to @"GHC.Generics".'Generic1'@, but has a few+-- differences.+--+-- == Multiplicity polymorphism+--+-- As with 'Generic', the @to1@ and @from1@ methods are+-- multiplicity polymorphic.+--+-- == Differences in 'Rep1' representation+--+-- === 'G.Rec1' is not used+--+-- Given a type like+--+-- @+-- newtype Foo a = Foo (Maybe a)+-- @+--+-- where a single type constructor (here @Maybe@) is applied to the+-- parameter, "GHC.Generics" represents the field as @'G.Rec1' Maybe@.+-- We instead represent it using @Par1 :.: Maybe@. It is expected+-- that very few real-life uses of "GHC.Generics" will break as a+-- result, and this simplification means that users don't have to+-- write 'G.Rec1' instances for their generic-deriving classes.+--+-- === Compositions associate in the opposite order+--+-- Given a type like+--+-- @+-- newtype Bar a = Bar (Maybe [Either e a])+-- @+--+-- where multiple type constructors are layered around the parameter,+-- "GHC.Generics@ represents the field as+--+-- @+-- Maybe 'G.:.:' ([] 'G.:.:' 'G.Rec1' (Either e))+-- @+--+-- We instead represent it as+--+-- @+-- (('Par1' ':.:' Maybe) ':.:' []) ':.:' Either e+-- @+--+-- Doing it this way prevents `to1` and `from1` from having to 'fmap' newtype+-- constructors through the composed types, which can be a considerable+-- performance improvement and enables multiplicity polymorphism.+--+-- In most cases, modifying generic-deriving classes to accommodate this change+-- is simple: just swap which side of the composition is treated as a generic+-- representation and which as a base type. In a few cases, more restructuring+-- will be needed, which will require using different generic-deriving classes+-- than for "GHC.Generics".+--+-- == Difference in specificity+--+-- Users of type application will need to be aware that the kind parameter for+-- 'Generic1' is marked as inferred, whereas for @"GHC.Generics".'Generic1'@ it+-- is marked as specified. So you should use, for example, @to1 \@Maybe@ rather+-- than @to1 \@_ \@Maybe@.++type Generic1 :: forall {k}. (k -> Type) -> Constraint+class Generic1 (f :: k -> Type) where+ type family Rep1 f :: k -> Type++ to1 :: forall p m. Rep1 f p %m-> f p+ from1 :: forall p m. f p %m-> Rep1 f p++infixl 7 :.:++-- | The composition operator for types. We use our own here because for many+-- classes, it's possible to share generic deriving classes between+-- "GHC.Generics" and "Generics.Linear" by just instantiating them for both+-- composition operators (and 'MP1').+type (:.:) :: forall k2 k1. (k2 -> Type) -> (k1 -> k2) -> k1 -> Type+-- See Note: kind specificity+newtype (f :.: g) x = Comp1 { unComp1 :: f (g x) }+ deriving stock ( Eq, Ord, Show, Read+ , G.Generic, G.Generic1, Data+ , Functor, Foldable )+ deriving newtype (Semigroup, Monoid)++-- Note: kind specificity+--+-- I'd prefer to have the kinds inferred for @(:.:)@ and @MP@ rather than+-- specified. Unfortunately, I think it would be too confusing not to match the+-- types imported from GHC.Generics. See+-- https://gitlab.haskell.org/ghc/ghc/-/issues/20497++deriving stock instance (Traversable f, Traversable g) => Traversable (f :.: g)++deriving via forall (f :: Type -> Type) (g :: Type -> Type). f G.:.: g+ instance (Applicative f, Applicative g) => Applicative (f :.: g)++deriving via forall (f :: Type -> Type) (g :: Type -> Type). f G.:.: g+ instance (Alternative f, Applicative g) => Alternative (f :.: g)++deriving via forall (f :: Type -> Type) (g :: Type -> Type). f G.:.: g+ instance (Functor f, Contravariant g) => Contravariant (f :.: g)++instance (Eq1 f, Eq1 g) => Eq1 (f :.: g) where+ liftEq eq (Comp1 x) (Comp1 y) = liftEq (liftEq eq) x y++instance (Ord1 f, Ord1 g) => Ord1 (f :.: g) where+ liftCompare cmp (Comp1 x) (Comp1 y) = liftCompare (liftCompare cmp) x y++instance (Show1 f, Show1 g) => Show1 (f :.: g) where+ liftShowsPrec sp sl d (Comp1 x) =+ showsUnaryWith (liftShowsPrec sp' sl') "Comp1" d x+ where+ sp' = liftShowsPrec sp sl+ sl' = liftShowList sp sl++instance (Read1 f, Read1 g) => Read1 (f :.: g) where+ liftReadPrec rp rl = readData $+ readUnaryWith (liftReadPrec rp' rl') "Comp1" Comp1+ where+ rp' = liftReadPrec rp rl+ rl' = liftReadListPrec rp rl++ liftReadListPrec = liftReadListPrecDefault+ liftReadList = liftReadListDefault++-- | Types with nonlinear or multiplicity-polymorphic fields should use @MP1@+-- under @S1@. Unfortunately, Template Haskell (and GHC Generics) currently+-- lack any support for such types, so their instances must currently be+-- written entirely manually. We may add some functions to ease the pain at+-- some point.+--+-- Generic-deriving classes that do not involve linear types should treat+-- @MP1 m@ much as they treat @M1@: dig through it to get to the meat.+-- Unfortunately, some futzing about may be necessary to convince the+-- type checker that multiplicities work out.+--+-- Generic-deriving classes that use linear types may have to treat @MP1 m@+-- specially. In particular, they may need to constrain @m@ to be+-- ''GHC.Types.One' or ''GHC.Types.Many', or to match some other type+-- variable.+data MP1 :: forall k. Multiplicity -> (k -> Type) -> k -> Type where+-- See Note: kind specificity++-- If anything changes here (e.g., we add a field selector), then+-- the generic instances below will have to change.+ MP1 :: f a %m-> MP1 m f a++unMP1 :: MP1 m f a %n-> f a+-- Making this a field selector seems to break the type of the @MP1@+-- constructor. Whoops!+unMP1 (MP1 fa) = fa++deriving instance G.Generic (MP1 m f a)+deriving instance G.Generic1 (MP1 m f)+-- TODO: Give MP1 Generic and Generic1 instances!++instance Functor f => Functor (MP1 m f) where+ fmap f (MP1 fa) = MP1 (fmap f fa)+ x <$ MP1 fa = MP1 (x <$ fa)++instance Applicative f => Applicative (MP1 m f) where+ -- Why can't we use pure = MP1 Prelude.. pure ?+ pure a = MP1 (pure a)+ liftA2 f (MP1 x) (MP1 y) = MP1 (liftA2 f x y)++instance Monad f => Monad (MP1 m f) where+ MP1 fa >>= f = MP1 (fa >>= unMP1 Prelude.. f)++instance Foldable f => Foldable (MP1 m f) where+ foldMap f (MP1 x) = foldMap f x+ foldMap' f (MP1 x) = foldMap' f x+ fold (MP1 x) = fold x+ foldr c n (MP1 x) = foldr c n x+ foldr' c n (MP1 x) = foldr' c n x+ foldl c n (MP1 x) = foldl c n x+ foldl' c n (MP1 x) = foldl' c n x+ length (MP1 x) = length x+ null (MP1 x) = null x+ elem e (MP1 x) = elem e x+ maximum (MP1 x) = maximum x+ minimum (MP1 x) = minimum x+ sum (MP1 x) = sum x+ product (MP1 x) = product x++instance Traversable f => Traversable (MP1 m f) where+ traverse f (MP1 x) = wrapMP1 <$> traverse f x+ sequenceA (MP1 x) = wrapMP1 <$> sequenceA x+ mapM f (MP1 x) = wrapMP1 <$> mapM f x+ sequence (MP1 x) = wrapMP1 <$> sequence x++instance Contravariant f => Contravariant (MP1 m f) where+ contramap f (MP1 x) = MP1 (contramap f x)+ a >$ MP1 x = MP1 (a >$ x)++instance Alternative f => Alternative (MP1 m f) where+ empty = MP1 empty+ MP1 x <|> MP1 y = MP1 (x <|> y)+ many (MP1 x) = MP1 (many x)+ some (MP1 x) = MP1 (some x)++instance MonadPlus f => MonadPlus (MP1 m f) where+ mzero = MP1 mzero+ mplus (MP1 x) (MP1 y) = MP1 (mplus x y)++deriving instance Eq (f a) => Eq (MP1 m f a)+instance Ord (f a) => Ord (MP1 m f a) where+ compare (MP1 a) (MP1 b) = compare a b+ MP1 a < MP1 b = a < b+ MP1 a <= MP1 b = a <= b+ MP1 a > MP1 b = a > b+ MP1 a >= MP1 b = a >= b+ min (MP1 a) (MP1 b) = MP1 (min a b)+ max (MP1 a) (MP1 b) = MP1 (max a b)++deriving instance Read (f a) => Read (MP1 m f a)+deriving instance Show (f a) => Show (MP1 m f a)++instance Semigroup (f a) => Semigroup (MP1 m f a) where+ MP1 x <> MP1 y = MP1 (x <> y)+ stimes n (MP1 x) = MP1 (stimes n x)+ sconcat x = MP1 (sconcat (fmap unMP1 x))++instance Monoid (f a) => Monoid (MP1 m f a) where+ mempty = MP1 mempty++-- -------------------+-- Lifted instances++instance Eq1 f => Eq1 (MP1 m f) where+ liftEq eq (MP1 x) (MP1 y) = liftEq eq x y++instance Ord1 f => Ord1 (MP1 m f) where+ liftCompare cmp (MP1 x) (MP1 y) = liftCompare cmp x y++instance Show1 f => Show1 (MP1 m f) where+ liftShowsPrec sp sl d (MP1 a) = showsUnaryWith (liftShowsPrec sp sl) "MP1" d a++instance Read1 f => Read1 (MP1 m f) where+ liftReadPrec rp rl = readData $+ readUnaryWith (liftReadPrec rp rl) "MP1" (\x -> MP1 x)+ liftReadListPrec = liftReadListPrecDefault+ liftReadList = liftReadListDefault++-- -------------------+-- Data instance++-- For some reason, the derived Data instance produces a multiplicity mismatch.+-- *sigh*.+instance (Typeable m, Typeable f, Data a, Data (f a)) => Data (MP1 m f a) where+ gfoldl f g (MP1 fa) = (g wrapMP1 `f` fa)+ gunfold f g _constr = f (g wrapMP1)+ toConstr (MP1 _) = mpConstr+ dataTypeOf _ = mpDataType+ dataCast1 mp = gcast1 mp++mpDataType :: D.DataType+mpDataType = D.mkDataType "MP1" [mpConstr]++mpConstr :: D.Constr+mpConstr = D.mkConstr mpDataType "MP1" [] D.Prefix++-- Why do we need this?+wrapMP1 :: f a -> MP1 m f a+wrapMP1 fa = MP1 fa++-- -----------------+-- Generic instances for MP1 (ugh)++-- | This type is used solely to get the name of this very module and the+-- package it's in, reliably. It must be in the same module as 'MP1'!++data ForInfo deriving G.Generic++-- | @CopyPkgModule f g@ copies the module and package name from+-- representation @f@ to representation @g@. Everything else is left+-- alone.+type family CopyPkgModule (f :: j -> Type) (g :: k -> Type) :: k -> Type where+ CopyPkgModule (D1 ('MetaData _ mod_name pkg_name _) _)+ (D1 ('MetaData type_name _ _ is_newtype) r)+ = D1 ('MetaData type_name mod_name pkg_name is_newtype) r++instance Generic (MP1 m f a) where+ type Rep (MP1 m f a) = CopyPkgModule (G.Rep ForInfo)+ (D1+ ('MetaData "MP1" "" "" 'False)+ (C1+ ('MetaCons "MP1" 'PrefixI 'False)+ (S1+ ('MetaSel+ 'Nothing 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy)+ (MP1 m (Rec0 (f a))))))+ from y = from' y+ where+ from' :: MP1 m f a %1 -> Rep (MP1 m f a) x+ from' (MP1 x) = M1 (M1 (M1 (MP1 (K1 x))))+ to y = to' y+ where+ to' :: Rep (MP1 m f a) x %1 -> MP1 m f a+ to' (M1 (M1 (M1 (MP1 (K1 x))))) = MP1 x++instance Generic1 (MP1 m f) where+ type Rep1 (MP1 m f) = CopyPkgModule (G.Rep ForInfo)+ (D1+ ('MetaData "MP1" "" "" 'False)+ (C1+ ('MetaCons "MP1" 'PrefixI 'False)+ (S1+ ('MetaSel+ 'Nothing 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy)+ (MP1 m (Par1 :.: f)))))+ from1 y = from1' y+ where+ from1' :: MP1 m f a %1 -> Rep1 (MP1 m f) a+ from1' (MP1 x) = M1 (M1 (M1 (MP1 (Comp1 (Par1 x)))))+ to1 y = to1' y+ where+ to1' :: Rep1 (MP1 m f) a %1 -> MP1 m f a+ to1' (M1 (M1 (M1 (MP1 (Comp1 (Par1 x)))))) = MP1 x
+ src/Generics/Linear/Instances.hs view
@@ -0,0 +1,6 @@+{-# LANGUAGE Trustworthy #-}+module Generics.Linear.Instances where+import Generics.Linear.Instances.Base ()+import Generics.Linear.Instances.Containers ()+import Generics.Linear.Instances.Linear_generics ()+import Generics.Linear.Instances.Template_haskell ()
+ src/Generics/Linear/Instances/Base.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# language TemplateHaskell #-}+{-# language DataKinds #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Generics.Linear.Instances.Base (+ -- Instances only+ ) where++import Control.Applicative+import Data.Complex (Complex)+import Data.Functor.Identity (Identity)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Semigroup as S+import qualified Data.Monoid as M+import Data.Proxy (Proxy)+import Data.Version (Version)+import System.Exit (ExitCode)+import Data.Ord (Down)+import Control.Arrow (Kleisli)+import qualified GHC.Generics as GHCG+import qualified Data.Functor.Sum as FSum+import qualified Data.Functor.Product as FProd+import Data.Functor.Compose+import Foreign.Ptr (Ptr)+import Generics.Linear.TH+import GHC.Tuple (Solo)++-- GHC.Tuple+$(deriveGenericAnd1 ''Solo)+$(deriveGenericAnd1 ''(,))+$(deriveGenericAnd1 ''(,,))+$(deriveGenericAnd1 ''(,,,))+$(deriveGenericAnd1 ''(,,,,))+$(deriveGenericAnd1 ''(,,,,,))+$(deriveGenericAnd1 ''(,,,,,,))+$(deriveGenericAnd1 ''(,,,,,,,))+$(deriveGenericAnd1 ''(,,,,,,,,))+$(deriveGenericAnd1 ''(,,,,,,,,,))+$(deriveGenericAnd1 ''(,,,,,,,,,,))+$(deriveGenericAnd1 ''(,,,,,,,,,,,))+$(deriveGenericAnd1 ''(,,,,,,,,,,,,))+$(deriveGenericAnd1 ''(,,,,,,,,,,,,,))+$(deriveGenericAnd1 ''(,,,,,,,,,,,,,,))++-- Data.Functor.Compose+$(deriveGeneric1 ''Compose)++-- Data.Functor.Identity+$(deriveGenericAnd1 ''Identity)++-- Control.Category+$(deriveGenericAnd1 ''Kleisli)++-- Data.Ord+$(deriveGenericAnd1 ''Down)+$(deriveGeneric ''Ordering)++-- System.Exit+$(deriveGeneric ''ExitCode)++-- Data.Version+$(deriveGeneric ''Version)++-- GHC.Generics+$(deriveGenericAnd1 ''(GHCG.:+:))+$(deriveGenericAnd1 ''(GHCG.:*:))+$(deriveGenericAnd1 ''GHCG.K1)+$(deriveGenericAnd1 ''GHCG.M1)+$(deriveGenericAnd1 ''GHCG.Par1)+$(deriveGenericAnd1 ''GHCG.U1)+$(deriveGenericAnd1 ''GHCG.V1)+$(deriveGenericAnd1 ''(GHCG.:.:))+$(deriveGenericAnd1 ''GHCG.Rec1)+$(deriveGeneric ''GHCG.Fixity)+$(deriveGeneric ''GHCG.Associativity)+$(deriveGeneric ''GHCG.DecidedStrictness)+$(deriveGeneric ''GHCG.SourceStrictness)+$(deriveGeneric ''GHCG.SourceUnpackedness)++-- These ones use data constructor names+$(deriveGenericAnd1 'GHCG.UAddr)+$(deriveGenericAnd1 'GHCG.UChar)+$(deriveGenericAnd1 'GHCG.UDouble)+$(deriveGenericAnd1 'GHCG.UFloat)+$(deriveGenericAnd1 'GHCG.UInt)+$(deriveGenericAnd1 'GHCG.UWord)++-- Data.Complex+$(deriveGenericAnd1 ''Complex)++-- Data.Proxy+$(deriveGenericAnd1 ''Proxy)++-- Data.Semigroup+$(deriveGeneric ''S.All)+$(deriveGeneric ''S.Any)++$(deriveGenericAnd1 ''S.Min)+$(deriveGenericAnd1 ''S.Max)+$(deriveGenericAnd1 ''S.Arg)+$(deriveGenericAnd1 ''S.Dual)+$(deriveGeneric ''S.Endo)+$(deriveGenericAnd1 ''S.First)+$(deriveGenericAnd1 ''S.Last)+$(deriveGenericAnd1 ''S.Product)+$(deriveGenericAnd1 ''S.Sum)+$(deriveGenericAnd1 ''S.WrappedMonoid)++-- Data.Monoid+$(deriveGenericAnd1 ''M.Alt)+$(deriveGenericAnd1 ''M.Ap)+$(deriveGenericAnd1 ''M.First)+$(deriveGenericAnd1 ''M.Last)++-- Control.Applicative++$(deriveGenericAnd1 ''WrappedArrow)++$(deriveGenericAnd1 ''WrappedMonad)++$(deriveGenericAnd1 ''ZipList)++$(deriveGenericAnd1 ''Const)++-- Prelude+$(deriveGenericAnd1 ''[])+$(deriveGenericAnd1 ''Either)+$(deriveGenericAnd1 ''Maybe)+$(deriveGeneric ''Bool)+$(deriveGeneric ''())+$(deriveGeneric ''Char)+$(deriveGeneric ''Double)+$(deriveGeneric ''Int)+$(deriveGeneric ''Float)+$(deriveGeneric ''Word)++-- Data.List.NonEmpty+$(deriveGenericAnd1 ''NonEmpty)++-- Data.Functor.Sum+$(deriveGenericAnd1 ''FSum.Sum)++-- Data.Functor.Product+$(deriveGenericAnd1 ''FProd.Product)++-- Foreign.Ptr+$(deriveGeneric ''Ptr)
+ src/Generics/Linear/Instances/Containers.hs view
@@ -0,0 +1,18 @@+{-# language TemplateHaskell #-}++{-# options_ghc -Wno-orphans #-}++module Generics.Linear.Instances.Containers where+import Generics.Linear.TH++import Data.Tree (Tree)+import Data.Sequence (ViewL, ViewR)+import Data.Sequence.Internal (FingerTree, Node, Digit, Elem)++$(deriveGenericAnd1 ''Tree)+$(deriveGenericAnd1 ''ViewL)+$(deriveGenericAnd1 ''ViewR)+$(deriveGenericAnd1 ''FingerTree)+$(deriveGenericAnd1 ''Node)+$(deriveGenericAnd1 ''Digit)+$(deriveGenericAnd1 ''Elem)
+ src/Generics/Linear/Instances/Linear_generics.hs view
@@ -0,0 +1,18 @@+-- {-# LANGUAGE EmptyCase #-}+-- {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# language TemplateHaskell #-}+{-# language DataKinds #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Generics.Linear.Instances.Linear_generics (+ -- Instances only+ ) where++import Generics.Linear.Class+import Generics.Linear.TH++$(deriveGenericAnd1 ''(:.:))
+ src/Generics/Linear/Instances/Template_haskell.hs view
@@ -0,0 +1,62 @@+{-# language PolyKinds #-}+{-# language TemplateHaskell #-}++{-# options_ghc -Wno-orphans #-}++module Generics.Linear.Instances.Template_haskell where+import Generics.Linear.TH+import Language.Haskell.TH+import Language.Haskell.TH.Syntax++deriveGeneric ''Loc+deriveGeneric ''Info+deriveGeneric ''ModuleInfo+deriveGeneric ''Extension+deriveGeneric ''AnnLookup+deriveGenericAnd1 ''Code+deriveGeneric ''Name+deriveGeneric ''NameSpace+deriveGeneric ''Dec+deriveGeneric ''Con+deriveGeneric ''Clause+deriveGeneric ''SourceUnpackedness+deriveGeneric ''SourceStrictness+deriveGeneric ''DecidedStrictness+deriveGeneric ''Bang+deriveGeneric ''Foreign+deriveGeneric ''Callconv+deriveGeneric ''Safety+deriveGeneric ''Pragma+deriveGeneric ''Inline+deriveGeneric ''RuleMatch+deriveGeneric ''Phases+deriveGeneric ''RuleBndr+deriveGeneric ''AnnTarget+deriveGeneric ''FunDep+deriveGeneric ''TySynEqn+deriveGeneric ''TypeFamilyHead+deriveGeneric ''Fixity+deriveGeneric ''FixityDirection+deriveGeneric ''PatSynDir+deriveGeneric ''PatSynArgs+deriveGeneric ''Exp+deriveGeneric ''Match+deriveGeneric ''Body+deriveGeneric ''Guard+deriveGeneric ''Stmt+deriveGeneric ''Range+deriveGeneric ''Lit+deriveGeneric ''Pat+deriveGeneric ''Type+deriveGenericAnd1 ''TyVarBndr+deriveGeneric ''TyLit+deriveGeneric ''Role+deriveGeneric ''Specificity+deriveGeneric ''FamilyResultSig+deriveGeneric ''InjectivityAnn+deriveGeneric ''OccName+deriveGeneric ''NameFlavour+deriveGeneric ''Module+deriveGeneric ''PkgName+-- No instance for TExp because it really wants that abstraction barrier.+deriveGeneric ''ForeignSrcLang
+ src/Generics/Linear/TH.hs view
@@ -0,0 +1,588 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TemplateHaskellQuotes #-}++{- |+Module : Generics.Linear.TH+Copyright : (c) 2008--2009 Universiteit Utrecht+License : BSD3++Maintainer : David.Feuer@gmail.com+Stability : experimental+Portability : non-portable++This module contains Template Haskell code that can be used to+automatically generate the boilerplate code for the generic deriving+library.++To use these functions, pass the name of a data type as an argument:++@+{-# LANGUAGE TemplateHaskell #-}++data Example a = Example Int Char a+$('deriveGeneric' ''Example) -- Derives Generic instance+$('deriveGeneric1' ''Example) -- Derives Generic1 instance+$('deriveGenericAnd1' ''Example) -- Derives Generic and Generic1 instances+@++This code can also be used with data families. To derive+for a data family instance, pass the name of one of the instance's constructors:++@+{-# LANGUAGE FlexibleInstances, TemplateHaskell, TypeFamilies #-}++data family Family a b+newtype instance Family Char x = FamilyChar Char+data instance Family Bool x = FamilyTrue | FamilyFalse++$('deriveGeneric' 'FamilyChar) -- instance Generic (Family Char b) where ...+$('deriveGeneric1' 'FamilyTrue) -- instance Generic1 (Family Bool) where ...+-- Alternatively, one could type $(deriveGeneric1 'FamilyFalse)+@++=== General usage notes++Template Haskell imposes some fairly harsh limitations on ordering and+visibility within a module. In most cases, classes derived generically will+need to be derived using @StandaloneDeriving@ /after/ the @deriveGeneric*@+invocation. For example, if @Generically@ is a class that uses a 'Generic'+constraint for its instances, then you cannot write++@+data Fish = Fish+ deriving Show via (Generically Fish)++$(deriveGeneric 'Fish)+@++You must instead write++@+data Fish = Fish++$(deriveGeneric 'Fish)++deriving via Generically Fish+ instance Show Fish+@++Furthermore, types defined after a @deriveGeneric*@ invocation are not+visible before that invocation. This may require some careful ordering,+especially in the case of mutually recursive types. For example, the+following will not compile:++@+data Foo = Foo | Bar Baz+$(deriveGeneric 'Foo)++data Baz = Baz Int Foo+$(deriveGeneric 'Baz)+@++Instead, you must write++@+data Foo = Foo | Bar Baz+data Baz = Baz Int Foo++$(deriveGeneric 'Foo)+$(deriveGeneric 'Baz)+@+-}++-- Adapted from Generics.Regular.TH, via+-- Generics.Deriving.TH+module Generics.Linear.TH (+ deriveGeneric+ , deriveGeneric1+ , deriveGenericAnd1+ ) where++import Control.Monad ((>=>), unless, when)++import qualified Data.Map as Map++import Generics.Linear.TH.Internal+import Generics.Linear.TH.MetaData+import Language.Haskell.TH.Datatype+import Language.Haskell.TH.Lib+import Language.Haskell.TH++-- Imports for splices+import Generics.Linear.Class+ hiding ( uAddr#, uChar#, uDouble#, uFloat#, uInt#, uWord#+ , unM1, unK1, unPar1, unComp1)+import Generics.Linear.TH.Insertions+ hiding ((.))+import qualified Generics.Linear.TH.Insertions as Ins+import GHC.Exts (Addr#, Char#, Int#, Word#, Double#, Float#)++-- | Given the name of a type or data family constructor,+-- derive a 'Generic' instance.+deriveGeneric :: Name -> Q [Dec]+deriveGeneric = deriveGenericCommon True False++-- | Given the name of a type or data family constructor,+-- derive a 'Generic1' instance.+deriveGeneric1 :: Name -> Q [Dec]+deriveGeneric1 = deriveGenericCommon False True++-- | Given the name of a type or data family constructor,+-- derive a 'Generic' instance and a 'Generic1' instance.+deriveGenericAnd1 :: Name -> Q [Dec]+deriveGenericAnd1 = deriveGenericCommon True True++deriveGenericCommon :: Bool -> Bool -> Name -> Q [Dec]+deriveGenericCommon generic generic1 n = do+ b <- if generic+ then deriveInst Generic n+ else return []+ c <- if generic1+ then deriveInst Generic1 n+ else return []+ return (b ++ c)++deriveInst :: GenericClass -> Name -> Q [Dec]+deriveInst Generic = deriveInstCommon ''Generic ''Rep Generic 'from 'to+deriveInst Generic1 = deriveInstCommon ''Generic1 ''Rep1 Generic1 'from1 'to1++deriveInstCommon :: Name+ -> Name+ -> GenericClass+ -> Name+ -> Name+ -> Name+ -> Q [Dec]+deriveInstCommon genericName repName gClass fromName toName n = do+ i <- reifyDataInfo n+ let (name, instTys, cons, dv) = either error id i+ (origTy, origKind) <- buildTypeInstance gClass name instTys+ tyInsRHS <- makeRepInline gClass dv name instTys cons origTy++ let origSigTy = SigT origTy origKind+ tyIns <- tySynInstDCompat repName Nothing [return origSigTy] (return tyInsRHS)+ let+ mkBody maker = [clause [] (normalB $+ lamCaseE [maker gClass 1 1 instTys cons]) []]++ fcs = mkBody mkFrom+ tcs = mkBody mkTo++ fmap (:[]) $+ instanceD (cxt []) (conT genericName `appT` return origSigTy)+ [return tyIns, funD fromName fcs, funD toName tcs]++makeRepInline :: GenericClass+ -> DatatypeVariant_+ -> Name+ -> [Type]+ -> [ConstructorInfo]+ -> Type+ -> Q Type+makeRepInline gClass dv name instTys cons ty = do+ let instVars = freeVariablesWellScoped [ty]+ (tySynVars, gk) = genericKind gClass instTys++ typeSubst :: TypeSubst+ typeSubst = Map.fromList $+ zip (map tvName tySynVars)+ (map (VarT . tvName) instVars)++ repType gk dv name typeSubst cons++repType :: GenericKind+ -> DatatypeVariant_+ -> Name+ -> TypeSubst+ -> [ConstructorInfo]+ -> Q Type+repType gk dv dt typeSubst cs =+ conT ''D1 `appT` mkMetaDataType dv dt `appT`+ foldBal sum' (conT ''V1) (map (repCon gk dv dt typeSubst) cs)+ where+ sum' :: Q Type -> Q Type -> Q Type+ sum' a b = conT ''(:+:) `appT` a `appT` b++repCon :: GenericKind+ -> DatatypeVariant_+ -> Name+ -> TypeSubst+ -> ConstructorInfo+ -> Q Type+repCon gk dv dt typeSubst+ (ConstructorInfo { constructorName = n+ , constructorVars = vars+ , constructorContext = ctxt+ , constructorStrictness = bangs+ , constructorFields = ts+ , constructorVariant = cv+ }) = do+ checkExistentialContext n vars ctxt+ let mbSelNames = case cv of+ NormalConstructor -> Nothing+ InfixConstructor -> Nothing+ RecordConstructor selNames -> Just selNames+ isRecord = case cv of+ NormalConstructor -> False+ InfixConstructor -> False+ RecordConstructor _ -> True+ isInfix = case cv of+ NormalConstructor -> False+ InfixConstructor -> True+ RecordConstructor _ -> False+ ssis <- reifySelStrictInfo n bangs+ repConWith gk dv dt n typeSubst mbSelNames ssis ts isRecord isInfix++repConWith :: GenericKind+ -> DatatypeVariant_+ -> Name+ -> Name+ -> TypeSubst+ -> Maybe [Name]+ -> [SelStrictInfo]+ -> [Type]+ -> Bool+ -> Bool+ -> Q Type+repConWith gk dv dt n typeSubst mbSelNames ssis ts isRecord isInfix = do+ let structureType :: Q Type+ structureType = foldBal prodT (conT ''U1) f++ f :: [Q Type]+ f = case mbSelNames of+ Just selNames -> zipWith3 (repField gk dv dt n typeSubst . Just)+ selNames ssis ts+ Nothing -> zipWith (repField gk dv dt n typeSubst Nothing)+ ssis ts++ conT ''C1+ `appT` mkMetaConsType dv dt n isRecord isInfix+ `appT` structureType++prodT :: Q Type -> Q Type -> Q Type+prodT a b = conT ''(:*:) `appT` a `appT` b++repField :: GenericKind+ -> DatatypeVariant_+ -> Name+ -> Name+ -> TypeSubst+ -> Maybe Name+ -> SelStrictInfo+ -> Type+ -> Q Type+repField gk dv dt ns typeSubst mbF ssi t =+ conT ''S1+ `appT` mkMetaSelType dv dt ns mbF ssi+ `appT` (repFieldArg gk =<< resolveTypeSynonyms t')+ where+ t' :: Type+ t' = applySubstitution typeSubst t++repFieldArg :: GenericKind -> Type -> Q Type+repFieldArg Gen0 (dustOff -> t0) = boxT t0+repFieldArg (Gen1 name) (dustOff -> t0) = go (conT ''Par1) t0+ where+ -- | Returns NoPar if the parameter doesn't appear.+ -- Expects its argument to have been dusted.+ go :: Q Type -> Type -> Q Type+ go _ ForallT{} = rankNError+ go _ ForallVisT{} = rankNError+ go macc (VarT t) | t == name = macc+ go macc (AppT f x) = do+ when (not (f `ground` name)) outOfPlaceTyVarError+ let+ macc' = do+ itf <- isUnsaturatedType f+ when itf typeFamilyApplicationError+ infixT macc ''(:.:) (pure f)+ go macc' (dustOff x)+ go _ _ = boxT t0++boxT :: Type -> Q Type+boxT ty = case unboxedRepNames ty of+ Just (boxTyName, _, _) -> conT boxTyName+ Nothing -> conT ''Rec0 `appT` return ty++mkFrom :: GenericClass -> Int -> Int -> [Type]+ -> [ConstructorInfo] -> Q Match+mkFrom gClass m i instTys cs = do+ y <- newName "y"+ match (varP y)+ (normalB $ conE 'M1 `appE` tweakedCaseE (varE y) cases)+ []+ where+ cases = zipWith (fromCon gk wrapE (length cs)) [1..] cs+ wrapE e = lrE i m e+ (_, gk) = genericKind gClass instTys++mkTo :: GenericClass -> Int -> Int -> [Type]+ -> [ConstructorInfo] -> Q Match+mkTo gClass m i instTys cs = do+ y <- newName "y"+ match (conP 'M1 [varP y])+ (normalB $ tweakedCaseE (varE y) cases)+ []+ where+ cases = zipWith (toCon gk wrapP (length cs)) [1..] cs+ wrapP p = lrP i m p+ (_, gk) = genericKind gClass instTys++tweakedCaseE :: Quote m => m Exp -> [m Match] -> m Exp+#if __GLASGOW_HASKELL__ >= 901+tweakedCaseE = caseE+#else+-- In GHC 9.0.1, there was a bug in multiplicity checking of case expressions,+-- so we can't use those. Fortunately, lambda case was fine, so we just express+--+-- case scrut of+-- branches+--+-- as+--+-- (\case branches) scrut+tweakedCaseE scrut branches = lamCaseE branches `appE` scrut+#endif++fromCon :: GenericKind -> (Q Exp -> Q Exp) -> Int -> Int+ -> ConstructorInfo -> Q Match+fromCon gk wrap m i+ (ConstructorInfo { constructorName = cn+ , constructorVars = vars+ , constructorContext = ctxt+ , constructorFields = ts+ }) = do+ checkExistentialContext cn vars ctxt+ fNames <- newNameList "f" $ length ts+ match (conP cn (map varP fNames))+ (normalB $ wrap $ lrE i m $ conE 'M1 `appE`+ foldBal prodE (conE 'U1) (zipWith (fromField gk) fNames ts)) []++prodE :: Q Exp -> Q Exp -> Q Exp+prodE x y = conE '(:*:) `appE` x `appE` y++fromField :: GenericKind -> Name -> Type -> Q Exp+fromField gk nr t = conE 'M1 `appE` (fromFieldWrap gk nr =<< resolveTypeSynonyms t)++fromFieldWrap :: GenericKind -> Name -> Type -> Q Exp+fromFieldWrap _ _ ForallT{} = rankNError+fromFieldWrap gk nr (SigT t _) = fromFieldWrap gk nr t+fromFieldWrap Gen0 nr t = conE (boxRepName t) `appE` varE nr+fromFieldWrap (Gen1 name) nr t = wC t name `appE` varE nr++wC :: Type -> Name -> Q Exp+wC (dustOff -> t0) name = go (ConE 'Par1) t0+ where+ go :: Exp -> Type -> Q Exp+ go !_ ForallT{} = rankNError+ go _ ForallVisT{} = rankNError+ go acc (VarT t) | t == name = pure acc+ go acc (AppT _f x) =+ -- We needn't check f `ground` name here; that was checked in+ -- repFieldArg.+ let+ acc' =+ -- We needn't check for f being unsaturated; that was checked+ -- in repFieldArg.+ InfixE (Just (ConE 'Comp1)) (VarE '(Ins..)) (Just acc)+ in go acc' (dustOff x)+ go _ _ = conE (boxRepName t0)++boxRepName :: Type -> Name+boxRepName = maybe 'K1 snd3 . unboxedRepNames++toCon :: GenericKind -> (Q Pat -> Q Pat) -> Int -> Int+ -> ConstructorInfo -> Q Match+toCon gk wrap m i+ (ConstructorInfo { constructorName = cn+ , constructorVars = vars+ , constructorContext = ctxt+ , constructorFields = ts+ }) = do+ checkExistentialContext cn vars ctxt+ fNames <- newNameList "f" $ length ts+ match (wrap $ lrP i m $ conP 'M1+ [foldBal prod (conP 'U1 []) (zipWith (toField gk) fNames ts)])+ (normalB $ foldl appE (conE cn)+ (zipWith (\nr -> resolveTypeSynonyms >=> toConUnwC gk nr)+ fNames ts)) []+ where prod x y = conP '(:*:) [x,y]++toConUnwC :: GenericKind -> Name -> Type -> Q Exp+toConUnwC Gen0 nr _ = varE nr+toConUnwC (Gen1 name) nr t = unwC t name `appE` varE nr++toField :: GenericKind -> Name -> Type -> Q Pat+toField gk nr t = conP 'M1 [toFieldWrap gk nr t]++toFieldWrap :: GenericKind -> Name -> Type -> Q Pat+toFieldWrap Gen0 nr t = conP (boxRepName t) [varP nr]+toFieldWrap Gen1{} nr _ = varP nr++unwC :: Type -> Name -> Q Exp+unwC (dustOff -> t0) name = go (VarE 'unPar1) t0+ where+ go :: Exp -> Type -> Q Exp+ go !_ ForallT{} = rankNError+ go _ ForallVisT{} = rankNError+ go acc (VarT t) | t == name = pure acc+ go acc (AppT _f x) =+ -- We needn't check f `ground` name here; that was checked in+ -- repFieldArg.+ let+ acc' =+ -- We needn't check for f being unsaturated; that was checked+ -- in repFieldArg.+ InfixE (Just acc)+ (VarE '(Ins..))+ (Just (VarE 'unComp1))+ in+ go acc' (dustOff x)+ go _ _ = varE (unboxRepName t0)++unboxRepName :: Type -> Name+unboxRepName = maybe 'unK1 trd3 . unboxedRepNames++lrP :: Int -> Int -> (Q Pat -> Q Pat)+lrP i n p+ | n == 0 = fail "lrP: impossible"+ | n == 1 = p+ | i <= div n 2 = conP 'L1 [lrP i (div n 2) p]+ | otherwise = conP 'R1 [lrP (i-m) (n-m) p]+ where m = div n 2++lrE :: Int -> Int -> (Q Exp -> Q Exp)+lrE i n e+ | n == 0 = fail "lrE: impossible"+ | n == 1 = e+ | i <= div n 2 = conE 'L1 `appE` lrE i (div n 2) e+ | otherwise = conE 'R1 `appE` lrE (i-m) (n-m) e+ where m = div n 2++unboxedRepNames :: Type -> Maybe (Name, Name, Name)+unboxedRepNames ty+ | ty == ConT ''Addr# = Just (''UAddr, 'UAddr, 'uAddr#)+ | ty == ConT ''Char# = Just (''UChar, 'UChar, 'uChar#)+ | ty == ConT ''Double# = Just (''UDouble, 'UDouble, 'uDouble#)+ | ty == ConT ''Float# = Just (''UFloat, 'UFloat, 'uFloat#)+ | ty == ConT ''Int# = Just (''UInt, 'UInt, 'uInt#)+ | ty == ConT ''Word# = Just (''UWord, 'UWord, 'uWord#)+ | otherwise = Nothing++-- For the given Types, deduces the instance type (and kind) to use for a+-- Generic(1) instance. Coming up with the instance type isn't as simple as+-- dropping the last types, as you need to be wary of kinds being instantiated+-- with *.+-- See Note [Type inference in derived instances]+buildTypeInstance :: GenericClass+ -- ^ Generic or Generic1+ -> Name+ -- ^ The type constructor or data family name+ -> [Type]+ -- ^ The types to instantiate the instance with+ -> Q (Type, Kind)+buildTypeInstance gClass tyConName varTysOrig = do+ -- Make sure to expand through type/kind synonyms! Otherwise, the+ -- eta-reduction check might get tripped up over type variables in a+ -- synonym that are actually dropped.+ -- (See GHC Trac #11416 for a scenario where this actually happened.)+ varTysExp <- mapM resolveTypeSynonyms varTysOrig++ let remainingLength :: Int+ remainingLength = length varTysOrig - fromEnum gClass++ droppedTysExp :: [Type]+ droppedTysExp = drop remainingLength varTysExp++ droppedStarKindStati :: [StarKindStatus]+ droppedStarKindStati = map canRealizeKindStar droppedTysExp++ -- Check there are enough types to drop and that all of them are either of+ -- kind * or kind k (for some kind variable k). If not, throw an error.+ when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $+ derivingKindError tyConName++ -- Substitute kind * for any dropped kind variables+ let varTysExpSubst :: [Type]+ varTysExpSubst = varTysExp++ let remainingTysExpSubst, droppedTysExpSubst :: [Type]+ (remainingTysExpSubst, droppedTysExpSubst) =+ splitAt remainingLength varTysExpSubst++ -- We now substitute all of the specialized-to-* kind variable names+ -- with *, but in the original types, not the synonym-expanded types. The reason+ -- we do this is a superficial one: we want the derived instance to resemble+ -- the datatype written in source code as closely as possible. For example,+ -- for the following data family instance:+ --+ -- data family Fam a+ -- newtype instance Fam String = Fam String+ --+ -- We'd want to generate the instance:+ --+ -- instance C (Fam String)+ --+ -- Not:+ --+ -- instance C (Fam [Char])+ let+ remainingTysOrigSubst, droppedTysOrigSubst :: [Type]+ (remainingTysOrigSubst, droppedTysOrigSubst) =+ splitAt remainingLength varTysOrig++ instanceType :: Type+ instanceType = applyTyToTys (ConT tyConName) remainingTysOrigSubst++ -- See Note [Kind signatures in derived instances]+ instanceKind :: Kind+ instanceKind = makeFunKind (map typeKind droppedTysOrigSubst) starK++ -- Ensure the dropped types can be safely eta-reduced. Otherwise,+ -- throw an error.+ unless (canEtaReduce remainingTysExpSubst droppedTysExpSubst) $+ etaReductionError instanceType+ return (instanceType, instanceKind)++{-+Note [Kind signatures in derived instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We include explicit type signatures in derived instances. One reason for+doing so is that in the case of certain data family instances, not including kind+signatures can result in ambiguity. For example, consider the following two data+family instances that are distinguished by their kinds:++ data family Fam (a :: k)+ data instance Fam (a :: * -> *)+ data instance Fam (a :: *)++If we dropped the kind signature for a in a derived instance for Fam a, then GHC+would have no way of knowing which instance we are talking about.++Another motivation for explicit kind signatures is the -XTypeInType extension.+With -XTypeInType, dropping kind signatures can completely change the meaning+of some data types. For example, there is a substantial difference between these+two data types:++ data T k (a :: k) = T k+ data T k a = T k++In addition to using explicit kind signatures on type variables, we also put+explicit kinds in the instance head, so generated instances will look+something like this:++ data S (a :: k) = S k+ instance Generic1 (S :: k -> *) where+ type Rep1 (S :: k -> *) = ... (Rec0 k)++Why do we do this? Imagine what the instance would be without the explicit return kind:++ instance Generic1 S where+ type Rep1 S = ... (Rec0 k)++This is an error, since the variable k is now out-of-scope!+-}
+ src/Generics/Linear/TH/Insertions.hs view
@@ -0,0 +1,57 @@+{-# language LinearTypes #-}+{-# language MagicHash #-}+{-# language NoImplicitPrelude #-}+{-# language PolyKinds #-}+{-# language TypeOperators #-}+{-# options_haddock hide #-}++-- | Functions intended to be emitted by Template Haskell splices. Do /not/+-- import this module outside the @linear-generics@ package—its contents will+-- depend on the GHC version and may change at absolutely any time.+module Generics.Linear.TH.Insertions where+import qualified Generics.Linear.Class as G+import qualified GHC.Exts as E++infixr 9 .+(.) :: (b %m-> c) -> (a %m-> b) -> a %m-> c+f . g = \x -> f (g x)+{-# INLINE (.) #-}++-- As of ghc-9.2.0.20210821, field accessors (even for newtypes) aren't+-- multiplicity polymorphic, so we have to make our own.++uAddr# :: G.UAddr a %m-> E.Addr#+uAddr# (G.UAddr a) = a+{-# INLINE uAddr# #-}++uChar# :: G.UChar a %m-> E.Char#+uChar# (G.UChar a) = a+{-# INLINE uChar# #-}++uDouble# :: G.UDouble a %m-> E.Double#+uDouble# (G.UDouble a) = a+{-# INLINE uDouble# #-}++uInt# :: G.UInt a %m-> E.Int#+uInt# (G.UInt a) = a+{-# INLINE uInt# #-}++uFloat# :: G.UFloat a %m-> E.Float#+uFloat# (G.UFloat a) = a+{-# INLINE uFloat# #-}++uWord# :: G.UWord a %m-> E.Word#+uWord# (G.UWord a) = a+{-# INLINE uWord# #-}++unComp1 :: (f G.:.: g) a %m-> f (g a)+unComp1 (G.Comp1 a) = a+{-# INLINE unComp1 #-}++unK1 :: G.K1 i c a %m-> c+unK1 (G.K1 c) = c+{-# INLINE unK1 #-}++unPar1 :: G.Par1 a %m-> a+unPar1 (G.Par1 a) = a+{-# INLINE unPar1 #-}
+ src/Generics/Linear/TH/Internal.hs view
@@ -0,0 +1,365 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}++{- |+Module : Generics.Linear.TH.Internal+Copyright : (c) 2008--2009 Universiteit Utrecht+License : BSD3++Maintainer : generics@haskell.org+Stability : experimental+Portability : non-portable++Template Haskell-related utilities.+-}++module Generics.Linear.TH.Internal where++import Control.Monad (unless)++import Data.Foldable (foldr')+import qualified Data.List as List+import Data.Map as Map (Map)+import qualified Data.Set as Set+import Data.Set (Set)++import Language.Haskell.TH.Datatype+import Language.Haskell.TH.Datatype.TyVarBndr+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Ppr (pprint)+import Language.Haskell.TH.Syntax++-------------------------------------------------------------------------------+-- Expanding type synonyms+-------------------------------------------------------------------------------++type TypeSubst = Map Name Type++-------------------------------------------------------------------------------+-- StarKindStatus+-------------------------------------------------------------------------------++-- | Whether a type is not of kind *, is of kind *, or is a kind variable.+data StarKindStatus = NotKindStar+ | MaybeKindStar+ deriving Eq++-- | Can a type possibly have kind *? This is a really rough guess,+-- because there are lots of ways for it to happen.+canRealizeKindStar :: Type -> StarKindStatus+canRealizeKindStar = \case+ VarT{} -> MaybeKindStar+ SigT _ StarT -> MaybeKindStar+ ParensT t -> canRealizeKindStar t+ SigT _ (VarT _) -> MaybeKindStar+ SigT _ k -> canMakeStar k+ _ -> MaybeKindStar++-- | Can a kind be *?+canMakeStar :: Kind -> StarKindStatus+canMakeStar = \case+ ParensT t -> canMakeStar t+ AppT k _ -> canMakeStar k+ StarT -> MaybeKindStar+ TupleT _ -> NotKindStar+ UnboxedTupleT _ -> NotKindStar+ ArrowT -> NotKindStar+ ListT -> NotKindStar+ _ -> MaybeKindStar++-------------------------------------------------------------------------------+-- Assorted utilities+-------------------------------------------------------------------------------++-- Note: There are quite a few other utilities in+--+-- generic-deriving: Generics.Deriving.TH.Internal+--+-- Most of the ones that aren't used here have been stripped out.++-- | If a Type is a SigT, returns its kind signature. Otherwise, return *.+typeKind :: Type -> Kind+typeKind (SigT _ k) = k+typeKind _ = starK++-- | Turns+--+-- @+-- [a, b] c+-- @+--+-- into+--+-- @+-- a -> b -> c+-- @+makeFunType :: [Type] -> Type -> Type+makeFunType argTys resTy = foldr' (AppT . AppT ArrowT) resTy argTys++-- | Turns+--+-- @+-- [k1, k2] k3+-- @+--+-- into+--+-- @+-- k1 -> k2 -> k3+-- @+makeFunKind :: [Kind] -> Kind -> Kind+makeFunKind = makeFunType++-- | Remove any outer `SigT` and `ParensT` constructors, and turn+-- an outermost `InfixT` constructor into plain applications.+dustOff :: Type -> Type+dustOff (SigT ty _) = dustOff ty+dustOff (ParensT ty) = dustOff ty+dustOff (InfixT ty1 n ty2) = ConT n `AppT` ty1 `AppT` ty2+dustOff ty = ty++-- | Checks whether a type is an unsaturated type family+-- application.+isUnsaturatedType :: Type -> Q Bool+isUnsaturatedType = go 0 . dustOff+ where+ -- Expects its argument to be dusted+ go :: Int -> Type -> Q Bool+ go d t = case t of+ ConT tcName -> check d tcName+ AppT f _ -> go (d + 1) (dustOff f)+ _ -> return False++ check :: Int -> Name -> Q Bool+ check d tcName = do+ mbinders <- getTypeFamilyBinders tcName+ return $ case mbinders of+ Just bndrs -> length bndrs > d+ Nothing -> False++-- | Given a name, check if that name is a type family. If+-- so, return a list of its binders.+getTypeFamilyBinders :: Name -> Q (Maybe [TyVarBndr_ ()])+getTypeFamilyBinders tcName = do+ info <- reify tcName+ return $ case info of+ FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _+ -> Just bndrs++ FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _+ -> Just bndrs+ _ -> Nothing++-- | True if the type does not mention the Name+ground :: Type -> Name -> Bool+ground ty name = name `notElem` freeVariables ty++-- | Construct a type via curried application.+applyTyToTys :: Type -> [Type] -> Type+applyTyToTys = List.foldl' AppT++-- | Generate a list of fresh names with a common prefix, and numbered suffixes.+newNameList :: String -> Int -> Q [Name]+newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n]++-- | Checks to see if the last types in a data family instance can be safely eta-+-- reduced (i.e., dropped), given the other types. This checks for three conditions:+--+-- (1) All of the dropped types are type variables+-- (2) All of the dropped types are distinct+-- (3) None of the remaining types mention any of the dropped types+canEtaReduce :: [Type] -> [Type] -> Bool+canEtaReduce remaining dropped =+ all isTyVar dropped+ -- Make sure not to pass something of type [Type], since Type+ -- didn't have an Ord instance until template-haskell-2.10.0.0+ && allDistinct droppedNames+ && not (any (`mentionsName` droppedNames) remaining)+ where+ droppedNames :: [Name]+ droppedNames = map varTToName dropped++-- | Extract the Name from a type variable. If the argument Type is not a+-- type variable, throw an error.+varTToName :: Type -> Name+varTToName (VarT n) = n+varTToName (SigT t _) = varTToName t+varTToName _ = error "Not a type variable!"++-- | Is the given type a variable?+isTyVar :: Type -> Bool+isTyVar VarT{} = True+isTyVar (SigT t _) = isTyVar t+isTyVar _ = False++-- | Is the given kind a variable?+isKindVar :: Kind -> Bool+isKindVar = isTyVar++-- | Does the given type mention any of the Names in the list?+mentionsName :: Type -> [Name] -> Bool+mentionsName = go+ where+ go :: Type -> [Name] -> Bool+ go (AppT t1 t2) names = go t1 names || go t2 names+ go (SigT t k) names = go t names || go k names+ go (VarT n) names = n `elem` names+ go _ _ = False++-- | Are all of the items in a list (which have an ordering) distinct?+--+-- This uses Set (as opposed to nub) for better asymptotic time complexity.+allDistinct :: Ord a => [a] -> Bool+allDistinct = allDistinct' Set.empty+ where+ allDistinct' :: Ord a => Set a -> [a] -> Bool+ allDistinct' uniqs (x:xs)+ | x `Set.member` uniqs = False+ | otherwise = allDistinct' (Set.insert x uniqs) xs+ allDistinct' _ _ = True++fst3 :: (a, b, c) -> a+fst3 (a, _, _) = a++snd3 :: (a, b, c) -> b+snd3 (_, b, _) = b++trd3 :: (a, b, c) -> c+trd3 (_, _, c) = c++foldBal :: (a -> a -> a) -> a -> [a] -> a+{-# INLINE foldBal #-} -- inlined to produce specialised code for each op+foldBal op0 x0 xs0 = fold_bal op0 x0 (length xs0) xs0+ where+ fold_bal op x !n xs = case xs of+ [] -> x+ [a] -> a+ _ -> let !nl = n `div` 2+ !nr = n - nl+ (l,r) = splitAt nl xs+ in fold_bal op x nl l+ `op` fold_bal op x nr r++isNewtypeVariant :: DatatypeVariant_ -> Bool+isNewtypeVariant Datatype_ = False+isNewtypeVariant Newtype_ = True+isNewtypeVariant (DataInstance_ {}) = False+isNewtypeVariant (NewtypeInstance_ {}) = True++-- | Indicates whether Generic or Generic1 is being derived.+data GenericClass = Generic | Generic1 deriving Enum++-- | Like 'GenericClass', but in the 'Gen1' case bundling the+-- 'Name' of the last type parameter.+data GenericKind = Gen0+ | Gen1 Name++-- Determines the universally quantified type variables (possibly after+-- substituting * in the case of Generic1) and the last type parameter name+-- (if there is one).+genericKind :: GenericClass -> [Type] -> ([TyVarBndrUnit], GenericKind)+genericKind gClass tySynVars =+ case gClass of+ Generic -> (freeVariablesWellScoped tySynVars, Gen0)+ Generic1 -> (freeVariablesWellScoped initArgs, Gen1 (varTToName lastArg))+ where+ -- Everything below is only used for Generic1.+ initArgs :: [Type]+ initArgs = init tySynVars++ lastArg :: Type+ lastArg = last tySynVars++-- | A version of 'DatatypeVariant' in which the data family instance+-- constructors come equipped with the 'ConstructorInfo' of the first+-- constructor in the family instance (for 'Name' generation purposes).+data DatatypeVariant_+ = Datatype_+ | Newtype_+ | DataInstance_ ConstructorInfo+ | NewtypeInstance_ ConstructorInfo++-- | One of the last type variables cannot be eta-reduced (see the canEtaReduce+-- function for the criteria it would have to meet).+etaReductionError :: Type -> Q a+etaReductionError instanceType = fail $+ "Cannot eta-reduce to an instance of form \n\tinstance (...) => "+ ++ pprint instanceType++-- | Either the given data type doesn't have enough type variables, or one of+-- the type variables to be eta-reduced cannot realize kind *.+derivingKindError :: Name -> Q a+derivingKindError tyConName = fail+ . showString "Cannot derive well-kinded instance of form ‘Generic1 "+ . showParen True+ ( showString (nameBase tyConName)+ . showString " ..."+ )+ . showString "‘\n\tClass Generic1 expects an argument of kind * -> *"+ $ ""++-- | The data type mentions the last type variable in a place other+-- than the last position of a data type in a constructor's field.+outOfPlaceTyVarError :: Q a+outOfPlaceTyVarError = fail+ . showString "Constructor must only use its last type variable as"+ . showString " the last argument of a data type"+ $ ""++-- | The data type mentions the last type variable in a type family+-- application.+typeFamilyApplicationError :: Q a+typeFamilyApplicationError = fail+ . showString "Constructor must not apply its last type variable"+ . showString " to an unsaturated type family"+ $ ""++-- | Cannot have a constructor argument of form (forall a1 ... an. <type>)+-- when deriving Generic(1)+rankNError :: Q a+rankNError = fail "Cannot have polymorphic arguments"++-- | Boilerplate for top level splices.+--+-- The given Name must meet one of two criteria:+--+-- 1. It must be the name of a type constructor of a plain data type or newtype.+-- 2. It must be the name of a data family instance or newtype instance constructor.+--+-- Any other value will result in an exception.+reifyDataInfo :: Name+ -> Q (Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_))+reifyDataInfo name = do+ return $ Left $ ns ++ " Could not reify " ++ nameBase name+ `recover`+ do DatatypeInfo { datatypeContext = ctxt+ , datatypeName = parentName+ , datatypeInstTypes = tys+ , datatypeVariant = variant+ , datatypeCons = cons+ } <- reifyDatatype name+ let variant_ = case variant of+ Datatype -> Datatype_+ Newtype -> Newtype_+ -- This isn't total, but the API requires that the data+ -- family instance have at least one constructor anyways,+ -- so this will always succeed.+ DataInstance -> DataInstance_ $ head cons+ NewtypeInstance -> NewtypeInstance_ $ head cons+ checkDataContext parentName ctxt $ Right (parentName, tys, cons, variant_)+ where+ ns :: String+ ns = "Generics.Linear.TH.reifyDataInfo: "++-- | One cannot derive Generic(1) instance for anything that uses DatatypeContexts,+-- so check to make sure the Cxt field of a datatype is null.+checkDataContext :: Name -> Cxt -> a -> Q a+checkDataContext _ [] x = return x+checkDataContext dataName _ _ = fail $+ nameBase dataName ++ " must not have a datatype context"++-- | Deriving Generic(1) doesn't work with ExistentialQuantification or GADTs.+checkExistentialContext :: Name -> [TyVarBndrUnit] -> Cxt -> Q ()+checkExistentialContext conName vars ctxt =+ unless (null vars && null ctxt) $ fail $+ nameBase conName ++ " must be a vanilla data constructor"
+ src/Generics/Linear/TH/MetaData.hs view
@@ -0,0 +1,108 @@+{- |+Module : Generics.Linear.TH.MetaData+Copyright : (c) 2008--2009 Universiteit Utrecht+License : BSD3++Maintainer : generics@haskell.org+Stability : experimental+Portability : non-portable++Template Haskell machinery for the type-literal-based variant of GHC+generics introduced in @base-4.9@.+-}++{-# LANGUAGE TemplateHaskellQuotes #-}++module Generics.Linear.TH.MetaData (+ mkMetaDataType+ , mkMetaConsType+ , mkMetaSelType+ , SelStrictInfo(..)+ , reifySelStrictInfo+ ) where++import Data.Maybe (fromMaybe)++import Generics.Linear.TH.Internal++import Language.Haskell.TH.Datatype as THAbs+import Language.Haskell.TH.Lib+import Language.Haskell.TH.Syntax++-- For splices++import qualified Generics.Linear.Class as G++mkMetaDataType :: DatatypeVariant_ -> Name -> Q Type+mkMetaDataType dv n =+ promotedT 'G.MetaData+ `appT` litT (strTyLit (nameBase n))+ `appT` litT (strTyLit m)+ `appT` litT (strTyLit pkg)+ `appT` promoteBool (isNewtypeVariant dv)+ where+ m, pkg :: String+ m = fromMaybe (error "Cannot fetch module name!") (nameModule n)+ pkg = fromMaybe (error "Cannot fetch package name!") (namePackage n)++mkMetaConsType :: DatatypeVariant_ -> Name -> Name -> Bool -> Bool -> Q Type+mkMetaConsType _ _ n conIsRecord conIsInfix = do+ mbFi <- reifyFixity n+ promotedT 'G.MetaCons+ `appT` litT (strTyLit (nameBase n))+ `appT` fixityIPromotedType mbFi conIsInfix+ `appT` promoteBool conIsRecord++promoteBool :: Bool -> Q Type+promoteBool True = promotedT 'True+promoteBool False = promotedT 'False++fixityIPromotedType :: Maybe Fixity -> Bool -> Q Type+fixityIPromotedType mbFi True =+ promotedT 'G.InfixI+ `appT` promoteAssociativity a+ `appT` litT (numTyLit (toInteger n))+ where+ Fixity n a = fromMaybe defaultFixity mbFi+fixityIPromotedType _ False = promotedT 'G.PrefixI++promoteAssociativity :: FixityDirection -> Q Type+promoteAssociativity InfixL = promotedT 'G.LeftAssociative+promoteAssociativity InfixR = promotedT 'G.RightAssociative+promoteAssociativity InfixN = promotedT 'G.NotAssociative++mkMetaSelType :: DatatypeVariant_ -> Name -> Name -> Maybe Name+ -> SelStrictInfo -> Q Type+mkMetaSelType _ _ _ mbF (SelStrictInfo su ss ds) =+ let mbSelNameT = case mbF of+ Just f -> promotedT 'Just `appT` litT (strTyLit (nameBase f))+ Nothing -> promotedT 'Nothing+ in promotedT 'G.MetaSel+ `appT` mbSelNameT+ `appT` promoteUnpackedness su+ `appT` promoteStrictness ss+ `appT` promoteDecidedStrictness ds++data SelStrictInfo = SelStrictInfo Unpackedness Strictness DecidedStrictness++promoteUnpackedness :: Unpackedness -> Q Type+promoteUnpackedness UnspecifiedUnpackedness = promotedT 'G.NoSourceUnpackedness+promoteUnpackedness NoUnpack = promotedT 'G.SourceNoUnpack+promoteUnpackedness Unpack = promotedT 'G.SourceUnpack++promoteStrictness :: Strictness -> Q Type+promoteStrictness UnspecifiedStrictness = promotedT 'G.NoSourceStrictness+promoteStrictness Lazy = promotedT 'G.SourceLazy+promoteStrictness THAbs.Strict = promotedT 'G.SourceStrict++promoteDecidedStrictness :: DecidedStrictness -> Q Type+promoteDecidedStrictness DecidedLazy = promotedT 'G.DecidedLazy+promoteDecidedStrictness DecidedStrict = promotedT 'G.DecidedStrict+promoteDecidedStrictness DecidedUnpack = promotedT 'G.DecidedUnpack++reifySelStrictInfo :: Name -> [FieldStrictness] -> Q [SelStrictInfo]+reifySelStrictInfo conName fs = do+ dcdStrs <- reifyConStrictness conName+ let srcUnpks = map fieldUnpackedness fs+ srcStrs = map fieldStrictness fs+ return $ zipWith3 SelStrictInfo srcUnpks srcStrs dcdStrs
+ src/Generics/Linear/Unsafe/ViaGHCGenerics.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LinearTypes #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE Unsafe #-}++-- | 'DerivingVia' targets to instantiate 'Generic' and 'Generic1' using+-- @"GHC.Generics".'G.Generic'@ and @"GHC.Generics".'G.Generic1'@,+-- respectively.+--+-- === Caution++-- It is almost always better to use "Generics.Linear.TH" to derive instances+-- using Template Haskell. The instances derived using this module use unsafe+-- coercions, which tend to block up GHC's optimizer (see+-- <https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/multiplicity-evidence this wiki page>+-- for more details on the inner workings of GHC). Use this+-- module only when the Template Haskell is unable to derive the instance+-- (rare) or you absolutely cannot use Template Haskell for some reason.++module Generics.Linear.Unsafe.ViaGHCGenerics+ ( GHCGenerically(..)+ , GHCGenerically1(..)+ ) where+import Data.Coerce (Coercible, coerce)+import Data.Kind (Constraint, Type)+import Generics.Linear+import qualified GHC.Generics as G+import Unsafe.Coerce+import GHC.Exts (Any)+import GHC.TypeLits (TypeError, ErrorMessage (..))+++-- | When @a@ is an instance+-- of @"GHC.Generics".'G.Generic'@, @GHCGenerically a@ is an instance+-- of 'Generic'.+--+-- === Warnings+--+-- @GHCGenerically@ is intended for use as a 'DerivingVia' target.+-- Most other uses of its 'Generic' instance will be quite wrong.+--+-- @GHCGenerically@ /must not/ be used with datatypes that have+-- nonlinear or linearity-polymorphic fields. Doing so will produce+-- completely bogus results, breaking the linearity rules.+--+-- @GHCGenerically@ is otherwise safe to use with /derived/+-- @"GHC.Generics".'G.Generic'@ instances, which are linear. If+-- you choose to use it with a hand-written instance, you should+-- check that the underlying instance is linear.+--+-- === Example+--+-- @+-- data Foo a = Bar a (Either Int a) | Baz (Maybe a) Int+-- deriving stock (Show, "GHC.Generics".'G.Generic')+-- deriving 'Generic' via GHCGenerically (Foo a)+-- @+newtype GHCGenerically a = GHCGenerically { unGHCGenerically :: a }++instance G.Generic a => Generic (GHCGenerically a) where+ type Rep (GHCGenerically a) = G.Rep a+ to = toLinear (GHCGenerically #. G.to)+ from = toLinear (G.from .# unGHCGenerically)++-- | When @a@ is an instance of @"GHC.Generics".'G.Generic1'@, and its 'G.Rep1'+-- contains no compositions, @GHCGenerically1 a@ is an instance of 'Generic1'.+--+-- === Warning+--+-- @GHCGenerically1@ is intended for use as a 'DerivingVia' target.+-- Most other uses of its 'Generic1' instance will be quite wrong.+--+-- @GHCGenerically1@ /must not/ be used with datatypes that have+-- nonlinear or linearity-polymorphic fields. Doing so will produce+-- completely bogus results, breaking the linearity rules.+--+-- @GHCGenerically1@ is otherwise safe to use with /derived/+-- @"GHC.Generics".'G.Generic1'@ instances, which are linear. If+-- you choose to use it with a hand-written instance, you should+-- check that the underlying instance is linear.+--+-- === Example+--+-- @+-- data Foo a = Bar a (Either Int a) | Baz (Maybe a) Int+-- deriving stock (Show, "GHC.Generics".'G.Generic1')+-- deriving 'Generic1' via GHCGenerically1 Foo+-- @+type GHCGenerically1 :: forall k. (k -> Type) -> k -> Type+newtype GHCGenerically1 f a = GHCGenerically1 { unGHCGenerically1 :: f a }++instance (G.Generic1 f, Repairable ('ShowType f) (G.Rep1 f)) => Generic1 (GHCGenerically1 f) where+ type Rep1 (GHCGenerically1 f) = Repair (G.Rep1 f)++ -- Why do we use 'unsafeCoerce' for these rather than just 'toLinear'?+ -- While @Rec1 f@ and @Par1 :.: f@ are represented the same way in+ -- memory, they are not @Coercible@. So we'd have to tear down the+ -- representation and build it back up again. Since we need an unsafe+ -- coercion anyway (in 'toLinear'), there's no operational benefit.+ -- That would shrink the trusted code base slightly, in a sense, but+ -- I don't think it's worth it.++ to1 :: forall a m. Rep1 (GHCGenerically1 f) a %m-> GHCGenerically1 f a+ to1 = unsafeCoerce (GHCGenerically1 #. G.to1 @_ @f @a)++ from1 :: forall a m. GHCGenerically1 f a %m-> Rep1 (GHCGenerically1 f) a+ from1 = unsafeCoerce (G.from1 @_ @f @a .# unGHCGenerically1)++-- | A @"GHC.Generics".'G.Rep1'@ is @Repairable@ if it contains no+-- compositions. The 'ErrorMessage' argument should be 'ShowType'+-- of the type whose representation this is.+type Repairable :: forall k. ErrorMessage -> (k -> Type) -> Constraint+class Repairable tn (grep1 :: k -> Type) where+ -- | Convert a @"GHC.Generics".'G.Rep1'@ representation into a 'Rep1'+ -- representation.+ type Repair grep1 :: k -> Type+instance Repairable tn f => Repairable tn (M1 i c f) where+ type Repair (M1 i c f) = M1 i c (Repair f)+instance Repairable tn (G.Rec1 f) where+ type Repair (G.Rec1 f) = Par1 :.: f+instance Repairable tn (K1 i c) where+ type Repair (K1 i c) = K1 i c+instance Repairable tn Par1 where+ type Repair Par1 = Par1+instance (Repairable tn f, Repairable tn g) => Repairable tn (f :*: g) where+ type Repair (f :*: g) = Repair f :*: Repair g+instance (Repairable tn f, Repairable tn g) => Repairable tn (f :+: g) where+ type Repair (f :+: g) = Repair f :+: Repair g+instance Repairable tn U1 where+ type Repair U1 = U1+instance Repairable tn V1 where+ type Repair V1 = V1+instance Repairable tn (URec r) where+ type Repair (URec r) = URec r+instance+ TypeError ('Text "Could not derive linear Generic1 from GHC Generic1 for type" ':$$:+ tn ':<>: 'Text "." ':$$: 'Text "Its Rep1 instance includes composition.")+ => Repairable tn (f :.: g) where+ type Repair (_ :.: _) = Any++-- Stolen from linear-base, but without some polymorphism+-- we don't need here.++toLinear+ :: forall a b p q.+ (a %p-> b) %1-> (a %q-> b)+toLinear f = case unsafeEqualityProof @p @q of+ UnsafeRefl -> f++-- Stolen from profunctors++infixr 9 #.+(#.) :: Coercible b c => p b c -> (a -> b) -> a -> c+(#.) _ = coerce++infixl 8 .#+(.#) :: Coercible a b => (b -> c) -> p a b -> a -> c+f .# _ = coerce f
+ tests/DefaultSpec.hs view
@@ -0,0 +1,161 @@+-- |+-- Module : DefaultSpec+-- Description : Ensure that deriving via (Default a) newtype works+-- License : BSD-3-Clause+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- Tests DerivingVia on GHC versions 8.6 and above. There are no tests on+-- versions below.+--+-- The test check a miscellany of properties of the derived type classes.+-- (Testing all the required properties is beyond the scope of this module.)+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module DefaultSpec where++import Test.Hspec++import Test.Hspec.QuickCheck++import Data.Semigroup (First(..))+import Data.Foldable (sequenceA_)+import Examples hiding (universe)+import Generics.Deriving.Default ()+import Generics.Deriving.Foldable (GFoldable(..))+import Generics.Deriving.Semigroup (GSemigroup(..))+import Generics.Linear.TH++-- These types all implement instances using `DerivingVia`: most via+-- `Default` (one uses `First`).++newtype TestEq = TestEq Bool+ deriving (GEq) via (Default Bool)+newtype TestEnum = TestEnum Bool+ deriving stock (Eq, Show)+ deriving (GEnum) via (Default Bool)+newtype TestShow = TestShow Bool+ deriving (GShow) via (Default Bool)++newtype FirstSemigroup = FirstSemigroup Bool+ deriving stock (Eq, Show)+ deriving (GSemigroup) via (First Bool)++newtype TestFoldable a = TestFoldable (Maybe a)+ deriving (GFoldable) via (Default1 Maybe)++newtype TestFunctor a = TestFunctor (Maybe a)+ deriving stock (Eq, Show, Functor)+ deriving (GFunctor) via (Default1 Maybe)++newtype TestHigherEq a = TestHigherEq (Maybe a)+$(deriveGeneric ''TestHigherEq)+deriving via Default (TestHigherEq a)+ instance GEq a => GEq (TestHigherEq a)++-- These types correspond to the hypothetical examples in the module+-- documentation.++data MyType = MyType Bool+$(deriveGeneric ''MyType)+deriving via Default MyType+ instance GEq MyType++deriving via (Default MyType) instance GShow MyType++data MyType1 a = MyType1 a+$(deriveGenericAnd1 ''MyType1)+deriving via Default (MyType1 a)+ instance GEq a => GEq (MyType1 a)+deriving via Default1 MyType1+ instance GFunctor MyType1++deriving via Default (MyType1 a) instance GShow a => GShow (MyType1 a)+deriving via (Default1 MyType1) instance GFoldable MyType1++spec :: Spec+spec = do+ describe "DerivingVia Default" $ do++ it "GEq is commutative for derivingVia (Default MyType)" . sequenceA_ $+ let commutative :: GEq a => a -> a -> Expectation+ commutative x y = x `geq` y `shouldBe` y `geq` x++ universe :: [MyType]+ universe = MyType <$> [False, True]++ in commutative <$> universe <*> universe++ it "GShow for MyType is like Show for Bool with derivingVia (Default MyType) but prefixed with 'MyType '" $ do+ gshowsPrec 0 (MyType False) "" `shouldBe` "MyType " <> showsPrec 0 False ""+ gshowsPrec 0 (MyType True) "" `shouldBe` "MyType " <> showsPrec 0 True ""++ it "GEq is commutative for parameterized derivingVia (Default (MyType1 Bool))" . sequenceA_ $+ let commutative :: GEq a => a -> a -> Expectation+ commutative x y = x `geq` y `shouldBe` y `geq` x++ universe :: [MyType1 Bool]+ universe = MyType1 <$> [False, True]++ in commutative <$> universe <*> universe++ it "GShow for MyType1 Bool is like Show for Bool with derivingVia (Default (MyType1 Bool)) but prefixed with 'MyType1 '" $ do+ gshowsPrec 0 (MyType1 False) "" `shouldBe` "MyType1 " <> showsPrec 0 False ""+ gshowsPrec 0 (MyType1 True) "" `shouldBe` "MyType1 " <> showsPrec 0 True ""++ it "GEq is commutative for derivingVia (Default Bool)" . sequenceA_ $+ let commutative :: GEq a => a -> a -> Expectation+ commutative x y = x `geq` y `shouldBe` y `geq` x++ universe :: [TestEq]+ universe = TestEq <$> [False, True]++ in commutative <$> universe <*> universe++ it "GENum is correct for derivingVia (Default Bool)" $+ genum `shouldBe` [TestEnum False, TestEnum True]++ it "GShow for TestShow is the same as Show for Bool with derivingVia (Default Bool)" $ do+ gshowsPrec 0 (TestShow False) "" `shouldBe` showsPrec 0 False ""+ gshowsPrec 0 (TestShow True) "" `shouldBe` showsPrec 0 True ""++ it "GSemigroup is like First when instantiated with derivingVia (First Bool)" . sequenceA_ $+ let first' :: (Eq a, Show a, GSemigroup a) => a -> a -> Expectation+ first' x y = x `gsappend` y `shouldBe` x++ universe :: [FirstSemigroup]+ universe = FirstSemigroup <$> [False, True]++ in first' <$> universe <*> universe++ prop "GFoldable with derivingVia (Default1 Option) acts like mconcat with Maybe (First Bool)" $ \(xs :: [Maybe Bool]) ->+ let ys :: [Maybe (First Bool)]+ -- Note that there is no Arbitrary instance for this type+ ys = fmap First <$> xs++ unTestFoldable :: TestFoldable a -> Maybe a+ unTestFoldable (TestFoldable x) = x++ in gfoldMap unTestFoldable (TestFoldable <$> ys) `shouldBe` mconcat ys++ it "GFunctor for TestFunctor Bool is as Functor for Maybe Bool" . sequenceA_ $+ let universe :: [Maybe Bool]+ universe = [Nothing, Just False, Just True]++ functor_prop :: Maybe Bool -> Expectation+ functor_prop x = gmap not (TestFunctor x) `shouldBe` TestFunctor (not <$> x)++ in functor_prop <$> universe++ return ()
+ tests/EmptyCaseSpec.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE DataKinds #-}+#endif++#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE EmptyCase #-}+#endif++module EmptyCaseSpec (main, spec) where++import Generics.Linear.TH+import Test.Hspec++data Empty a+$(deriveGenericAnd1 ''Empty)++main :: IO ()+main = hspec spec++spec :: Spec+spec = return ()
+ tests/ExampleSpec.hs view
@@ -0,0 +1,396 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module ExampleSpec (main, spec) where++import Examples+import Generics.Linear.TH++import GHC.Exts (Addr#, Char#, Double#, Float#, Int#, Word#)++import Prelude hiding (Either(..))++import Test.Hspec (Spec, describe, hspec, it, parallel, shouldBe)++import qualified Text.Read.Lex (Lexeme)+import Data.Kind (Type)++-------------------------------------------------------------------------------+-- Example: Haskell's lists and Maybe+-------------------------------------------------------------------------------++hList:: [Int]+hList = [1..10]++maybe1, maybe2 :: Maybe (Maybe Char)+maybe1 = Nothing+maybe2 = Just (Just 'p')++double :: [Int] -> [Int]+double [] = []+double (x:xs) = x:x:xs++-------------------------------------------------------------------------------+-- Example: trees of integers (kind *)+-------------------------------------------------------------------------------++data Tree = Empty | Branch Int Tree Tree++$(deriveGeneric ''Tree)++instance GShow Tree where+ gshowsPrec = gshowsPrecdefault++instance Uniplate Tree where+ children = childrendefault+ context = contextdefault+ descend = descenddefault+ descendM = descendMdefault+ transform = transformdefault+ transformM = transformMdefault++instance GEnum Tree where+ genum = genumDefault++upgradeTree :: Tree -> Tree+upgradeTree Empty = Branch 0 Empty Empty+upgradeTree (Branch n l r) = Branch (succ n) l r++tree :: Tree+tree = Branch 2 Empty (Branch 1 Empty Empty)++-------------------------------------------------------------------------------+-- Example: lists (kind * -> *)+-------------------------------------------------------------------------------++data List a = Nil | Cons a (List a)++$(deriveGenericAnd1 ''List)++instance GFunctor List where+ gmap = gmapdefault++instance (GShow a) => GShow (List a) where+ gshowsPrec = gshowsPrecdefault++instance (Uniplate a) => Uniplate (List a) where+ children = childrendefault+ context = contextdefault+ descend = descenddefault+ descendM = descendMdefault+ transform = transformdefault+ transformM = transformMdefault++list :: List Char+list = Cons 'p' (Cons 'q' Nil)++listlist :: List (List Char)+listlist = Cons list (Cons Nil Nil) -- ["pq",""]++-------------------------------------------------------------------------------+-- Example: Type composition+-------------------------------------------------------------------------------++data Rose a = Rose [a] [Rose a]++$(deriveGenericAnd1 ''Rose)++instance (GShow a) => GShow (Rose a) where+ gshowsPrec = gshowsPrecdefault++instance GFunctor Rose where+ gmap = gmapdefault++-- Example usage+rose1 :: Rose Int+rose1 = Rose [1,2] [Rose [3,4] [], Rose [5] []]++-------------------------------------------------------------------------------+-- Example: Higher-order kinded datatype, type composition+-------------------------------------------------------------------------------++data GRose f a = GRose (f a) (f (GRose f a))+deriving instance Functor f => Functor (GRose f)++$(deriveGenericAnd1 ''GRose)++instance (GShow (f a), GShow (f (GRose f a))) => GShow (GRose f a) where+ gshowsPrec = gshowsPrecdefault++instance (Functor f, GFunctor f) => GFunctor (GRose f) where+ gmap = gmapdefault++grose1 :: GRose [] Int+grose1 = GRose [1,2] [GRose [3] [], GRose [] []]++-------------------------------------------------------------------------------+-- Example: Two parameters, nested on other parameter+-------------------------------------------------------------------------------++data Either a b = Left (Either [a] b) | Right b++$(deriveGenericAnd1 ''Either)++instance (GShow a, GShow b) => GShow (Either a b) where+ gshowsPrec = gshowsPrecdefault++instance GFunctor (Either a) where+ gmap = gmapdefault++either1 :: Either Int Char+either1 = Left either2++either2 :: Either [Int] Char+either2 = Right 'p'++-------------------------------------------------------------------------------+-- Example: Nested datatype, record selectors+-------------------------------------------------------------------------------++data Nested a = Leaf | Nested { value :: a, rec :: Nested [a] }+ deriving Functor++$(deriveGenericAnd1 ''Nested)++instance (GShow a) => GShow (Nested a) where+ gshowsPrec = gshowsPrecdefault++instance GFunctor Nested where+ gmap = gmapdefault++nested :: Nested Int+nested = Nested { value = 1, rec = Nested [2] (Nested [[3],[4,5],[]] Leaf) }++-------------------------------------------------------------------------------+-- Example: Nested datatype Bush (minimal)+-------------------------------------------------------------------------------++data Bush a = BushNil | BushCons a (Bush (Bush a)) deriving Functor++$(deriveGenericAnd1 ''Bush)++instance GFunctor Bush where+ gmap = gmapdefault++instance (GShow a) => GShow (Bush a) where+ gshowsPrec = gshowsPrecdefault++bush1 :: Bush Int+bush1 = BushCons 0 (BushCons (BushCons 1 BushNil) BushNil)++-------------------------------------------------------------------------------+-- Example: Double type composition (minimal)+-------------------------------------------------------------------------------++data Weird a = Weird [[[a]]] deriving Show++$(deriveGenericAnd1 ''Weird)++instance GFunctor Weird where+ gmap = gmapdefault++data Bloom a = Bloom (Maybe (Bloom a)) | Bling a+$(deriveGenericAnd1 ''Bloom)++data Fix f a = Fix (f (Fix f a))+$(deriveGenericAnd1 ''Fix)++--------------------------------------------------------------------------------+-- Temporary tests for TH generation+--------------------------------------------------------------------------------++data Empty a++data (:/:) f a = MyType1Nil+ | MyType1Cons { _myType1Rec :: (f :/: a), _myType2Rec :: MyType2 }+ | MyType1Cons2 (f :/: a) Int a (f a)+ | (f :/: a) :/: MyType2++infixr 5 :!@!:+data GADTSyntax a b where+ GADTPrefix :: d -> c -> GADTSyntax c d+ (:!@!:) :: e -> f -> GADTSyntax e f++data MyType2 = MyType2 Float ([] :/: Int)+data PlainHash a = Hash a Addr# Char# Double# Float# Int# Word#++-- Test to see if generated names are unique+data Lexeme = Lexeme++data family MyType3+ (a :: v) (b :: w) (c :: x) (d :: y) (e :: z)+newtype instance MyType3 (f p) (f p) f p (q :: Type) = MyType3Newtype q+data instance MyType3 Bool () f p q = MyType3True | MyType3False+data instance MyType3 Int () f p (q :: Type) = MyType3Hash q Addr# Char# Double# Float# Int# Word#++$(deriveGenericAnd1 ''Empty)+$(deriveGenericAnd1 ''(:/:))+$(deriveGenericAnd1 ''GADTSyntax)+$(deriveGeneric ''MyType2)+$(deriveGenericAnd1 ''PlainHash)+$(deriveGeneric ''ExampleSpec.Lexeme)+$(deriveGeneric ''Text.Read.Lex.Lexeme)+$(deriveGenericAnd1 'MyType3Newtype)+$(deriveGenericAnd1 'MyType3False)+$(deriveGenericAnd1 'MyType3Hash)++-------------------------------------------------------------------------------+-- Unit tests+-------------------------------------------------------------------------------++main :: IO ()+main = hspec spec++spec :: Spec+spec = parallel $ do+ describe "[] and Maybe tests" $ do+ it "gshow hList" $+ gshow hList `shouldBe`+ "[1,2,3,4,5,6,7,8,9,10]"++ it "gshow (children maybe2)" $+ gshow (children maybe2) `shouldBe`+ "[]"++ it "gshow (transform (const \"abc\") [])" $+ gshow (transform (const "abc") []) `shouldBe`+ "\"abc\""++ it "gshow (transform double hList)" $+ gshow (transform double hList) `shouldBe`+ "[1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8,9,9,10,10]"++ it "gshow (geq hList hList)" $+ gshow (geq hList hList) `shouldBe`+ "True"++ it "gshow (geq maybe1 maybe2)" $+ gshow (geq maybe1 maybe2) `shouldBe`+ "False"++ it "gshow (take 5 genum)" $+ gshow (take 5 (genum :: [Maybe Int])) `shouldBe`+ "[Nothing,Just 0,Just -1,Just 1,Just -2]"++ it "gshow (take 15 genum)" $+ gshow (take 15 (genum :: [[Int]])) `shouldBe`+ "[[],[0],[0,0],[-1],[0,0,0],[-1,0],[1],[0,-1],[-1,0,0],[1,0],[-2],[0,0,0,0],[-1,-1],[1,0,0],[-2,0]]"++ it "gshow (range ([0], [1]))" $+ gshow (range ([0], [1::Int])) `shouldBe`+ "[[0],[0,0],[-1],[0,0,0],[-1,0]]"++ it "gshow (inRange ([0], [3,5]) hList)" $+ gshow (inRange ([0], [3,5::Int]) hList) `shouldBe`+ "False"++ describe "Tests for Tree" $ do+ it "gshow tree" $+ gshow tree `shouldBe`+ "Branch 2 Empty (Branch 1 Empty Empty)"++ it "gshow (children tree)" $+ gshow (children tree) `shouldBe`+ "[Empty,Branch 1 Empty Empty]"++ it "gshow (descend (descend (\\_ -> Branch 0 Empty Empty)) tree)" $+ gshow (descend (descend (\_ -> Branch 0 Empty Empty)) tree) `shouldBe`+ "Branch 2 Empty (Branch 1 (Branch 0 Empty Empty) (Branch 0 Empty Empty))"++ it "gshow (context tree [Branch 1 Empty Empty,Empty])" $+ gshow (context tree [Branch 1 Empty Empty,Empty]) `shouldBe`+ "Branch 2 (Branch 1 Empty Empty) Empty"++ it "gshow (transform upgradeTree tree)" $+ gshow (transform upgradeTree tree) `shouldBe`+ "Branch 3 (Branch 0 Empty Empty) (Branch 2 (Branch 0 Empty Empty) (Branch 0 Empty Empty))"++ it "gshow (take 10 genum)" $ do+ gshow (take 10 (genum :: [Tree])) `shouldBe`+ "[Empty,Branch 0 Empty Empty,Branch 0 Empty (Branch 0 Empty Empty),Branch -1 Empty Empty,Branch 0 (Branch 0 Empty Empty) Empty,Branch -1 Empty (Branch 0 Empty Empty),Branch 1 Empty Empty,Branch 0 Empty (Branch 0 Empty (Branch 0 Empty Empty)),Branch -1 (Branch 0 Empty Empty) Empty,Branch 1 Empty (Branch 0 Empty Empty)]"++ describe "Tests for List" $ do+ it "gshow (gmap fromEnum list)" $+ gshow (gmap fromEnum list) `shouldBe`+ "Cons 112 (Cons 113 Nil)"++ it "gshow (gmap gshow listlist)" $+ gshow (gmap gshow listlist) `shouldBe`+ "Cons \"Cons 'p' (Cons 'q' Nil)\" (Cons \"Nil\" Nil)"++ it "gshow list" $+ gshow list `shouldBe`+ "Cons 'p' (Cons 'q' Nil)"++ it "gshow listlist" $+ gshow listlist `shouldBe`+ "Cons (Cons 'p' (Cons 'q' Nil)) (Cons Nil Nil)"++ it "gshow (children list)" $+ gshow (children list) `shouldBe`+ "[Cons 'q' Nil]"++ it "gshow (children listlist)" $+ gshow (children listlist) `shouldBe`+ "[Cons Nil Nil]"++ describe "Tests for Rose" $ do+ it "gshow rose1" $+ gshow rose1 `shouldBe`+ "Rose [1,2] [Rose [3,4] [],Rose [5] []]"++ it "gshow (gmap gshow rose1)" $+ gshow (gmap gshow rose1) `shouldBe`+ "Rose [\"1\",\"2\"] [Rose [\"3\",\"4\"] [],Rose [\"5\"] []]"++ describe "Tests for GRose" $ do+ it "gshow grose1" $+ gshow grose1 `shouldBe`+ "GRose [1,2] [GRose [3] [],GRose [] []]"++ it "gshow (gmap gshow grose1)" $+ gshow (gmap gshow grose1) `shouldBe`+ "GRose [\"1\",\"2\"] [GRose [\"3\"] [],GRose [] []]"++ describe "Tests for Either" $ do+ it "gshow either1" $+ gshow either1 `shouldBe`+ "Left Right 'p'"++ it "gshow (gmap gshow either1)" $+ gshow (gmap gshow either1) `shouldBe`+ "Left Right \"'p'\""++ describe "Tests for Nested" $ do+ it "gshow nested" $+ gshow nested `shouldBe`+ "Nested {value = 1, rec = Nested {value = [2], rec = Nested {value = [[3],[4,5],[]], rec = Leaf}}}"++ it "gshow (gmap gshow nested)" $+ gshow (gmap gshow nested) `shouldBe`+ "Nested {value = \"1\", rec = Nested {value = [\"2\"], rec = Nested {value = [[\"3\"],[\"4\",\"5\"],[]], rec = Leaf}}}"++ describe "Tests for Bush" $ do+ it "gshow bush1" $+ gshow bush1 `shouldBe`+ "BushCons 0 (BushCons (BushCons 1 BushNil) BushNil)"++ it "gshow (gmap gshow bush1)" $+ gshow (gmap gshow bush1) `shouldBe`+ "BushCons \"0\" (BushCons (BushCons \"1\" BushNil) BushNil)"
+ tests/Examples.hs view
@@ -0,0 +1,28 @@+-- These examples are all yanked from generic-deriving, which exports them as+-- part of the package, and modified as needed. We probably don't want to+-- expose them from this package, but they make for great tests!+module Examples (++ module Generics.Linear,+ module Generics.Deriving.Copoint,+ module Generics.Deriving.ConNames,+ module Generics.Deriving.Default,+ module Generics.Deriving.Enum,+ module Generics.Deriving.Eq,+ module Generics.Deriving.Functor,+ module Generics.Deriving.Show,+ module Generics.Deriving.Uniplate,+ module Generics.Deriving.TraversableConf++ ) where++import Generics.Linear+import Generics.Deriving.Copoint+import Generics.Deriving.ConNames+import Generics.Deriving.Default+import Generics.Deriving.Enum+import Generics.Deriving.Eq+import Generics.Deriving.Functor+import Generics.Deriving.Show+import Generics.Deriving.Uniplate+import Generics.Deriving.TraversableConf
+ tests/Generics/Deriving/ConNames.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif++#if __GLASGOW_HASKELL__ >= 705+{-# LANGUAGE PolyKinds #-}+#endif++{- |+Module : Generics.Deriving.ConNames+Copyright : (c) 2012 University of Oxford+License : BSD3++Maintainer : generics@haskell.org+Stability : experimental+Portability : non-portable++Summary: Return the name of all the constructors of a type.+-}++module Generics.Deriving.ConNames (++ -- * Functionality for retrieving the names of the possible contructors+ -- of a type or the constructor name of a given value+ ConNames(..), conNames, conNameOf++ ) where++import Generics.Linear+++class ConNames f where+ gconNames :: f a -> [String]+ gconNameOf :: f a -> String++instance (ConNames f, ConNames g) => ConNames (f :+: g) where+ gconNames (_ :: (f :+: g) a) = gconNames (undefined :: f a) +++ gconNames (undefined :: g a)++ gconNameOf (L1 x) = gconNameOf x+ gconNameOf (R1 x) = gconNameOf x++instance (ConNames f) => ConNames (D1 c f) where+ gconNames (_ :: (D1 c f) a) = gconNames (undefined :: f a)++ gconNameOf (M1 x) = gconNameOf x++instance (Constructor c) => ConNames (C1 c f) where+ gconNames x = [conName x]++ gconNameOf x = conName x+++-- We should never need any other instances.+++-- | Return the name of all the constructors of the type of the given term.+conNames :: (Generic a, ConNames (Rep a)) => a -> [String]+conNames x = gconNames (undefined `asTypeOf` (from x))++-- | Return the name of the constructor of the given term+conNameOf :: (ConNames (Rep a), Generic a) => a -> String+conNameOf x = gconNameOf (from x)
+ tests/Generics/Deriving/Copoint.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}++{-# LANGUAGE DefaultSignatures #-}++{-# LANGUAGE PolyKinds #-}++{-# LANGUAGE Safe #-}+{-# LANGUAGE TypeApplications #-}++module Generics.Deriving.Copoint (+ -- * GCopoint class+ GCopoint(..)++ -- * Default method+ , gcopointdefault++ -- * Internal class+ , GCopoint'(..)++ ) where++import Control.Applicative (WrappedMonad)++import Data.Monoid (Dual)+import qualified Data.Monoid as Monoid (Sum)++import Generics.Linear++import Data.Ord (Down)++import Data.Functor.Identity (Identity)+import Data.Monoid (Alt)++import qualified Data.Functor.Sum as Functor (Sum)+import Data.Semigroup (Arg, First, Last, Max, Min, WrappedMonoid)++--------------------------------------------------------------------------------+-- Generic copoint+--------------------------------------------------------------------------------++-- General copoint may return 'Nothing'++class GCopoint' t where+ gcopoint' :: (a -> b) -> t a -> Maybe b++instance GCopoint' V1 where+ gcopoint' _ _ = Nothing++instance GCopoint' U1 where+ gcopoint' _ U1 = Nothing++instance GCopoint' Par1 where+ gcopoint' f (Par1 a) = Just (f a)++instance GCopoint' (K1 i c) where+ gcopoint' _ _ = Nothing++instance GCopoint' f => GCopoint' (M1 i c f) where+ gcopoint' f (M1 a) = gcopoint' f a++instance GCopoint' f => GCopoint' (MP1 m f) where+ gcopoint' f (MP1 a) = gcopoint' f a++instance (GCopoint' f, GCopoint' g) => GCopoint' (f :+: g) where+ gcopoint' f (L1 a) = gcopoint' f a+ gcopoint' f (R1 a) = gcopoint' f a++-- Favours left "hole" for copoint+instance (GCopoint' f, GCopoint' g) => GCopoint' (f :*: g) where+ gcopoint' f (a :*: b) = case (gcopoint' f a) of+ Just x -> Just x+ Nothing -> gcopoint' f b++instance (GCopoint' f, GCopoint g) => GCopoint' (f :.: g) where+ gcopoint' f (Comp1 x) = gcopoint' (f . gcopoint) x++class GCopoint d where+ gcopoint :: d a -> a+ default gcopoint :: (Generic1 d, GCopoint' (Rep1 d))+ => (d a -> a)+ gcopoint = gcopointdefault++gcopointdefault :: (Generic1 d, GCopoint' (Rep1 d))+ => d a -> a+gcopointdefault x = case (gcopoint' id . from1 $ x) of+ Just x' -> x'+ Nothing -> error "Data type is not copointed"++-- instance (Generic1 d, GCopoint' (Rep1 d)) => GCopoint d++-- Base types instances+instance GCopoint ((,) a)+instance GCopoint ((,,) a b)+instance GCopoint ((,,,) a b c)+instance GCopoint ((,,,,) a b c d)+instance GCopoint ((,,,,,) a b c d e)+instance GCopoint ((,,,,,,) a b c d e f)+instance GCopoint f => GCopoint (Alt f)+instance GCopoint (Arg a)+instance GCopoint Down+instance GCopoint Dual+instance GCopoint First+instance GCopoint Identity+instance GCopoint Last+instance GCopoint Max+instance GCopoint Min+instance (GCopoint f, GCopoint g) => GCopoint (Functor.Sum f g)+instance GCopoint Monoid.Sum+instance GCopoint m => GCopoint (WrappedMonad m)+instance GCopoint WrappedMonoid
+ tests/Generics/Deriving/Default.hs view
@@ -0,0 +1,281 @@+-- |+-- Module : Generics.Deriving.Default+-- Description : Default implementations of generic classes+-- License : BSD-3-Clause+--+-- Maintainer : generics@haskell.org+-- Stability : experimental+-- Portability : non-portable+--+-- GHC 8.6 introduced the+-- @<https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/glasgow_exts.html?highlight=derivingvia#extension-DerivingVia DerivingVia>@+-- language extension, which means a typeclass instance can be derived from+-- an existing instance for an isomorphic type. Any newtype is isomorphic+-- to the underlying type. By implementing a typeclass once for the newtype,+-- it is possible to derive any typeclass for any type with a 'Generic' instance.+--+-- For a number of classes, there are sensible default instantiations. In+-- older GHCs, these can be supplied in the class definition, using the+-- @<https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/glasgow_exts.html?highlight=defaultsignatures#extension-DefaultSignatures DefaultSignatures>@+-- extension. However, only one default can be provided! With+-- @<https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/glasgow_exts.html?highlight=derivingvia#extension-DerivingVia DerivingVia>@+-- it is now possible to choose from many+-- default instantiations.+--+-- This package contains a number of such classes. This module demonstrates+-- how one might create a family of newtypes ('Default', 'Default1') for+-- which such instances are defined.+--+-- One might then use+-- @<https://downloads.haskell.org/~ghc/8.6.3/docs/html/users_guide/glasgow_exts.html?highlight=derivingvia#extension-DerivingVia DerivingVia>@+-- as follows. The implementations of the data types are elided here (they+-- are irrelevant). For most cases, either the deriving clause with the+-- data type definition or the standalone clause will work (for some types+-- it is necessary to supply the context explicitly using the latter form).+-- See the source of this module for the implementations of instances for+-- the 'Default' family of newtypes and the source of the test suite for+-- some types which derive instances via these wrappers.++{-# LANGUAGE CPP #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+# if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Safe #-}+# else+{-# LANGUAGE Trustworthy #-}+# endif+#endif+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}++module Generics.Deriving.Default+ ( -- * Kind @*@ (aka @Type@)++ -- $default++ Default(..)++ , -- * Kind @* -> *@ (aka @Type -> Type@)++ -- $default1++ Default1(..)++ -- * Other kinds++ -- $other-kinds+ ) where++#if !(MIN_VERSION_base(4,8,0))+import Control.Applicative ((<$>))+#endif+import Control.Monad (liftM)++import Generics.Linear+import Generics.Deriving.Copoint+import Generics.Deriving.Enum+import Generics.Deriving.Eq+import Generics.Deriving.Foldable+import Generics.Deriving.Functor+import Generics.Deriving.Monoid+import Generics.Deriving.Semigroup+import Generics.Deriving.Show+import Generics.Deriving.Traversable+import Generics.Deriving.Uniplate++-- $default+--+-- For classes which take an argument of kind 'Data.Kind.Type', use+-- 'Default'. An example of this class from @base@ would be 'Eq', or+-- 'Generic'.+--+-- These examples use 'GShow' and 'GEq'; they are interchangeable.+--+-- @+-- data MyType = …+-- deriving ('Generic')+-- deriving ('GEq') via ('Default' MyType)+--+-- deriving via ('Default' MyType) instance 'GShow' MyType+-- @+--+-- Instances may be parameterized by type variables.+--+-- @+-- data MyType1 a = …+-- deriving ('Generic')+-- deriving ('GShow') via ('Default' (MyType1 a))+--+-- deriving via 'Default' (MyType1 a) instance 'GEq' a => 'GEq' (MyType1 a)+-- @+--+-- These types both require instances for 'Generic'. This is because the+-- implementations of 'geq' and 'gshowsPrec' for @'Default' b@ have a @'Generic'+-- b@ constraint, i.e. the type corresponding to @b@ require a 'Generic'+-- instance. For these two types, that means instances for @'Generic' MyType@+-- and @'Generic' (MyType1 a)@ respectively.+--+-- It also means the 'Generic' instance is not needed when there is already+-- a generic instance for the type used to derive the relevant instances.+-- For an example, see the documentation of the 'GShow' instance for+-- 'Default', below.++-- | This newtype wrapper can be used to derive default instances for+-- classes taking an argument of kind 'Data.Kind.Type'.+newtype Default a = Default { unDefault :: a }++-- $default1+--+-- For classes which take an argument of kind @'Data.Kind.Type' ->+-- 'Data.Kind.Type'@, use 'Default1'. An example of this class from @base@+-- would be 'Data.Functor.Classes.Eq1', or 'Generic1'.+--+-- Unlike for @MyType1@, there can be no implementation of these classes for @MyType :: 'Data.Kind.Type'@.+--+-- @+-- data MyType1 a = …+-- deriving ('Generic1')+-- deriving ('GFunctor') via ('Default1' MyType1)+--+-- deriving via ('Default1' MyType1) instance 'GFoldable' MyType1+-- @+--+-- Note that these instances require a @'Generic1' MyType1@ constraint as+-- 'gmap' and 'gfoldMap' have @'Generic1' a@ constraints on the+-- implementations for @'Default1' a@.++-- | This newtype wrapper can be used to derive default instances for+-- classes taking an argument of kind @'Data.Kind.Type' -> 'Data.Kind.Type'@.+newtype Default1 f a = Default1 { unDefault1 :: f a }++-- $other-kinds+--+-- These principles extend to classes taking arguments of other kinds.++--------------------------------------------------------------------------------+-- Eq+--------------------------------------------------------------------------------++instance (Generic a, GEq' (Rep a)) => GEq (Default a) where+ -- geq :: Default a -> Default a -> Bool+ Default x `geq` Default y = x `geqdefault` y++--------------------------------------------------------------------------------+-- Enum+--------------------------------------------------------------------------------++-- | The 'Enum' class in @base@ is slightly different; it comprises 'toEnum' and+-- 'fromEnum'. "Generics.Deriving.Enum" provides functions 'toEnumDefault'+-- and 'fromEnumDefault'.+instance (Generic a, GEq a, Enum' (Rep a)) => GEnum (Default a) where+ -- genum :: [Default a]+ genum = Default . to <$> enum'++--------------------------------------------------------------------------------+-- Show+--------------------------------------------------------------------------------++-- | For example, with this type:+--+-- @+-- newtype TestShow = TestShow 'Bool'+-- deriving ('GShow') via ('Default' 'Bool')+-- @+--+-- 'gshow' for @TestShow@ would produce the same string as `gshow` for+-- 'Bool'.+--+-- In this example, @TestShow@ requires no 'Generic' instance, as the+-- constraint on 'gshowsPrec' from @'Default' 'Bool'@ is @'Generic' 'Bool'@.+--+-- In general, when using a newtype wrapper, the instance can be derived+-- via the wrapped type, as here (via @'Default' 'Bool'@ rather than @'Default'+-- TestShow@).+instance (Generic a, GShow' (Rep a)) => GShow (Default a) where+ -- gshowsPrec :: Int -> Default a -> ShowS+ gshowsPrec n (Default x) = gshowsPrecdefault n x++--------------------------------------------------------------------------------+-- Semigroup+--------------------------------------------------------------------------------++-- | Semigroups often have many sensible implementations of+-- 'Data.Semigroup.<>' / 'gsappend', and therefore no sensible default.+-- Indeed, there is no 'GSemigroup'' instance for representations of sum+-- types.+--+-- In other cases, one may wish to use the existing wrapper newtypes in+-- @base@, such as the following (using 'Data.Semigroup.First'):+--+-- @+-- newtype FirstSemigroup = FirstSemigroup 'Bool'+-- deriving stock ('Eq', 'Show')+-- deriving ('GSemigroup') via ('Data.Semigroup.First' 'Bool')+-- @+--+instance (Generic a, GSemigroup' (Rep a)) => GSemigroup (Default a) where+ -- gsappend :: Default a -> Default a -> Default a+ Default x `gsappend` Default y = Default $ x `gsappenddefault` y++--------------------------------------------------------------------------------+-- Monoid+--------------------------------------------------------------------------------++instance (Generic a, GMonoid' (Rep a)) => GMonoid (Default a) where+ -- gmempty :: Default a+ gmempty = Default gmemptydefault++ -- gmappend :: Default a -> Default a -> Default a+ Default x `gmappend` Default y = Default $ x `gmappenddefault` y++--------------------------------------------------------------------------------+-- Uniplate+--------------------------------------------------------------------------------++instance (Generic a, Uniplate' (Rep a) a, Context' (Rep a) a) => Uniplate (Default a) where++ -- children :: Default a -> [Default a]+ -- context :: Default a -> [Default a] -> Default a+ -- descend :: (Default a -> Default a) -> Default a -> Default a+ -- descendM :: Monad m => (Default a -> m (Default a)) -> Default a -> m (Default a)+ -- transform :: (Default a -> Default a) -> Default a -> Default a+ -- transformM :: Monad m => (Default a -> m (Default a)) -> Default a -> m (Default a)++ children (Default x) = Default <$> childrendefault x+ context (Default x) ys = Default $ contextdefault x (unDefault <$> ys)+ descend f (Default x) = Default $ descenddefault (unDefault . f . Default) x+ descendM f (Default x) = liftM Default $ descendMdefault (liftM unDefault . f . Default) x+ transform f (Default x) = Default $ transformdefault (unDefault . f . Default) x+ transformM f (Default x) = liftM Default $ transformMdefault (liftM unDefault . f . Default) x++--------------------------------------------------------------------------------+-- Functor+--------------------------------------------------------------------------------++instance (Generic1 f, GFunctor' (Rep1 f)) => GFunctor (Default1 f) where+ -- gmap :: (a -> b) -> (Default1 f) a -> (Default1 f) b+ gmap f (Default1 fx) = Default1 $ gmapdefault f fx++--------------------------------------------------+-- Copoint+--------------------------------------------------++instance (Generic1 f, GCopoint' (Rep1 f)) => GCopoint (Default1 f) where+ -- gcopoint :: Default1 f a -> a+ gcopoint = gcopointdefault . unDefault1++--------------------------------------------------+-- Foldable+--------------------------------------------------++instance (Generic1 t, GFoldable' (Rep1 t)) => GFoldable (Default1 t) where+ -- gfoldMap :: Monoid m => (a -> m) -> Default1 t a -> m+ gfoldMap f (Default1 tx) = gfoldMapdefault f tx++--------------------------------------------------+-- Traversable+--------------------------------------------------++instance (Generic1 t, GFunctor' (Rep1 t), GFoldable' (Rep1 t), GTraversable' (Rep1 t)) => GTraversable (Default1 t) where+ -- gtraverse :: Applicative f => (a -> f b) -> Default1 t a -> f (Default1 t b)+ gtraverse f (Default1 fx) = Default1 <$> gtraversedefault f fx
+ tests/Generics/Deriving/Enum.hs view
@@ -0,0 +1,1140 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE Trustworthy #-}+#endif++#if __GLASGOW_HASKELL__ >= 705+{-# LANGUAGE PolyKinds #-}+#endif++#include "HsBaseConfig.h"++module Generics.Deriving.Enum (++ -- * Generic enum class+ GEnum(..)++ -- * Default definitions for GEnum+ , genumDefault, toEnumDefault, fromEnumDefault++ -- * Internal enum class+ , Enum'(..)++ -- * Generic Ix class+ , GIx(..)++ -- * Default definitions for GIx+ , rangeDefault, indexDefault, inRangeDefault++ ) where++import Control.Applicative (Const, ZipList)++import Data.Int+import Data.Monoid (All, Any, Dual, Product, Sum)+import qualified Data.Monoid as Monoid (First, Last)+import Data.Word++import Foreign.C.Types+import Foreign.Ptr++import Generics.Linear+import Generics.Deriving.Eq++import System.Exit (ExitCode)+import System.Posix.Types++#if MIN_VERSION_base(4,4,0)+import Data.Complex (Complex)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Coerce (coerce)+import Data.Proxy (Proxy)+#else+import Unsafe.Coerce (unsafeCoerce)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+import Data.Monoid (Alt)+import Numeric.Natural (Natural)+#endif++#if MIN_VERSION_base(4,9,0)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg, Max, Min, WrappedMonoid)+#endif++-----------------------------------------------------------------------------+-- Utility functions for Enum'+-----------------------------------------------------------------------------++infixr 5 |||++-- | Interleave elements from two lists. Similar to (++), but swap left and+-- right arguments on every recursive application.+--+-- From Mark Jones' talk at AFP2008+(|||) :: [a] -> [a] -> [a]+[] ||| ys = ys+(x:xs) ||| ys = x : ys ||| xs++-- | Diagonalization of nested lists. Ensure that some elements from every+-- sublist will be included. Handles infinite sublists.+--+-- From Mark Jones' talk at AFP2008+diag :: [[a]] -> [a]+diag = concat . foldr skew [] . map (map (\x -> [x]))++skew :: [[a]] -> [[a]] -> [[a]]+skew [] ys = ys+skew (x:xs) ys = x : combine (++) xs ys++combine :: (a -> a -> a) -> [a] -> [a] -> [a]+combine _ xs [] = xs+combine _ [] ys = ys+combine f (x:xs) (y:ys) = f x y : combine f xs ys++findIndex :: (a -> Bool) -> [a] -> Maybe Int+findIndex p xs = let l = [ i | (y,i) <- zip xs [(0::Int)..], p y]+ in if (null l)+ then Nothing+ else Just (head l)++--------------------------------------------------------------------------------+-- Generic enum+--------------------------------------------------------------------------------++class Enum' f where+ enum' :: [f a]++instance Enum' U1 where+ enum' = [U1]++instance GEnum c => Enum' (K1 i c) where+ enum' = map K1 genum++instance Enum' f => Enum' (M1 i c f) where+ enum' = map M1 enum'++instance Enum' f => Enum' (MP1 m f) where+ enum' = map (\x -> MP1 x) enum'++instance (Enum' f, Enum' g) => Enum' (f :+: g) where+ enum' = map L1 enum' ||| map R1 enum'++instance (Enum' f, Enum' g) => Enum' (f :*: g) where+ enum' = diag [ [ x :*: y | y <- enum' ] | x <- enum' ]++genumDefault :: (Generic a, Enum' (Rep a)) => [a]+genumDefault = map to enum'++toEnumDefault :: (Generic a, Enum' (Rep a)) => Int -> a+toEnumDefault i = let l = enum'+ in if (length l > i)+ then to (l !! i)+ else error "toEnum: invalid index"++fromEnumDefault :: (GEq a, Generic a, Enum' (Rep a))+ => a -> Int+fromEnumDefault x = case findIndex (geq x) (map to enum') of+ Nothing -> error "fromEnum: no corresponding index"+ Just i -> i+++class GEnum a where+ genum :: [a]++#if __GLASGOW_HASKELL__ >= 701+ default genum :: (Generic a, Enum' (Rep a)) => [a]+ genum = genumDefault+#endif++genumNumUnbounded :: Num a => [a]+genumNumUnbounded = pos 0 ||| neg 0 where+ pos n = n : pos (n + 1)+ neg n = (n-1) : neg (n - 1)++genumNumSigned :: (Bounded a, Enum a, Num a) => [a]+genumNumSigned = [0 .. maxBound] ||| [-1, -2 .. minBound]++genumNumUnsigned :: (Enum a, Num a) => [a]+genumNumUnsigned = [0 ..]++#if !(MIN_VERSION_base(4,7,0))+coerce :: a -> b+coerce = unsafeCoerce+#endif++-- Base types instances+instance GEnum () where+ genum = genumDefault++instance (GEnum a, GEnum b) => GEnum (a, b) where+ genum = genumDefault++instance (GEnum a, GEnum b, GEnum c) => GEnum (a, b, c) where+ genum = genumDefault++instance (GEnum a, GEnum b, GEnum c, GEnum d) => GEnum (a, b, c, d) where+ genum = genumDefault++instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e) => GEnum (a, b, c, d, e) where+ genum = genumDefault++instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f)+ => GEnum (a, b, c, d, e, f) where+ genum = genumDefault++instance (GEnum a, GEnum b, GEnum c, GEnum d, GEnum e, GEnum f, GEnum g)+ => GEnum (a, b, c, d, e, f, g) where+ genum = genumDefault++instance GEnum a => GEnum [a] where+ genum = genumDefault++instance (GEnum (f p), GEnum (g p)) => GEnum ((f :+: g) p) where+ genum = genumDefault++instance (GEnum (f p), GEnum (g p)) => GEnum ((f :*: g) p) where+ genum = genumDefault++instance GEnum (f (g p)) => GEnum ((f :.: g) p) where+ genum = genumDefault++instance GEnum All where+ genum = genumDefault++#if MIN_VERSION_base(4,8,0)+instance GEnum (f a) => GEnum (Alt f a) where+ genum = genumDefault+#endif++instance GEnum Any where+ genum = genumDefault++#if MIN_VERSION_base(4,9,0)+instance (GEnum a, GEnum b) => GEnum (Arg a b) where+ genum = genumDefault+#endif++#if !(MIN_VERSION_base(4,9,0))+instance GEnum Arity where+ genum = genumDefault+#endif++instance GEnum Associativity where+ genum = genumDefault++instance GEnum Bool where+ genum = genumDefault++#if defined(HTYPE_CC_T)+instance GEnum CCc where+ genum = coerce (genum :: [HTYPE_CC_T])+#endif++instance GEnum CChar where+ genum = coerce (genum :: [HTYPE_CHAR])++instance GEnum CClock where+ genum = coerce (genum :: [HTYPE_CLOCK_T])++#if defined(HTYPE_DEV_T)+instance GEnum CDev where+ genum = coerce (genum :: [HTYPE_DEV_T])+#endif++instance GEnum CDouble where+ genum = coerce (genum :: [HTYPE_DOUBLE])++instance GEnum CFloat where+ genum = coerce (genum :: [HTYPE_FLOAT])++#if defined(HTYPE_GID_T)+instance GEnum CGid where+ genum = coerce (genum :: [HTYPE_GID_T])+#endif++#if defined(HTYPE_INO_T)+instance GEnum CIno where+ genum = coerce (genum :: [HTYPE_INO_T])+#endif++instance GEnum CInt where+ genum = coerce (genum :: [HTYPE_INT])++instance GEnum CIntMax where+ genum = coerce (genum :: [HTYPE_INTMAX_T])++instance GEnum CIntPtr where+ genum = coerce (genum :: [HTYPE_INTPTR_T])++instance GEnum CLLong where+ genum = coerce (genum :: [HTYPE_LONG_LONG])++instance GEnum CLong where+ genum = coerce (genum :: [HTYPE_LONG])++#if defined(HTYPE_MODE_T)+instance GEnum CMode where+ genum = coerce (genum :: [HTYPE_MODE_T])+#endif++#if defined(HTYPE_NLINK_T)+instance GEnum CNlink where+ genum = coerce (genum :: [HTYPE_NLINK_T])+#endif++#if defined(HTYPE_OFF_T)+instance GEnum COff where+ genum = coerce (genum :: [HTYPE_OFF_T])+#endif++#if MIN_VERSION_base(4,4,0)+instance GEnum a => GEnum (Complex a) where+ genum = genumDefault+#endif++instance GEnum a => GEnum (Const a b) where+ genum = genumDefault++#if defined(HTYPE_PID_T)+instance GEnum CPid where+ genum = coerce (genum :: [HTYPE_PID_T])+#endif++instance GEnum CPtrdiff where+ genum = coerce (genum :: [HTYPE_PTRDIFF_T])++#if defined(HTYPE_RLIM_T)+instance GEnum CRLim where+ genum = coerce (genum :: [HTYPE_RLIM_T])+#endif++instance GEnum CSChar where+ genum = coerce (genum :: [HTYPE_SIGNED_CHAR])++#if defined(HTYPE_SPEED_T)+instance GEnum CSpeed where+ genum = coerce (genum :: [HTYPE_SPEED_T])+#endif++#if MIN_VERSION_base(4,4,0)+instance GEnum CSUSeconds where+ genum = coerce (genum :: [HTYPE_SUSECONDS_T])+#endif++instance GEnum CShort where+ genum = coerce (genum :: [HTYPE_SHORT])++instance GEnum CSigAtomic where+ genum = coerce (genum :: [HTYPE_SIG_ATOMIC_T])++instance GEnum CSize where+ genum = coerce (genum :: [HTYPE_SIZE_T])++#if defined(HTYPE_SSIZE_T)+instance GEnum CSsize where+ genum = coerce (genum :: [HTYPE_SSIZE_T])+#endif++#if defined(HTYPE_TCFLAG_T)+instance GEnum CTcflag where+ genum = coerce (genum :: [HTYPE_TCFLAG_T])+#endif++instance GEnum CTime where+ genum = coerce (genum :: [HTYPE_TIME_T])++instance GEnum CUChar where+ genum = coerce (genum :: [HTYPE_UNSIGNED_CHAR])++#if defined(HTYPE_UID_T)+instance GEnum CUid where+ genum = coerce (genum :: [HTYPE_UID_T])+#endif++instance GEnum CUInt where+ genum = coerce (genum :: [HTYPE_UNSIGNED_INT])++instance GEnum CUIntMax where+ genum = coerce (genum :: [HTYPE_UINTMAX_T])++instance GEnum CUIntPtr where+ genum = coerce (genum :: [HTYPE_UINTPTR_T])++instance GEnum CULLong where+ genum = coerce (genum :: [HTYPE_UNSIGNED_LONG_LONG])++instance GEnum CULong where+ genum = coerce (genum :: [HTYPE_UNSIGNED_LONG])++#if MIN_VERSION_base(4,4,0)+instance GEnum CUSeconds where+ genum = coerce (genum :: [HTYPE_USECONDS_T])+#endif++instance GEnum CUShort where+ genum = coerce (genum :: [HTYPE_UNSIGNED_SHORT])++instance GEnum CWchar where+ genum = coerce (genum :: [HTYPE_WCHAR_T])++instance GEnum Double where+ genum = genumNumUnbounded++instance GEnum a => GEnum (Dual a) where+ genum = genumDefault++instance (GEnum a, GEnum b) => GEnum (Either a b) where+ genum = genumDefault++instance GEnum ExitCode where+ genum = genumDefault++instance GEnum Fd where+ genum = coerce (genum :: [CInt])++instance GEnum a => GEnum (Monoid.First a) where+ genum = genumDefault++#if MIN_VERSION_base(4,9,0)+instance GEnum a => GEnum (Semigroup.First a) where+ genum = genumDefault+#endif++instance GEnum Fixity where+ genum = genumDefault++instance GEnum Float where+ genum = genumNumUnbounded++#if MIN_VERSION_base(4,8,0)+instance GEnum a => GEnum (Identity a) where+ genum = genumDefault+#endif++instance GEnum Int where+ genum = genumNumSigned++instance GEnum Int8 where+ genum = genumNumSigned++instance GEnum Int16 where+ genum = genumNumSigned++instance GEnum Int32 where+ genum = genumNumSigned++instance GEnum Int64 where+ genum = genumNumSigned++instance GEnum Integer where+ genum = genumNumUnbounded++instance GEnum IntPtr where+ genum = genumNumSigned++instance GEnum c => GEnum (K1 i c p) where+ genum = genumDefault++instance GEnum a => GEnum (Monoid.Last a) where+ genum = genumDefault++#if MIN_VERSION_base(4,9,0)+instance GEnum a => GEnum (Semigroup.Last a) where+ genum = genumDefault+#endif++instance GEnum (f p) => GEnum (M1 i c f p) where+ genum = genumDefault++#if MIN_VERSION_base(4,9,0)+instance GEnum a => GEnum (Max a) where+ genum = genumDefault+#endif++instance GEnum a => GEnum (Maybe a) where+ genum = genumDefault++#if MIN_VERSION_base(4,9,0)+instance GEnum a => GEnum (Min a) where+ genum = genumDefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GEnum Natural where+ genum = genumNumUnsigned+#endif++#if MIN_VERSION_base(4,9,0)+instance GEnum a => GEnum (NonEmpty a) where+ genum = genumDefault+#endif++instance GEnum Ordering where+ genum = genumDefault++instance GEnum p => GEnum (Par1 p) where+ genum = genumDefault++instance GEnum a => GEnum (Product a) where+ genum = genumDefault++#if MIN_VERSION_base(4,7,0)+instance GEnum+# if MIN_VERSION_base(4,9,0)+ (Proxy s)+# else+ (Proxy (s :: *))+# endif+ where+ genum = genumDefault+#endif++instance GEnum a => GEnum (Sum a) where+ genum = genumDefault++instance GEnum (U1 p) where+ genum = genumDefault++instance GEnum Word where+ genum = genumNumUnsigned++instance GEnum Word8 where+ genum = genumNumUnsigned++instance GEnum Word16 where+ genum = genumNumUnsigned++instance GEnum Word32 where+ genum = genumNumUnsigned++instance GEnum Word64 where+ genum = genumNumUnsigned++instance GEnum WordPtr where+ genum = genumNumUnsigned++#if MIN_VERSION_base(4,9,0)+instance GEnum m => GEnum (WrappedMonoid m) where+ genum = genumDefault+#endif++instance GEnum a => GEnum (ZipList a) where+ genum = genumDefault++#if MIN_VERSION_base(4,10,0)+instance GEnum CBool where+ genum = coerce (genum :: [HTYPE_BOOL])++# if defined(HTYPE_BLKSIZE_T)+instance GEnum CBlkSize where+ genum = coerce (genum :: [HTYPE_BLKSIZE_T])+# endif++# if defined(HTYPE_BLKCNT_T)+instance GEnum CBlkCnt where+ genum = coerce (genum :: [HTYPE_BLKCNT_T])+# endif++# if defined(HTYPE_CLOCKID_T)+instance GEnum CClockId where+ genum = coerce (genum :: [HTYPE_CLOCKID_T])+# endif++# if defined(HTYPE_FSBLKCNT_T)+instance GEnum CFsBlkCnt where+ genum = coerce (genum :: [HTYPE_FSBLKCNT_T])+# endif++# if defined(HTYPE_FSFILCNT_T)+instance GEnum CFsFilCnt where+ genum = coerce (genum :: [HTYPE_FSFILCNT_T])+# endif++# if defined(HTYPE_ID_T)+instance GEnum CId where+ genum = coerce (genum :: [HTYPE_ID_T])+# endif++# if defined(HTYPE_KEY_T)+instance GEnum CKey where+ genum = coerce (genum :: [HTYPE_KEY_T])+# endif+#endif++--------------------------------------------------------------------------------+-- Generic Ix+--------------------------------------------------------------------------------++-- Minimal complete instance: 'range', 'index' and 'inRange'.+class (Ord a) => GIx a where+ -- | The list of values in the subrange defined by a bounding pair.+ range :: (a,a) -> [a]+ -- | The position of a subscript in the subrange.+ index :: (a,a) -> a -> Int+ -- | Returns 'True' the given subscript lies in the range defined+ -- the bounding pair.+ inRange :: (a,a) -> a -> Bool+#if __GLASGOW_HASKELL__ >= 701+ default range :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> [a]+ range = rangeDefault++ default index :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Int+ index = indexDefault++ default inRange :: (GEq a, Generic a, Enum' (Rep a)) => (a,a) -> a -> Bool+ inRange = inRangeDefault+#endif++rangeDefault :: (GEq a, Generic a, Enum' (Rep a))+ => (a,a) -> [a]+rangeDefault = t (map to enum') where+ t l (x,y) =+ case (findIndex (geq x) l, findIndex (geq y) l) of+ (Nothing, _) -> error "rangeDefault: no corresponding index"+ (_, Nothing) -> error "rangeDefault: no corresponding index"+ (Just i, Just j) -> take (j-i) (drop i l)++indexDefault :: (GEq a, Generic a, Enum' (Rep a))+ => (a,a) -> a -> Int+indexDefault = t (map to enum') where+ t l (x,y) z =+ case (findIndex (geq x) l, findIndex (geq y) l) of+ (Nothing, _) -> error "indexDefault: no corresponding index"+ (_, Nothing) -> error "indexDefault: no corresponding index"+ (Just i, Just j) -> case findIndex (geq z) (take (j-i) (drop i l)) of+ Nothing -> error "indexDefault: index out of range"+ Just k -> k++inRangeDefault :: (GEq a, Generic a, Enum' (Rep a))+ => (a,a) -> a -> Bool+inRangeDefault = t (map to enum') where+ t l (x,y) z =+ case (findIndex (geq x) l, findIndex (geq y) l) of+ (Nothing, _) -> error "indexDefault: no corresponding index"+ (_, Nothing) -> error "indexDefault: no corresponding index"+ (Just i, Just j) -> maybe False (const True)+ (findIndex (geq z) (take (j-i) (drop i l)))++rangeEnum :: Enum a => (a, a) -> [a]+rangeEnum (m,n) = [m..n]++indexIntegral :: Integral a => (a, a) -> a -> Int+indexIntegral (m,_n) i = fromIntegral (i - m)++inRangeOrd :: Ord a => (a, a) -> a -> Bool+inRangeOrd (m,n) i = m <= i && i <= n++-- Base types instances+instance GIx () where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (a, b) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c)+ => GIx (a, b, c) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c,+ GEq d, GEnum d, GIx d)+ => GIx (a, b, c, d) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c,+ GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e)+ => GIx (a, b, c, d, e) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c,+ GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f)+ => GIx (a, b, c, d, e, f) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b, GEq c, GEnum c, GIx c,+ GEq d, GEnum d, GIx d, GEq e, GEnum e, GIx e, GEq f, GEnum f, GIx f,+ GEq g, GEnum g, GIx g)+ => GIx (a, b, c, d, e, f, g) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a) => GIx [a] where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance GIx All where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++#if MIN_VERSION_base(4,8,0)+instance (GEq (f a), GEnum (f a), GIx (f a)) => GIx (Alt f a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++instance GIx Any where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++#if MIN_VERSION_base(4,9,0)+instance (GEq a, GEnum a, GIx a, GEnum b) => GIx (Arg a b) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++#if !(MIN_VERSION_base(4,9,0))+instance GIx Arity where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++instance GIx Associativity where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance GIx Bool where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance GIx CChar where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++#if defined(HTYPE_GID_T)+instance GIx CGid where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++#if defined(HTYPE_INO_T)+instance GIx CIno where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++instance GIx CInt where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CIntMax where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CIntPtr where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CLLong where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CLong where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++#if defined(HTYPE_MODE_T)+instance GIx CMode where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++#if defined(HTYPE_NLINK_T)+instance GIx CNlink where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++#if defined(HTYPE_OFF_T)+instance GIx COff where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++#if defined(HTYPE_PID_T)+instance GIx CPid where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++instance GIx CPtrdiff where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++#if defined(HTYPE_RLIM_T)+instance GIx CRLim where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++instance GIx CSChar where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CShort where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CSigAtomic where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CSize where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++#if defined(HTYPE_SSIZE_T)+instance GIx CSsize where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++#if defined(HTYPE_TCFLAG_T)+instance GIx CTcflag where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++instance GIx CUChar where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++#if defined(HTYPE_UID_T)+instance GIx CUid where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++instance GIx CUInt where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CUIntMax where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CUIntPtr where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CULLong where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CULong where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CUShort where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx CWchar where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance (GEq a, GEnum a, GIx a) => GIx (Dual a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a, GEq b, GEnum b, GIx b) => GIx (Either a b) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance GIx ExitCode where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance GIx Fd where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance (GEq a, GEnum a, GIx a) => GIx (Monoid.First a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++#if MIN_VERSION_base(4,9,0)+instance (GEq a, GEnum a, GIx a) => GIx (Semigroup.First a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++instance GIx Fixity where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++#if MIN_VERSION_base(4,8,0)+instance (GEq a, GEnum a, GIx a) => GIx (Identity a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++instance GIx Int where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Int8 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Int16 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Int32 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Int64 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Integer where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx IntPtr where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance (GEq a, GEnum a, GIx a) => GIx (Monoid.Last a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++#if MIN_VERSION_base(4,9,0)+instance (GEq a, GEnum a, GIx a) => GIx (Semigroup.Last a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++#if MIN_VERSION_base(4,9,0)+instance (GEq a, GEnum a, GIx a) => GIx (Max a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++instance (GEq a, GEnum a, GIx a) => GIx (Maybe a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++#if MIN_VERSION_base(4,9,0)+instance (GEq a, GEnum a, GIx a) => GIx (Min a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GIx Natural where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+#endif++#if MIN_VERSION_base(4,9,0)+instance (GEq a, GEnum a, GIx a) => GIx (NonEmpty a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++instance GIx Ordering where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance (GEq a, GEnum a, GIx a) => GIx (Product a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++#if MIN_VERSION_base(4,7,0)+instance GIx+# if MIN_VERSION_base(4,9,0)+ (Proxy s)+# else+ (Proxy (s :: *))+# endif+ where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++instance (GEq a, GEnum a, GIx a) => GIx (Sum a) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault++instance GIx Word where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Word8 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Word16 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Word32 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx Word64 where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++instance GIx WordPtr where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++#if MIN_VERSION_base(4,9,0)+instance (GEq m, GEnum m, GIx m) => GIx (WrappedMonoid m) where+ range = rangeDefault+ index = indexDefault+ inRange = inRangeDefault+#endif++#if MIN_VERSION_base(4,10,0)+instance GIx CBool where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd++# if defined(HTYPE_BLKSIZE_T)+instance GIx CBlkSize where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+# endif++# if defined(HTYPE_BLKCNT_T)+instance GIx CBlkCnt where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+# endif++# if defined(HTYPE_CLOCKID_T)+instance GIx CClockId where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+# endif++# if defined(HTYPE_FSBLKCNT_T)+instance GIx CFsBlkCnt where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+# endif++# if defined(HTYPE_FSFILCNT_T)+instance GIx CFsFilCnt where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+# endif++# if defined(HTYPE_ID_T)+instance GIx CId where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+# endif++# if defined(HTYPE_KEY_T)+instance GIx CKey where+ range = rangeEnum+ index = indexIntegral+ inRange = inRangeOrd+# endif+#endif
+ tests/Generics/Deriving/Eq.hs view
@@ -0,0 +1,626 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MagicHash #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE Trustworthy #-}+#endif++#if __GLASGOW_HASKELL__ >= 705+{-# LANGUAGE PolyKinds #-}+#endif++#include "HsBaseConfig.h"++module Generics.Deriving.Eq (+ -- * Generic Eq class+ GEq(..)++ -- * Default definition+ , geqdefault++ -- * Internal Eq class+ , GEq'(..)++ ) where++import Control.Applicative (Const, ZipList)++import Data.Char (GeneralCategory)+import Data.Int+import qualified Data.Monoid as Monoid (First, Last)+import Data.Monoid (All, Any, Dual, Product, Sum)+import Data.Version (Version)+import Data.Word++import Foreign.C.Error+import Foreign.C.Types+import Foreign.ForeignPtr (ForeignPtr)+import Foreign.Ptr+import Foreign.StablePtr (StablePtr)++import Generics.Linear++import GHC.Exts hiding (Any)++import System.Exit (ExitCode)+import System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode)+import System.IO.Error (IOErrorType)+import System.Posix.Types++#if MIN_VERSION_base(4,4,0)+import Data.Complex (Complex)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+import Data.Monoid (Alt)+import Data.Void (Void)+import Numeric.Natural (Natural)+#endif++#if MIN_VERSION_base(4,9,0)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg(..), Max, Min, WrappedMonoid)+#endif++--------------------------------------------------------------------------------+-- Generic show+--------------------------------------------------------------------------------++class GEq' f where+ geq' :: f a -> f a -> Bool++instance GEq' V1 where+ geq' _ _ = True++instance GEq' U1 where+ geq' _ _ = True++instance (GEq c) => GEq' (K1 i c) where+ geq' (K1 a) (K1 b) = geq a b++-- No instances for P or Rec because geq is only applicable to types of kind *++instance GEq' a => GEq' (M1 i c a) where+ geq' (M1 a) (M1 b) = geq' a b++instance GEq' a => GEq' (MP1 m a) where+ geq' (MP1 a) (MP1 b) = geq' a b++instance (GEq' a, GEq' b) => GEq' (a :+: b) where+ geq' (L1 a) (L1 b) = geq' a b+ geq' (R1 a) (R1 b) = geq' a b+ geq' _ _ = False++instance (GEq' a, GEq' b) => GEq' (a :*: b) where+ geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2++-- Unboxed types+instance GEq' UAddr where+ geq' (UAddr a1) (UAddr a2) = isTrue# (eqAddr# a1 a2)+instance GEq' UChar where+ geq' (UChar c1) (UChar c2) = isTrue# (eqChar# c1 c2)+instance GEq' UDouble where+ geq' (UDouble d1) (UDouble d2) = isTrue# (d1 ==## d2)+instance GEq' UFloat where+ geq' (UFloat f1) (UFloat f2) = isTrue# (eqFloat# f1 f2)+instance GEq' UInt where+ geq' (UInt i1) (UInt i2) = isTrue# (i1 ==# i2)+instance GEq' UWord where+ geq' (UWord w1) (UWord w2) = isTrue# (eqWord# w1 w2)++#if !(MIN_VERSION_base(4,7,0))+isTrue# :: Bool -> Bool+isTrue# = id+#endif+++class GEq a where+ geq :: a -> a -> Bool+++#if __GLASGOW_HASKELL__ >= 701+ default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool+ geq = geqdefault+#endif++geqdefault :: (Generic a, GEq' (Rep a)) => a -> a -> Bool+geqdefault x y = geq' (from x) (from y)++-- Base types instances+instance GEq () where+ geq = geqdefault++instance (GEq a, GEq b) => GEq (a, b) where+ geq = geqdefault++instance (GEq a, GEq b, GEq c) => GEq (a, b, c) where+ geq = geqdefault++instance (GEq a, GEq b, GEq c, GEq d) => GEq (a, b, c, d) where+ geq = geqdefault++instance (GEq a, GEq b, GEq c, GEq d, GEq e) => GEq (a, b, c, d, e) where+ geq = geqdefault++instance (GEq a, GEq b, GEq c, GEq d, GEq e, GEq f)+ => GEq (a, b, c, d, e, f) where+ geq = geqdefault++instance (GEq a, GEq b, GEq c, GEq d, GEq e, GEq f, GEq g)+ => GEq (a, b, c, d, e, f, g) where+ geq = geqdefault++instance GEq a => GEq [a] where+ geq = geqdefault++instance (GEq (f p), GEq (g p)) => GEq ((f :+: g) p) where+ geq = geqdefault++instance (GEq (f p), GEq (g p)) => GEq ((f :*: g) p) where+ geq = geqdefault++instance GEq (f (g p)) => GEq ((f :.: g) p) where+ geq = geqdefault++instance GEq All where+ geq = geqdefault++#if MIN_VERSION_base(4,8,0)+instance GEq (f a) => GEq (Alt f a) where+ geq = geqdefault+#endif++instance GEq Any where+ geq = geqdefault++#if !(MIN_VERSION_base(4,9,0))+instance GEq Arity where+ geq = geqdefault+#endif++#if MIN_VERSION_base(4,9,0)+instance GEq a => GEq (Arg a b) where+ geq (Arg a _) (Arg b _) = geq a b+#endif++instance GEq Associativity where+ geq = geqdefault++instance GEq Bool where+ geq = geqdefault++instance GEq BufferMode where+ geq = (==)++#if defined(HTYPE_CC_T)+instance GEq CCc where+ geq = (==)+#endif++instance GEq CChar where+ geq = (==)++instance GEq CClock where+ geq = (==)++#if defined(HTYPE_DEV_T)+instance GEq CDev where+ geq = (==)+#endif++instance GEq CDouble where+ geq = (==)++instance GEq CFloat where+ geq = (==)++#if defined(HTYPE_GID_T)+instance GEq CGid where+ geq = (==)+#endif++instance GEq Char where+ geq = (==)++#if defined(HTYPE_INO_T)+instance GEq CIno where+ geq = (==)+#endif++instance GEq CInt where+ geq = (==)++instance GEq CIntMax where+ geq = (==)++instance GEq CIntPtr where+ geq = (==)++instance GEq CLLong where+ geq = (==)++instance GEq CLong where+ geq = (==)++#if defined(HTYPE_MODE_T)+instance GEq CMode where+ geq = (==)+#endif++#if defined(HTYPE_NLINK_T)+instance GEq CNlink where+ geq = (==)+#endif++#if defined(HTYPE_OFF_T)+instance GEq COff where+ geq = (==)+#endif++#if MIN_VERSION_base(4,4,0)+instance GEq a => GEq (Complex a) where+ geq = geqdefault+#endif++instance GEq a => GEq (Const a b) where+ geq = geqdefault++#if defined(HTYPE_PID_T)+instance GEq CPid where+ geq = (==)+#endif++instance GEq CPtrdiff where+ geq = (==)++#if defined(HTYPE_RLIM_T)+instance GEq CRLim where+ geq = (==)+#endif++instance GEq CSChar where+ geq = (==)++#if defined(HTYPE_SPEED_T)+instance GEq CSpeed where+ geq = (==)+#endif++#if MIN_VERSION_base(4,4,0)+instance GEq CSUSeconds where+ geq = (==)+#endif++instance GEq CShort where+ geq = (==)++instance GEq CSigAtomic where+ geq = (==)++instance GEq CSize where+ geq = (==)++#if defined(HTYPE_SSIZE_T)+instance GEq CSsize where+ geq = (==)+#endif++#if defined(HTYPE_TCFLAG_T)+instance GEq CTcflag where+ geq = (==)+#endif++instance GEq CTime where+ geq = (==)++instance GEq CUChar where+ geq = (==)++#if defined(HTYPE_UID_T)+instance GEq CUid where+ geq = (==)+#endif++instance GEq CUInt where+ geq = (==)++instance GEq CUIntMax where+ geq = (==)++instance GEq CUIntPtr where+ geq = (==)++instance GEq CULLong where+ geq = (==)++instance GEq CULong where+ geq = (==)++#if MIN_VERSION_base(4,4,0)+instance GEq CUSeconds where+ geq = (==)+#endif++instance GEq CUShort where+ geq = (==)++instance GEq CWchar where+ geq = (==)++#if MIN_VERSION_base(4,9,0)+instance GEq DecidedStrictness where+ geq = geqdefault+#endif++instance GEq Double where+ geq = (==)++instance GEq a => GEq (Down a) where+ geq = geqdefault++instance GEq a => GEq (Dual a) where+ geq = geqdefault++instance (GEq a, GEq b) => GEq (Either a b) where+ geq = geqdefault++instance GEq Errno where+ geq = (==)++instance GEq ExitCode where+ geq = geqdefault++instance GEq Fd where+ geq = (==)++instance GEq a => GEq (Monoid.First a) where+ geq = geqdefault++#if MIN_VERSION_base(4,9,0)+instance GEq a => GEq (Semigroup.First a) where+ geq = geqdefault+#endif++instance GEq Fixity where+ geq = geqdefault++instance GEq Float where+ geq = (==)++instance GEq (ForeignPtr a) where+ geq = (==)++instance GEq (FunPtr a) where+ geq = (==)++instance GEq GeneralCategory where+ geq = (==)++instance GEq Handle where+ geq = (==)++instance GEq HandlePosn where+ geq = (==)++#if MIN_VERSION_base(4,8,0)+instance GEq a => GEq (Identity a) where+ geq = geqdefault+#endif++instance GEq Int where+ geq = (==)++instance GEq Int8 where+ geq = (==)++instance GEq Int16 where+ geq = (==)++instance GEq Int32 where+ geq = (==)++instance GEq Int64 where+ geq = (==)++instance GEq Integer where+ geq = (==)++instance GEq IntPtr where+ geq = (==)++instance GEq IOError where+ geq = (==)++instance GEq IOErrorType where+ geq = (==)++instance GEq IOMode where+ geq = (==)++instance GEq c => GEq (K1 i c p) where+ geq = geqdefault++instance GEq a => GEq (Monoid.Last a) where+ geq = geqdefault++#if MIN_VERSION_base(4,9,0)+instance GEq a => GEq (Semigroup.Last a) where+ geq = geqdefault+#endif++instance GEq (f p) => GEq (M1 i c f p) where+ geq = geqdefault++instance GEq a => GEq (Maybe a) where+ geq = geqdefault++#if MIN_VERSION_base(4,9,0)+instance GEq a => GEq (Max a) where+ geq = geqdefault++instance GEq a => GEq (Min a) where+ geq = geqdefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GEq Natural where+ geq = (==)+#endif++#if MIN_VERSION_base(4,9,0)+instance GEq a => GEq (NonEmpty a) where+ geq = geqdefault+#endif++instance GEq Ordering where+ geq = geqdefault++instance GEq p => GEq (Par1 p) where+ geq = geqdefault++instance GEq a => GEq (Product a) where+ geq = geqdefault++#if MIN_VERSION_base(4,7,0)+instance GEq+# if MIN_VERSION_base(4,9,0)+ (Proxy s)+# else+ (Proxy (s :: *))+# endif+ where+ geq = geqdefault+#endif++instance GEq (Ptr a) where+ geq = (==)++instance GEq SeekMode where+ geq = (==)++instance GEq (StablePtr a) where+ geq = (==)++#if MIN_VERSION_base(4,9,0)+instance GEq SourceStrictness where+ geq = geqdefault++instance GEq SourceUnpackedness where+ geq = geqdefault+#endif++instance GEq a => GEq (Sum a) where+ geq = geqdefault++instance GEq (U1 p) where+ geq = geqdefault++instance GEq (UAddr p) where+ geq = geqdefault++instance GEq (UChar p) where+ geq = geqdefault++instance GEq (UDouble p) where+ geq = geqdefault++instance GEq (UFloat p) where+ geq = geqdefault++instance GEq (UInt p) where+ geq = geqdefault++instance GEq (UWord p) where+ geq = geqdefault++instance GEq Version where+ geq = (==)++#if MIN_VERSION_base(4,8,0)+instance GEq Void where+ geq = (==)+#endif++instance GEq Word where+ geq = (==)++instance GEq Word8 where+ geq = (==)++instance GEq Word16 where+ geq = (==)++instance GEq Word32 where+ geq = (==)++instance GEq Word64 where+ geq = (==)++instance GEq WordPtr where+ geq = (==)++#if MIN_VERSION_base(4,9,0)+instance GEq m => GEq (WrappedMonoid m) where+ geq = geqdefault+#endif++instance GEq a => GEq (ZipList a) where+ geq = geqdefault++#if MIN_VERSION_base(4,10,0)+instance GEq CBool where+ geq = (==)++# if defined(HTYPE_BLKSIZE_T)+instance GEq CBlkSize where+ geq = (==)+# endif++# if defined(HTYPE_BLKCNT_T)+instance GEq CBlkCnt where+ geq = (==)+# endif++# if defined(HTYPE_CLOCKID_T)+instance GEq CClockId where+ geq = (==)+# endif++# if defined(HTYPE_FSBLKCNT_T)+instance GEq CFsBlkCnt where+ geq = (==)+# endif++# if defined(HTYPE_FSFILCNT_T)+instance GEq CFsFilCnt where+ geq = (==)+# endif++# if defined(HTYPE_ID_T)+instance GEq CId where+ geq = (==)+# endif++# if defined(HTYPE_KEY_T)+instance GEq CKey where+ geq = (==)+# endif++# if defined(HTYPE_TIMER_T)+instance GEq CTimer where+ geq = (==)+# endif+#endif
+ tests/Generics/Deriving/Foldable.hs view
@@ -0,0 +1,327 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+#endif++#if __GLASGOW_HASKELL__ >= 705+{-# LANGUAGE PolyKinds #-}+#endif++#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++module Generics.Deriving.Foldable (+ -- * Generic Foldable class+ GFoldable(..)++ -- * Default method+ , gfoldMapdefault++ -- * Derived functions+ , gtoList+ , gconcat+ , gconcatMap+ , gand+ , gor+ , gany+ , gall+ , gsum+ , gproduct+ , gmaximum+ , gmaximumBy+ , gminimum+ , gminimumBy+ , gelem+ , gnotElem+ , gfind++ -- * Internal Foldable class+ , GFoldable'(..)+ ) where++import Control.Applicative (Const, ZipList)++import Data.Maybe+import qualified Data.Monoid as Monoid (First, Last, Product(..), Sum(..))+import Data.Monoid (All(..), Any(..), Dual(..), Endo(..))+#if !(MIN_VERSION_base(4,8,0))+import Data.Monoid (Monoid(..))+#endif++import Generics.Linear++#if MIN_VERSION_base(4,4,0)+import Data.Complex (Complex)+#endif++#if MIN_VERSION_base(4,6,0)+import Data.Ord (Down)+#else+import GHC.Exts (Down)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+#endif++#if MIN_VERSION_base(4,9,0)+import qualified Data.Functor.Product as Functor (Product)+import qualified Data.Functor.Sum as Functor (Sum)+import Data.Functor.Compose (Compose)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg, Max, Min, WrappedMonoid)+#endif++--------------------------------------------------------------------------------+-- Generic fold+--------------------------------------------------------------------------------++class GFoldable' t where+ gfoldMap' :: Monoid m => (a -> m) -> t a -> m++instance GFoldable' V1 where+ gfoldMap' _ _ = mempty++instance GFoldable' U1 where+ gfoldMap' _ U1 = mempty++instance GFoldable' Par1 where+ gfoldMap' f (Par1 a) = f a++instance GFoldable' (K1 i c) where+ gfoldMap' _ (K1 _) = mempty++instance GFoldable' f => GFoldable' (M1 i c f) where+ gfoldMap' f (M1 a) = gfoldMap' f a++instance GFoldable' f => GFoldable' (MP1 m f) where+ gfoldMap' f (MP1 a) = gfoldMap' f a++instance (GFoldable' f, GFoldable' g) => GFoldable' (f :+: g) where+ gfoldMap' f (L1 a) = gfoldMap' f a+ gfoldMap' f (R1 a) = gfoldMap' f a++instance (GFoldable' f, GFoldable' g) => GFoldable' (f :*: g) where+ gfoldMap' f (a :*: b) = mappend (gfoldMap' f a) (gfoldMap' f b)++instance (GFoldable' f, GFoldable g) => GFoldable' (f :.: g) where+ gfoldMap' f (Comp1 x) = gfoldMap' (gfoldMap f) x++instance GFoldable' UAddr where+ gfoldMap' _ (UAddr _) = mempty++instance GFoldable' UChar where+ gfoldMap' _ (UChar _) = mempty++instance GFoldable' UDouble where+ gfoldMap' _ (UDouble _) = mempty++instance GFoldable' UFloat where+ gfoldMap' _ (UFloat _) = mempty++instance GFoldable' UInt where+ gfoldMap' _ (UInt _) = mempty++instance GFoldable' UWord where+ gfoldMap' _ (UWord _) = mempty++class GFoldable t where+ gfoldMap :: Monoid m => (a -> m) -> t a -> m+#if __GLASGOW_HASKELL__ >= 701+ default gfoldMap :: (Generic1 t, GFoldable' (Rep1 t), Monoid m)+ => (a -> m) -> t a -> m+ gfoldMap = gfoldMapdefault+#endif++ gfold :: Monoid m => t m -> m+ gfold = gfoldMap id++ gfoldr :: (a -> b -> b) -> b -> t a -> b+ gfoldr f z t = appEndo (gfoldMap (Endo . f) t) z++ gfoldr' :: (a -> b -> b) -> b -> t a -> b+ gfoldr' f z0 xs = gfoldl f' id xs z0+ where f' k x z = k $! f x z++ gfoldl :: (a -> b -> a) -> a -> t b -> a+ gfoldl f z t = appEndo (getDual (gfoldMap (Dual . Endo . flip f) t)) z++ gfoldl' :: (a -> b -> a) -> a -> t b -> a+ gfoldl' f z0 xs = gfoldr f' id xs z0+ where f' x k z = k $! f z x++ gfoldr1 :: (a -> a -> a) -> t a -> a+ gfoldr1 f xs = fromMaybe (error "gfoldr1: empty structure")+ (gfoldr mf Nothing xs)+ where+ mf x Nothing = Just x+ mf x (Just y) = Just (f x y)++ gfoldl1 :: (a -> a -> a) -> t a -> a+ gfoldl1 f xs = fromMaybe (error "foldl1: empty structure")+ (gfoldl mf Nothing xs)+ where+ mf Nothing y = Just y+ mf (Just x) y = Just (f x y)++gfoldMapdefault :: (Generic1 t, GFoldable' (Rep1 t), Monoid m)+ => (a -> m) -> t a -> m+gfoldMapdefault f x = gfoldMap' f (from1 x)++-- Base types instances+instance GFoldable ((,) a)+instance GFoldable ((,,) a b)+instance GFoldable ((,,,) a b c)++instance GFoldable [] where+ gfoldMap = gfoldMapdefault++#if MIN_VERSION_base(4,9,0)+instance GFoldable (Arg a) where+ gfoldMap = gfoldMapdefault+#endif++#if MIN_VERSION_base(4,4,0)+instance GFoldable Complex where+ gfoldMap = gfoldMapdefault+#endif++instance GFoldable (Const m) where+ gfoldMap = gfoldMapdefault++instance GFoldable Down where+ gfoldMap = gfoldMapdefault++instance GFoldable Dual where+ gfoldMap = gfoldMapdefault++instance GFoldable (Either a) where+ gfoldMap = gfoldMapdefault++instance GFoldable Monoid.First where+ gfoldMap = gfoldMapdefault++#if MIN_VERSION_base(4,9,0)+instance GFoldable (Semigroup.First) where+ gfoldMap = gfoldMapdefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GFoldable Identity where+ gfoldMap = gfoldMapdefault+#endif++instance GFoldable Monoid.Last where+ gfoldMap = gfoldMapdefault++#if MIN_VERSION_base(4,9,0)+instance GFoldable Semigroup.Last where+ gfoldMap = gfoldMapdefault++instance GFoldable Max where+ gfoldMap = gfoldMapdefault+#endif++instance GFoldable Maybe where+ gfoldMap = gfoldMapdefault++#if MIN_VERSION_base(4,9,0)+instance GFoldable Min where+ gfoldMap = gfoldMapdefault++instance GFoldable NonEmpty where+ gfoldMap = gfoldMapdefault+#endif++instance GFoldable Monoid.Product where+ gfoldMap = gfoldMapdefault++instance (GFoldable f, GFoldable g) => GFoldable (Functor.Product f g)++instance (GFoldable f, GFoldable g) => GFoldable (Compose f g)++#if MIN_VERSION_base(4,7,0)+instance GFoldable Proxy where+ gfoldMap = gfoldMapdefault+#endif++instance GFoldable Monoid.Sum where+ gfoldMap = gfoldMapdefault++#if MIN_VERSION_base(4,9,0)+instance (GFoldable f, GFoldable g) => GFoldable (Functor.Sum f g) where+ gfoldMap = gfoldMapdefault++instance GFoldable WrappedMonoid where+ gfoldMap = gfoldMapdefault+#endif++instance GFoldable ZipList where+ gfoldMap = gfoldMapdefault++gtoList :: GFoldable t => t a -> [a]+gtoList = gfoldr (:) []++gconcat :: GFoldable t => t [a] -> [a]+gconcat = gfold++gconcatMap :: GFoldable t => (a -> [b]) -> t a -> [b]+gconcatMap = gfoldMap++gand :: GFoldable t => t Bool -> Bool+gand = getAll . gfoldMap All++gor :: GFoldable t => t Bool -> Bool+gor = getAny . gfoldMap Any++gany :: GFoldable t => (a -> Bool) -> t a -> Bool+gany p = getAny . gfoldMap (Any . p)++gall :: GFoldable t => (a -> Bool) -> t a -> Bool+gall p = getAll . gfoldMap (All . p)++gsum :: (GFoldable t, Num a) => t a -> a+gsum = Monoid.getSum . gfoldMap Monoid.Sum++gproduct :: (GFoldable t, Num a) => t a -> a+gproduct = Monoid.getProduct . gfoldMap Monoid.Product++gmaximum :: (GFoldable t, Ord a) => t a -> a+gmaximum = gfoldr1 max++gmaximumBy :: GFoldable t => (a -> a -> Ordering) -> t a -> a+gmaximumBy cmp = gfoldr1 max'+ where max' x y = case cmp x y of+ GT -> x+ _ -> y++gminimum :: (GFoldable t, Ord a) => t a -> a+gminimum = gfoldr1 min++gminimumBy :: GFoldable t => (a -> a -> Ordering) -> t a -> a+gminimumBy cmp = gfoldr1 min'+ where min' x y = case cmp x y of+ GT -> y+ _ -> x++gelem :: (GFoldable t, Eq a) => a -> t a -> Bool+gelem = gany . (==)++gnotElem :: (GFoldable t, Eq a) => a -> t a -> Bool+gnotElem x = not . gelem x++gfind :: GFoldable t => (a -> Bool) -> t a -> Maybe a+gfind p = listToMaybe . gconcatMap (\ x -> if p x then [x] else [])
+ tests/Generics/Deriving/Functor.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+#endif++#if __GLASGOW_HASKELL__ >= 705+{-# LANGUAGE PolyKinds #-}+#endif++#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE EmptyCase #-}+#endif++#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++module Generics.Deriving.Functor (+ -- * Generic Functor class+ GFunctor(..)++ -- * Default method+ , gmapdefault++ -- * Internal Functor class+ , GFunctor'(..)++ ) where++import Control.Applicative (Const, ZipList)++import qualified Data.Monoid as Monoid (First, Last, Product, Sum)+import Data.Monoid (Dual)++import Generics.Linear++#if MIN_VERSION_base(4,4,0)+import Data.Complex (Complex)+#endif++#if MIN_VERSION_base(4,6,0)+import Data.Ord (Down)+#else+import GHC.Exts (Down)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+import Data.Monoid (Alt)+#endif++#if MIN_VERSION_base(4,9,0)+import qualified Data.Functor.Product as Functor (Product)+import qualified Data.Functor.Sum as Functor (Sum)+import Data.Functor.Compose (Compose)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg, Max, Min, WrappedMonoid)+#endif++--------------------------------------------------------------------------------+-- Generic fmap+--------------------------------------------------------------------------------++class GFunctor' f where+ gmap' :: (a -> b) -> f a -> f b++instance GFunctor' V1 where+ gmap' _ x = case x of+#if __GLASGOW_HASKELL__ >= 708+ {}+#else+ !_ -> error "Void gmap"+#endif++instance GFunctor' U1 where+ gmap' _ U1 = U1++instance GFunctor' Par1 where+ gmap' f (Par1 a) = Par1 (f a)++instance GFunctor' (K1 i c) where+ gmap' _ (K1 a) = K1 a++instance GFunctor' f => GFunctor' (M1 i c f) where+ gmap' f (M1 a) = M1 (gmap' f a)++instance GFunctor' f => GFunctor' (MP1 m f) where+ gmap' f (MP1 a) = MP1 (gmap' f a)++instance (GFunctor' f, GFunctor' g) => GFunctor' (f :+: g) where+ gmap' f (L1 a) = L1 (gmap' f a)+ gmap' f (R1 a) = R1 (gmap' f a)++instance (GFunctor' f, GFunctor' g) => GFunctor' (f :*: g) where+ gmap' f (a :*: b) = gmap' f a :*: gmap' f b++instance (GFunctor' f, GFunctor g) => GFunctor' (f :.: g) where+ gmap' f (Comp1 x) = Comp1 (gmap' (gmap f) x)++instance GFunctor' UAddr where+ gmap' _ (UAddr a) = UAddr a++instance GFunctor' UChar where+ gmap' _ (UChar c) = UChar c++instance GFunctor' UDouble where+ gmap' _ (UDouble d) = UDouble d++instance GFunctor' UFloat where+ gmap' _ (UFloat f) = UFloat f++instance GFunctor' UInt where+ gmap' _ (UInt i) = UInt i++instance GFunctor' UWord where+ gmap' _ (UWord w) = UWord w++class GFunctor f where+ gmap :: (a -> b) -> f a -> f b+#if __GLASGOW_HASKELL__ >= 701+ default gmap :: (Generic1 f, GFunctor' (Rep1 f))+ => (a -> b) -> f a -> f b+ gmap = gmapdefault+#endif++gmapdefault :: (Generic1 f, GFunctor' (Rep1 f))+ => (a -> b) -> f a -> f b+gmapdefault f = \xs -> to1 (gmap' f (from1 xs))++-- Base types instances+instance GFunctor ((->) r) where+ gmap = fmap++instance GFunctor ((,) a)+instance GFunctor ((,,) a b)+instance GFunctor ((,,,) a b c)++instance GFunctor [] where+ gmap = gmapdefault++#if MIN_VERSION_base(4,8,0)+instance GFunctor f => GFunctor (Alt f) where+ gmap = gmapdefault+#endif++#if MIN_VERSION_base(4,9,0)+instance GFunctor (Arg a) where+ gmap = gmapdefault+#endif++#if MIN_VERSION_base(4,4,0)+instance GFunctor Complex where+ gmap = gmapdefault+#endif++instance GFunctor (Const m) where+ gmap = gmapdefault++instance GFunctor Down where+ gmap = gmapdefault++instance GFunctor Dual where+ gmap = gmapdefault++instance GFunctor (Either a) where+ gmap = gmapdefault++instance GFunctor Monoid.First where+ gmap = gmapdefault++#if MIN_VERSION_base(4,9,0)+instance GFunctor (Semigroup.First) where+ gmap = gmapdefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GFunctor Identity where+ gmap = gmapdefault+#endif++instance GFunctor IO where+ gmap = fmap++instance GFunctor Monoid.Last where+ gmap = gmapdefault++#if MIN_VERSION_base(4,9,0)+instance GFunctor Semigroup.Last where+ gmap = gmapdefault++instance GFunctor Max where+ gmap = gmapdefault+#endif++instance GFunctor Maybe where+ gmap = gmapdefault++#if MIN_VERSION_base(4,9,0)+instance GFunctor Min where+ gmap = gmapdefault++instance GFunctor NonEmpty where+ gmap = gmapdefault+#endif++instance GFunctor Monoid.Product where+ gmap = gmapdefault++instance (GFunctor f, GFunctor g) => GFunctor (Functor.Product f g)+instance (GFunctor f, GFunctor g) => GFunctor (Compose f g)++#if MIN_VERSION_base(4,7,0)+instance GFunctor Proxy where+ gmap = gmapdefault+#endif++instance GFunctor Monoid.Sum where+ gmap = gmapdefault++#if MIN_VERSION_base(4,9,0)+instance (GFunctor f, GFunctor g) => GFunctor (Functor.Sum f g) where+ gmap = gmapdefault++instance GFunctor WrappedMonoid where+ gmap = gmapdefault+#endif++instance GFunctor ZipList where+ gmap = gmapdefault
+ tests/Generics/Deriving/Monoid.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif++module Generics.Deriving.Monoid (module Generics.Deriving.Monoid.Internal) where++import Generics.Deriving.Monoid.Internal+import Generics.Deriving.Semigroup (GSemigroup(..))++#if MIN_VERSION_base(4,9,0)+import Data.Semigroup (WrappedMonoid)+#endif++instance GSemigroup a => GMonoid (Maybe a) where+ gmempty = Nothing+ gmappend = gsappend++#if MIN_VERSION_base(4,9,0)+instance GMonoid m => GMonoid (WrappedMonoid m) where+ gmempty = gmemptydefault+ gmappend = gmappenddefault+#endif
+ tests/Generics/Deriving/Monoid/Internal.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+#endif++#if __GLASGOW_HASKELL__ >= 705+{-# LANGUAGE PolyKinds #-}+#endif++#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++module Generics.Deriving.Monoid.Internal (++ -- * Introduction+ {- | This module provides two main features:++ 1. 'GMonoid', a generic version of the 'Monoid' type class, including instances+ of the types from "Data.Monoid"++ 2. Default generic definitions for the 'Monoid' methods 'mempty' and 'mappend'++ The generic defaults only work for types without alternatives (i.e. they have+ only one constructor). We cannot in general know how to deal with different+ constructors.+ -}++ -- * GMonoid type class+ GMonoid(..),++ -- * Default definitions+ -- ** GMonoid+ gmemptydefault,+ gmappenddefault,++ -- * Internal auxiliary class for GMonoid+ GMonoid'(..),++ -- ** Monoid+ {- | These functions can be used in a 'Monoid' instance. For example:++ @+ -- LANGUAGE DeriveGeneric++ import Generics.Linear (Generic)+ import Generics.Deriving.Monoid++ data T a = C a (Maybe a) deriving Generic++ instance Monoid a => Monoid (T a) where+ mempty = memptydefault+ mappend = mappenddefault+ @+ -}+ memptydefault,+ mappenddefault,++ -- * Internal auxiliary class for Monoid+ Monoid'(..),++ -- * The Monoid module+ -- | This is exported for convenient access to the various wrapper types.+ module Data.Monoid,++ ) where++--------------------------------------------------------------------------------++import Control.Applicative+import Data.Monoid+import Generics.Linear+import Generics.Deriving.Semigroup.Internal++#if MIN_VERSION_base(4,6,0)+import Data.Ord (Down)+#else+import GHC.Exts (Down)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+#endif++--------------------------------------------------------------------------------++class GSemigroup' f => GMonoid' f where+ gmempty' :: f x+ gmappend' :: f x -> f x -> f x++instance GMonoid' U1 where+ gmempty' = U1+ gmappend' U1 U1 = U1++instance GMonoid a => GMonoid' (K1 i a) where+ gmempty' = K1 gmempty+ gmappend' (K1 x) (K1 y) = K1 (x `gmappend` y)++instance GMonoid' f => GMonoid' (M1 i c f) where+ gmempty' = M1 gmempty'+ gmappend' (M1 x) (M1 y) = M1 (x `gmappend'` y)++instance GMonoid' f => GMonoid' (MP1 m f) where+ gmempty' = MP1 gmempty'+ gmappend' (MP1 x) (MP1 y) = MP1 (x `gmappend'` y)++instance (GMonoid' f, GMonoid' h) => GMonoid' (f :*: h) where+ gmempty' = gmempty' :*: gmempty'+ gmappend' (x1 :*: y1) (x2 :*: y2) = gmappend' x1 x2 :*: gmappend' y1 y2++--------------------------------------------------------------------------------++gmemptydefault :: (Generic a, GMonoid' (Rep a)) => a+gmemptydefault = to gmempty'++gmappenddefault :: (Generic a, GMonoid' (Rep a)) => a -> a -> a+gmappenddefault x y = to (gmappend' (from x) (from y))++--------------------------------------------------------------------------------++class Monoid' f where+ mempty' :: f x+ mappend' :: f x -> f x -> f x++instance Monoid' U1 where+ mempty' = U1+ mappend' U1 U1 = U1++instance Monoid a => Monoid' (K1 i a) where+ mempty' = K1 mempty+ mappend' (K1 x) (K1 y) = K1 (x `mappend` y)++instance Monoid' f => Monoid' (M1 i c f) where+ mempty' = M1 mempty'+ mappend' (M1 x) (M1 y) = M1 (x `mappend'` y)++instance (Monoid' f, Monoid' h) => Monoid' (f :*: h) where+ mempty' = mempty' :*: mempty'+ mappend' (x1 :*: y1) (x2 :*: y2) = mappend' x1 x2 :*: mappend' y1 y2++--------------------------------------------------------------------------------++memptydefault :: (Generic a, Monoid' (Rep a)) => a+memptydefault = to mempty'++mappenddefault :: (Generic a, Monoid' (Rep a)) => a -> a -> a+mappenddefault x y = to (mappend' (from x) (from y))++--------------------------------------------------------------------------------++class GSemigroup a => GMonoid a where++ -- | Generic 'mempty'+ gmempty :: a++ -- | Generic 'mappend'+ gmappend :: a -> a -> a++ -- | Generic 'mconcat'+ gmconcat :: [a] -> a+ gmconcat = foldr gmappend gmempty++#if __GLASGOW_HASKELL__ >= 701+ default gmempty :: (Generic a, GMonoid' (Rep a)) => a+ gmempty = to gmempty'++ default gmappend :: (Generic a, GMonoid' (Rep a)) => a -> a -> a+ gmappend x y = to (gmappend' (from x) (from y))+#endif++--------------------------------------------------------------------------------++-- Instances that reuse Monoid+instance GMonoid Ordering where+ gmempty = mempty+ gmappend = mappend+instance GMonoid () where+ gmempty = mempty+ gmappend = mappend+instance GMonoid Any where+ gmempty = mempty+ gmappend = mappend+instance GMonoid All where+ gmempty = mempty+ gmappend = mappend+instance GMonoid (First a) where+ gmempty = mempty+ gmappend = mappend+instance GMonoid (Last a) where+ gmempty = mempty+ gmappend = mappend+instance Num a => GMonoid (Sum a) where+ gmempty = mempty+ gmappend = mappend+instance Num a => GMonoid (Product a) where+ gmempty = mempty+ gmappend = mappend+instance GMonoid [a] where+ gmempty = mempty+ gmappend = mappend+instance GMonoid (Endo a) where+ gmempty = mempty+ gmappend = mappend+#if MIN_VERSION_base(4,8,0)+instance Alternative f => GMonoid (Alt f a) where+ gmempty = mempty+ gmappend = mappend+#endif++-- Handwritten instances+instance GMonoid a => GMonoid (Dual a) where+ gmempty = Dual gmempty+ gmappend (Dual x) (Dual y) = Dual (gmappend y x)+instance GMonoid b => GMonoid (a -> b) where+ gmempty _ = gmempty+ gmappend f g x = gmappend (f x) (g x)+instance GMonoid a => GMonoid (Const a b) where+ gmempty = gmemptydefault+ gmappend = gmappenddefault+instance GMonoid a => GMonoid (Down a) where+ gmempty = gmemptydefault+ gmappend = gmappenddefault++#if MIN_VERSION_base(4,7,0)+instance GMonoid+# if MIN_VERSION_base(4,9,0)+ (Proxy s)+# else+ (Proxy (s :: *))+# endif+ where+ gmempty = memptydefault+ gmappend = mappenddefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GMonoid a => GMonoid (Identity a) where+ gmempty = gmemptydefault+ gmappend = gmappenddefault+#endif++-- Tuple instances+instance (GMonoid a,GMonoid b) => GMonoid (a,b) where+ gmempty = (gmempty,gmempty)+ gmappend (a1,b1) (a2,b2) =+ (gmappend a1 a2,gmappend b1 b2)+instance (GMonoid a,GMonoid b,GMonoid c) => GMonoid (a,b,c) where+ gmempty = (gmempty,gmempty,gmempty)+ gmappend (a1,b1,c1) (a2,b2,c2) =+ (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2)+instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d) => GMonoid (a,b,c,d) where+ gmempty = (gmempty,gmempty,gmempty,gmempty)+ gmappend (a1,b1,c1,d1) (a2,b2,c2,d2) =+ (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2)+instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e) => GMonoid (a,b,c,d,e) where+ gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty)+ gmappend (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) =+ (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2)+instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f) => GMonoid (a,b,c,d,e,f) where+ gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty)+ gmappend (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) =+ (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2)+instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f,GMonoid g) => GMonoid (a,b,c,d,e,f,g) where+ gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty)+ gmappend (a1,b1,c1,d1,e1,f1,g1) (a2,b2,c2,d2,e2,f2,g2) =+ (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2,gmappend g1 g2)+instance (GMonoid a,GMonoid b,GMonoid c,GMonoid d,GMonoid e,GMonoid f,GMonoid g,GMonoid h) => GMonoid (a,b,c,d,e,f,g,h) where+ gmempty = (gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty,gmempty)+ gmappend (a1,b1,c1,d1,e1,f1,g1,h1) (a2,b2,c2,d2,e2,f2,g2,h2) =+ (gmappend a1 a2,gmappend b1 b2,gmappend c1 c2,gmappend d1 d2,gmappend e1 e2,gmappend f1 f2,gmappend g1 g2,gmappend h1 h2)
+ tests/Generics/Deriving/Semigroup.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE Trustworthy #-}+#endif++module Generics.Deriving.Semigroup (module Generics.Deriving.Semigroup.Internal) where++import Generics.Deriving.Semigroup.Internal++#if MIN_VERSION_base(4,9,0)+import Data.Semigroup (WrappedMonoid(..))+import Generics.Deriving.Monoid.Internal (GMonoid(..))++instance GMonoid m => GSemigroup (WrappedMonoid m) where+ gsappend (WrapMonoid a) (WrapMonoid b) = WrapMonoid (gmappend a b)+#endif
+ tests/Generics/Deriving/Semigroup/Internal.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+#endif++#if __GLASGOW_HASKELL__ >= 705+{-# LANGUAGE PolyKinds #-}+#endif++#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif++module Generics.Deriving.Semigroup.Internal (+ -- * Generic semigroup class+ GSemigroup(..)++ -- * Default definition+ , gsappenddefault++ -- * Internal semigroup class+ , GSemigroup'(..)++ ) where++import Control.Applicative+import Data.Monoid as Monoid+#if MIN_VERSION_base(4,5,0)+ hiding ((<>))+#endif+import Generics.Linear++#if MIN_VERSION_base(4,6,0)+import Data.Ord (Down)+#else+import GHC.Exts (Down)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+import Data.Void (Void)+#endif++#if MIN_VERSION_base(4,9,0)+import Data.List.NonEmpty (NonEmpty(..))+import Data.Semigroup as Semigroup+#endif++-------------------------------------------------------------------------------++infixr 6 `gsappend'`+class GSemigroup' f where+ gsappend' :: f x -> f x -> f x++instance GSemigroup' U1 where+ gsappend' U1 U1 = U1++instance GSemigroup a => GSemigroup' (K1 i a) where+ gsappend' (K1 x) (K1 y) = K1 (gsappend x y)++instance GSemigroup' f => GSemigroup' (M1 i c f) where+ gsappend' (M1 x) (M1 y) = M1 (gsappend' x y)++instance GSemigroup' f => GSemigroup' (MP1 m f) where+ gsappend' (MP1 x) (MP1 y) = MP1 (gsappend' x y)++instance (GSemigroup' f, GSemigroup' g) => GSemigroup' (f :*: g) where+ gsappend' (x1 :*: y1) (x2 :*: y2) = gsappend' x1 x2 :*: gsappend' y1 y2++-------------------------------------------------------------------------------++infixr 6 `gsappend`+class GSemigroup a where+ gsappend :: a -> a -> a+#if __GLASGOW_HASKELL__ >= 701+ default gsappend :: (Generic a, GSemigroup' (Rep a)) => a -> a -> a+ gsappend = gsappenddefault+#endif++ gstimes :: Integral b => b -> a -> a+ gstimes y0 x0+ | y0 <= 0 = error "gstimes: positive multiplier expected"+ | otherwise = f x0 y0+ where+ f x y+ | even y = f (gsappend x x) (y `quot` 2)+ | y == 1 = x+ | otherwise = g (gsappend x x) (pred y `quot` 2) x+ g x y z+ | even y = g (gsappend x x) (y `quot` 2) z+ | y == 1 = gsappend x z+ | otherwise = g (gsappend x x) (pred y `quot` 2) (gsappend x z)++#if MIN_VERSION_base(4,9,0)+ -- | Only available with @base-4.9@ or later+ gsconcat :: NonEmpty a -> a+ gsconcat (a :| as) = go a as where+ go b (c:cs) = gsappend b (go c cs)+ go b [] = b+#endif++infixr 6 `gsappenddefault`+gsappenddefault :: (Generic a, GSemigroup' (Rep a)) => a -> a -> a+gsappenddefault x y = to (gsappend' (from x) (from y))++-------------------------------------------------------------------------------++-- Instances that reuse Monoid+instance GSemigroup Ordering where+ gsappend = mappend+instance GSemigroup () where+ gsappend = mappend+instance GSemigroup Any where+ gsappend = mappend+instance GSemigroup All where+ gsappend = mappend+instance GSemigroup (Monoid.First a) where+ gsappend = mappend+instance GSemigroup (Monoid.Last a) where+ gsappend = mappend+instance Num a => GSemigroup (Sum a) where+ gsappend = mappend+instance Num a => GSemigroup (Product a) where+ gsappend = mappend+instance GSemigroup [a] where+ gsappend = mappend+instance GSemigroup (Endo a) where+ gsappend = mappend+#if MIN_VERSION_base(4,8,0)+instance Alternative f => GSemigroup (Alt f a) where+ gsappend = mappend+#endif++-- Handwritten instances+instance GSemigroup a => GSemigroup (Dual a) where+ gsappend (Dual x) (Dual y) = Dual (gsappend y x)+instance GSemigroup a => GSemigroup (Maybe a) where+ gsappend Nothing x = x+ gsappend x Nothing = x+ gsappend (Just x) (Just y) = Just (gsappend x y)+instance GSemigroup b => GSemigroup (a -> b) where+ gsappend f g x = gsappend (f x) (g x)+instance GSemigroup a => GSemigroup (Const a b) where+ gsappend = gsappenddefault+instance GSemigroup a => GSemigroup (Down a) where+ gsappend = gsappenddefault+instance GSemigroup (Either a b) where+ gsappend Left{} b = b+ gsappend a _ = a++#if MIN_VERSION_base(4,7,0)+instance GSemigroup+# if MIN_VERSION_base(4,9,0)+ (Proxy s)+# else+ (Proxy (s :: *))+# endif+ where+ gsappend = gsappenddefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GSemigroup a => GSemigroup (Identity a) where+ gsappend = gsappenddefault++instance GSemigroup Void where+ gsappend a _ = a+#endif++#if MIN_VERSION_base(4,9,0)+instance GSemigroup (Semigroup.First a) where+ gsappend = (<>)++instance GSemigroup (Semigroup.Last a) where+ gsappend = (<>)++instance Ord a => GSemigroup (Max a) where+ gsappend = (<>)++instance Ord a => GSemigroup (Min a) where+ gsappend = (<>)++instance GSemigroup (NonEmpty a) where+ gsappend = (<>)+#endif++-- Tuple instances+instance (GSemigroup a,GSemigroup b) => GSemigroup (a,b) where+ gsappend (a1,b1) (a2,b2) =+ (gsappend a1 a2,gsappend b1 b2)+instance (GSemigroup a,GSemigroup b,GSemigroup c) => GSemigroup (a,b,c) where+ gsappend (a1,b1,c1) (a2,b2,c2) =+ (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2)+instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d) => GSemigroup (a,b,c,d) where+ gsappend (a1,b1,c1,d1) (a2,b2,c2,d2) =+ (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2)+instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e) => GSemigroup (a,b,c,d,e) where+ gsappend (a1,b1,c1,d1,e1) (a2,b2,c2,d2,e2) =+ (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2)+instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e,GSemigroup f) => GSemigroup (a,b,c,d,e,f) where+ gsappend (a1,b1,c1,d1,e1,f1) (a2,b2,c2,d2,e2,f2) =+ (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2,gsappend f1 f2)+instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e,GSemigroup f,GSemigroup g) => GSemigroup (a,b,c,d,e,f,g) where+ gsappend (a1,b1,c1,d1,e1,f1,g1) (a2,b2,c2,d2,e2,f2,g2) =+ (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2,gsappend f1 f2,gsappend g1 g2)+instance (GSemigroup a,GSemigroup b,GSemigroup c,GSemigroup d,GSemigroup e,GSemigroup f,GSemigroup g,GSemigroup h) => GSemigroup (a,b,c,d,e,f,g,h) where+ gsappend (a1,b1,c1,d1,e1,f1,g1,h1) (a2,b2,c2,d2,e2,f2,g2,h2) =+ (gsappend a1 a2,gsappend b1 b2,gsappend c1 c2,gsappend d1 d2,gsappend e1 e2,gsappend f1 f2,gsappend g1 g2,gsappend h1 h2)
+ tests/Generics/Deriving/Show.hs view
@@ -0,0 +1,666 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE Trustworthy #-}+#endif++#if __GLASGOW_HASKELL__ >= 708+{-# LANGUAGE EmptyCase #-}+#endif++module Generics.Deriving.Show (+ -- * Generic show class+ GShow(..)++ -- * Default definition+ , gshowsPrecdefault++ -- * Internal show class+ , GShow'(..)++ ) where++import Control.Applicative (Const, ZipList)++import Data.Char (GeneralCategory)+import Data.Int+import Data.Monoid (All, Any, Dual, Product, Sum)+import qualified Data.Monoid as Monoid (First, Last)+import Data.Version (Version)+import Data.Word++import Foreign.C.Types+import Foreign.ForeignPtr (ForeignPtr)+import Foreign.Ptr++import Generics.Linear++import GHC.Exts hiding (Any)++import System.Exit (ExitCode)+import System.IO (BufferMode, Handle, HandlePosn, IOMode, SeekMode)+import System.IO.Error (IOErrorType)+import System.Posix.Types++#if MIN_VERSION_base(4,4,0)+import Data.Complex (Complex)+#endif++#if MIN_VERSION_base(4,7,0)+import Data.Proxy (Proxy)+#endif++#if MIN_VERSION_base(4,8,0)+import Data.Functor.Identity (Identity)+import Data.Monoid (Alt)+import Data.Void (Void)+import Numeric.Natural (Natural)+#endif++#if MIN_VERSION_base(4,9,0)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg, Max, Min, WrappedMonoid)+#endif++--------------------------------------------------------------------------------+-- Generic show+--------------------------------------------------------------------------------++intersperse :: a -> [a] -> [a]+intersperse _ [] = []+intersperse _ [h] = [h]+intersperse x (h:t) = h : x : (intersperse x t)++appPrec :: Int+appPrec = 2++data Type = Rec | Tup | Pref | Inf String++class GShow' f where+ gshowsPrec' :: Type -> Int -> f a -> ShowS+ isNullary :: f a -> Bool+ isNullary = error "generic show (isNullary): unnecessary case"++instance GShow' V1 where+ gshowsPrec' _ _ x = case x of+#if __GLASGOW_HASKELL__ >= 708+ {}+#else+ !_ -> error "Void gshowsPrec"+#endif++instance GShow' U1 where+ gshowsPrec' _ _ U1 = id+ isNullary _ = True++instance (GShow c) => GShow' (K1 i c) where+ gshowsPrec' _ n (K1 a) = gshowsPrec n a+ isNullary _ = False++-- No instances for P or Rec because gshow is only applicable to types of kind *++instance (GShow' a, Constructor c) => GShow' (M1 C c a) where+ gshowsPrec' _ n c@(M1 x) =+ case fixity of+ Prefix -> showParen (n > appPrec && not (isNullary x))+ ( showString (conName c)+ . if (isNullary x) then id else showChar ' '+ . showBraces t (gshowsPrec' t appPrec x))+ Infix _ m -> showParen (n > m) (showBraces t (gshowsPrec' t m x))+ where fixity = conFixity c+ t = if (conIsRecord c) then Rec else+ case (conIsTuple c) of+ True -> Tup+ False -> case fixity of+ Prefix -> Pref+ Infix _ _ -> Inf (show (conName c))+ showBraces :: Type -> ShowS -> ShowS+ showBraces Rec p = showChar '{' . p . showChar '}'+ showBraces Tup p = showChar '(' . p . showChar ')'+ showBraces Pref p = p+ showBraces (Inf _) p = p++ conIsTuple :: C1 c f p -> Bool+ conIsTuple y = tupleName (conName y) where+ tupleName ('(':',':_) = True+ tupleName _ = False++instance (Selector s, GShow' a) => GShow' (M1 S s a) where+ gshowsPrec' t n s@(M1 x) | selName s == "" = --showParen (n > appPrec)+ (gshowsPrec' t n x)+ | otherwise = showString (selName s)+ . showString " = "+ . gshowsPrec' t 0 x+ isNullary (M1 x) = isNullary x++instance GShow' a => GShow' (M1 D d a) where+ gshowsPrec' t n (M1 x) = gshowsPrec' t n x++instance GShow' a => GShow' (MP1 m a) where+ gshowsPrec' t n (MP1 x) = gshowsPrec' t n x++instance (GShow' a, GShow' b) => GShow' (a :+: b) where+ gshowsPrec' t n (L1 x) = gshowsPrec' t n x+ gshowsPrec' t n (R1 x) = gshowsPrec' t n x++instance (GShow' a, GShow' b) => GShow' (a :*: b) where+ gshowsPrec' t@Rec n (a :*: b) =+ gshowsPrec' t n a . showString ", " . gshowsPrec' t n b+ gshowsPrec' t@(Inf s) n (a :*: b) =+ gshowsPrec' t n a . showString s . gshowsPrec' t n b+ gshowsPrec' t@Tup n (a :*: b) =+ gshowsPrec' t n a . showChar ',' . gshowsPrec' t n b+ gshowsPrec' t@Pref n (a :*: b) =+ gshowsPrec' t (n+1) a . showChar ' ' . gshowsPrec' t (n+1) b++ -- If we have a product then it is not a nullary constructor+ isNullary _ = False++-- Unboxed types+instance GShow' UChar where+ gshowsPrec' _ _ (UChar c) = showsPrec 0 (C# c) . showChar '#'+instance GShow' UDouble where+ gshowsPrec' _ _ (UDouble d) = showsPrec 0 (D# d) . showString "##"+instance GShow' UFloat where+ gshowsPrec' _ _ (UFloat f) = showsPrec 0 (F# f) . showChar '#'+instance GShow' UInt where+ gshowsPrec' _ _ (UInt i) = showsPrec 0 (I# i) . showChar '#'+instance GShow' UWord where+ gshowsPrec' _ _ (UWord w) = showsPrec 0 (W# w) . showString "##"+++class GShow a where+ gshowsPrec :: Int -> a -> ShowS+#if __GLASGOW_HASKELL__ >= 701+ default gshowsPrec :: (Generic a, GShow' (Rep a))+ => Int -> a -> ShowS+ gshowsPrec = gshowsPrecdefault+#endif++ gshows :: a -> ShowS+ gshows = gshowsPrec 0++ gshow :: a -> String+ gshow x = gshows x ""++ gshowList :: [a] -> ShowS+ gshowList l = showChar '['+ . foldr (.) id+ (intersperse (showChar ',') (map (gshowsPrec 0) l))+ . showChar ']'++gshowsPrecdefault :: (Generic a, GShow' (Rep a))+ => Int -> a -> ShowS+gshowsPrecdefault n = gshowsPrec' Pref n . from+++-- Base types instances+-- Base types instances+instance GShow () where+ gshowsPrec = gshowsPrecdefault++instance (GShow a, GShow b) => GShow (a, b) where+ gshowsPrec = gshowsPrecdefault++instance (GShow a, GShow b, GShow c) => GShow (a, b, c) where+ gshowsPrec = gshowsPrecdefault++instance (GShow a, GShow b, GShow c, GShow d) => GShow (a, b, c, d) where+ gshowsPrec = gshowsPrecdefault++instance (GShow a, GShow b, GShow c, GShow d, GShow e) => GShow (a, b, c, d, e) where+ gshowsPrec = gshowsPrecdefault++instance (GShow a, GShow b, GShow c, GShow d, GShow e, GShow f)+ => GShow (a, b, c, d, e, f) where+ gshowsPrec = gshowsPrecdefault++instance (GShow a, GShow b, GShow c, GShow d, GShow e, GShow f, GShow g)+ => GShow (a, b, c, d, e, f, g) where+ gshowsPrec = gshowsPrecdefault++instance GShow a => GShow [a] where+ gshowsPrec _ = gshowList++instance (GShow (f p), GShow (g p)) => GShow ((f :+: g) p) where+ gshowsPrec = gshowsPrecdefault++instance (GShow (f p), GShow (g p)) => GShow ((f :*: g) p) where+ gshowsPrec = gshowsPrecdefault++instance GShow (f (g p)) => GShow ((f :.: g) p) where+ gshowsPrec = gshowsPrecdefault++instance GShow All where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,8,0)+instance GShow (f a) => GShow (Alt f a) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow Any where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,9,0)+instance (GShow a, GShow b) => GShow (Arg a b) where+ gshowsPrec = gshowsPrecdefault+#endif++#if !(MIN_VERSION_base(4,9,0))+instance GShow Arity where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow Associativity where+ gshowsPrec = gshowsPrecdefault++instance GShow Bool where+ gshowsPrec = gshowsPrecdefault++instance GShow BufferMode where+ gshowsPrec = showsPrec++#if defined(HTYPE_CC_T)+instance GShow CCc where+ gshowsPrec = showsPrec+#endif++instance GShow CChar where+ gshowsPrec = showsPrec++instance GShow CClock where+ gshowsPrec = showsPrec++#if defined(HTYPE_DEV_T)+instance GShow CDev where+ gshowsPrec = showsPrec+#endif++instance GShow CDouble where+ gshowsPrec = showsPrec++instance GShow CFloat where+ gshowsPrec = showsPrec++#if defined(HTYPE_GID_T)+instance GShow CGid where+ gshowsPrec = showsPrec+#endif++instance GShow Char where+ gshowsPrec = showsPrec+ gshowList = showList++#if defined(HTYPE_INO_T)+instance GShow CIno where+ gshowsPrec = showsPrec+#endif++instance GShow CInt where+ gshowsPrec = showsPrec++instance GShow CIntMax where+ gshowsPrec = showsPrec++instance GShow CIntPtr where+ gshowsPrec = showsPrec++instance GShow CLLong where+ gshowsPrec = showsPrec++instance GShow CLong where+ gshowsPrec = showsPrec++#if defined(HTYPE_MODE_T)+instance GShow CMode where+ gshowsPrec = showsPrec+#endif++#if defined(HTYPE_NLINK_T)+instance GShow CNlink where+ gshowsPrec = showsPrec+#endif++#if defined(HTYPE_OFF_T)+instance GShow COff where+ gshowsPrec = showsPrec+#endif++#if MIN_VERSION_base(4,4,0)+instance GShow a => GShow (Complex a) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow a => GShow (Const a b) where+ gshowsPrec = gshowsPrecdefault++#if defined(HTYPE_PID_T)+instance GShow CPid where+ gshowsPrec = showsPrec+#endif++instance GShow CPtrdiff where+ gshowsPrec = showsPrec++#if defined(HTYPE_RLIM_T)+instance GShow CRLim where+ gshowsPrec = showsPrec+#endif++instance GShow CSChar where+ gshowsPrec = showsPrec++#if defined(HTYPE_SPEED_T)+instance GShow CSpeed where+ gshowsPrec = showsPrec+#endif++#if MIN_VERSION_base(4,4,0)+instance GShow CSUSeconds where+ gshowsPrec = showsPrec+#endif++instance GShow CShort where+ gshowsPrec = showsPrec++instance GShow CSigAtomic where+ gshowsPrec = showsPrec++instance GShow CSize where+ gshowsPrec = showsPrec++#if defined(HTYPE_SSIZE_T)+instance GShow CSsize where+ gshowsPrec = showsPrec+#endif++#if defined(HTYPE_TCFLAG_T)+instance GShow CTcflag where+ gshowsPrec = showsPrec+#endif++instance GShow CTime where+ gshowsPrec = showsPrec++instance GShow CUChar where+ gshowsPrec = showsPrec++#if defined(HTYPE_UID_T)+instance GShow CUid where+ gshowsPrec = showsPrec+#endif++instance GShow CUInt where+ gshowsPrec = showsPrec++instance GShow CUIntMax where+ gshowsPrec = showsPrec++instance GShow CUIntPtr where+ gshowsPrec = showsPrec++instance GShow CULLong where+ gshowsPrec = showsPrec++instance GShow CULong where+ gshowsPrec = showsPrec++#if MIN_VERSION_base(4,4,0)+instance GShow CUSeconds where+ gshowsPrec = showsPrec+#endif++instance GShow CUShort where+ gshowsPrec = showsPrec++instance GShow CWchar where+ gshowsPrec = showsPrec++instance GShow Double where+ gshowsPrec = showsPrec++instance GShow a => GShow (Down a) where+ gshowsPrec = gshowsPrecdefault++instance GShow a => GShow (Dual a) where+ gshowsPrec = gshowsPrecdefault++instance (GShow a, GShow b) => GShow (Either a b) where+ gshowsPrec = gshowsPrecdefault++instance GShow ExitCode where+ gshowsPrec = gshowsPrecdefault++instance GShow Fd where+ gshowsPrec = showsPrec++instance GShow a => GShow (Monoid.First a) where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,9,0)+instance GShow a => GShow (Semigroup.First a) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow Fixity where+ gshowsPrec = gshowsPrecdefault++instance GShow Float where+ gshowsPrec = showsPrec++instance GShow (ForeignPtr a) where+ gshowsPrec = showsPrec++instance GShow (FunPtr a) where+ gshowsPrec = showsPrec++instance GShow GeneralCategory where+ gshowsPrec = showsPrec++instance GShow Handle where+ gshowsPrec = showsPrec++instance GShow HandlePosn where+ gshowsPrec = showsPrec++#if MIN_VERSION_base(4,8,0)+instance GShow a => GShow (Identity a) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow Int where+ gshowsPrec = showsPrec++instance GShow Int8 where+ gshowsPrec = showsPrec++instance GShow Int16 where+ gshowsPrec = showsPrec++instance GShow Int32 where+ gshowsPrec = showsPrec++instance GShow Int64 where+ gshowsPrec = showsPrec++instance GShow Integer where+ gshowsPrec = showsPrec++instance GShow IntPtr where+ gshowsPrec = showsPrec++instance GShow IOError where+ gshowsPrec = showsPrec++instance GShow IOErrorType where+ gshowsPrec = showsPrec++instance GShow IOMode where+ gshowsPrec = showsPrec++instance GShow c => GShow (K1 i c p) where+ gshowsPrec = gshowsPrecdefault++instance GShow a => GShow (Monoid.Last a) where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,9,0)+instance GShow a => GShow (Semigroup.Last a) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow (f p) => GShow (M1 i c f p) where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,9,0)+instance GShow a => GShow (Max a) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow a => GShow (Maybe a) where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,9,0)+instance GShow a => GShow (Min a) where+ gshowsPrec = gshowsPrecdefault+#endif++#if MIN_VERSION_base(4,8,0)+instance GShow Natural where+ gshowsPrec = showsPrec+#endif++#if MIN_VERSION_base(4,9,0)+instance GShow a => GShow (NonEmpty a) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow Ordering where+ gshowsPrec = gshowsPrecdefault++instance GShow p => GShow (Par1 p) where+ gshowsPrec = gshowsPrecdefault++instance GShow a => GShow (Product a) where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,7,0)+instance GShow (Proxy s) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow (Ptr a) where+ gshowsPrec = showsPrec++instance GShow SeekMode where+ gshowsPrec = showsPrec++instance GShow a => GShow (Sum a) where+ gshowsPrec = gshowsPrecdefault++instance GShow (U1 p) where+ gshowsPrec = gshowsPrecdefault++instance GShow (UChar p) where+ gshowsPrec = gshowsPrecdefault++instance GShow (UDouble p) where+ gshowsPrec = gshowsPrecdefault++instance GShow (UFloat p) where+ gshowsPrec = gshowsPrecdefault++instance GShow (UInt p) where+ gshowsPrec = gshowsPrecdefault++instance GShow (UWord p) where+ gshowsPrec = gshowsPrecdefault++instance GShow Version where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,8,0)+instance GShow Void where+ gshowsPrec = showsPrec+#endif++instance GShow Word where+ gshowsPrec = showsPrec++instance GShow Word8 where+ gshowsPrec = showsPrec++instance GShow Word16 where+ gshowsPrec = showsPrec++instance GShow Word32 where+ gshowsPrec = showsPrec++instance GShow Word64 where+ gshowsPrec = showsPrec++instance GShow WordPtr where+ gshowsPrec = showsPrec++#if MIN_VERSION_base(4,9,0)+instance GShow m => GShow (WrappedMonoid m) where+ gshowsPrec = gshowsPrecdefault+#endif++instance GShow a => GShow (ZipList a) where+ gshowsPrec = gshowsPrecdefault++#if MIN_VERSION_base(4,10,0)+instance GShow CBool where+ gshowsPrec = showsPrec++# if defined(HTYPE_BLKSIZE_T)+instance GShow CBlkSize where+ gshowsPrec = showsPrec+# endif++# if defined(HTYPE_BLKCNT_T)+instance GShow CBlkCnt where+ gshowsPrec = showsPrec+# endif++# if defined(HTYPE_CLOCKID_T)+instance GShow CClockId where+ gshowsPrec = showsPrec+# endif++# if defined(HTYPE_FSBLKCNT_T)+instance GShow CFsBlkCnt where+ gshowsPrec = showsPrec+# endif++# if defined(HTYPE_FSFILCNT_T)+instance GShow CFsFilCnt where+ gshowsPrec = showsPrec+# endif++# if defined(HTYPE_ID_T)+instance GShow CId where+ gshowsPrec = showsPrec+# endif++# if defined(HTYPE_KEY_T)+instance GShow CKey where+ gshowsPrec = showsPrec+# endif++# if defined(HTYPE_TIMER_T)+instance GShow CTimer where+ gshowsPrec = showsPrec+# endif+#endif
+ tests/Generics/Deriving/Traversable.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE Safe #-}++-- | A generic implementation of a 'Traversable'-like class.+-- See "Generics.Deriving.TraversableConf" for a more efficient,+-- but also more complicated, version.+module Generics.Deriving.Traversable (+ -- * Generic Traversable class+ GTraversable(..)++ -- * Default method+ , gtraversedefault++ -- * Internal Traversable class+ , GTraversable'(..)++ ) where++import Control.Applicative (Const, WrappedMonad(..), ZipList)++import qualified Data.Monoid as Monoid (First, Last, Product, Sum)+import Data.Monoid (Dual)++import Generics.Linear+import Generics.Deriving.Foldable+import Generics.Deriving.Functor+++import Data.Complex (Complex)+++import Data.Ord (Down)+++import Data.Proxy (Proxy)++++import Data.Functor.Identity (Identity)++++import qualified Data.Functor.Product as Functor (Product)+import qualified Data.Functor.Sum as Functor (Sum)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg, Max, Min, WrappedMonoid)+++--------------------------------------------------------------------------------+-- Generic traverse+--------------------------------------------------------------------------------++class GTraversable' t where+ gtraverse' :: Applicative f => (a -> f b) -> t a -> f (t b)++instance GTraversable' V1 where+ gtraverse' _ x = pure $ case x of++instance GTraversable' U1 where+ gtraverse' _ U1 = pure U1++instance GTraversable' Par1 where+ gtraverse' f (Par1 a) = Par1 <$> f a++instance GTraversable' (K1 i c) where+ gtraverse' _ (K1 a) = pure (K1 a)++instance GTraversable' f => GTraversable' (M1 i c f) where+ gtraverse' f (M1 a) = M1 <$> gtraverse' f a++instance GTraversable' f => GTraversable' (MP1 m f) where+ gtraverse' f (MP1 a) = (\x -> MP1 x) <$> gtraverse' f a++instance (GTraversable' f, GTraversable' g) => GTraversable' (f :+: g) where+ gtraverse' f (L1 a) = L1 <$> gtraverse' f a+ gtraverse' f (R1 a) = R1 <$> gtraverse' f a++instance (GTraversable' f, GTraversable' g) => GTraversable' (f :*: g) where+ gtraverse' f (a :*: b) = (:*:) <$> gtraverse' f a <*> gtraverse' f b++instance (GTraversable' f, GTraversable g) => GTraversable' (f :.: g) where+ gtraverse' f (Comp1 x) = Comp1 <$> gtraverse' (gtraverse f) x++instance GTraversable' UAddr where+ gtraverse' _ (UAddr a) = pure (UAddr a)++instance GTraversable' UChar where+ gtraverse' _ (UChar c) = pure (UChar c)++instance GTraversable' UDouble where+ gtraverse' _ (UDouble d) = pure (UDouble d)++instance GTraversable' UFloat where+ gtraverse' _ (UFloat f) = pure (UFloat f)++instance GTraversable' UInt where+ gtraverse' _ (UInt i) = pure (UInt i)++instance GTraversable' UWord where+ gtraverse' _ (UWord w) = pure (UWord w)++class (GFunctor t, GFoldable t) => GTraversable t where+ gtraverse :: Applicative f => (a -> f b) -> t a -> f (t b)++ default gtraverse :: (Generic1 t, GTraversable' (Rep1 t), Applicative f)+ => (a -> f b) -> t a -> f (t b)+ gtraverse = gtraversedefault+++ gsequenceA :: Applicative f => t (f a) -> f (t a)+ gsequenceA = gtraverse id++ gmapM :: Monad m => (a -> m b) -> t a -> m (t b)+ gmapM f = unwrapMonad . gtraverse (WrapMonad . f)++ gsequence :: Monad m => t (m a) -> m (t a)+ gsequence = gmapM id++gtraversedefault :: (Generic1 t, GTraversable' (Rep1 t), Applicative f)+ => (a -> f b) -> t a -> f (t b)+gtraversedefault f x = to1 <$> gtraverse' f (from1 x)++-- Base types instances+instance GTraversable ((,) a)+instance GTraversable []+instance GTraversable (Arg a)+instance GTraversable Complex+instance GTraversable (Const m)+instance GTraversable Down+instance GTraversable Dual+instance GTraversable (Either a)+instance GTraversable Monoid.First+instance GTraversable (Semigroup.First)+instance GTraversable Identity+instance GTraversable Monoid.Last+instance GTraversable Semigroup.Last+instance GTraversable Max+instance GTraversable Maybe+instance GTraversable Min+instance GTraversable NonEmpty+instance GTraversable Monoid.Product+instance (GTraversable f, GTraversable g) => GTraversable (Functor.Product f g)+instance GTraversable Proxy+instance GTraversable Monoid.Sum+instance (GTraversable f, GTraversable g) => GTraversable (Functor.Sum f g)+instance GTraversable WrappedMonoid+instance GTraversable ZipList
+ tests/Generics/Deriving/TraversableConf.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# language RankNTypes #-}++-- | A \"confusing\" default implementation of a 'Traversable'-like class that+-- produces code very much like derived instances. It uses the same magic+-- behind @Control.Lens.Traversal.confusing@.+module Generics.Deriving.TraversableConf (+ -- * Generic Traversable class+ GTraversable(..)++ -- * Default method+ , gtraversedefault++ -- * Internal Traversable class+ , GTraversable'(..)++ ) where++import Control.Applicative (Const, WrappedMonad(..), ZipList)+import qualified Data.Monoid as Monoid (First, Last, Product, Sum)+import Data.Monoid (Dual)+import Generics.Linear+import Generics.Deriving.Foldable+import Generics.Deriving.Functor+import Data.Complex (Complex)+import Data.Ord (Down)+import Data.Proxy (Proxy)+import Data.Functor.Identity (Identity)+import qualified Data.Functor.Product as Functor (Product)+import qualified Data.Functor.Sum as Functor (Sum)+import Data.Functor.Compose (Compose)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.Semigroup as Semigroup (First, Last)+import Data.Semigroup (Arg, Max, Min, WrappedMonoid)++--------------------------------------------------------------------------------+-- Generic traverse+--------------------------------------------------------------------------------++class GTraversable' t where+ gtraverse' :: Applicative f => (a -> f b) -> t a -> CY f (t b)++instance GTraversable' V1 where+ gtraverse' _ x = pure $ case x of++instance GTraversable' U1 where+ gtraverse' _ U1 = pure U1++instance GTraversable' Par1 where+ gtraverse' f (Par1 a) = Par1 <$> liftCY (f a)++instance GTraversable' (K1 i c) where+ gtraverse' _ (K1 a) = pure (K1 a)++instance GTraversable' f => GTraversable' (M1 i c f) where+ gtraverse' f (M1 a) = M1 <$> gtraverse' f a++instance GTraversable' f => GTraversable' (MP1 m f) where+ gtraverse' f (MP1 a) = (\x -> MP1 x) <$> gtraverse' f a++instance (GTraversable' f, GTraversable' g) => GTraversable' (f :+: g) where+ gtraverse' f (L1 a) = L1 <$> gtraverse' f a+ gtraverse' f (R1 a) = R1 <$> gtraverse' f a++instance (GTraversable' f, GTraversable' g) => GTraversable' (f :*: g) where+ gtraverse' f (a :*: b) = (:*:) <$> gtraverse' f a <*> gtraverse' f b++instance (GTraversable' f, GTraversable g) => GTraversable' (f :.: g) where+ gtraverse' f (Comp1 x) = Comp1 <$> gtraverse' (gtraverse f) x++instance GTraversable' UAddr where+ gtraverse' _ (UAddr a) = pure (UAddr a)++instance GTraversable' UChar where+ gtraverse' _ (UChar c) = pure (UChar c)++instance GTraversable' UDouble where+ gtraverse' _ (UDouble d) = pure (UDouble d)++instance GTraversable' UFloat where+ gtraverse' _ (UFloat f) = pure (UFloat f)++instance GTraversable' UInt where+ gtraverse' _ (UInt i) = pure (UInt i)++instance GTraversable' UWord where+ gtraverse' _ (UWord w) = pure (UWord w)++class (GFunctor t, GFoldable t) => GTraversable t where+ gtraverse :: Applicative f => (a -> f b) -> t a -> f (t b)+ default gtraverse :: (Generic1 t, GTraversable' (Rep1 t), Applicative f)+ => (a -> f b) -> t a -> f (t b)+ gtraverse = gtraversedefault++ gsequenceA :: Applicative f => t (f a) -> f (t a)+ gsequenceA = gtraverse id++ gmapM :: Monad m => (a -> m b) -> t a -> m (t b)+ gmapM f = unwrapMonad . gtraverse (WrapMonad . f)++ gsequence :: Monad m => t (m a) -> m (t a)+ gsequence = gmapM id++gtraversedefault :: (Generic1 t, GTraversable' (Rep1 t), Applicative f)+ => (a -> f b) -> t a -> f (t b)+gtraversedefault f x = lowerCY $ to1 <$> gtraverse' f (from1 x)+{-# INLINE gtraversedefault #-}++-- Base types instances+instance GTraversable ((,) a)+instance GTraversable ((,,) a b)+instance GTraversable ((,,,) a b c)+instance GTraversable []+instance GTraversable (Arg a)+instance GTraversable Complex+instance GTraversable (Const m)+instance GTraversable Down+instance GTraversable Dual+instance GTraversable (Either a)+instance GTraversable Monoid.First+instance GTraversable (Semigroup.First)+instance GTraversable Identity+instance GTraversable Monoid.Last+instance GTraversable Semigroup.Last+instance GTraversable Max+instance GTraversable Maybe+instance GTraversable Min+instance GTraversable NonEmpty+instance GTraversable Monoid.Product+instance (GTraversable f, GTraversable g) => GTraversable (Functor.Product f g)+instance (GTraversable f, GTraversable g) => GTraversable (Compose f g)+instance GTraversable Proxy+instance GTraversable Monoid.Sum+instance (GTraversable f, GTraversable g) => GTraversable (Functor.Sum f g)+instance GTraversable WrappedMonoid+instance GTraversable ZipList++-- The types below are stolen from kan-extensions, and used in the same way as+-- Control.Lens.Traversal.confusing. Note that this is *not* equivalent to+-- applying `confusing` itself to a plain traversal: the latter seems to make a+-- mess with types like+--+-- data Gramp f a = Gramp Int a (f a)++newtype Curried g h a = Curried (forall r. g (a -> r) -> h r)++instance Functor g => Functor (Curried g h) where+ fmap f (Curried g) = Curried (g . fmap (.f))+ {-# INLINE fmap #-}++instance (Functor g, g ~ h) => Applicative (Curried g h) where+ pure a = Curried (fmap ($ a))+ {-# INLINE pure #-}+ Curried mf <*> Curried ma = Curried (ma . mf . fmap (.))+ {-# INLINE (<*>) #-}++lowerCurried :: Applicative f => Curried f g a -> g a+lowerCurried (Curried f) = f (pure id)+{-# INLINE lowerCurried #-}++newtype Yoneda f a = Yoneda { runYoneda :: forall b. (a -> b) -> f b }++lowerYoneda :: Yoneda f a -> f a+lowerYoneda (Yoneda f) = f id+{-# INLINE lowerYoneda #-}++instance Functor (Yoneda f) where+ fmap f m = Yoneda (\k -> runYoneda m (k . f))+ {-# INLINE fmap #-}++instance Applicative f => Applicative (Yoneda f) where+ pure a = Yoneda (\f -> pure (f a))+ {-# INLINE pure #-}+ Yoneda m <*> Yoneda n = Yoneda (\f -> m (f .) <*> n id)+ {-# INLINE (<*>) #-}++-- Lifted from the implementation of Control.Lens.Traversal.confusing+liftCurriedYoneda :: Applicative f => f a -> Curried (Yoneda f) (Yoneda f) a+liftCurriedYoneda fa = Curried (`yap` fa)+{-# INLINE liftCurriedYoneda #-}++yap :: Applicative f => Yoneda f (a -> b) -> f a -> Yoneda f b+yap (Yoneda k) fa = Yoneda (\ab_r -> k (ab_r .) <*> fa)+{-# INLINE yap #-}++-- This wrapper makes it easy to swap out implementations.+-- See, for example, https://github.com/glguy/generic-traverse,+-- which is essentially the same but uses a custom @Boggle@+-- type. I don't have a good sense of the tradeoffs between+-- the two.+newtype CY f a = CY { unCY :: Curried (Yoneda f) (Yoneda f) a }+ deriving newtype (Functor, Applicative)++liftCY :: Applicative f => f a -> CY f a+liftCY = CY . liftCurriedYoneda++lowerCY :: Applicative f => CY f a -> f a+lowerCY = lowerYoneda . lowerCurried . unCY
+ tests/Generics/Deriving/Uniplate.hs view
@@ -0,0 +1,391 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE Trustworthy #-}+#endif++#if __GLASGOW_HASKELL__ >= 705+{-# LANGUAGE PolyKinds #-}+#endif++#if __GLASGOW_HASKELL__ < 709+{-# LANGUAGE OverlappingInstances #-}+#endif++{- |+Module : Generics.Deriving.Uniplate+Copyright : 2011-2012 Universiteit Utrecht, University of Oxford+License : BSD3++Maintainer : generics@haskell.org+Stability : experimental+Portability : non-portable++Summary: Functions inspired by the Uniplate generic programming library,+mostly implemented by Sean Leather.+-}++module Generics.Deriving.Uniplate (+ -- * Generic Uniplate class+ Uniplate(..)++ -- * Derived functions+ , uniplate+ , universe+ , rewrite+ , rewriteM+ , contexts+ , holes+ , para++ -- * Default definitions+ , childrendefault+ , contextdefault+ , descenddefault+ , descendMdefault+ , transformdefault+ , transformMdefault++ -- * Internal Uniplate class+ , Uniplate'(..)++ -- * Internal Context class+ , Context'(..)+ ) where+++import Generics.Linear++import Control.Monad (liftM, liftM2)+import GHC.Exts (build)++--------------------------------------------------------------------------------+-- Generic Uniplate+--------------------------------------------------------------------------------++class Uniplate' f b where+ children' :: f a -> [b]+ descend' :: (b -> b) -> f a -> f a+ descendM' :: Monad m => (b -> m b) -> f a -> m (f a)+ transform' :: (b -> b) -> f a -> f a+ transformM' :: Monad m => (b -> m b) -> f a -> m (f a)++instance Uniplate' U1 a where+ children' U1 = []+ descend' _ U1 = U1+ descendM' _ U1 = return U1+ transform' _ U1 = U1+ transformM' _ U1 = return U1++instance {-# OVERLAPPING #-} Uniplate a => Uniplate' (K1 i a) a where+ children' (K1 a) = [a]+ descend' f (K1 a) = K1 (f a)+ descendM' f (K1 a) = liftM K1 (f a)+ transform' f (K1 a) = K1 (transform f a)+ transformM' f (K1 a) = liftM K1 (transformM f a)++instance {-# OVERLAPPABLE #-} Uniplate' (K1 i a) b where+ children' (K1 _) = []+ descend' _ (K1 a) = K1 a+ descendM' _ (K1 a) = return (K1 a)+ transform' _ (K1 a) = K1 a+ transformM' _ (K1 a) = return (K1 a)++instance (Uniplate' f b) => Uniplate' (M1 i c f) b where+ children' (M1 a) = children' a+ descend' f (M1 a) = M1 (descend' f a)+ descendM' f (M1 a) = liftM M1 (descendM' f a)+ transform' f (M1 a) = M1 (transform' f a)+ transformM' f (M1 a) = liftM M1 (transformM' f a)++instance Uniplate' f b => Uniplate' (MP1 m f) b where+ children' (MP1 a) = children' a+ descend' f (MP1 a) = MP1 (descend' f a)+ descendM' f (MP1 a) = liftM (\x -> MP1 x) (descendM' f a)+ transform' f (MP1 a) = MP1 (transform' f a)+ transformM' f (MP1 a) = liftM (\x -> MP1 x) (transformM' f a)++instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :+: g) b where+ children' (L1 a) = children' a+ children' (R1 a) = children' a+ descend' f (L1 a) = L1 (descend' f a)+ descend' f (R1 a) = R1 (descend' f a)+ descendM' f (L1 a) = liftM L1 (descendM' f a)+ descendM' f (R1 a) = liftM R1 (descendM' f a)+ transform' f (L1 a) = L1 (transform' f a)+ transform' f (R1 a) = R1 (transform' f a)+ transformM' f (L1 a) = liftM L1 (transformM' f a)+ transformM' f (R1 a) = liftM R1 (transformM' f a)++instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :*: g) b where+ children' (a :*: b) = children' a ++ children' b+ descend' f (a :*: b) = descend' f a :*: descend' f b+ descendM' f (a :*: b) = liftM2 (:*:) (descendM' f a) (descendM' f b)+ transform' f (a :*: b) = transform' f a :*: transform' f b+ transformM' f (a :*: b) = liftM2 (:*:) (transformM' f a) (transformM' f b)+++-- Context' is a separate class from Uniplate' since it uses special product+-- instances, but the context function still appears in Uniplate.+class Context' f b where+ context' :: f a -> [b] -> f a++instance Context' U1 b where+ context' U1 _ = U1++instance+#if __GLASGOW_HASKELL__ >= 709+ {-# OVERLAPPING #-}+#endif+ Context' (K1 i a) a where+ context' _ [] = error "Generics.Deriving.Uniplate.context: empty list"+ context' (K1 _) (c:_) = K1 c++instance+#if __GLASGOW_HASKELL__ >= 709+ {-# OVERLAPPABLE #-}+#endif+ Context' (K1 i a) b where+ context' (K1 a) _ = K1 a++instance (Context' f b) => Context' (M1 i c f) b where+ context' (M1 a) cs = M1 (context' a cs)++instance (Context' f b, Context' g b) => Context' (f :+: g) b where+ context' (L1 a) cs = L1 (context' a cs)+ context' (R1 a) cs = R1 (context' a cs)++instance+#if __GLASGOW_HASKELL__ >= 709+ {-# OVERLAPPING #-}+#endif+ (Context' g a) => Context' (M1 i c (K1 j a) :*: g) a where+ context' _ [] = error "Generics.Deriving.Uniplate.context: empty list"+ context' (M1 (K1 _) :*: b) (c:cs) = M1 (K1 c) :*: context' b cs++instance+#if __GLASGOW_HASKELL__ >= 709+ {-# OVERLAPPABLE #-}+#endif+ (Context' g b) => Context' (f :*: g) b where+ context' (a :*: b) cs = a :*: context' b cs+++class Uniplate a where+ children :: a -> [a]+#if __GLASGOW_HASKELL__ >= 701+ default children :: (Generic a, Uniplate' (Rep a) a) => a -> [a]+ children = childrendefault+#endif++ context :: a -> [a] -> a+#if __GLASGOW_HASKELL__ >= 701+ default context :: (Generic a, Context' (Rep a) a) => a -> [a] -> a+ context = contextdefault+#endif++ descend :: (a -> a) -> a -> a+#if __GLASGOW_HASKELL__ >= 701+ default descend :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a+ descend = descenddefault+#endif++ descendM :: Monad m => (a -> m a) -> a -> m a+#if __GLASGOW_HASKELL__ >= 701+ default descendM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a+ descendM = descendMdefault+#endif++ transform :: (a -> a) -> a -> a+#if __GLASGOW_HASKELL__ >= 701+ default transform :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a+ transform = transformdefault+#endif++ transformM :: Monad m => (a -> m a) -> a -> m a+#if __GLASGOW_HASKELL__ >= 701+ default transformM :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a+ transformM = transformMdefault+#endif++childrendefault :: (Generic a, Uniplate' (Rep a) a) => a -> [a]+childrendefault = children' . from++contextdefault :: (Generic a, Context' (Rep a) a) => a -> [a] -> a+contextdefault x cs = to (context' (from x) cs)++descenddefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a+descenddefault f = to . descend' f . from++descendMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a+descendMdefault f = liftM to . descendM' f . from++transformdefault :: (Generic a, Uniplate' (Rep a) a) => (a -> a) -> a -> a+transformdefault f = f . to . transform' f . from++transformMdefault :: (Generic a, Uniplate' (Rep a) a, Monad m) => (a -> m a) -> a -> m a+transformMdefault f = liftM to . transformM' f . from+++-- Derived functions (mostly copied from Neil Michell's code)++uniplate :: Uniplate a => a -> ([a], [a] -> a)+uniplate a = (children a, context a)++universe :: Uniplate a => a -> [a]+universe a = build (go a)+ where+ go x cons nil = cons x $ foldr ($) nil $ map (\c -> go c cons) $ children x++rewrite :: Uniplate a => (a -> Maybe a) -> a -> a+rewrite f = transform g+ where+ g x = maybe x (rewrite f) (f x)++rewriteM :: (Monad m, Uniplate a) => (a -> m (Maybe a)) -> a -> m a+rewriteM f = transformM g+ where+ g x = f x >>= maybe (return x) (rewriteM f)++contexts :: Uniplate a => a -> [(a, a -> a)]+contexts a = (a, id) : f (holes a)+ where+ f xs = [ (ch2, ctx1 . ctx2)+ | (ch1, ctx1) <- xs+ , (ch2, ctx2) <- contexts ch1]++holes :: Uniplate a => a -> [(a, a -> a)]+holes a = uncurry f (uniplate a)+ where+ f [] _ = []+ f (x:xs) gen = (x, gen . (:xs)) : f xs (gen . (x:))++para :: Uniplate a => (a -> [r] -> r) -> a -> r+para f x = f x $ map (para f) $ children x+++-- Base types instances+instance Uniplate Bool where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate Char where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate Double where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate Float where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate Int where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate () where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return++-- Tuple instances+instance Uniplate (b,c) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate (b,c,d) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate (b,c,d,e) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate (b,c,d,e,f) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate (b,c,d,e,f,g) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate (b,c,d,e,f,g,h) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return++-- Parameterized type instances+instance Uniplate (Maybe a) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return+instance Uniplate (Either a b) where+ children _ = []+ context x _ = x+ descend _ = id+ descendM _ = return+ transform = id+ transformM _ = return++instance Uniplate [a] where+ children [] = []+ children (_:t) = [t]+ context _ [] = error "Generics.Deriving.Uniplate.context: empty list"+ context [] _ = []+ context (h:_) (t:_) = h:t+ descend _ [] = []+ descend f (h:t) = h:f t+ descendM _ [] = return []+ descendM f (h:t) = f t >>= \t' -> return (h:t')+ transform f [] = f []+ transform f (h:t) = f (h:transform f t)+ transformM f [] = f []+ transformM f (h:t) = transformM f t >>= \t' -> f (h:t')+
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ tests/T68Spec.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++#if __GLASGOW_HASKELL__ >= 706+{-# LANGUAGE DataKinds #-}+#endif++module T68Spec (main, spec) where++import Generics.Linear.TH+import Test.Hspec+import Data.Kind (Type)++main :: IO ()+main = hspec spec++spec :: Spec+spec = return ()++type family F68 :: Type -> Type+type instance F68 = Maybe+data T68 a = MkT68 (F68 a)+$(deriveGeneric1 ''T68)
+ tests/TypeInTypeSpec.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module TypeInTypeSpec (main, spec) where++import Test.Hspec++import Data.Proxy (Proxy(..))+import Generics.Linear.TH++import Generics.Linear (Generic1(..))++data TyCon x (a :: x) (b :: k) = TyCon k x (Proxy a) (TyCon x a b)+$(deriveGenericAnd1 ''TyCon)++data family TyFam x (a :: x) (b :: k)+data instance TyFam x (a :: x) (b :: k) = TyFam k x (Proxy a) (TyFam x a b)+$(deriveGenericAnd1 'TyFam)++gen1PolyKinds :: Generic1 f => f 'True -> Rep1 f 'True+gen1PolyKinds = from1++main :: IO ()+main = hspec spec++spec :: Spec+spec = parallel $ do+ describe "TyCon Bool 'False 'True" $+ it "has an appropriately kinded Generic1 instance" $+ let rep :: Rep1 (TyCon Bool 'False) 'True+ rep = gen1PolyKinds $ let x = TyCon True False Proxy x in x+ in seq rep () `shouldBe` ()+ describe "TyFam Bool 'False 'True" $+ it "has an appropriately kinded Generic1 instance" $+ let rep :: Rep1 (TyFam Bool 'False) 'True+ rep = gen1PolyKinds $ let x = TyFam True False Proxy x in x+ in seq rep () `shouldBe` ()