Make mkDFunUnfolding more robust

It now uses tcSplitDFunTy, which is designed for the purpose and
allows arbitrary argument types to the dfun, rather than
tcSplitSigmaTy.  This generality is used in DPH, which has
internally-generated dfuns with impliciation-typed arguments.

To do this I had to make tcSplitDFunTy return the number of
arguments, so there are some minor knock-on effects in other
modules.

diff --git a/compiler/coreSyn/CoreUnfold.lhs b/compiler/coreSyn/CoreUnfold.lhs
index dfbb322..06a2d72 100644 (file)
--- a/compiler/coreSyn/CoreUnfold.lhs
+++ b/compiler/coreSyn/CoreUnfold.lhs
@@ -41,8 +41,8 @@ import StaticFlags
 import DynFlags
 import CoreSyn
 import PprCore         ()      -- Instances
-import TcType          ( tcSplitSigmaTy, tcSplitDFunHead )
-import OccurAnal
+import TcType           ( tcSplitDFunTy )
+import OccurAnal        ( occurAnalyseExpr )
 import CoreSubst hiding( substTy )
 import CoreFVs         ( exprFreeVars )
 import CoreArity       ( manifestArity, exprBotStrictness_maybe )
@@ -54,8 +54,7 @@ import Literal
 import PrimOp
 import IdInfo
 import BasicTypes      ( Arity )
-import TcType          ( tcSplitDFunTy )
-import Type 
+import Type
 import Coercion
 import PrelNames
 import VarEnv           ( mkInScopeSet )
@@ -95,11 +94,8 @@ mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding
 mkDFunUnfolding dfun_ty ops 
   = DFunUnfolding dfun_nargs data_con ops
   where
-    (tvs, theta, head_ty) = tcSplitSigmaTy dfun_ty
-         -- NB: tcSplitSigmaTy: do not look through a newtype
-         --     when the dictionary type is a newtype
-    (cls, _)   = tcSplitDFunHead head_ty
-    dfun_nargs = length tvs + length theta
+    (tvs, n_theta, cls, _) = tcSplitDFunTy dfun_ty
+    dfun_nargs = length tvs + n_theta
     data_con   = classDataCon cls
 
 mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding
@@ -1285,7 +1281,7 @@ exprIsConApp_maybe id_unf expr
         , let sat = length args == dfun_nargs    -- See Note [DFun arity check]
           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)
+        , let (dfun_tvs, _n_theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
               subst    = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
               mk_arg (DFunConstArg e) = e
               mk_arg (DFunLamArg i)   = args !! i

diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index f8d66d5..c0d49a3 100644 (file)
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1428,7 +1428,7 @@ instanceToIfaceInst (Instance { is_dfun = dfun_id, is_flag = oflag,
     is_local name = nameIsLocalOrFrom mod name
 
        -- Compute orphanhood.  See Note [Orphans] in IfaceSyn
-    (_, cls, tys) = tcSplitDFunTy (idType dfun_id)
+    (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id)
                -- Slightly awkward: we need the Class to get the fundeps
     (tvs, fds) = classTvsFds cls
     arg_names = [filterNameSet is_local (tyClsNamesOfType ty) | ty <- tys]

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index c880a8a..8dccc72 100644 (file)
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -989,7 +989,7 @@ tcIdDetails _  IfVanillaId = return VanillaId
 tcIdDetails ty (IfDFunId ns)
   = return (DFunId ns (isNewTyCon (classTyCon cls)))
   where
-    (_, cls, _) = tcSplitDFunTy ty
+    (_, _, cls, _) = tcSplitDFunTy ty
 
 tcIdDetails _ (IfRecSelId tc naughty)
   = do { tc' <- tcIfaceTyCon tc

diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index f4e338d..f84f3d5 100644 (file)
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -1249,7 +1249,7 @@ instDeclCtxt2 :: Type -> SDoc
 instDeclCtxt2 dfun_ty
   = inst_decl_ctxt (ppr (mkClassPred cls tys))
   where
-    (_,cls,tys) = tcSplitDFunTy dfun_ty
+    (_,_,cls,tys) = tcSplitDFunTy dfun_ty
 
 inst_decl_ctxt :: SDoc -> SDoc
 inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 50ac35a..c68c10f 100644 (file)
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -919,23 +919,24 @@ tcIsTyVarTy :: Type -> Bool
 tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty)
 
 -----------------------
-tcSplitDFunTy :: Type -> ([TyVar], Class, [Type])
+tcSplitDFunTy :: Type -> ([TyVar], Int, Class, [Type])
 -- Split the type of a dictionary function
 -- We don't use tcSplitSigmaTy,  because a DFun may (with NDP)
 -- have non-Pred arguments, such as
 --     df :: forall m. (forall b. Eq b => Eq (m b)) -> C m
 tcSplitDFunTy ty 
-  = case tcSplitForAllTys ty                 of { (tvs, rho)  ->
-    case tcSplitDFunHead (drop_pred_tys rho) of { (clas, tys) -> 
-    (tvs, clas, tys) }}
+  = case tcSplitForAllTys ty   of { (tvs, rho)  ->
+    case split_dfun_args 0 rho of { (n_theta, tau) ->
+    case tcSplitDFunHead tau   of { (clas, tys) ->
+    (tvs, n_theta, clas, tys) }}}
   where
-    -- Discard the context of the dfun.  This can be a mix of
+    -- Count the context of the dfun.  This can be a mix of
     -- coercion and class constraints; or (in the general NDP case)
     -- some other function argument
-    drop_pred_tys ty | Just ty' <- tcView ty = drop_pred_tys ty'
-    drop_pred_tys (ForAllTy tv ty) = ASSERT( isCoVar tv ) drop_pred_tys ty
-    drop_pred_tys (FunTy _ ty)     = drop_pred_tys ty
-    drop_pred_tys ty               = ty
+    split_dfun_args n ty | Just ty' <- tcView ty = split_dfun_args n ty'
+    split_dfun_args n (ForAllTy tv ty) = ASSERT( isCoVar tv ) split_dfun_args (n+1) ty
+    split_dfun_args n (FunTy _ ty)     = split_dfun_args (n+1) ty
+    split_dfun_args n ty               = (n, ty)
 
 tcSplitDFunHead :: Type -> (Class, [Type])
 tcSplitDFunHead tau  

diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs
index 34bd5eb..753b04a 100644 (file)
--- a/compiler/types/InstEnv.lhs
+++ b/compiler/types/InstEnv.lhs
@@ -128,7 +128,7 @@ setInstanceDFunId ispec dfun
        -- are ok; hence the assert
      ispec { is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys }
    where 
-     (tvs, _, tys) = tcSplitDFunTy (idType dfun)
+     (tvs, _, _, tys) = tcSplitDFunTy (idType dfun)
 
 instanceRoughTcs :: Instance -> [Maybe Name]
 instanceRoughTcs = is_tcs
@@ -184,7 +184,7 @@ mkLocalInstance dfun oflag
                is_tvs = mkVarSet tvs, is_tys = tys,
                 is_cls = className cls, is_tcs = roughMatchTcs tys }
   where
-    (tvs, cls, tys) = tcSplitDFunTy (idType dfun)
+    (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
 
 mkImportedInstance :: Name -> [Maybe Name]
                   -> DFunId -> OverlapFlag -> Instance
@@ -195,7 +195,7 @@ mkImportedInstance cls mb_tcs dfun oflag
                is_tvs = mkVarSet tvs, is_tys = tys,
                is_cls = cls, is_tcs = mb_tcs }
   where
-    (tvs, _, tys) = tcSplitDFunTy (idType dfun)
+    (tvs, _, _, tys) = tcSplitDFunTy (idType dfun)
 
 roughMatchTcs :: [Type] -> [Maybe Name]
 roughMatchTcs tys = map rough tys