X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FDsBinds.lhs;h=a4d6dda09e6a887b1f38e3f957f163de88ecba03;hb=68afb16743cafd5b7495771d359891c6dfc5a186;hp=c2c23ae2d6e2f68fc5d49005add74be52fa3fbe6;hpb=7b0181919416d8f04324575b7e17031ca692f5b0;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs
index c2c23ae..a4d6dda 100644
--- a/ghc/compiler/deSugar/DsBinds.lhs
+++ b/ghc/compiler/deSugar/DsBinds.lhs
@@ -16,9 +16,12 @@ import Ubiq
 import DsLoop		-- break dsExpr-ish loop
 
 import HsSyn		-- lots of things
+			hiding ( collectBinders{-also in CoreSyn-} )
 import CoreSyn		-- lots of things
 import TcHsSyn		( TypecheckedHsBinds(..), TypecheckedHsExpr(..),
-			  TypecheckedBind(..), TypecheckedMonoBinds(..) )
+			  TypecheckedBind(..), TypecheckedMonoBinds(..),
+			  TypecheckedPat(..)
+			)
 import DsHsSyn		( collectTypedBinders, collectTypedPatBinders )
 
 import DsMonad
@@ -33,14 +36,17 @@ import ListSetOps	( minusList, intersectLists )
 import PprType		( GenType )
 import PprStyle		( PprStyle(..) )
 import Pretty		( ppShow )
-import Type		( mkTyVarTys, splitSigmaTy,
+import Type		( mkTyVarTys, mkForAllTys, splitSigmaTy,
 			  tyVarsOfType, tyVarsOfTypes
 			)
 import TyVar		( tyVarSetToList, GenTyVar{-instance Eq-} )
-import Util		( isIn, panic )
+import Util		( isIn, panic, pprTrace{-ToDo:rm-} )
+import PprCore--ToDo:rm
+import PprType		( GenTyVar ) --ToDo:rm
+import Usage--ToDo:rm
+import Unique--ToDo:rm
 
 isDictTy = panic "DsBinds.isDictTy"
-quantifyTy = panic "DsBinds.quantifyTy"
 \end{code}
 
 %************************************************************************
@@ -154,7 +160,7 @@ dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds)
 	-- local_global_prs.
     private_binders = binders `minusList` [local | (local,_) <- local_global_prs]
     binders	    = collectTypedBinders val_binds
-    mk_poly_private_binder id = newSysLocalDs (snd (quantifyTy tyvars (idType id)))
+    mk_poly_private_binder id = newSysLocalDs (mkForAllTys tyvars (idType id))
 
     tyvar_tys = mkTyVarTys tyvars
 \end{code}
@@ -244,7 +250,7 @@ dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
     non_overloaded_tyvars = all_tyvars `minusList` (tyVarSetToList{-????-} overloaded_tyvars)
 
     binders      = collectTypedBinders val_binds
-    mk_binder id = newSysLocalDs (snd (quantifyTy non_overloaded_tyvars (idType id)))
+    mk_binder id = newSysLocalDs (mkForAllTys non_overloaded_tyvars (idType id))
 \end{code}
 
 @mkSatTyApp id tys@ constructs an expression whose value is (id tys).
@@ -343,8 +349,8 @@ dsInstBinds tyvars ((inst, expr) : bs)
   where
     inst_ty    = idType inst
     abs_tyvars = tyVarSetToList{-???sigh-} (tyVarsOfType inst_ty) `intersectLists` tyvars
-    abs_tys    = mkTyVarTys abs_tyvars
-    (_, poly_inst_ty) = quantifyTy abs_tyvars inst_ty
+    abs_tys      = mkTyVarTys  abs_tyvars
+    poly_inst_ty = mkForAllTys abs_tyvars inst_ty
 
     ------------------------
     -- Wrap a desugared expression in `_scc_ "DICT" <expr>' if
@@ -470,7 +476,7 @@ dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr)
 \end{code}
 
 \begin{code}
-dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun matches locn)
+dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn)
   = putSrcLocDs locn	$
     let
 	new_fun      = binder_subst fun
@@ -541,6 +547,8 @@ dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn)
 	-- we can just use the rhs directly
     else
 -}
+    pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug body_expr) $
+
     mkSelectorBinds tyvars pat
 	[(binder, binder_subst binder) | binder <- pat_binders]
 	body_expr