Migrate cvs diff from fptools-assoc branch

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

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 9e0b6cc..1e61c39 100644 (file)
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -11,8 +11,8 @@ module TcTyClsDecls (
 #include "HsVersions.h"
 
 import HsSyn           ( TyClDecl(..),  HsConDetails(..), HsTyVarBndr(..),
-                         ConDecl(..),   Sig(..), , NewOrData(..), ResType(..),
-                         tyClDeclTyVars, isSynDecl, hsConArgs,
+                         ConDecl(..),   Sig(..), NewOrData(..), ResType(..),
+                         tyClDeclTyVars, isSynDecl, isClassDecl, hsConArgs,
                          LTyClDecl, tcdName, hsTyVarName, LHsTyVarBndr
                        )
 import HsTypes          ( HsBang(..), getBangStrictness )
@@ -127,7 +127,12 @@ tcTyAndClassDecls boot_details decls
        ; traceTc (text "tcTyAndCl" <+> ppr mod)
        ; (syn_tycons, alg_tyclss) <- fixM (\ ~(rec_syn_tycons, rec_alg_tyclss) ->
          do    { let { -- Calculate variances and rec-flag
-                     ; (syn_decls, alg_decls) = partition (isSynDecl . unLoc) decls }
+                     ; (syn_decls, alg_decls_pre) = partition (isSynDecl . unLoc) decls
+                      ; alg_decls = alg_decls_pre ++ 
+                                   concat [tcdATs decl        -- add AT decls
+                                          | declLoc <- alg_decls_pre
+                                          , let decl = unLoc declLoc
+                                          , isClassDecl decl] }
 
                        -- Extend the global env with the knot-tied results
                        -- for data types and classes
@@ -301,7 +306,7 @@ kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
         details' <- kc_con_details details 
         res'     <- case res of
           ResTyH98 -> return ResTyH98
-          ResTyGADT ty -> return . ResTyGADT =<< kcHsSigType ty
+          ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
         return (ConDecl name expl ex_tvs' ex_ctxt' details' res')
 
     kc_con_details (PrefixCon btys) 
@@ -320,10 +325,10 @@ kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
        -- going to remove the constructor while coercing it to a lifted type.
        -- And newtypes can't be bang'd
 
+-- !!!TODO -=chak
 kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt,  tcdSigs = sigs})
   = kcTyClDeclBody decl        $ \ tvs' ->
     do { is_boot <- tcIsHsBoot
-       ; checkTc (not is_boot) badBootClassDeclErr
        ; ctxt' <- kcHsContext ctxt     
        ; sigs' <- mappM (wrapLocM kc_sig) sigs
        ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs'}) }
@@ -435,10 +440,11 @@ tcTyClDecl1 calc_vrcs calc_isrec
 tcTyClDecl1 calc_vrcs calc_isrec 
   (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, 
              tcdCtxt = ctxt, tcdMeths = meths,
-             tcdFDs = fundeps, tcdSigs = sigs} )
+             tcdFDs = fundeps, tcdSigs = sigs, tcdATs = ats} )
   = tcTyVarBndrs tvs           $ \ tvs' -> do 
   { ctxt' <- tcHsKindedContext ctxt
   ; fds' <- mappM (addLocM tc_fundep) fundeps
+  -- !!!TODO: process `ats`; what do we want to store in the `Class'? -=chak
   ; sig_stuff <- tcClassSigs class_name sigs meths
   ; clas <- fixM (\ clas ->
                let     -- This little knot is just so we can get
@@ -631,7 +637,7 @@ checkValidTyCon tc
     get_fields con = dataConFieldLabels con `zip` repeat con
        -- dataConFieldLabels may return the empty list, which is fine
 
-    -- XXX - autrijus - Make this far more complex to acommodate 
+    -- Note: The complicated checkOne logic below is there to accomodate
     --       for different return types.  Add res_ty to the mix,
     --       comparing them in two steps, all for good error messages.
     --       Plan: Use Unify.tcMatchTys to compare the first candidate's
@@ -705,11 +711,15 @@ checkValidClass cls
        -- class has only one parameter.  We can't do generic
        -- multi-parameter type classes!
        ; checkTc (unary || no_generics) (genericMultiParamErr cls)
+
+       -- Check that the class has no associated types, unless GlaExs
+       ; checkTc (gla_exts || no_ats) (badATDecl cls)
        }
   where
     (tyvars, theta, _, op_stuff) = classBigSig cls
     unary      = isSingleton tyvars
     no_generics = null [() | (_, GenDefMeth) <- op_stuff]
+    no_ats      = True -- !!!TODO: determine whether the class has ATs -=chak
 
     check_op gla_exts (sel_id, dm) 
       = addErrCtxt (classOpCtxt sel_id tau) $ do
@@ -821,9 +831,11 @@ newtypeFieldErr con_name n_flds
   = sep [ptext SLIT("The constructor of a newtype must have exactly one field"), 
         nest 2 $ ptext SLIT("but") <+> quotes (ppr con_name) <+> ptext SLIT("has") <+> speakN n_flds]
 
+badATDecl cl_name
+  = vcat [ ptext SLIT("Illegal associated type declaration in") <+> quotes (ppr cl_name)
+        , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow ATs")) ]
+
 emptyConDeclsErr tycon
   = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
         nest 2 $ ptext SLIT("(-fglasgow-exts permits this)")]
-
-badBootClassDeclErr = ptext SLIT("Illegal class declaration in hs-boot file")
 \end{code}