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

diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 788c4b4..2d5a4fd 100644 (file)
--- 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 dbe2937..25ecbb1 100644 (file)
--- 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 ad58028..9eda907 100644 (file)
--- 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 857999b..550b274 100644 (file)
--- 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 7b1c132..1bb1bb7 100644 (file)
--- 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 4542a34..23c3381 100644 (file)
--- 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 8f06270..c0bb23b 100644 (file)
--- 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 52262ec..30960dc 100644 (file)
--- 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