{- (c) The University of Glasgow 2011 -} {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} -- | The deriving code for the Functor, Foldable, and Traversable classes module GHC.Tc.Deriv.Functor ( FFoldType(..) , functorLikeTraverse , deepSubtypesContaining , foldDataConArgs , gen_Functor_binds , gen_Foldable_binds , gen_Traversable_binds ) where #include "HsVersions.h" import GHC.Prelude import GHC.Data.Bag import GHC.Core.DataCon import GHC.Data.FastString import GHC.Hs import GHC.Utils.Panic import GHC.Builtin.Names import GHC.Types.Name.Reader import GHC.Types.SrcLoc import GHC.Utils.Monad.State import GHC.Tc.Deriv.Generate import GHC.Tc.Utils.TcType import GHC.Core.TyCon import GHC.Core.TyCo.Rep import GHC.Core.Type import GHC.Utils.Misc import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Id.Make (coerceId) import GHC.Builtin.Types (true_RDR, false_RDR) import Data.Maybe (catMaybes, isJust) {- ************************************************************************ * * Functor instances see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html * * ************************************************************************ For the data type: data T a = T1 Int a | T2 (T a) We generate the instance: instance Functor T where fmap f (T1 b1 a) = T1 b1 (f a) fmap f (T2 ta) = T2 (fmap f ta) Notice that we don't simply apply 'fmap' to the constructor arguments. Rather - Do nothing to an argument whose type doesn't mention 'a' - Apply 'f' to an argument of type 'a' - Apply 'fmap f' to other arguments That's why we have to recurse deeply into the constructor argument types, rather than just one level, as we typically do. What about types with more than one type parameter? In general, we only derive Functor for the last position: data S a b = S1 [b] | S2 (a, T a b) instance Functor (S a) where fmap f (S1 bs) = S1 (fmap f bs) fmap f (S2 (p,q)) = S2 (a, fmap f q) However, we have special cases for - tuples - functions More formally, we write the derivation of fmap code over type variable 'a for type 'b as ($fmap 'a 'b x). In this general notation the derived instance for T is: instance Functor T where fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2) fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1) $(fmap 'a 'b x) = x -- when b does not contain a $(fmap 'a 'a x) = f x $(fmap 'a '(b1,b2) x) = case x of (x1,x2) -> ($(fmap 'a 'b1 x1), $(fmap 'a 'b2 x2)) $(fmap 'a '(T b1 a) x) = fmap f x -- when a only occurs directly as the last argument of T $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 $(fmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(fmap 'a' 'tc' (x $(cofmap 'a 'tb y))) For functions, the type parameter 'a can occur in a contravariant position, which means we need to derive a function like: cofmap :: (a -> b) -> (f b -> f a) This is pretty much the same as $fmap, only without the $(cofmap 'a 'a x) and $(cofmap 'a '(T b1 a) x) cases: $(cofmap 'a 'b x) = x -- when b does not contain a $(cofmap 'a 'a x) = error "type variable in contravariant position" $(cofmap 'a '(b1,b2) x) = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2) $(cofmap 'a '(T b1 a) x) = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T $(cofmap 'a '(T b1 b2) x) = fmap (\y. $(cofmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 $(cofmap 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(cofmap 'a' 'tc' (x $(fmap 'a 'tb y))) Note that the code produced by $(fmap _ _ _) is always a higher order function, with type `(a -> b) -> (g a -> g b)` for some g. Note that there are two distinct cases in $fmap (and $cofmap) that match on an application of some type constructor T (where T is not a tuple type constructor): $(fmap 'a '(T b1 a) x) = fmap f x -- when a only occurs directly as the last argument of T $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 While the latter case technically subsumes the former case, it is important to give special treatment to the former case to avoid unnecessary eta expansion. See Note [Avoid unnecessary eta expansion in derived fmap implementations]. We also generate code for (<$) in addition to fmap—see Note [Deriving <$] for an explanation of why this is important. Just like $fmap/$cofmap above, there is a similar algorithm for generating `p <$ x` (for some constant `p`): $(replace 'a 'b x) = x -- when b does not contain a $(replace 'a 'a x) = p $(replace 'a '(b1,b2) x) = case x of (x1,x2) -> ($(replace 'a 'b1 x1), $(replace 'a 'b2 x2)) $(replace 'a '(T b1 a) x) = p <$ x -- when a only occurs directly as the last argument of T $(replace 'a '(T b1 b2) x) = fmap (\y. $(replace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 $(replace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(replace 'a' 'tc' (x $(coreplace 'a 'tb y))) $(coreplace 'a 'b x) = x -- when b does not contain a $(coreplace 'a 'a x) = error "type variable in contravariant position" $(coreplace 'a '(b1,b2) x) = case x of (x1,x2) -> ($(coreplace 'a 'b1 x1), $(coreplace 'a 'b2 x2)) $(coreplace 'a '(T b1 a) x) = error "type variable in contravariant position" -- when a only occurs directly as the last argument of T $(coreplace 'a '(T b1 b2) x) = fmap (\y. $(coreplace 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 $(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y))) -} gen_Functor_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff) -- When the argument is phantom, we can use fmap _ = coerce -- See Note [Phantom types with Functor, Foldable, and Traversable] gen_Functor_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds (GhcPass 'Parsed), BagDerivStuff) gen_Functor_binds SrcSpan loc TyCon tycon [Type] _ | Role Phantom <- forall a. [a] -> a last (TyCon -> [Role] tyConRoles TyCon tycon) = (forall a. a -> Bag a unitBag LHsBind (GhcPass 'Parsed) fmap_bind, forall a. Bag a emptyBag) where fmap_name :: GenLocated SrcSpanAnnN RdrName fmap_name = forall l e. l -> e -> GenLocated l e L (forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc) RdrName fmap_RDR fmap_bind :: LHsBind (GhcPass 'Parsed) fmap_bind = GenLocated SrcSpanAnnN RdrName -> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))] -> LHsBind (GhcPass 'Parsed) mkRdrFunBind GenLocated SrcSpanAnnN RdrName fmap_name [GenLocated (Anno (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))) (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))] fmap_eqns fmap_eqns :: [GenLocated (Anno (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))) (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))] fmap_eqns = [forall (p :: Pass) (body :: * -> *). (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA, Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan) => HsMatchContext (NoGhcTc (GhcPass p)) -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p)) -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) mkSimpleMatch HsMatchContext (GhcPass (NoGhcTcPass 'Parsed)) fmap_match_ctxt [LPat (GhcPass 'Parsed) nlWildPat] LHsExpr (GhcPass 'Parsed) coerce_Expr] fmap_match_ctxt :: HsMatchContext (GhcPass (NoGhcTcPass 'Parsed)) fmap_match_ctxt = forall p. LIdP p -> HsMatchContext p mkPrefixFunRhs GenLocated SrcSpanAnnN RdrName fmap_name gen_Functor_binds SrcSpan loc TyCon tycon [Type] tycon_args = (forall a. [a] -> Bag a listToBag [LHsBind (GhcPass 'Parsed) fmap_bind, LHsBind (GhcPass 'Parsed) replace_bind], forall a. Bag a emptyBag) where data_cons :: [DataCon] data_cons = TyCon -> [Type] -> [DataCon] getPossibleDataCons TyCon tycon [Type] tycon_args fmap_name :: GenLocated SrcSpanAnnN RdrName fmap_name = forall l e. l -> e -> GenLocated l e L (forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc) RdrName fmap_RDR -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] fmap_bind :: LHsBind (GhcPass 'Parsed) fmap_bind = Int -> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)) -> GenLocated SrcSpanAnnN RdrName -> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))] -> LHsBind (GhcPass 'Parsed) mkRdrFunBindEC Int 2 forall a. a -> a id GenLocated SrcSpanAnnN RdrName fmap_name [GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))] fmap_eqns fmap_match_ctxt :: HsMatchContext (GhcPass 'Parsed) fmap_match_ctxt = forall p. LIdP p -> HsMatchContext p mkPrefixFunRhs GenLocated SrcSpanAnnN RdrName fmap_name fmap_eqn :: DataCon -> GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))) fmap_eqn DataCon con = forall a b c. (a -> b -> c) -> b -> a -> c flip forall s a. State s a -> s -> a evalState [RdrName] bs_RDRs forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). Monad m => HsMatchContext (GhcPass 'Parsed) -> [LPat (GhcPass 'Parsed)] -> DataCon -> [LHsExpr (GhcPass 'Parsed) -> m (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) match_for_con HsMatchContext (GhcPass 'Parsed) fmap_match_ctxt [LPat (GhcPass 'Parsed) f_Pat] DataCon con [LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed)))] parts where parts :: [LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed)))] parts = forall a. FFoldType a -> DataCon -> [a] foldDataConArgs FFoldType (LHsExpr (GhcPass 'Parsed) -> State [RdrName] (LHsExpr (GhcPass 'Parsed))) ft_fmap DataCon con fmap_eqns :: [GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))] fmap_eqns = forall a b. (a -> b) -> [a] -> [b] map DataCon -> GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))) fmap_eqn [DataCon] data_cons ft_fmap :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) ft_fmap :: FFoldType (LHsExpr (GhcPass 'Parsed) -> State [RdrName] (LHsExpr (GhcPass 'Parsed))) ft_fmap = FT { ft_triv :: LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) ft_triv = \LocatedA (HsExpr (GhcPass 'Parsed)) x -> forall (f :: * -> *) a. Applicative f => a -> f a pure LocatedA (HsExpr (GhcPass 'Parsed)) x -- fmap f x = x , ft_var :: LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) ft_var = \LocatedA (HsExpr (GhcPass 'Parsed)) x -> forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (id :: Pass). IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) nlHsApp LHsExpr (GhcPass 'Parsed) f_Expr LocatedA (HsExpr (GhcPass 'Parsed)) x -- fmap f x = f x , ft_fun :: (LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed)))) -> (LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed)))) -> LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) ft_fun = \LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) g LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) h LocatedA (HsExpr (GhcPass 'Parsed)) x -> (LHsExpr (GhcPass 'Parsed) -> State [RdrName] (LHsExpr (GhcPass 'Parsed))) -> State [RdrName] (LHsExpr (GhcPass 'Parsed)) mkSimpleLam forall a b. (a -> b) -> a -> b $ \LHsExpr (GhcPass 'Parsed) b -> do LocatedA (HsExpr (GhcPass 'Parsed)) gg <- LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) g LHsExpr (GhcPass 'Parsed) b LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) h forall a b. (a -> b) -> a -> b $ forall (id :: Pass). IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) nlHsApp LocatedA (HsExpr (GhcPass 'Parsed)) x LocatedA (HsExpr (GhcPass 'Parsed)) gg -- fmap f x = \b -> h (x (g b)) , ft_tup :: TyCon -> [LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed)))] -> LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) ft_tup = forall (m :: * -> *) a. Monad m => ([LPat (GhcPass 'Parsed)] -> DataCon -> [a] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))) -> TyCon -> [a] -> LHsExpr (GhcPass 'Parsed) -> m (LHsExpr (GhcPass 'Parsed)) mkSimpleTupleCase (forall (m :: * -> *). Monad m => HsMatchContext (GhcPass 'Parsed) -> [LPat (GhcPass 'Parsed)] -> DataCon -> [LHsExpr (GhcPass 'Parsed) -> m (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) match_for_con forall p. HsMatchContext p CaseAlt) -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..) , ft_ty_app :: Type -> Type -> (LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed)))) -> LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) ft_ty_app = \Type _ Type arg_ty LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) g LocatedA (HsExpr (GhcPass 'Parsed)) x -> -- If the argument type is a bare occurrence of the -- data type's last type variable, then we can generate -- more efficient code. -- See Note [Avoid unnecessary eta expansion in derived fmap implementations] if Type -> Bool tcIsTyVarTy Type arg_ty then forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p) nlHsApps RdrName fmap_RDR [LHsExpr (GhcPass 'Parsed) f_Expr,LocatedA (HsExpr (GhcPass 'Parsed)) x] else do LocatedA (HsExpr (GhcPass 'Parsed)) gg <- (LHsExpr (GhcPass 'Parsed) -> State [RdrName] (LHsExpr (GhcPass 'Parsed))) -> State [RdrName] (LHsExpr (GhcPass 'Parsed)) mkSimpleLam LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) g forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p) nlHsApps RdrName fmap_RDR [LocatedA (HsExpr (GhcPass 'Parsed)) gg,LocatedA (HsExpr (GhcPass 'Parsed)) x] -- fmap f x = fmap g x , ft_forall :: Id -> (LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed)))) -> LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) ft_forall = \Id _ LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) g LocatedA (HsExpr (GhcPass 'Parsed)) x -> LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) g LocatedA (HsExpr (GhcPass 'Parsed)) x , ft_bad_app :: LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) ft_bad_app = forall a. String -> a panic String "in other argument in ft_fmap" , ft_co_var :: LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) ft_co_var = forall a. String -> a panic String "contravariant in ft_fmap" } -- See Note [Deriving <$] replace_name :: GenLocated SrcSpanAnnN RdrName replace_name = forall l e. l -> e -> GenLocated l e L (forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc) RdrName replace_RDR -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] replace_bind :: LHsBind (GhcPass 'Parsed) replace_bind = Int -> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)) -> GenLocated SrcSpanAnnN RdrName -> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))] -> LHsBind (GhcPass 'Parsed) mkRdrFunBindEC Int 2 forall a. a -> a id GenLocated SrcSpanAnnN RdrName replace_name [GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))] replace_eqns replace_match_ctxt :: HsMatchContext (GhcPass 'Parsed) replace_match_ctxt = forall p. LIdP p -> HsMatchContext p mkPrefixFunRhs GenLocated SrcSpanAnnN RdrName replace_name replace_eqn :: DataCon -> GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))) replace_eqn DataCon con = forall a b c. (a -> b -> c) -> b -> a -> c flip forall s a. State s a -> s -> a evalState [RdrName] bs_RDRs forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). Monad m => HsMatchContext (GhcPass 'Parsed) -> [LPat (GhcPass 'Parsed)] -> DataCon -> [LHsExpr (GhcPass 'Parsed) -> m (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) match_for_con HsMatchContext (GhcPass 'Parsed) replace_match_ctxt [LPat (GhcPass 'Parsed) z_Pat] DataCon con [LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed)))] parts where parts :: [LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed)))] parts = forall a. FFoldType a -> DataCon -> [a] foldDataConArgs FFoldType (LHsExpr (GhcPass 'Parsed) -> State [RdrName] (LHsExpr (GhcPass 'Parsed))) ft_replace DataCon con replace_eqns :: [GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))] replace_eqns = forall a b. (a -> b) -> [a] -> [b] map DataCon -> GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))) replace_eqn [DataCon] data_cons ft_replace :: FFoldType (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) ft_replace :: FFoldType (LHsExpr (GhcPass 'Parsed) -> State [RdrName] (LHsExpr (GhcPass 'Parsed))) ft_replace = FT { ft_triv :: LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) ft_triv = \LocatedA (HsExpr (GhcPass 'Parsed)) x -> forall (f :: * -> *) a. Applicative f => a -> f a pure LocatedA (HsExpr (GhcPass 'Parsed)) x -- p <$ x = x , ft_var :: LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) ft_var = \LocatedA (HsExpr (GhcPass 'Parsed)) _ -> forall (f :: * -> *) a. Applicative f => a -> f a pure LHsExpr (GhcPass 'Parsed) z_Expr -- p <$ _ = p , ft_fun :: (LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed)))) -> (LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed)))) -> LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) ft_fun = \LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) g LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) h LocatedA (HsExpr (GhcPass 'Parsed)) x -> (LHsExpr (GhcPass 'Parsed) -> State [RdrName] (LHsExpr (GhcPass 'Parsed))) -> State [RdrName] (LHsExpr (GhcPass 'Parsed)) mkSimpleLam forall a b. (a -> b) -> a -> b $ \LHsExpr (GhcPass 'Parsed) b -> do LocatedA (HsExpr (GhcPass 'Parsed)) gg <- LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) g LHsExpr (GhcPass 'Parsed) b LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) h forall a b. (a -> b) -> a -> b $ forall (id :: Pass). IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) nlHsApp LocatedA (HsExpr (GhcPass 'Parsed)) x LocatedA (HsExpr (GhcPass 'Parsed)) gg -- p <$ x = \b -> h (x (g b)) , ft_tup :: TyCon -> [LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed)))] -> LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) ft_tup = forall (m :: * -> *) a. Monad m => ([LPat (GhcPass 'Parsed)] -> DataCon -> [a] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))) -> TyCon -> [a] -> LHsExpr (GhcPass 'Parsed) -> m (LHsExpr (GhcPass 'Parsed)) mkSimpleTupleCase (forall (m :: * -> *). Monad m => HsMatchContext (GhcPass 'Parsed) -> [LPat (GhcPass 'Parsed)] -> DataCon -> [LHsExpr (GhcPass 'Parsed) -> m (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) match_for_con forall p. HsMatchContext p CaseAlt) -- p <$ x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..) , ft_ty_app :: Type -> Type -> (LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed)))) -> LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) ft_ty_app = \Type _ Type arg_ty LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) g LocatedA (HsExpr (GhcPass 'Parsed)) x -> -- If the argument type is a bare occurrence of the -- data type's last type variable, then we can generate -- more efficient code. -- See [Deriving <$] if Type -> Bool tcIsTyVarTy Type arg_ty then forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p) nlHsApps RdrName replace_RDR [LHsExpr (GhcPass 'Parsed) z_Expr,LocatedA (HsExpr (GhcPass 'Parsed)) x] else do LocatedA (HsExpr (GhcPass 'Parsed)) gg <- (LHsExpr (GhcPass 'Parsed) -> State [RdrName] (LHsExpr (GhcPass 'Parsed))) -> State [RdrName] (LHsExpr (GhcPass 'Parsed)) mkSimpleLam LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) g forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p) nlHsApps RdrName fmap_RDR [LocatedA (HsExpr (GhcPass 'Parsed)) gg,LocatedA (HsExpr (GhcPass 'Parsed)) x] -- p <$ x = fmap (p <$) x , ft_forall :: Id -> (LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed)))) -> LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) ft_forall = \Id _ LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) g LocatedA (HsExpr (GhcPass 'Parsed)) x -> LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) g LocatedA (HsExpr (GhcPass 'Parsed)) x , ft_bad_app :: LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) ft_bad_app = forall a. String -> a panic String "in other argument in ft_replace" , ft_co_var :: LocatedA (HsExpr (GhcPass 'Parsed)) -> State [RdrName] (LocatedA (HsExpr (GhcPass 'Parsed))) ft_co_var = forall a. String -> a panic String "contravariant in ft_replace" } -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ... match_for_con :: Monad m => HsMatchContext GhcPs -> [LPat GhcPs] -> DataCon -> [LHsExpr GhcPs -> m (LHsExpr GhcPs)] -> m (LMatch GhcPs (LHsExpr GhcPs)) match_for_con :: forall (m :: * -> *). Monad m => HsMatchContext (GhcPass 'Parsed) -> [LPat (GhcPass 'Parsed)] -> DataCon -> [LHsExpr (GhcPass 'Parsed) -> m (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) match_for_con HsMatchContext (GhcPass 'Parsed) ctxt = forall (m :: * -> *) a. Monad m => HsMatchContext (GhcPass 'Parsed) -> (RdrName -> [a] -> m (LHsExpr (GhcPass 'Parsed))) -> [LPat (GhcPass 'Parsed)] -> DataCon -> [LHsExpr (GhcPass 'Parsed) -> a] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) mkSimpleConMatch HsMatchContext (GhcPass 'Parsed) ctxt forall a b. (a -> b) -> a -> b $ \RdrName con_name [m (LHsExpr (GhcPass 'Parsed))] xsM -> do [LocatedA (HsExpr (GhcPass 'Parsed))] xs <- forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence [m (LHsExpr (GhcPass 'Parsed))] xsM forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p) nlHsApps RdrName con_name [LocatedA (HsExpr (GhcPass 'Parsed))] xs -- Con x1 x2 .. {- Note [Avoid unnecessary eta expansion in derived fmap implementations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For the sake of simplicity, the algorithm that derived implementations of fmap used to have a single case that dealt with applications of some type constructor T (where T is not a tuple type constructor): $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 This generated less than optimal code in certain situations, however. Consider this example: data List a = Nil | Cons a (List a) deriving Functor This would generate the following Functor instance: instance Functor List where fmap f Nil = Nil fmap f (Cons x xs) = Cons (f x) (fmap (\y -> f y) xs) The code `fmap (\y -> f y) xs` is peculiar, since it eta expands an application of `f`. What's worse, this eta expansion actually degrades performance! To see why, we can trace an invocation of fmap on a small List: fmap id $ Cons 0 $ Cons 0 $ Cons 0 $ Cons 0 Nil Cons (id 0) $ fmap (\y -> id y) $ Cons 0 $ Cons 0 $ Cons 0 Nil Cons (id 0) $ Cons ((\y -> id y) 0) $ fmap (\y' -> (\y -> id y) y') $ Cons 0 $ Cons 0 Nil Cons (id 0) $ Cons ((\y -> id y) 0) $ Cons ((\y' -> (\y -> id y) y') 0) $ fmap (\y'' -> (\y' -> (\y -> id y) y') y'') $ Cons 0 Nil Cons (id 0) $ Cons ((\y -> id y) 0) $ Cons ((\y' -> (\y -> id y) y') 0) $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0) $ fmap (\y''' -> (\y'' -> (\y' -> (\y -> id y) y') y'') y''') $ Nil Cons (id 0) $ Cons ((\y -> id y) 0) $ Cons ((\y' -> (\y -> id y) y') 0) $ Cons ((\y'' -> (\y' -> (\y -> id y) y') y'') 0) $ Nil Notice how the number of lambdas—and hence, the number of closures—one needs to evaluate grows very quickly. In general, a List with N cons cells will require (1 + 2 + ... (N-1)) beta reductions, which takes O(N^2) time! This is what caused the performance issues observed in #7436. But hold on a second: shouldn't GHC's optimizer be able to eta reduce `\y -> f y` to `f` and avoid these beta reductions? Unfortunately, this is not the case. In general, eta reduction can change the semantics of a program. For instance, (\x -> ⊥) `seq` () converges, but ⊥ `seq` () diverges. It just so happens that the fmap implementation above would have the same semantics regardless of whether or not `\y -> f y` or `f` is used, but GHC's optimizer is not yet smart enough to realize this (see #17881). To avoid this quadratic blowup, we add a special case to $fmap that applies `fmap f` directly: $(fmap 'a '(T b1 a) x) = fmap f x -- when a only occurs directly as the last argument of T $(fmap 'a '(T b1 b2) x) = fmap (\y. $(fmap 'a 'b2 y)) x -- when a only occurs in the last parameter, b2 With this modified algorithm, the derived Functor List instance becomes: instance Functor List where fmap f Nil = Nil fmap f (Cons x xs) = Cons (f x) (fmap f xs) No lambdas in sight, just the way we like it. This special case does not prevent all sources quadratic closure buildup, however. In this example: data PolyList a = PLNil | PLCons a (PolyList (PolyList a)) deriving Functor We would derive the following code: instance Functor PolyList where fmap f PLNil = PLNil fmap f (PLCons x xs) = PLCons (f x) (fmap (\y -> fmap f y) xs) The use of `fmap (\y -> fmap f y) xs` builds up closures in much the same way as `fmap (\y -> f y) xs`. The difference here is that even if we eta reduced to `fmap (fmap f) xs`, GHC would /still/ build up a closure, since we are recursively invoking fmap with a different argument (fmap f). Since we end up paying the price of building a closure either way, we do not extend the special case in $fmap any further, since it wouldn't buy us anything. The ft_ty_app field of FFoldType distinguishes between these two $fmap cases by inspecting the argument type. If the argument type is a bare type variable, then we can conclude the type variable /must/ be the same as the data type's last type parameter. We know that this must be the case since there is an invariant that the argument type in ft_ty_app will always contain the last type parameter somewhere (see Note [FFoldType and functorLikeTraverse]), so if the argument type is a bare variable, then that must be exactly the last type parameter. Note that the ft_ty_app case of ft_replace (which derives implementations of (<$)) also inspects the argument type to generate more efficient code. See Note [Deriving <$]. Note [Deriving <$] ~~~~~~~~~~~~~~~~~~ We derive the definition of <$. Allowing this to take the default definition can lead to memory leaks: mapping over a structure with a constant function can fill the result structure with trivial thunks that retain the values from the original structure. The simplifier seems to handle this all right for simple types, but not for recursive ones. Consider data Tree a = Bin !(Tree a) a !(Tree a) | Tip deriving Functor -- fmap _ Tip = Tip -- fmap f (Bin l v r) = Bin (fmap f l) (f v) (fmap f r) Using the default definition of <$, we get (<$) x = fmap (\_ -> x) and that simplifies no further. Why is that? `fmap` is defined recursively, so GHC cannot inline it. The static argument transformation would turn the definition into a non-recursive one -- fmap f = go where -- go Tip = Tip -- go (Bin l v r) = Bin (go l) (f v) (go r) which GHC could inline, producing an efficient definion of `<$`. But there are several problems. First, GHC does not perform the static argument transformation by default, even with -O2. Second, even when it does perform the static argument transformation, it does so only when there are at least two static arguments, which is not the case for fmap. Finally, when the type in question is non-regular, such as data Nesty a = Z a | S (Nesty a) (Nest (a, a)) the function argument is no longer (entirely) static, so the static argument transformation will do nothing for us. Applying the default definition of `<$` will produce a tree full of thunks that look like ((\_ -> x) x0), which represents unnecessary thunk allocation and also retention of the previous value, potentially leaking memory. Instead, we derive <$ separately. Two aspects are different from fmap: the case of the sought type variable (ft_var) and the case of a type application (ft_ty_app). The interesting one is ft_ty_app. We have to distinguish two cases: the "immediate" case where the type argument *is* the sought type variable, and the "nested" case where the type argument *contains* the sought type variable. The immediate case: Suppose we have data Imm a = Imm (F ... a) Then we want to define x <$ Imm q = Imm (x <$ q) The nested case: Suppose we have data Nes a = Nes (F ... (G a)) Then we want to define x <$ Nes q = Nes (fmap (x <$) q) We inspect the argument type in ft_ty_app (see Note [FFoldType and functorLikeTraverse]) to distinguish between these two cases. If the argument type is a bare type variable, then we know that it must be the same variable as the data type's last type parameter. This is very similar to a trick that derived fmap implementations use in their own ft_ty_app case. See Note [Avoid unnecessary eta expansion in derived fmap implementations], which explains why checking if the argument type is a bare variable is the right thing to do. We could, but do not, give tuples special treatment to improve efficiency in some cases. Suppose we have data Nest a = Z a | S (Nest (a,a)) The optimal definition would be x <$ Z _ = Z x x <$ S t = S ((x, x) <$ t) which produces a result with maximal internal sharing. The reason we do not attempt to treat this case specially is that we have no way to give user-provided tuple-like types similar treatment. If the user changed the definition to data Pair a = Pair a a data Nest a = Z a | S (Nest (Pair a)) they would experience a surprising degradation in performance. -} {- Utility functions related to Functor deriving. Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse. This function works like a fold: it makes a value of type 'a' in a bottom up way. -} -- Generic traversal for Functor deriving -- See Note [FFoldType and functorLikeTraverse] data FFoldType a -- Describes how to fold over a Type in a functor like way = FT { forall a. FFoldType a -> a ft_triv :: a -- ^ Does not contain variable , forall a. FFoldType a -> a ft_var :: a -- ^ The variable itself , forall a. FFoldType a -> a ft_co_var :: a -- ^ The variable itself, contravariantly , forall a. FFoldType a -> a -> a -> a ft_fun :: a -> a -> a -- ^ Function type , forall a. FFoldType a -> TyCon -> [a] -> a ft_tup :: TyCon -> [a] -> a -- ^ Tuple type. The @[a]@ is the result of folding over the -- arguments of the tuple. , forall a. FFoldType a -> Type -> Type -> a -> a ft_ty_app :: Type -> Type -> a -> a -- ^ Type app, variable only in last argument. The two 'Type's are -- the function and argument parts of @fun_ty arg_ty@, -- respectively. , forall a. FFoldType a -> a ft_bad_app :: a -- ^ Type app, variable other than in last argument , forall a. FFoldType a -> Id -> a -> a ft_forall :: TcTyVar -> a -> a -- ^ Forall type } functorLikeTraverse :: forall a. TyVar -- ^ Variable to look for -> FFoldType a -- ^ How to fold -> Type -- ^ Type to process -> a functorLikeTraverse :: forall a. Id -> FFoldType a -> Type -> a functorLikeTraverse Id var (FT { ft_triv :: forall a. FFoldType a -> a ft_triv = a caseTrivial, ft_var :: forall a. FFoldType a -> a ft_var = a caseVar , ft_co_var :: forall a. FFoldType a -> a ft_co_var = a caseCoVar, ft_fun :: forall a. FFoldType a -> a -> a -> a ft_fun = a -> a -> a caseFun , ft_tup :: forall a. FFoldType a -> TyCon -> [a] -> a ft_tup = TyCon -> [a] -> a caseTuple, ft_ty_app :: forall a. FFoldType a -> Type -> Type -> a -> a ft_ty_app = Type -> Type -> a -> a caseTyApp , ft_bad_app :: forall a. FFoldType a -> a ft_bad_app = a caseWrongArg, ft_forall :: forall a. FFoldType a -> Id -> a -> a ft_forall = Id -> a -> a caseForAll }) Type ty = forall a b. (a, b) -> a fst (Bool -> Type -> (a, Bool) go Bool False Type ty) where go :: Bool -- Covariant or contravariant context -> Type -> (a, Bool) -- (result of type a, does type contain var) go :: Bool -> Type -> (a, Bool) go Bool co Type ty | Just Type ty' <- Type -> Maybe Type tcView Type ty = Bool -> Type -> (a, Bool) go Bool co Type ty' go Bool co (TyVarTy Id v) | Id v forall a. Eq a => a -> a -> Bool == Id var = (if Bool co then a caseCoVar else a caseVar,Bool True) go Bool co (FunTy { ft_arg :: Type -> Type ft_arg = Type x, ft_res :: Type -> Type ft_res = Type y, ft_af :: Type -> AnonArgFlag ft_af = AnonArgFlag af }) | AnonArgFlag InvisArg <- AnonArgFlag af = Bool -> Type -> (a, Bool) go Bool co Type y | Bool xc Bool -> Bool -> Bool || Bool yc = (a -> a -> a caseFun a xr a yr,Bool True) where (a xr,Bool xc) = Bool -> Type -> (a, Bool) go (Bool -> Bool not Bool co) Type x (a yr,Bool yc) = Bool -> Type -> (a, Bool) go Bool co Type y go Bool co (AppTy Type x Type y) | Bool xc = (a caseWrongArg, Bool True) | Bool yc = (Type -> Type -> a -> a caseTyApp Type x Type y a yr, Bool True) where (a _, Bool xc) = Bool -> Type -> (a, Bool) go Bool co Type x (a yr,Bool yc) = Bool -> Type -> (a, Bool) go Bool co Type y go Bool co ty :: Type ty@(TyConApp TyCon con [Type] args) | Bool -> Bool not (forall (t :: * -> *). Foldable t => t Bool -> Bool or [Bool] xcs) = (a caseTrivial, Bool False) -- Variable does not occur -- At this point we know that xrs, xcs is not empty, -- and at least one xr is True | TyCon -> Bool isTupleTyCon TyCon con = (TyCon -> [a] -> a caseTuple TyCon con [a] xrs, Bool True) | forall (t :: * -> *). Foldable t => t Bool -> Bool or (forall a. [a] -> [a] init [Bool] xcs) = (a caseWrongArg, Bool True) -- T (..var..) ty | Just (Type fun_ty, Type arg_ty) <- Type -> Maybe (Type, Type) splitAppTy_maybe Type ty -- T (..no var..) ty = (Type -> Type -> a -> a caseTyApp Type fun_ty Type arg_ty (forall a. [a] -> a last [a] xrs), Bool True) | Bool otherwise = (a caseWrongArg, Bool True) -- Non-decomposable (eg type function) where -- When folding over an unboxed tuple, we must explicitly drop the -- runtime rep arguments, or else GHC will generate twice as many -- variables in a unboxed tuple pattern match and expression as it -- actually needs. See #12399 ([a] xrs,[Bool] xcs) = forall a b. [(a, b)] -> ([a], [b]) unzip (forall a b. (a -> b) -> [a] -> [b] map (Bool -> Type -> (a, Bool) go Bool co) ([Type] -> [Type] dropRuntimeRepArgs [Type] args)) go Bool co (ForAllTy (Bndr Id v ArgFlag vis) Type x) | ArgFlag -> Bool isVisibleArgFlag ArgFlag vis = forall a. String -> a panic String "unexpected visible binder" | Id v forall a. Eq a => a -> a -> Bool /= Id var Bool -> Bool -> Bool && Bool xc = (Id -> a -> a caseForAll Id v a xr,Bool True) where (a xr,Bool xc) = Bool -> Type -> (a, Bool) go Bool co Type x go Bool _ Type _ = (a caseTrivial,Bool False) -- Return all syntactic subterms of ty that contain var somewhere -- These are the things that should appear in instance constraints deepSubtypesContaining :: TyVar -> Type -> [TcType] deepSubtypesContaining :: Id -> Type -> [Type] deepSubtypesContaining Id tv = forall a. Id -> FFoldType a -> Type -> a functorLikeTraverse Id tv (FT { ft_triv :: [Type] ft_triv = [] , ft_var :: [Type] ft_var = [] , ft_fun :: [Type] -> [Type] -> [Type] ft_fun = forall a. [a] -> [a] -> [a] (++) , ft_tup :: TyCon -> [[Type]] -> [Type] ft_tup = \TyCon _ [[Type]] xs -> forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [[Type]] xs , ft_ty_app :: Type -> Type -> [Type] -> [Type] ft_ty_app = \Type t Type _ [Type] ts -> Type tforall a. a -> [a] -> [a] :[Type] ts , ft_bad_app :: [Type] ft_bad_app = forall a. String -> a panic String "in other argument in deepSubtypesContaining" , ft_co_var :: [Type] ft_co_var = forall a. String -> a panic String "contravariant in deepSubtypesContaining" , ft_forall :: Id -> [Type] -> [Type] ft_forall = \Id v [Type] xs -> forall a. (a -> Bool) -> [a] -> [a] filterOut ((Id v Id -> VarSet -> Bool `elemVarSet`) forall b c a. (b -> c) -> (a -> b) -> a -> c . Type -> VarSet tyCoVarsOfType) [Type] xs }) foldDataConArgs :: FFoldType a -> DataCon -> [a] -- Fold over the arguments of the datacon foldDataConArgs :: forall a. FFoldType a -> DataCon -> [a] foldDataConArgs FFoldType a ft DataCon con = forall a b. (a -> b) -> [a] -> [b] map Type -> a foldArg (forall a b. (a -> b) -> [a] -> [b] map forall a. Scaled a -> a scaledThing forall a b. (a -> b) -> a -> b $ DataCon -> [Scaled Type] dataConOrigArgTys DataCon con) where foldArg :: Type -> a foldArg = case Type -> Maybe Id getTyVar_maybe (forall a. [a] -> a last (Type -> [Type] tyConAppArgs (DataCon -> Type dataConOrigResTy DataCon con))) of Just Id tv -> forall a. Id -> FFoldType a -> Type -> a functorLikeTraverse Id tv FFoldType a ft Maybe Id Nothing -> forall a b. a -> b -> a const (forall a. FFoldType a -> a ft_triv FFoldType a ft) -- If we are deriving Foldable for a GADT, there is a chance that the last -- type variable in the data type isn't actually a type variable at all. -- (for example, this can happen if the last type variable is refined to -- be a concrete type such as Int). If the last type variable is refined -- to be a specific type, then getTyVar_maybe will return Nothing. -- See Note [DeriveFoldable with ExistentialQuantification] -- -- The kind checks have ensured the last type parameter is of kind *. -- Make a HsLam using a fresh variable from a State monad mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) -> State [RdrName] (LHsExpr GhcPs) -- (mkSimpleLam fn) returns (\x. fn(x)) mkSimpleLam :: (LHsExpr (GhcPass 'Parsed) -> State [RdrName] (LHsExpr (GhcPass 'Parsed))) -> State [RdrName] (LHsExpr (GhcPass 'Parsed)) mkSimpleLam LHsExpr (GhcPass 'Parsed) -> State [RdrName] (LHsExpr (GhcPass 'Parsed)) lam = forall s. State s s get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case RdrName n:[RdrName] names -> do forall s. s -> State s () put [RdrName] names LocatedA (HsExpr (GhcPass 'Parsed)) body <- LHsExpr (GhcPass 'Parsed) -> State [RdrName] (LHsExpr (GhcPass 'Parsed)) lam (forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LHsExpr (GhcPass p) nlHsVar RdrName n) forall (m :: * -> *) a. Monad m => a -> m a return (forall (p :: Pass). (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) => [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) mkHsLam [forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LPat (GhcPass p) nlVarPat RdrName n] LocatedA (HsExpr (GhcPass 'Parsed)) body) [RdrName] _ -> forall a. String -> a panic String "mkSimpleLam" mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs)) -> State [RdrName] (LHsExpr GhcPs) mkSimpleLam2 :: (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed) -> State [RdrName] (LHsExpr (GhcPass 'Parsed))) -> State [RdrName] (LHsExpr (GhcPass 'Parsed)) mkSimpleLam2 LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed) -> State [RdrName] (LHsExpr (GhcPass 'Parsed)) lam = forall s. State s s get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= \case RdrName n1:RdrName n2:[RdrName] names -> do forall s. s -> State s () put [RdrName] names LocatedA (HsExpr (GhcPass 'Parsed)) body <- LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed) -> State [RdrName] (LHsExpr (GhcPass 'Parsed)) lam (forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LHsExpr (GhcPass p) nlHsVar RdrName n1) (forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LHsExpr (GhcPass p) nlHsVar RdrName n2) forall (m :: * -> *) a. Monad m => a -> m a return (forall (p :: Pass). (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) => [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) mkHsLam [forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LPat (GhcPass p) nlVarPat RdrName n1,forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LPat (GhcPass p) nlVarPat RdrName n2] LocatedA (HsExpr (GhcPass 'Parsed)) body) [RdrName] _ -> forall a. String -> a panic String "mkSimpleLam2" -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]" -- -- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in -- which the LHS pattern-matches on @extra_pats@, followed by a match on the -- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@ -- and its arguments, applying an expression (from @insides@) to each of the -- respective arguments of @con@. mkSimpleConMatch :: Monad m => HsMatchContext GhcPs -> (RdrName -> [a] -> m (LHsExpr GhcPs)) -> [LPat GhcPs] -> DataCon -> [LHsExpr GhcPs -> a] -> m (LMatch GhcPs (LHsExpr GhcPs)) mkSimpleConMatch :: forall (m :: * -> *) a. Monad m => HsMatchContext (GhcPass 'Parsed) -> (RdrName -> [a] -> m (LHsExpr (GhcPass 'Parsed))) -> [LPat (GhcPass 'Parsed)] -> DataCon -> [LHsExpr (GhcPass 'Parsed) -> a] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) mkSimpleConMatch HsMatchContext (GhcPass 'Parsed) ctxt RdrName -> [a] -> m (LHsExpr (GhcPass 'Parsed)) fold [LPat (GhcPass 'Parsed)] extra_pats DataCon con [LHsExpr (GhcPass 'Parsed) -> a] insides = do let con_name :: RdrName con_name = forall thing. NamedThing thing => thing -> RdrName getRdrName DataCon con let vars_needed :: [RdrName] vars_needed = forall b a. [b] -> [a] -> [a] takeList [LHsExpr (GhcPass 'Parsed) -> a] insides [RdrName] as_RDRs let bare_pat :: LPat (GhcPass 'Parsed) bare_pat = RdrName -> [RdrName] -> LPat (GhcPass 'Parsed) nlConVarPat RdrName con_name [RdrName] vars_needed let pat :: LPat (GhcPass 'Parsed) pat = if forall (t :: * -> *) a. Foldable t => t a -> Bool null [RdrName] vars_needed then LPat (GhcPass 'Parsed) bare_pat else forall (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name) nlParPat LPat (GhcPass 'Parsed) bare_pat LocatedA (HsExpr (GhcPass 'Parsed)) rhs <- RdrName -> [a] -> m (LHsExpr (GhcPass 'Parsed)) fold RdrName con_name (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith (\LocatedA (HsExpr (GhcPass 'Parsed)) -> a i RdrName v -> LocatedA (HsExpr (GhcPass 'Parsed)) -> a i forall a b. (a -> b) -> a -> b $ forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LHsExpr (GhcPass p) nlHsVar RdrName v) [LHsExpr (GhcPass 'Parsed) -> a] insides [RdrName] vars_needed) forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall (p :: Pass). IsPass p => HsMatchContext (NoGhcTc (GhcPass p)) -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> HsLocalBinds (GhcPass p) -> LMatch (GhcPass p) (LHsExpr (GhcPass p)) mkMatch HsMatchContext (GhcPass 'Parsed) ctxt ([LPat (GhcPass 'Parsed)] extra_pats forall a. [a] -> [a] -> [a] ++ [LPat (GhcPass 'Parsed) pat]) LocatedA (HsExpr (GhcPass 'Parsed)) rhs forall (a :: Pass) (b :: Pass). HsLocalBindsLR (GhcPass a) (GhcPass b) emptyLocalBinds -- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)" -- -- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to -- 'mkSimpleConMatch', with two key differences: -- -- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a -- @[LHsExpr RdrName]@. This is because it filters out the expressions -- corresponding to arguments whose types do not mention the last type -- variable in a derived 'Foldable' or 'Traversable' instance (i.e., the -- 'Nothing' elements of @insides@). -- -- 2. @fold@ takes an expression as its first argument instead of a -- constructor name. This is because it uses a specialized -- constructor function expression that only takes as many parameters as -- there are argument types that mention the last type variable. -- -- See Note [Generated code for DeriveFoldable and DeriveTraversable] mkSimpleConMatch2 :: Monad m => HsMatchContext GhcPs -> (LHsExpr GhcPs -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs)) -> [LPat GhcPs] -> DataCon -> [Maybe (LHsExpr GhcPs)] -> m (LMatch GhcPs (LHsExpr GhcPs)) mkSimpleConMatch2 :: forall (m :: * -> *). Monad m => HsMatchContext (GhcPass 'Parsed) -> (LHsExpr (GhcPass 'Parsed) -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed))) -> [LPat (GhcPass 'Parsed)] -> DataCon -> [Maybe (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) mkSimpleConMatch2 HsMatchContext (GhcPass 'Parsed) ctxt LHsExpr (GhcPass 'Parsed) -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed)) fold [LPat (GhcPass 'Parsed)] extra_pats DataCon con [Maybe (LHsExpr (GhcPass 'Parsed))] insides = do let con_name :: RdrName con_name = forall thing. NamedThing thing => thing -> RdrName getRdrName DataCon con vars_needed :: [RdrName] vars_needed = forall b a. [b] -> [a] -> [a] takeList [Maybe (LHsExpr (GhcPass 'Parsed))] insides [RdrName] as_RDRs pat :: LPat (GhcPass 'Parsed) pat = RdrName -> [RdrName] -> LPat (GhcPass 'Parsed) nlConVarPat RdrName con_name [RdrName] vars_needed -- Make sure to zip BEFORE invoking catMaybes. We want the variable -- indices in each expression to match up with the argument indices -- in con_expr (defined below). exps :: [LocatedA (HsExpr (GhcPass 'Parsed))] exps = forall a. [Maybe a] -> [a] catMaybes forall a b. (a -> b) -> a -> b $ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c] zipWith (\Maybe (LocatedA (HsExpr (GhcPass 'Parsed))) i RdrName v -> (forall (id :: Pass). IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) `nlHsApp` forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LHsExpr (GhcPass p) nlHsVar RdrName v) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Maybe (LocatedA (HsExpr (GhcPass 'Parsed))) i) [Maybe (LHsExpr (GhcPass 'Parsed))] insides [RdrName] vars_needed -- An element of argTysTyVarInfo is True if the constructor argument -- with the same index has a type which mentions the last type -- variable. argTysTyVarInfo :: [Bool] argTysTyVarInfo = forall a b. (a -> b) -> [a] -> [b] map forall a. Maybe a -> Bool isJust [Maybe (LHsExpr (GhcPass 'Parsed))] insides ([LocatedA (HsExpr (GhcPass 'Parsed))] asWithTyVar, [LocatedA (HsExpr (GhcPass 'Parsed))] asWithoutTyVar) = forall a. [Bool] -> [a] -> ([a], [a]) partitionByList [Bool] argTysTyVarInfo [LHsExpr (GhcPass 'Parsed)] as_Vars con_expr :: LHsExpr (GhcPass 'Parsed) con_expr | forall (t :: * -> *) a. Foldable t => t a -> Bool null [LocatedA (HsExpr (GhcPass 'Parsed))] asWithTyVar = forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p) nlHsApps RdrName con_name [LocatedA (HsExpr (GhcPass 'Parsed))] asWithoutTyVar | Bool otherwise = let bs :: [RdrName] bs = forall a. [Bool] -> [a] -> [a] filterByList [Bool] argTysTyVarInfo [RdrName] bs_RDRs vars :: [LocatedA (HsExpr (GhcPass 'Parsed))] vars = forall a. [Bool] -> [a] -> [a] -> [a] filterByLists [Bool] argTysTyVarInfo [LHsExpr (GhcPass 'Parsed)] bs_Vars [LHsExpr (GhcPass 'Parsed)] as_Vars in forall (p :: Pass). (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) => [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) mkHsLam (forall a b. (a -> b) -> [a] -> [b] map forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LPat (GhcPass p) nlVarPat [RdrName] bs) (forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p) nlHsApps RdrName con_name [LocatedA (HsExpr (GhcPass 'Parsed))] vars) LocatedA (HsExpr (GhcPass 'Parsed)) rhs <- LHsExpr (GhcPass 'Parsed) -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed)) fold LHsExpr (GhcPass 'Parsed) con_expr [LocatedA (HsExpr (GhcPass 'Parsed))] exps forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall (p :: Pass). IsPass p => HsMatchContext (NoGhcTc (GhcPass p)) -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> HsLocalBinds (GhcPass p) -> LMatch (GhcPass p) (LHsExpr (GhcPass p)) mkMatch HsMatchContext (GhcPass 'Parsed) ctxt ([LPat (GhcPass 'Parsed)] extra_pats forall a. [a] -> [a] -> [a] ++ [LPat (GhcPass 'Parsed) pat]) LocatedA (HsExpr (GhcPass 'Parsed)) rhs forall (a :: Pass) (b :: Pass). HsLocalBindsLR (GhcPass a) (GhcPass b) emptyLocalBinds -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" mkSimpleTupleCase :: Monad m => ([LPat GhcPs] -> DataCon -> [a] -> m (LMatch GhcPs (LHsExpr GhcPs))) -> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs) mkSimpleTupleCase :: forall (m :: * -> *) a. Monad m => ([LPat (GhcPass 'Parsed)] -> DataCon -> [a] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))) -> TyCon -> [a] -> LHsExpr (GhcPass 'Parsed) -> m (LHsExpr (GhcPass 'Parsed)) mkSimpleTupleCase [LPat (GhcPass 'Parsed)] -> DataCon -> [a] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) match_for_con TyCon tc [a] insides LHsExpr (GhcPass 'Parsed) x = do { let data_con :: DataCon data_con = TyCon -> DataCon tyConSingleDataCon TyCon tc ; GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))) match <- [LPat (GhcPass 'Parsed)] -> DataCon -> [a] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) match_for_con [] DataCon data_con [a] insides ; forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ LHsExpr (GhcPass 'Parsed) -> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))] -> LHsExpr (GhcPass 'Parsed) nlHsCase LHsExpr (GhcPass 'Parsed) x [GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))) match] } {- ************************************************************************ * * Foldable instances see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html * * ************************************************************************ Deriving Foldable instances works the same way as Functor instances, only Foldable instances are not possible for function types at all. Given (data T a = T a a (T a) deriving Foldable), we get: instance Foldable T where foldr f z (T x1 x2 x3) = $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) ) -XDeriveFoldable is different from -XDeriveFunctor in that it filters out arguments to the constructor that would produce useless code in a Foldable instance. For example, the following datatype: data Foo a = Foo Int a Int deriving Foldable would have the following generated Foldable instance: instance Foldable Foo where foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2 since neither of the two Int arguments are folded over. The cases are: $(foldr 'a 'a) = f $(foldr 'a '(b1,b2)) = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z ) $(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2 Note that the arguments to the real foldr function are the wrong way around, since (f :: a -> b -> b), while (foldr f :: b -> t a -> b). One can envision a case for types that don't contain the last type variable: $(foldr 'a 'b) = \x z -> z -- when b does not contain a But this case will never materialize, since the aforementioned filtering removes all such types from consideration. See Note [Generated code for DeriveFoldable and DeriveTraversable]. Foldable instances differ from Functor and Traversable instances in that Foldable instances can be derived for data types in which the last type variable is existentially quantified. In particular, if the last type variable is refined to a more specific type in a GADT: data GADT a where G :: a ~ Int => a -> G Int then the deriving machinery does not attempt to check that the type a contains Int, since it is not syntactically equal to a type variable. That is, the derived Foldable instance for GADT is: instance Foldable GADT where foldr _ z (GADT _) = z See Note [DeriveFoldable with ExistentialQuantification]. Note [Deriving null] ~~~~~~~~~~~~~~~~~~~~ In some cases, deriving the definition of 'null' can produce much better results than the default definition. For example, with data SnocList a = Nil | Snoc (SnocList a) a the default definition of 'null' would walk the entire spine of a nonempty snoc-list before concluding that it is not null. But looking at the Snoc constructor, we can immediately see that it contains an 'a', and so 'null' can return False immediately if it matches on Snoc. When we derive 'null', we keep track of things that cannot be null. The interesting case is type application. Given data Wrap a = Wrap (Foo (Bar a)) we use null (Wrap fba) = all null fba but if we see data Wrap a = Wrap (Foo a) we can just use null (Wrap fa) = null fa Indeed, we allow this to happen even for tuples: data Wrap a = Wrap (Foo (a, Int)) produces null (Wrap fa) = null fa As explained in Note [Deriving <$], giving tuples special performance treatment could surprise users if they switch to other types, but Ryan Scott seems to think it's okay to do it for now. -} gen_Foldable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff) -- When the parameter is phantom, we can use foldMap _ _ = mempty -- See Note [Phantom types with Functor, Foldable, and Traversable] gen_Foldable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds (GhcPass 'Parsed), BagDerivStuff) gen_Foldable_binds SrcSpan loc TyCon tycon [Type] _ | Role Phantom <- forall a. [a] -> a last (TyCon -> [Role] tyConRoles TyCon tycon) = (forall a. a -> Bag a unitBag LHsBind (GhcPass 'Parsed) foldMap_bind, forall a. Bag a emptyBag) where foldMap_name :: GenLocated SrcSpanAnnN RdrName foldMap_name = forall l e. l -> e -> GenLocated l e L (forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc) RdrName foldMap_RDR foldMap_bind :: LHsBind (GhcPass 'Parsed) foldMap_bind = GenLocated SrcSpanAnnN RdrName -> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))] -> LHsBind (GhcPass 'Parsed) mkRdrFunBind GenLocated SrcSpanAnnN RdrName foldMap_name [GenLocated (Anno (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))) (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))] foldMap_eqns foldMap_eqns :: [GenLocated (Anno (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))) (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))] foldMap_eqns = [forall (p :: Pass) (body :: * -> *). (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA, Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan) => HsMatchContext (NoGhcTc (GhcPass p)) -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p)) -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) mkSimpleMatch HsMatchContext (GhcPass (NoGhcTcPass 'Parsed)) foldMap_match_ctxt [LPat (GhcPass 'Parsed) nlWildPat, LPat (GhcPass 'Parsed) nlWildPat] LHsExpr (GhcPass 'Parsed) mempty_Expr] foldMap_match_ctxt :: HsMatchContext (GhcPass (NoGhcTcPass 'Parsed)) foldMap_match_ctxt = forall p. LIdP p -> HsMatchContext p mkPrefixFunRhs GenLocated SrcSpanAnnN RdrName foldMap_name gen_Foldable_binds SrcSpan loc TyCon tycon [Type] tycon_args | forall (t :: * -> *) a. Foldable t => t a -> Bool null [DataCon] data_cons -- There's no real point producing anything but -- foldMap for a type with no constructors. = (forall a. a -> Bag a unitBag LHsBind (GhcPass 'Parsed) foldMap_bind, forall a. Bag a emptyBag) | Bool otherwise = (forall a. [a] -> Bag a listToBag [LHsBind (GhcPass 'Parsed) foldr_bind, LHsBind (GhcPass 'Parsed) foldMap_bind, LHsBind (GhcPass 'Parsed) null_bind], forall a. Bag a emptyBag) where data_cons :: [DataCon] data_cons = TyCon -> [Type] -> [DataCon] getPossibleDataCons TyCon tycon [Type] tycon_args foldr_bind :: LHsBind (GhcPass 'Parsed) foldr_bind = GenLocated SrcSpanAnnN RdrName -> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))] -> LHsBind (GhcPass 'Parsed) mkRdrFunBind (forall l e. l -> e -> GenLocated l e L (forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc) RdrName foldable_foldr_RDR) [GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))] eqns eqns :: [GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))] eqns = forall a b. (a -> b) -> [a] -> [b] map DataCon -> GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))) foldr_eqn [DataCon] data_cons foldr_eqn :: DataCon -> GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))) foldr_eqn DataCon con = forall s a. State s a -> s -> a evalState (forall (m :: * -> *). Monad m => LHsExpr (GhcPass 'Parsed) -> [LPat (GhcPass 'Parsed)] -> DataCon -> [Maybe (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) match_foldr LHsExpr (GhcPass 'Parsed) z_Expr [LPat (GhcPass 'Parsed) f_Pat,LPat (GhcPass 'Parsed) z_Pat] DataCon con forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< State [RdrName] [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))] parts) [RdrName] bs_RDRs where parts :: State [RdrName] [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))] parts = forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence forall a b. (a -> b) -> a -> b $ forall a. FFoldType a -> DataCon -> [a] foldDataConArgs FFoldType (State [RdrName] (Maybe (LHsExpr (GhcPass 'Parsed)))) ft_foldr DataCon con foldMap_name :: GenLocated SrcSpanAnnN RdrName foldMap_name = forall l e. l -> e -> GenLocated l e L (forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc) RdrName foldMap_RDR -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] foldMap_bind :: LHsBind (GhcPass 'Parsed) foldMap_bind = Int -> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)) -> GenLocated SrcSpanAnnN RdrName -> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))] -> LHsBind (GhcPass 'Parsed) mkRdrFunBindEC Int 2 (forall a b. a -> b -> a const LHsExpr (GhcPass 'Parsed) mempty_Expr) GenLocated SrcSpanAnnN RdrName foldMap_name [GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))] foldMap_eqns foldMap_eqns :: [GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))] foldMap_eqns = forall a b. (a -> b) -> [a] -> [b] map DataCon -> GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))) foldMap_eqn [DataCon] data_cons foldMap_eqn :: DataCon -> GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))) foldMap_eqn DataCon con = forall s a. State s a -> s -> a evalState (forall (m :: * -> *). Monad m => [LPat (GhcPass 'Parsed)] -> DataCon -> [Maybe (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) match_foldMap [LPat (GhcPass 'Parsed) f_Pat] DataCon con forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< State [RdrName] [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))] parts) [RdrName] bs_RDRs where parts :: State [RdrName] [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))] parts = forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence forall a b. (a -> b) -> a -> b $ forall a. FFoldType a -> DataCon -> [a] foldDataConArgs FFoldType (State [RdrName] (Maybe (LHsExpr (GhcPass 'Parsed)))) ft_foldMap DataCon con -- Given a list of NullM results, produce Nothing if any of -- them is NotNull, and otherwise produce a list of Maybes -- with Justs representing unknowns and Nothings representing -- things that are definitely null. convert :: [NullM a] -> Maybe [Maybe a] convert :: forall a. [NullM a] -> Maybe [Maybe a] convert = forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse forall {a}. NullM a -> Maybe (Maybe a) go where go :: NullM a -> Maybe (Maybe a) go NullM a IsNull = forall a. a -> Maybe a Just forall a. Maybe a Nothing go NullM a NotNull = forall a. Maybe a Nothing go (NullM a a) = forall a. a -> Maybe a Just (forall a. a -> Maybe a Just a a) null_name :: GenLocated SrcSpanAnnN RdrName null_name = forall l e. l -> e -> GenLocated l e L (forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc) RdrName null_RDR null_match_ctxt :: HsMatchContext (GhcPass (NoGhcTcPass 'Parsed)) null_match_ctxt = forall p. LIdP p -> HsMatchContext p mkPrefixFunRhs GenLocated SrcSpanAnnN RdrName null_name null_bind :: LHsBind (GhcPass 'Parsed) null_bind = GenLocated SrcSpanAnnN RdrName -> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))] -> LHsBind (GhcPass 'Parsed) mkRdrFunBind GenLocated SrcSpanAnnN RdrName null_name [GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))] null_eqns null_eqns :: [GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))] null_eqns = forall a b. (a -> b) -> [a] -> [b] map DataCon -> GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))) null_eqn [DataCon] data_cons null_eqn :: DataCon -> GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))) null_eqn DataCon con = forall a b c. (a -> b -> c) -> b -> a -> c flip forall s a. State s a -> s -> a evalState [RdrName] bs_RDRs forall a b. (a -> b) -> a -> b $ do [NullM (LocatedA (HsExpr (GhcPass 'Parsed)))] parts <- forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence forall a b. (a -> b) -> a -> b $ forall a. FFoldType a -> DataCon -> [a] foldDataConArgs FFoldType (State [RdrName] (NullM (LHsExpr (GhcPass 'Parsed)))) ft_null DataCon con case forall a. [NullM a] -> Maybe [Maybe a] convert [NullM (LocatedA (HsExpr (GhcPass 'Parsed)))] parts of Maybe [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))] Nothing -> forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall (p :: Pass). IsPass p => HsMatchContext (NoGhcTc (GhcPass p)) -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> HsLocalBinds (GhcPass p) -> LMatch (GhcPass p) (LHsExpr (GhcPass p)) mkMatch HsMatchContext (GhcPass (NoGhcTcPass 'Parsed)) null_match_ctxt [forall (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name) nlParPat (DataCon -> LPat (GhcPass 'Parsed) nlWildConPat DataCon con)] LHsExpr (GhcPass 'Parsed) false_Expr forall (a :: Pass) (b :: Pass). HsLocalBindsLR (GhcPass a) (GhcPass b) emptyLocalBinds Just [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))] cp -> forall (m :: * -> *). Monad m => [LPat (GhcPass 'Parsed)] -> DataCon -> [Maybe (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) match_null [] DataCon con [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))] cp -- Yields 'Just' an expression if we're folding over a type that mentions -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. -- See Note [FFoldType and functorLikeTraverse] ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr (GhcPass 'Parsed)))) ft_foldr = FT { ft_triv :: State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_triv = forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing -- foldr f = \x z -> z , ft_var :: State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_var = forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall a. a -> Maybe a Just LHsExpr (GhcPass 'Parsed) f_Expr -- foldr f = f , ft_tup :: TyCon -> [State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))] -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_tup = \TyCon t [State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))] g -> do [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))] gg <- forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence [State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))] g LocatedA (HsExpr (GhcPass 'Parsed)) lam <- (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed) -> State [RdrName] (LHsExpr (GhcPass 'Parsed))) -> State [RdrName] (LHsExpr (GhcPass 'Parsed)) mkSimpleLam2 forall a b. (a -> b) -> a -> b $ \LHsExpr (GhcPass 'Parsed) x LHsExpr (GhcPass 'Parsed) z -> forall (m :: * -> *) a. Monad m => ([LPat (GhcPass 'Parsed)] -> DataCon -> [a] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))) -> TyCon -> [a] -> LHsExpr (GhcPass 'Parsed) -> m (LHsExpr (GhcPass 'Parsed)) mkSimpleTupleCase (forall (m :: * -> *). Monad m => LHsExpr (GhcPass 'Parsed) -> [LPat (GhcPass 'Parsed)] -> DataCon -> [Maybe (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) match_foldr LHsExpr (GhcPass 'Parsed) z) TyCon t [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))] gg LHsExpr (GhcPass 'Parsed) x forall (m :: * -> *) a. Monad m => a -> m a return (forall a. a -> Maybe a Just LocatedA (HsExpr (GhcPass 'Parsed)) lam) -- foldr f = (\x z -> case x of ...) , ft_ty_app :: Type -> Type -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_ty_app = \Type _ Type _ State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) g -> do Maybe (LocatedA (HsExpr (GhcPass 'Parsed))) gg <- State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) g forall (t :: * -> *) (m :: * -> *) a b. (Traversable t, Monad m) => (a -> m b) -> t a -> m (t b) mapM (\LocatedA (HsExpr (GhcPass 'Parsed)) gg' -> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed) -> State [RdrName] (LHsExpr (GhcPass 'Parsed))) -> State [RdrName] (LHsExpr (GhcPass 'Parsed)) mkSimpleLam2 forall a b. (a -> b) -> a -> b $ \LHsExpr (GhcPass 'Parsed) x LHsExpr (GhcPass 'Parsed) z -> forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p) nlHsApps RdrName foldable_foldr_RDR [LocatedA (HsExpr (GhcPass 'Parsed)) gg',LHsExpr (GhcPass 'Parsed) z,LHsExpr (GhcPass 'Parsed) x]) Maybe (LocatedA (HsExpr (GhcPass 'Parsed))) gg -- foldr f = (\x z -> foldr g z x) , ft_forall :: Id -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_forall = \Id _ State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) g -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) g , ft_co_var :: State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_co_var = forall a. String -> a panic String "contravariant in ft_foldr" , ft_fun :: State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_fun = forall a. String -> a panic String "function in ft_foldr" , ft_bad_app :: State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_bad_app = forall a. String -> a panic String "in other argument in ft_foldr" } match_foldr :: Monad m => LHsExpr GhcPs -> [LPat GhcPs] -> DataCon -> [Maybe (LHsExpr GhcPs)] -> m (LMatch GhcPs (LHsExpr GhcPs)) match_foldr :: forall (m :: * -> *). Monad m => LHsExpr (GhcPass 'Parsed) -> [LPat (GhcPass 'Parsed)] -> DataCon -> [Maybe (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) match_foldr LHsExpr (GhcPass 'Parsed) z = forall (m :: * -> *). Monad m => HsMatchContext (GhcPass 'Parsed) -> (LHsExpr (GhcPass 'Parsed) -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed))) -> [LPat (GhcPass 'Parsed)] -> DataCon -> [Maybe (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) mkSimpleConMatch2 forall p. HsMatchContext p LambdaExpr forall a b. (a -> b) -> a -> b $ \LHsExpr (GhcPass 'Parsed) _ [LHsExpr (GhcPass 'Parsed)] xs -> forall (m :: * -> *) a. Monad m => a -> m a return ([LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed) mkFoldr [LHsExpr (GhcPass 'Parsed)] xs) where -- g1 v1 (g2 v2 (.. z)) mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs mkFoldr :: [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed) mkFoldr = forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr forall (id :: Pass). IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) nlHsApp LHsExpr (GhcPass 'Parsed) z -- See Note [FFoldType and functorLikeTraverse] ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr (GhcPass 'Parsed)))) ft_foldMap = FT { ft_triv :: State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_triv = forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing -- foldMap f = \x -> mempty , ft_var :: State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_var = forall (m :: * -> *) a. Monad m => a -> m a return (forall a. a -> Maybe a Just LHsExpr (GhcPass 'Parsed) f_Expr) -- foldMap f = f , ft_tup :: TyCon -> [State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))] -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_tup = \TyCon t [State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))] g -> do [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))] gg <- forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence [State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))] g LocatedA (HsExpr (GhcPass 'Parsed)) lam <- (LHsExpr (GhcPass 'Parsed) -> State [RdrName] (LHsExpr (GhcPass 'Parsed))) -> State [RdrName] (LHsExpr (GhcPass 'Parsed)) mkSimpleLam forall a b. (a -> b) -> a -> b $ forall (m :: * -> *) a. Monad m => ([LPat (GhcPass 'Parsed)] -> DataCon -> [a] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))) -> TyCon -> [a] -> LHsExpr (GhcPass 'Parsed) -> m (LHsExpr (GhcPass 'Parsed)) mkSimpleTupleCase forall (m :: * -> *). Monad m => [LPat (GhcPass 'Parsed)] -> DataCon -> [Maybe (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) match_foldMap TyCon t [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))] gg forall (m :: * -> *) a. Monad m => a -> m a return (forall a. a -> Maybe a Just LocatedA (HsExpr (GhcPass 'Parsed)) lam) -- foldMap f = \x -> case x of (..,) , ft_ty_app :: Type -> Type -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_ty_app = \Type _ Type _ State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) g -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall (id :: Pass). IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) nlHsApp LHsExpr (GhcPass 'Parsed) foldMap_Expr) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) g -- foldMap f = foldMap g , ft_forall :: Id -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_forall = \Id _ State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) g -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) g , ft_co_var :: State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_co_var = forall a. String -> a panic String "contravariant in ft_foldMap" , ft_fun :: State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_fun = forall a. String -> a panic String "function in ft_foldMap" , ft_bad_app :: State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_bad_app = forall a. String -> a panic String "in other argument in ft_foldMap" } match_foldMap :: Monad m => [LPat GhcPs] -> DataCon -> [Maybe (LHsExpr GhcPs)] -> m (LMatch GhcPs (LHsExpr GhcPs)) match_foldMap :: forall (m :: * -> *). Monad m => [LPat (GhcPass 'Parsed)] -> DataCon -> [Maybe (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) match_foldMap = forall (m :: * -> *). Monad m => HsMatchContext (GhcPass 'Parsed) -> (LHsExpr (GhcPass 'Parsed) -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed))) -> [LPat (GhcPass 'Parsed)] -> DataCon -> [Maybe (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) mkSimpleConMatch2 forall p. HsMatchContext p CaseAlt forall a b. (a -> b) -> a -> b $ \LHsExpr (GhcPass 'Parsed) _ [LHsExpr (GhcPass 'Parsed)] xs -> forall (m :: * -> *) a. Monad m => a -> m a return ([LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed) mkFoldMap [LHsExpr (GhcPass 'Parsed)] xs) where -- mappend v1 (mappend v2 ..) mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs mkFoldMap :: [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed) mkFoldMap [] = LHsExpr (GhcPass 'Parsed) mempty_Expr mkFoldMap [LHsExpr (GhcPass 'Parsed)] xs = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a foldr1 (\LocatedA (HsExpr (GhcPass 'Parsed)) x LocatedA (HsExpr (GhcPass 'Parsed)) y -> forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p) nlHsApps RdrName mappend_RDR [LocatedA (HsExpr (GhcPass 'Parsed)) x,LocatedA (HsExpr (GhcPass 'Parsed)) y]) [LHsExpr (GhcPass 'Parsed)] xs -- See Note [FFoldType and functorLikeTraverse] -- Yields NullM an expression if we're folding over an expression -- that may or may not be null. Yields IsNull if it's certainly -- null, and yields NotNull if it's certainly not null. -- See Note [Deriving null] ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr GhcPs))) ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr (GhcPass 'Parsed)))) ft_null = FT { ft_triv :: State [RdrName] (NullM (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_triv = forall (m :: * -> *) a. Monad m => a -> m a return forall a. NullM a IsNull -- null = \_ -> True , ft_var :: State [RdrName] (NullM (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_var = forall (m :: * -> *) a. Monad m => a -> m a return forall a. NullM a NotNull -- null = \_ -> False , ft_tup :: TyCon -> [State [RdrName] (NullM (LocatedA (HsExpr (GhcPass 'Parsed))))] -> State [RdrName] (NullM (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_tup = \TyCon t [State [RdrName] (NullM (LocatedA (HsExpr (GhcPass 'Parsed))))] g -> do [NullM (LocatedA (HsExpr (GhcPass 'Parsed)))] gg <- forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence [State [RdrName] (NullM (LocatedA (HsExpr (GhcPass 'Parsed))))] g case forall a. [NullM a] -> Maybe [Maybe a] convert [NullM (LocatedA (HsExpr (GhcPass 'Parsed)))] gg of Maybe [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))] Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a pure forall a. NullM a NotNull Just [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))] ggg -> forall a. a -> NullM a NullM forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> ((LHsExpr (GhcPass 'Parsed) -> State [RdrName] (LHsExpr (GhcPass 'Parsed))) -> State [RdrName] (LHsExpr (GhcPass 'Parsed)) mkSimpleLam forall a b. (a -> b) -> a -> b $ forall (m :: * -> *) a. Monad m => ([LPat (GhcPass 'Parsed)] -> DataCon -> [a] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))) -> TyCon -> [a] -> LHsExpr (GhcPass 'Parsed) -> m (LHsExpr (GhcPass 'Parsed)) mkSimpleTupleCase forall (m :: * -> *). Monad m => [LPat (GhcPass 'Parsed)] -> DataCon -> [Maybe (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) match_null TyCon t [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))] ggg) -- null = \x -> case x of (..,) , ft_ty_app :: Type -> Type -> State [RdrName] (NullM (LocatedA (HsExpr (GhcPass 'Parsed)))) -> State [RdrName] (NullM (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_ty_app = \Type _ Type _ State [RdrName] (NullM (LocatedA (HsExpr (GhcPass 'Parsed)))) g -> forall a b c. (a -> b -> c) -> b -> a -> c flip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap State [RdrName] (NullM (LocatedA (HsExpr (GhcPass 'Parsed)))) g forall a b. (a -> b) -> a -> b $ \NullM (LocatedA (HsExpr (GhcPass 'Parsed))) nestedResult -> case NullM (LocatedA (HsExpr (GhcPass 'Parsed))) nestedResult of -- If e definitely contains the parameter, -- then we can test if (G e) contains it by -- simply checking if (G e) is null NullM (LocatedA (HsExpr (GhcPass 'Parsed))) NotNull -> forall a. a -> NullM a NullM LHsExpr (GhcPass 'Parsed) null_Expr -- This case is unreachable--it will actually be -- caught by ft_triv NullM (LocatedA (HsExpr (GhcPass 'Parsed))) IsNull -> forall a. NullM a IsNull -- The general case uses (all null), -- (all (all null)), etc. NullM LocatedA (HsExpr (GhcPass 'Parsed)) nestedTest -> forall a. a -> NullM a NullM forall a b. (a -> b) -> a -> b $ forall (id :: Pass). IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) nlHsApp LHsExpr (GhcPass 'Parsed) all_Expr LocatedA (HsExpr (GhcPass 'Parsed)) nestedTest -- null fa = null fa, or null fa = all null fa, or null fa = True , ft_forall :: Id -> State [RdrName] (NullM (LocatedA (HsExpr (GhcPass 'Parsed)))) -> State [RdrName] (NullM (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_forall = \Id _ State [RdrName] (NullM (LocatedA (HsExpr (GhcPass 'Parsed)))) g -> State [RdrName] (NullM (LocatedA (HsExpr (GhcPass 'Parsed)))) g , ft_co_var :: State [RdrName] (NullM (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_co_var = forall a. String -> a panic String "contravariant in ft_null" , ft_fun :: State [RdrName] (NullM (LocatedA (HsExpr (GhcPass 'Parsed)))) -> State [RdrName] (NullM (LocatedA (HsExpr (GhcPass 'Parsed)))) -> State [RdrName] (NullM (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_fun = forall a. String -> a panic String "function in ft_null" , ft_bad_app :: State [RdrName] (NullM (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_bad_app = forall a. String -> a panic String "in other argument in ft_null" } match_null :: Monad m => [LPat GhcPs] -> DataCon -> [Maybe (LHsExpr GhcPs)] -> m (LMatch GhcPs (LHsExpr GhcPs)) match_null :: forall (m :: * -> *). Monad m => [LPat (GhcPass 'Parsed)] -> DataCon -> [Maybe (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) match_null = forall (m :: * -> *). Monad m => HsMatchContext (GhcPass 'Parsed) -> (LHsExpr (GhcPass 'Parsed) -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed))) -> [LPat (GhcPass 'Parsed)] -> DataCon -> [Maybe (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) mkSimpleConMatch2 forall p. HsMatchContext p CaseAlt forall a b. (a -> b) -> a -> b $ \LHsExpr (GhcPass 'Parsed) _ [LHsExpr (GhcPass 'Parsed)] xs -> forall (m :: * -> *) a. Monad m => a -> m a return ([LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed) mkNull [LHsExpr (GhcPass 'Parsed)] xs) where -- v1 && v2 && .. mkNull :: [LHsExpr GhcPs] -> LHsExpr GhcPs mkNull :: [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed) mkNull [] = LHsExpr (GhcPass 'Parsed) true_Expr mkNull [LHsExpr (GhcPass 'Parsed)] xs = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a foldr1 (\LocatedA (HsExpr (GhcPass 'Parsed)) x LocatedA (HsExpr (GhcPass 'Parsed)) y -> forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p) nlHsApps RdrName and_RDR [LocatedA (HsExpr (GhcPass 'Parsed)) x,LocatedA (HsExpr (GhcPass 'Parsed)) y]) [LHsExpr (GhcPass 'Parsed)] xs data NullM a = IsNull -- Definitely null | NotNull -- Definitely not null | NullM a -- Unknown {- ************************************************************************ * * Traversable instances see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html * * ************************************************************************ Again, Traversable is much like Functor and Foldable. The cases are: $(traverse 'a 'a) = f $(traverse 'a '(b1,b2)) = \x -> case x of (x1,x2) -> liftA2 (,) ($(traverse 'a 'b1) x1) ($(traverse 'a 'b2) x2) $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2 Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types do not mention the last type parameter. Therefore, the following datatype: data Foo a = Foo Int a Int would have the following derived Traversable instance: instance Traversable Foo where traverse f (Foo x1 x2 x3) = fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 ) since the two Int arguments do not produce any effects in a traversal. One can envision a case for types that do not mention the last type parameter: $(traverse 'a 'b) = pure -- when b does not contain a But this case will never materialize, since the aforementioned filtering removes all such types from consideration. See Note [Generated code for DeriveFoldable and DeriveTraversable]. -} gen_Traversable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff) -- When the argument is phantom, we can use traverse = pure . coerce -- See Note [Phantom types with Functor, Foldable, and Traversable] gen_Traversable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds (GhcPass 'Parsed), BagDerivStuff) gen_Traversable_binds SrcSpan loc TyCon tycon [Type] _ | Role Phantom <- forall a. [a] -> a last (TyCon -> [Role] tyConRoles TyCon tycon) = (forall a. a -> Bag a unitBag LHsBind (GhcPass 'Parsed) traverse_bind, forall a. Bag a emptyBag) where traverse_name :: GenLocated SrcSpanAnnN RdrName traverse_name = forall l e. l -> e -> GenLocated l e L (forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc) RdrName traverse_RDR traverse_bind :: LHsBind (GhcPass 'Parsed) traverse_bind = GenLocated SrcSpanAnnN RdrName -> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))] -> LHsBind (GhcPass 'Parsed) mkRdrFunBind GenLocated SrcSpanAnnN RdrName traverse_name [GenLocated (Anno (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))) (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))] traverse_eqns traverse_eqns :: [GenLocated (Anno (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))) (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))] traverse_eqns = [forall (p :: Pass) (body :: * -> *). (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA, Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan) => HsMatchContext (NoGhcTc (GhcPass p)) -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p)) -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) mkSimpleMatch HsMatchContext (GhcPass (NoGhcTcPass 'Parsed)) traverse_match_ctxt [LPat (GhcPass 'Parsed) nlWildPat, LPat (GhcPass 'Parsed) z_Pat] (forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p) nlHsApps RdrName pure_RDR [forall (id :: Pass). IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) nlHsApp LHsExpr (GhcPass 'Parsed) coerce_Expr LHsExpr (GhcPass 'Parsed) z_Expr])] traverse_match_ctxt :: HsMatchContext (GhcPass (NoGhcTcPass 'Parsed)) traverse_match_ctxt = forall p. LIdP p -> HsMatchContext p mkPrefixFunRhs GenLocated SrcSpanAnnN RdrName traverse_name gen_Traversable_binds SrcSpan loc TyCon tycon [Type] tycon_args = (forall a. a -> Bag a unitBag LHsBind (GhcPass 'Parsed) traverse_bind, forall a. Bag a emptyBag) where data_cons :: [DataCon] data_cons = TyCon -> [Type] -> [DataCon] getPossibleDataCons TyCon tycon [Type] tycon_args traverse_name :: GenLocated SrcSpanAnnN RdrName traverse_name = forall l e. l -> e -> GenLocated l e L (forall ann. SrcSpan -> SrcAnn ann noAnnSrcSpan SrcSpan loc) RdrName traverse_RDR -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] traverse_bind :: LHsBind (GhcPass 'Parsed) traverse_bind = Int -> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)) -> GenLocated SrcSpanAnnN RdrName -> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))] -> LHsBind (GhcPass 'Parsed) mkRdrFunBindEC Int 2 (forall (id :: Pass). IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) nlHsApp LHsExpr (GhcPass 'Parsed) pure_Expr) GenLocated SrcSpanAnnN RdrName traverse_name [GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))] traverse_eqns traverse_eqns :: [GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))] traverse_eqns = forall a b. (a -> b) -> [a] -> [b] map DataCon -> GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))) traverse_eqn [DataCon] data_cons traverse_eqn :: DataCon -> GenLocated SrcSpanAnnA (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))) traverse_eqn DataCon con = forall s a. State s a -> s -> a evalState (forall (m :: * -> *). Monad m => [LPat (GhcPass 'Parsed)] -> DataCon -> [Maybe (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) match_for_con [LPat (GhcPass 'Parsed) f_Pat] DataCon con forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< State [RdrName] [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))] parts) [RdrName] bs_RDRs where parts :: State [RdrName] [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))] parts = forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence forall a b. (a -> b) -> a -> b $ forall a. FFoldType a -> DataCon -> [a] foldDataConArgs FFoldType (State [RdrName] (Maybe (LHsExpr (GhcPass 'Parsed)))) ft_trav DataCon con -- Yields 'Just' an expression if we're folding over a type that mentions -- the last type parameter of the datatype. Otherwise, yields 'Nothing'. -- See Note [FFoldType and functorLikeTraverse] ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs))) ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr (GhcPass 'Parsed)))) ft_trav = FT { ft_triv :: State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_triv = forall (m :: * -> *) a. Monad m => a -> m a return forall a. Maybe a Nothing -- traverse f = pure x , ft_var :: State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_var = forall (m :: * -> *) a. Monad m => a -> m a return (forall a. a -> Maybe a Just LHsExpr (GhcPass 'Parsed) f_Expr) -- traverse f = f x , ft_tup :: TyCon -> [State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))] -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_tup = \TyCon t [State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))] gs -> do [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))] gg <- forall (t :: * -> *) (m :: * -> *) a. (Traversable t, Monad m) => t (m a) -> m (t a) sequence [State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed))))] gs LocatedA (HsExpr (GhcPass 'Parsed)) lam <- (LHsExpr (GhcPass 'Parsed) -> State [RdrName] (LHsExpr (GhcPass 'Parsed))) -> State [RdrName] (LHsExpr (GhcPass 'Parsed)) mkSimpleLam forall a b. (a -> b) -> a -> b $ forall (m :: * -> *) a. Monad m => ([LPat (GhcPass 'Parsed)] -> DataCon -> [a] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))) -> TyCon -> [a] -> LHsExpr (GhcPass 'Parsed) -> m (LHsExpr (GhcPass 'Parsed)) mkSimpleTupleCase forall (m :: * -> *). Monad m => [LPat (GhcPass 'Parsed)] -> DataCon -> [Maybe (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) match_for_con TyCon t [Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))] gg forall (m :: * -> *) a. Monad m => a -> m a return (forall a. a -> Maybe a Just LocatedA (HsExpr (GhcPass 'Parsed)) lam) -- traverse f = \x -> case x of (a1,a2,..) -> -- liftA2 (,,) (g1 a1) (g2 a2) <*> .. , ft_ty_app :: Type -> Type -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_ty_app = \Type _ Type _ State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) g -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (forall (id :: Pass). IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) nlHsApp LHsExpr (GhcPass 'Parsed) traverse_Expr) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) g -- traverse f = traverse g , ft_forall :: Id -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_forall = \Id _ State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) g -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) g , ft_co_var :: State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_co_var = forall a. String -> a panic String "contravariant in ft_trav" , ft_fun :: State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) -> State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_fun = forall a. String -> a panic String "function in ft_trav" , ft_bad_app :: State [RdrName] (Maybe (LocatedA (HsExpr (GhcPass 'Parsed)))) ft_bad_app = forall a. String -> a panic String "in other argument in ft_trav" } -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1) -- (g2 a2) <*> ... match_for_con :: Monad m => [LPat GhcPs] -> DataCon -> [Maybe (LHsExpr GhcPs)] -> m (LMatch GhcPs (LHsExpr GhcPs)) match_for_con :: forall (m :: * -> *). Monad m => [LPat (GhcPass 'Parsed)] -> DataCon -> [Maybe (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) match_for_con = forall (m :: * -> *). Monad m => HsMatchContext (GhcPass 'Parsed) -> (LHsExpr (GhcPass 'Parsed) -> [LHsExpr (GhcPass 'Parsed)] -> m (LHsExpr (GhcPass 'Parsed))) -> [LPat (GhcPass 'Parsed)] -> DataCon -> [Maybe (LHsExpr (GhcPass 'Parsed))] -> m (LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))) mkSimpleConMatch2 forall p. HsMatchContext p CaseAlt forall a b. (a -> b) -> a -> b $ \LHsExpr (GhcPass 'Parsed) con [LHsExpr (GhcPass 'Parsed)] xs -> forall (m :: * -> *) a. Monad m => a -> m a return (LHsExpr (GhcPass 'Parsed) -> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed) mkApCon LHsExpr (GhcPass 'Parsed) con [LHsExpr (GhcPass 'Parsed)] xs) where -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> .. mkApCon :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs mkApCon :: LHsExpr (GhcPass 'Parsed) -> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed) mkApCon LHsExpr (GhcPass 'Parsed) con [] = forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p) nlHsApps RdrName pure_RDR [LHsExpr (GhcPass 'Parsed) con] mkApCon LHsExpr (GhcPass 'Parsed) con [LHsExpr (GhcPass 'Parsed) x] = forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p) nlHsApps RdrName fmap_RDR [LHsExpr (GhcPass 'Parsed) con,LHsExpr (GhcPass 'Parsed) x] mkApCon LHsExpr (GhcPass 'Parsed) con (LHsExpr (GhcPass 'Parsed) x1:LHsExpr (GhcPass 'Parsed) x2:[LHsExpr (GhcPass 'Parsed)] xs) = forall (t :: * -> *) b a. Foldable t => (b -> a -> b) -> b -> t a -> b foldl' forall {p :: Pass}. (Anno (IdGhcP p) ~ SrcSpanAnnN, IdGhcP p ~ RdrName, IsPass p) => GenLocated SrcSpanAnnA (HsExpr (GhcPass p)) -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p)) -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p)) appAp (forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p) nlHsApps RdrName liftA2_RDR [LHsExpr (GhcPass 'Parsed) con,LHsExpr (GhcPass 'Parsed) x1,LHsExpr (GhcPass 'Parsed) x2]) [LHsExpr (GhcPass 'Parsed)] xs where appAp :: GenLocated SrcSpanAnnA (HsExpr (GhcPass p)) -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p)) -> LHsExpr (GhcPass p) appAp GenLocated SrcSpanAnnA (HsExpr (GhcPass p)) x GenLocated SrcSpanAnnA (HsExpr (GhcPass p)) y = forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p) nlHsApps RdrName ap_RDR [GenLocated SrcSpanAnnA (HsExpr (GhcPass p)) x,GenLocated SrcSpanAnnA (HsExpr (GhcPass p)) y] ----------------------------------------------------------------------- f_Expr, z_Expr, mempty_Expr, foldMap_Expr, traverse_Expr, coerce_Expr, pure_Expr, true_Expr, false_Expr, all_Expr, null_Expr :: LHsExpr GhcPs f_Expr :: LHsExpr (GhcPass 'Parsed) f_Expr = forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LHsExpr (GhcPass p) nlHsVar RdrName f_RDR z_Expr :: LHsExpr (GhcPass 'Parsed) z_Expr = forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LHsExpr (GhcPass p) nlHsVar RdrName z_RDR mempty_Expr :: LHsExpr (GhcPass 'Parsed) mempty_Expr = forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LHsExpr (GhcPass p) nlHsVar RdrName mempty_RDR foldMap_Expr :: LHsExpr (GhcPass 'Parsed) foldMap_Expr = forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LHsExpr (GhcPass p) nlHsVar RdrName foldMap_RDR traverse_Expr :: LHsExpr (GhcPass 'Parsed) traverse_Expr = forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LHsExpr (GhcPass p) nlHsVar RdrName traverse_RDR coerce_Expr :: LHsExpr (GhcPass 'Parsed) coerce_Expr = forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LHsExpr (GhcPass p) nlHsVar (forall thing. NamedThing thing => thing -> RdrName getRdrName Id coerceId) pure_Expr :: LHsExpr (GhcPass 'Parsed) pure_Expr = forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LHsExpr (GhcPass p) nlHsVar RdrName pure_RDR true_Expr :: LHsExpr (GhcPass 'Parsed) true_Expr = forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LHsExpr (GhcPass p) nlHsVar RdrName true_RDR false_Expr :: LHsExpr (GhcPass 'Parsed) false_Expr = forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LHsExpr (GhcPass p) nlHsVar RdrName false_RDR all_Expr :: LHsExpr (GhcPass 'Parsed) all_Expr = forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LHsExpr (GhcPass p) nlHsVar RdrName all_RDR null_Expr :: LHsExpr (GhcPass 'Parsed) null_Expr = forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LHsExpr (GhcPass p) nlHsVar RdrName null_RDR f_RDR, z_RDR :: RdrName f_RDR :: RdrName f_RDR = FastString -> RdrName mkVarUnqual (String -> FastString fsLit String "f") z_RDR :: RdrName z_RDR = FastString -> RdrName mkVarUnqual (String -> FastString fsLit String "z") as_RDRs, bs_RDRs :: [RdrName] as_RDRs :: [RdrName] as_RDRs = [ FastString -> RdrName mkVarUnqual (String -> FastString mkFastString (String "a"forall a. [a] -> [a] -> [a] ++forall a. Show a => a -> String show Int i)) | Int i <- [(Int 1::Int) .. ] ] bs_RDRs :: [RdrName] bs_RDRs = [ FastString -> RdrName mkVarUnqual (String -> FastString mkFastString (String "b"forall a. [a] -> [a] -> [a] ++forall a. Show a => a -> String show Int i)) | Int i <- [(Int 1::Int) .. ] ] as_Vars, bs_Vars :: [LHsExpr GhcPs] as_Vars :: [LHsExpr (GhcPass 'Parsed)] as_Vars = forall a b. (a -> b) -> [a] -> [b] map forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LHsExpr (GhcPass p) nlHsVar [RdrName] as_RDRs bs_Vars :: [LHsExpr (GhcPass 'Parsed)] bs_Vars = forall a b. (a -> b) -> [a] -> [b] map forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LHsExpr (GhcPass p) nlHsVar [RdrName] bs_RDRs f_Pat, z_Pat :: LPat GhcPs f_Pat :: LPat (GhcPass 'Parsed) f_Pat = forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LPat (GhcPass p) nlVarPat RdrName f_RDR z_Pat :: LPat (GhcPass 'Parsed) z_Pat = forall (p :: Pass) a. IsSrcSpanAnn p a => IdP (GhcPass p) -> LPat (GhcPass p) nlVarPat RdrName z_RDR {- Note [DeriveFoldable with ExistentialQuantification] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Functor and Traversable instances can only be derived for data types whose last type parameter is truly universally polymorphic. For example: data T a b where T1 :: b -> T a b -- YES, b is unconstrained T2 :: Ord b => b -> T a b -- NO, b is constrained by (Ord b) T3 :: b ~ Int => b -> T a b -- NO, b is constrained by (b ~ Int) T4 :: Int -> T a Int -- NO, this is just like T3 T5 :: Ord a => a -> b -> T a b -- YES, b is unconstrained, even -- though a is existential T6 :: Int -> T Int b -- YES, b is unconstrained For Foldable instances, however, we can completely lift the constraint that the last type parameter be truly universally polymorphic. This means that T (as defined above) can have a derived Foldable instance: instance Foldable (T a) where foldr f z (T1 b) = f b z foldr f z (T2 b) = f b z foldr f z (T3 b) = f b z foldr f z (T4 b) = z foldr f z (T5 a b) = f b z foldr f z (T6 a) = z foldMap f (T1 b) = f b foldMap f (T2 b) = f b foldMap f (T3 b) = f b foldMap f (T4 b) = mempty foldMap f (T5 a b) = f b foldMap f (T6 a) = mempty In a Foldable instance, it is safe to fold over an occurrence of the last type parameter that is not truly universally polymorphic. However, there is a bit of subtlety in determining what is actually an occurrence of a type parameter. T3 and T4, as defined above, provide one example: data T a b where ... T3 :: b ~ Int => b -> T a b T4 :: Int -> T a Int ... instance Foldable (T a) where ... foldr f z (T3 b) = f b z foldr f z (T4 b) = z ... foldMap f (T3 b) = f b foldMap f (T4 b) = mempty ... Notice that the argument of T3 is folded over, whereas the argument of T4 is not. This is because we only fold over constructor arguments that syntactically mention the universally quantified type parameter of that particular data constructor. See foldDataConArgs for how this is implemented. As another example, consider the following data type. The argument of each constructor has the same type as the last type parameter: data E a where E1 :: (a ~ Int) => a -> E a E2 :: Int -> E Int E3 :: (a ~ Int) => a -> E Int E4 :: (a ~ Int) => Int -> E a Only E1's argument is an occurrence of a universally quantified type variable that is syntactically equivalent to the last type parameter, so only E1's argument will be folded over in a derived Foldable instance. See #10447 for the original discussion on this feature. Also see https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/derive-functor for a more in-depth explanation. Note [FFoldType and functorLikeTraverse] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Deriving Functor, Foldable, and Traversable all require generating expressions which perform an operation on each argument of a data constructor depending on the argument's type. In particular, a generated operation can be different depending on whether the type mentions the last type variable of the datatype (e.g., if you have data T a = MkT a Int, then a generated foldr expression would fold over the first argument of MkT, but not the second). This pattern is abstracted with the FFoldType datatype, which provides hooks for the user to specify how a constructor argument should be folded when it has a type with a particular "shape". The shapes are as follows (assume that a is the last type variable in a given datatype): * ft_triv: The type does not mention the last type variable at all. Examples: Int, b * ft_var: The type is syntactically equal to the last type variable. Moreover, the type appears in a covariant position (see the Deriving Functor instances section of the user's guide for an in-depth explanation of covariance vs. contravariance). Example: a (covariantly) * ft_co_var: The type is syntactically equal to the last type variable. Moreover, the type appears in a contravariant position. Example: a (contravariantly) * ft_fun: A function type which mentions the last type variable in the argument position, result position or both. Examples: a -> Int, Int -> a, Maybe a -> [a] * ft_tup: A tuple type which mentions the last type variable in at least one of its fields. The TyCon argument of ft_tup represents the particular tuple's type constructor. Examples: (a, Int), (Maybe a, [a], Either a Int), (# Int, a #) * ft_ty_app: A type is being applied to the last type parameter, where the applied type does not mention the last type parameter (if it did, it would fall under ft_bad_app) and the argument type mentions the last type parameter (if it did not, it would fall under ft_triv). The first two Type arguments to ft_ty_app represent the applied type and argument type, respectively. Currently, only DeriveFunctor makes use of the argument type. It inspects the argument type so that it can generate more efficient implementations of fmap (see Note [Avoid unnecessary eta expansion in derived fmap implementations]) and (<$) (see Note [Deriving <$]) in certain cases. Note that functions, tuples, and foralls are distinct cases and take precedence over ft_ty_app. (For example, (Int -> a) would fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a). Examples: Maybe a, Either b a * ft_bad_app: A type application uses the last type parameter in a position other than the last argument. This case is singled out because Functor, Foldable, and Traversable instances cannot be derived for datatypes containing arguments with such types. Examples: Either a Int, Const a b * ft_forall: A forall'd type mentions the last type parameter on its right- hand side (and is not quantified on the left-hand side). This case is present mostly for plumbing purposes. Example: forall b. Either b a If FFoldType describes a strategy for folding subcomponents of a Type, then functorLikeTraverse is the function that applies that strategy to the entirety of a Type, returning the final folded-up result. foldDataConArgs applies functorLikeTraverse to every argument type of a constructor, returning a list of the fold results. This makes foldDataConArgs a natural way to generate the subexpressions in a generated fmap, foldr, foldMap, or traverse definition (the subexpressions must then be combined in a method-specific fashion to form the final generated expression). Deriving Generic1 also does validity checking by looking for the last type variable in certain positions of a constructor's argument types, so it also uses foldDataConArgs. See Note [degenerate use of FFoldType] in GHC.Tc.Deriv.Generics. Note [Generated code for DeriveFoldable and DeriveTraversable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on that of -XDeriveFunctor. However, there an important difference between deriving the former two typeclasses and the latter one, which is best illustrated by the following scenario: data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable) The generated code for the Functor instance is straightforward: instance Functor WithInt where fmap f (WithInt a i) = WithInt (f a) i But if we use too similar of a strategy for deriving the Foldable and Traversable instances, we end up with this code: instance Foldable WithInt where foldMap f (WithInt a i) = f a <> mempty instance Traversable WithInt where traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i This is unsatisfying for two reasons: 1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure expects an argument whose type is of kind *. This effectively prevents Traversable from being derived for any datatype with an unlifted argument type (#11174). 2. The generated code contains superfluous expressions. By the Monoid laws, we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)). We can fix both of these issues by incorporating a slight twist to the usual algorithm that we use for -XDeriveFunctor. The differences can be summarized as follows: 1. In the generated expression, we only fold over arguments whose types mention the last type parameter. Any other argument types will simply produce useless 'mempty's or 'pure's, so they can be safely ignored. 2. In the case of -XDeriveTraversable, instead of applying ConName, we apply (\b_i ... b_k -> ConName a_1 ... a_n), where * ConName has n arguments * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond to the arguments whose types mention the last type parameter. As a consequence, taking the difference of {a_1, ..., a_n} and {b_i, ..., b_k} yields the all the argument values of ConName whose types do not mention the last type parameter. Note that [i, ..., k] is a strictly increasing—but not necessarily consecutive—integer sequence. For example, the datatype data Foo a = Foo Int a Int a would generate the following Traversable instance: instance Traversable Foo where traverse f (Foo a1 a2 a3 a4) = fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4 Technically, this approach would also work for -XDeriveFunctor as well, but we decide not to do so because: 1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a)) instead of (WithInt (f a) i). 2. There would be certain datatypes for which the above strategy would generate Functor code that would fail to typecheck. For example: data Bar f a = Bar (forall f. Functor f => f a) deriving Functor With the conventional algorithm, it would generate something like: fmap f (Bar a) = Bar (fmap f a) which typechecks. But with the strategy mentioned above, it would generate: fmap f (Bar a) = (\b -> Bar b) (fmap f a) which does not typecheck, since GHC cannot unify the rank-2 type variables in the types of b and (fmap f a). Note [Phantom types with Functor, Foldable, and Traversable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Given a type F :: * -> * whose type argument has a phantom role, we can always produce lawful Functor and Traversable instances using fmap _ = coerce traverse _ = pure . coerce Indeed, these are equivalent to any *strictly lawful* instances one could write, except that this definition of 'traverse' may be lazier. That is, if instances obey the laws under true equality (rather than up to some equivalence relation), then they will be essentially equivalent to these. These definitions are incredibly cheap, so we want to use them even if it means ignoring some non-strictly-lawful instance in an embedded type. Foldable has far fewer laws to work with, which leaves us unwelcome freedom in implementing it. At a minimum, we would like to ensure that a derived foldMap is always at least as good as foldMapDefault with a derived traverse. To accomplish that, we must define foldMap _ _ = mempty in these cases. This may have different strictness properties from a standard derivation. Consider data NotAList a = Nil | Cons (NotAList a) deriving Foldable The usual deriving mechanism would produce foldMap _ Nil = mempty foldMap f (Cons x) = foldMap f x which is strict in the entire spine of the NotAList. Final point: why do we even care about such types? Users will rarely if ever map, fold, or traverse over such things themselves, but other derived instances may: data Hasn'tAList a = NotHere a (NotAList a) deriving Foldable Note [EmptyDataDecls with Functor, Foldable, and Traversable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There are some slightly tricky decisions to make about how to handle Functor, Foldable, and Traversable instances for types with no constructors. For fmap, the two basic options are fmap _ _ = error "Sorry, no constructors" or fmap _ z = case z of In most cases, the latter is more helpful: if the thunk passed to fmap throws an exception, we're generally going to be much more interested in that exception than in the fact that there aren't any constructors. In order to match the semantics for phantoms (see note above), we need to be a bit careful about 'traverse'. The obvious definition would be traverse _ z = case z of but this is stricter than the one for phantoms. We instead use traverse _ z = pure $ case z of For foldMap, the obvious choices are foldMap _ _ = mempty or foldMap _ z = case z of We choose the first one to be consistent with what foldMapDefault does for a derived Traversable instance. -}