[project @ 2003-11-05 14:51:53 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 911da5c..1d23c7b 100644 (file)
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -16,10 +16,10 @@ import RdrHsSyn             ( RdrNameMonoBinds )
 import RnHsSyn         ( RenamedHsBinds, RenamedTyClDecl, RenamedHsPred )
 import CmdLineOpts     ( DynFlag(..) )
 
-import Generics                ( mkGenericBinds )
+import Generics                ( mkTyConGenericBinds )
 import TcRnMonad
 import TcEnv           ( newDFunName, 
-                         InstInfo(..), pprInstInfo, InstBindings(..),
+                         InstInfo(..), InstBindings(..),
                          pprInstInfoDetails, tcLookupTyCon, tcExtendTyVarEnv
                        )
 import TcGenDeriv      -- Deriv stuff
@@ -43,7 +43,7 @@ import Name           ( Name, getSrcLoc )
 import NameSet         ( NameSet, emptyNameSet, duDefs )
 import Unique          ( Unique, getUnique )
 
-import TyCon           ( tyConTyVars, tyConDataCons, tyConArity, 
+import TyCon           ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics,
                          tyConTheta, isProductTyCon, isDataTyCon,
                          isEnumerationTyCon, isRecursiveTyCon, TyCon
                        )
@@ -211,13 +211,14 @@ tcDeriving tycl_decls
                -- before tacking the "ordinary" ones
 
        -- Generate the generic to/from functions from each type declaration
-       ; tcg_env <- getGblEnv
-       ; let gen_binds = mkGenericBinds (typeEnvTyCons (tcg_type_env tcg_env))
+       ; gen_binds <- mkGenericBinds tycl_decls
        ; let inst_info  = newtype_inst_info ++ ordinary_inst_info
 
        -- Rename these extra bindings, discarding warnings about unused bindings etc
+       -- Set -fglasgow exts so that we can have type signatures in patterns,
+       -- which is used in the generic binds
        ; (rn_binds, gen_bndrs) 
-               <- discardWarnings $ do
+               <- discardWarnings $ setOptM Opt_GlasgowExts $ do
                        { (rn_deriv, _dus1) <- rnTopMonoBinds deriv_binds []
                        ; (rn_gen, dus_gen) <- rnTopMonoBinds gen_binds   []
                        ; return (rn_deriv `ThenBinds` rn_gen, duDefs dus_gen) }
@@ -254,6 +255,13 @@ deriveOrdinaryStuff eqns
 
        -- Done
        ; returnM (inst_infos, andMonoBindList (extra_binds : aux_binds_s)) }
+
+-----------------------------------------
+mkGenericBinds tycl_decls
+  = do { tcs <- mapM tcLookupTyCon [tc_name | TyData { tcdName = tc_name } <- tycl_decls]
+               -- We are only interested in the data type declarations
+       ; return (andMonoBindList [mkTyConGenericBinds tc | tc <- tcs, tyConHasGenerics tc]) }
+               -- And then only in the ones whose 'has-generics' flag is on
 \end{code}