diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +Version 1.4.3 +--------------- +* Fixed links to standard rank-1 classes in Haddock documentation +* Fixed issue #23 with the `traverse` template generated for sum types with a fieldless constructor +* Incremented upper dependency bounds + Version 1.4.2 --------------- * Fixed compatibility with GHC 9 - PR by Felix Yan diff --git a/rank2classes.cabal b/rank2classes.cabal --- a/rank2classes.cabal +++ b/rank2classes.cabal @@ -1,5 +1,5 @@ name: rank2classes -version: 1.4.2 +version: 1.4.3 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 @@ -15,8 +15,8 @@ copyright: (c) 2017 Mario Blažević category: Control, Data, Generics build-type: Custom --- extra-source-files: 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 extra-source-files: README.md, CHANGELOG.md, test/MyModule.lhs source-repository head type: git @@ -38,8 +38,8 @@ default-language: Haskell2010 -- other-modules: ghc-options: -Wall - build-depends: base >=4.10 && <5, - transformers >= 0.5 && < 0.6, + build-depends: base >=4.9 && <5, + transformers >= 0.5 && < 0.7, distributive < 0.7 if flag(use-template-haskell) @@ -63,6 +63,7 @@ hs-source-dirs: test default-language: Haskell2010 main-is: TH.hs + other-modules: Issue23 ghc-options: -threaded -pgmL markdown-unlit build-depends: base, rank2classes, distributive < 0.7, tasty < 2, tasty-hunit < 1 diff --git a/src/Rank2.hs b/src/Rank2.hs --- a/src/Rank2.hs +++ b/src/Rank2.hs @@ -45,7 +45,7 @@ snd :: Product g h p -> h p snd (Pair _ y) = y --- | Equivalent of 'Functor' for rank 2 data types, satisfying the usual functor laws +-- | Equivalent of 'Rank1.Functor' for rank 2 data types, satisfying the usual functor laws -- -- > id <$> g == g -- > (p . q) <$> g == p <$> (q <$> g) @@ -58,11 +58,11 @@ fmap f g = f <$> g {-# INLINE fmap #-} --- | Equivalent of 'Foldable' for rank 2 data types +-- | Equivalent of 'Rank1.Foldable' for rank 2 data types class Foldable g where foldMap :: Monoid m => (forall a. p a -> m) -> g p -> m --- | Equivalent of 'Traversable' for rank 2 data types +-- | Equivalent of 'Rank1.Traversable' for rank 2 data types class (Functor g, Foldable g) => Traversable g where {-# MINIMAL traverse | sequence #-} traverse :: Rank1.Applicative m => (forall a. p a -> m (q a)) -> g p -> m (g q) diff --git a/src/Rank2/TH.hs b/src/Rank2/TH.hs --- a/src/Rank2/TH.hs +++ b/src/Rank2/TH.hs @@ -421,7 +421,7 @@ genTraverseClause :: Con -> Q ([Type], Clause) genTraverseClause (NormalC name []) = - (,) [] <$> clause [wildP, wildP] (normalB [| pure $(conE name) |]) [] + (,) [] <$> clause [wildP, conP name []] (normalB [| pure $(conE name) |]) [] genTraverseClause (NormalC name fieldTypes) = do f <- newName "f" fieldNames <- replicateM (length fieldTypes) (newName "x") diff --git a/test/Issue23.hs b/test/Issue23.hs new file mode 100644 --- /dev/null +++ b/test/Issue23.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Issue23 (test) where + +import Data.Functor.Identity +import Data.Functor.Classes +import qualified Rank2 +import qualified Rank2.TH + +import Test.Tasty (TestTree) +import Test.Tasty.HUnit (testCase, assertEqual) + +data Stm r = Unit | ExpStmt (r Int) (Exp r) +data Exp r = Nil | Cons (r Bool) (Exp r) (Stm r) + +instance Show1 r => Show (Stm r) where + show Unit = "Unit" + show (ExpStmt r e) = "(Stmt (" ++ showsPrec1 0 r (") " ++ show e ++ ")") +instance Show1 r => Show (Exp r) where + show Nil = "Nil" + show (Cons r e s) = + "(Cons (" ++ showsPrec1 0 r (") " ++ show e ++ " " ++ show s ++ ")") + +$(mconcat <$> traverse + (\derive -> mconcat <$> traverse derive [''Stm, ''Exp]) + [ Rank2.TH.deriveFunctor + , Rank2.TH.deriveFoldable + , Rank2.TH.deriveTraversable + ]) + +expToMaybe :: Exp Identity -> Exp Maybe +expToMaybe = Rank2.fmap (Just . runIdentity) + +maybeToExp :: Exp Maybe -> Maybe (Exp Identity) +maybeToExp = Rank2.traverse (fmap Identity) + +myExp :: Exp Identity +myExp = Cons + (Identity True) + (Cons (Identity False) Nil (ExpStmt (Identity 2) Nil)) + (ExpStmt (Identity 3) (Cons (Identity True) Nil Unit)) + +test :: TestTree +test = testCase "Issue #23" $ do + print myExp + let myExp' = expToMaybe myExp + assertEqual "" (show $ Just myExp) (show $ maybeToExp myExp') diff --git a/test/TH.hs b/test/TH.hs --- a/test/TH.hs +++ b/test/TH.hs @@ -8,6 +8,7 @@ import Data.Functor.Classes (Eq1, Show1, eq1, showsPrec1) import Data.Functor.Compose (Compose(Compose)) import Data.Functor.Identity (Identity(Identity, runIdentity)) +import qualified Issue23 import qualified Rank2 import qualified Rank2.TH import Test.Tasty @@ -35,57 +36,59 @@ $(Rank2.TH.deriveAll ''Test0) $(Rank2.TH.deriveAll ''Test1) -main = defaultMain $ testCase "Template test" $ - do let test = Test1{single= [3, 4, 5], - whole= Test0, - wrapSingle= pure (pure ["a", "b", "ab"]), - wrapWhole= pure (pure Test0)} - id Rank2.<$> test @?= test - Rank2.pure (Rank2.Arrow id) Rank2.<*> test @?= test - Rank2.liftA2 (++) test test @?= Test1{single= [3, 4, 5, 3, 4, 5], - whole= Test0, - wrapSingle= pure (pure ["a", "b", "ab", "a", "b", "ab"]), - wrapWhole= pure (pure Test0)} - Rank2.foldMap (Sum . length) test @?= Sum 6 - Rank2.traverse (map Identity) test @?= [Test1{single= Identity 3, - whole= Test0, - wrapSingle= pure (pure $ Identity "a"), - wrapWhole= pure (pure Test0)}, - Test1{single= Identity 3, - whole= Test0, - wrapSingle= pure (pure $ Identity "b"), - wrapWhole= pure (pure Test0)}, - Test1{single= Identity 3, - whole= Test0, - wrapSingle= pure (pure $ Identity "ab"), - wrapWhole= pure (pure Test0)}, - Test1{single= Identity 4, - whole= Test0, - wrapSingle= pure (pure $ Identity "a"), - wrapWhole= pure (pure Test0)}, - Test1{single= Identity 4, - whole= Test0, - wrapSingle= pure (pure $ Identity "b"), - wrapWhole= pure (pure Test0)}, - Test1{single= Identity 4, - whole= Test0, - wrapSingle= pure (pure $ Identity "ab"), - wrapWhole= pure (pure Test0)}, - Test1{single= Identity 5, - whole= Test0, - wrapSingle= pure (pure $ Identity "a"), - wrapWhole= pure (pure Test0)}, - Test1{single= Identity 5, - whole= Test0, - wrapSingle= pure (pure $ Identity "b"), - wrapWhole= pure (pure Test0)}, - Test1{single= Identity 5, - whole= Test0, - wrapSingle= pure (pure $ Identity "ab"), - wrapWhole= pure (pure Test0)} - ] - Rank2.distribute (Identity test) @?= Test1{single= Compose (Identity [3, 4, 5]), - whole= Test0, - wrapSingle= pure (pure $ Compose $ Identity ["a", "b", "ab"]), - wrapWhole= pure (pure Test0)} - Rank2.cotraverse (take 1 . map runIdentity) (Rank2.traverse (map Identity) test) @?= take 1 Rank2.<$> test +main = defaultMain $ testGroup "Template tests" + [ testCase "Simple template test" $ + do let test = Test1{single= [3, 4, 5], + whole= Test0, + wrapSingle= pure (pure ["a", "b", "ab"]), + wrapWhole= pure (pure Test0)} + id Rank2.<$> test @?= test + Rank2.pure (Rank2.Arrow id) Rank2.<*> test @?= test + Rank2.liftA2 (++) test test @?= Test1{single= [3, 4, 5, 3, 4, 5], + whole= Test0, + wrapSingle= pure (pure ["a", "b", "ab", "a", "b", "ab"]), + wrapWhole= pure (pure Test0)} + Rank2.foldMap (Sum . length) test @?= Sum 6 + Rank2.traverse (map Identity) test @?= [Test1{single= Identity 3, + whole= Test0, + wrapSingle= pure (pure $ Identity "a"), + wrapWhole= pure (pure Test0)}, + Test1{single= Identity 3, + whole= Test0, + wrapSingle= pure (pure $ Identity "b"), + wrapWhole= pure (pure Test0)}, + Test1{single= Identity 3, + whole= Test0, + wrapSingle= pure (pure $ Identity "ab"), + wrapWhole= pure (pure Test0)}, + Test1{single= Identity 4, + whole= Test0, + wrapSingle= pure (pure $ Identity "a"), + wrapWhole= pure (pure Test0)}, + Test1{single= Identity 4, + whole= Test0, + wrapSingle= pure (pure $ Identity "b"), + wrapWhole= pure (pure Test0)}, + Test1{single= Identity 4, + whole= Test0, + wrapSingle= pure (pure $ Identity "ab"), + wrapWhole= pure (pure Test0)}, + Test1{single= Identity 5, + whole= Test0, + wrapSingle= pure (pure $ Identity "a"), + wrapWhole= pure (pure Test0)}, + Test1{single= Identity 5, + whole= Test0, + wrapSingle= pure (pure $ Identity "b"), + wrapWhole= pure (pure Test0)}, + Test1{single= Identity 5, + whole= Test0, + wrapSingle= pure (pure $ Identity "ab"), + wrapWhole= pure (pure Test0)} + ] + Rank2.distribute (Identity test) @?= Test1{single= Compose (Identity [3, 4, 5]), + whole= Test0, + wrapSingle= pure (pure $ Compose $ Identity ["a", "b", "ab"]), + wrapWhole= pure (pure Test0)} + Rank2.cotraverse (take 1 . map runIdentity) (Rank2.traverse (map Identity) test) @?= take 1 Rank2.<$> test, + Issue23.test]