Fix recursive superclasses (again). Fixes Trac #4809.

[ghc-hetmet.git] / compiler / coreSyn / CoreUnfold.lhs

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index 5a00869..519fb74 100644 (file)
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -91,7 +91,7 @@ mkImplicitUnfolding expr = mkTopUnfolding False (simpleOptExpr expr)
 mkSimpleUnfolding :: CoreExpr -> Unfolding
 mkSimpleUnfolding = mkUnfolding InlineRhs False False
 
-mkDFunUnfolding :: Type -> [CoreExpr] -> Unfolding
+mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding
 mkDFunUnfolding dfun_ty ops 
   = DFunUnfolding dfun_nargs data_con ops
   where
@@ -1270,9 +1270,11 @@ exprIsConApp_maybe id_unf expr
           in if sat then True else 
              pprTrace "Unsaturated dfun" (ppr fun <+> int dfun_nargs $$ ppr args) False   
         , let (dfun_tvs, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
-             subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
-        = Just (con, substTys subst dfun_res_tys, 
-                     [mkApps op args | op <- ops])
+              subst    = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
+              mk_arg (DFunConstArg e) = e
+              mk_arg (DFunLamArg i)   = args !! i
+              mk_arg (DFunPolyArg e)  = mkApps e args
+        = Just (con, substTys subst dfun_res_tys, map mk_arg ops)
 
        -- Look through unfoldings, but only cheap ones, because
        -- we are effectively duplicating the unfolding