Improve error messages for roles by writing role names out
[ghc.git] / compiler / typecheck / TcDeriv.lhs
index ac2d810..144678e 100644 (file)
@@ -46,7 +46,6 @@ import RdrName
 import Name
 import NameSet
 import TyCon
-import CoAxiom
 import TcType
 import Var
 import VarSet
@@ -355,7 +354,7 @@ tcDeriving tycl_decls inst_decls deriv_decls
   where
     ddump_deriving :: Bag (InstInfo Name) -> HsValBinds Name
                    -> Bag TyCon                 -- ^ Empty data constructors
-                   -> Bag (FamInst Unbranched)  -- ^ Rep type family instances
+                   -> Bag (FamInst)             -- ^ Rep type family instances
                    -> SDoc
     ddump_deriving inst_infos extra_binds repMetaTys repFamInsts
       =    hang (ptext (sLit "Derived instances:"))
@@ -370,12 +369,11 @@ tcDeriving tycl_decls inst_decls deriv_decls
     hangP s x = text "" $$ hang (ptext (sLit s)) 2 x
 
 -- Prints the representable type family instance
-pprRepTy :: FamInst Unbranched -> SDoc
-pprRepTy fi@(FamInst { fi_branches = FirstBranch (FamInstBranch { fib_lhs = lhs
-                                                                , fib_rhs = rhs }) })
+pprRepTy :: FamInst -> SDoc
+pprRepTy fi@(FamInst { fi_tys = lhs })
   = ptext (sLit "type") <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>
-      equals <+> ppr rhs 
-
+      equals <+> ppr rhs
+  where rhs = famInstRHS fi
 
 -- As of 24 April 2012, this only shares MetaTyCons between derivations of
 -- Generic and Generic1; thus the types and logic are quite simple.
@@ -406,7 +404,7 @@ renameDeriv is_boot inst_infos bagBinds
 
   | otherwise
   = discardWarnings $         -- Discard warnings about unused bindings etc
-    setXOptM Opt_EmptyCase $  -- Derived decls (for empty types) can have 
+    setXOptM Opt_EmptyCase $  -- Derived decls (for empty types) can have
                               --    case x of {}
     do  {
         -- Bring the extra deriving stuff into scope
@@ -552,8 +550,9 @@ deriveFamInst decl@(DataFamInstDecl { dfid_tycon = L _ tc_name, dfid_pats = pats
                                     , dfid_defn = HsDataDefn { dd_derivs = Just preds } })
   = tcAddDataFamInstCtxt decl $
     do { fam_tc <- tcLookupTyCon tc_name
-       ; tcFamTyPats fam_tc pats (\_ -> return ()) $ \ tvs' pats' _ ->
-         mapM (deriveTyData tvs' fam_tc pats') preds }
+       ; tcFamTyPats tc_name (tyConKind fam_tc) pats (\_ -> return ()) $
+         \ tvs' pats' _ ->
+           mapM (deriveTyData tvs' fam_tc pats') preds }
         -- Tiresomely we must figure out the "lhs", which is awkward for type families
         -- E.g.   data T a b = .. deriving( Eq )
         --          Here, the lhs is (T a b)
@@ -744,10 +743,8 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta
                 Nothing -> bale_out (ptext (sLit "No family instance for")
                                      <+> quotes (pprTypeApp tycon tys))
                 Just (FamInstMatch { fim_instance = famInst
-                                   , fim_index    = index
                                    , fim_tys      = tys })
-                  -> ASSERT( index == 0 )
-                     let tycon' = dataFamInstRepTyCon famInst
+                  -> let tycon' = dataFamInstRepTyCon famInst
                      in return (tycon', tys) }
 \end{code}
 
@@ -767,7 +764,7 @@ if there are any overlaps.
 There are two other things that might go wrong with the lookup.
 First, we might see a standalone deriving clause
    deriving Eq (F ())
-when there is no data instance F () in scope. 
+when there is no data instance F () in scope.
 
 Note that it's OK to have
   data instance F [a] = ...
@@ -799,7 +796,7 @@ When type familes are involved it's trickier:
 
     instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
        -- d1 :: Monad []
-       -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT)) 
+       -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT))
 
 Note the need for the eta-reduced rule axioms.  After all, we can
 write it out
@@ -915,7 +912,7 @@ mkPolyKindedTypeableEqn orig tvs cls _cls_tys tycon tc_args mtheta
                      , ds_tc = tycon, ds_tc_args = tc_args
                      , ds_theta = mtheta `orElse` []  -- Context is empty for polykinded Typeable
                      , ds_newtype = False })  }
-  where 
+  where
     is_kind_var tc_arg = case tcGetTyVar_maybe tc_arg of
                            Just v  -> isKindVar v
                            Nothing -> False
@@ -1005,16 +1002,10 @@ ghc-prim does not use Functor or Typeable implicitly via these lookups.
 Note [Deriving and unboxed types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We have some special hacks to support things like
-   data T = MkT Int# deriving( Ord, Show )
-
-Specifically
-  * For Show we use TcGenDeriv.box_if_necy to box the Int# into an Int
-    (which we know how to show)
-
-  * For Eq, Ord, we ust TcGenDeriv.primOrdOps to give Ord operations
-    on some primitive types
+   data T = MkT Int# deriving ( Show )
 
-It's all a bit ad hoc.
+Specifically, we use TcGenDeriv.box_if_necy to box the Int# into an Int
+(which we know how to show). It's a bit ad hoc.
 
 
 \begin{code}
@@ -1447,6 +1438,7 @@ mkNewTypeEqn orig dflags tvs
            && arity_ok
            && eta_ok
            && ats_ok
+           && roles_ok
 --         && not (isRecursiveTyCon tycon)      -- Note [Recursive newtypes]
 
         arity_ok = length cls_tys + 1 == classArity cls
@@ -1467,13 +1459,26 @@ mkNewTypeEqn orig dflags tvs
                -- currently generate type 'instance' decls; and cannot do
                -- so for 'data' instance decls
 
+        roles_ok = let cls_roles = tyConRoles (classTyCon cls) in
+                   not (null cls_roles) && last cls_roles /= Nominal
+               -- We must make sure that the class definition (and all its
+               -- members) never pattern-match on the last parameter.
+               -- See Trac #1496 and Note [Roles] in Coercion
+
         cant_derive_err
            = vcat [ ppUnless arity_ok arity_msg
                   , ppUnless eta_ok eta_msg
-                  , ppUnless ats_ok ats_msg ]
+                  , ppUnless ats_ok ats_msg
+                  , ppUnless roles_ok roles_msg ]
         arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
         eta_msg   = ptext (sLit "cannot eta-reduce the representation type enough")
         ats_msg   = ptext (sLit "the class has associated types")
+        roles_msg = ptext (sLit "it is not type-safe to use") <+>
+                    ptext (sLit "GeneralizedNewtypeDeriving on this class;") $$
+                    ptext (sLit "the last parameter of") <+>
+                    quotes (ppr (className cls)) <+>
+                    ptext (sLit "is at role Nominal")
+
 \end{code}
 
 Note [Recursive newtypes]
@@ -1599,7 +1604,7 @@ extendLocalInstEnv dfuns thing_inside
 
 
 ***********************************************************************************
-*                                                                                 * 
+*                                                                                 *
 *            Simplify derived constraints
 *                                                                                 *
 ***********************************************************************************
@@ -1607,16 +1612,16 @@ extendLocalInstEnv dfuns thing_inside
 \begin{code}
 simplifyDeriv :: CtOrigin
               -> PredType
-              -> [TyVar]        
+              -> [TyVar]
               -> ThetaType              -- Wanted
               -> TcM ThetaType  -- Needed
--- Given  instance (wanted) => C inst_ty 
+-- Given  instance (wanted) => C inst_ty
 -- Simplify 'wanted' as much as possibles
 -- Fail if not possible
-simplifyDeriv orig pred tvs theta 
+simplifyDeriv orig pred tvs theta
   = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize
-                -- The constraint solving machinery 
-                -- expects *TcTyVars* not TyVars.  
+                -- The constraint solving machinery
+                -- expects *TcTyVars* not TyVars.
                 -- We use *non-overlappable* (vanilla) skolems
                 -- See Note [Overlap and deriving]
 
@@ -1626,7 +1631,7 @@ simplifyDeriv orig pred tvs theta
 
        ; wanted <- newFlatWanteds orig (substTheta skol_subst theta)
 
-       ; traceTc "simplifyDeriv" $ 
+       ; traceTc "simplifyDeriv" $
          vcat [ pprTvBndrs tvs $$ ppr theta $$ ppr wanted, doc ]
        ; (residual_wanted, _ev_binds1)
              <- solveWantedsTcM (mkFlatWC wanted)
@@ -1635,8 +1640,8 @@ simplifyDeriv orig pred tvs theta
        ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted)
                          -- See Note [Exotic derived instance contexts]
              get_good :: Ct -> Either PredType Ct
-             get_good ct | validDerivPred skol_set p 
-                         , isWantedCt ct  = Left p 
+             get_good ct | validDerivPred skol_set p
+                         , isWantedCt ct  = Left p
                          -- NB: residual_wanted may contain unsolved
                          -- Derived and we stick them into the bad set
                          -- so that reportUnsolved may decide what to do with them
@@ -1673,7 +1678,7 @@ and we want to infer
    f :: Show [a] => a -> String
 
 BOTTOM LINE: use vanilla, non-overlappable skolems when inferring
-             the context for the derived instance. 
+             the context for the derived instance.
              Hence tcInstSkolTyVars not tcInstSuperSkolTyVars
 
 Note [Exotic derived instance contexts]
@@ -1688,13 +1693,13 @@ One could go further: consider
         data T a b c = MkT (Foo a b c) deriving( Eq )
         instance (C Int a, Eq b, Eq c) => Eq (Foo a b c)
 
-Notice that this instance (just) satisfies the Paterson termination 
+Notice that this instance (just) satisfies the Paterson termination
 conditions.  Then we *could* derive an instance decl like this:
 
-        instance (C Int a, Eq b, Eq c) => Eq (T a b c) 
+        instance (C Int a, Eq b, Eq c) => Eq (T a b c)
 even though there is no instance for (C Int a), because there just
 *might* be an instance for, say, (C Int Bool) at a site where we
-need the equality instance for T's.  
+need the equality instance for T's.
 
 However, this seems pretty exotic, and it's quite tricky to allow
 this, and yet give sensible error messages in the (much more common)