summaryrefslogtreecommitdiff
path: root/compiler/deSugar/DsBinds.lhs
diff options
context:
space:
mode:
authorRichard Eisenberg <eir@cis.upenn.edu>2013-10-21 13:02:57 -0400
committerRichard Eisenberg <eir@cis.upenn.edu>2013-10-23 09:23:30 -0400
commitff3904d9c97ae5e6d23bc1e961129a76ed283f3f (patch)
treeb78516e2871372e802fdc38a21db63a4471e59e4 /compiler/deSugar/DsBinds.lhs
parent755bdc83bde5ebaf9ae46b960328f8a5cea25a4a (diff)
downloadhaskell-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.lhs13
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