packages feed

rank2classes (empty) → 0.1

raw patch · 7 files changed

+731/−0 lines, 7 filesdep +basedep +doctestdep +rank2classessetup-changed

Dependencies added: base, doctest, rank2classes, template-haskell, transformers

Files

+ LICENSE view
@@ -0,0 +1,26 @@+Copyright (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.
+ README.md view
@@ -0,0 +1,193 @@+Rank 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 #-}+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/packages/rank2/doc/html/Rank2.html#t:Functor)+  * [Rank2.Apply](http://hackage.haskell.org/packages/rank2/doc/html/Rank2.html#t:Apply)+  * [Rank2.Applicative](http://hackage.haskell.org/packages/rank2/doc/html/Rank2.html#t:Applicative)+  * [Rank2.Foldable](http://hackage.haskell.org/packages/archive/doc/html/Rank2.html#t:Foldable)+  * [Rank2.Traversable](http://hackage.haskell.org/packages/archive/doc/html/Rank2.html#t:Traversable)+  * [Rank2.Distributive](http://hackage.haskell.org/packages/archive/doc/html/Rank2.html#t:Distributive)++The methods of these type classes all have rank-2 types. The class instances are data types of kind `(* -> *) -> *`, 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 (Rank2.Arrow (Const String) (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/packages/rank2/doc/html/Rank2.html#v:-60--42--62-)+method of the [Rank2.Apply](http://hackage.haskell.org/packages/rank2/doc/html/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/packages/rank2/doc/html/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/packages/rank2/doc/html/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/packages/rank2/doc/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 ""}+-- >>> let Right bob = completeVerified $ verify [] Person{name= Const "Bob", age= Const "45", mother= Const "", father= Const ""}+-- >>> let 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 "Eve", age= Const "young", mother= Const "Lise", father= Const "Mike"}+-- >>> dave+-- Person{+--  name=Right "Eve",+--  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)})]}+~~~++Grammars are another use case that is almost, but not quite, completely unlike database records. See+[grammatical-parsers](https://github.com/blamario/grampa/tree/master/grammatical-parsers) about that.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ rank2classes.cabal view
@@ -0,0 +1,43 @@+name:                rank2classes+version:             0.1+synopsis:            a mirror image of some standard type classes, with methods of rank 2 types+description:+  A mirror image of the standard constructor type class hierarchy rooted in 'Functor', except with methods of rank 2+  types and class instances of kind @(*->*)->*@. 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ć <blamario@protonmail.com>+copyright:           (c) 2017 Mario Blažević+category:            Control, Data, Generics+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10+extra-source-files:  README.md+source-repository head+  type:              git+  location:          https://github.com/blamario/grampa++library+  hs-source-dirs:      src+  exposed-modules:     Rank2, Rank2.TH+  default-language:    Haskell2010+  -- other-modules:+  ghc-options:         -Wall+  build-depends:       base >=4.7 && <5,+                       template-haskell >= 2.11 && < 2.12,+                       transformers >= 0.5 && < 0.6+  -- hs-source-dirs:      +  default-language:    Haskell2010++test-suite doctests+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  default-language:    Haskell2010+  main-is:             Doctest.hs+  ghc-options:         -threaded -pgmL markdown-unlit+  build-depends:       base, rank2classes, doctest >= 0.8
+ src/Rank2.hs view
@@ -0,0 +1,201 @@+-- | 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 two less standard classes 'Apply' and 'Distributive'.+{-# LANGUAGE InstanceSigs, KindSignatures, Rank2Types, ScopedTypeVariables #-}+module Rank2 (+-- * Rank 2 classes+   Functor(..), Apply(..), Applicative(..),+   Foldable(..), Traversable(..), Distributive(..),+-- * Rank 2 data types+   Compose(..), Empty(..), Only(..), Identity(..), Product(..), Arrow(..),+-- * Method synonyms and helper functions+   ap, fmap, liftA3)+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 Data.Monoid (Monoid(..), (<>))+import Data.Functor.Compose (Compose(..))++import Prelude hiding (Foldable(..), Traversable(..), Functor(..), Applicative(..), (<$>), fst, snd)++-- | Equivalent of 'Functor' for rank 2 data types+class Functor g where+   (<$>) :: (forall a. p a -> q a) -> g p -> g q++-- | Alphabetical synonym for '<$>'+fmap :: Functor g => (forall a. p a -> q a) -> g p -> g q+fmap = (<$>)++-- | Equivalent of 'Foldable' for rank 2 data types+class Foldable g where+   foldMap :: Monoid m => (forall a. p a -> m) -> g p -> m++-- | Equivalent of '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 (Compose m p) -> m (g p)+   traverse f = sequence . fmap (Compose . f)+   sequence = traverse getCompose++-- | Wrapper for functions that map the argument constructor type+newtype Arrow p q a = Arrow{apply :: p a -> q a}++-- | Subclass of 'Functor' halfway to 'Applicative'+--+-- > (.) <$> u <*> v <*> w == u <*> (v <*> w)+class Functor g => Apply g where+   {-# MINIMAL liftA2 | (<*>) #-}+   -- | Equivalent of 'Rank1.<*>' for rank 2 data types+   (<*>) :: g (Arrow 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++   (<*>) = liftA2 apply+   liftA2 f g h = (Arrow . f) <$> g <*> h++-- | Alphabetical synonym for '<*>'+ap :: Apply g => g (Arrow p q) -> g p -> g q+ap = (<*>)++-- | Equivalent of 'Rank1.liftA3' for rank 2 data types+liftA3 :: Apply g => (forall a. p a -> q a -> r a -> s a) -> g p -> g q -> g r -> g s+liftA3 f g h i = (\x-> Arrow (Arrow . f x)) <$> g <*> h <*> i++-- | Equivalent of 'Rank1.Applicative' for rank 2 data types+class Apply g => Applicative g where+   pure :: (forall a. f a) -> g f++-- | Equivalent of 'Distributive' for rank 2 data types+class Functor g => Distributive g where+   {-# MINIMAL distributeWith #-}+   collect :: Rank1.Functor f1 => (a -> g f2) -> f1 a -> g (Compose f1 f2)+   distribute :: Rank1.Functor f1 => f1 (g f2) -> g (Compose f1 f2)+   distributeWith :: Rank1.Functor f1 => (forall x. f1 (f2 x) -> f x) -> f1 (g f2) -> g f+   distributeM :: Rank1.Monad f => f (g f) -> g f++   collect f = distribute . Rank1.fmap f+   distribute = distributeWith Compose+   distributeM = distributeWith Rank1.join++-- | 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.Product' for rank 2 data types+data Product g h (f :: * -> *) = Pair {fst :: g f,+                                       snd :: h f}+                               deriving (Eq, Ord, Show)++newtype Flip g a f = Flip (g (f a)) deriving (Eq, Ord, Show)++instance Monoid (g (f a)) => Monoid (Flip g a f) where+   mempty = Flip mempty+   Flip x `mappend` Flip y = Flip (x `mappend` y)++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 (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, Functor h) => Functor (Product g h) where+   f <$> g = Pair (f <$> fst g) (f <$> snd g)++instance Foldable Empty 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, Foldable h) => Foldable (Product g h) where+   foldMap f ~(Pair g h) = foldMap f g <> foldMap f h++instance Traversable Empty where+   traverse _ _ = Rank1.pure Empty++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, Traversable h) => Traversable (Product g h) where+   traverse f ~(Pair g h) = Rank1.liftA2 Pair (traverse f g) (traverse f h)++instance Apply Empty where+   _ <*> _ = Empty+   liftA2 _ _ _ = Empty++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, Apply h) => Apply (Product g h) where+   gf <*> gx = Pair (fst gf <*> fst gx) (snd gf <*> snd gx)+   liftA2 f ~(Pair g1 g2) ~(Pair h1 h2) = Pair (liftA2 f g1 h1) (liftA2 f g2 h2)++instance Applicative Empty where+   pure = const Empty++instance Applicative (Only x) where+   pure = Only++instance Applicative g => Applicative (Identity g) where+   pure f = Identity (pure f)++instance (Applicative g, Applicative h) => Applicative (Product g h) where+   pure f = Pair (pure f) (pure f)++instance Distributive Empty where+   distributeWith _ _ = Empty+   distributeM _ = Empty++instance Distributive (Only x) where+   distributeWith w f = Only (w $ Rank1.fmap fromOnly f)+   distributeM f = Only (f >>= fromOnly)++instance Distributive g => Distributive (Identity g) where+   distributeWith w f = Identity (distributeWith w $ Rank1.fmap runIdentity f)+   distributeM f = Identity (distributeM $ Rank1.fmap runIdentity f)++instance (Distributive g, Distributive h) => Distributive (Product g h) where+   distributeWith w f = Pair (distributeWith w $ Rank1.fmap fst f) (distributeWith w $ Rank1.fmap snd f)+   distributeM f = Pair (distributeM $ Rank1.fmap fst f) (distributeM $ Rank1.fmap snd f)
+ src/Rank2/TH.hs view
@@ -0,0 +1,263 @@+-- | 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 = ...+-- > $(Rank2.TH.deriveAll ''MyDataType)+--+-- or, if you're picky, you can invoke only 'deriveFunctor' and whichever other instances you need instead.++{-# Language TemplateHaskell #-}+-- Adapted from https://wiki.haskell.org/A_practical_Template_Haskell_Tutorial++module Rank2.TH (deriveAll, deriveFunctor, deriveApply, deriveApplicative,+                 deriveFoldable, deriveTraversable, deriveDistributive)+where++import Control.Monad (replicateM)+import Data.Monoid ((<>))+import Language.Haskell.TH+import Language.Haskell.TH.Syntax (BangType, VarBangType, getQ, putQ)++import qualified Rank2++data Deriving = Deriving { derivingConstructor :: Name, derivingVariable :: Name }++deriveAll :: Name -> Q [Dec]+deriveAll ty = foldr f (pure []) [deriveFunctor, deriveApply, deriveApplicative,+                                  deriveFoldable, deriveTraversable, deriveDistributive]+   where f derive rest = (<>) <$> derive ty <*> rest++deriveFunctor :: Name -> Q [Dec]+deriveFunctor ty = do+   (instanceType, cs) <- reifyConstructors ''Rank2.Functor ty+   sequence [instanceD (return []) instanceType [genFmap cs]]++deriveApply :: Name -> Q [Dec]+deriveApply ty = do+   (instanceType, cs) <- reifyConstructors ''Rank2.Apply ty+   sequence [instanceD (return []) instanceType [genAp cs]]++deriveApplicative :: Name -> Q [Dec]+deriveApplicative ty = do+   (instanceType, cs) <- reifyConstructors ''Rank2.Applicative ty+   sequence [instanceD (return []) instanceType [genPure cs]]++deriveFoldable :: Name -> Q [Dec]+deriveFoldable ty = do+   (instanceType, cs) <- reifyConstructors ''Rank2.Foldable ty+   sequence [instanceD (return []) instanceType [genFoldMap cs]]++deriveTraversable :: Name -> Q [Dec]+deriveTraversable ty = do+   (instanceType, cs) <- reifyConstructors ''Rank2.Traversable ty+   sequence [instanceD (return []) instanceType [genTraverse cs]]++deriveDistributive :: Name -> Q [Dec]+deriveDistributive ty = do+   (instanceType, cs) <- reifyConstructors ''Rank2.Distributive ty+   sequence [instanceD (return []) instanceType [genDistributeWith cs, genDistributeM cs]]++reifyConstructors :: Name -> Name -> Q (TypeQ, [Con])+reifyConstructors cls ty = do+   (TyConI tyCon) <- 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 (KindedTV tyVar (AppT (AppT ArrowT StarT) StarT)) = last tyVars+       instanceType           = conT cls `appT` foldl apply (conT tyConName) (init tyVars)+       apply t (PlainTV name)    = appT t (varT name)+       apply t (KindedTV name _) = appT t (varT name)+ +   putQ (Deriving tyConName tyVar)+   return (instanceType, cs)++genFmap :: [Con] -> Q Dec+genFmap cs = funD '(Rank2.<$>) (map genFmapClause cs)++genAp :: [Con] -> Q Dec+genAp cs = funD '(Rank2.<*>) (map genApClause cs)++genPure :: [Con] -> Q Dec+genPure cs = funD 'Rank2.pure (map genPureClause cs)++genFoldMap :: [Con] -> Q Dec+genFoldMap cs = funD 'Rank2.foldMap (map genFoldMapClause cs)++genTraverse :: [Con] -> Q Dec+genTraverse cs = funD 'Rank2.traverse (map genTraverseClause cs)++genDistributeM :: [Con] -> Q Dec+genDistributeM cs = funD 'Rank2.distributeM (map genDistributeMClause cs)++genDistributeWith :: [Con] -> Q Dec+genDistributeWith cs = funD 'Rank2.distributeWith (map genDistributeWithClause cs)++genFmapClause :: Con -> Q Clause+genFmapClause (NormalC name fieldTypes) = do+   f          <- newName "f"+   fieldNames <- replicateM (length fieldTypes) (newName "x")+   let pats = [varP f, tildeP (conP name $ map varP fieldNames)]+       body = normalB $ appsE $ conE name : zipWith newField fieldNames fieldTypes+       newField :: Name -> BangType -> Q Exp+       newField x (_, fieldType) = do+          Just (Deriving _ typeVar) <- getQ+          case fieldType of+             AppT ty _ | ty == VarT typeVar -> [| $(varE f) $(varE x) |]+             AppT _ ty | ty == VarT typeVar -> [| Rank2.fmap $(varE f) $(varE x) |]+             _ -> [| $(varE x) |]+   clause pats body []+genFmapClause (RecC name fields) = do+   f <- newName "f"+   x <- newName "x"+   let body = normalB $ recConE name $ map newNamedField fields+       newNamedField :: VarBangType -> Q (Name, Exp)+       newNamedField (fieldName, _, fieldType) = do+          Just (Deriving _ typeVar) <- getQ+          case fieldType of+             AppT ty _+                | ty == VarT typeVar -> fieldExp fieldName [| $(varE f) ($(varE fieldName) $(varE x)) |]+             AppT _ ty+                | ty == VarT typeVar -> fieldExp fieldName [| Rank2.fmap $(varE f) ($(varE fieldName) $(varE x)) |]+             _ -> fieldExp fieldName [| $(varE x) |]+   clause [varP f, varP x] body []+ +genApClause :: Con -> Q Clause+genApClause (NormalC name fieldTypes) = do+   fieldNames1 <- replicateM (length fieldTypes) (newName "x")+   fieldNames2 <- replicateM (length fieldTypes) (newName "y")+   let pats = [tildeP (conP name $ map varP fieldNames1), tildeP (conP name $ map varP fieldNames2)]+       body = normalB $ appsE $ conE name : zipWith newField (zip fieldNames1 fieldNames2) fieldTypes+       newField :: (Name, Name) -> BangType -> Q Exp+       newField (x, y) (_, fieldType) = do+          Just (Deriving _ typeVar) <- getQ+          case fieldType of+             AppT ty _ | ty == VarT typeVar -> [| Rank2.apply $(varE x) $(varE y) |]+             AppT _ ty | ty == VarT typeVar -> [| Rank2.ap $(varE x) $(varE y) |]+   clause pats body []+genApClause (RecC name fields) = do+   x <- newName "x"+   y <- newName "y"+   let body = normalB $ recConE name $ map newNamedField fields+       newNamedField :: VarBangType -> Q (Name, Exp)+       newNamedField (fieldName, _, fieldType) = do+          Just (Deriving _ typeVar) <- getQ+          case fieldType of+             AppT ty _ | ty == VarT typeVar -> fieldExp fieldName [| $(varE fieldName) $(varE x) `Rank2.apply`+                                                                       $(varE fieldName) $(varE y) |]+             AppT _ ty | ty == VarT typeVar -> fieldExp fieldName [| $(varE fieldName) $(varE x) `Rank2.ap`+                                                                       $(varE fieldName) $(varE y) |]+   clause [varP x, varP y] body []++genPureClause :: Con -> Q Clause+genPureClause (NormalC name fieldTypes) = do+   argName <- newName "f"+   let body = normalB $ appsE $ conE name : map newField fieldTypes+       newField :: BangType -> Q Exp+       newField (_, fieldType) = do+          Just (Deriving _ typeVar) <- getQ+          case fieldType of+             AppT ty _ | ty == VarT typeVar -> varE argName+             AppT _ ty | ty == VarT typeVar -> appE (varE 'Rank2.pure) (varE argName)+   clause [varP argName] body []+genPureClause (RecC name fields) = do+   argName <- newName "f"+   let body = normalB $ recConE name $ map newNamedField fields+       newNamedField :: VarBangType -> Q (Name, Exp)+       newNamedField (fieldName, _, fieldType) = do+          Just (Deriving _ typeVar) <- getQ+          case fieldType of+             AppT ty _ | ty == VarT typeVar -> fieldExp fieldName (varE argName)+             AppT _ ty | ty == VarT typeVar -> fieldExp fieldName (appE (varE 'Rank2.pure) $ varE argName)+   clause [varP argName] body []++genFoldMapClause :: Con -> Q Clause+genFoldMapClause (NormalC name fieldTypes) = do+   f          <- newName "f"+   fieldNames <- replicateM (length fieldTypes) (newName "x")+   let pats = [varP f, tildeP (conP name $ map varP fieldNames)]+       body = normalB $ foldr1 append $ zipWith newField fieldNames fieldTypes+       append a b = [| $(a) <> $(b) |]+       newField :: Name -> BangType -> Q Exp+       newField x (_, fieldType) = do+          Just (Deriving _ typeVar) <- getQ+          case fieldType of+             AppT ty _ | ty == VarT typeVar -> [| $(varE f) $(varE x) |]+             AppT _ ty | ty == VarT typeVar -> [| Rank2.foldMap $(varE f) $(varE x) |]+             _ -> [| $(varE x) |]+   clause pats body []+genFoldMapClause (RecC _name fields) = do+   f <- newName "f"+   x <- newName "x"+   let body = normalB $ foldr1 append $ map newField fields+       append a b = [| $(a) <> $(b) |]+       newField :: VarBangType -> Q Exp+       newField (fieldName, _, fieldType) = do+          Just (Deriving _ typeVar) <- getQ+          case fieldType of+             AppT ty _ | ty == VarT typeVar -> [| $(varE f) ($(varE fieldName) $(varE x)) |]+             AppT _ ty | ty == VarT typeVar -> [| Rank2.foldMap $(varE f) ($(varE fieldName) $(varE x)) |]+             _ -> [| $(varE x) |]+   clause [varP f, varP x] body []++genTraverseClause :: Con -> Q Clause+genTraverseClause (NormalC name fieldTypes) = do+   f          <- newName "f"+   fieldNames <- replicateM (length fieldTypes) (newName "x")+   let pats = [varP f, tildeP (conP name $ map varP fieldNames)]+       body = normalB $ fst $ foldl apply (conE name, False) $ zipWith newField fieldNames fieldTypes+       apply (a, False) b = ([| $(a) <$> $(b) |], True)+       apply (a, True) b = ([| $(a) <*> $(b) |], True)+       newField :: Name -> BangType -> Q Exp+       newField x (_, fieldType) = do+          Just (Deriving _ typeVar) <- getQ+          case fieldType of+             AppT ty _ | ty == VarT typeVar -> [| $(varE f) $(varE x) |]+             AppT _ ty | ty == VarT typeVar -> [| Rank2.traverse $(varE f) $(varE x) |]+             _ -> [| $(varE x) |]+   clause pats body []+genTraverseClause (RecC name fields) = do+   f <- newName "f"+   x <- newName "x"+   let body = normalB $ fst $ foldl apply (conE name, False) $ map newField fields+       apply (a, False) b = ([| $(a) <$> $(b) |], True)+       apply (a, True) b = ([| $(a) <*> $(b) |], True)+       newField :: VarBangType -> Q Exp+       newField (fieldName, _, fieldType) = do+          Just (Deriving _ typeVar) <- getQ+          case fieldType of+             AppT ty _ | ty == VarT typeVar -> [| $(varE f) ($(varE fieldName) $(varE x)) |]+             AppT _ ty | ty == VarT typeVar -> [| Rank2.traverse $(varE f) ($(varE fieldName) $(varE x)) |]+             _ -> [| $(varE x) |]+   clause [varP f, varP x] body []++genDistributeMClause :: Con -> Q Clause+genDistributeMClause (RecC name fields) = do+   argName <- newName "f"+   let body = normalB $ recConE name $ map newNamedField fields+       newNamedField :: VarBangType -> Q (Name, Exp)+       newNamedField (fieldName, _, fieldType) = do+          Just (Deriving _ typeVar) <- getQ+          case fieldType of+             AppT ty _ | ty == VarT typeVar -> fieldExp fieldName [| $(varE argName) >>= $(varE fieldName) |]+             AppT _ ty | ty == VarT typeVar ->+                         fieldExp fieldName [| Rank2.distributeM ($(varE fieldName) <$> $(varE argName)) |]+   clause [varP argName] body []++genDistributeWithClause :: Con -> Q Clause+genDistributeWithClause (RecC name fields) = do+   withName <- newName "w"+   argName <- newName "f"+   let body = normalB $ recConE name $ map newNamedField fields+       newNamedField :: VarBangType -> Q (Name, Exp)+       newNamedField (fieldName, _, fieldType) = do+          Just (Deriving _ typeVar) <- getQ+          case fieldType of+             AppT ty _+                | ty == VarT typeVar -> fieldExp fieldName [| $(varE withName) ($(varE fieldName) <$> $(varE argName)) |]+             AppT _ ty+                | ty == VarT typeVar ->+                  fieldExp fieldName [| Rank2.distributeWith $(varE withName) ($(varE fieldName) <$> $(varE argName)) |]+   clause [varP withName, varP argName] body []
+ test/Doctest.hs view
@@ -0,0 +1,3 @@+import Test.DocTest++main = doctest ["-pgmL", "markdown-unlit", "-isrc", "test/README.lhs"]