put back the conversion of warn-lazy-unlifted-bindings into an error until 7.2

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

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 47b8c31..8989d43 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -7,7 +7,7 @@ TcTyClsDecls: Typecheck type and class declarations
 
 \begin{code}
 module TcTyClsDecls (
-       tcTyAndClassDecls, tcFamInstDecl, mkAuxBinds
+       tcTyAndClassDecls, tcFamInstDecl, mkRecSelBinds
     ) where
 
 #include "HsVersions.h"
@@ -30,7 +30,7 @@ import Class
 import TyCon
 import DataCon
 import Id
-import MkId            ( rEC_SEL_ERROR_ID )
+import MkId            ( rEC_SEL_ERROR_ID, mkDefaultMethodId )
 import IdInfo
 import Var
 import VarSet
@@ -136,7 +136,9 @@ indeed type families).  I think.
 tcTyAndClassDecls :: ModDetails -> [LTyClDecl Name]
                   -> TcM (TcGblEnv,         -- Input env extended by types and classes 
                                             -- and their implicit Ids,DataCons
-                          HsValBinds Name)  -- Renamed bindings for record selectors
+                          HsValBinds Name,  -- Renamed bindings for record selectors
+                          [Id])             -- Default method ids
+
 -- Fails if there are any errors
 
 tcTyAndClassDecls boot_details allDecls
@@ -202,11 +204,12 @@ tcTyAndClassDecls boot_details allDecls
        --     second time here.  This doesn't matter as the definitions are
        --     the same.
        ; let { implicit_things = concatMap implicitTyThings alg_tyclss
-             ; aux_binds       = mkAuxBinds alg_tyclss }
+             ; rec_sel_binds   = mkRecSelBinds alg_tyclss
+              ; dm_ids          = mkDefaultMethodIds alg_tyclss }
        ; traceTc ((text "Adding" <+> ppr alg_tyclss) 
                   $$ (text "and" <+> ppr implicit_things))
        ; env <- tcExtendGlobalEnv implicit_things getGblEnv
-       ; return (env, aux_binds) }
+       ; return (env, rec_sel_binds, dm_ids) }
     }
   where
     -- Pull associated types out of class declarations, to tie them into the
@@ -244,8 +247,8 @@ lot of kinding and type checking code with ordinary algebraic data types (and
 GADTs).
 
 \begin{code}
-tcFamInstDecl :: LTyClDecl Name -> TcM TyThing
-tcFamInstDecl (L loc decl)
+tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing
+tcFamInstDecl top_lvl (L loc decl)
   =    -- Prime error recovery, set source location
     setSrcSpan loc                             $
     tcAddDeclCtxt decl                         $
@@ -260,8 +263,26 @@ tcFamInstDecl (L loc decl)
        ; tc <- tcFamInstDecl1 decl
        ; checkValidTyCon tc    -- Remember to check validity;
                                -- no recursion to worry about here
+
+       -- Check that toplevel type instances are not for associated types.
+       ; when (isTopLevel top_lvl && isAssocFamily tc)
+              (addErr $ assocInClassErr (tcdName decl))
+
        ; return (ATyCon tc) }
 
+isAssocFamily :: TyCon -> Bool -- Is an assocaited type
+isAssocFamily tycon
+  = case tyConFamInst_maybe tycon of
+          Nothing       -> panic "isAssocFamily: no family?!?"
+          Just (fam, _) -> isTyConAssoc fam
+
+assocInClassErr :: Name -> SDoc
+assocInClassErr name
+ = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
+   ptext (sLit "must be inside a class instance")
+
+
+
 tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon
 
   -- "type instance"
@@ -763,7 +784,7 @@ tcTyClDecl1 calc_isrec
                   NewType  -> ASSERT( not (null data_cons) )
                                mkNewTyConRhs tc_name tycon (head data_cons)
        ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec
-           (want_generic && canDoGenerics data_cons) h98_syntax Nothing
+           (want_generic && canDoGenerics data_cons) (not h98_syntax) Nothing
        })
   ; return [ATyCon tycon]
   }
@@ -1228,11 +1249,36 @@ checkValidClass cls
 %************************************************************************
 
 \begin{code}
-mkAuxBinds :: [TyThing] -> HsValBinds Name
+mkDefaultMethodIds :: [TyThing] -> [Id]
+-- See Note [Default method Ids and Template Haskell]
+mkDefaultMethodIds things
+  = [ mkDefaultMethodId sel_id dm_name
+    | AClass cls <- things
+    , (sel_id, DefMeth dm_name) <- classOpItems cls ]
+\end{code}
+
+Note [Default method Ids and Template Haskell]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this (Trac #4169):
+   class Numeric a where
+     fromIntegerNum :: a
+     fromIntegerNum = ...
+
+   ast :: Q [Dec]
+   ast = [d| instance Numeric Int |]
+
+When we typecheck 'ast' we have done the first pass over the class decl
+(in tcTyClDecls), but we have not yet typechecked the default-method
+declarations (becuase they can mention value declarations).  So we 
+must bring the default method Ids into scope first (so they can be seen
+when typechecking the [d| .. |] quote, and typecheck them later.
+
+\begin{code}
+mkRecSelBinds :: [TyThing] -> HsValBinds Name
 -- NB We produce *un-typechecked* bindings, rather like 'deriving'
 --    This makes life easier, because the later type checking will add
 --    all necessary type abstractions and applications
-mkAuxBinds ty_things
+mkRecSelBinds ty_things
   = ValBindsOut [(NonRecursive, b) | b <- binds] sigs
   where
     (sigs, binds) = unzip rec_sels