diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,2 @@ +# 0.1.0.0 +* Initial fork from `generic-deriving`. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,62 @@ +## `linear-generics`: Generic programming library with linearity support +[![Hackage](https://img.shields.io/hackage/v/linear-generics.svg)][Hackage: linear-generics] +[![Hackage Dependencies](https://img.shields.io/hackage-deps/v/linear-generics.svg)](http://packdeps.haskellers.com/reverse/linear-generics) +[![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)][Haskell.org] +[![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)][tl;dr Legal: BSD3] +[![Build Status](https://github.com/dreixel/linear-generics/workflows/Haskell-CI/badge.svg)](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`. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple + +main :: IO () +main = defaultMain diff --git a/linear-generics.cabal b/linear-generics.cabal new file mode 100644 --- /dev/null +++ b/linear-generics.cabal @@ -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 + + 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 + , + and it is + . + A smaller change, approximately + , + 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 + + 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 diff --git a/src/Generics/Linear.hs b/src/Generics/Linear.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Linear.hs @@ -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 () diff --git a/src/Generics/Linear/Class.hs b/src/Generics/Linear/Class.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Linear/Class.hs @@ -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 diff --git a/src/Generics/Linear/Instances.hs b/src/Generics/Linear/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Linear/Instances.hs @@ -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 () diff --git a/src/Generics/Linear/Instances/Base.hs b/src/Generics/Linear/Instances/Base.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Linear/Instances/Base.hs @@ -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) diff --git a/src/Generics/Linear/Instances/Containers.hs b/src/Generics/Linear/Instances/Containers.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Linear/Instances/Containers.hs @@ -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) diff --git a/src/Generics/Linear/Instances/Linear_generics.hs b/src/Generics/Linear/Instances/Linear_generics.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Linear/Instances/Linear_generics.hs @@ -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 ''(:.:)) diff --git a/src/Generics/Linear/Instances/Template_haskell.hs b/src/Generics/Linear/Instances/Template_haskell.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Linear/Instances/Template_haskell.hs @@ -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 diff --git a/src/Generics/Linear/TH.hs b/src/Generics/Linear/TH.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Linear/TH.hs @@ -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! +-} diff --git a/src/Generics/Linear/TH/Insertions.hs b/src/Generics/Linear/TH/Insertions.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Linear/TH/Insertions.hs @@ -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 #-} diff --git a/src/Generics/Linear/TH/Internal.hs b/src/Generics/Linear/TH/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Linear/TH/Internal.hs @@ -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. ) +-- 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" diff --git a/src/Generics/Linear/TH/MetaData.hs b/src/Generics/Linear/TH/MetaData.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Linear/TH/MetaData.hs @@ -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 diff --git a/src/Generics/Linear/Unsafe/ViaGHCGenerics.hs b/src/Generics/Linear/Unsafe/ViaGHCGenerics.hs new file mode 100644 --- /dev/null +++ b/src/Generics/Linear/Unsafe/ViaGHCGenerics.hs @@ -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 +-- +-- 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 diff --git a/tests/DefaultSpec.hs b/tests/DefaultSpec.hs new file mode 100644 --- /dev/null +++ b/tests/DefaultSpec.hs @@ -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 () diff --git a/tests/EmptyCaseSpec.hs b/tests/EmptyCaseSpec.hs new file mode 100644 --- /dev/null +++ b/tests/EmptyCaseSpec.hs @@ -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 () diff --git a/tests/ExampleSpec.hs b/tests/ExampleSpec.hs new file mode 100644 --- /dev/null +++ b/tests/ExampleSpec.hs @@ -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)" diff --git a/tests/Examples.hs b/tests/Examples.hs new file mode 100644 --- /dev/null +++ b/tests/Examples.hs @@ -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 diff --git a/tests/Generics/Deriving/ConNames.hs b/tests/Generics/Deriving/ConNames.hs new file mode 100644 --- /dev/null +++ b/tests/Generics/Deriving/ConNames.hs @@ -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) diff --git a/tests/Generics/Deriving/Copoint.hs b/tests/Generics/Deriving/Copoint.hs new file mode 100644 --- /dev/null +++ b/tests/Generics/Deriving/Copoint.hs @@ -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 diff --git a/tests/Generics/Deriving/Default.hs b/tests/Generics/Deriving/Default.hs new file mode 100644 --- /dev/null +++ b/tests/Generics/Deriving/Default.hs @@ -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 +-- @@ +-- 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 +-- @@ +-- extension. However, only one default can be provided! With +-- @@ +-- 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 +-- @@ +-- 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 diff --git a/tests/Generics/Deriving/Enum.hs b/tests/Generics/Deriving/Enum.hs new file mode 100644 --- /dev/null +++ b/tests/Generics/Deriving/Enum.hs @@ -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 diff --git a/tests/Generics/Deriving/Eq.hs b/tests/Generics/Deriving/Eq.hs new file mode 100644 --- /dev/null +++ b/tests/Generics/Deriving/Eq.hs @@ -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 diff --git a/tests/Generics/Deriving/Foldable.hs b/tests/Generics/Deriving/Foldable.hs new file mode 100644 --- /dev/null +++ b/tests/Generics/Deriving/Foldable.hs @@ -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 []) diff --git a/tests/Generics/Deriving/Functor.hs b/tests/Generics/Deriving/Functor.hs new file mode 100644 --- /dev/null +++ b/tests/Generics/Deriving/Functor.hs @@ -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 diff --git a/tests/Generics/Deriving/Monoid.hs b/tests/Generics/Deriving/Monoid.hs new file mode 100644 --- /dev/null +++ b/tests/Generics/Deriving/Monoid.hs @@ -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 diff --git a/tests/Generics/Deriving/Monoid/Internal.hs b/tests/Generics/Deriving/Monoid/Internal.hs new file mode 100644 --- /dev/null +++ b/tests/Generics/Deriving/Monoid/Internal.hs @@ -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) diff --git a/tests/Generics/Deriving/Semigroup.hs b/tests/Generics/Deriving/Semigroup.hs new file mode 100644 --- /dev/null +++ b/tests/Generics/Deriving/Semigroup.hs @@ -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 diff --git a/tests/Generics/Deriving/Semigroup/Internal.hs b/tests/Generics/Deriving/Semigroup/Internal.hs new file mode 100644 --- /dev/null +++ b/tests/Generics/Deriving/Semigroup/Internal.hs @@ -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) diff --git a/tests/Generics/Deriving/Show.hs b/tests/Generics/Deriving/Show.hs new file mode 100644 --- /dev/null +++ b/tests/Generics/Deriving/Show.hs @@ -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 diff --git a/tests/Generics/Deriving/Traversable.hs b/tests/Generics/Deriving/Traversable.hs new file mode 100644 --- /dev/null +++ b/tests/Generics/Deriving/Traversable.hs @@ -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 diff --git a/tests/Generics/Deriving/TraversableConf.hs b/tests/Generics/Deriving/TraversableConf.hs new file mode 100644 --- /dev/null +++ b/tests/Generics/Deriving/TraversableConf.hs @@ -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 diff --git a/tests/Generics/Deriving/Uniplate.hs b/tests/Generics/Deriving/Uniplate.hs new file mode 100644 --- /dev/null +++ b/tests/Generics/Deriving/Uniplate.hs @@ -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') + diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tests/T68Spec.hs b/tests/T68Spec.hs new file mode 100644 --- /dev/null +++ b/tests/T68Spec.hs @@ -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) diff --git a/tests/TypeInTypeSpec.hs b/tests/TypeInTypeSpec.hs new file mode 100644 --- /dev/null +++ b/tests/TypeInTypeSpec.hs @@ -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` ()