Deriving for phantom and empty types
[ghc.git] / compiler / typecheck / TcGenFunctor.hs
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.
 -}