rank2classes 1.1.0.1 → 1.2

raw patch · 4 files changed

+37/−9 lines, 4 filesdep ~template-haskell

Dependency ranges changed: template-haskell

Files

CHANGELOG.md +5/−0
rank2classes.cabal +2/−2
src/Rank2.hs +21/−0
src/Rank2/TH.hs +9/−7

CHANGELOG.md view

@@ -1,3 +1,8 @@+Version 1.2+---------------+* Added the class instances for Data.Functor.Const+* Fixed and optimized the Foldable/Traversable instance code generated for bare fields in Rank2.TH+ Version 1.1 --------------- * Replaced own `Product` data type by the one from `Data.Functor.Product`

rank2classes.cabal view

@@ -1,5 +1,5 @@ name:                rank2classes-version:             1.1.0.1+version:             1.2 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@@ -38,7 +38,7 @@                        distributive < 0.7    if flag(use-template-haskell)-    build-depends: template-haskell >= 2.11 && < 2.14+    build-depends: template-haskell >= 2.11 && < 2.15     exposed-modules: Rank2.TH  test-suite doctests

src/Rank2.hs view

@@ -23,9 +23,11 @@ import qualified Control.Monad as Rank1 import qualified Data.Foldable as Rank1 import qualified Data.Traversable as Rank1+import Data.Coerce (coerce) import Data.Semigroup (Semigroup(..)) import Data.Monoid (Monoid(..)) import Data.Functor.Compose (Compose(..))+import Data.Functor.Const (Const(..)) import Data.Functor.Product (Product(..)) import Data.Functor.Sum (Sum(..)) @@ -195,6 +197,9 @@ instance Functor Empty where    _ <$> _ = Empty +instance Functor (Const a) where+   _ <$> Const a = Const a+ instance Functor (Only a) where    f <$> Only a = Only (f a) @@ -211,6 +216,9 @@ instance Foldable Empty where    foldMap _ _ = mempty +instance Foldable (Const x) where+   foldMap _ _ = mempty+ instance Foldable (Only x) where    foldMap f (Only x) = f x @@ -227,6 +235,9 @@ instance Traversable Empty where    traverse _ _ = Rank1.pure Empty +instance Traversable (Const x) where+   traverse _ (Const x) = Rank1.pure (Const x)+ instance Traversable (Only x) where    traverse f (Only x) = Only Rank1.<$> f x @@ -244,6 +255,10 @@    _ <*> _ = Empty    liftA2 _ _ _ = Empty +instance Semigroup x => Apply (Const x) where+   Const x <*> Const y = Const (x <> y)+   liftA2 _ (Const x) (Const y) = Const (x <> y)+ instance Apply (Only x) where    Only f <*> Only x = Only (apply f x)    liftA2 f (Only x) (Only y) = Only (f x y)@@ -259,6 +274,9 @@ instance Applicative Empty where    pure = const Empty +instance (Semigroup x, Monoid x) => Applicative (Const x) where+   pure = const (Const mempty)+ instance Applicative (Only x) where    pure = Only @@ -278,6 +296,9 @@  instance Distributive Empty where    cotraverse _ _ = Empty++instance Monoid x => DistributiveTraversable (Const x) where+   cotraverseTraversable _ f = coerce (Rank1.fold f)  instance Distributive (Only x) where    cotraverse w f = Only (w $ Rank1.fmap fromOnly f)

src/Rank2/TH.hs view

@@ -2,7 +2,7 @@ -- use it would be -- -- > import qualified Rank2.TH--- > data MyDataType = ...+-- > data MyDataType f = ... -- > $(Rank2.TH.deriveAll ''MyDataType) -- -- or, if you're picky, you can invoke only 'deriveFunctor' and whichever other instances you need instead.@@ -268,19 +268,21 @@    f          <- newName "f"    fieldNames <- replicateM (length fieldTypes) (newName "x")    let pats = [varP f, tildeP (conP name $ map varP fieldNames)]-       body = normalB $ foldr append [| mempty |] $ zipWith newField fieldNames fieldTypes+       body | null fieldNames = [| mempty |]+            | otherwise = foldr1 append $ zipWith newField fieldNames fieldTypes        append a b = [| $(a) <> $(b) |]        newField :: Name -> BangType -> Q Exp        newField x (_, fieldType) = genFoldMapField f fieldType (varE x) id-   clause pats body []+   clause pats (normalB body) [] genFoldMapClause (RecC _name fields) = do    f <- newName "f"    x <- newName "x"-   let body = normalB $ foldr append [| mempty |] $ map newField fields+   let body | null fields = [| mempty |]+            | otherwise = foldr1 append $ map newField fields        append a b = [| $(a) <> $(b) |]        newField :: VarBangType -> Q Exp        newField (fieldName, _, fieldType) = genFoldMapField f fieldType (appE (varE fieldName) (varE x)) id-   clause [varP f, varP x] body []+   clause [varP f, varP x] (normalB body) []  genFoldMapField :: Name -> Type -> Q Exp -> (Q Exp -> Q Exp) -> Q Exp genFoldMapField funcName fieldType fieldAccess wrap = do@@ -291,7 +293,7 @@      AppT t1 t2 | t1 /= VarT typeVar -> genFoldMapField funcName t2 fieldAccess (wrap . appE (varE 'foldMap))      SigT ty _kind -> genFoldMapField funcName ty fieldAccess wrap      ParensT ty -> genFoldMapField funcName ty fieldAccess wrap-     _ -> fieldAccess+     _ -> [| mempty |]  genTraverseClause :: Con -> Q Clause genTraverseClause (NormalC name []) =@@ -325,7 +327,7 @@      AppT t1 t2 | t1 /= VarT typeVar -> genTraverseField fun t2 fieldAccess (wrap . appE (varE 'traverse))      SigT ty _kind -> genTraverseField fun ty fieldAccess wrap      ParensT ty -> genTraverseField fun ty fieldAccess wrap-     _ -> fieldAccess+     _ -> [| pure $fieldAccess |]  genCotraverseClause :: Con -> Q Clause genCotraverseClause (NormalC name []) = genCotraverseClause (RecC name [])