[commit: ghc] master: With GND, report Coercible errors earliy (bd7a125)
git at git.haskell.org
git at git.haskell.org
Mon Dec 2 11:12:05 UTC 2013
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/bd7a125b74e9e958bc88a450e9a4e5d1af3dc801/ghc
>---------------------------------------------------------------
commit bd7a125b74e9e958bc88a450e9a4e5d1af3dc801
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Mon Dec 2 09:45:12 2013 +0000
With GND, report Coercible errors earliy
just like other type errors occurring during deriving.
>---------------------------------------------------------------
bd7a125b74e9e958bc88a450e9a4e5d1af3dc801
compiler/typecheck/TcDeriv.lhs | 16 +++++++--
compiler/typecheck/TcGenDeriv.lhs | 66 +++++++++++++++++++++++--------------
2 files changed, 54 insertions(+), 28 deletions(-)
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 76a9011..9ce4f92 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -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
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index d4af39f..f2e5413 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -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}
%************************************************************************
More information about the ghc-commits
mailing list