[project @ 2003-06-27 21:17:24 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs
index ef9ff79..f107451 100644 (file)
--- a/ghc/compiler/typecheck/TcDefaults.lhs
+++ b/ghc/compiler/typecheck/TcDefaults.lhs
@@ -8,9 +8,8 @@ module TcDefaults ( tcDefaults ) where
 
 #include "HsVersions.h"
 
-import HsSyn           ( HsDecl(..), DefaultDecl(..) )
-import RnHsSyn         ( RenamedHsDecl )
-
+import HsSyn           ( DefaultDecl(..) )
+import Name            ( Name )
 import TcRnMonad
 import TcEnv           ( tcLookupGlobal_maybe )
 import TcMonoType      ( tcHsType )
@@ -22,18 +21,27 @@ import HscTypes             ( TyThing(..) )
 \end{code}
 
 \begin{code}
-tcDefaults :: [RenamedHsDecl]
-          -> TcM [Type]            -- defaulting types to heave
+tcDefaults :: [DefaultDecl Name]
+          -> TcM [Type]            -- Defaulting types to heave
                                    -- into Tc monad for later use
                                    -- in Disambig.
-tcDefaults decls = tc_defaults [default_decl | DefD default_decl <- decls]
-
-tc_defaults [] = returnM defaultDefaultTys
-
-tc_defaults [DefaultDecl [] locn]
-  = returnM []         -- no defaults
 
-tc_defaults [DefaultDecl mono_tys locn]
+tcDefaults [] 
+  = getDefaultTys              -- No default declaration, so get the
+                               -- default types from the envt; 
+                               -- i.e. use the curent ones
+                               -- (the caller will put them back there)
+       -- It's important not to return defaultDefaultTys here (which
+       -- we used to do) because in a TH program, tcDefaults [] is called
+       -- repeatedly, once for each group of declarations between top-level
+       -- splices.  We don't want to carefully set the default types in
+       -- one group, only for the next group to ignore them and install
+       -- defaultDefaultTys
+
+tcDefaults [DefaultDecl [] locn]
+  = returnM []                 -- Default declaration specifying no types
+
+tcDefaults [DefaultDecl mono_tys locn]
   = tcLookupGlobal_maybe numClassName  `thenM` \ maybe_num ->
     case maybe_num of
        Just (AClass num_class) -> common_case num_class
@@ -55,7 +63,7 @@ tc_defaults [DefaultDecl mono_tys locn]
     
        returnM tau_tys
 
-tc_defaults decls@(DefaultDecl _ loc : _) =
+tcDefaults decls@(DefaultDecl _ loc : _) =
     addSrcLoc loc $
     failWithTc (dupDefaultDeclErr decls)