diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,9 @@ +5.3 +--- +* Added `bifoldr1`, `bifoldl1`, `bimsum`, `biasum`, `binull`, `bilength`, `bielem`, `bimaximum`, `biminimum`, `bisum`, `biproduct`, `biand`, `bior`, `bimaximumBy`, `biminimumBy`, `binotElem`, and `bifind` to `Data.Bifoldable` +* Added `Bifunctor`, `Bifoldable`, and `Bitraversable` instances for `GHC.Generics.K1` +* TH code no longer generates superfluous `mempty` or `pure` subexpressions in derived `Bifoldable` or `Bitraversable` instances, respectively + 5.2.1 ---- * Added `Bifoldable` and `Bitraversable` instances for `Constant` from `transformers` diff --git a/bifunctors.cabal b/bifunctors.cabal --- a/bifunctors.cabal +++ b/bifunctors.cabal @@ -1,6 +1,6 @@ name: bifunctors category: Data, Functors -version: 5.2.1 +version: 5.3 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE @@ -39,12 +39,13 @@ library hs-source-dirs: src build-depends: - base >= 4 && < 5, - comonad >= 4 && < 6, - containers >= 0.1 && < 0.6, - template-haskell >= 2.4 && < 2.12, - transformers >= 0.2 && < 0.6, - transformers-compat >= 0.5 && < 0.6 + base >= 4 && < 5, + base-orphans >= 0.5.2 && < 1, + comonad >= 4 && < 6, + containers >= 0.1 && < 0.6, + template-haskell >= 2.4 && < 2.12, + transformers >= 0.2 && < 0.6, + transformers-compat >= 0.5 && < 0.6 if flag(tagged) build-depends: tagged >= 0.7.3 && < 1 diff --git a/old-src/Data/Bifunctor.hs b/old-src/Data/Bifunctor.hs --- a/old-src/Data/Bifunctor.hs +++ b/old-src/Data/Bifunctor.hs @@ -36,6 +36,10 @@ import Data.Tagged #endif +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Generics (K1(..)) +#endif + #if __GLASGOW_HASKELL__ >= 708 import Data.Typeable #endif @@ -143,6 +147,12 @@ instance Bifunctor Constant where bimap f _ (Constant a) = Constant (f a) {-# INLINE bimap #-} + +#if __GLASGOW_HASKELL__ >= 702 +instance Bifunctor (K1 i) where + bimap f _ (K1 c) = K1 (f c) + {-# INLINE bimap #-} +#endif #ifdef MIN_VERSION_tagged instance Bifunctor Tagged where diff --git a/src/Data/Biapplicative.hs b/src/Data/Biapplicative.hs --- a/src/Data/Biapplicative.hs +++ b/src/Data/Biapplicative.hs @@ -26,12 +26,14 @@ import Control.Applicative import Data.Bifunctor -#if MIN_VERSION_semigroups(0,16,2) -import Data.Semigroup -#else +#if !(MIN_VERSION_base(4,8,0)) import Data.Monoid #endif +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2) +import Data.Semigroup (Arg(..)) +#endif + #ifdef MIN_VERSION_tagged import Data.Tagged #endif @@ -82,7 +84,7 @@ (f, g) <<*>> (a, b) = (f a, g b) {-# INLINE (<<*>>) #-} -#if MIN_VERSION_semigroups(0,16,2) +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2) instance Biapplicative Arg where bipure = Arg {-# INLINE bipure #-} diff --git a/src/Data/Bifoldable.hs b/src/Data/Bifoldable.hs --- a/src/Data/Bifoldable.hs +++ b/src/Data/Bifoldable.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} #ifndef MIN_VERSION_semigroups @@ -18,35 +19,57 @@ module Data.Bifoldable ( Bifoldable(..) , bifoldr' + , bifoldr1 , bifoldrM , bifoldl' + , bifoldl1 , bifoldlM , bitraverse_ , bifor_ , bimapM_ , biforM_ + , bimsum , bisequenceA_ , bisequence_ + , biasum , biList + , binull + , bilength + , bielem + , bimaximum + , biminimum + , bisum + , biproduct , biconcat , biconcatMap + , biand + , bior , biany , biall + , bimaximumBy + , biminimumBy + , binotElem + , bifind ) where import Control.Applicative +import Control.Monad import Data.Functor.Constant - -#if MIN_VERSION_semigroups(0,16,2) -import Data.Semigroup -#else +import Data.Maybe (fromMaybe) import Data.Monoid + +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2) +import Data.Semigroup (Arg(..)) #endif #ifdef MIN_VERSION_tagged import Data.Tagged #endif +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Generics (K1(..)) +#endif + #if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 import Data.Typeable #endif @@ -113,7 +136,7 @@ deriving instance Typeable Bifoldable #endif -#if MIN_VERSION_semigroups(0,16,2) +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2) instance Bifoldable Arg where bifoldMap f g (Arg a b) = f a `mappend` g b #endif @@ -130,6 +153,12 @@ bifoldMap f _ (Constant a) = f a {-# INLINE bifoldMap #-} +#if __GLASGOW_HASKELL__ >= 702 +instance Bifoldable (K1 i) where + bifoldMap f _ (K1 c) = f c + {-# INLINE bifoldMap #-} +#endif + instance Bifoldable ((,,) x) where bifoldMap f g ~(_,a,b) = f a `mappend` g b {-# INLINE bifoldMap #-} @@ -169,6 +198,17 @@ g' k x z = k $! g x z {-# INLINE bifoldr' #-} +-- | A variant of 'bifoldr' that has no base case, +-- and thus may only be applied to non-empty structures. +bifoldr1 :: Bifoldable t => (a -> a -> a) -> t a a -> a +bifoldr1 f xs = fromMaybe (error "bifoldr1: empty structure") + (bifoldr mbf mbf Nothing xs) + where + mbf x m = Just (case m of + Nothing -> x + Just y -> f x y) +{-# INLINE bifoldr1 #-} + -- | Right associative monadic bifold over a structure. bifoldrM :: (Bifoldable t, Monad m) => (a -> c -> m c) -> (b -> c -> m c) -> c -> t a b -> m c bifoldrM f g z0 xs = bifoldl f' g' return xs z0 where @@ -184,6 +224,17 @@ g' x k z = k $! g z x {-# INLINE bifoldl' #-} +-- | A variant of 'bifoldl' that has no base case, +-- and thus may only be applied to non-empty structures. +bifoldl1 :: Bifoldable t => (a -> a -> a) -> t a a -> a +bifoldl1 f xs = fromMaybe (error "bifoldl1: empty structure") + (bifoldl mbf mbf Nothing xs) + where + mbf m y = Just (case m of + Nothing -> y + Just x -> f x y) +{-# INLINe bifoldl1 #-} + -- | Left associative monadic bifold over a structure. bifoldlM :: (Bifoldable t, Monad m) => (a -> b -> m a) -> (a -> c -> m a) -> a -> t b c -> m a bifoldlM f g z0 xs = bifoldr f' g' return xs z0 where @@ -224,22 +275,109 @@ bisequence_ = bifoldr (>>) (>>) (return ()) {-# INLINE bisequence_ #-} +-- | The sum of a collection of actions, generalizing 'biconcat'. +biasum :: (Bifoldable t, Alternative f) => t (f a) (f a) -> f a +biasum = bifoldr (<|>) (<|>) empty +{-# INLINE biasum #-} + +-- | The sum of a collection of actions, generalizing 'biconcat'. +bimsum :: (Bifoldable t, MonadPlus m) => t (m a) (m a) -> m a +bimsum = bifoldr mplus mplus mzero +{-# INLINE bimsum #-} + -- | Collects the list of elements of a structure in order. biList :: Bifoldable t => t a a -> [a] biList = bifoldr (:) (:) [] {-# INLINE biList #-} +-- | Test whether the structure is empty. +binull :: Bifoldable t => t a b -> Bool +binull = bifoldr (\_ _ -> False) (\_ _ -> False) True +{-# INLINE binull #-} + +-- | Returns the size/length of a finite structure as an 'Int'. +bilength :: Bifoldable t => t a b -> Int +bilength = bifoldl' (\c _ -> c+1) (\c _ -> c+1) 0 +{-# INLINE bilength #-} + +-- | Does the element occur in the structure? +bielem :: (Bifoldable t, Eq a) => a -> t a a -> Bool +bielem x = biany (== x) (== x) +{-# INLINE bielem #-} + -- | Reduces a structure of lists to the concatenation of those lists. biconcat :: Bifoldable t => t [a] [a] -> [a] biconcat = bifold {-# INLINE biconcat #-} +newtype Max a = Max {getMax :: Maybe a} +newtype Min a = Min {getMin :: Maybe a} + +instance Ord a => Monoid (Max a) where + mempty = Max Nothing + + {-# INLINE mappend #-} + m `mappend` Max Nothing = m + Max Nothing `mappend` n = n + (Max m@(Just x)) `mappend` (Max n@(Just y)) + | x >= y = Max m + | otherwise = Max n + +instance Ord a => Monoid (Min a) where + mempty = Min Nothing + + {-# INLINE mappend #-} + m `mappend` Min Nothing = m + Min Nothing `mappend` n = n + (Min m@(Just x)) `mappend` (Min n@(Just y)) + | x <= y = Min m + | otherwise = Min n + +-- | The largest element of a non-empty structure. +bimaximum :: forall t a. (Bifoldable t, Ord a) => t a a -> a +bimaximum = fromMaybe (error "bimaximum: empty structure") . + getMax . bifoldMap mj mj + where mj = Max . (Just :: a -> Maybe a) +{-# INLINE bimaximum #-} + +-- | The least element of a non-empty structure. +biminimum :: forall t a. (Bifoldable t, Ord a) => t a a -> a +biminimum = fromMaybe (error "biminimum: empty structure") . + getMin . bifoldMap mj mj + where mj = Min . (Just :: a -> Maybe a) +{-# INLINE biminimum #-} + +-- | The 'bisum' function computes the sum of the numbers of a structure. +bisum :: (Bifoldable t, Num a) => t a a -> a +bisum = getSum . bifoldMap Sum Sum +{-# INLINE bisum #-} + +-- | The 'biproduct' function computes the product of the numbers of a +-- structure. +biproduct :: (Bifoldable t, Num a) => t a a -> a +biproduct = getProduct . bifoldMap Product Product +{-# INLINE biproduct #-} + -- | Given a means of mapping the elements of a structure to lists, computes the -- concatenation of all such lists in order. biconcatMap :: Bifoldable t => (a -> [c]) -> (b -> [c]) -> t a b -> [c] biconcatMap = bifoldMap {-# INLINE biconcatMap #-} +-- | 'biand' returns the conjunction of a container of Bools. For the +-- result to be 'True', the container must be finite; 'False', however, +-- results from a 'False' value finitely far from the left end. +biand :: Bifoldable t => t Bool Bool -> Bool +biand = getAll . bifoldMap All All +{-# INLINE biand #-} + +-- | 'bior' returns the disjunction of a container of Bools. For the +-- result to be 'False', the container must be finite; 'True', however, +-- results from a 'True' value finitely far from the left end. +bior :: Bifoldable t => t Bool Bool -> Bool +bior = getAny . bifoldMap Any Any +{-# INLINE bior #-} + -- | Determines whether any element of the structure satisfies the appropriate -- predicate. biany :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool @@ -251,3 +389,34 @@ biall :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool biall p q = getAll . bifoldMap (All . p) (All . q) {-# INLINE biall #-} + +-- | The largest element of a non-empty structure with respect to the +-- given comparison function. +bimaximumBy :: Bifoldable t => (a -> a -> Ordering) -> t a a -> a +bimaximumBy cmp = bifoldr1 max' + where max' x y = case cmp x y of + GT -> x + _ -> y +{-# INLINE bimaximumBy #-} + +-- | The least element of a non-empty structure with respect to the +-- given comparison function. +biminimumBy :: Bifoldable t => (a -> a -> Ordering) -> t a a -> a +biminimumBy cmp = bifoldr1 min' + where min' x y = case cmp x y of + GT -> y + _ -> x +{-# INLINE biminimumBy #-} + +-- | 'binotElem' is the negation of 'bielem'. +binotElem :: (Bifoldable t, Eq a) => a -> t a a-> Bool +binotElem x = not . bielem x +{-# INLINE binotElem #-} + +-- | The 'bifind' function takes a predicate and a structure and returns +-- the leftmost element of the structure matching the predicate, or +-- 'Nothing' if there is no such element. +bifind :: Bifoldable t => (a -> Bool) -> t a a -> Maybe a +bifind p = getFirst . bifoldMap finder finder + where finder x = First (if p x then Just x else Nothing) +{-# INLINE bifind #-} diff --git a/src/Data/Bifunctor/TH.hs b/src/Data/Bifunctor/TH.hs --- a/src/Data/Bifunctor/TH.hs +++ b/src/Data/Bifunctor/TH.hs @@ -42,14 +42,15 @@ , makeBisequence ) where -import Control.Monad (guard, unless, when) +import Control.Monad (guard, unless, when, zipWithM) import Data.Bifunctor.TH.Internal +import Data.Either (rights) #if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0)) import Data.Foldable (foldr') #endif import Data.List -import qualified Data.Map as Map (fromList, keys, lookup) +import qualified Data.Map as Map (fromList, keys, lookup, size) import Data.Maybe import Language.Haskell.TH.Lib @@ -319,26 +320,10 @@ -- | Generates a lambda expression for a single constructor. makeBiFunForCon :: BiFun -> Name -> Name -> Name -> Con -> Q Match --- makeBiFunForCon biFun z tvis (NormalC conName tys) = do --- args <- newNameList "arg" $ length tys --- let argTys = map snd tys --- makeBiFunForArgs biFun z tvis conName argTys args --- makeBiFunForCon biFun z tvis (RecC conName tys) = do --- args <- newNameList "arg" $ length tys --- let argTys = map thd3 tys --- makeBiFunForArgs biFun z tvis conName argTys args --- makeBiFunForCon biFun z tvis (InfixC (_, argTyL) conName (_, argTyR)) = do --- argL <- newName "argL" --- argR <- newName "argR" --- makeBiFunForArgs biFun z tvis conName [argTyL, argTyR] [argL, argR] --- makeBiFunForCon biFun z tvis (ForallC tvbs faCxt con) --- | any (`predMentionsNameBase` map fst tvis) faCxt && not (allowExQuant (biFunToClass biFun)) --- = existentialContextError (constructorName con) --- | otherwise = makeBiFunForCon biFun z (removeForalled tvbs tvis) con makeBiFunForCon biFun z map1 map2 con = do let conName = constructorName con (ts, tvMap) <- reifyConTys biFun conName map1 map2 - argNames <- newNameList "arg" $ length ts + argNames <- newNameList "_arg" $ length ts makeBiFunForArgs biFun z tvMap conName ts argNames -- | Generates a lambda expression for a single constructor's arguments. @@ -348,38 +333,43 @@ -> Name -> [Type] -> [Name] - -> Q Match + -> Q Match makeBiFunForArgs biFun z tvMap conName tys args = match (conP conName $ map varP args) - (normalB $ biFunCombine biFun conName z mappedArgs) + (normalB $ biFunCombine biFun conName z args mappedArgs) [] where - mappedArgs :: [Q Exp] - mappedArgs = zipWith (makeBiFunForArg biFun tvMap conName) tys args + mappedArgs :: Q [Either Exp Exp] + mappedArgs = zipWithM (makeBiFunForArg biFun tvMap conName) tys args -- | Generates a lambda expression for a single argument of a constructor. +-- The returned value is 'Right' if its type mentions one of the last two type +-- parameters. Otherwise, it is 'Left'. makeBiFunForArg :: BiFun -> TyVarMap -> Name -> Type -> Name - -> Q Exp + -> Q (Either Exp Exp) makeBiFunForArg biFun tvMap conName ty tyExpName = - makeBiFunForType biFun tvMap conName True ty `appE` varE tyExpName + makeBiFunForType biFun tvMap conName True ty `appEitherE` varE tyExpName --- | Generates a lambda expression for a specific type. +-- | Generates a lambda expression for a specific type. The returned value is +-- 'Right' if its type mentions one of the last two type parameters. Otherwise, +-- it is 'Left'. makeBiFunForType :: BiFun -> TyVarMap -> Name -> Bool -> Type - -> Q Exp + -> Q (Either Exp Exp) makeBiFunForType biFun tvMap conName covariant (VarT tyName) = case Map.lookup tyName tvMap of - Just mapName -> varE $ if covariant + Just mapName -> fmap Right . varE $ + if covariant then mapName else contravarianceError conName - Nothing -> biFunTriv biFun + Nothing -> fmap Left $ biFunTriv biFun makeBiFunForType biFun tvMap conName covariant (SigT ty _) = makeBiFunForType biFun tvMap conName covariant ty makeBiFunForType biFun tvMap conName covariant (ForallT _ _ ty) = @@ -401,9 +391,10 @@ mentionsTyArgs :: Bool mentionsTyArgs = any (`mentionsName` tyVarNames) tyArgs - makeBiFunTuple :: Type -> Name -> Q Exp + makeBiFunTuple :: Type -> Name -> Q (Either Exp Exp) makeBiFunTuple fieldTy fieldName = - makeBiFunForType biFun tvMap conName covariant fieldTy `appE` varE fieldName + makeBiFunForType biFun tvMap conName covariant fieldTy + `appEitherE` varE fieldName in case tyCon of ArrowT @@ -411,27 +402,28 @@ | mentionsTyArgs, [argTy, resTy] <- tyArgs -> do x <- newName "x" b <- newName "b" - lamE [varP x, varP b] $ + fmap Right . lamE [varP x, varP b] $ covBiFun covariant resTy `appE` (varE x `appE` (covBiFun (not covariant) argTy `appE` varE b)) where covBiFun :: Bool -> Type -> Q Exp - covBiFun = makeBiFunForType biFun tvMap conName + covBiFun cov = fmap fromEither . makeBiFunForType biFun tvMap conName cov TupleT n | n > 0 && mentionsTyArgs -> do args <- mapM newName $ catMaybes [ Just "x" , guard (biFun == Bifoldr) >> Just "z" ] - xs <- newNameList "tup" n + xs <- newNameList "_tup" n let x = head args z = last args - lamE (map varP args) $ caseE (varE x) + fmap Right $ lamE (map varP args) $ caseE (varE x) [ match (tupP $ map varP xs) (normalB $ biFunCombine biFun (tupleDataName n) z - (zipWith makeBiFunTuple tyArgs xs) + xs + (zipWithM makeBiFunTuple tyArgs xs) ) [] ] @@ -440,11 +432,12 @@ if any (`mentionsName` tyVarNames) lhsArgs || (itf && mentionsTyArgs) then outOfPlaceTyVarError conName else if any (`mentionsName` tyVarNames) rhsArgs - then biFunApp biFun . appsE $ + then fmap Right . biFunApp biFun . appsE $ ( varE (fromJust $ biFunArity biFun numLastArgs) - : map (makeBiFunForType biFun tvMap conName covariant) rhsArgs + : map (fmap fromEither . makeBiFunForType biFun tvMap conName covariant) + rhsArgs ) - else biFunTriv biFun + else fmap Left $ biFunTriv biFun ------------------------------------------------------------------------------- -- Template Haskell reifying and AST manipulation @@ -671,8 +664,8 @@ droppedTyVarNames :: [Name] droppedTyVarNames = concatMap tyVarNamesOfType droppedTysExpSubst - -- If any of the dropped types were polykinded, ensure that there are of kind - -- * after substituting * for the dropped kind variables. If not, throw an error. + -- If any of the dropped types were polykinded, ensure that they are of kind * + -- after substituting * for the dropped kind variables. If not, throw an error. unless (all hasKindStar droppedTysExpSubst) $ derivingKindError biClass tyConName @@ -874,12 +867,12 @@ instance (Functor f, Bifunctor g) => Bifunctor (Compose f g) where ... (ii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are - * or kind variables), then generate a Bifunctor constraint and perform + * or kind variables), then generate a Bifunctor n constraint and perform kind substitution as in the other case. -} -- Determines the types of a constructor's arguments as well as the last type --- parameters (mapped to their show functions), expanding through any type synonyms. +-- parameters (along with their map functions), expanding through any type synonyms. -- The type parameters are determined on a constructor-by-constructor basis since -- they may be refined to be particular types in a GADT. reifyConTys :: BiFun @@ -900,14 +893,14 @@ unapResTy = unapplyTy resTy -- If one of the last type variables is refined to a particular type -- (i.e., not truly polymorphic), we mark it with Nothing and filter - -- it out later, since we only apply show functions to arguments of + -- it out later, since we only apply map functions to arguments of -- a type that it (1) one of the last type variables, and (2) -- of a truly polymorphic type. mbTvNames = map varTToName_maybe $ drop (length unapResTy - 2) unapResTy -- We use Map.fromList to ensure that if there are any duplicate type -- variables (as can happen in a GADT), the rightmost type variable gets - -- associated with the show function. + -- associated with the map function. -- -- See Note [Matching functions with GADT type variables] tvMap = Map.fromList @@ -915,7 +908,8 @@ $ zipWith (\mbTvName sp -> fmap (\tvName -> (tvName, sp)) mbTvName) mbTvNames [map1, map2] - if any (`predMentionsName` Map.keys tvMap) ctxt + if (any (`predMentionsName` Map.keys tvMap) ctxt + || Map.size tvMap < 2) && not (allowExQuant (biFunToClass biFun)) then existentialContextError conName else return (argTys, tvMap) @@ -929,7 +923,7 @@ data Both a b where BothCon :: x -> x -> Both x x -Which show functions should be applied to which arguments of BothCon? We have a +Which fold functions should be applied to which arguments of BothCon? We have a choice, since both the function of type (a -> m) and of type (b -> m) can be applied to either argument. In such a scenario, the second fold function takes precedence over the first fold function, so the derived Bifoldable instance would be: @@ -1097,6 +1091,9 @@ biFunTriv Bimap = do x <- newName "x" lamE [varP x] $ varE x +-- The biFunTriv definitions for bifoldr, bifoldMap, and bitraverse might seem +-- useless, but they do serve a purpose. +-- See Note [biFunTriv for Bifoldable and Bitraversable] biFunTriv Bifoldr = do z <- newName "z" lamE [wildP, varP z] $ varE z @@ -1110,24 +1107,97 @@ lamE [varP x, varP z] $ appsE [e, varE z, varE x] biFunApp _ e = e -biFunCombine :: BiFun -> Name -> Name -> [Q Exp] -> Q Exp +biFunCombine :: BiFun + -> Name + -> Name + -> [Name] + -> Q [Either Exp Exp] + -> Q Exp biFunCombine Bimap = bimapCombine biFunCombine Bifoldr = bifoldrCombine biFunCombine BifoldMap = bifoldMapCombine biFunCombine Bitraverse = bitraverseCombine -bimapCombine :: Name -> Name -> [Q Exp] -> Q Exp -bimapCombine conName _ = foldl' appE (conE conName) +bimapCombine :: Name + -> Name + -> [Name] + -> Q [Either Exp Exp] + -> Q Exp +bimapCombine conName _ _ = fmap (foldl' AppE (ConE conName) . fmap fromEither) -bifoldrCombine :: Name -> Name -> [Q Exp] -> Q Exp -bifoldrCombine _ zName = foldr appE (varE zName) +-- bifoldr, bifoldMap, and bitraverse are handled differently from bimap, since +-- they filter out subexpressions whose types do not mention one of the last two +-- type parameters. See +-- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor#AlternativestrategyforderivingFoldableandTraversable +-- for further discussion. -bifoldMapCombine :: Name -> Name -> [Q Exp] -> Q Exp -bifoldMapCombine _ _ [] = varE memptyValName -bifoldMapCombine _ _ es = foldr1 (appE . appE (varE mappendValName)) es +bifoldrCombine :: Name + -> Name + -> [Name] + -> Q [Either Exp Exp] + -> Q Exp +bifoldrCombine _ zName _ = fmap (foldr AppE (VarE zName) . rights) -bitraverseCombine :: Name -> Name -> [Q Exp] -> Q Exp -bitraverseCombine conName _ [] = varE pureValName `appE` conE conName -bitraverseCombine conName _ (e:es) = - foldl' (flip infixApp $ varE apValName) - (appsE [varE fmapValName, conE conName, e]) es +bifoldMapCombine :: Name + -> Name + -> [Name] + -> Q [Either Exp Exp] + -> Q Exp +bifoldMapCombine _ _ _ = fmap (go . rights) + where + go :: [Exp] -> Exp + go [] = VarE memptyValName + go es = foldr1 (AppE . AppE (VarE mappendValName)) es + +bitraverseCombine :: Name + -> Name + -> [Name] + -> Q [Either Exp Exp] + -> Q Exp +bitraverseCombine conName _ args essQ = do + ess <- essQ + + let argTysTyVarInfo :: [Bool] + argTysTyVarInfo = map isRight ess + + argsWithTyVar, argsWithoutTyVar :: [Name] + (argsWithTyVar, argsWithoutTyVar) = partitionByList argTysTyVarInfo args + + conExpQ :: Q Exp + conExpQ + | null argsWithTyVar + = appsE (conE conName:map varE argsWithoutTyVar) + | otherwise = do + bs <- newNameList "b" $ length args + let bs' = filterByList argTysTyVarInfo bs + vars = filterByLists argTysTyVarInfo + (map varE bs) (map varE args) + lamE (map varP bs') (appsE (conE conName:vars)) + + conExp <- conExpQ + + let go :: [Exp] -> Exp + go [] = VarE pureValName `AppE` conExp + go (e:es) = foldl' (\e1 e2 -> InfixE (Just e1) (VarE apValName) (Just e2)) + (VarE fmapValName `AppE` conExp `AppE` e) es + + return . go . rights $ ess + +{- +Note [biFunTriv for Bifoldable and Bitraversable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When deriving Bifoldable and Bitraversable, we filter out any subexpressions whose +type does not mention one of the last two type parameters. From this, you might +think that we don't need to implement biFunTriv for bifoldr, bifoldMap, or +bitraverse at all, but in fact we do need to. Imagine the following data type: + + data T a b = MkT a (T Int b) + +In a derived Bifoldable T instance, you would generate the following bifoldMap +definition: + + bifoldMap f g (MkT a1 a2) = f a1 <> bifoldMap (\_ -> mempty) g arg2 + +You need to fill in biFunTriv (\_ -> mempty) as the first argument to the recursive +call to bifoldMap, since that is how the algorithm handles polymorphic recursion. +-} diff --git a/src/Data/Bifunctor/TH/Internal.hs b/src/Data/Bifunctor/TH/Internal.hs --- a/src/Data/Bifunctor/TH/Internal.hs +++ b/src/Data/Bifunctor/TH/Internal.hs @@ -13,6 +13,7 @@ import Control.Monad (liftM) +import Data.Bifunctor (bimap) import Data.Foldable (foldr') import Data.List import qualified Data.Map as Map (fromList, findWithDefault, singleton) @@ -159,6 +160,71 @@ -- Assorted utilities ------------------------------------------------------------------------------- +-- isRight and fromEither taken from the extra package (BSD3-licensed) + +-- | Test if an 'Either' value is the 'Right' constructor. +-- Provided as standard with GHC 7.8 and above. +isRight :: Either l r -> Bool +isRight Right{} = True; isRight _ = False + +-- | Pull the value out of an 'Either' where both alternatives +-- have the same type. +-- +-- > \x -> fromEither (Left x ) == x +-- > \x -> fromEither (Right x) == x +fromEither :: Either a a -> a +fromEither = either id id + +-- filterByList, filterByLists, and partitionByList taken from GHC (BSD3-licensed) + +-- | 'filterByList' takes a list of Bools and a list of some elements and +-- filters out these elements for which the corresponding value in the list of +-- Bools is False. This function does not check whether the lists have equal +-- length. +filterByList :: [Bool] -> [a] -> [a] +filterByList (True:bs) (x:xs) = x : filterByList bs xs +filterByList (False:bs) (_:xs) = filterByList bs xs +filterByList _ _ = [] + +-- | 'filterByLists' takes a list of Bools and two lists as input, and +-- outputs a new list consisting of elements from the last two input lists. For +-- each Bool in the list, if it is 'True', then it takes an element from the +-- former list. If it is 'False', it takes an element from the latter list. +-- The elements taken correspond to the index of the Bool in its list. +-- For example: +-- +-- @ +-- filterByLists [True, False, True, False] \"abcd\" \"wxyz\" = \"axcz\" +-- @ +-- +-- This function does not check whether the lists have equal length. +filterByLists :: [Bool] -> [a] -> [a] -> [a] +filterByLists (True:bs) (x:xs) (_:ys) = x : filterByLists bs xs ys +filterByLists (False:bs) (_:xs) (y:ys) = y : filterByLists bs xs ys +filterByLists _ _ _ = [] + +-- | 'partitionByList' takes a list of Bools and a list of some elements and +-- partitions the list according to the list of Bools. Elements corresponding +-- to 'True' go to the left; elements corresponding to 'False' go to the right. +-- For example, @partitionByList [True, False, True] [1,2,3] == ([1,3], [2])@ +-- This function does not check whether the lists have equal +-- length. +partitionByList :: [Bool] -> [a] -> ([a], [a]) +partitionByList = go [] [] + where + go trues falses (True : bs) (x : xs) = go (x:trues) falses bs xs + go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs + go trues falses _ _ = (reverse trues, reverse falses) + +-- | Apply an @Either Exp Exp@ expression to an 'Exp' expression, +-- preserving the 'Either'-ness. +appEitherE :: Q (Either Exp Exp) -> Q Exp -> Q (Either Exp Exp) +appEitherE e1Q e2Q = do + e2 <- e2Q + let e2' :: Exp -> Exp + e2' = (`AppE` e2) + bimap e2' e2' `fmap` e1Q + -- | Returns True if a Type has kind *. hasKindStar :: Type -> Bool hasKindStar VarT{} = True @@ -227,7 +293,7 @@ -- | A mapping of type variable Names to their map function Names. For example, in a -- Bifunctor declaration, a TyVarMap might look like (a ~> f, b ~> g), where -- a and b are the last two type variables of the datatype, and f and g are the two --- functions which show their respective type variables. +-- functions which map their respective type variables. type TyVarMap = Map Name Name thd3 :: (a, b, c) -> c diff --git a/src/Data/Bitraversable.hs b/src/Data/Bitraversable.hs --- a/src/Data/Bitraversable.hs +++ b/src/Data/Bitraversable.hs @@ -33,17 +33,24 @@ import Data.Bifunctor import Data.Bifoldable import Data.Functor.Constant +import Data.Orphans () -#if MIN_VERSION_semigroups(0,16,2) -import Data.Semigroup -#else +#if !(MIN_VERSION_base(4,8,0)) import Data.Monoid #endif +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2) +import Data.Semigroup (Arg(..)) +#endif + #ifdef MIN_VERSION_tagged import Data.Tagged #endif +#if __GLASGOW_HASKELL__ >= 702 +import GHC.Generics (K1(..)) +#endif + #if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 import Data.Typeable #endif @@ -159,7 +166,7 @@ deriving instance Typeable Bitraversable #endif -#if MIN_VERSION_semigroups(0,16,2) +#if MIN_VERSION_base(4,9,0) || MIN_VERSION_semigroups(0,16,2) instance Bitraversable Arg where bitraverse f g (Arg a b) = Arg <$> f a <*> g b #endif @@ -200,6 +207,12 @@ instance Bitraversable Constant where bitraverse f _ (Constant a) = Constant <$> f a {-# INLINE bitraverse #-} + +#if __GLASGOW_HASKELL__ >= 702 +instance Bitraversable (K1 i) where + bitraverse f _ (K1 c) = K1 <$> f c + {-# INLINE bitraverse #-} +#endif #ifdef MIN_VERSION_tagged instance Bitraversable Tagged where diff --git a/tests/BifunctorSpec.hs b/tests/BifunctorSpec.hs --- a/tests/BifunctorSpec.hs +++ b/tests/BifunctorSpec.hs @@ -3,12 +3,16 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} +#if __GLASGOW_HASKELL__ >= 800 +{-# OPTIONS_GHC -fno-warn-unused-foralls #-} +#endif {-| Module: BifunctorSpec @@ -32,6 +36,8 @@ import Data.Functor.Identity (Identity(..)) import Data.Monoid +import GHC.Exts (Int#) + import Test.Hspec import Test.Hspec.QuickCheck (prop) import Test.QuickCheck (Arbitrary) @@ -92,6 +98,13 @@ | forall f. Bitraversable f => ExistentialFunctor (f a b) | forall b. SneakyUseSameName (Maybe b) +data IntHash a b + = IntHash Int# Int# + | IntHashTuple Int# a b (a, b, Int, IntHash Int (a, b, Int)) + +data IntHashFun a b + = IntHashFun ((((a -> Int#) -> b) -> Int#) -> a) + -- Data families data family StrangeFam x y z @@ -144,6 +157,15 @@ | forall f. Bitraversable f => ExistentialFunctorFam (f a b) | forall b. SneakyUseSameNameFam (Maybe b) +data family IntHashFam x y +data instance IntHashFam a b + = IntHashFam Int# Int# + | IntHashTupleFam Int# a b (a, b, Int, IntHashFam Int (a, b, Int)) + +data family IntHashFunFam x y +data instance IntHashFunFam a b + = IntHashFunFam ((((a -> Int#) -> b) -> Int#) -> a) + ------------------------------------------------------------------------------- -- Plain data types @@ -180,6 +202,12 @@ $(deriveBifoldable ''Existential) $(deriveBitraversable ''Existential) +$(deriveBifunctor ''IntHash) +$(deriveBifoldable ''IntHash) +$(deriveBitraversable ''IntHash) + +$(deriveBifunctor ''IntHashFun) + #if MIN_VERSION_template_haskell(2,7,0) -- Data families @@ -214,6 +242,12 @@ $(deriveBifunctor 'ExistentialListFam) $(deriveBifoldable 'ExistentialFunctorFam) $(deriveBitraversable 'SneakyUseSameNameFam) + +$(deriveBifunctor 'IntHashFam) +$(deriveBifoldable 'IntHashTupleFam) +$(deriveBitraversable 'IntHashFam) + +$(deriveBifunctor 'IntHashFunFam) #endif ------------------------------------------------------------------------------- @@ -241,12 +275,13 @@ prop_BifoldableEx :: Bifoldable p => p [Int] [Int] -> Bool prop_BifoldableEx = prop_BifoldableLaws reverse (++ [42]) ((+) . length) ((*) . length) 0 -prop_BitraversableLaws :: (Applicative f, Bitraversable p, Eq (f (p c c)), +prop_BitraversableLaws :: (Applicative f, Applicative g, + Bitraversable p, Eq (f (p c c)), Eq (g (p c c)), Eq (p a b), Eq (p d e), Eq1 f) => (a -> f c) -> (b -> f c) -> (c -> f d) -> (c -> f e) - -> (f c -> f c) -> p a b -> Bool + -> (forall x. f x -> g x) -> p a b -> Bool prop_BitraversableLaws f g h i t x = - bitraverse (t . f) (t . g) x == bitraverse f g x + bitraverse (t . f) (t . g) x == (t . bitraverse f g) x && bitraverse Identity Identity x == Identity x && (Compose . fmap (bitraverse h i) . bitraverse f g) x == bitraverse (Compose . fmap h . f) (Compose . fmap i . g) x