some bug-fixes, newtype deriving might work now

Mon Sep 18 14:33:01 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * some bug-fixes, newtype deriving might work now
  Sat Aug  5 21:29:28 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * some bug-fixes, newtype deriving might work now
    Tue Jul 11 12:16:13 EDT 2006  kevind@bu.edu

8 files changed, 52 insertions, 26 deletions

diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 788c4b4bb6..2d5a4fd391 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -396,12 +396,13 @@ lintCoreArg fun_ty a@(Type arg_ty) =
 lintCoreArg fun_ty arg = 
        -- Make sure function type matches argument
   do { arg_ty <- lintCoreExpr arg
-     ; let err = mkAppMsg fun_ty arg_ty arg
+     ; let err1 =  mkAppMsg fun_ty arg_ty arg
+           err2 = mkNonFunAppMsg fun_ty arg_ty arg
      ; case splitFunTy_maybe fun_ty of
         Just (arg,res) -> 
-          do { checkTys arg arg_ty err 
+          do { checkTys arg arg_ty err1
              ; return res }
-        _ -> addErrL err }
+        _ -> addErrL err2 }
 \end{code}
 
 \begin{code}
@@ -819,6 +820,13 @@ mkAppMsg fun_ty arg_ty arg
 	      hang (ptext SLIT("Arg type:")) 4 (ppr arg_ty),
 	      hang (ptext SLIT("Arg:")) 4 (ppr arg)]
 
+mkNonFunAppMsg :: Type -> Type -> CoreExpr -> Message
+mkNonFunAppMsg fun_ty arg_ty arg
+  = vcat [ptext SLIT("Non-function type in function position"),
+	      hang (ptext SLIT("Fun type:")) 4 (ppr fun_ty),
+	      hang (ptext SLIT("Arg type:")) 4 (ppr arg_ty),
+	      hang (ptext SLIT("Arg:")) 4 (ppr arg)]
+
 mkKindErrMsg :: TyVar -> Type -> Message
 mkKindErrMsg tyvar arg_ty
   = vcat [ptext SLIT("Kinds don't match in type application:"),
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index dbe29376bf..25ecbb1138 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -608,7 +608,7 @@ We know the list must have at least one @Match@ in it.
 
 \begin{code}
 pprMatches :: (OutputableBndr id) => HsMatchContext id -> MatchGroup id -> SDoc
-pprMatches ctxt (MatchGroup matches _) = vcat (map (pprMatch ctxt) (map unLoc matches))
+pprMatches ctxt (MatchGroup matches ty) = (ppr ty) $$ vcat (map (pprMatch ctxt) (map unLoc matches))
 
 -- Exported to HsBinds, which can't see the defn of HsMatchContext
 pprFunBind :: (OutputableBndr id) => id -> MatchGroup id -> SDoc
diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index ad580289c5..9eda9073dd 100644
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -138,7 +138,7 @@ mkNewTyConRep tc rhs_ty
                     if isRecursiveTyCon tc then
 			go (tc:tcs) (substTyWith tvs tys rhs_ty)
                     else
-                        go tcs (head tys)
+                        substTyWith tvs tys rhs_ty
 		where
 		  (tvs, rhs_ty) = newTyConRhs tc
 
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 857999b95b..550b274ec5 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -465,7 +465,7 @@ makeDerivEqns overlap_flag tycl_decls
 		-- If there are no tyvars, there's no need
 		-- to abstract over the dictionaries we need
 	dict_tvs = deriv_tvs ++ tc_tvs
-	dict_args | null dict_tvs = []
+	dict_args -- | null dict_tvs = []
 		  | otherwise     = rep_pred : sc_theta
 
 		-- Finally! Here's where we build the dictionary Id
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 7b1c132951..1bb1bb7671 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -15,7 +15,7 @@ import TcClassDcl	( tcMethodBind, mkMethodBind, badMethodErr,
 import TcRnMonad       
 import TcMType		( tcSkolSigType, checkValidInstance, checkValidInstHead )
 import TcType		( mkClassPred, tcSplitSigmaTy, tcSplitDFunHead, mkTyVarTys,
-                          SkolemInfo(InstSkol), tcSplitDFunTy )
+                          SkolemInfo(InstSkol), tcSplitDFunTy, mkFunTy )
 import Inst		( tcInstClassOp, newDicts, instToId, showLIE, 
 			  getOverlapFlag, tcExtendLocalInstEnv )
 import InstEnv		( mkLocalInstance, instanceDFunId )
@@ -29,11 +29,11 @@ import TcSimplify	( tcSimplifyCheck, tcSimplifySuperClasses )
 import Type		( zipOpenTvSubst, substTheta, substTys, mkTyConApp, mkTyVarTy )
 import Coercion         ( mkAppCoercion, mkAppsCoercion )
 import TyCon            ( TyCon, newTyConCo )
-import DataCon		( classDataCon, dataConTyCon )
-import Class		( classBigSig )
+import DataCon		( classDataCon, dataConTyCon, dataConInstArgTys )
+import Class		( classBigSig, classMethods )
 import Var		( TyVar, Id, idName, idType )
 import Id               ( mkSysLocal )
-import UniqSupply       ( uniqsFromSupply )
+import UniqSupply       ( uniqsFromSupply, splitUniqSupply )
 import MkId		( mkDictFunId )
 import Name		( Name, getSrcLoc )
 import Maybe		( catMaybes )
@@ -337,9 +337,9 @@ tcInstDecl2 (InstInfo { iSpec = ispec,
               maybe_co_con = newTyConCo tycon
 	; (tvs, theta, inst_head) <- tcSkolSigType rigid_info inst_ty
 	; dicts <- newDicts origin theta
-	; uniqs <- newUniqueSupply
-        ; let (cls, op_tys) = tcSplitDFunHead inst_head
-        ; [this_dict] <- newDicts origin [mkClassPred cls op_tys]
+        ; uniqs <- newUniqueSupply
+        ; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head
+        ; [this_dict] <- newDicts origin [mkClassPred cls rep_tys]
         ; let (rep_dict_id:sc_dict_ids) =
                  if null dicts then
                      [instToId this_dict]
@@ -349,32 +349,48 @@ tcInstDecl2 (InstInfo { iSpec = ispec,
 		-- (Here, we are relying on the order of dictionary 
 		-- arguments built by NewTypeDerived in TcDeriv.)
 
-              wrap_fn | null dicts = idCoercion
-                      | otherwise  = CoTyLams tvs <.> CoLams sc_dict_ids
+              wrap_fn = CoTyLams tvs <.> CoLams (rep_dict_id:sc_dict_ids)
 	 
               coerced_rep_dict = mkHsCoerce (co_fn tvs cls_tycon) (HsVar rep_dict_id)
 
-	      body | null dicts || null sc_dict_ids = coerced_rep_dict
+	      body | null sc_dict_ids = coerced_rep_dict
 		   | otherwise = HsCase (noLoc coerced_rep_dict) $
-				 MatchGroup [the_match] inst_head
-	      the_match = mkSimpleMatch [the_pat] the_rhs
+				 MatchGroup [the_match] (mkFunTy in_dict_ty inst_head)
+	      in_dict_ty = mkTyConApp cls_tycon cls_inst_tys
+
+              the_match = mkSimpleMatch [the_pat] the_rhs
+
+	      (uniqs1, uniqs2) = splitUniqSupply uniqs
+
 	      op_ids = zipWith (mkSysLocal FSLIT("op"))
-                        	      (uniqsFromSupply uniqs) op_tys
-	      the_pat = noLoc $ ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
-				    pat_dicts = sc_dict_ids,
+                        	      (uniqsFromSupply uniqs1) op_tys
+
+              dict_ids = zipWith (mkSysLocal FSLIT("dict"))
+                          (uniqsFromSupply uniqs2) (map idType sc_dict_ids)
+
+	      the_pat = noLoc $
+                        ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
+				    pat_dicts = dict_ids,
 				    pat_binds = emptyLHsBinds,
 				    pat_args = PrefixCon (map nlVarPat op_ids),
-				    pat_ty = inst_head }
+				    pat_ty = in_dict_ty} 
+
               cls_data_con = classDataCon cls
               cls_tycon = dataConTyCon cls_data_con
+              cls_arg_tys = dataConInstArgTys cls_data_con cls_inst_tys 
+              
+              n_dict_args = if length dicts == 0 then 0 else length dicts - 1
+              op_tys = drop n_dict_args cls_arg_tys
               
-	      the_rhs = mkHsConApp (cls_data_con) (mkTyVarTys tvs) (map HsVar (sc_dict_ids ++ op_ids))
+	      the_rhs = mkHsConApp cls_data_con cls_inst_tys (map HsVar (sc_dict_ids ++ op_ids))
               dict = (mkHsCoerce wrap_fn body)
-        ; pprTrace "built dict:" (ppr dict) $ return (unitBag (noLoc $ VarBind (dfun_id) (noLoc dict))) }
+        ; return (unitBag (noLoc $ VarBind (dfun_id) (noLoc dict))) }
   where
     co_fn :: [TyVar] -> TyCon -> ExprCoFn
     co_fn tvs cls_tycon | Just co_con <- newTyConCo tycon
-	  = ExprCoFn (mkAppCoercion (mkTyConApp cls_tycon []) 
+	  = ExprCoFn (mkAppCoercion -- (mkAppsCoercion 
+                                     (mkTyConApp cls_tycon []) 
+                                     -- rep_tys)
                        		    (mkTyConApp co_con (map mkTyVarTy tvs)))
 	  | otherwise
 	  = idCoercion
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 4542a34a0a..23c3381581 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -107,6 +107,7 @@ import Outputable
 
 import Control.Monad	( when )
 import Data.List	( (\\) )
+
 \end{code}
 
 
diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 8f062704aa..c0bb23bc47 100644
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -2533,7 +2533,7 @@ monomorphism_fix = ptext SLIT("Probable fix:") <+>
     
 warnDefault dicts default_ty
   = doptM Opt_WarnTypeDefaults  `thenM` \ warn_flag ->
-    addInstCtxt (instLoc (head dicts)) (warnTc warn_flag warn_msg)
+    addInstCtxt (instLoc (head (dicts))) (warnTc warn_flag warn_msg)
   where
 	-- Tidy them first
     (_, tidy_dicts) = tidyInsts dicts
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index 52262ec02e..30960dc817 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -76,6 +76,7 @@ import Char             ( ord )
 %************************************************************************
 
 \begin{code}
+
 data PprStyle
   = PprUser PrintUnqualified Depth
 		-- Pretty-print in a way that will make sense to the