diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,6 +1,2 @@ -module Main where - -import Distribution.Extra.Doctest (defaultMainWithDoctests) - -main :: IO () -main = defaultMainWithDoctests "doctests" +import Distribution.Simple +main = defaultMain diff --git a/rank2classes.cabal b/rank2classes.cabal --- a/rank2classes.cabal +++ b/rank2classes.cabal @@ -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ć 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 diff --git a/src/Rank2.hs b/src/Rank2.hs --- a/src/Rank2.hs +++ b/src/Rank2.hs @@ -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 diff --git a/src/Rank2/TH.hs b/src/Rank2/TH.hs --- a/src/Rank2/TH.hs +++ b/src/Rank2/TH.hs @@ -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 diff --git a/test/Doctest.hs b/test/Doctest.hs deleted file mode 100644 --- a/test/Doctest.hs +++ /dev/null @@ -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"]) diff --git a/test/MyModule.lhs b/test/MyModule.lhs --- a/test/MyModule.lhs +++ b/test/MyModule.lhs @@ -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. diff --git a/test/TH.hs b/test/TH.hs --- a/test/TH.hs +++ b/test/TH.hs @@ -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,