diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +Version 1.3.2.1 +--------------- +* Incremented the upper bound of the template-haskell dependency + +Version 1.3.2 +--------------- +* Exported the `$` synonym for `apply` + Version 1.3.1.2 --------------- * Fixed doctest module name issue diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -22,13 +22,14 @@ ~~~ 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) + * [Rank2.Functor](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Functor) + * [Rank2.Apply](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Apply) + * [Rank2.Applicative](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Applicative) + * [Rank2.Foldable](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Foldable) + * [Rank2.Traversable](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Traversable) + * [Rank2.Distributive](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Distributive) + The methods of these type classes all have rank-2 types. The class instances are data types of kind `(k -> *) -> *`, one example of which would be a database record with different field types but all wrapped by the same type constructor: @@ -111,8 +112,8 @@ 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 +We can apply it using the [Rank2.<*>](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#v:-60--42--62-) +method of the [Rank2.Apply](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Apply) type class to a bunch of textual fields for `Person`, and get back either errors or proper field values: ~~~ {.haskell} @@ -121,7 +122,7 @@ ~~~ 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: +[Rank2.traverse](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#v:traverse) to the result: ~~~ {.haskell} completeVerified :: PersonWithErrors -> Either String PersonVerified @@ -129,7 +130,7 @@ ~~~ or we can go in the opposite direction with -[Rank2.<$>](http://hackage.haskell.org/packages/rank2/doc/html/Rank2.html#v:-60--36--62-): +[Rank2.<$>](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#v:-60--36--62-): ~~~ {.haskell} uncompleteVerified :: PersonVerified -> PersonWithErrors @@ -137,7 +138,7 @@ ~~~ 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): +[Rank2.foldMap](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#v:foldMap): ~~~ {.haskell} verificationErrors :: PersonWithErrors -> [String] diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,6 @@ -import Distribution.Simple -main = defaultMain +module Main where + +import Distribution.Extra.Doctest (defaultMainWithDoctests) + +main :: IO () +main = defaultMainWithDoctests "doctests" diff --git a/rank2classes.cabal b/rank2classes.cabal --- a/rank2classes.cabal +++ b/rank2classes.cabal @@ -1,5 +1,5 @@ name: rank2classes -version: 1.3.1.2 +version: 1.3.2.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,13 +14,18 @@ maintainer: Mario Blažević copyright: (c) 2017 Mario Blažević category: Control, Data, Generics -build-type: Simple +build-type: Custom -- extra-source-files: cabal-version: >=1.10 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 @@ -38,7 +43,7 @@ distributive < 0.7 if flag(use-template-haskell) - build-depends: template-haskell >= 2.11 && < 2.15 + build-depends: template-haskell >= 2.11 && < 2.16 exposed-modules: Rank2.TH test-suite doctests diff --git a/src/Rank2.hs b/src/Rank2.hs --- a/src/Rank2.hs +++ b/src/Rank2.hs @@ -15,7 +15,7 @@ -- * Rank 2 data types Compose(..), Empty(..), Only(..), Flip(..), Identity(..), Product(..), Sum(..), Arrow(..), type (~>), -- * Method synonyms and helper functions - fst, snd, ap, fmap, liftA4, liftA5, + ($), fst, snd, ap, fmap, liftA4, liftA5, fmapTraverse, liftA2Traverse1, liftA2Traverse2, liftA2TraverseBoth, distributeWith, distributeWithTraversable) where @@ -34,7 +34,7 @@ import Data.Proxy (Proxy(..)) import qualified GHC.Generics as Generics -import Prelude hiding (Foldable(..), Traversable(..), Functor(..), Applicative(..), (<$>), fst, snd) +import Prelude hiding (Foldable(..), Traversable(..), Functor(..), Applicative(..), ($), (<$>), fst, snd) -- | Helper function for accessing the first field of a 'Pair' fst :: Product g h p -> g p @@ -72,7 +72,10 @@ newtype Arrow p q a = Arrow{apply :: p a -> q a} type (~>) = Arrow +($) :: Arrow p q a -> p a -> q a +($) = apply infixr 0 ~> +infixr 0 $ -- | Subclass of 'Functor' halfway to 'Applicative', satisfying -- @@ -134,22 +137,22 @@ distributeJoin = cotraverse Rank1.join -- | Like 'fmap', but traverses over its argument -fmapTraverse :: (DistributiveTraversable f, Rank1.Traversable g) => (forall a. g (t a) -> u a) -> g (f t) -> f u +fmapTraverse :: (DistributiveTraversable g, Rank1.Traversable f) => (forall a. f (t a) -> u a) -> f (g t) -> g u fmapTraverse f x = fmap (f . getCompose) (distributeTraversable x) -- | Like 'liftA2', but traverses over its first argument -liftA2Traverse1 :: (Apply f, DistributiveTraversable f, Rank1.Traversable g) => - (forall a. g (t a) -> u a -> v a) -> g (f t) -> f u -> f v +liftA2Traverse1 :: (Apply g, DistributiveTraversable g, Rank1.Traversable f) => + (forall a. f (t a) -> u a -> v a) -> f (g t) -> g u -> g v liftA2Traverse1 f x = liftA2 (f . getCompose) (distributeTraversable x) -- | Like 'liftA2', but traverses over its second argument -liftA2Traverse2 :: (Apply f, DistributiveTraversable f, Rank1.Traversable g) => - (forall a. t a -> g (u a) -> v a) -> f t -> g (f u) -> f v +liftA2Traverse2 :: (Apply g, DistributiveTraversable g, Rank1.Traversable f) => + (forall a. t a -> f (u a) -> v a) -> g t -> f (g u) -> g v liftA2Traverse2 f x y = liftA2 (\x' y' -> f x' (getCompose y')) x (distributeTraversable y) -- | Like 'liftA2', but traverses over both its arguments -liftA2TraverseBoth :: (Apply f, DistributiveTraversable f, Rank1.Traversable g1, Rank1.Traversable g2) => - (forall a. g1 (t a) -> g2 (u a) -> v a) -> g1 (f t) -> g2 (f u) -> f v +liftA2TraverseBoth :: (Apply g, DistributiveTraversable g, Rank1.Traversable f1, Rank1.Traversable f2) => + (forall a. f1 (t a) -> f2 (u a) -> v a) -> f1 (g t) -> f2 (g u) -> g v liftA2TraverseBoth f x y = liftA2 applyCompose (distributeTraversable x) (distributeTraversable y) where applyCompose x' y' = f (getCompose x') (getCompose y') @@ -410,10 +413,10 @@ instance DistributiveTraversable Proxy instance DistributiveTraversable (Only x) instance DistributiveTraversable g => DistributiveTraversable (Identity g) where - cotraverseTraversable w f = Identity (cotraverseTraversable w $ Rank1.fmap runIdentity f) + cotraverseTraversable w f = Identity (cotraverseTraversable w (Rank1.fmap runIdentity f)) instance (DistributiveTraversable g, DistributiveTraversable h) => DistributiveTraversable (Product g h) where - cotraverseTraversable w f = Pair (cotraverseTraversable w $ Rank1.fmap fst f) - (cotraverseTraversable w $ Rank1.fmap snd f) + cotraverseTraversable w f = Pair (cotraverseTraversable w (Rank1.fmap fst f)) + (cotraverseTraversable w (Rank1.fmap snd f)) instance DistributiveTraversable f => DistributiveTraversable (Generics.M1 i c f) where cotraverseTraversable w f = Generics.M1 (cotraverseTraversable w (Rank1.fmap Generics.unM1 f)) @@ -432,13 +435,13 @@ cotraverseTraversable _ f = coerce (Rank1.fold f) instance Distributive (Only x) where - cotraverse w f = Only (w $ Rank1.fmap fromOnly f) + cotraverse w f = Only (w (Rank1.fmap fromOnly f)) instance Distributive g => Distributive (Identity g) where - cotraverse w f = Identity (cotraverse w $ Rank1.fmap runIdentity f) + cotraverse w f = Identity (cotraverse w (Rank1.fmap runIdentity f)) instance (Distributive g, Distributive h) => Distributive (Product g h) where - cotraverse w f = Pair (cotraverse w $ Rank1.fmap fst f) (cotraverse w $ Rank1.fmap snd f) + 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.fold f) diff --git a/src/Rank2/TH.hs b/src/Rank2/TH.hs --- a/src/Rank2/TH.hs +++ b/src/Rank2/TH.hs @@ -197,14 +197,13 @@ genLiftA2Clause unsafely (NormalC name fieldTypes) = do f <- newName "f" fieldNames1 <- replicateM (length fieldTypes) (newName "x") + y <- newName "y" fieldNames2 <- replicateM (length fieldTypes) (newName "y") - let pats = [varP f, - conP name (map varP fieldNames1), - tildeP (conP name $ map varP fieldNames2)] + let pats = [varP f, conP name (map varP fieldNames1), varP y] body = normalB $ appsE $ conE name : zipWith newField (zip fieldNames1 fieldNames2) fieldTypes newField :: (Name, Name) -> BangType -> Q Exp newField (x, y) (_, fieldType) = genLiftA2Field unsafely (varE f) fieldType (varE x) (varE y) id - clause pats body [] + clause pats body [valD (conP name $ map varP fieldNames2) (normalB $ varE y) []] genLiftA2Clause unsafely (RecC name fields) = do f <- newName "f" x <- newName "x" @@ -215,6 +214,15 @@ fieldExp fieldName (genLiftA2Field unsafely (varE f) fieldType (getFieldOf x) (getFieldOf y) id) where getFieldOf = appE (varE fieldName) . varE clause [varP f, bangP (varP x), varP y] body [] +genLiftA2Clause unsafely (GadtC [name] fieldTypes _resultType@(AppT _ (VarT tyVar))) = + do Just (Deriving tyConName _tyVar) <- getQ + putQ (Deriving tyConName tyVar) + genLiftA2Clause unsafely (NormalC name fieldTypes) +genLiftA2Clause unsafely (RecGadtC [name] fields _resultType@(AppT _ (VarT tyVar))) = + do Just (Deriving tyConName _tyVar) <- getQ + putQ (Deriving tyConName tyVar) + genLiftA2Clause unsafely (RecC name fields) +genLiftA2Clause unsafely (ForallC _vars _cxt con) = genLiftA2Clause unsafely con genLiftA2Field :: Bool -> Q Exp -> Type -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp genLiftA2Field unsafely fun fieldType field1Access field2Access wrap = do @@ -233,16 +241,16 @@ genLiftA3Clause unsafely (NormalC name fieldTypes) = do f <- newName "f" fieldNames1 <- replicateM (length fieldTypes) (newName "x") + y <- newName "y" + z <- newName "z" fieldNames2 <- replicateM (length fieldTypes) (newName "y") fieldNames3 <- replicateM (length fieldTypes) (newName "z") - let pats = [varP f, - conP name (map varP fieldNames1), - tildeP (conP name $ map varP fieldNames2), - tildeP (conP name $ map varP fieldNames3)] + let pats = [varP f, conP name (map varP fieldNames1), varP y, varP z] body = normalB $ appsE $ conE name : zipWith newField (zip3 fieldNames1 fieldNames2 fieldNames3) fieldTypes newField :: (Name, Name, Name) -> BangType -> Q Exp newField (x, y, z) (_, fieldType) = genLiftA3Field unsafely (varE f) fieldType (varE x) (varE y) (varE z) id - clause pats body [] + clause pats body [valD (conP name $ map varP fieldNames2) (normalB $ varE y) [], + valD (conP name $ map varP fieldNames3) (normalB $ varE z) []] genLiftA3Clause unsafely (RecC name fields) = do f <- newName "f" x <- newName "x" @@ -254,6 +262,15 @@ fieldExp fieldName (genLiftA3Field unsafely (varE f) fieldType (getFieldOf x) (getFieldOf y) (getFieldOf z) id) where getFieldOf = appE (varE fieldName) . varE clause [varP f, bangP (varP x), varP y, varP z] body [] +genLiftA3Clause unsafely (GadtC [name] fieldTypes _resultType@(AppT _ (VarT tyVar))) = + do Just (Deriving tyConName _tyVar) <- getQ + putQ (Deriving tyConName tyVar) + genLiftA3Clause unsafely (NormalC name fieldTypes) +genLiftA3Clause unsafely (RecGadtC [name] fields _resultType@(AppT _ (VarT tyVar))) = + do Just (Deriving tyConName _tyVar) <- getQ + putQ (Deriving tyConName tyVar) + genLiftA3Clause unsafely (RecC name fields) +genLiftA3Clause unsafely (ForallC _vars _cxt con) = genLiftA3Clause unsafely con genLiftA3Field :: Bool -> Q Exp -> Type -> Q Exp -> Q Exp -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp genLiftA3Field unsafely fun fieldType field1Access field2Access field3Access wrap = do @@ -275,15 +292,15 @@ genApClause unsafely (NormalC name fieldTypes) = do fieldNames1 <- replicateM (length fieldTypes) (newName "x") fieldNames2 <- replicateM (length fieldTypes) (newName "y") - let pats = [conP name (map varP fieldNames1), - tildeP (conP name $ map varP fieldNames2)] + rhsName <- newName "rhs" + let pats = [conP name (map varP fieldNames1), varP rhsName] constraintsAndFields = zipWith newField (zip fieldNames1 fieldNames2) fieldTypes newFields = map (snd <$>) constraintsAndFields body = normalB $ appsE $ conE name : newFields newField :: (Name, Name) -> BangType -> Q ([Type], Exp) newField (x, y) (_, fieldType) = genApField unsafely fieldType (varE x) (varE y) id constraints <- (concat . (fst <$>)) <$> sequence constraintsAndFields - (,) constraints <$> clause pats body [] + (,) constraints <$> clause pats body [valD (conP name $ map varP fieldNames2) (normalB $ varE rhsName) []] genApClause unsafely (RecC name fields) = do x <- newName "x" y <- newName "y" diff --git a/test/Doctest.hs b/test/Doctest.hs --- a/test/Doctest.hs +++ b/test/Doctest.hs @@ -1,3 +1,5 @@ -import Test.DocTest +import Build_doctests (flags, pkgs, module_sources) +import Test.DocTest (doctest) -main = doctest ["-pgmL", "markdown-unlit", "-isrc", "test/MyModule.lhs"] +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 @@ -22,13 +22,14 @@ ~~~ 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) + * [Rank2.Functor](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Functor) + * [Rank2.Apply](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Apply) + * [Rank2.Applicative](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Applicative) + * [Rank2.Foldable](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Foldable) + * [Rank2.Traversable](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Traversable) + * [Rank2.Distributive](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Distributive) + The methods of these type classes all have rank-2 types. The class instances are data types of kind `(k -> *) -> *`, one example of which would be a database record with different field types but all wrapped by the same type constructor: @@ -111,8 +112,8 @@ 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 +We can apply it using the [Rank2.<*>](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#v:-60--42--62-) +method of the [Rank2.Apply](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#t:Apply) type class to a bunch of textual fields for `Person`, and get back either errors or proper field values: ~~~ {.haskell} @@ -121,7 +122,7 @@ ~~~ 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: +[Rank2.traverse](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#v:traverse) to the result: ~~~ {.haskell} completeVerified :: PersonWithErrors -> Either String PersonVerified @@ -129,7 +130,7 @@ ~~~ or we can go in the opposite direction with -[Rank2.<$>](http://hackage.haskell.org/packages/rank2/doc/html/Rank2.html#v:-60--36--62-): +[Rank2.<$>](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#v:-60--36--62-): ~~~ {.haskell} uncompleteVerified :: PersonVerified -> PersonWithErrors @@ -137,7 +138,7 @@ ~~~ 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): +[Rank2.foldMap](http://hackage.haskell.org/package/rank2classes/docs/Rank2.html#v:foldMap): ~~~ {.haskell} verificationErrors :: PersonWithErrors -> [String]