Commit bd7a125b authored by Joachim Breitner's avatar Joachim Breitner

With GND, report Coercible errors earliy

just like other type errors occurring during deriving.
parent 5e86ea50
......@@ -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
......
......@@ -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}
%************************************************************************
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment