[commit: ghc] ghc-8.0: Some tiding up in TcGenDeriv (cec5066)
git at git.haskell.org
git at git.haskell.org
Thu Oct 13 15:16:18 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : ghc-8.0
Link : http://ghc.haskell.org/trac/ghc/changeset/cec5066594842f046ae7ded99ebbc31f4cdb86b0/ghc
>---------------------------------------------------------------
commit cec5066594842f046ae7ded99ebbc31f4cdb86b0
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Mon Feb 8 15:29:12 2016 +0000
Some tiding up in TcGenDeriv
..around newtype deriving instances.
See esp the new Note [Newtype-deriving instances]
No change in behaviour
(cherry picked from commit 96d451450923a80b043b5314c5eaaa9d0eab7c56)
>---------------------------------------------------------------
cec5066594842f046ae7ded99ebbc31f4cdb86b0
compiler/typecheck/TcGenDeriv.hs | 103 ++++++++++++++++++++++++++-------------
compiler/typecheck/TcType.hs | 20 ++++++++
2 files changed, 90 insertions(+), 33 deletions(-)
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 8c6bc81..139fdae 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -2137,65 +2137,102 @@ mk_appE_app a b = nlHsApps appE_RDR [a, b]
* *
************************************************************************
+Note [Newtype-deriving instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We take every method in the original instance and `coerce` it to fit
into the derived instance. We need a type annotation on the argument
to `coerce` to make it obvious what instantiation of the method we're
-coercing from.
+coercing from. So from, say,
+ class C a b where
+ op :: a -> [b] -> Int
+
+ newtype T x = MkT <rep-ty>
+
+ instance C a <rep-ty> => C a (T x) where
+ op = (coerce
+ (op :: a -> [<rep-ty>] -> Int)
+ ) :: a -> [T x] -> Int
+
+Notice that we give the 'coerce' call two type signatures: one to
+fix the of the inner call, and one for the expected type. The outer
+type signature ought to be redundant, but may improve error messages.
+The inner one is essential to fix the type at which 'op' is called.
See #8503 for more discussion.
+
+Here's a wrinkle. Supppose 'op' is locally overloaded:
+
+ class C2 b where
+ op2 :: forall a. Eq a => a -> [b] -> Int
+
+Then we could do exactly as above, but it's a bit redundant to
+instantiate op, then re-generalise with the inner signature.
+(The inner sig is only there to fix the type at which 'op' is
+called.) So we just instantiate the signature, and add
+
+ instance C2 <rep-ty> => C2 (T x) where
+ op2 = (coerce
+ (op2 :: a -> [<rep-ty>] -> Int)
+ ) :: forall a. Eq a => a -> [T x] -> Int
-}
+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
+-- See Note [Newtype-deriving instances]
+gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty
+ = listToBag $ map mk_bind (classMethods cls)
+ where
+ coerce_RDR = getRdrName coerceId
+
+ mk_bind :: Id -> LHsBind RdrName
+ mk_bind meth_id
+ = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch [] rhs_expr]
+ where
+ Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty meth_id
+
+ -- See "wrinkle" in Note [Newtype-deriving instances]
+ (_, _, from_ty') = tcSplitSigmaTy from_ty
+
+ meth_RDR = getRdrName meth_id
+
+ rhs_expr = ( nlHsVar coerce_RDR
+ `nlHsApp`
+ (nlHsVar meth_RDR `nlExprWithTySig` toLHsSigWcType from_ty'))
+ `nlExprWithTySig` toLHsSigWcType to_ty
+
+
+ nlExprWithTySig :: LHsExpr RdrName -> LHsSigWcType RdrName -> LHsExpr RdrName
+ nlExprWithTySig e s = noLoc (ExprWithTySig e s)
+
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)
-> Id -- the method to look at
-> Pair Type
+-- See Note [Newtype-deriving instances]
+-- The pair is the (from_type, to_type), where to_type is
+-- the type of the method we are tyrying to get
mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty id
- = Pair (substTy rhs_subst user_meth_ty) (substTy lhs_subst user_meth_ty)
+ = Pair (substTy rhs_subst user_meth_ty)
+ (substTy lhs_subst user_meth_ty)
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))
(_class_tvs, _class_constraint, user_meth_ty)
- = tcSplitSigmaTy (varType id)
+ = tcSplitMethodTy (varType id)
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)
- (map (mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty) (classMethods cls))
- where
- coerce_RDR = getRdrName coerceId
- mk_bind :: Id -> Pair Type -> LHsBind RdrName
- mk_bind id (Pair tau_ty user_ty)
- = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch [] rhs_expr]
- where
- meth_RDR = getRdrName id
- rhs_expr
- = ( nlHsVar coerce_RDR
- `nlHsApp`
- (nlHsVar meth_RDR `nlExprWithTySig` toLHsSigWcType tau_ty'))
- `nlExprWithTySig` toLHsSigWcType 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 :: LHsExpr RdrName -> LHsSigWcType RdrName -> LHsExpr RdrName
-nlExprWithTySig e s = noLoc (ExprWithTySig e s)
-
{-
************************************************************************
* *
diff --git a/compiler/typecheck/TcType.hs b/compiler/typecheck/TcType.hs
index d26dc5f..e5037d1 100644
--- a/compiler/typecheck/TcType.hs
+++ b/compiler/typecheck/TcType.hs
@@ -23,6 +23,7 @@ module TcType (
TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType,
TcTyVar, TcTyVarSet, TcDTyVarSet, TcTyCoVarSet, TcDTyCoVarSet,
TcKind, TcCoVar, TcTyCoVar, TcTyBinder, TcTyCon,
+ tcSplitMethodTy,
ExpType(..), ExpSigmaType, ExpRhoType, mkCheckExpType,
@@ -1397,6 +1398,25 @@ tcSplitDFunTy ty
tcSplitDFunHead :: Type -> (Class, [Type])
tcSplitDFunHead = getClassPredTys
+tcSplitMethodTy :: Type -> ([TyVar], PredType, Type)
+-- A class method (selector) always has a type like
+-- forall as. C as => blah
+-- So if the class looks like
+-- class C a where
+-- op :: forall b. (Eq a, Ix b) => a -> b
+-- the class method type looks like
+-- op :: forall a. C a => forall b. (Eq a, Ix b) => a -> b
+--
+-- tcSplitMethodTy just peels off the outer forall and
+-- that first predicate
+tcSplitMethodTy ty
+ | (sel_tyvars,sel_rho) <- tcSplitForAllTys ty
+ , Just (first_pred, local_meth_ty) <- tcSplitPredFunTy_maybe sel_rho
+ = (sel_tyvars, first_pred, local_meth_ty)
+ | otherwise
+ = pprPanic "tcSplitMethodTy" (ppr ty)
+
+-----------------------
tcEqKind :: TcKind -> TcKind -> Bool
tcEqKind = tcEqType
More information about the ghc-commits
mailing list