[project @ 2001-09-07 12:44:30 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index ff99a46..0e37312 100644 (file)
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -43,7 +43,7 @@ import Class          ( classTyVars, classBigSig, classTyCon, className,
                          Class, ClassOpItem, DefMeth (..) )
 import MkId            ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
 import DataCon         ( mkDataCon )
-import Id              ( idType, idName )
+import Id              ( idType, idName, setIdLocalExported )
 import Module          ( Module )
 import Name            ( Name, NamedThing(..) )
 import NameEnv         ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv )
@@ -201,7 +201,8 @@ checkDefaultBinds clas ops (Just mbs)
 tcClassSig :: RecTcEnv                 -- Knot tying only!
           -> Class                     -- ...ditto...
           -> [TyVar]                   -- The class type variable, used for error check only
-          -> Maybe (NameEnv Bool)      -- Info about default methods
+          -> Maybe (NameEnv Bool)      -- Info about default methods; 
+                                       --      Nothing => imported class defn with no method binds
           -> RenamedClassOpSig
           -> TcM (Type,                -- Type of the method
                     ClassOpItem)       -- Selector Id, default-method Id, True if explicit default binding
@@ -261,8 +262,8 @@ checkValidClass cls
     doptsTc Opt_GlasgowExts                            `thenTc` \ gla_exts ->
 
        -- Check that the class is unary, unless GlaExs
-    checkTc (gla_exts || unary)
-           (classArityErr cls)                         `thenTc_`
+    checkTc (arity > 0)                (nullaryClassErr cls)   `thenTc_`
+    checkTc (gla_exts || unary) (classArityErr cls)    `thenTc_`
 
        -- Check the super-classes
     checkValidTheta (ClassSCCtxt (className cls)) theta        `thenTc_`
@@ -277,7 +278,8 @@ checkValidClass cls
 
   where
     (tyvars, theta, sel_ids, op_stuff) = classBigSig cls
-    unary      = length tyvars == 1
+    arity      = length tyvars
+    unary      = arity == 1
     no_generics = null [() | (_, GenDefMeth) <- op_stuff]
 
     check_op (sel_id, dm) 
@@ -422,6 +424,8 @@ tcDefMeth clas tyvars binds_in prags op_item@(_, DefMeth dm_id)
   = tcInstTyVars tyvars                        `thenNF_Tc` \ (clas_tyvars, inst_tys, _) ->
     let
         theta = [(mkClassPred clas inst_tys)]
+       local_dm_id = setIdLocalExported dm_id
+               -- Reason for setIdLocalExported: see notes with MkId.mkDictFunId
     in
     newDicts origin theta              `thenNF_Tc` \ [this_dict] ->
 
@@ -446,7 +450,7 @@ tcDefMeth clas tyvars binds_in prags op_item@(_, DefMeth dm_id)
         full_bind = AbsBinds
                    clas_tyvars'
                    [instToId this_dict]
-                   [(clas_tyvars', dm_id, instToId local_dm_inst)]
+                   [(clas_tyvars', local_dm_id, instToId local_dm_inst)]
                    emptyNameSet        -- No inlines (yet)
                    (dict_binds `andMonoBinds` defm_bind)
     in
@@ -614,8 +618,12 @@ find_prags sel_name meth_name (prag:prags) = find_prags sel_name meth_name prags
 Contexts and errors
 ~~~~~~~~~~~~~~~~~~~
 \begin{code}
+nullaryClassErr cls
+  = ptext SLIT("No parameters for class")  <+> quotes (ppr cls)
+
 classArityErr cls
-  = ptext SLIT("Too many parameters for class") <+> quotes (ppr cls)
+  = vcat [ptext SLIT("Too many parameters for class") <+> quotes (ppr cls),
+         parens (ptext SLIT("Use -fglasgow-exts to allow multi-parameter classes"))]
 
 defltMethCtxt clas
   = ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas)