diff options
author | Richard Eisenberg <eir@cis.upenn.edu> | 2013-10-21 13:02:57 -0400 |
---|---|---|
committer | Richard Eisenberg <eir@cis.upenn.edu> | 2013-10-23 09:23:30 -0400 |
commit | ff3904d9c97ae5e6d23bc1e961129a76ed283f3f (patch) | |
tree | b78516e2871372e802fdc38a21db63a4471e59e4 /compiler/deSugar/DsBinds.lhs | |
parent | 755bdc83bde5ebaf9ae46b960328f8a5cea25a4a (diff) | |
download | haskell-ff3904d9c97ae5e6d23bc1e961129a76ed283f3f.tar.gz |
Change GeneralizedNewtypeDeriving safety check.
Now, instead of looking at a class's roles, the GND check looks
at all of the methods in the class individually. This has the
advantage that sometimes, we can use information about the
derivation requested during the safety check. For example,
we can now derive (IArray UArray), whereas the previous check
prevented this.
Diffstat (limited to 'compiler/deSugar/DsBinds.lhs')
-rw-r--r-- | compiler/deSugar/DsBinds.lhs | 13 |
1 files changed, 10 insertions, 3 deletions
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index a33ff9126c..1e828f8a20 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -74,6 +74,8 @@ import Util import Control.Monad( when ) import MonadUtils import Control.Monad(liftM) + +import TcRnMonad (traceIf) -- RAE \end{code} %************************************************************************ @@ -838,15 +840,18 @@ dsTcCoercion :: Role -> TcCoercion -> (Coercion -> CoreExpr) -> DsM CoreExpr -- k (trans g1# g2#) -- thing_inside will get a coercion at the role requested dsTcCoercion role co thing_inside - = do { us <- newUniqueSupply + = do { traceIf $ hang (text "dsTcCoercion {") 2 $ vcat [ppr role, ppr co] -- RAE + ; us <- newUniqueSupply ; let eqvs_covs :: [(EqVar,CoVar)] eqvs_covs = zipWith mk_co_var (varSetElems (coVarsOfTcCo co)) (uniqsFromSupply us) subst = mkCvSubst emptyInScopeSet [(eqv, mkCoVarCo cov) | (eqv, cov) <- eqvs_covs] - result_expr = thing_inside (ds_tc_coercion subst role co) + ds_co = ds_tc_coercion subst role co -- RAE + result_expr = thing_inside ds_co result_ty = exprType result_expr + ; traceIf $ hang (text "dsTcCoercion }") 2 (ppr ds_co) -- RAE ; return (foldr (wrap_in_case result_ty) result_expr eqvs_covs) } where mk_co_var :: Id -> Unique -> (Id, Id) @@ -875,7 +880,9 @@ ds_tc_coercion subst role tc_co go r (TcRefl ty) = Refl r (Coercion.substTy subst ty) go r (TcTyConAppCo tc cos) = mkTyConAppCo r tc (zipWith go (tyConRolesX r tc) cos) - go r (TcAppCo co1 co2) = mkAppCo (go r co1) (go Nominal co2) + go r (TcAppCo co1 co2) = let leftCo = go r co1 + rightRole = nextRole leftCo in + mkAppCoFlexible leftCo rightRole (go rightRole co2) go r (TcForAllCo tv co) = mkForAllCo tv' (ds_tc_coercion subst' r co) where (subst', tv') = Coercion.substTyVarBndr subst tv |