[project @ 2003-11-03 10:11:04 by simonmar]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcClassDcl.lhs

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 5e515b6..3971330 100644 (file)
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -12,10 +12,10 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2,
 
 #include "HsVersions.h"
 
-import HsSyn           ( TyClDecl(..), Sig(..), MonoBinds(..), HsType(..),
+import HsSyn           ( TyClDecl(..), Sig(..), MonoBinds(..), HsType(..), 
                          HsExpr(..), HsLit(..), Pat(WildPat), HsTyVarBndr(..),
                          mkSimpleMatch, andMonoBinds, andMonoBindList, 
-                         isPragSig, placeHolderType, mkHsForAllTy
+                         isPragSig, placeHolderType, mkExplicitHsForAllTy
                        )
 import BasicTypes      ( RecFlag(..), NewOrData(..) )
 import RnHsSyn         ( RenamedTyClDecl, RenamedSig,
@@ -28,7 +28,8 @@ import TcHsSyn                ( TcMonoBinds )
 
 import Inst            ( Inst, InstOrigin(..), instToId, newDicts, newMethod )
 import TcEnv           ( tcLookupClass, tcExtendLocalValEnv2, tcExtendTyVarEnv2,
-                         InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy,
+                         InstInfo(..), pprInstInfoDetails,
+                         simpleInstInfoTyCon, simpleInstInfoTy,
                          InstBindings(..), newDFunName
                        )
 import TcBinds         ( tcMonoBinds, tcSpecSigs )
@@ -534,29 +535,28 @@ mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
     wild_pats   = [WildPat placeHolderType | ty <- arg_tys]
 
 mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth 
-  =    -- A generic default method
-       -- If the method is defined generically, we can only do the job if the
+  =    -- A generic default method
+       -- If the method is defined generically, we can only do the job if the
        -- instance declaration is for a single-parameter type class with
        -- a type constructor applied to type arguments in the instance decl
        --      (checkTc, so False provokes the error)
-     ASSERT( isInstDecl origin )       -- We never get here from a class decl
-
-     checkTc (isJust maybe_tycon)
-            (badGenericInstance sel_id (notSimple inst_tys))           `thenM_`
-     checkTc (tyConHasGenerics tycon)
-            (badGenericInstance sel_id (notGeneric tycon))             `thenM_`
-
-     ioToTcRn (dumpIfSet opt_PprStyle_Debug "Generic RHS" stuff)       `thenM_`
-
-       -- Rename it before returning it
-     rnExpr rhs                        `thenM` \ (rn_rhs, _) ->
-     returnM rn_rhs
+    ASSERT( isInstDecl origin )        -- We never get here from a class decl
+    do { checkTc (isJust maybe_tycon)
+                 (badGenericInstance sel_id (notSimple inst_tys))
+       ; checkTc (tyConHasGenerics tycon)
+                 (badGenericInstance sel_id (notGeneric tycon))
+
+       ; dflags <- getDOpts
+       ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body" 
+                  (vcat [ppr clas <+> ppr inst_tys,
+                         nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
+
+               -- Rename it before returning it
+       ; (rn_rhs, _) <- rnExpr rhs
+       ; returnM rn_rhs }
   where
     rhs = mkGenericRhs sel_id clas_tyvar tycon
 
-    stuff = vcat [ppr clas <+> ppr inst_tys,
-                 nest 4 (ppr sel_id <+> equals <+> ppr rhs)]
-
          -- The tycon is only used in the generic case, and in that
          -- case we require that the instance decl is for a single-parameter
          -- type class with type variable arguments:
@@ -628,7 +628,7 @@ getGenericInstances class_decls
        -- Otherwise print it out
        { dflags <- getDOpts
        ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances" 
-                  (vcat (map pprInstInfo gen_inst_info)))      
+                  (vcat (map pprInstInfoDetails gen_inst_info)))       
        ; returnM gen_inst_info }}
 
 get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = def_methods, tcdLoc = loc})
@@ -669,7 +669,6 @@ get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = def_methods, tcdL
     checkTc (null missing) (missingGenericInstances missing)   `thenM_`
 
     returnM inst_infos
-
   where
     generic_binds :: [(HsType Name, RenamedMonoBinds)]
     generic_binds = getGenericBinds def_methods
@@ -699,8 +698,12 @@ groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
 eqPatType :: HsType Name -> HsType Name -> Bool
 -- A very simple equality function, only for 
 -- type patterns in generic function definitions.
-eqPatType (HsTyVar v1)    (HsTyVar v2)    = v1==v2
-eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatType` s2 && t2 `eqPatType` t2
+eqPatType (HsTyVar v1)       (HsTyVar v2)      = v1==v2
+eqPatType (HsAppTy s1 t1)    (HsAppTy s2 t2)   = s1 `eqPatType` s2 && t2 `eqPatType` t2
+eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatType` s2 && t2 `eqPatType` t2 && op1 == op2
+eqPatType (HsNumTy n1)      (HsNumTy n2)       = n1 == n2
+eqPatType (HsParTy t1)      t2                 = t1 `eqPatType` t2
+eqPatType t1                (HsParTy t2)       = t1 `eqPatType` t2
 eqPatType _ _ = False
 
 ---------------------------------
@@ -717,7 +720,7 @@ mkGenericInstance clas loc (hs_ty, binds)
        -- works in the standard way
     let
        sig_tvs = map UserTyVar (nameSetToList (extractHsTyVars hs_ty))
-       hs_forall_ty = mkHsForAllTy (Just sig_tvs) [] hs_ty
+       hs_forall_ty = mkExplicitHsForAllTy sig_tvs [] hs_ty
     in
        -- Type-check the instance type, and check its form
     tcHsSigType GenPatCtxt hs_forall_ty                `thenM` \ forall_inst_ty ->
@@ -798,7 +801,7 @@ dupGenericInsts tc_inst_infos
          ptext SLIT("All the type patterns for a generic type constructor must be identical")
     ]
   where 
-    ppr_inst_ty (tc,inst) = ppr (simpleInstInfoTy inst)
+    ppr_inst_ty (tc,inst) = ppr tc <+> ppr (simpleInstInfoTy inst)
 
 mixedGenericErr op
   = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)