From 69f070d8e4d6043937e3405675ac911448bfcb44 Mon Sep 17 00:00:00 2001 From: David Feuer Date: Thu, 30 Mar 2017 13:30:52 -0400 Subject: [PATCH] Deriving for phantom and empty types Make `Functor`, `Foldable`, and `Traversable` take advantage of the case where the type parameter is phantom. In this case, * `fmap _ = coerce` * `foldMap _ _ = mempty` * `traverse _ x = pure (coerce x)` For the sake of consistency and especially simplicity, make other types with no data constructors behave the same: * `fmap _ x = case x of` * `foldMap _ _ = mempty` * `traverse _ x = pure (case x of)` Similarly, for `Generic`, * `to x = case x of` * `from x = case x of` Give all derived methods for types without constructors appropriate arities. For example, ``` compare _ _ = error ... ``` rather than ``` compare = error ... ``` Fixes #13117 and #13328 Reviewers: austin, bgamari, RyanGlScott Reviewed By: RyanGlScott Subscribers: ekmett, RyanGlScott, rwbarton, thomie Differential Revision: https://phabricator.haskell.org/D3374 --- compiler/typecheck/TcGenDeriv.hs | 114 +++++---- compiler/typecheck/TcGenFunctor.hs | 216 ++++++++++++++---- compiler/typecheck/TcGenGenerics.hs | 15 +- docs/users_guide/8.4.1-notes.rst | 78 +++++++ docs/users_guide/glasgow_exts.rst | 74 +++++- docs/users_guide/index.rst | 1 + testsuite/tests/deriving/should_compile/all.T | 5 + .../deriving/should_compile/drv-empty-data.hs | 19 ++ .../should_compile/drv-empty-data.stderr | 68 ++++++ .../deriving/should_compile/drv-phantom.hs | 12 + .../should_compile/drv-phantom.stderr | 18 ++ .../generics/T10604/T10604_deriving.stderr | 128 +++++------ testsuite/tests/perf/compiler/T13056.hs | 4 + 13 files changed, 584 insertions(+), 168 deletions(-) create mode 100644 docs/users_guide/8.4.1-notes.rst create mode 100644 testsuite/tests/deriving/should_compile/drv-empty-data.hs create mode 100644 testsuite/tests/deriving/should_compile/drv-empty-data.stderr create mode 100644 testsuite/tests/deriving/should_compile/drv-phantom.hs create mode 100644 testsuite/tests/deriving/should_compile/drv-phantom.stderr diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index c46c2919b6..d21535ee2b 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -31,7 +31,7 @@ module TcGenDeriv ( mkCoerceClassMethEqn, genAuxBinds, ordOpTbl, boxConTbl, litConTbl, - mkRdrFunBind, error_Expr + mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr ) where #include "HsVersions.h" @@ -190,14 +190,9 @@ gen_Eq_binds loc tycon = do aux_binds | no_tag_match_cons = emptyBag | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon - method_binds dflags = listToBag - [ eq_bind dflags - , ne_bind - ] - eq_bind dflags = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons + method_binds dflags = unitBag (eq_bind dflags) + eq_bind dflags = mkFunBindSE 2 loc eq_RDR (map pats_etc pat_match_cons ++ fall_through_eqn dflags) - ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] ( - nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR]))) ------------------------------------------------------------------ pats_etc data_con @@ -341,7 +336,7 @@ gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff) gen_Ord_binds loc tycon = do dflags <- getDynFlags return $ if null tycon_data_cons -- No data-cons => invoke bale-out case - then ( unitBag $ mk_FunBind loc compare_RDR [] + then ( unitBag $ mkFunBindSE 2 loc compare_RDR [] , emptyBag) else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags , aux_binds) @@ -1124,7 +1119,7 @@ gen_Show_binds get_fixity loc tycon (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0)))) ----------------------------------------------------------------------- data_cons = tyConDataCons tycon - shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc data_cons) + shows_prec = mkFunBindSE 1 loc showsPrec_RDR (map pats_etc data_cons) comma_space = nlHsVar showCommaSpace_RDR pats_etc data_con @@ -1345,11 +1340,11 @@ gen_data dflags data_type_name constr_names loc rep_tc | otherwise = prefix_RDR ------------ gfoldl - gfoldl_bind = mk_HRFunBind 2 loc gfoldl_RDR (map gfoldl_eqn data_cons) + gfoldl_bind = mkFunBindSE 3 loc gfoldl_RDR (map gfoldl_eqn data_cons) gfoldl_eqn con - = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed], - foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed) + = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed], + foldl mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed) where con_name :: RdrName con_name = getRdrName con @@ -1357,10 +1352,10 @@ gen_data dflags data_type_name constr_names loc rep_tc mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v)) ------------ gunfold - gunfold_bind = mk_HRFunBind 2 loc + gunfold_bind = mk_easy_FunBind loc gunfold_RDR - [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat], - gunfold_rhs)] + [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat] + gunfold_rhs gunfold_rhs | one_constr = mk_unfold_rhs (head data_cons) -- No need for case @@ -1369,7 +1364,7 @@ gen_data dflags data_type_name constr_names loc rep_tc gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc) mk_unfold_rhs dc = foldr nlHsApp - (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc)) + (z_Expr `nlHsApp` nlHsVar (getRdrName dc)) (replicate (dataConSourceArity dc) (nlHsVar k_RDR)) mk_unfold_pat dc -- Last one is a wild-pat, to avoid @@ -1381,7 +1376,8 @@ gen_data dflags data_type_name constr_names loc rep_tc tag = dataConTag dc ------------ toConstr - toCon_bind = mk_FunBind loc toConstr_RDR (zipWith to_con_eqn data_cons constr_names) + toCon_bind = mkFunBindSE 1 loc toConstr_RDR + (zipWith to_con_eqn data_cons constr_names) to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name) ------------ dataTypeOf @@ -1523,10 +1519,13 @@ gen_Lift_binds loc tycon , emptyBag) | otherwise = (unitBag lift_bind, emptyBag) where + -- We may want to make mkFunBindSE's error message generation general + -- enough to avoid needing to duplicate its logic here. On the other + -- hand, it may not be worth the trouble. errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit (mkHsString $ "Can't lift value of empty datatype " ++ tycon_str) - lift_bind = mk_FunBind loc lift_RDR (map pats_etc data_cons) + lift_bind = mkFunBindSE 1 loc lift_RDR (map pats_etc data_cons) data_cons = tyConDataCons tycon tycon_str = occNameString . nameOccName . tyConName $ tycon @@ -1656,19 +1655,18 @@ gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty return ( listToBag $ map mk_bind (classMethods cls) , listToBag $ map DerivFamInst atf_insts ) where - coerce_RDR = getRdrName coerceId - mk_bind :: Id -> LHsBind RdrName mk_bind meth_id = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch - (FunRhs (L loc meth_RDR) Prefix) - [] rhs_expr] + (FunRhs (L loc meth_RDR) Prefix) + [] rhs_expr] where Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id meth_RDR = getRdrName meth_id - rhs_expr = nlHsVar coerce_RDR `nlHsAppType` from_ty + rhs_expr = nlHsVar (getRdrName coerceId) + `nlHsAppType` from_ty `nlHsAppType` to_ty `nlHsApp` nlHsVar meth_RDR @@ -1753,7 +1751,7 @@ fiddling around. genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName) genAuxBindSpec dflags loc (DerivCon2Tag tycon) - = (mk_FunBind loc rdr_name eqns, + = (mkFunBindSE 0 loc rdr_name eqns, L loc (TypeSig [L loc rdr_name] sig_ty)) where rdr_name = con2tag_RDR dflags tycon @@ -1777,7 +1775,7 @@ genAuxBindSpec dflags loc (DerivCon2Tag tycon) (toInteger ((dataConTag con) - fIRST_TAG)))) genAuxBindSpec dflags loc (DerivTag2Con tycon) - = (mk_FunBind loc rdr_name + = (mkFunBindSE 0 loc rdr_name [([nlConVarPat intDataCon_RDR [a_RDR]], nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)], L loc (TypeSig [L loc rdr_name] sig_ty)) @@ -1841,34 +1839,60 @@ mkParentType tc ************************************************************************ -} -mk_FunBind :: SrcSpan -> RdrName - -> [([LPat RdrName], LHsExpr RdrName)] - -> LHsBind RdrName -mk_FunBind = mk_HRFunBind 0 -- by using mk_FunBind and not mk_HRFunBind, - -- the caller says that the Void case needs no - -- patterns - --- | This variant of 'mk_FunBind' puts an 'Arity' number of wildcards before --- the "=" in the empty-data-decl case. This is necessary if the function --- has a higher-rank type, like foldl. (See deriving/should_compile/T4302) -mk_HRFunBind :: Arity -> SrcSpan -> RdrName +-- | Make a function binding. If no equations are given, produce a function +-- with the given arity that produces a stock error. +mkFunBindSE :: Arity -> SrcSpan -> RdrName -> [([LPat RdrName], LHsExpr RdrName)] -> LHsBind RdrName -mk_HRFunBind arity loc fun pats_and_exprs - = mkHRRdrFunBind arity (L loc fun) matches +mkFunBindSE arity loc fun pats_and_exprs + = mkRdrFunBindSE arity (L loc fun) matches where matches = [mkMatch (FunRhs (L loc fun) Prefix) p e (noLoc emptyLocalBinds) | (p,e) <-pats_and_exprs] mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName -mkRdrFunBind = mkHRRdrFunBind 0 +mkRdrFunBind fun@(L loc _fun_rdr) matches + = L loc (mkFunBind fun matches) + +-- | Produces a function binding. When no equations are given, it generates +-- a binding of the given arity and an empty case expression +-- for the last argument that it passes to the given function to produce +-- the right-hand side. +mkRdrFunBindEC :: Arity + -> (LHsExpr RdrName -> LHsExpr RdrName) + -> Located RdrName + -> [LMatch RdrName (LHsExpr RdrName)] + -> LHsBind RdrName +mkRdrFunBindEC arity catch_all + fun@(L loc _fun_rdr) matches = L loc (mkFunBind fun matches') + where + -- Catch-all eqn looks like + -- fmap _ z = case z of {} + -- or + -- traverse _ z = pure (case z of) + -- or + -- foldMap _ z = mempty + -- It's needed if there no data cons at all, + -- which can happen with -XEmptyDataDecls + -- See Trac #4302 + matches' = if null matches + then [mkMatch (FunRhs fun Prefix) + (replicate (arity - 1) nlWildPat ++ [z_Pat]) + (catch_all $ nlHsCase z_Expr []) + (noLoc emptyLocalBinds)] + else matches -mkHRRdrFunBind :: Arity -> Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName -mkHRRdrFunBind arity fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches') +-- | Produces a function binding. When there are no equations, it generates +-- a binding with the given arity that produces an error based on the name of +-- the type of the last argument. +mkRdrFunBindSE :: Arity -> Located RdrName -> + [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName +mkRdrFunBindSE arity + fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches') where -- Catch-all eqn looks like - -- fmap = error "Void fmap" + -- compare _ _ = error "Void compare" -- It's needed if there no data cons at all, -- which can happen with -XEmptyDataDecls -- See Trac #4302 @@ -1879,6 +1903,7 @@ mkHRRdrFunBind arity fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches' else matches str = "Void " ++ occNameString (rdrNameOcc fun_rdr) + box :: String -- The class involved -> TyCon -- The tycon involved -> LHsExpr RdrName -- The argument @@ -2079,11 +2104,12 @@ as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] -a_Expr, b_Expr, c_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr, +a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr, true_Expr :: LHsExpr RdrName a_Expr = nlHsVar a_RDR b_Expr = nlHsVar b_RDR c_Expr = nlHsVar c_RDR +z_Expr = nlHsVar z_RDR ltTag_Expr = nlHsVar ltTag_RDR eqTag_Expr = nlHsVar eqTag_RDR gtTag_Expr = nlHsVar gtTag_RDR diff --git a/compiler/typecheck/TcGenFunctor.hs b/compiler/typecheck/TcGenFunctor.hs index e7bf394ba1..edf58514d1 100644 --- a/compiler/typecheck/TcGenFunctor.hs +++ b/compiler/typecheck/TcGenFunctor.hs @@ -33,6 +33,7 @@ import Type import Util import Var import VarSet +import MkId (coerceId) import Data.Maybe (catMaybes, isJust) @@ -124,12 +125,27 @@ It is better to produce too many lambdas than to eta expand, see ticket #7436. -} gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) +-- When the argument is phantom, we can use fmap _ = coerce +-- See Note [Phantom types with Functor, Foldable, and Traversable] +gen_Functor_binds loc tycon + | Phantom <- last (tyConRoles tycon) + = (unitBag fmap_bind, emptyBag) + where + fmap_name = L loc fmap_RDR + fmap_bind = mkRdrFunBind fmap_name fmap_eqns + fmap_eqns = [mkSimpleMatch fmap_match_ctxt + [nlWildPat] + coerce_Expr] + fmap_match_ctxt = FunRhs fmap_name Prefix + gen_Functor_binds loc tycon = (listToBag [fmap_bind, replace_bind], emptyBag) where data_cons = tyConDataCons tycon fmap_name = L loc fmap_RDR - fmap_bind = mkRdrFunBind fmap_name fmap_eqns + + -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] + fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns fmap_match_ctxt = FunRhs fmap_name Prefix fmap_eqn con = flip evalState bs_RDRs $ @@ -137,11 +153,7 @@ gen_Functor_binds loc tycon where parts = sequence $ foldDataConArgs ft_fmap con - fmap_eqns - | null data_cons = [mkSimpleMatch fmap_match_ctxt - [nlWildPat, nlWildPat] - (error_Expr "Void fmap")] - | otherwise = map fmap_eqn data_cons + fmap_eqns = map fmap_eqn data_cons ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName)) ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x @@ -161,12 +173,14 @@ gen_Functor_binds loc tycon , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g -- fmap f = fmap g , ft_forall = \_ g -> g - , ft_bad_app = panic "in other argument" - , ft_co_var = panic "contravariant" } + , ft_bad_app = panic "in other argument in ft_fmap" + , ft_co_var = panic "contravariant in ft_fmap" } -- See Note [deriving <$] replace_name = L loc replace_RDR - replace_bind = mkRdrFunBind replace_name replace_eqns + + -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] + replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns replace_match_ctxt = FunRhs replace_name Prefix replace_eqn con = flip evalState bs_RDRs $ @@ -174,11 +188,7 @@ gen_Functor_binds loc tycon where parts = traverse (fmap replace) $ foldDataConArgs ft_replace con - replace_eqns - | null data_cons = [mkSimpleMatch replace_match_ctxt - [nlWildPat, nlWildPat] - (error_Expr "Void <$")] - | otherwise = map replace_eqn data_cons + replace_eqns = map replace_eqn data_cons ft_replace :: FFoldType (State [RdrName] Replacer) ft_replace = FT { ft_triv = fmap Nested $ mkSimpleLam $ \x -> return x @@ -205,8 +215,8 @@ gen_Functor_binds loc tycon nlHsApp replace_Expr z_Expr -- (p <$) = fmap (p <$) , ft_forall = \_ g -> g - , ft_bad_app = panic "in other argument" - , ft_co_var = panic "contravariant" } + , ft_bad_app = panic "in other argument in ft_replace" + , ft_co_var = panic "contravariant in ft_replace" } -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ... match_for_con :: HsMatchContext RdrName @@ -394,8 +404,8 @@ deepSubtypesContaining tv , ft_fun = (++) , ft_tup = \_ xs -> concat xs , ft_ty_app = (:) - , ft_bad_app = panic "in other argument" - , ft_co_var = panic "contravariant" + , ft_bad_app = panic "in other argument in deepSubtypesContaining" + , ft_co_var = panic "contravariant in deepSubtypesContaining" , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs }) @@ -456,7 +466,8 @@ mkSimpleConMatch ctxt fold extra_pats con insides = do let pat = if null vars_needed then bare_pat else nlParPat bare_pat - rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed)) + rhs <- fold con_name + (zipWith (\i v -> i `nlHsApp` nlHsVar v) insides vars_needed) return $ mkMatch ctxt (extra_pats ++ [pat]) rhs (noLoc emptyLocalBinds) @@ -492,21 +503,19 @@ mkSimpleConMatch2 ctxt fold extra_pats con insides = do -- Make sure to zip BEFORE invoking catMaybes. We want the variable -- indicies in each expression to match up with the argument indices -- in con_expr (defined below). - exps = catMaybes $ zipWith (\i v -> (`nlHsApp` v) <$> i) - insides (map nlHsVar vars_needed) + exps = catMaybes $ zipWith (\i v -> (`nlHsApp` nlHsVar v) <$> i) + insides 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 = map isJust insides - (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_RDRs + (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_Vars con_expr - | null asWithTyVar = nlHsApps con_name $ map nlHsVar asWithoutTyVar + | null asWithTyVar = nlHsApps con_name asWithoutTyVar | otherwise = let bs = filterByList argTysTyVarInfo bs_RDRs - vars = filterByLists argTysTyVarInfo - (map nlHsVar bs_RDRs) - (map nlHsVar as_RDRs) + vars = filterByLists argTysTyVarInfo bs_Vars as_Vars in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars) rhs <- fold con_expr exps @@ -590,7 +599,25 @@ See Note [DeriveFoldable with ExistentialQuantification]. -} gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) +-- When the parameter is phantom, we can use foldMap _ _ = mempty +-- See Note [Phantom types with Functor, Foldable, and Traversable] +gen_Foldable_binds loc tycon + | Phantom <- last (tyConRoles tycon) + = (unitBag foldMap_bind, emptyBag) + where + foldMap_name = L loc foldMap_RDR + foldMap_bind = mkRdrFunBind foldMap_name foldMap_eqns + foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt + [nlWildPat, nlWildPat] + mempty_Expr] + foldMap_match_ctxt = FunRhs foldMap_name Prefix + gen_Foldable_binds loc tycon + | null data_cons -- There's no real point producing anything but + -- foldMap for a type with no constructors. + = (unitBag foldMap_bind, emptyBag) + + | otherwise = (listToBag [foldr_bind, foldMap_bind], emptyBag) where data_cons = tyConDataCons tycon @@ -602,7 +629,14 @@ gen_Foldable_binds loc tycon where parts = sequence $ foldDataConArgs ft_foldr con - foldMap_bind = mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons) + foldMap_name = L loc foldMap_RDR + + -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] + foldMap_bind = mkRdrFunBindEC 2 (const mempty_Expr) + foldMap_name foldMap_eqns + + foldMap_eqns = map foldMap_eqn data_cons + foldMap_eqn con = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs where @@ -629,9 +663,9 @@ gen_Foldable_binds loc tycon nlHsApps foldable_foldr_RDR [gg',z,x]) gg -- foldr f = (\x z -> foldr g z x) , ft_forall = \_ g -> g - , ft_co_var = panic "contravariant" - , ft_fun = panic "function" - , ft_bad_app = panic "in other argument" } + , ft_co_var = panic "contravariant in ft_foldr" + , ft_fun = panic "function in ft_foldr" + , ft_bad_app = panic "in other argument in ft_foldr" } match_foldr :: LHsExpr RdrName -> [LPat RdrName] @@ -659,9 +693,9 @@ gen_Foldable_binds loc tycon , ft_ty_app = \_ g -> fmap (nlHsApp foldMap_Expr) <$> g -- foldMap f = foldMap g , ft_forall = \_ g -> g - , ft_co_var = panic "contravariant" - , ft_fun = panic "function" - , ft_bad_app = panic "in other argument" } + , ft_co_var = panic "contravariant in ft_foldMap" + , ft_fun = panic "function in ft_foldMap" + , ft_bad_app = panic "in other argument in ft_foldMap" } match_foldMap :: [LPat RdrName] -> DataCon @@ -715,13 +749,31 @@ See Note [Generated code for DeriveFoldable and DeriveTraversable]. -} gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff) +-- When the argument is phantom, we can use traverse = pure . coerce +-- See Note [Phantom types with Functor, Foldable, and Traversable] +gen_Traversable_binds loc tycon + | Phantom <- last (tyConRoles tycon) + = (unitBag traverse_bind, emptyBag) + where + traverse_name = L loc traverse_RDR + traverse_bind = mkRdrFunBind traverse_name traverse_eqns + traverse_eqns = + [mkSimpleMatch traverse_match_ctxt + [nlWildPat, z_Pat] + (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])] + traverse_match_ctxt = FunRhs traverse_name Prefix + gen_Traversable_binds loc tycon = (unitBag traverse_bind, emptyBag) where data_cons = tyConDataCons tycon - traverse_bind = mkRdrFunBind (L loc traverse_RDR) eqns - eqns = map traverse_eqn data_cons + traverse_name = L loc traverse_RDR + + -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable] + traverse_bind = mkRdrFunBindEC 2 (nlHsApp pure_Expr) + traverse_name traverse_eqns + traverse_eqns = map traverse_eqn data_cons traverse_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs where @@ -745,9 +797,9 @@ gen_Traversable_binds loc tycon , ft_ty_app = \_ g -> fmap (nlHsApp traverse_Expr) <$> g -- traverse f = traverse g , ft_forall = \_ g -> g - , ft_co_var = panic "contravariant" - , ft_fun = panic "function" - , ft_bad_app = panic "in other argument" } + , ft_co_var = panic "contravariant in ft_trav" + , ft_fun = panic "function in ft_trav" + , ft_bad_app = panic "in other argument in ft_trav" } -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1) -- (g2 a2) <*> ... @@ -769,7 +821,7 @@ gen_Traversable_binds loc tycon ----------------------------------------------------------------------- f_Expr, z_Expr, fmap_Expr, replace_Expr, mempty_Expr, foldMap_Expr, - traverse_Expr :: LHsExpr RdrName + traverse_Expr, coerce_Expr, pure_Expr :: LHsExpr RdrName f_Expr = nlHsVar f_RDR z_Expr = nlHsVar z_RDR fmap_Expr = nlHsVar fmap_RDR @@ -777,6 +829,8 @@ replace_Expr = nlHsVar replace_RDR mempty_Expr = nlHsVar mempty_RDR foldMap_Expr = nlHsVar foldMap_RDR traverse_Expr = nlHsVar traverse_RDR +coerce_Expr = nlHsVar (getRdrName coerceId) +pure_Expr = nlHsVar pure_RDR f_RDR, z_RDR :: RdrName f_RDR = mkVarUnqual (fsLit "f") @@ -786,6 +840,10 @@ as_RDRs, bs_RDRs :: [RdrName] as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] +as_Vars, bs_Vars :: [LHsExpr RdrName] +as_Vars = map nlHsVar as_RDRs +bs_Vars = map nlHsVar bs_RDRs + f_Pat, z_Pat :: LPat RdrName f_Pat = nlVarPat f_RDR z_Pat = nlVarPat z_RDR @@ -1021,4 +1079,84 @@ decide not to do so because: 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. -} diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index ffbade1153..51451a6d1a 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -345,7 +345,7 @@ mkBindsRep gk tycon = -- Recurse over the sum first from_alts, to_alts :: [Alt] - (from_alts, to_alts) = mkSum gk_ (1 :: US) tycon datacons + (from_alts, to_alts) = mkSum gk_ (1 :: US) datacons where gk_ = case gk of Gen0 -> Gen0_ Gen1 -> ASSERT(length tyvars >= 1) @@ -693,24 +693,19 @@ mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k ty mkSum :: GenericKind_ -- Generic or Generic1? -> US -- Base for generating unique names - -> TyCon -- The type constructor -> [DataCon] -- The data constructors -> ([Alt], -- Alternatives for the T->Trep "from" function [Alt]) -- Alternatives for the Trep->T "to" function -- Datatype without any constructors -mkSum _ _ tycon [] = ([from_alt], [to_alt]) +mkSum _ _ [] = ([from_alt], [to_alt]) where - from_alt = (nlWildPat, makeError errMsgFrom) - to_alt = (nlWildPat, makeError errMsgTo) + from_alt = (x_Pat, nlHsCase x_Expr []) + to_alt = (x_Pat, nlHsCase x_Expr []) -- These M1s are meta-information for the datatype - makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s)) - tyConStr = occNameString (nameOccName (tyConName tycon)) - errMsgFrom = "No generic representation for empty datatype " ++ tyConStr - errMsgTo = "No values for empty datatype " ++ tyConStr -- Datatype with at least one constructor -mkSum gk_ us _ datacons = +mkSum gk_ us datacons = -- switch the payload of gk_ to be datacon-centric instead of tycon-centric unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d | (d,i) <- zip datacons [1..] ] diff --git a/docs/users_guide/8.4.1-notes.rst b/docs/users_guide/8.4.1-notes.rst new file mode 100644 index 0000000000..4470bb9e79 --- /dev/null +++ b/docs/users_guide/8.4.1-notes.rst @@ -0,0 +1,78 @@ +.. _release-8-4-1: + +Release notes for version 8.4.1 +=============================== + +The significant changes to the various parts of the compiler are listed in the +following sections. There have also been numerous bug fixes and performance +improvements over the 8.2.1 release. + + +Highlights +---------- + +The highlights, since the 8.2.1 release, are: + +- Many, many bug fixes. + +Full details +------------ + +Language +~~~~~~~~ + +Compiler +~~~~~~~~ + +- Derived ``Functor``, ``Foldable``, and ``Traversable`` instances are now +optimized when their last type parameters have phantom roles. Specifically, :: + + fmap _ = coerce + traverse _ x = pure (coerce x) + foldMap _ _ = mempty + +These definitions of ``foldMap`` and ``traverse`` are lazier than +the ones we would otherwise derive, as they may produce results without +inspecting their arguments at all. + +See also :ref:`deriving-functor`, :ref:`deriving-foldable`, and +:ref:`deriving-traversable`. + +- Derived ``Functor``, ``Foldable``, ``Traversable``, ``Generic``, and +``Generic1`` instances now have better, and generally better-documented, +behaviors for types with no constructors. In particular, :: + + fmap _ x = case x of + foldMap _ _ = mempty + traverse _ x = pure (case x of) + to x = case x of + to1 x = case x of + from x = case x of + from1 x = case x of + +The new behavior generally leads to more useful error messages than the +old did, and lazier semantics for ``foldMap`` and ``traverse``. + +- Derived instances for types with no constructors now have appropriate +arities: they take all their arguments before producing errors. This may not +be terribly important in practice, but it seems like the right thing to do. +Previously, we generated :: + + (==) = error ... + +Now we generate :: + + _ == _ = error ... + +- Lots of other bugs. See `Trac + `_ + for a complete list. + +Runtime system +~~~~~~~~~~~~~~ + +Template Haskell +~~~~~~~~~~~~~~~~ + +``ghc`` library +~~~~~~~~~~~~~~~ diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst index 98fbea1b9c..e1642062c4 100644 --- a/docs/users_guide/glasgow_exts.rst +++ b/docs/users_guide/glasgow_exts.rst @@ -3776,6 +3776,29 @@ fail to compile: would not compile successfully due to the way in which ``b`` is constrained. +When the last type parameter has a phantom role (see :ref:`roles`), the derived +``Functor`` instance will not be produced using the usual algorithm. Instead, +the entire value will be coerced. :: + + data Phantom a = Z | S (Phantom a) deriving Functor + +will produce the following instance: :: + + instance Functor Phantom where + fmap _ = coerce + +When a type has no constructors, the derived ``Functor`` instance will +simply force the (bottom) value of the argument using +:ghc-flag:`-XEmptyCase`. :: + + data V a deriving Functor + type role V nominal + +will produce + + instance Functor V where + fmap _ z = case z of + .. _deriving-foldable: Deriving ``Foldable`` instances @@ -3799,7 +3822,30 @@ of ``fmap``. In addition, :ghc-flag:`-XDeriveFoldable` filters out all constructor arguments on the RHS expression whose types do not mention the last type parameter, since those arguments do not need to be folded over. -Here are the differences between the generated code in each extension: +When the type parameter has a phantom role (see :ref:`roles`), +:ghc-flag:`-XDeriveFoldable` derives a trivial instance. For example, this +declaration: :: + + data Phantom a = Z | S (Phantom a) + +will generate the following instance. :: + + instance Foldable Phantom where + foldMap _ _ = mempty + +Similarly, when the type has no constructors, :ghc-flag:`-XDeriveFoldable` will +derive a trivial instance: :: + + data V a deriving Foldable + type role V nominal + +will generate the following. :: + + instance Foldable V where + foldMap _ _ = mempty + +Here are the differences between the generated code for ``Functor`` and +``Foldable``: #. When a bare type variable ``a`` is encountered, :ghc-flag:`-XDeriveFunctor` would generate ``f a`` for an ``fmap`` definition. :ghc-flag:`-XDeriveFoldable` would @@ -3882,7 +3928,31 @@ The algorithm for :ghc-flag:`-XDeriveTraversable` is adapted from the instead of ``fmap``. In addition, :ghc-flag:`-XDeriveTraversable` filters out all constructor arguments on the RHS expression whose types do not mention the last type parameter, since those arguments do not produce any effects in a -traversal. Here are the differences between the generated code in each +traversal. + +When the type parameter has a phantom role (see :ref:`roles`), +:ghc-flag:`-XDeriveTraversable` coerces its argument. For example, this +declaration:: + + data Phantom a = Z | S (Phantom a) deriving Traversable + +will generate the following instance:: + + instance Traversable Phantom where + traverse _ z = pure (coerce z) + +When the type has no constructors, :ghc-flag:`-XDeriveTraversable` will +derive the laziest instance it can. :: + + data V a deriving Traversable + type role V nominal + +will generate the following, using :ghc-flag:`-XEmptyCase`: :: + + instance Traversable V where + traverse _ z = pure (case z of) + +Here are the differences between the generated code in each extension: #. When a bare type variable ``a`` is encountered, both :ghc-flag:`-XDeriveFunctor` and diff --git a/docs/users_guide/index.rst b/docs/users_guide/index.rst index bdb6b98e9b..b57e37b018 100644 --- a/docs/users_guide/index.rst +++ b/docs/users_guide/index.rst @@ -13,6 +13,7 @@ Contents: license intro 8.2.1-notes + 8.4.1-notes ghci runghc usage diff --git a/testsuite/tests/deriving/should_compile/all.T b/testsuite/tests/deriving/should_compile/all.T index 5c3f970ef2..837bb04856 100644 --- a/testsuite/tests/deriving/should_compile/all.T +++ b/testsuite/tests/deriving/should_compile/all.T @@ -1,3 +1,6 @@ +def just_the_deriving( msg ): + return msg[0:msg.find('Filling in method body')] + test('drv001', normal, compile, ['']) test('drv002', normal, compile, ['']) test('drv003', normal, compile, ['']) @@ -85,3 +88,5 @@ test('T12814', normal, compile, ['-Wredundant-constraints']) test('T13272', normal, compile, ['']) test('T13272a', normal, compile, ['']) test('T13297', normal, compile, ['']) +test('drv-empty-data', [normalise_errmsg_fun(just_the_deriving)],compile, ['-ddump-deriv -dsuppress-uniques']) +test('drv-phantom', [normalise_errmsg_fun(just_the_deriving)],compile, ['-ddump-deriv -dsuppress-uniques']) diff --git a/testsuite/tests/deriving/should_compile/drv-empty-data.hs b/testsuite/tests/deriving/should_compile/drv-empty-data.hs new file mode 100644 index 0000000000..383ce8f9f7 --- /dev/null +++ b/testsuite/tests/deriving/should_compile/drv-empty-data.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE DeriveTraversable, DeriveGeneric, EmptyCase, + DeriveDataTypeable, StandaloneDeriving, DeriveLift #-} + +module DrvEmptyData where +import GHC.Generics (Generic, Generic1) +import Data.Data (Data) +import Language.Haskell.TH.Syntax (Lift) + +data Void a deriving (Functor, Foldable, Traversable, Generic, Generic1, Lift) + +-- We don't want to invoke the special case for phantom types here. +type role Void nominal + +deriving instance Data a => Data (Void a) +deriving instance Eq (Void a) +deriving instance Ord (Void a) +deriving instance Show (Void a) +deriving instance Read (Void a) diff --git a/testsuite/tests/deriving/should_compile/drv-empty-data.stderr b/testsuite/tests/deriving/should_compile/drv-empty-data.stderr new file mode 100644 index 0000000000..502ba6c572 --- /dev/null +++ b/testsuite/tests/deriving/should_compile/drv-empty-data.stderr @@ -0,0 +1,68 @@ + +==================== Derived instances ==================== +Derived class instances: + instance GHC.Read.Read (DrvEmptyData.Void a) where + GHC.Read.readPrec + = GHC.Read.parens Text.ParserCombinators.ReadPrec.pfail + GHC.Read.readList = GHC.Read.readListDefault + GHC.Read.readListPrec = GHC.Read.readListPrecDefault + + instance GHC.Show.Show (DrvEmptyData.Void a) where + GHC.Show.showsPrec _ = GHC.Err.error "Void showsPrec" + GHC.Show.showList = GHC.Show.showList__ (GHC.Show.showsPrec 0) + + instance GHC.Classes.Ord (DrvEmptyData.Void a) where + GHC.Classes.compare _ _ = GHC.Err.error "Void compare" + + instance GHC.Classes.Eq (DrvEmptyData.Void a) where + (GHC.Classes.==) _ _ = GHC.Err.error "Void ==" + + instance Data.Data.Data a => + Data.Data.Data (DrvEmptyData.Void a) where + Data.Data.gfoldl _ _ _ = GHC.Err.error "Void gfoldl" + Data.Data.gunfold k z c = case Data.Data.constrIndex c of + Data.Data.toConstr _ = GHC.Err.error "Void toConstr" + Data.Data.dataTypeOf _ = DrvEmptyData.$tVoid + Data.Data.dataCast1 f = Data.Typeable.gcast1 f + + instance GHC.Base.Functor DrvEmptyData.Void where + GHC.Base.fmap _ z = case z of + (GHC.Base.<$) _ z = case z of + + instance Data.Foldable.Foldable DrvEmptyData.Void where + Data.Foldable.foldMap _ z = GHC.Base.mempty + + instance Data.Traversable.Traversable DrvEmptyData.Void where + Data.Traversable.traverse _ z = GHC.Base.pure (case z of) + + instance GHC.Generics.Generic (DrvEmptyData.Void a) where + GHC.Generics.from x + = GHC.Generics.M1 (case x of { x -> case x of }) + GHC.Generics.to (GHC.Generics.M1 x) = case x of { x -> case x of } + + instance GHC.Generics.Generic1 DrvEmptyData.Void where + GHC.Generics.from1 x + = GHC.Generics.M1 (case x of { x -> case x of }) + GHC.Generics.to1 (GHC.Generics.M1 x) = case x of { x -> case x of } + + instance Language.Haskell.TH.Syntax.Lift + (DrvEmptyData.Void a) where + Language.Haskell.TH.Syntax.lift _ + = GHC.Err.error "Can't lift value of empty datatype Void" + + DrvEmptyData.$tVoid :: Data.Data.DataType + DrvEmptyData.$tVoid = Data.Data.mkDataType "Void" [] + +Derived type family instances: + type GHC.Generics.Rep (DrvEmptyData.Void a) = GHC.Generics.D1 + ('GHC.Generics.MetaData + "Void" "DrvEmptyData" "main" 'GHC.Types.False) + GHC.Generics.V1 + type GHC.Generics.Rep1 DrvEmptyData.Void = GHC.Generics.D1 + ('GHC.Generics.MetaData + "Void" "DrvEmptyData" "main" 'GHC.Types.False) + GHC.Generics.V1 + + + +==================== Filling in method body ==================== diff --git a/testsuite/tests/deriving/should_compile/drv-phantom.hs b/testsuite/tests/deriving/should_compile/drv-phantom.hs new file mode 100644 index 0000000000..7116f75d0a --- /dev/null +++ b/testsuite/tests/deriving/should_compile/drv-phantom.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE DeriveTraversable #-} + +module DrvPhantom where +import GHC.Generics (Generic, Generic1) +import Data.Data (Data) +import Language.Haskell.TH.Syntax (Lift) + +data NotAList a = Nil | NotCons (NotAList a) + deriving (Functor, Foldable, Traversable) + +type role NotAList phantom diff --git a/testsuite/tests/deriving/should_compile/drv-phantom.stderr b/testsuite/tests/deriving/should_compile/drv-phantom.stderr new file mode 100644 index 0000000000..67a053a665 --- /dev/null +++ b/testsuite/tests/deriving/should_compile/drv-phantom.stderr @@ -0,0 +1,18 @@ + +==================== Derived instances ==================== +Derived class instances: + instance GHC.Base.Functor DrvPhantom.NotAList where + GHC.Base.fmap _ = GHC.Prim.coerce + + instance Data.Foldable.Foldable DrvPhantom.NotAList where + Data.Foldable.foldMap _ _ = GHC.Base.mempty + + instance Data.Traversable.Traversable DrvPhantom.NotAList where + Data.Traversable.traverse _ z = GHC.Base.pure (GHC.Prim.coerce z) + + +Derived type family instances: + + + +==================== Filling in method body ==================== diff --git a/testsuite/tests/generics/T10604/T10604_deriving.stderr b/testsuite/tests/generics/T10604/T10604_deriving.stderr index 6862ff5adc..59be21fd45 100644 --- a/testsuite/tests/generics/T10604/T10604_deriving.stderr +++ b/testsuite/tests/generics/T10604/T10604_deriving.stderr @@ -3,28 +3,17 @@ Derived class instances: instance GHC.Generics.Generic (T10604_deriving.Empty a) where GHC.Generics.from x - = GHC.Generics.M1 - (case x of { - _ -> GHC.Err.error - "No generic representation for empty datatype Empty" }) - GHC.Generics.to (GHC.Generics.M1 x) - = case x of { - _ -> GHC.Err.error "No values for empty datatype Empty" } + = GHC.Generics.M1 (case x of { x -> case x of }) + GHC.Generics.to (GHC.Generics.M1 x) = case x of { x -> case x of } instance GHC.Generics.Generic1 GHC.Types.Bool T10604_deriving.Empty where GHC.Generics.from1 x - = GHC.Generics.M1 - (case x of { - _ -> GHC.Err.error - "No generic representation for empty datatype Empty" }) - GHC.Generics.to1 (GHC.Generics.M1 x) - = case x of { - _ -> GHC.Err.error "No values for empty datatype Empty" } + = GHC.Generics.M1 (case x of { x -> case x of }) + GHC.Generics.to1 (GHC.Generics.M1 x) = case x of { x -> case x of } instance GHC.Base.Functor (T10604_deriving.Proxy *) where - GHC.Base.fmap f T10604_deriving.Proxy = T10604_deriving.Proxy - (GHC.Base.<$) z T10604_deriving.Proxy = T10604_deriving.Proxy + GHC.Base.fmap _ = GHC.Prim.coerce instance forall k (a :: k). GHC.Generics.Generic (T10604_deriving.Proxy k a) where @@ -56,8 +45,7 @@ Derived class instances: (GHC.Generics.M1 (GHC.Generics.M1 (GHC.Generics.K1 g1))) -> T10604_deriving.Wrap g1 } - instance GHC.Generics.Generic1 - (* -> *) T10604_deriving.Wrap where + instance GHC.Generics.Generic1 (* -> *) T10604_deriving.Wrap where GHC.Generics.from1 x = GHC.Generics.M1 (case x of { @@ -250,35 +238,25 @@ Derived type family instances: 'GHC.Generics.DecidedLazy) (GHC.Generics.Rec0 * - (T10604_deriving.Proxy - (* -> *) a)))) + (T10604_deriving.Proxy (* -> *) a)))) type GHC.Generics.Rep1 (* -> *) T10604_deriving.Wrap = GHC.Generics.D1 - (* -> *) - ('GHC.Generics.MetaData - "Wrap" - "T10604_deriving" - "main" - 'GHC.Types.False) - (GHC.Generics.C1 - (* -> *) - ('GHC.Generics.MetaCons - "Wrap" - 'GHC.Generics.PrefixI - 'GHC.Types.False) - (GHC.Generics.S1 - (* -> *) - ('GHC.Generics.MetaSel - ('GHC.Base.Nothing - GHC.Types.Symbol) - 'GHC.Generics.NoSourceUnpackedness - 'GHC.Generics.NoSourceStrictness - 'GHC.Generics.DecidedLazy) - (GHC.Generics.Rec1 - (* -> *) - (T10604_deriving.Proxy - (* - -> *))))) + (* -> *) + ('GHC.Generics.MetaData + "Wrap" "T10604_deriving" "main" 'GHC.Types.False) + (GHC.Generics.C1 + (* -> *) + ('GHC.Generics.MetaCons + "Wrap" 'GHC.Generics.PrefixI 'GHC.Types.False) + (GHC.Generics.S1 + (* -> *) + ('GHC.Generics.MetaSel + ('GHC.Base.Nothing GHC.Types.Symbol) + 'GHC.Generics.NoSourceUnpackedness + 'GHC.Generics.NoSourceStrictness + 'GHC.Generics.DecidedLazy) + (GHC.Generics.Rec1 + (* -> *) (T10604_deriving.Proxy (* -> *))))) type GHC.Generics.Rep (T10604_deriving.Wrap2 k a) = GHC.Generics.D1 * ('GHC.Generics.MetaData @@ -308,34 +286,32 @@ Derived type family instances: (k -> *) a))))) type GHC.Generics.Rep1 (k -> *) (T10604_deriving.Wrap2 k) = GHC.Generics.D1 - (k -> *) - ('GHC.Generics.MetaData - "Wrap2" - "T10604_deriving" - "main" - 'GHC.Types.False) - (GHC.Generics.C1 - (k -> *) - ('GHC.Generics.MetaCons - "Wrap2" - 'GHC.Generics.PrefixI - 'GHC.Types.False) - (GHC.Generics.S1 - (k -> *) - ('GHC.Generics.MetaSel - ('GHC.Base.Nothing - GHC.Types.Symbol) - 'GHC.Generics.NoSourceUnpackedness - 'GHC.Generics.NoSourceStrictness - 'GHC.Generics.DecidedLazy) - ((GHC.Generics.:.:) - * - (k -> *) - (T10604_deriving.Proxy *) - (GHC.Generics.Rec1 - (k -> *) - (T10604_deriving.Proxy - (k -> *)))))) + (k -> *) + ('GHC.Generics.MetaData + "Wrap2" + "T10604_deriving" + "main" + 'GHC.Types.False) + (GHC.Generics.C1 + (k -> *) + ('GHC.Generics.MetaCons + "Wrap2" + 'GHC.Generics.PrefixI + 'GHC.Types.False) + (GHC.Generics.S1 + (k -> *) + ('GHC.Generics.MetaSel + ('GHC.Base.Nothing GHC.Types.Symbol) + 'GHC.Generics.NoSourceUnpackedness + 'GHC.Generics.NoSourceStrictness + 'GHC.Generics.DecidedLazy) + ((GHC.Generics.:.:) + * + (k -> *) + (T10604_deriving.Proxy *) + (GHC.Generics.Rec1 + (k -> *) + (T10604_deriving.Proxy (k -> *)))))) type GHC.Generics.Rep (T10604_deriving.SumOfProducts k a) = GHC.Generics.D1 * @@ -542,3 +518,9 @@ Derived type family instances: * GHC.Types.Int)))) + +==================== Filling in method body ==================== +GHC.Base.Functor [T10604_deriving.Proxy *] + GHC.Base.<$ = GHC.Base.$dm<$ @T10604_deriving.Proxy * + + diff --git a/testsuite/tests/perf/compiler/T13056.hs b/testsuite/tests/perf/compiler/T13056.hs index 046e1b0747..f2dd040bdc 100644 --- a/testsuite/tests/perf/compiler/T13056.hs +++ b/testsuite/tests/perf/compiler/T13056.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE RoleAnnotations #-} module Bug where import Data.Typeable @@ -10,6 +11,9 @@ import Data.Data data Condition v = Condition deriving (Functor, Foldable) +-- We don't want the phantom optimization to kick +-- in here and confuse the test. +type role Condition representational data CondTree v c a = CondNode { condTreeData :: a -- GitLab