[project @ 2001-12-10 01:27:59 by sebc]

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

diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 298d2dd..ee364ac 100644 (file)
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -30,21 +30,21 @@ import RnMonad              ( renameDerivedCode, thenRn, mapRn, returnRn )
 import HscTypes                ( DFunId, PersistentRenamerState )
 
 import BasicTypes      ( Fixity )
-import Class           ( classKey, Class )
+import Class           ( className, classKey, Class )
 import ErrUtils                ( dumpIfSet_dyn, Message )
 import MkId            ( mkDictFunId )
 import DataCon         ( dataConArgTys, isNullaryDataCon, isExistentialDataCon )
 import PrelInfo                ( needsDataDeclCtxtClassKeys )
 import Maybes          ( maybeToBool, catMaybes )
 import Module          ( Module )
-import Name            ( Name, getSrcLoc )
+import Name            ( Name, getSrcLoc, nameUnique )
 import RdrName         ( RdrName )
 
 import TyCon           ( tyConTyVars, tyConDataCons,
                          tyConTheta, maybeTyConSingleCon, isDataTyCon,
                          isEnumerationTyCon, TyCon
                        )
-import Type            ( TauType, ThetaType, PredType, mkTyVarTys, mkTyConApp, 
+import TcType          ( ThetaType, mkTyVarTys, mkTyConApp, 
                          isUnLiftedType, mkClassPred )
 import Var             ( TyVar )
 import PrelNames
@@ -245,11 +245,10 @@ tcDeriving prs mod inst_env_in get_fixity tycl_decls
        -- Make a Real dfun instead of the dummy one we have so far
     gen_inst_info :: DFunId -> RenamedMonoBinds -> InstInfo
     gen_inst_info dfun binds
-      = InstInfo { iDFunId = dfun, 
-                  iBinds = binds, iPrags = [] }
+      = InstInfo { iDFunId = dfun, iBinds = binds, iPrags = [] }
 
-    rn_meths meths = rnMethodBinds [] meths `thenRn` \ (meths', _) -> returnRn meths'
-       -- Ignore the free vars returned
+    rn_meths (cls, meths) = rnMethodBinds cls [] meths `thenRn` \ (meths', _) -> 
+                           returnRn meths'     -- Ignore the free vars returned
 \end{code}
 
 
@@ -320,7 +319,8 @@ makeDerivEqns tycl_decls
                 ]
        in
        case chk_out clas tycon of
-          Just err ->  addErrTc err                            `thenNF_Tc_` 
+          Just err ->  tcAddSrcLoc (getSrcLoc tycon)   $
+                       addErrTc err                    `thenNF_Tc_` 
                        returnNF_Tc Nothing
           Nothing  ->  newDFunName clas [ty] locn `thenNF_Tc` \ dfun_name ->
                        returnNF_Tc (Just (dfun_name, clas, tycon, tyvars, constraints))
@@ -330,18 +330,21 @@ makeDerivEqns tycl_decls
     ------------------------------------------------------------------
     chk_out :: Class -> TyCon -> Maybe Message
     chk_out clas tycon
-       | clas `hasKey` enumClassKey    && not is_enumeration         = bog_out nullary_why
+       | clas `hasKey` enumClassKey    && not is_enumeration           = bog_out nullary_why
        | clas `hasKey` boundedClassKey && not is_enumeration_or_single = bog_out single_nullary_why
        | clas `hasKey` ixClassKey      && not is_enumeration_or_single = bog_out single_nullary_why
-       | any isExistentialDataCon (tyConDataCons tycon)              = Just (existentialErr clas tycon)
-       | otherwise                                                   = Nothing
+       | null data_cons                     = bog_out no_cons_why
+       | any isExistentialDataCon data_cons = Just (existentialErr clas tycon)
+       | otherwise                          = Nothing
        where
+           data_cons = tyConDataCons tycon
            is_enumeration = isEnumerationTyCon tycon
            is_single_con  = maybeToBool (maybeTyConSingleCon tycon)
            is_enumeration_or_single = is_enumeration || is_single_con
 
            single_nullary_why = SLIT("one constructor data type or type with all nullary constructors expected")
            nullary_why        = SLIT("data type with all nullary constructors expected")
+           no_cons_why        = SLIT("type has no data constructors")
 
            bog_out why = Just (derivingThingErr clas tycon why)
 \end{code}
@@ -405,7 +408,8 @@ solveDerivEqns inst_env_in orig_eqns
         in
            -- Simplify each RHS
        tcSetInstEnv inst_env (
-         listTc [ tcAddErrCtxt (derivCtxt tc) $
+         listTc [ tcAddSrcLoc (getSrcLoc tc)   $
+                  tcAddErrCtxt (derivCtxt tc)  $
                   tcSimplifyThetas deriv_rhs
                 | (_, _,tc,_,deriv_rhs) <- orig_eqns ]  
        )                                       `thenTc` \ next_solns ->
@@ -503,24 +507,26 @@ the renamer.  What a great hack!
 
 \begin{code}
 -- Generate the method bindings for the required instance
--- (paired with class name, as we need that when generating dict
---  names.)
-gen_bind :: (Name -> Maybe Fixity) -> DFunId -> RdrNameMonoBinds
+-- (paired with class name, as we need that when renaming
+--  the method binds)
+gen_bind :: (Name -> Maybe Fixity) -> DFunId -> (Name, RdrNameMonoBinds)
 gen_bind get_fixity dfun
-  | clas `hasKey` showClassKey   = gen_Show_binds get_fixity tycon
-  | clas `hasKey` readClassKey   = gen_Read_binds get_fixity tycon
-  | otherwise
-  = assoc "gen_bind:bad derived class"
-          [(eqClassKey,      gen_Eq_binds)
-          ,(ordClassKey,     gen_Ord_binds)
-          ,(enumClassKey,    gen_Enum_binds)
-          ,(boundedClassKey, gen_Bounded_binds)
-          ,(ixClassKey,      gen_Ix_binds)
-          ]
-          (classKey clas)
-          tycon
+  = (cls_nm, binds)
   where
+    cls_nm       = className clas
     (clas, tycon) = simpleDFunClassTyCon dfun
+
+    binds = assoc "gen_bind:bad derived class" gen_list 
+                 (nameUnique cls_nm) tycon
+
+    gen_list = [(eqClassKey,      gen_Eq_binds)
+              ,(ordClassKey,     gen_Ord_binds)
+              ,(enumClassKey,    gen_Enum_binds)
+              ,(boundedClassKey, gen_Bounded_binds)
+              ,(ixClassKey,      gen_Ix_binds)
+              ,(showClassKey,    gen_Show_binds get_fixity)
+              ,(readClassKey,    gen_Read_binds get_fixity)
+              ]
 \end{code}