rank2classes 1.4.6 → 1.5.5.1
raw patch · 9 files changed
Files
- CHANGELOG.md +42/−0
- README.md +3/−2
- Setup.hs +2/−6
- rank2classes.cabal +9/−16
- src/Rank2.hs +30/−21
- src/Rank2/TH.hs +192/−88
- test/Doctest.hs +0/−5
- test/MyModule.lhs +3/−2
- test/TH.hs +4/−1
CHANGELOG.md view
@@ -1,3 +1,45 @@+Version 1.5.5.1+---------------+* Bumped the upper bound of the `template-haskell` dependency.++Version 1.5.5+---------------+* Added `Rank2.coerce`+* Allow `markdown-unlit` 0.6, thanks to Felix Yan+* Turned doctests from a testsuite into a named library, dropped cabal-doctest+* Updated GitHub CI action++Version 1.5.4+---------------+* Deriving `Data` and `Typeable` for all declared data types.+* Bumped the upper bound of the `template-haskell` dependency.++Version 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`
README.md view
@@ -29,6 +29,7 @@ * [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@@ -211,9 +212,9 @@ 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 [hiddledy](https://hackage.haskell.org/package/higgledy).+[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, completely unlike database records. See+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.
Setup.hs view
@@ -1,6 +1,2 @@-module Main where--import Distribution.Extra.Doctest (defaultMainWithDoctests)--main :: IO ()-main = defaultMainWithDoctests "doctests"+import Distribution.Simple+main = defaultMain
rank2classes.cabal view
@@ -1,5 +1,5 @@ name: rank2classes-version: 1.4.6+version: 1.5.5.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@@ -14,18 +14,13 @@ maintainer: Mario Blažević <blamario@protonmail.com> copyright: (c) 2017 Mario Blažević category: Control, Data, Generics-build-type: Custom-cabal-version: >=1.10-tested-with: GHC==9.0.1, GHC==8.10.4, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2+build-type: Simple+cabal-version: 2.0+tested-with: GHC==9.12.2, GHC==9.10.2, GHC==9.8.4, GHC==9.6.7, GHC==9.4.8, GHC==9.2.8, GHC==9.0.2, GHC==8.10.7 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,- cabal-doctest >= 1 && <1.1 flag use-template-haskell description: Enable the compilation of the Rank2.TH module@@ -44,18 +39,16 @@ data-functor-logistic < 0.1 if flag(use-template-haskell)- build-depends: template-haskell >= 2.11 && < 2.20+ build-depends: template-haskell >= 2.11 && < 2.25 exposed-modules: Rank2.TH -test-suite doctests- type: exitcode-stdio-1.0+library doctests 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+ build-depends: base, rank2classes+ build-tool-depends: markdown-unlit:markdown-unlit >= 0.5 && < 0.7 test-suite TH if !flag(use-template-haskell)@@ -69,4 +62,4 @@ 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+ build-tool-depends: markdown-unlit:markdown-unlit >= 0.5 && < 0.7, doctest:doctest >= 0.8 && < 1
src/Rank2.hs view
@@ -4,10 +4,12 @@ -- -- 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'.+-- the less standard classes 'Apply', 'Distributive', and 'Logistic'. {-# LANGUAGE DefaultSignatures, InstanceSigs, KindSignatures, PolyKinds, Rank2Types #-} {-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, TypeOperators, UndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyCase #-}+{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE TypeApplications #-} module Rank2 ( -- * Rank 2 classes@@ -30,7 +32,8 @@ 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 qualified Data.Coerce as Coerce+import Data.Data (Data, Typeable) import Data.Semigroup (Semigroup(..)) import Data.Monoid (Monoid(..)) import Data.Functor.Const (Const(..))@@ -39,6 +42,7 @@ import Data.Kind (Type) import Data.Proxy (Proxy(..)) import qualified GHC.Generics as Generics+import Unsafe.Coerce (unsafeCoerce) import Prelude hiding (Foldable(..), Traversable(..), Functor(..), Applicative(..), ($), (<$>), fst, snd) @@ -56,6 +60,9 @@ -- > (p . q) <$> g == p <$> (q <$> g) class Functor g where (<$>) :: (forall a. p a -> q a) -> g p -> g q+ -- | Equivalent to @(Data.Coerce.coerce <$>)@ but faster+ coerce :: (forall a. Coerce.Coercible (p a) (q a)) => g p -> g q+ coerce = unsafeCoerce infixl 4 <$> -- | Alphabetical synonym for '<$>'@@ -75,7 +82,7 @@ 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}+newtype Arrow p q a = Arrow{apply :: p a -> q a} deriving Typeable type (~>) = Arrow ($) :: Arrow p q a -> p a -> q a@@ -189,23 +196,25 @@ distributeWithTraversable = cotraverseTraversable -- | A rank-2 equivalent of @()@, a zero-element tuple-data Empty f = Empty deriving (Eq, Ord, Show)+data Empty f = Empty deriving (Eq, Ord, Show, Data, Typeable) -- | A rank-2 tuple of only one element-newtype Only a f = Only {fromOnly :: f a} deriving (Eq, Ord, Show)+newtype Only a f = Only {fromOnly :: f a} deriving (Eq, Ord, Show, Data, Typeable) -- | Equivalent of 'Data.Functor.Identity' for rank 2 data types-newtype Identity g f = Identity {runIdentity :: g f} deriving (Eq, Ord, Show)+newtype Identity g f = Identity {runIdentity :: g f} deriving (Eq, Ord, Show, Data, Typeable) -- | Equivalent of 'Data.Functor.Compose' for rank 2 data types-newtype Compose g p q = Compose {getCompose :: g (Rank1.Compose p q)}+newtype Compose g p q = Compose {getCompose :: g (Rank1.Compose p q)} deriving Typeable 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)+deriving instance (Typeable k1, Typeable k, Typeable g, Typeable (p :: k -> Type), Typeable (q :: k1 -> k),+ Data (g (Rank1.Compose p q))) => Data (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)+newtype Flip g a f = Flip {unFlip :: g (f a)} deriving (Eq, Ord, Show, Data, Typeable) instance Semigroup (g (f a)) => Semigroup (Flip g a f) where Flip x <> Flip y = Flip (x <> y)@@ -218,7 +227,7 @@ 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)+ Flip g <*> Flip h = Flip (Rank1.liftA2 apply g h) instance Rank1.Applicative g => Rank2.Applicative (Flip g a) where pure f = Flip (Rank1.pure f)@@ -258,13 +267,13 @@ f <$> InR h = InR (f <$> h) instance Functor Generics.V1 where- (<$>) _ = coerce+ (<$>) _ = Coerce.coerce instance Functor Generics.U1 where- (<$>) _ = coerce+ (<$>) _ = Coerce.coerce instance Functor (Generics.K1 i c) where- (<$>) _ = coerce+ (<$>) _ = Coerce.coerce instance Functor f => Functor (Generics.M1 i c f) where f <$> Generics.M1 x = Generics.M1 (f <$> x)@@ -358,13 +367,13 @@ traverse f (InR h) = InR Rank1.<$> traverse f h instance Traversable Generics.V1 where- traverse _ = Rank1.pure . coerce+ traverse _ = Rank1.pure . Coerce.coerce instance Traversable Generics.U1 where- traverse _ = Rank1.pure . coerce+ traverse _ = Rank1.pure . Coerce.coerce instance Traversable (Generics.K1 i c) where- traverse _ = Rank1.pure . coerce+ traverse _ = Rank1.pure . Coerce.coerce instance Traversable f => Traversable (Generics.M1 i c f) where traverse f (Generics.M1 x) = Rank1.fmap Generics.M1 (traverse f x)@@ -415,10 +424,10 @@ 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+ (<*>) _ = Coerce.coerce instance Apply Generics.U1 where- (<*>) _ = coerce+ (<*>) _ = Coerce.coerce instance Semigroup c => Apply (Generics.K1 i c) where Generics.K1 x <*> Generics.K1 y = Generics.K1 (x <> y)@@ -492,7 +501,7 @@ cotraverse _ _ = Proxy instance Monoid x => DistributiveTraversable (Const x) where- cotraverseTraversable _ f = coerce (Rank1.fold f)+ cotraverseTraversable _ f = Coerce.coerce (Rank1.fold f) instance Distributive (Only x) where cotraverse w f = Only (w (Rank1.fmap fromOnly f))@@ -508,7 +517,7 @@ 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)+ cotraverseTraversable _ f = Coerce.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))@@ -524,10 +533,10 @@ deliver _ = Proxy instance Logistic (Only x) where- deliver f = Only (Rank1.Compose (Rank1.contramap coerce f))+ deliver f = Only (Rank1.Compose (Rank1.contramap Coerce.coerce f)) instance Logistic g => Logistic (Identity g) where- deliver f = Identity (deliver (Rank1.contramap coerce f))+ deliver f = Identity (deliver (Rank1.contramap Coerce.coerce f)) instance (Logistic g, Rank1.Logistic p) => Logistic (Compose g p) where deliver = Compose
src/Rank2/TH.hs view
@@ -9,6 +9,7 @@ {-# 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,@@ -18,15 +19,14 @@ 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 (contramap)-import Data.Functor.Logistic (deliver)-import Data.Monoid ((<>))+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, instanceD, varE, varP, normalB, pragInlD, recConE, recUpdE, wildP)+ 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@@ -42,14 +42,14 @@ deriveFunctor :: Name -> Q [Dec] deriveFunctor ty = do (instanceType, cs) <- reifyConstructors ''Rank2.Functor ty- (constraints, dec) <- genFmap cs+ (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 cs+ (constraints, dec) <- genAp instanceType cs sequence [instanceD (TH.cxt $ map pure constraints) instanceType [pure dec, genLiftA2 cs, genLiftA3 cs, pragInlD '(Rank2.<*>) Inlinable FunLike AllPhases,@@ -59,7 +59,7 @@ unsafeDeriveApply :: Name -> Q [Dec] unsafeDeriveApply ty = do (instanceType, cs) <- reifyConstructors ''Rank2.Apply ty- (constraints, dec) <- genApUnsafely cs+ (constraints, dec) <- genApUnsafely instanceType cs sequence [instanceD (TH.cxt $ map pure constraints) instanceType [pure dec, genLiftA2Unsafely cs, genLiftA3Unsafely cs, pragInlD '(Rank2.<*>) Inlinable FunLike AllPhases,@@ -75,14 +75,14 @@ deriveFoldable :: Name -> Q [Dec] deriveFoldable ty = do (instanceType, cs) <- reifyConstructors ''Rank2.Foldable ty- (constraints, dec) <- genFoldMap cs+ (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 cs+ (constraints, dec) <- genTraverse instanceType cs sequence [instanceD (TH.cxt $ map pure constraints) instanceType [pure dec, pragInlD 'Rank2.traverse Inlinable FunLike AllPhases]] @@ -102,9 +102,9 @@ deriveLogistic :: Name -> Q [Dec] deriveLogistic ty = do (instanceType, cs) <- reifyConstructors ''Rank2.Logistic ty- (constraints, dec) <- genDeliver cs+ (constraints, decs) <- genDeliver instanceType cs sequence [instanceD (TH.cxt $ map pure constraints) instanceType- [pure dec, pragInlD 'Rank2.deliver Inline FunLike AllPhases]]+ (map pure decs <> [pragInlD 'Rank2.deliver Inline FunLike AllPhases])] reifyConstructors :: Name -> Name -> Q (TypeQ, [Con]) reifyConstructors cls ty = do@@ -113,29 +113,49 @@ 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)- let (KindedTV tyVar () (AppT (AppT ArrowT _) StarT)) = last tyVars- instanceType = TH.conT cls `TH.appT` foldl apply (TH.conT tyConName) (init tyVars)- apply t (PlainTV name _) = TH.appT t (TH.varT name)- apply t (KindedTV name _ _) = TH.appT t (TH.varT name)+ reifyTVKindSynonyms (KindedTV v s k) = KindedTV v s <$> reifySynonyms k #else- let (KindedTV tyVar (AppT (AppT ArrowT _) StarT)) = last tyVars- instanceType = TH.conT cls `TH.appT` foldl apply (TH.conT tyConName) (init tyVars)- apply t (PlainTV name) = TH.appT t (TH.varT name)- apply t (KindedTV name _) = TH.appT t (TH.varT name)+ 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 :: [Con] -> Q ([Type], Dec)-genFmap cs = do (constraints, clauses) <- unzip <$> mapM genFmapClause cs- return (concat constraints, FunD '(Rank2.<$>) clauses)+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 :: [Con] -> Q ([Type], Dec)-genAp [con] = do (constraints, clause) <- genApClause False con- return (constraints, FunD '(Rank2.<*>) [clause])+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]@@ -143,9 +163,11 @@ genLiftA3 :: [Con] -> Q Dec genLiftA3 [con] = TH.funD 'Rank2.liftA3 [genLiftA3Clause False con] -genApUnsafely :: [Con] -> Q ([Type], Dec)-genApUnsafely cons = do (constraints, clauses) <- unzip <$> mapM (genApClause True) cons- return (concat constraints, FunD '(Rank2.<*>) clauses)+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)@@ -157,13 +179,17 @@ genPure cs = do (constraints, clauses) <- unzip <$> mapM genPureClause cs return (concat constraints, FunD 'Rank2.pure clauses) -genFoldMap :: [Con] -> Q ([Type], Dec)-genFoldMap cs = do (constraints, clauses) <- unzip <$> mapM genFoldMapClause cs- return (concat constraints, FunD 'Rank2.foldMap 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 :: [Con] -> Q ([Type], Dec)-genTraverse cs = do (constraints, clauses) <- unzip <$> mapM genTraverseClause cs- return (concat constraints, FunD 'Rank2.traverse 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@@ -173,12 +199,29 @@ genCotraverseTraversable [con] = do (constraints, clause) <- genCotraverseTraversableClause con return (constraints, FunD 'Rank2.cotraverseTraversable [clause]) -genDeliver :: [Con] -> Q ([Type], Dec)-genDeliver [con] = do (constraints, clause) <- genDeliverClause con- return (constraints, FunD 'Rank2.deliver [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 :: Con -> Q ([Type], Clause)-genFmapClause (NormalC name fieldTypes) = do++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)]@@ -189,7 +232,7 @@ 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+genFmapClause _ (RecC name fields) = do f <- newName "f" x <- newName "x" let body = normalB $ recConE name $ (snd <$>) <$> constraintsAndFields@@ -197,18 +240,20 @@ newNamedField :: VarBangType -> Q ([Type], (Name, Exp)) newNamedField (fieldName, _, fieldType) = ((,) fieldName <$>)- <$> genFmapField (varE f) fieldType (appE (varE fieldName) (varE x)) id+ <$> 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 (GadtC [name] fieldTypes _resultType@(AppT _ (VarT tyVar))) =+genFmapClause instanceType (GadtC [name] fieldTypes _resultType@(AppT initType (VarT tyVar))) = do Just (Deriving tyConName _tyVar) <- getQ putQ (Deriving tyConName tyVar)- genFmapClause (NormalC name fieldTypes)-genFmapClause (RecGadtC [name] fields _resultType@(AppT _ (VarT 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)- genFmapClause (RecC name fields)-genFmapClause (ForallC _vars _cxt con) = genFmapClause con+ 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@@ -239,8 +284,8 @@ 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) (getFieldOf y) id)- where getFieldOf = appE (varE fieldName) . varE+ 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@@ -288,8 +333,7 @@ newNamedField :: VarBangType -> Q (Name, Exp) newNamedField (fieldName, _, fieldType) = TH.fieldExp fieldName- (genLiftA3Field unsafely (varE f) fieldType (getFieldOf x) (getFieldOf y) (getFieldOf z) id)- where getFieldOf = appE (varE fieldName) . varE+ (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@@ -317,8 +361,8 @@ _ | unsafely -> field1Access | otherwise -> error ("Cannot apply liftA3 to field of type " <> show fieldType) -genApClause :: Bool -> Con -> Q ([Type], Clause)-genApClause unsafely (NormalC name fieldTypes) = do+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"@@ -330,26 +374,27 @@ 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+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) (getFieldOf y) id- where getFieldOf = appE (varE fieldName) . varE+ ((,) 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 (GadtC [name] fieldTypes _resultType@(AppT _ (VarT tyVar))) =+genApClause unsafely instanceType (GadtC [name] fieldTypes _resultType@(AppT initType (VarT tyVar))) = do Just (Deriving tyConName _tyVar) <- getQ putQ (Deriving tyConName tyVar)- genApClause unsafely (NormalC name fieldTypes)-genApClause unsafely (RecGadtC [name] fields _resultType@(AppT _ (VarT 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)- genApClause unsafely (RecC name fields)-genApClause unsafely (ForallC _vars _cxt con) = genApClause unsafely con+ 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@@ -393,8 +438,8 @@ ParensT ty -> genPureField ty pureValue wrap _ -> error ("Cannot create a pure field of type " <> show fieldType) -genFoldMapClause :: Con -> Q ([Type], Clause)-genFoldMapClause (NormalC name fieldTypes) = do+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)]@@ -406,7 +451,7 @@ 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+genFoldMapClause _ (RecC name fields) = do f <- newName "f" x <- newName "x" let body | null fields = [| mempty |]@@ -414,18 +459,20 @@ constraintsAndFields = map newField fields append a b = [| $(a) <> $(b) |] newField :: VarBangType -> Q ([Type], Exp)- newField (fieldName, _, fieldType) = genFoldMapField f fieldType (appE (varE fieldName) (varE x)) id+ 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 (GadtC [name] fieldTypes _resultType@(AppT _ (VarT tyVar))) =+genFoldMapClause instanceType (GadtC [name] fieldTypes _resultType@(AppT initType (VarT tyVar))) = do Just (Deriving tyConName _tyVar) <- getQ putQ (Deriving tyConName tyVar)- genFoldMapClause (NormalC name fieldTypes)-genFoldMapClause (RecGadtC [name] fields _resultType@(AppT _ (VarT 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)- genFoldMapClause (RecC name fields)-genFoldMapClause (ForallC _vars _cxt con) = genFoldMapClause con+ 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@@ -439,10 +486,10 @@ ParensT ty -> genFoldMapField funcName ty fieldAccess wrap _ -> (,) [] <$> [| mempty |] -genTraverseClause :: Con -> Q ([Type], Clause)-genTraverseClause (NormalC name []) =+genTraverseClause :: Type -> Con -> Q ([Type], Clause)+genTraverseClause _ (NormalC name []) = (,) [] <$> TH.clause [wildP, conP name []] (normalB [| pure $(conE name) |]) []-genTraverseClause (NormalC name fieldTypes) = do+genTraverseClause _ (NormalC name fieldTypes) = do f <- newName "f" fieldNames <- replicateM (length fieldTypes) (newName "x") let pats = [varP f, conP name (map varP fieldNames)]@@ -455,7 +502,7 @@ 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+genTraverseClause _ (RecC name fields) = do f <- newName "f" x <- newName "x" let constraintsAndFields = map newField fields@@ -463,18 +510,20 @@ 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 (appE (varE fieldName) (varE x)) id+ 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 (GadtC [name] fieldTypes _resultType@(AppT _ (VarT tyVar))) =+genTraverseClause instanceType (GadtC [name] fieldTypes _resultType@(AppT initType (VarT tyVar))) = do Just (Deriving tyConName _tyVar) <- getQ putQ (Deriving tyConName tyVar)- genTraverseClause (NormalC name fieldTypes)-genTraverseClause (RecGadtC [name] fields _resultType@(AppT _ (VarT 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)- genTraverseClause (RecC name fields)-genTraverseClause (ForallC _vars _cxt con) = genTraverseClause con+ 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@@ -498,7 +547,7 @@ newNamedField :: VarBangType -> Q ([Type], (Name, Exp)) newNamedField (fieldName, _, fieldType) = ((,) fieldName <$>) <$> (genCotraverseField ''Rank2.Distributive (varE 'Rank2.cotraverse) (varE withName)- fieldType [| $(varE fieldName) <$> $(varE argName) |] id)+ fieldType [| $(projectField fieldName) <$> $(varE argName) |] id) constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields (,) constraints <$> TH.clause [varP withName, varP argName] body [] @@ -513,22 +562,23 @@ newNamedField (fieldName, _, fieldType) = ((,) fieldName <$>) <$> (genCotraverseField ''Rank2.DistributiveTraversable (varE 'Rank2.cotraverseTraversable) (varE withName) fieldType- [| $(varE fieldName) <$> $(varE argName) |] id)+ [| $(projectField fieldName) <$> $(varE argName) |] id) constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields (,) constraints <$> TH.clause [varP withName, varP argName] body [] -genDeliverClause :: Con -> Q ([Type], Clause)-genDeliverClause (NormalC name []) = genDeliverClause (RecC name [])-genDeliverClause (RecC name fields) = do+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 [|g|] [(,) fieldName <$> appE (wrap [| Rank2.apply set |]) [| $(varE fieldName) g |]]) |])- (\wrap-> [| \set g-> $(TH.recUpdE [|g|] [(,) fieldName <$> appE (wrap [| set |]) [| $(varE fieldName) g |]]) |])+ (\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)@@ -565,6 +615,60 @@ 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
− test/Doctest.hs
@@ -1,5 +0,0 @@-import 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"])
test/MyModule.lhs view
@@ -29,6 +29,7 @@ * [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@@ -211,9 +212,9 @@ 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 [hiddledy](https://hackage.haskell.org/package/higgledy).+[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, completely unlike database records. See+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.
test/TH.hs view
@@ -2,6 +2,7 @@ import Control.Applicative (liftA2) import Data.Foldable (fold, foldMap)+import Data.Kind (Type) import Data.Traversable (traverse) import Data.Distributive (cotraverse) import Data.Monoid (Dual, Sum(Sum), getDual)@@ -14,7 +15,7 @@ import Test.Tasty import Test.Tasty.HUnit -data Test0 (p :: * -> *) = Test0{} deriving (Eq, Show)+data Test0 (p :: Type -> Type) = Test0{} deriving (Eq, Show) data Test1 p = Test1{single :: p Int, whole :: Test0 p,@@ -43,6 +44,8 @@ wrapSingle= pure (pure ["a", "b", "ab"]), wrapWhole= pure (pure Test0)} id Rank2.<$> test @?= test+ Rank2.coerce test @?= test+ Rank2.coerce (Compose . Identity 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,