Deriving for phantom and empty types
authorDavid Feuer <david.feuer@gmail.com>
Thu, 30 Mar 2017 17:30:52 +0000 (13:30 -0400)
committerDavid Feuer <David.Feuer@gmail.com>
Thu, 30 Mar 2017 17:30:54 +0000 (13:30 -0400)
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

13 files changed:
compiler/typecheck/TcGenDeriv.hs
compiler/typecheck/TcGenFunctor.hs
compiler/typecheck/TcGenGenerics.hs
docs/users_guide/8.4.1-notes.rst [new file with mode: 0644]
docs/users_guide/glasgow_exts.rst
docs/users_guide/index.rst
testsuite/tests/deriving/should_compile/all.T
testsuite/tests/deriving/should_compile/drv-empty-data.hs [new file with mode: 0644]
testsuite/tests/deriving/should_compile/drv-empty-data.stderr [new file with mode: 0644]
testsuite/tests/deriving/should_compile/drv-phantom.hs [new file with mode: 0644]
testsuite/tests/deriving/should_compile/drv-phantom.stderr [new file with mode: 0644]
testsuite/tests/generics/T10604/T10604_deriving.stderr
testsuite/tests/perf/compiler/T13056.hs

index c46c291..d21535e 100644 (file)
@@ -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
index e7bf394..edf5851 100644 (file)
@@ -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.
 -}
index ffbade1..51451a6 100644 (file)
@@ -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 (file)
index 0000000..4470bb9
--- /dev/null
@@ -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
+   <https://ghc.haskell.org/trac/ghc/query?status=closed&milestone=8.4.1&col=id&col=summary&col=status&col=type&col=priority&col=milestone&col=component&order=priority>`_
+   for a complete list.
+
+Runtime system
+~~~~~~~~~~~~~~
+
+Template Haskell
+~~~~~~~~~~~~~~~~
+
+``ghc`` library
+~~~~~~~~~~~~~~~
index 98fbea1..e164206 100644 (file)
@@ -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
index bdb6b98..b57e37b 100644 (file)
@@ -13,6 +13,7 @@ Contents:
    license
    intro
    8.2.1-notes
+   8.4.1-notes
    ghci
    runghc
    usage
index 5c3f970..837bb04 100644 (file)
@@ -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 (file)
index 0000000..383ce8f
--- /dev/null
@@ -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 (file)
index 0000000..502ba6c
--- /dev/null
@@ -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 (file)
index 0000000..7116f75
--- /dev/null
@@ -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 (file)
index 0000000..67a053a
--- /dev/null
@@ -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 ====================
index 6862ff5..59be21f 100644 (file)
@@ -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 *
+
+
index 046e1b0..f2dd040 100644 (file)
@@ -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