With GND, report Coercible errors earliy
authorJoachim Breitner <mail@joachim-breitner.de>
Mon, 2 Dec 2013 09:45:12 +0000 (09:45 +0000)
committerJoachim Breitner <mail@joachim-breitner.de>
Mon, 2 Dec 2013 11:00:15 +0000 (11:00 +0000)
just like other type errors occurring during deriving.

compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcGenDeriv.lhs

index 76a9011..9ce4f92 100644 (file)
@@ -57,6 +57,7 @@ import ListSetOps
 import Outputable
 import FastString
 import Bag
+import Pair
 
 import Control.Monad
 import Data.List
@@ -1486,8 +1487,8 @@ mkNewTypeEqn orig dflags tvs
                 -- dictionary
 
 
-    -- Next we figure out what superclass dictionaries to use
-    -- See Note [Newtype deriving superclasses] above
+        -- Next we figure out what superclass dictionaries to use
+        -- See Note [Newtype deriving superclasses] above
 
         cls_tyvars = classTyVars cls
         dfun_tvs = tyVarsOfTypes inst_tys
@@ -1496,6 +1497,15 @@ mkNewTypeEqn orig dflags tvs
         sc_theta = substTheta (zipOpenTvSubst cls_tyvars inst_tys)
                               (classSCTheta cls)
 
+
+        -- Next we collect Coercible constaints between
+        -- the Class method types, instantiated with the representation and the
+        -- newtype type; precisely the constraints required for the
+        -- calls to coercible that we are going to generate.
+        coercible_constraints =
+            map (\(Pair t1 t2) -> mkCoerciblePred t1 t2) $
+            mkCoerceClassMethEqn cls (varSetElemsKvsFirst dfun_tvs) inst_tys rep_inst_ty
+
                 -- If there are no tyvars, there's no need
                 -- to abstract over the dictionaries we need
                 -- Example:     newtype T = MkT Int deriving( C )
@@ -1503,7 +1513,7 @@ mkNewTypeEqn orig dflags tvs
                 --              instance C T
                 -- rather than
                 --              instance C Int => C T
-        all_preds = rep_pred : sc_theta         -- NB: rep_pred comes first
+        all_preds = rep_pred : coercible_constraints ++ sc_theta -- NB: rep_pred comes first
 
         -------------------------------------------------------------------
         --  Figuring out whether we can only do this newtype-deriving thing
index d4af39f..f2e5413 100644 (file)
@@ -30,6 +30,7 @@ module TcGenDeriv (
         deepSubtypesContaining, foldDataConArgs,
         gen_Foldable_binds,
         gen_Traversable_binds,
+        mkCoerceClassMethEqn,
         gen_Newtype_binds,
         genAuxBinds,
         ordOpTbl, boxConTbl
@@ -68,6 +69,7 @@ import Var
 import MonadUtils
 import Outputable
 import FastString
+import Pair
 import Bag
 import Fingerprint
 import TcEnv (InstInfo)
@@ -1907,44 +1909,58 @@ coercing from.
 See #8503 for more discussion.
 
 \begin{code}
-gen_Newtype_binds :: SrcSpan
-                  -> Class   -- the class being derived
-                  -> [TyVar] -- the tvs in the instance head
-                  -> [Type]  -- instance head parameters (incl. newtype)
-                  -> Type    -- the representation type (already eta-reduced)
-                  -> LHsBinds RdrName
-gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty
-  = listToBag $ map (L loc . mk_bind) $ classMethods cls
+mkCoerceClassMethEqn :: Class   -- the class being derived
+                     -> [TyVar] -- the tvs in the instance head
+                     -> [Type]  -- instance head parameters (incl. newtype)
+                     -> Type    -- the representation type (already eta-reduced)
+                     -> [Pair Type]
+mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty
+  = map mk_tys $ classMethods cls
   where
     cls_tvs = classTyVars cls
     in_scope = mkInScopeSet $ mkVarSet inst_tvs
     lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs cls_tys)
     rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast cls_tys rhs_ty))
 
-    coerce_RDR = getRdrName coerceId
-    
-    mk_bind :: Id -> HsBind RdrName
-    mk_bind id
-      = mkRdrFunBind (L loc meth_RDR)
-                     [mkSimpleMatch [] rhs_expr]
+    mk_tys :: Id -> Pair Type
+    mk_tys id = Pair (substTy rhs_subst user_meth_ty)
+                     (substTy lhs_subst user_meth_ty)
       where
-        meth_RDR = getRdrName id
         (_class_tvs, _class_constraint, user_meth_ty) = tcSplitSigmaTy (varType id)
-        (_quant_tvs, _quant_constraint, tau_meth_ty)  = tcSplitSigmaTy user_meth_ty
-                       
-        rhs_expr
-          = noLoc $ ExprWithTySig
-              (nlHsApp
-                (nlHsVar coerce_RDR)
-                (noLoc $ ExprWithTySig
-                  (nlHsVar meth_RDR)
-                  (toHsType $ substTy rhs_subst tau_meth_ty)))
-              (toHsType $ substTy lhs_subst user_meth_ty)
 
     changeLast :: [a] -> a -> [a]
     changeLast []     _  = panic "changeLast"
     changeLast [_]    x  = [x]
     changeLast (x:xs) x' = x : changeLast xs x'
+
+
+gen_Newtype_binds :: SrcSpan
+                  -> Class   -- the class being derived
+                  -> [TyVar] -- the tvs in the instance head
+                  -> [Type]  -- instance head parameters (incl. newtype)
+                  -> Type    -- the representation type (already eta-reduced)
+                  -> LHsBinds RdrName
+gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty
+  = listToBag $ zipWith mk_bind
+        (classMethods cls)
+        (mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty)
+  where
+    coerce_RDR = getRdrName coerceId
+    mk_bind :: Id -> Pair Type -> LHsBind RdrName
+    mk_bind id (Pair tau_ty user_ty)
+      = L loc $ mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch [] rhs_expr]
+      where
+        meth_RDR = getRdrName id
+        rhs_expr
+          = ( nlHsVar coerce_RDR
+                `nlHsApp`
+              (nlHsVar meth_RDR `nlExprWithTySig` toHsType tau_ty'))
+            `nlExprWithTySig` toHsType user_ty
+        -- Open the representation type here, so that it's forall'ed type
+        -- variables refer to the ones bound in the user_ty
+        (_, _, tau_ty')  = tcSplitSigmaTy tau_ty
+
+    nlExprWithTySig e s = noLoc (ExprWithTySig e s)
 \end{code}
 
 %************************************************************************