Allow type families to use GADT syntax (and be GADTs)

[ghc-hetmet.git] / compiler / rename / RnSource.lhs

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index bf29b64..d2bae38 100644 (file)
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -94,13 +94,8 @@ Checks the @(..)@ etc constraints in the export list.
 \begin{code}
 -- Brings the binders of the group into scope in the appropriate places;
 -- does NOT assume that anything is in scope already
---
--- The Bool determines whether (True) names in the group shadow existing
--- Unquals in the global environment (used in Template Haskell) or
--- (False) whether duplicates are reported as an error
-rnSrcDecls :: Bool -> HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
-
-rnSrcDecls shadowP group@(HsGroup {hs_valds  = val_decls,
+rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
+rnSrcDecls group@(HsGroup {hs_valds  = val_decls,
                                    hs_tyclds = tycl_decls,
                                    hs_instds = inst_decls,
                                    hs_derivds = deriv_decls,
@@ -119,7 +114,7 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds  = val_decls,
    -- (B) Bring top level binders (and their fixities) into scope,
    --     *except* for the value bindings, which get brought in below.
    avails <- getLocalNonValBinders group ;
-   tc_envs <- extendGlobalRdrEnvRn shadowP avails local_fix_env ;
+   tc_envs <- extendGlobalRdrEnvRn avails local_fix_env ;
    setEnvs tc_envs $ do {
 
    failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
@@ -139,7 +134,7 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds  = val_decls,
    let { lhs_binders = map unLoc $ collectHsValBinders new_lhs;
          lhs_avails = map Avail lhs_binders
        } ;
-   (tcg_env, tcl_env) <- extendGlobalRdrEnvRn shadowP lhs_avails local_fix_env ;
+   (tcg_env, tcl_env) <- extendGlobalRdrEnvRn lhs_avails local_fix_env ;
    setEnvs (tcg_env, tcl_env) $ do {
 
    --  Now everything is in scope, as the remaining renaming assumes.
@@ -666,23 +661,26 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
         } }
 
   | otherwise            -- GADT
-  = ASSERT( none typatsMaybe )    -- GADTs cannot have type patterns for now
-    do { tycon' <- if isFamInstDecl tydecl
+  = do { tycon' <- if isFamInstDecl tydecl
                    then lookupLocatedOccRn     tycon -- may be imported family
                    else lookupLocatedTopBndrRn tycon
        ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
-       ; tyvars' <- bindTyVarsRn data_doc tyvars 
-                                 (\ tyvars' -> return tyvars')
+       ; (tyvars', typats')
+               <- bindTyVarsRn data_doc tyvars $ \ tyvars' -> do
+                  { typats' <- rnTyPats data_doc typatsMaybe
+                  ; return (tyvars', typats') }
                -- For GADTs, the type variables in the declaration 
                -- do not scope over the constructor signatures
                --      data T a where { T1 :: forall b. b-> b }
+
        ; (derivs', deriv_fvs) <- rn_derivs derivs
        ; condecls' <- rnConDecls (unLoc tycon') condecls
                -- No need to check for duplicate constructor decls
                -- since that is done by RnNames.extendGlobalRdrEnvRn
+
        ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], 
                           tcdLName = tycon', tcdTyVars = tyvars', 
-                          tcdTyPats = Nothing, tcdKindSig = sig,
+                          tcdTyPats = typats', tcdKindSig = sig,
                           tcdCons = condecls', tcdDerivs = derivs'}, 
                   plusFVs (map conDeclFVs condecls') `plusFV` 
                   deriv_fvs                          `plusFV`
@@ -696,10 +694,6 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
                     L _ (ConDecl { con_res = ResTyH98 }) : _  -> True
                     _                     -> False
 
-    none Nothing   = True
-    none (Just []) = True
-    none _         = False
-
     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
 
     rn_derivs Nothing   = returnM (Nothing, emptyFVs)