rank2classes-1.5.3.1/0000755000000000000000000000000007346545000012443 5ustar0000000000000000rank2classes-1.5.3.1/CHANGELOG.md0000644000000000000000000001011207346545000014247 0ustar0000000000000000Version 1.5.3.1 --------------- * Bumped the upper bound of the `template-haskell` dependency. Version 1.5.3 --------------- * Fixed compilation with GHC 9.8.1 and `template-haskell` 2.22 Version 1.5.2 --------------- * Fixed the generated TH instance contexts for GADTs. * Fixed the generated signature of the `deliver` instance method in presence of `InstanceSigs`. * Bumped the upper bound of the `template-haskell` dependency. Version 1.5.1 --------------- * Fixed the `Rank2.TH` templates on GHC < 9.2 with no `OverloadedRecordDot` support to revert to their 1.4.6 behaviour. Version 1.5 --------------- * The `Rank2.TH` templates have changed, are now applicable with `DuplicateRecordFields` provided that `OverloadedRecordDot` is enabled. * `Rank2.TH.deriveLogistic` also needs `ScopedTypeVariables` and `InstanceSigs` extensions to generate proper record updates. Version 1.4.6 --------------- * Added the `Logistic` type class, `getters` and `setters` * Added `Rank2.TH.deriveLogistic`, included it in `deriveAll` * Compiling with GHC 9.4.2 * Forward compatibility with `TypeFamilies` Version 1.4.4 --------------- * Tested with GHC 9.2.1, incremented the upper `template-haskell` dependency bound * Generalized the TH generation to handle PolyRec types * Incremented the lower bound of rank2classes' `base` dependency, thanks to phadej Version 1.4.3 --------------- * Fixed links to standard rank-1 classes in Haddock documentation * Fixed issue #23 with the `traverse` template generated for sum types with a fieldless constructor * Incremented upper dependency bounds Version 1.4.2 --------------- * Fixed compatibility with GHC 9 - PR by Felix Yan Version 1.4.1 --------------- * Fixed the templates for multi-constructor records * Made Rank2.TH.unsafeDeriveApply even more unsafe Version 1.4 --------------- * Added Rank2.Compose :: ((* -> *) -> *) -> (* -> *) -> ((* -> *) -> *) * Matched the precedence of <$> and <*> operators with Prelude * Relaxed the lower bound of base dependency to 4.10 Version 1.3.2.1 --------------- * Incremented the upper bound of the template-haskell dependency Version 1.3.2 --------------- * Exported the `$` synonym for `apply` Version 1.3.1.2 --------------- * Fixed doctest module name issue * Incremented the lower bound of base dependency Version 1.3.1.1 --------------- * Fixed the doctests after cabal get Version 1.3.1 --------------- * Added missing markdown-unlit dependency * Strictified one argument of Rank2.<$> and Rank2.<*> Version 1.3 --------------- * Added `newtype Flip` to exports - PR by Jeremy List * Generating INLINE pragmas from Rank2.TH * Generating the proper constraints on derived instances where needed Version 1.2.1 --------------- * Added unsafeDeriveApply Version 1.2 --------------- * Added the class instances for Data.Functor.Const * Fixed and optimized the Foldable/Traversable instance code generated for bare fields in Rank2.TH Version 1.1 --------------- * Replaced own `Product` data type by the one from `Data.Functor.Product` * Added instances of `Data.Functor.Sum` * Removed the TH generation of partial Apply and Distributive instances * Covered more constructor cases in TH code * Added use-template-haskell flag, true by default - PR by Dridus Version 1.0.2 --------------- * Fixed the bounds and `Semigroup` to compile with GHC 8.4.1 * Added the ~> type synonym * Fixed `deriveFunctor` for record fields with concrete types - PR by Tom Smalley Version 1.0.1 --------------- * Fixed the doctests Version 1.0 --------------- * Swapped `distributeWith` with `cotraverse` * Documentation improvements Version 0.2.1.1 --------------- * Corrected the README Version 0.2.1 --------------- * Incremented the dependency bounds for GHC 8.2.1 Version 0.2 --------------- * Introduced `DistributiveTraversable` as a generalization of `Distributive` * Export "cotraverse" and "cotraverseTraversable" * Added `liftA3`, `liftA4`, `liftA5` * Added more convienence functions * Fixed grammatical errors and overlong lines Version 0.1.1 --------------- * Generalized the classes with `{-# LANGUAGE PolyKinds" #-}` Version 0.1 --------------- * Initial release rank2classes-1.5.3.1/LICENSE0000644000000000000000000000243207346545000013451 0ustar0000000000000000Copyright (c) 2016, Mario Blažević 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. 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. rank2classes-1.5.3.1/README.md0000644000000000000000000002172707346545000013733 0ustar0000000000000000Rank 2 Classes ============== ### The standard constructor type classes in the parallel rank-2 universe ### The rank2 package exports module `Rank2`, meant to be imported qualified like this: ~~~ {.haskell} {-# LANGUAGE RankNTypes, TemplateHaskell, TypeOperators #-} module MyModule where import qualified Rank2 import qualified Rank2.TH ~~~ Several more imports for the examples... ~~~ {.haskell} import Data.Functor.Classes (Show1, showsPrec1) import Data.Functor.Identity (Identity(..)) import Data.Functor.Const (Const(..)) import Data.List (find) ~~~ The `Rank2` import will make available the following type classes: * [Rank2.Functor](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Functor) * [Rank2.Apply](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Apply) * [Rank2.Applicative](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Applicative) * [Rank2.Foldable](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Foldable) * [Rank2.Traversable](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Traversable) * [Rank2.Distributive](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Distributive) * [Rank2.Logistic](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Logistic) The methods of these type classes all have rank-2 types. The class instances are data types of kind `(k -> *) -> *`, one example of which would be a database record with different field types but all wrapped by the same type constructor: ~~~ {.haskell} data Person f = Person{ name :: f String, age :: f Int, mother, father :: f (Maybe PersonVerified) } ~~~ By wrapping each field we have declared a generalized record type. It can made to play different roles by switching the value of the parameter `f`. Some examples would be ~~~ {.haskell} type PersonVerified = Person Identity type PersonText = Person (Const String) type PersonWithErrors = Person (Either String) type PersonDatabase = [PersonVerified] type PersonDatabaseByColumns = Person [] ~~~ If you wish to have the standard [Eq](http://hackage.haskell.org/package/base/docs/Data-Eq.html#t:Eq) and [Show](http://hackage.haskell.org/package/base/docs/Text-Show.html#t:Show) instances for a record type like `Person`, it's best if they refer to the [Eq1](http://hackage.haskell.org/package/base-4.9.1.0/docs/Data-Functor-Classes.html#t:Eq1) and [Show1](http://hackage.haskell.org/package/base-4.9.1.0/docs/Data-Functor-Classes.html#t:Show1) instances for its parameter `f`: ~~~ {.haskell} instance Show1 f => Show (Person f) where showsPrec prec person rest = "Person{" ++ separator ++ "name=" ++ showsPrec1 prec' (name person) ("," ++ separator ++ "age=" ++ showsPrec1 prec' (age person) ("," ++ separator ++ "mother=" ++ showsPrec1 prec' (mother person) ("," ++ separator ++ "father=" ++ showsPrec1 prec' (father person) ("}" ++ rest)))) where prec' = succ prec separator = "\n" ++ replicate prec' ' ' ~~~ You can create the rank-2 class instances for your data types manually, or you can generate the instances using the templates imported from the `Rank2.TH` module with a single line of code per data type: ~~~ {.haskell} $(Rank2.TH.deriveAll ''Person) ~~~ Either way, once you have the rank-2 type class instances, you can use them to easily convert between records with different parameters `f`. ### Record construction and modification examples ### In case of our `Person` record, a couple of helper functions will prove handy: ~~~ {.haskell} findPerson :: PersonDatabase -> String -> Maybe PersonVerified findPerson db nameToFind = find ((nameToFind ==) . runIdentity . name) db personByName :: PersonDatabase -> String -> Either String (Maybe PersonVerified) personByName db personName | null personName = Right Nothing | p@Just{} <- findPerson db personName = Right p | otherwise = Left ("Nobody by name of " ++ personName) ~~~ Now we can start by constructing a `Person` record with rank-2 functions for fields. This record is not so much a person as a field-by-field person verifier: ~~~ {.haskell} personChecker :: PersonDatabase -> Person (Const String Rank2.~> Either String) personChecker db = Person{name= Rank2.Arrow (Right . getConst), age= Rank2.Arrow $ \(Const age)-> case reads age of [(n, "")] -> Right n _ -> Left (age ++ " is not an integer"), mother= Rank2.Arrow (personByName db . getConst), father= Rank2.Arrow (personByName db . getConst)} ~~~ We can apply it using the [Rank2.<*>](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#v:-60--42--62-) method of the [Rank2.Apply](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Apply) type class to a bunch of textual fields for `Person`, and get back either errors or proper field values: ~~~ {.haskell} verify :: PersonDatabase -> PersonText -> PersonWithErrors verify db person = personChecker db Rank2.<*> person ~~~ If there are no errors, we can get a fully verified record by applying [Rank2.traverse](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#v:traverse) to the result: ~~~ {.haskell} completeVerified :: PersonWithErrors -> Either String PersonVerified completeVerified = Rank2.traverse (Identity <$>) ~~~ or we can go in the opposite direction with [Rank2.<$>](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#v:-60--36--62-): ~~~ {.haskell} uncompleteVerified :: PersonVerified -> PersonWithErrors uncompleteVerified = Rank2.fmap (Right . runIdentity) ~~~ If on the other hand there *are* errors, we can collect them using [Rank2.foldMap](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#v:foldMap): ~~~ {.haskell} verificationErrors :: PersonWithErrors -> [String] verificationErrors = Rank2.foldMap (either (:[]) (const [])) ~~~ Here is an example GHCi session: ~~~ {.haskell} -- | -- >>> :{ --let Right alice = completeVerified $ -- verify [] Person{name= Const "Alice", age= Const "44", -- mother= Const "", father= Const ""} -- Right bob = completeVerified $ -- verify [] Person{name= Const "Bob", age= Const "45", -- mother= Const "", father= Const ""} -- Right charlie = completeVerified $ -- verify [alice, bob] Person{name= Const "Charlie", age= Const "19", -- mother= Const "Alice", father= Const "Bob"} -- :} -- -- >>> charlie -- Person{ -- name=Identity "Charlie", -- age=Identity 19, -- mother=Identity (Just Person{ -- name=(Identity "Alice"), -- age=(Identity 44), -- mother=(Identity Nothing), -- father=(Identity Nothing)}), -- father=Identity (Just Person{ -- name=(Identity "Bob"), -- age=(Identity 45), -- mother=(Identity Nothing), -- father=(Identity Nothing)})} -- >>> :{ --let dave = verify [alice, bob, charlie] -- Person{name= Const "Dave", age= Const "young", -- mother= Const "Lise", father= Const "Mike"} -- :} -- -- >>> dave -- Person{ -- name=Right "Dave", -- age=Left "young is not an integer", -- mother=Left "Nobody by name of Lise", -- father=Left "Nobody by name of Mike"} -- >>> completeVerified dave -- Left "young is not an integer" -- >>> verificationErrors dave -- ["young is not an integer","Nobody by name of Lise","Nobody by name of Mike"] -- >>> Rank2.distribute [alice, bob, charlie] -- Person{ -- name=Compose [Identity "Alice",Identity "Bob",Identity "Charlie"], -- age=Compose [Identity 44,Identity 45,Identity 19], -- mother=Compose [Identity Nothing,Identity Nothing,Identity (Just Person{ -- name=(Identity "Alice"), -- age=(Identity 44), -- mother=(Identity Nothing), -- father=(Identity Nothing)})], -- father=Compose [Identity Nothing,Identity Nothing,Identity (Just Person{ -- name=(Identity "Bob"), -- age=(Identity 45), -- mother=(Identity Nothing), -- father=(Identity Nothing)})]} ~~~ ### Related works ### This package is one of several implementations of a pattern that is often called *Higher-Kinded Data*. Other examples include [hkd-lens](https://hackage.haskell.org/package/hkd-lens), [barbies](https://hackage.haskell.org/package/barbies), and [higgledy](https://hackage.haskell.org/package/higgledy). Grammars are another use case that is almost, but not quite, entirely unlike database records. See [grammatical-parsers](https://github.com/blamario/grampa/tree/master/grammatical-parsers) or [construct](https://hackage.haskell.org/package/construct) for examples. Both database records and grammars are flat structures. If your use case involves trees of rank-2 records, this package will probably not suffice. Consider using [deep-transformations](https://hackage.haskell.org/package/deep-transformations) instead. rank2classes-1.5.3.1/Setup.hs0000644000000000000000000000021007346545000014070 0ustar0000000000000000module Main where import Distribution.Extra.Doctest (defaultMainWithDoctests) main :: IO () main = defaultMainWithDoctests "doctests" rank2classes-1.5.3.1/rank2classes.cabal0000644000000000000000000000524607346545000016031 0ustar0000000000000000name: rank2classes version: 1.5.3.1 synopsis: standard type constructor class hierarchy, only with methods of rank 2 types description: A mirror image of the standard type constructor class hierarchy rooted in 'Functor', except with methods of rank 2 types and class instances of kind @(k->*)->*@. The classes enable generic handling of heterogenously typed data structures and other neat tricks. homepage: https://github.com/blamario/grampa/tree/master/rank2classes bug-reports: https://github.com/blamario/grampa/issues license: BSD3 license-file: LICENSE author: Mario Blažević maintainer: Mario Blažević copyright: (c) 2017 Mario Blažević category: Control, Data, Generics build-type: Custom cabal-version: >=1.10 tested-with: GHC==9.2.2, GHC==9.0.1, GHC==8.10.4, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2 extra-source-files: README.md, CHANGELOG.md, test/MyModule.lhs source-repository head type: git location: https://github.com/blamario/grampa custom-setup setup-depends: base >= 4 && <5, Cabal < 4, cabal-doctest >= 1 && <1.1 flag use-template-haskell description: Enable the compilation of the Rank2.TH module default: True manual: True library hs-source-dirs: src exposed-modules: Rank2 default-language: Haskell2010 -- other-modules: ghc-options: -Wall build-depends: base >=4.10 && <5, transformers >= 0.5 && < 0.7, distributive < 0.7, data-functor-logistic < 0.1 if flag(use-template-haskell) build-depends: template-haskell >= 2.11 && < 2.23 exposed-modules: Rank2.TH test-suite doctests type: exitcode-stdio-1.0 hs-source-dirs: test default-language: Haskell2010 main-is: Doctest.hs other-modules: MyModule ghc-options: -threaded -pgmL markdown-unlit build-depends: base, rank2classes, doctest >= 0.8 build-tool-depends: markdown-unlit:markdown-unlit >= 0.5 && < 0.6 test-suite TH if !flag(use-template-haskell) buildable: False type: exitcode-stdio-1.0 hs-source-dirs: test default-language: Haskell2010 main-is: TH.hs other-modules: Issue23 ghc-options: -threaded -pgmL markdown-unlit build-depends: base, rank2classes, distributive < 0.7, tasty < 2, tasty-hunit < 1, data-functor-logistic < 0.1 build-tool-depends: markdown-unlit:markdown-unlit >= 0.5 && < 0.6 rank2classes-1.5.3.1/src/0000755000000000000000000000000007346545000013232 5ustar0000000000000000rank2classes-1.5.3.1/src/Rank2.hs0000644000000000000000000005621707346545000014556 0ustar0000000000000000-- | Import this module qualified, like this: -- -- > import qualified Rank2 -- -- This will bring into scope the standard classes 'Functor', 'Applicative', 'Foldable', and 'Traversable', but with a -- @Rank2.@ prefix and a twist that their methods operate on a heterogenous collection. The same property is shared by -- the less standard classes 'Apply', 'Distributive', and 'Logistic'. {-# LANGUAGE DefaultSignatures, InstanceSigs, KindSignatures, PolyKinds, Rank2Types #-} {-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE TypeApplications #-} module Rank2 ( -- * Rank 2 classes Functor(..), Apply(..), Applicative(..), Foldable(..), Traversable(..), Distributive(..), DistributiveTraversable(..), Logistic(..), distributeJoin, -- * Rank 2 data types Compose(..), Empty(..), Only(..), Flip(..), Identity(..), Product(..), Sum(..), Arrow(..), type (~>), -- * Method synonyms and helper functions ($), fst, snd, ap, fmap, liftA4, liftA5, fmapTraverse, liftA2Traverse1, liftA2Traverse2, liftA2TraverseBoth, distributeWith, distributeWithTraversable, getters, setters) where import qualified Control.Applicative as Rank1 import qualified Control.Monad as Rank1 import qualified Data.Foldable as Rank1 import qualified Data.Traversable as Rank1 import qualified Data.Functor.Compose as Rank1 import qualified Data.Functor.Contravariant as Rank1 import qualified Data.Functor.Logistic as Rank1 import qualified Data.Distributive as Rank1 import Data.Coerce (coerce) import Data.Semigroup (Semigroup(..)) import Data.Monoid (Monoid(..)) import Data.Functor.Const (Const(..)) import Data.Functor.Product (Product(Pair)) import Data.Functor.Sum (Sum(InL, InR)) import Data.Kind (Type) import Data.Proxy (Proxy(..)) import qualified GHC.Generics as Generics import Prelude hiding (Foldable(..), Traversable(..), Functor(..), Applicative(..), ($), (<$>), fst, snd) -- | Helper function for accessing the first field of a 'Pair' fst :: Product g h p -> g p fst (Pair x _) = x -- | Helper function for accessing the second field of a 'Pair' snd :: Product g h p -> h p snd (Pair _ y) = y -- | Equivalent of 'Rank1.Functor' for rank 2 data types, satisfying the usual functor laws -- -- > id <$> g == g -- > (p . q) <$> g == p <$> (q <$> g) class Functor g where (<$>) :: (forall a. p a -> q a) -> g p -> g q infixl 4 <$> -- | Alphabetical synonym for '<$>' fmap :: Functor g => (forall a. p a -> q a) -> g p -> g q fmap f g = f <$> g {-# INLINE fmap #-} -- | Equivalent of 'Rank1.Foldable' for rank 2 data types class Foldable g where foldMap :: Monoid m => (forall a. p a -> m) -> g p -> m -- | Equivalent of 'Rank1.Traversable' for rank 2 data types class (Functor g, Foldable g) => Traversable g where {-# MINIMAL traverse | sequence #-} traverse :: Rank1.Applicative m => (forall a. p a -> m (q a)) -> g p -> m (g q) sequence :: Rank1.Applicative m => g (Rank1.Compose m p) -> m (g p) traverse f = sequence . fmap (Rank1.Compose . f) sequence = traverse Rank1.getCompose -- | Wrapper for functions that map the argument constructor type newtype Arrow p q a = Arrow{apply :: p a -> q a} type (~>) = Arrow ($) :: Arrow p q a -> p a -> q a ($) = apply infixr 0 ~> infixr 0 $ -- | Subclass of 'Functor' halfway to 'Applicative', satisfying -- -- > (.) <$> u <*> v <*> w == u <*> (v <*> w) class Functor g => Apply g where {-# MINIMAL liftA2 | (<*>) #-} -- | Equivalent of 'Rank1.<*>' for rank 2 data types (<*>) :: g (p ~> q) -> g p -> g q -- | Equivalent of 'Rank1.liftA2' for rank 2 data types liftA2 :: (forall a. p a -> q a -> r a) -> g p -> g q -> g r -- | Equivalent of 'Rank1.liftA3' for rank 2 data types liftA3 :: (forall a. p a -> q a -> r a -> s a) -> g p -> g q -> g r -> g s (<*>) = liftA2 apply liftA2 f g h = (Arrow . f) <$> g <*> h liftA3 f g h i = liftA2 (\p q-> Arrow (f p q)) g h <*> i infixl 4 <*> liftA4 :: Apply g => (forall a. p a -> q a -> r a -> s a -> t a) -> g p -> g q -> g r -> g s -> g t liftA4 f g h i j = liftA3 (\p q r-> Arrow (f p q r)) g h i <*> j liftA5 :: Apply g => (forall a. p a -> q a -> r a -> s a -> t a -> u a) -> g p -> g q -> g r -> g s -> g t -> g u liftA5 f g1 g2 g3 g4 g5 = liftA4 (\p q r s-> Arrow (f p q r s)) g1 g2 g3 g4 <*> g5 -- | Alphabetical synonym for '<*>' ap :: Apply g => g (p ~> q) -> g p -> g q ap = (<*>) -- | Equivalent of 'Rank1.Applicative' for rank 2 data types class Apply g => Applicative g where pure :: (forall a. f a) -> g f -- | Equivalent of 'Rank1.Distributive' for rank 2 data types class DistributiveTraversable g => Distributive g where {-# MINIMAL cotraverse|distribute #-} collect :: Rank1.Functor p => (a -> g q) -> p a -> g (Rank1.Compose p q) distribute :: Rank1.Functor p => p (g q) -> g (Rank1.Compose p q) -- | Dual of 'traverse', equivalent of 'Rank1.cotraverse' for rank 2 data types cotraverse :: Rank1.Functor m => (forall a. m (p a) -> q a) -> m (g p) -> g q collect f = distribute . Rank1.fmap f distribute = cotraverse Rank1.Compose cotraverse f = fmap (f . Rank1.getCompose) . distribute -- | A weaker 'Distributive' that requires 'Rank1.Traversable' to use, not just a 'Rank1.Functor'. class Functor g => DistributiveTraversable (g :: (k -> Type) -> Type) where collectTraversable :: Rank1.Traversable f1 => (a -> g f2) -> f1 a -> g (Rank1.Compose f1 f2) distributeTraversable :: Rank1.Traversable f1 => f1 (g f2) -> g (Rank1.Compose f1 f2) cotraverseTraversable :: Rank1.Traversable f1 => (forall x. f1 (f2 x) -> f x) -> f1 (g f2) -> g f collectTraversable f = distributeTraversable . Rank1.fmap f distributeTraversable = cotraverseTraversable Rank1.Compose default cotraverseTraversable :: (Rank1.Traversable m, Distributive g) => (forall a. m (p a) -> q a) -> m (g p) -> g q cotraverseTraversable = cotraverse -- | Equivalent of 'Rank1.Logistic' for rank 2 data types class Functor g => Logistic g where deliver :: Rank1.Contravariant p => p (g q -> g q) -> g (Rank1.Compose p (q ~> q)) -- | A variant of 'distribute' convenient with 'Rank1.Monad' instances distributeJoin :: (Distributive g, Rank1.Monad f) => f (g f) -> g f distributeJoin = cotraverse Rank1.join -- | Like 'fmap', but traverses over its argument fmapTraverse :: (DistributiveTraversable g, Rank1.Traversable f) => (forall a. f (t a) -> u a) -> f (g t) -> g u fmapTraverse f x = fmap (f . Rank1.getCompose) (distributeTraversable x) -- | Like 'liftA2', but traverses over its first argument liftA2Traverse1 :: (Apply g, DistributiveTraversable g, Rank1.Traversable f) => (forall a. f (t a) -> u a -> v a) -> f (g t) -> g u -> g v liftA2Traverse1 f x = liftA2 (f . Rank1.getCompose) (distributeTraversable x) -- | Like 'liftA2', but traverses over its second argument liftA2Traverse2 :: (Apply g, DistributiveTraversable g, Rank1.Traversable f) => (forall a. t a -> f (u a) -> v a) -> g t -> f (g u) -> g v liftA2Traverse2 f x y = liftA2 (\x' y' -> f x' (Rank1.getCompose y')) x (distributeTraversable y) -- | Like 'liftA2', but traverses over both its arguments liftA2TraverseBoth :: forall f1 f2 g t u v. (Apply g, DistributiveTraversable g, Rank1.Traversable f1, Rank1.Traversable f2) => (forall a. f1 (t a) -> f2 (u a) -> v a) -> f1 (g t) -> f2 (g u) -> g v liftA2TraverseBoth f x y = liftA2 applyCompose (distributeTraversable x) (distributeTraversable y) where applyCompose :: forall a. Rank1.Compose f1 t a -> Rank1.Compose f2 u a -> v a applyCompose x' y' = f (Rank1.getCompose x') (Rank1.getCompose y') -- | Enumerate getters for each element getters :: Distributive g => g (Rank1.Compose ((->) (g f)) f) getters = distribute id -- | Enumerate setters for each element setters :: Logistic g => g ((f ~> f) ~> Const (g f -> g f)) setters = Arrow . (Const .) . Rank1.getOp . Rank1.getCompose <$> deliver (Rank1.Op id) {-# DEPRECATED distributeWith "Use cotraverse instead." #-} -- | Synonym for 'cotraverse' distributeWith :: (Distributive g, Rank1.Functor f) => (forall i. f (a i) -> b i) -> f (g a) -> g b distributeWith = cotraverse {-# DEPRECATED distributeWithTraversable "Use cotraverseTraversable instead." #-} -- | Synonym for 'cotraverseTraversable' distributeWithTraversable :: (DistributiveTraversable g, Rank1.Traversable m) => (forall a. m (p a) -> q a) -> m (g p) -> g q distributeWithTraversable = cotraverseTraversable -- | A rank-2 equivalent of @()@, a zero-element tuple data Empty f = Empty deriving (Eq, Ord, Show) -- | A rank-2 tuple of only one element newtype Only a f = Only {fromOnly :: f a} deriving (Eq, Ord, Show) -- | Equivalent of 'Data.Functor.Identity' for rank 2 data types newtype Identity g f = Identity {runIdentity :: g f} deriving (Eq, Ord, Show) -- | Equivalent of 'Data.Functor.Compose' for rank 2 data types newtype Compose g p q = Compose {getCompose :: g (Rank1.Compose p q)} deriving instance Eq (g (Rank1.Compose p q)) => Eq (Compose g p q) deriving instance Ord (g (Rank1.Compose p q)) => Ord (Compose g p q) deriving instance Show (g (Rank1.Compose p q)) => Show (Compose g p q) -- | A nested parametric type represented as a rank-2 type newtype Flip g a f = Flip {unFlip :: g (f a)} deriving (Eq, Ord, Show) instance Semigroup (g (f a)) => Semigroup (Flip g a f) where Flip x <> Flip y = Flip (x <> y) instance Monoid (g (f a)) => Monoid (Flip g a f) where mempty = Flip mempty mappend = (<>) instance Rank1.Functor g => Rank2.Functor (Flip g a) where f <$> Flip g = Flip (f Rank1.<$> g) instance Rank1.Applicative g => Rank2.Apply (Flip g a) where Flip g <*> Flip h = Flip (apply Rank1.<$> g Rank1.<*> h) instance Rank1.Applicative g => Rank2.Applicative (Flip g a) where pure f = Flip (Rank1.pure f) instance Rank1.Foldable g => Rank2.Foldable (Flip g a) where foldMap f (Flip g) = Rank1.foldMap f g instance Rank1.Traversable g => Rank2.Traversable (Flip g a) where traverse f (Flip g) = Flip Rank1.<$> Rank1.traverse f g instance Functor Empty where _ <$> _ = Empty instance Functor Proxy where _ <$> _ = Proxy instance Functor (Const a) where _ <$> Const a = Const a instance Functor (Only a) where f <$> Only a = Only (f a) instance Functor g => Functor (Identity g) where f <$> Identity g = Identity (f <$> g) instance (Functor g, Rank1.Functor p) => Functor (Compose g p) where (<$>) :: forall q r. (forall a. q a -> r a) -> Compose g p q -> Compose g p r f <$> Compose g = Compose (f' <$> g) where f' :: forall a. Rank1.Compose p q a -> Rank1.Compose p r a f' (Rank1.Compose q) = Rank1.Compose (f Rank1.<$> q) instance (Functor g, Functor h) => Functor (Product g h) where f <$> Pair a b = Pair (f <$> a) (f <$> b) instance (Functor g, Functor h) => Functor (Sum g h) where f <$> InL g = InL (f <$> g) f <$> InR h = InR (f <$> h) instance Functor Generics.V1 where (<$>) _ = coerce instance Functor Generics.U1 where (<$>) _ = coerce instance Functor (Generics.K1 i c) where (<$>) _ = coerce instance Functor f => Functor (Generics.M1 i c f) where f <$> Generics.M1 x = Generics.M1 (f <$> x) instance Functor f => Functor (Generics.Rec1 f) where f <$> Generics.Rec1 x = Generics.Rec1 (f <$> x) -- instance (Rank1.Functor f, Functor g) => Functor ((Generics.:.:) f g) where -- f <$> Generics.Comp1 x = Generics.Comp1 (Rank1.fmap (f <$>) x) instance (Functor f, Functor g) => Functor ((Generics.:+:) f g) where f <$> Generics.L1 x = Generics.L1 (f <$> x) f <$> Generics.R1 x = Generics.R1 (f <$> x) instance (Functor f, Functor g) => Functor ((Generics.:*:) f g) where f <$> (x Generics.:*: y) = (f <$> x) Generics.:*: (f <$> y) instance Foldable Empty where foldMap _ _ = mempty instance Foldable Proxy where foldMap _ _ = mempty instance Foldable (Const x) where foldMap _ _ = mempty instance Foldable (Only x) where foldMap f (Only x) = f x instance Foldable g => Foldable (Identity g) where foldMap f (Identity g) = foldMap f g instance (Foldable g, Rank1.Foldable p) => Foldable (Compose g p) where foldMap f (Compose g) = foldMap (Rank1.foldMap f . Rank1.getCompose) g instance (Foldable g, Foldable h) => Foldable (Product g h) where foldMap f (Pair g h) = foldMap f g `mappend` foldMap f h instance (Foldable g, Foldable h) => Foldable (Sum g h) where foldMap f (InL g) = foldMap f g foldMap f (InR h) = foldMap f h instance Foldable Generics.V1 where foldMap _ v = case v of {} instance Foldable Generics.U1 where foldMap _ _ = mempty instance Foldable (Generics.K1 i c) where foldMap _ _ = mempty instance Foldable f => Foldable (Generics.M1 i c f) where foldMap f (Generics.M1 x) = foldMap f x instance Foldable f => Foldable (Generics.Rec1 f) where foldMap f (Generics.Rec1 x) = foldMap f x instance (Foldable f, Foldable g) => Foldable ((Generics.:+:) f g) where foldMap f (Generics.L1 x) = foldMap f x foldMap f (Generics.R1 x) = foldMap f x instance (Foldable f, Foldable g) => Foldable ((Generics.:*:) f g) where foldMap f (x Generics.:*: y) = foldMap f x `mappend` foldMap f y instance Traversable Empty where traverse _ _ = Rank1.pure Empty instance Traversable Proxy where traverse _ _ = Rank1.pure Proxy instance Traversable (Const x) where traverse _ (Const x) = Rank1.pure (Const x) instance Traversable (Only x) where traverse f (Only x) = Only Rank1.<$> f x instance Traversable g => Traversable (Identity g) where traverse f (Identity g) = Identity Rank1.<$> traverse f g instance (Traversable g, Rank1.Traversable p) => Traversable (Compose g p) where traverse :: forall m q r. Rank1.Applicative m => (forall a. q a -> m (r a)) -> Compose g p q -> m (Compose g p r) traverse f (Compose g) = Compose Rank1.<$> traverse f' g where f' :: forall a. Rank1.Compose p q a -> m (Rank1.Compose p r a) f' (Rank1.Compose q) = Rank1.Compose Rank1.<$> Rank1.traverse f q instance (Traversable g, Traversable h) => Traversable (Product g h) where traverse f (Pair g h) = Rank1.liftA2 Pair (traverse f g) (traverse f h) instance (Traversable g, Traversable h) => Traversable (Sum g h) where traverse f (InL g) = InL Rank1.<$> traverse f g traverse f (InR h) = InR Rank1.<$> traverse f h instance Traversable Generics.V1 where traverse _ = Rank1.pure . coerce instance Traversable Generics.U1 where traverse _ = Rank1.pure . coerce instance Traversable (Generics.K1 i c) where traverse _ = Rank1.pure . coerce instance Traversable f => Traversable (Generics.M1 i c f) where traverse f (Generics.M1 x) = Rank1.fmap Generics.M1 (traverse f x) instance Traversable f => Traversable (Generics.Rec1 f) where traverse f (Generics.Rec1 x) = Rank1.fmap Generics.Rec1 (traverse f x) instance (Traversable f, Traversable g) => Traversable ((Generics.:+:) f g) where traverse f (Generics.L1 x) = Rank1.fmap Generics.L1 (traverse f x) traverse f (Generics.R1 x) = Rank1.fmap Generics.R1 (traverse f x) instance (Traversable f, Traversable g) => Traversable ((Generics.:*:) f g) where traverse f (x Generics.:*: y) = Rank1.liftA2 (Generics.:*:) (traverse f x) (traverse f y) instance Apply Empty where _ <*> _ = Empty liftA2 _ _ _ = Empty instance Apply Proxy where _ <*> _ = Proxy liftA2 _ _ _ = Proxy instance Semigroup x => Apply (Const x) where Const x <*> Const y = Const (x <> y) liftA2 _ (Const x) (Const y) = Const (x <> y) instance Apply (Only x) where Only f <*> Only x = Only (apply f x) liftA2 f (Only x) (Only y) = Only (f x y) instance Apply g => Apply (Identity g) where Identity g <*> Identity h = Identity (g <*> h) liftA2 f (Identity g) (Identity h) = Identity (liftA2 f g h) instance (Apply g, Rank1.Applicative p) => Apply (Compose g p) where (<*>) :: forall q r. Compose g p (q ~> r) -> Compose g p q -> Compose g p r liftA2 :: forall q r s. (forall a. q a -> r a -> s a) -> Compose g p q -> Compose g p r -> Compose g p s Compose g <*> Compose h = Compose (liftA2 f' g h) where f' :: forall a. Rank1.Compose p (q ~> r) a -> Rank1.Compose p q a -> Rank1.Compose p r a f' (Rank1.Compose f) (Rank1.Compose q) = Rank1.Compose (Rank1.liftA2 apply f q) liftA2 f (Compose g) (Compose h) = Compose (liftA2 f' g h) where f' :: forall a. Rank1.Compose p q a -> Rank1.Compose p r a -> Rank1.Compose p s a f' (Rank1.Compose q) (Rank1.Compose r) = Rank1.Compose (Rank1.liftA2 f q r) instance (Apply g, Apply h) => Apply (Product g h) where Pair gf hf <*> ~(Pair gx hx) = Pair (gf <*> gx) (hf <*> hx) liftA2 f (Pair g1 h1) ~(Pair g2 h2) = Pair (liftA2 f g1 g2) (liftA2 f h1 h2) liftA3 f (Pair g1 h1) ~(Pair g2 h2) ~(Pair g3 h3) = Pair (liftA3 f g1 g2 g3) (liftA3 f h1 h2 h3) instance Apply Generics.V1 where (<*>) _ = coerce instance Apply Generics.U1 where (<*>) _ = coerce instance Semigroup c => Apply (Generics.K1 i c) where Generics.K1 x <*> Generics.K1 y = Generics.K1 (x <> y) instance Apply f => Apply (Generics.M1 i c f) where Generics.M1 f <*> Generics.M1 x = Generics.M1 (f <*> x) instance Apply f => Apply (Generics.Rec1 f) where Generics.Rec1 f <*> Generics.Rec1 x = Generics.Rec1 (f <*> x) instance (Apply f, Apply g) => Apply ((Generics.:*:) f g) where (x1 Generics.:*: y1) <*> (x2 Generics.:*: y2) = (x1 <*> x2) Generics.:*: (y1 <*> y2) instance Applicative Empty where pure _ = Empty instance Applicative Proxy where pure _ = Proxy instance (Semigroup x, Monoid x) => Applicative (Const x) where pure _ = Const mempty instance Applicative (Only x) where pure f = Only f instance Applicative g => Applicative (Identity g) where pure f = Identity (pure f) instance (Applicative g, Rank1.Applicative p) => Applicative (Compose g p) where pure f = Compose (pure (Rank1.Compose (Rank1.pure f))) instance (Applicative g, Applicative h) => Applicative (Product g h) where pure f = Pair (pure f) (pure f) instance (Semigroup c, Monoid c) => Applicative (Generics.K1 i c) where pure _ = Generics.K1 mempty instance Applicative f => Applicative (Generics.M1 i c f) where pure f = Generics.M1 (pure f) instance Applicative f => Applicative (Generics.Rec1 f) where pure f = Generics.Rec1 (pure f) instance (Applicative f, Applicative g) => Applicative ((Generics.:*:) f g) where pure f = pure f Generics.:*: pure f instance DistributiveTraversable Empty instance DistributiveTraversable Proxy instance DistributiveTraversable (Only x) instance DistributiveTraversable g => DistributiveTraversable (Identity g) where cotraverseTraversable w f = Identity (cotraverseTraversable w (Rank1.fmap runIdentity f)) instance (DistributiveTraversable g, Rank1.Distributive p) => DistributiveTraversable (Compose g p) where cotraverseTraversable w f = Compose (cotraverseTraversable (Rank1.Compose . Rank1.fmap w . Rank1.distribute . Rank1.fmap Rank1.getCompose) (Rank1.fmap getCompose f)) instance (DistributiveTraversable g, DistributiveTraversable h) => DistributiveTraversable (Product g h) where cotraverseTraversable w f = Pair (cotraverseTraversable w (Rank1.fmap fst f)) (cotraverseTraversable w (Rank1.fmap snd f)) instance DistributiveTraversable f => DistributiveTraversable (Generics.M1 i c f) where cotraverseTraversable w f = Generics.M1 (cotraverseTraversable w (Rank1.fmap Generics.unM1 f)) instance DistributiveTraversable f => DistributiveTraversable (Generics.Rec1 f) where cotraverseTraversable w f = Generics.Rec1 (cotraverseTraversable w (Rank1.fmap Generics.unRec1 f)) instance (DistributiveTraversable f, DistributiveTraversable g) => DistributiveTraversable ((Generics.:*:) f g) where cotraverseTraversable w f = cotraverseTraversable w (Rank1.fmap (\(a Generics.:*: _) -> a) f) Generics.:*: cotraverseTraversable w (Rank1.fmap (\(_ Generics.:*: b) -> b) f) instance Distributive Empty where cotraverse _ _ = Empty instance Distributive Proxy where cotraverse _ _ = Proxy instance Monoid x => DistributiveTraversable (Const x) where cotraverseTraversable _ f = coerce (Rank1.fold f) instance Distributive (Only x) where cotraverse w f = Only (w (Rank1.fmap fromOnly f)) instance Distributive g => Distributive (Identity g) where cotraverse w f = Identity (cotraverse w (Rank1.fmap runIdentity f)) instance (Distributive g, Rank1.Distributive p) => Distributive (Compose g p) where cotraverse w f = Compose (cotraverse (Rank1.Compose . Rank1.fmap w . Rank1.distribute . Rank1.fmap Rank1.getCompose) (Rank1.fmap getCompose f)) instance (Distributive g, Distributive h) => Distributive (Product g h) where cotraverse w f = Pair (cotraverse w (Rank1.fmap fst f)) (cotraverse w (Rank1.fmap snd f)) instance Monoid c => DistributiveTraversable (Generics.K1 i c) where cotraverseTraversable _ f = coerce (Rank1.foldMap Generics.unK1 f) instance Distributive f => Distributive (Generics.M1 i c f) where cotraverse w f = Generics.M1 (cotraverse w (Rank1.fmap Generics.unM1 f)) instance Distributive f => Distributive (Generics.Rec1 f) where cotraverse w f = Generics.Rec1 (cotraverse w (Rank1.fmap Generics.unRec1 f)) instance (Distributive f, Distributive g) => Distributive ((Generics.:*:) f g) where cotraverse w f = cotraverse w (Rank1.fmap (\(a Generics.:*: _) -> a) f) Generics.:*: cotraverse w (Rank1.fmap (\(_ Generics.:*: b) -> b) f) instance Logistic Empty where deliver _ = Empty instance Logistic Proxy where deliver _ = Proxy instance Logistic (Only x) where deliver f = Only (Rank1.Compose (Rank1.contramap coerce f)) instance Logistic g => Logistic (Identity g) where deliver f = Identity (deliver (Rank1.contramap coerce f)) instance (Logistic g, Rank1.Logistic p) => Logistic (Compose g p) where deliver = Compose . fmap (inRank1Compose (Rank1.fmap (Rank1.Compose . Rank1.contramap apply) . Rank1.deliver . Rank1.contramap (Arrow . inRank1Compose))) . deliver . Rank1.contramap inCompose inCompose :: (g (Rank1.Compose p q) -> g' (Rank1.Compose p' q')) -> Compose g p q -> Compose g' p' q' inCompose f = Compose . f . getCompose inRank1Compose :: (p (q a) -> p' (q' a')) -> Rank1.Compose p q a -> Rank1.Compose p' q' a' inRank1Compose f = Rank1.Compose . f . Rank1.getCompose instance (Logistic g, Logistic h) => Logistic (Product g h) where deliver f = Pair (deliver (Rank1.contramap first f)) (deliver (Rank1.contramap second f)) first :: (g p -> g' p) -> Product g h p -> Product g' h p first f (Pair g h) = Pair (f g) h second :: (h p -> h' p) -> Product g h p -> Product g h' p second f (Pair g h) = Pair g (f h) instance Logistic f => Logistic (Generics.M1 i c f) where deliver f = Generics.M1 (deliver (Rank1.contramap (\f'-> Generics.M1 . f' . Generics.unM1) f)) instance Logistic f => Logistic (Generics.Rec1 f) where deliver f = Generics.Rec1 (deliver (Rank1.contramap (\f'-> Generics.Rec1 . f' . Generics.unRec1) f)) instance (Logistic f, Logistic g) => Logistic ((Generics.:*:) f g) where deliver f = deliver (Rank1.contramap (\f' (a Generics.:*: b) -> f' a Generics.:*: b) f) Generics.:*: deliver (Rank1.contramap (\f' (a Generics.:*: b) -> a Generics.:*: f' b) f) rank2classes-1.5.3.1/src/Rank2/0000755000000000000000000000000007346545000014207 5ustar0000000000000000rank2classes-1.5.3.1/src/Rank2/TH.hs0000644000000000000000000010556107346545000015066 0ustar0000000000000000-- | This module exports the templates for automatic instance deriving of "Rank2" type classes. The most common way to -- use it would be -- -- > import qualified Rank2.TH -- > data MyDataType f = ... -- > $(Rank2.TH.deriveAll ''MyDataType) -- -- or, if you're picky, you can invoke only 'deriveFunctor' and whichever other instances you need instead. {-# Language CPP #-} {-# Language TemplateHaskell #-} {-# Language TypeOperators #-} -- Adapted from https://wiki.haskell.org/A_practical_Template_Haskell_Tutorial module Rank2.TH (deriveAll, deriveFunctor, deriveApply, unsafeDeriveApply, deriveApplicative, deriveFoldable, deriveTraversable, deriveDistributive, deriveDistributiveTraversable, deriveLogistic) where import Control.Applicative (liftA2, liftA3) import Control.Monad (replicateM) import Data.Bifunctor (first) import Data.Distributive (cotraverse) import Data.Functor.Compose (Compose (Compose)) import Data.Functor.Contravariant (Contravariant, contramap) import qualified Language.Haskell.TH as TH import Language.Haskell.TH (Q, TypeQ, Name, TyVarBndr(KindedTV, PlainTV), Clause, Dec(..), Con(..), Type(..), Exp(..), Inline(Inlinable, Inline), RuleMatch(FunLike), Phases(AllPhases), appE, conE, conP, conT, instanceD, varE, varP, varT, normalB, pragInlD, recConE, wildP) import Language.Haskell.TH.Syntax (BangType, VarBangType, Info(TyConI), getQ, putQ, newName) import qualified Rank2 data Deriving = Deriving { _derivingConstructor :: Name, _derivingVariable :: Name } deriving Show deriveAll :: Name -> Q [Dec] deriveAll ty = foldr f (pure []) [deriveFunctor, deriveApply, deriveApplicative, deriveFoldable, deriveTraversable, deriveDistributive, deriveDistributiveTraversable, deriveLogistic] where f derive rest = (<>) <$> derive ty <*> rest deriveFunctor :: Name -> Q [Dec] deriveFunctor ty = do (instanceType, cs) <- reifyConstructors ''Rank2.Functor ty (constraints, dec) <- genFmap instanceType cs sequence [instanceD (TH.cxt $ map pure constraints) instanceType [pure dec, pragInlD '(Rank2.<$>) Inline FunLike AllPhases]] deriveApply :: Name -> Q [Dec] deriveApply ty = do (instanceType, cs) <- reifyConstructors ''Rank2.Apply ty (constraints, dec) <- genAp instanceType cs sequence [instanceD (TH.cxt $ map pure constraints) instanceType [pure dec, genLiftA2 cs, genLiftA3 cs, pragInlD '(Rank2.<*>) Inlinable FunLike AllPhases, pragInlD 'Rank2.liftA2 Inlinable FunLike AllPhases]] -- | This function always succeeds, but the methods it generates may be partial. Use with care. unsafeDeriveApply :: Name -> Q [Dec] unsafeDeriveApply ty = do (instanceType, cs) <- reifyConstructors ''Rank2.Apply ty (constraints, dec) <- genApUnsafely instanceType cs sequence [instanceD (TH.cxt $ map pure constraints) instanceType [pure dec, genLiftA2Unsafely cs, genLiftA3Unsafely cs, pragInlD '(Rank2.<*>) Inlinable FunLike AllPhases, pragInlD 'Rank2.liftA2 Inlinable FunLike AllPhases]] deriveApplicative :: Name -> Q [Dec] deriveApplicative ty = do (instanceType, cs) <- reifyConstructors ''Rank2.Applicative ty (constraints, dec) <- genPure cs sequence [instanceD (TH.cxt $ map pure constraints) instanceType [pure dec, pragInlD 'Rank2.pure Inline FunLike AllPhases]] deriveFoldable :: Name -> Q [Dec] deriveFoldable ty = do (instanceType, cs) <- reifyConstructors ''Rank2.Foldable ty (constraints, dec) <- genFoldMap instanceType cs sequence [instanceD (TH.cxt $ map pure constraints) instanceType [pure dec, pragInlD 'Rank2.foldMap Inlinable FunLike AllPhases]] deriveTraversable :: Name -> Q [Dec] deriveTraversable ty = do (instanceType, cs) <- reifyConstructors ''Rank2.Traversable ty (constraints, dec) <- genTraverse instanceType cs sequence [instanceD (TH.cxt $ map pure constraints) instanceType [pure dec, pragInlD 'Rank2.traverse Inlinable FunLike AllPhases]] deriveDistributive :: Name -> Q [Dec] deriveDistributive ty = do (instanceType, cs) <- reifyConstructors ''Rank2.Distributive ty (constraints, dec) <- genCotraverse cs sequence [instanceD (TH.cxt $ map pure constraints) instanceType [pure dec, pragInlD 'Rank2.cotraverse Inline FunLike AllPhases]] deriveDistributiveTraversable :: Name -> Q [Dec] deriveDistributiveTraversable ty = do (instanceType, cs) <- reifyConstructors ''Rank2.DistributiveTraversable ty (constraints, dec) <- genCotraverseTraversable cs sequence [instanceD (TH.cxt $ map pure constraints) instanceType [pure dec]] deriveLogistic :: Name -> Q [Dec] deriveLogistic ty = do (instanceType, cs) <- reifyConstructors ''Rank2.Logistic ty (constraints, decs) <- genDeliver instanceType cs sequence [instanceD (TH.cxt $ map pure constraints) instanceType (map pure decs <> [pragInlD 'Rank2.deliver Inline FunLike AllPhases])] reifyConstructors :: Name -> Name -> Q (TypeQ, [Con]) reifyConstructors cls ty = do (TyConI tyCon) <- TH.reify ty (tyConName, tyVars, _kind, cs) <- case tyCon of DataD _ nm tyVars kind cs _ -> return (nm, tyVars, kind, cs) NewtypeD _ nm tyVars kind c _ -> return (nm, tyVars, kind, [c]) _ -> fail "deriveApply: tyCon may not be a type synonym." let reifySynonyms (ConT name) = TH.reify name >>= reifySynonymInfo name reifySynonyms (AppT t1 t2) = AppT <$> reifySynonyms t1 <*> reifySynonyms t2 reifySynonyms t = pure t reifySynonymInfo _ (TyConI (TySynD _ [] t)) = reifySynonyms t reifySynonymInfo name _ = pure (ConT name) #if MIN_VERSION_template_haskell(2,17,0) reifyTVKindSynonyms (KindedTV v s k) = KindedTV v s <$> reifySynonyms k #else reifyTVKindSynonyms (KindedTV v k) = KindedTV v <$> reifySynonyms k #endif reifyTVKindSynonyms tv = pure tv lastVar <- reifyTVKindSynonyms (last tyVars) #if MIN_VERSION_template_haskell(2,17,0) let (KindedTV tyVar _ (AppT (AppT ArrowT _) resultKind)) = lastVar instanceType = conT cls `TH.appT` foldl apply (conT tyConName) (init tyVars) apply t (PlainTV name _) = TH.appT t (varT name) apply t (KindedTV name _ _) = TH.appT t (varT name) #else let (KindedTV tyVar (AppT (AppT ArrowT _) resultKind)) = lastVar instanceType = conT cls `TH.appT` foldl apply (conT tyConName) (init tyVars) apply t (PlainTV name) = TH.appT t (varT name) apply t (KindedTV name _) = TH.appT t (varT name) #endif case resultKind of StarT -> pure () _ -> fail ("Unexpected result kind: " <> show resultKind) putQ (Deriving tyConName tyVar) return (instanceType, cs) genFmap :: TypeQ -> [Con] -> Q ([Type], Dec) genFmap instanceType cs = do it <- instanceType (constraints, clauses) <- unzip <$> mapM (genFmapClause it) cs return (concat constraints, FunD '(Rank2.<$>) clauses) genAp :: TypeQ -> [Con] -> Q ([Type], Dec) genAp instanceType [con] = do it <- instanceType (constraints, clause) <- genApClause False it con return (constraints, FunD '(Rank2.<*>) [clause]) genLiftA2 :: [Con] -> Q Dec genLiftA2 [con] = TH.funD 'Rank2.liftA2 [genLiftA2Clause False con] genLiftA3 :: [Con] -> Q Dec genLiftA3 [con] = TH.funD 'Rank2.liftA3 [genLiftA3Clause False con] genApUnsafely :: TypeQ -> [Con] -> Q ([Type], Dec) genApUnsafely instanceType cons = do it <- instanceType (constraints, clauses) <- unzip <$> mapM (genApClause True it) cons return (concat constraints, FunD '(Rank2.<*>) clauses) genLiftA2Unsafely :: [Con] -> Q Dec genLiftA2Unsafely cons = TH.funD 'Rank2.liftA2 (genLiftA2Clause True <$> cons) genLiftA3Unsafely :: [Con] -> Q Dec genLiftA3Unsafely cons = TH.funD 'Rank2.liftA3 (genLiftA3Clause True <$> cons) genPure :: [Con] -> Q ([Type], Dec) genPure cs = do (constraints, clauses) <- unzip <$> mapM genPureClause cs return (concat constraints, FunD 'Rank2.pure clauses) genFoldMap :: TypeQ -> [Con] -> Q ([Type], Dec) genFoldMap instanceType cs = do it <- instanceType (constraints, clauses) <- unzip <$> mapM (genFoldMapClause it) cs return (concat constraints, FunD 'Rank2.foldMap clauses) genTraverse :: TypeQ -> [Con] -> Q ([Type], Dec) genTraverse instanceType cs = do it <- instanceType (constraints, clauses) <- unzip <$> mapM (genTraverseClause it) cs return (concat constraints, FunD 'Rank2.traverse clauses) genCotraverse :: [Con] -> Q ([Type], Dec) genCotraverse [con] = do (constraints, clause) <- genCotraverseClause con return (constraints, FunD 'Rank2.cotraverse [clause]) genCotraverseTraversable :: [Con] -> Q ([Type], Dec) genCotraverseTraversable [con] = do (constraints, clause) <- genCotraverseTraversableClause con return (constraints, FunD 'Rank2.cotraverseTraversable [clause]) genDeliver :: TypeQ -> [Con] -> Q ([Type], [Dec]) genDeliver instanceType [con] = do it <- instanceType let AppT _classType rt = it recType = pure rt signable <- TH.isExtEnabled TH.InstanceSigs scopable <- TH.isExtEnabled TH.ScopedTypeVariables if signable && scopable then do p <- newName "p" q <- newName "q" (constraints, clause) <- genDeliverClause recType (Just q) con ctx <- [t| Contravariant $(varT p) |] methodType <- [t| $(varT p) ($(recType) $(varT q) -> $(recType) $(varT q)) -> $(recType) (Compose $(varT p) ($(varT q) Rank2.~> $(varT q))) |] return (constraints, [SigD 'Rank2.deliver (ForallT [binder p, binder q] [ctx] methodType), FunD 'Rank2.deliver [clause]]) else do (constraints, clause) <- genDeliverClause recType Nothing con return (constraints, [FunD 'Rank2.deliver [clause]]) genFmapClause :: Type -> Con -> Q ([Type], Clause) genFmapClause _ (NormalC name fieldTypes) = do f <- newName "f" fieldNames <- replicateM (length fieldTypes) (newName "x") let pats = [varP f, conP name (map varP fieldNames)] constraintsAndFields = zipWith newField fieldNames fieldTypes newFields = map (snd <$>) constraintsAndFields body = normalB $ TH.appsE $ conE name : newFields newField :: Name -> BangType -> Q ([Type], Exp) newField x (_, fieldType) = genFmapField (varE f) fieldType (varE x) id constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields (,) constraints <$> TH.clause pats body [] genFmapClause _ (RecC name fields) = do f <- newName "f" x <- newName "x" let body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields constraintsAndFields = map newNamedField fields newNamedField :: VarBangType -> Q ([Type], (Name, Exp)) newNamedField (fieldName, _, fieldType) = ((,) fieldName <$>) <$> genFmapField (varE f) fieldType (getFieldOf x fieldName) id constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields (,) constraints <$> TH.clause [varP f, x `TH.asP` TH.recP name []] body [] genFmapClause instanceType (GadtC [name] fieldTypes _resultType@(AppT initType (VarT tyVar))) = do Just (Deriving tyConName _tyVar) <- getQ putQ (Deriving tyConName tyVar) let AppT _classType t = instanceType first (renameConstraintVars t initType <$>) <$> genFmapClause instanceType (NormalC name fieldTypes) genFmapClause instanceType (RecGadtC [name] fields _resultType@(AppT initType (VarT tyVar))) = do Just (Deriving tyConName _tyVar) <- getQ putQ (Deriving tyConName tyVar) let AppT _classType t = instanceType first (renameConstraintVars t initType <$>) <$> genFmapClause instanceType (RecC name fields) genFmapClause instanceType (ForallC _vars _cxt con) = genFmapClause instanceType con genFmapField :: Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp) genFmapField fun fieldType fieldAccess wrap = do Just (Deriving _ typeVar) <- getQ case fieldType of AppT ty _ | ty == VarT typeVar -> (,) [] <$> appE (wrap fun) fieldAccess AppT t1 t2 | t2 == VarT typeVar -> (,) (constrain ''Rank2.Functor t1) <$> appE (wrap [| ($fun Rank2.<$>) |]) fieldAccess AppT t1 t2 | t1 /= VarT typeVar -> genFmapField fun t2 fieldAccess (wrap . appE (varE '(<$>))) SigT ty _kind -> genFmapField fun ty fieldAccess wrap ParensT ty -> genFmapField fun ty fieldAccess wrap _ -> (,) [] <$> fieldAccess genLiftA2Clause :: Bool -> Con -> Q Clause genLiftA2Clause unsafely (NormalC name fieldTypes) = do f <- newName "f" fieldNames1 <- replicateM (length fieldTypes) (newName "x") y <- newName "y" fieldNames2 <- replicateM (length fieldTypes) (newName "y") let pats = [varP f, conP name (map varP fieldNames1), varP y] body = normalB $ TH.appsE $ conE name : zipWith newField (zip fieldNames1 fieldNames2) fieldTypes newField :: (Name, Name) -> BangType -> Q Exp newField (x, y) (_, fieldType) = genLiftA2Field unsafely (varE f) fieldType (varE x) (varE y) id TH.clause pats body [TH.valD (conP name $ map varP fieldNames2) (normalB $ varE y) []] genLiftA2Clause unsafely (RecC name fields) = do f <- newName "f" x <- newName "x" y <- newName "y" let body = normalB $ recConE name $ map newNamedField fields newNamedField :: VarBangType -> Q (Name, Exp) newNamedField (fieldName, _, fieldType) = TH.fieldExp fieldName $ genLiftA2Field unsafely (varE f) fieldType (getFieldOf x fieldName) (getFieldOf y fieldName) id TH.clause [varP f, x `TH.asP` TH.recP name [], varP y] body [] genLiftA2Clause unsafely (GadtC [name] fieldTypes _resultType@(AppT _ (VarT tyVar))) = do Just (Deriving tyConName _tyVar) <- getQ putQ (Deriving tyConName tyVar) genLiftA2Clause unsafely (NormalC name fieldTypes) genLiftA2Clause unsafely (RecGadtC [name] fields _resultType@(AppT _ (VarT tyVar))) = do Just (Deriving tyConName _tyVar) <- getQ putQ (Deriving tyConName tyVar) genLiftA2Clause unsafely (RecC name fields) genLiftA2Clause unsafely (ForallC _vars _cxt con) = genLiftA2Clause unsafely con genLiftA2Field :: Bool -> Q Exp -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp genLiftA2Field unsafely fun fieldType field1Access field2Access wrap = do Just (Deriving _ typeVar) <- getQ case fieldType of AppT ty _ | ty == VarT typeVar -> [| $(wrap fun) $field1Access $field2Access |] AppT _ ty | ty == VarT typeVar -> [| $(wrap $ appE (varE 'Rank2.liftA2) fun) $field1Access $field2Access |] AppT t1 t2 | t1 /= VarT typeVar -> genLiftA2Field unsafely fun t2 field1Access field2Access (appE (varE 'liftA2) . wrap) SigT ty _kind -> genLiftA2Field unsafely fun ty field1Access field2Access wrap ParensT ty -> genLiftA2Field unsafely fun ty field1Access field2Access wrap _ | unsafely -> field1Access | otherwise -> error ("Cannot apply liftA2 to field of type " <> show fieldType) genLiftA3Clause :: Bool -> Con -> Q Clause genLiftA3Clause unsafely (NormalC name fieldTypes) = do f <- newName "f" fieldNames1 <- replicateM (length fieldTypes) (newName "x") y <- newName "y" z <- newName "z" fieldNames2 <- replicateM (length fieldTypes) (newName "y") fieldNames3 <- replicateM (length fieldTypes) (newName "z") let pats = [varP f, conP name (map varP fieldNames1), varP y, varP z] body = normalB $ TH.appsE $ conE name : zipWith newField (zip3 fieldNames1 fieldNames2 fieldNames3) fieldTypes newField :: (Name, Name, Name) -> BangType -> Q Exp newField (x, y, z) (_, fieldType) = genLiftA3Field unsafely (varE f) fieldType (varE x) (varE y) (varE z) id TH.clause pats body [TH.valD (conP name $ map varP fieldNames2) (normalB $ varE y) [], TH.valD (conP name $ map varP fieldNames3) (normalB $ varE z) []] genLiftA3Clause unsafely (RecC name fields) = do f <- newName "f" x <- newName "x" y <- newName "y" z <- newName "z" let body = normalB $ recConE name $ map newNamedField fields newNamedField :: VarBangType -> Q (Name, Exp) newNamedField (fieldName, _, fieldType) = TH.fieldExp fieldName (genLiftA3Field unsafely (varE f) fieldType (getFieldOf x fieldName) (getFieldOf y fieldName) (getFieldOf z fieldName) id) TH.clause [varP f, x `TH.asP` TH.recP name [], varP y, varP z] body [] genLiftA3Clause unsafely (GadtC [name] fieldTypes _resultType@(AppT _ (VarT tyVar))) = do Just (Deriving tyConName _tyVar) <- getQ putQ (Deriving tyConName tyVar) genLiftA3Clause unsafely (NormalC name fieldTypes) genLiftA3Clause unsafely (RecGadtC [name] fields _resultType@(AppT _ (VarT tyVar))) = do Just (Deriving tyConName _tyVar) <- getQ putQ (Deriving tyConName tyVar) genLiftA3Clause unsafely (RecC name fields) genLiftA3Clause unsafely (ForallC _vars _cxt con) = genLiftA3Clause unsafely con genLiftA3Field :: Bool -> Q Exp -> Type -> Q Exp -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp genLiftA3Field unsafely fun fieldType field1Access field2Access field3Access wrap = do Just (Deriving _ typeVar) <- getQ case fieldType of AppT ty _ | ty == VarT typeVar -> [| $(wrap fun) $(field1Access) $(field2Access) $(field3Access) |] AppT _ ty | ty == VarT typeVar -> [| $(wrap $ appE (varE 'Rank2.liftA3) fun) $(field1Access) $(field2Access) $(field3Access) |] AppT t1 t2 | t1 /= VarT typeVar -> genLiftA3Field unsafely fun t2 field1Access field2Access field3Access (appE (varE 'liftA3) . wrap) SigT ty _kind -> genLiftA3Field unsafely fun ty field1Access field2Access field3Access wrap ParensT ty -> genLiftA3Field unsafely fun ty field1Access field2Access field3Access wrap _ | unsafely -> field1Access | otherwise -> error ("Cannot apply liftA3 to field of type " <> show fieldType) genApClause :: Bool -> Type -> Con -> Q ([Type], Clause) genApClause unsafely _ (NormalC name fieldTypes) = do fieldNames1 <- replicateM (length fieldTypes) (newName "x") fieldNames2 <- replicateM (length fieldTypes) (newName "y") rhsName <- newName "rhs" let pats = [conP name (map varP fieldNames1), varP rhsName] constraintsAndFields = zipWith newField (zip fieldNames1 fieldNames2) fieldTypes newFields = map (snd <$>) constraintsAndFields body = normalB $ TH.appsE $ conE name : newFields newField :: (Name, Name) -> BangType -> Q ([Type], Exp) newField (x, y) (_, fieldType) = genApField unsafely fieldType (varE x) (varE y) id constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields (,) constraints <$> TH.clause pats body [TH.valD (conP name $ map varP fieldNames2) (normalB $ varE rhsName) []] genApClause unsafely _ (RecC name fields) = do x <- newName "x" y <- newName "y" let body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields constraintsAndFields = map newNamedField fields newNamedField :: VarBangType -> Q ([Type], (Name, Exp)) newNamedField (fieldName, _, fieldType) = ((,) fieldName <$>) <$> genApField unsafely fieldType (getFieldOf x fieldName) (getFieldOf y fieldName) id constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields (,) constraints <$> TH.clause [x `TH.asP` TH.recP name [], varP y] body [] genApClause unsafely instanceType (GadtC [name] fieldTypes _resultType@(AppT initType (VarT tyVar))) = do Just (Deriving tyConName _tyVar) <- getQ putQ (Deriving tyConName tyVar) let AppT _classType t = instanceType first (renameConstraintVars t initType <$>) <$> genApClause unsafely instanceType (NormalC name fieldTypes) genApClause unsafely instanceType (RecGadtC [name] fields _resultType@(AppT initType (VarT tyVar))) = do Just (Deriving tyConName _tyVar) <- getQ putQ (Deriving tyConName tyVar) let AppT _classType t = instanceType first (renameConstraintVars t initType <$>) <$> genApClause unsafely instanceType (RecC name fields) genApClause unsafely instanceType (ForallC _vars _cxt con) = genApClause unsafely instanceType con genApField :: Bool -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp) genApField unsafely fieldType field1Access field2Access wrap = do Just (Deriving _ typeVar) <- getQ case fieldType of AppT ty _ | ty == VarT typeVar -> (,) [] <$> [| $(wrap (varE 'Rank2.apply)) $(field1Access) $(field2Access) |] AppT t1 t2 | t2 == VarT typeVar -> (,) (constrain ''Rank2.Apply t1) <$> [| $(wrap (varE 'Rank2.ap)) $(field1Access) $(field2Access) |] AppT t1 t2 | t1 /= VarT typeVar -> genApField unsafely t2 field1Access field2Access (appE (varE 'liftA2) . wrap) SigT ty _kind -> genApField unsafely ty field1Access field2Access wrap ParensT ty -> genApField unsafely ty field1Access field2Access wrap _ | unsafely -> (,) [] <$> field1Access | otherwise -> error ("Cannot apply ap to field of type " <> show fieldType) genPureClause :: Con -> Q ([Type], Clause) genPureClause (NormalC name fieldTypes) = do argName <- newName "f" let body = normalB $ TH.appsE $ conE name : ((snd <$>) <$> constraintsAndFields) constraintsAndFields = map newField fieldTypes newField :: BangType -> Q ([Type], Exp) newField (_, fieldType) = genPureField fieldType (varE argName) id constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields (,) constraints <$> TH.clause [varP argName] body [] genPureClause (RecC name fields) = do argName <- newName "f" let body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields constraintsAndFields = map newNamedField fields newNamedField :: VarBangType -> Q ([Type], (Name, Exp)) newNamedField (fieldName, _, fieldType) = ((,) fieldName <$>) <$> genPureField fieldType (varE argName) id constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields (,) constraints <$> TH.clause [varP argName] body [] genPureField :: Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp) genPureField fieldType pureValue wrap = do Just (Deriving _ typeVar) <- getQ case fieldType of AppT ty _ | ty == VarT typeVar -> (,) [] <$> wrap pureValue AppT t1 t2 | t2 == VarT typeVar -> (,) (constrain ''Rank2.Applicative t1) <$> wrap (appE (varE 'Rank2.pure) pureValue) AppT t1 t2 | t1 /= VarT typeVar -> genPureField t2 pureValue (wrap . appE (varE 'pure)) SigT ty _kind -> genPureField ty pureValue wrap ParensT ty -> genPureField ty pureValue wrap _ -> error ("Cannot create a pure field of type " <> show fieldType) genFoldMapClause :: Type -> Con -> Q ([Type], Clause) genFoldMapClause _ (NormalC name fieldTypes) = do f <- newName "f" fieldNames <- replicateM (length fieldTypes) (newName "x") let pats = [varP f, conP name (map varP fieldNames)] constraintsAndFields = zipWith newField fieldNames fieldTypes body | null fieldNames = [| mempty |] | otherwise = foldr1 append $ (snd <$>) <$> constraintsAndFields append a b = [| $(a) <> $(b) |] newField :: Name -> BangType -> Q ([Type], Exp) newField x (_, fieldType) = genFoldMapField f fieldType (varE x) id constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields (,) constraints <$> TH.clause pats (normalB body) [] genFoldMapClause _ (RecC name fields) = do f <- newName "f" x <- newName "x" let body | null fields = [| mempty |] | otherwise = foldr1 append $ (snd <$>) <$> constraintsAndFields constraintsAndFields = map newField fields append a b = [| $(a) <> $(b) |] newField :: VarBangType -> Q ([Type], Exp) newField (fieldName, _, fieldType) = genFoldMapField f fieldType (getFieldOf x fieldName) id constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields (,) constraints <$> TH.clause [varP f, x `TH.asP` TH.recP name []] (normalB body) [] genFoldMapClause instanceType (GadtC [name] fieldTypes _resultType@(AppT initType (VarT tyVar))) = do Just (Deriving tyConName _tyVar) <- getQ putQ (Deriving tyConName tyVar) let AppT _classType t = instanceType first (renameConstraintVars t initType <$>) <$> genFoldMapClause instanceType (NormalC name fieldTypes) genFoldMapClause instanceType (RecGadtC [name] fields _resultType@(AppT initType (VarT tyVar))) = do Just (Deriving tyConName _tyVar) <- getQ putQ (Deriving tyConName tyVar) let AppT _classType t = instanceType first (renameConstraintVars t initType <$>) <$> genFoldMapClause instanceType (RecC name fields) genFoldMapClause instanceType (ForallC _vars _cxt con) = genFoldMapClause instanceType con genFoldMapField :: Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp) genFoldMapField funcName fieldType fieldAccess wrap = do Just (Deriving _ typeVar) <- getQ case fieldType of AppT ty _ | ty == VarT typeVar -> (,) [] <$> appE (wrap $ varE funcName) fieldAccess AppT t1 t2 | t2 == VarT typeVar -> (,) (constrain ''Rank2.Foldable t1) <$> appE (wrap $ appE (varE 'Rank2.foldMap) (varE funcName)) fieldAccess AppT t1 t2 | t1 /= VarT typeVar -> genFoldMapField funcName t2 fieldAccess (wrap . appE (varE 'foldMap)) SigT ty _kind -> genFoldMapField funcName ty fieldAccess wrap ParensT ty -> genFoldMapField funcName ty fieldAccess wrap _ -> (,) [] <$> [| mempty |] genTraverseClause :: Type -> Con -> Q ([Type], Clause) genTraverseClause _ (NormalC name []) = (,) [] <$> TH.clause [wildP, conP name []] (normalB [| pure $(conE name) |]) [] genTraverseClause _ (NormalC name fieldTypes) = do f <- newName "f" fieldNames <- replicateM (length fieldTypes) (newName "x") let pats = [varP f, conP name (map varP fieldNames)] constraintsAndFields = zipWith newField fieldNames fieldTypes newFields = map (snd <$>) constraintsAndFields body = normalB $ fst $ foldl apply (conE name, False) newFields apply (a, False) b = ([| $(a) <$> $(b) |], True) apply (a, True) b = ([| $(a) <*> $(b) |], True) newField :: Name -> BangType -> Q ([Type], Exp) newField x (_, fieldType) = genTraverseField (varE f) fieldType (varE x) id constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields (,) constraints <$> TH.clause pats body [] genTraverseClause _ (RecC name fields) = do f <- newName "f" x <- newName "x" let constraintsAndFields = map newField fields body = normalB $ fst $ foldl apply (conE name, False) $ (snd <$>) <$> constraintsAndFields apply (a, False) b = ([| $(a) <$> $(b) |], True) apply (a, True) b = ([| $(a) <*> $(b) |], True) newField :: VarBangType -> Q ([Type], Exp) newField (fieldName, _, fieldType) = genTraverseField (varE f) fieldType (getFieldOf x fieldName) id constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields (,) constraints <$> TH.clause [varP f, x `TH.asP` TH.recP name []] body [] genTraverseClause instanceType (GadtC [name] fieldTypes _resultType@(AppT initType (VarT tyVar))) = do Just (Deriving tyConName _tyVar) <- getQ putQ (Deriving tyConName tyVar) let AppT _classType t = instanceType first (renameConstraintVars t initType <$>) <$> genTraverseClause instanceType (NormalC name fieldTypes) genTraverseClause instanceType (RecGadtC [name] fields _resultType@(AppT initType (VarT tyVar))) = do Just (Deriving tyConName _tyVar) <- getQ putQ (Deriving tyConName tyVar) let AppT _classType t = instanceType first (renameConstraintVars t initType <$>) <$> genTraverseClause instanceType (RecC name fields) genTraverseClause instanceType (ForallC _vars _cxt con) = genTraverseClause instanceType con genTraverseField :: Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp) genTraverseField fun fieldType fieldAccess wrap = do Just (Deriving _ typeVar) <- getQ case fieldType of AppT ty _ | ty == VarT typeVar -> (,) [] <$> appE (wrap fun) fieldAccess AppT t1 t2 | t2 == VarT typeVar -> (,) (constrain ''Rank2.Traversable t1) <$> appE (wrap [| Rank2.traverse $fun |]) fieldAccess AppT t1 t2 | t1 /= VarT typeVar -> genTraverseField fun t2 fieldAccess (wrap . appE (varE 'traverse)) SigT ty _kind -> genTraverseField fun ty fieldAccess wrap ParensT ty -> genTraverseField fun ty fieldAccess wrap _ -> (,) [] <$> [| pure $fieldAccess |] genCotraverseClause :: Con -> Q ([Type], Clause) genCotraverseClause (NormalC name []) = genCotraverseClause (RecC name []) genCotraverseClause (RecC name fields) = do withName <- newName "w" argName <- newName "f" let constraintsAndFields = map newNamedField fields body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields newNamedField :: VarBangType -> Q ([Type], (Name, Exp)) newNamedField (fieldName, _, fieldType) = ((,) fieldName <$>) <$> (genCotraverseField ''Rank2.Distributive (varE 'Rank2.cotraverse) (varE withName) fieldType [| $(projectField fieldName) <$> $(varE argName) |] id) constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields (,) constraints <$> TH.clause [varP withName, varP argName] body [] genCotraverseTraversableClause :: Con -> Q ([Type], Clause) genCotraverseTraversableClause (NormalC name []) = genCotraverseTraversableClause (RecC name []) genCotraverseTraversableClause (RecC name fields) = do withName <- newName "w" argName <- newName "f" let constraintsAndFields = map newNamedField fields body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields newNamedField :: VarBangType -> Q ([Type], (Name, Exp)) newNamedField (fieldName, _, fieldType) = ((,) fieldName <$>) <$> (genCotraverseField ''Rank2.DistributiveTraversable (varE 'Rank2.cotraverseTraversable) (varE withName) fieldType [| $(projectField fieldName) <$> $(varE argName) |] id) constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields (,) constraints <$> TH.clause [varP withName, varP argName] body [] genDeliverClause :: TypeQ -> Maybe Name -> Con -> Q ([Type], Clause) genDeliverClause recType typeVar (NormalC name []) = genDeliverClause recType typeVar (RecC name []) genDeliverClause recType typeVar (RecC name fields) = do argName <- newName "f" let constraintsAndFields = map newNamedField fields body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields recExp g = maybe g (\v-> [|($g :: $(recType) $(varT v))|]) typeVar newNamedField :: VarBangType -> Q ([Type], (Name, Exp)) newNamedField (fieldName, _, fieldType) = ((,) fieldName <$>) <$> (genDeliverField ''Rank2.Logistic fieldType (\wrap-> [| \set g-> $(TH.recUpdE (recExp [|g|]) [(,) fieldName <$> appE (wrap [| Rank2.apply set |]) (getFieldOfE [|g|] fieldName)]) |]) (\wrap-> [| \set g-> $(TH.recUpdE (recExp [|g|]) [(,) fieldName <$> appE (wrap [| set |]) (getFieldOfE [|g|] fieldName)]) |]) (varE argName) id id) constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields (,) constraints <$> TH.clause [varP argName] body [] genCotraverseField :: Name -> Q Exp -> Q Exp -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q ([Type], Exp) genCotraverseField className method fun fieldType fieldAccess wrap = do Just (Deriving _ typeVar) <- getQ case fieldType of AppT ty _ | ty == VarT typeVar -> (,) [] <$> appE (wrap fun) fieldAccess AppT t1 t2 | t2 == VarT typeVar -> (,) (constrain className t1) <$> appE (wrap $ appE method fun) fieldAccess AppT t1 t2 | t1 /= VarT typeVar -> genCotraverseField className method fun t2 fieldAccess (wrap . appE (varE 'cotraverse)) SigT ty _kind -> genCotraverseField className method fun ty fieldAccess wrap ParensT ty -> genCotraverseField className method fun ty fieldAccess wrap genDeliverField :: Name -> Type -> ((Q Exp -> Q Exp) -> Q Exp) -> ((Q Exp -> Q Exp) -> Q Exp) -> Q Exp -> (Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> Q ([Type], Exp) genDeliverField className fieldType fieldUpdate subRecordUpdate arg outer inner = do Just (Deriving _ typeVar) <- getQ case fieldType of AppT ty _ | ty == VarT typeVar -> (,) [] <$> outer (appE [|Compose|] ([|contramap|] `appE` fieldUpdate inner `appE` arg)) AppT t1 t2 | t2 == VarT typeVar -> (,) (constrain className t1) <$> outer (appE [| Rank2.deliver |] ([|contramap|] `appE` subRecordUpdate inner `appE` arg)) AppT t1 t2 | t1 /= VarT typeVar -> genDeliverField className t2 fieldUpdate subRecordUpdate arg (outer . appE (varE 'pure)) (inner . appE (varE 'fmap)) SigT ty _kind -> genDeliverField className ty fieldUpdate subRecordUpdate arg outer inner ParensT ty -> genDeliverField className ty fieldUpdate subRecordUpdate arg outer inner renameConstraintVars :: Type -> Type -> Type -> Type renameConstraintVars (AppT instanceType (VarT instanceVar)) (AppT returnType (VarT returnVar)) constrainedType = renameConstraintVars instanceType returnType (renameConstraintVar returnVar instanceVar constrainedType) renameConstraintVars (AppT instanceType _) (AppT returnType _) constrainedType = renameConstraintVars instanceType returnType constrainedType renameConstraintVars _ _ constrainedType = constrainedType renameConstraintVar :: Name -> Name -> Type -> Type renameConstraintVar from to (VarT name) | name == from = VarT to | otherwise = VarT name renameConstraintVar from to (AppT a b) = AppT (renameConstraintVar from to a) (renameConstraintVar from to b) #if MIN_VERSION_template_haskell(2,15,0) renameConstraintVar from to (AppKindT t k) = AppT (renameConstraintVar from to t) (renameConstraintVar from to k) #endif renameConstraintVar from to (InfixT a op b) = InfixT (renameConstraintVar from to a) op (renameConstraintVar from to b) renameConstraintVar from to (UInfixT a op b) = UInfixT (renameConstraintVar from to a) op (renameConstraintVar from to b) renameConstraintVar from to (SigT t k) = SigT (renameConstraintVar from to t) (renameConstraintVar from to k) renameConstraintVar from to (ParensT t) = ParensT (renameConstraintVar from to t) renameConstraintVar _ _ t = t projectField :: Name -> Q Exp projectField field = do #if MIN_VERSION_template_haskell(2,19,0) dotty <- TH.isExtEnabled TH.OverloadedRecordDot if dotty then TH.projectionE (pure $ TH.nameBase field) else varE field #else varE field #endif getFieldOf :: Name -> Name -> Q Exp getFieldOf = getFieldOfE . varE getFieldOfE :: Q Exp -> Name -> Q Exp getFieldOfE record field = do #if MIN_VERSION_template_haskell(2,19,0) dotty <- TH.isExtEnabled TH.OverloadedRecordDot if dotty then TH.getFieldE record (TH.nameBase field) else appE (varE field) record #else appE (varE field) record #endif constrain :: Name -> Type -> [Type] constrain _ ConT{} = [] constrain cls t = [ConT cls `AppT` t] #if MIN_VERSION_template_haskell(2,17,0) binder :: Name -> TyVarBndr TH.Specificity binder name = TH.PlainTV name TH.SpecifiedSpec #else binder :: Name -> TyVarBndr binder = TH.PlainTV #endif rank2classes-1.5.3.1/test/0000755000000000000000000000000007346545000013422 5ustar0000000000000000rank2classes-1.5.3.1/test/Doctest.hs0000644000000000000000000000033507346545000015364 0ustar0000000000000000import Build_doctests (flags, pkgs, module_sources) import Test.DocTest (doctest) main = do doctest (flags ++ pkgs ++ module_sources) doctest (flags ++ pkgs ++ ["-pgmL", "markdown-unlit", "test/MyModule.lhs"]) rank2classes-1.5.3.1/test/Issue23.hs0000644000000000000000000000243707346545000015221 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module Issue23 (test) where import Data.Functor.Identity import Data.Functor.Classes import qualified Rank2 import qualified Rank2.TH import Test.Tasty (TestTree) import Test.Tasty.HUnit (testCase, assertEqual) data Stm r = Unit | ExpStmt (r Int) (Exp r) data Exp r = Nil | Cons (r Bool) (Exp r) (Stm r) instance Show1 r => Show (Stm r) where show Unit = "Unit" show (ExpStmt r e) = "(Stmt (" ++ showsPrec1 0 r (") " ++ show e ++ ")") instance Show1 r => Show (Exp r) where show Nil = "Nil" show (Cons r e s) = "(Cons (" ++ showsPrec1 0 r (") " ++ show e ++ " " ++ show s ++ ")") $(mconcat <$> traverse (\derive -> mconcat <$> traverse derive [''Stm, ''Exp]) [ Rank2.TH.deriveFunctor , Rank2.TH.deriveFoldable , Rank2.TH.deriveTraversable ]) expToMaybe :: Exp Identity -> Exp Maybe expToMaybe = Rank2.fmap (Just . runIdentity) maybeToExp :: Exp Maybe -> Maybe (Exp Identity) maybeToExp = Rank2.traverse (fmap Identity) myExp :: Exp Identity myExp = Cons (Identity True) (Cons (Identity False) Nil (ExpStmt (Identity 2) Nil)) (ExpStmt (Identity 3) (Cons (Identity True) Nil Unit)) test :: TestTree test = testCase "Issue #23" $ do print myExp let myExp' = expToMaybe myExp assertEqual "" (show $ Just myExp) (show $ maybeToExp myExp') rank2classes-1.5.3.1/test/MyModule.lhs0000644000000000000000000002172707346545000015676 0ustar0000000000000000Rank 2 Classes ============== ### The standard constructor type classes in the parallel rank-2 universe ### The rank2 package exports module `Rank2`, meant to be imported qualified like this: ~~~ {.haskell} {-# LANGUAGE RankNTypes, TemplateHaskell, TypeOperators #-} module MyModule where import qualified Rank2 import qualified Rank2.TH ~~~ Several more imports for the examples... ~~~ {.haskell} import Data.Functor.Classes (Show1, showsPrec1) import Data.Functor.Identity (Identity(..)) import Data.Functor.Const (Const(..)) import Data.List (find) ~~~ The `Rank2` import will make available the following type classes: * [Rank2.Functor](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Functor) * [Rank2.Apply](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Apply) * [Rank2.Applicative](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Applicative) * [Rank2.Foldable](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Foldable) * [Rank2.Traversable](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Traversable) * [Rank2.Distributive](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Distributive) * [Rank2.Logistic](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Logistic) The methods of these type classes all have rank-2 types. The class instances are data types of kind `(k -> *) -> *`, one example of which would be a database record with different field types but all wrapped by the same type constructor: ~~~ {.haskell} data Person f = Person{ name :: f String, age :: f Int, mother, father :: f (Maybe PersonVerified) } ~~~ By wrapping each field we have declared a generalized record type. It can made to play different roles by switching the value of the parameter `f`. Some examples would be ~~~ {.haskell} type PersonVerified = Person Identity type PersonText = Person (Const String) type PersonWithErrors = Person (Either String) type PersonDatabase = [PersonVerified] type PersonDatabaseByColumns = Person [] ~~~ If you wish to have the standard [Eq](http://hackage.haskell.org/package/base/docs/Data-Eq.html#t:Eq) and [Show](http://hackage.haskell.org/package/base/docs/Text-Show.html#t:Show) instances for a record type like `Person`, it's best if they refer to the [Eq1](http://hackage.haskell.org/package/base-4.9.1.0/docs/Data-Functor-Classes.html#t:Eq1) and [Show1](http://hackage.haskell.org/package/base-4.9.1.0/docs/Data-Functor-Classes.html#t:Show1) instances for its parameter `f`: ~~~ {.haskell} instance Show1 f => Show (Person f) where showsPrec prec person rest = "Person{" ++ separator ++ "name=" ++ showsPrec1 prec' (name person) ("," ++ separator ++ "age=" ++ showsPrec1 prec' (age person) ("," ++ separator ++ "mother=" ++ showsPrec1 prec' (mother person) ("," ++ separator ++ "father=" ++ showsPrec1 prec' (father person) ("}" ++ rest)))) where prec' = succ prec separator = "\n" ++ replicate prec' ' ' ~~~ You can create the rank-2 class instances for your data types manually, or you can generate the instances using the templates imported from the `Rank2.TH` module with a single line of code per data type: ~~~ {.haskell} $(Rank2.TH.deriveAll ''Person) ~~~ Either way, once you have the rank-2 type class instances, you can use them to easily convert between records with different parameters `f`. ### Record construction and modification examples ### In case of our `Person` record, a couple of helper functions will prove handy: ~~~ {.haskell} findPerson :: PersonDatabase -> String -> Maybe PersonVerified findPerson db nameToFind = find ((nameToFind ==) . runIdentity . name) db personByName :: PersonDatabase -> String -> Either String (Maybe PersonVerified) personByName db personName | null personName = Right Nothing | p@Just{} <- findPerson db personName = Right p | otherwise = Left ("Nobody by name of " ++ personName) ~~~ Now we can start by constructing a `Person` record with rank-2 functions for fields. This record is not so much a person as a field-by-field person verifier: ~~~ {.haskell} personChecker :: PersonDatabase -> Person (Const String Rank2.~> Either String) personChecker db = Person{name= Rank2.Arrow (Right . getConst), age= Rank2.Arrow $ \(Const age)-> case reads age of [(n, "")] -> Right n _ -> Left (age ++ " is not an integer"), mother= Rank2.Arrow (personByName db . getConst), father= Rank2.Arrow (personByName db . getConst)} ~~~ We can apply it using the [Rank2.<*>](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#v:-60--42--62-) method of the [Rank2.Apply](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Apply) type class to a bunch of textual fields for `Person`, and get back either errors or proper field values: ~~~ {.haskell} verify :: PersonDatabase -> PersonText -> PersonWithErrors verify db person = personChecker db Rank2.<*> person ~~~ If there are no errors, we can get a fully verified record by applying [Rank2.traverse](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#v:traverse) to the result: ~~~ {.haskell} completeVerified :: PersonWithErrors -> Either String PersonVerified completeVerified = Rank2.traverse (Identity <$>) ~~~ or we can go in the opposite direction with [Rank2.<$>](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#v:-60--36--62-): ~~~ {.haskell} uncompleteVerified :: PersonVerified -> PersonWithErrors uncompleteVerified = Rank2.fmap (Right . runIdentity) ~~~ If on the other hand there *are* errors, we can collect them using [Rank2.foldMap](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#v:foldMap): ~~~ {.haskell} verificationErrors :: PersonWithErrors -> [String] verificationErrors = Rank2.foldMap (either (:[]) (const [])) ~~~ Here is an example GHCi session: ~~~ {.haskell} -- | -- >>> :{ --let Right alice = completeVerified $ -- verify [] Person{name= Const "Alice", age= Const "44", -- mother= Const "", father= Const ""} -- Right bob = completeVerified $ -- verify [] Person{name= Const "Bob", age= Const "45", -- mother= Const "", father= Const ""} -- Right charlie = completeVerified $ -- verify [alice, bob] Person{name= Const "Charlie", age= Const "19", -- mother= Const "Alice", father= Const "Bob"} -- :} -- -- >>> charlie -- Person{ -- name=Identity "Charlie", -- age=Identity 19, -- mother=Identity (Just Person{ -- name=(Identity "Alice"), -- age=(Identity 44), -- mother=(Identity Nothing), -- father=(Identity Nothing)}), -- father=Identity (Just Person{ -- name=(Identity "Bob"), -- age=(Identity 45), -- mother=(Identity Nothing), -- father=(Identity Nothing)})} -- >>> :{ --let dave = verify [alice, bob, charlie] -- Person{name= Const "Dave", age= Const "young", -- mother= Const "Lise", father= Const "Mike"} -- :} -- -- >>> dave -- Person{ -- name=Right "Dave", -- age=Left "young is not an integer", -- mother=Left "Nobody by name of Lise", -- father=Left "Nobody by name of Mike"} -- >>> completeVerified dave -- Left "young is not an integer" -- >>> verificationErrors dave -- ["young is not an integer","Nobody by name of Lise","Nobody by name of Mike"] -- >>> Rank2.distribute [alice, bob, charlie] -- Person{ -- name=Compose [Identity "Alice",Identity "Bob",Identity "Charlie"], -- age=Compose [Identity 44,Identity 45,Identity 19], -- mother=Compose [Identity Nothing,Identity Nothing,Identity (Just Person{ -- name=(Identity "Alice"), -- age=(Identity 44), -- mother=(Identity Nothing), -- father=(Identity Nothing)})], -- father=Compose [Identity Nothing,Identity Nothing,Identity (Just Person{ -- name=(Identity "Bob"), -- age=(Identity 45), -- mother=(Identity Nothing), -- father=(Identity Nothing)})]} ~~~ ### Related works ### This package is one of several implementations of a pattern that is often called *Higher-Kinded Data*. Other examples include [hkd-lens](https://hackage.haskell.org/package/hkd-lens), [barbies](https://hackage.haskell.org/package/barbies), and [higgledy](https://hackage.haskell.org/package/higgledy). Grammars are another use case that is almost, but not quite, entirely unlike database records. See [grammatical-parsers](https://github.com/blamario/grampa/tree/master/grammatical-parsers) or [construct](https://hackage.haskell.org/package/construct) for examples. Both database records and grammars are flat structures. If your use case involves trees of rank-2 records, this package will probably not suffice. Consider using [deep-transformations](https://hackage.haskell.org/package/deep-transformations) instead. rank2classes-1.5.3.1/test/TH.hs0000644000000000000000000001333307346545000014274 0ustar0000000000000000{-# LANGUAGE KindSignatures, RankNTypes, TemplateHaskell #-} import Control.Applicative (liftA2) import Data.Foldable (fold, foldMap) import Data.Traversable (traverse) import Data.Distributive (cotraverse) import Data.Monoid (Dual, Sum(Sum), getDual) import Data.Functor.Classes (Eq1, Show1, eq1, showsPrec1) import Data.Functor.Compose (Compose(Compose)) import Data.Functor.Identity (Identity(Identity, runIdentity)) import qualified Issue23 import qualified Rank2 import qualified Rank2.TH import Test.Tasty import Test.Tasty.HUnit data Test0 (p :: * -> *) = Test0{} deriving (Eq, Show) data Test1 p = Test1{single :: p Int, whole :: Test0 p, wrapSingle :: Dual (Identity (p String)), wrapWhole :: Sum (Identity (Test0 p))} instance Eq1 p => Eq (Test1 p) where a == b = single a `eq1` single b && whole a == whole b && all (all id) (liftA2 (liftA2 eq1) (wrapSingle a) (wrapSingle b)) && wrapWhole a == wrapWhole b instance Show1 p => Show (Test1 p) where showsPrec p t s = "Test1{single= " ++ showsPrec1 p (single t) (", whole= " ++ showsPrec p (whole t) (", wrapSingle= Dual (Identity (" ++ showsPrec1 p (runIdentity $ getDual $ wrapSingle t) (")), wrapWhole= " ++ showsPrec p (wrapWhole t) s))) $(Rank2.TH.deriveAll ''Test0) $(Rank2.TH.deriveAll ''Test1) main = defaultMain $ testGroup "Template tests" [ testCase "Simple template test" $ do let test = Test1{single= [3, 4, 5], whole= Test0, wrapSingle= pure (pure ["a", "b", "ab"]), wrapWhole= pure (pure Test0)} id Rank2.<$> test @?= test Rank2.pure (Rank2.Arrow id) Rank2.<*> test @?= test Rank2.liftA2 (++) test test @?= Test1{single= [3, 4, 5, 3, 4, 5], whole= Test0, wrapSingle= pure (pure ["a", "b", "ab", "a", "b", "ab"]), wrapWhole= pure (pure Test0)} Rank2.foldMap (Sum . length) test @?= Sum 6 Rank2.traverse (map Identity) test @?= [Test1{single= Identity 3, whole= Test0, wrapSingle= pure (pure $ Identity "a"), wrapWhole= pure (pure Test0)}, Test1{single= Identity 3, whole= Test0, wrapSingle= pure (pure $ Identity "b"), wrapWhole= pure (pure Test0)}, Test1{single= Identity 3, whole= Test0, wrapSingle= pure (pure $ Identity "ab"), wrapWhole= pure (pure Test0)}, Test1{single= Identity 4, whole= Test0, wrapSingle= pure (pure $ Identity "a"), wrapWhole= pure (pure Test0)}, Test1{single= Identity 4, whole= Test0, wrapSingle= pure (pure $ Identity "b"), wrapWhole= pure (pure Test0)}, Test1{single= Identity 4, whole= Test0, wrapSingle= pure (pure $ Identity "ab"), wrapWhole= pure (pure Test0)}, Test1{single= Identity 5, whole= Test0, wrapSingle= pure (pure $ Identity "a"), wrapWhole= pure (pure Test0)}, Test1{single= Identity 5, whole= Test0, wrapSingle= pure (pure $ Identity "b"), wrapWhole= pure (pure Test0)}, Test1{single= Identity 5, whole= Test0, wrapSingle= pure (pure $ Identity "ab"), wrapWhole= pure (pure Test0)} ] Rank2.distribute (Identity test) @?= Test1{single= Compose (Identity [3, 4, 5]), whole= Test0, wrapSingle= pure (pure $ Compose $ Identity ["a", "b", "ab"]), wrapWhole= pure (pure Test0)} Rank2.cotraverse (take 1 . map runIdentity) (Rank2.traverse (map Identity) test) @?= take 1 Rank2.<$> test, Issue23.test]