diff options
Diffstat (limited to 'ghc/compiler/rename/RnSource.lhs')
| -rw-r--r-- | ghc/compiler/rename/RnSource.lhs | 86 |
1 files changed, 57 insertions, 29 deletions
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index e173907173..7d3d308d3e 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -39,7 +39,7 @@ import Name ( Name ) import NameSet import NameEnv import Outputable -import SrcLoc ( Located(..), unLoc, getLoc ) +import SrcLoc ( Located(..), unLoc, getLoc, noLoc ) import CmdLineOpts ( DynFlag(..) ) -- Warn of unused for-all'd tyvars import Maybes ( seqMaybe ) @@ -155,7 +155,7 @@ rnSrcFixityDecls fix_decls rnFixityDecl :: FixityEnv -> LFixitySig RdrName -> RnM FixityEnv rnFixityDecl fix_env (L loc (FixitySig rdr_name fixity)) - = addSrcSpan loc $ + = setSrcSpan loc $ -- GHC extension: look up both the tycon and data con -- for con-like things -- If neither are in scope, report an error; otherwise @@ -486,24 +486,50 @@ rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_ emptyFVs) rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, - tcdTyVars = tyvars, tcdCons = condecls, - tcdDerivs = derivs}) - = lookupLocatedTopBndrRn tycon `thenM` \ tycon' -> - bindTyVarsRn data_doc tyvars $ \ tyvars' -> - rnContext data_doc context `thenM` \ context' -> - rn_derivs derivs `thenM` \ (derivs', deriv_fvs) -> - checkDupNames data_doc con_names `thenM_` - rnConDecls (unLoc tycon') condecls `thenM` \ condecls' -> - returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon', - tcdTyVars = tyvars', tcdCons = condecls', - tcdDerivs = derivs'}, - delFVs (map hsLTyVarName tyvars') $ - extractHsCtxtTyNames context' `plusFV` - plusFVs (map conDeclFVs condecls') `plusFV` - deriv_fvs) + tcdTyVars = tyvars, tcdCons = condecls, + tcdDerivs = derivs}) + | is_vanilla -- Normal Haskell data type decl + = bindTyVarsRn data_doc tyvars $ \ tyvars' -> + do { tycon' <- lookupLocatedTopBndrRn tycon + ; context' <- rnContext data_doc context + ; (derivs', deriv_fvs) <- rn_derivs derivs + ; checkDupNames data_doc con_names + ; condecls' <- rnConDecls (unLoc tycon') condecls + ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon', + tcdTyVars = tyvars', tcdCons = condecls', + tcdDerivs = derivs'}, + delFVs (map hsLTyVarName tyvars') $ + extractHsCtxtTyNames context' `plusFV` + plusFVs (map conDeclFVs condecls') `plusFV` + deriv_fvs) } + + | otherwise -- GADT + = ASSERT( null (unLoc context) ) + do { tycon' <- lookupLocatedTopBndrRn tycon + ; tyvars' <- bindTyVarsRn data_doc tyvars + (\ tyvars' -> return tyvars') + -- 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 + ; checkDupNames data_doc con_names + ; condecls' <- rnConDecls (unLoc tycon') condecls + ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon', + tcdTyVars = tyvars', tcdCons = condecls', + tcdDerivs = derivs'}, + plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) } + where + is_vanilla = case condecls of -- Yuk + [] -> True + L _ (ConDecl {}) : _ -> True + other -> False + data_doc = text "In the data type declaration for" <+> quotes (ppr tycon) - con_names = [ n | L _ (ConDecl n _ _ _) <- condecls ] + con_names = map con_names_helper condecls + + con_names_helper (L _ (ConDecl n _ _ _)) = n + con_names_helper (L _ (GadtDecl n _)) = n rn_derivs Nothing = returnM (Nothing, emptyFVs) rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' -> @@ -608,13 +634,21 @@ rnConDecl (ConDecl name tvs cxt details) where doc = text "In the definition of data constructor" <+> quotes (ppr name) +rnConDecl (GadtDecl name ty) + = addLocM checkConName name `thenM_` + lookupLocatedTopBndrRn name `thenM` \ new_name -> + rnHsSigType doc ty `thenM` \ new_ty -> + returnM (GadtDecl new_name new_ty) + where + doc = text "In the definition of data constructor" <+> quotes (ppr name) + rnConDetails doc (PrefixCon tys) - = mappM (rnLBangTy doc) tys `thenM` \ new_tys -> + = mappM (rnLHsType doc) tys `thenM` \ new_tys -> returnM (PrefixCon new_tys) rnConDetails doc (InfixCon ty1 ty2) - = rnLBangTy doc ty1 `thenM` \ new_ty1 -> - rnLBangTy doc ty2 `thenM` \ new_ty2 -> + = rnLHsType doc ty1 `thenM` \ new_ty1 -> + rnLHsType doc ty2 `thenM` \ new_ty2 -> returnM (InfixCon new_ty1 new_ty2) rnConDetails doc (RecCon fields) @@ -626,15 +660,9 @@ rnConDetails doc (RecCon fields) rnField doc (name, ty) = lookupLocatedTopBndrRn name `thenM` \ new_name -> - rnLBangTy doc ty `thenM` \ new_ty -> + rnLHsType doc ty `thenM` \ new_ty -> returnM (new_name, new_ty) -rnLBangTy doc = wrapLocM (rnBangTy doc) - -rnBangTy doc (BangType s ty) - = rnLHsType doc ty `thenM` \ new_ty -> - returnM (BangType s new_ty) - -- This data decl will parse OK -- data T = a Int -- treating "a" as the constructor. @@ -692,4 +720,4 @@ rnSplice (HsSplice n expr) newLocalsRn [L loc n] `thenM` \ [n'] -> rnLExpr expr `thenM` \ (expr', fvs) -> returnM (HsSplice n' expr', fvs) -\end{code}
\ No newline at end of file +\end{code} |