bifunctors 5.2.1 → 5.3
raw patch · 9 files changed
+456/−84 lines, 9 filesdep +base-orphansnew-uploader
Dependencies added: base-orphans
Files
- CHANGELOG.markdown +6/−0
- bifunctors.cabal +8/−7
- old-src/Data/Bifunctor.hs +10/−0
- src/Data/Biapplicative.hs +6/−4
- src/Data/Bifoldable.hs +174/−5
- src/Data/Bifunctor/TH.hs +130/−60
- src/Data/Bifunctor/TH/Internal.hs +67/−1
- src/Data/Bitraversable.hs +17/−4
- tests/BifunctorSpec.hs +38/−3
CHANGELOG.markdown view
@@ -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`
bifunctors.cabal view
@@ -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
old-src/Data/Bifunctor.hs view
@@ -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
src/Data/Biapplicative.hs view
@@ -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 #-}
src/Data/Bifoldable.hs view
@@ -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 #-}
src/Data/Bifunctor/TH.hs view
@@ -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.+-}
src/Data/Bifunctor/TH/Internal.hs view
@@ -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
src/Data/Bitraversable.hs view
@@ -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
tests/BifunctorSpec.hs view
@@ -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