X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnSource.lhs;h=6ee9f8a7dd9c7afebb534daf299726289b0a153c;hb=a8eecb891f9ca609b1ca96dee520124b00ece40f;hp=c70e7f6f95379ce41d9733a25590a8b914772533;hpb=49fabae45e348e93d25064e469dc777eb3bfc56d;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index c70e7f6..6ee9f8a 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -7,7 +7,7 @@ module RnSource ( rnSrcDecls, addTcgDUs, rnTyClDecls, checkModDeprec, - rnBindGroups, rnBindGroupsAndThen + rnBindGroups, rnBindGroupsAndThen, rnSplice ) where #include "HsVersions.h" @@ -16,8 +16,8 @@ import HsSyn import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, elemLocalRdrEnv ) import RdrHsSyn ( extractGenericPatTyVars ) import RnHsSyn -import RnExpr ( rnLExpr ) -import RnTypes ( rnLHsType, rnHsSigType, rnHsTypeFVs, rnContext ) +import RnExpr ( rnLExpr, checkTH ) +import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext ) import RnBinds ( rnTopBinds, rnBinds, rnMethodBinds, rnBindsAndThen, renameSigs, checkSigs ) import RnEnv ( lookupTopBndrRn, lookupTopFixSigNames, @@ -35,11 +35,11 @@ import BasicTypes ( TopLevelFlag(..) ) import HscTypes ( FixityEnv, FixItem(..), Deprecations, Deprecs(..), DeprecTxt, plusDeprecs ) import Class ( FunDep ) -import Name ( Name ) +import Name ( Name, nameOccName ) 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 ) @@ -121,9 +121,14 @@ rnSrcDecls (HsGroup { hs_valds = [HsBindGroup binds sigs _], other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, src_fvs5] ; src_dus = bind_dus `plusDU` usesOnly other_fvs + -- Note: src_dus will contain *uses* for locally-defined types + -- and classes, but no *defs* for them. (Because rnTyClDecl + -- returns only the uses.) This is a little + -- surprising but it doesn't actually matter at all. } ; traceRn (text "finish rnSrc" <+> ppr rn_group) ; + traceRn (text "finish Dus" <+> ppr src_dus ) ; tcg_env <- getGblEnv ; return (tcg_env `addTcgDUs` src_dus, rn_group) }}} @@ -155,7 +160,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 @@ -174,8 +179,7 @@ rnFixityDecl fix_env (L loc (FixitySig rdr_name fixity)) returnM fix_env Nothing -> returnM (extendNameEnv fix_env name fix_item) where - fix_item = FixItem (rdrNameOcc (unLoc rdr_name)) fixity - (getLoc rdr_name) + fix_item = FixItem (nameOccName name) fixity (getLoc rdr_name) pprFixEnv :: FixityEnv -> SDoc pprFixEnv env @@ -486,28 +490,56 @@ 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' -> + tcdTyVars = tyvars, tcdCons = condecls, + tcdKindSig = sig, tcdDerivs = derivs}) + | is_vanilla -- Normal Haskell data type decl + = ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the + -- data type is syntactically illegal 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) + 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', tcdKindSig = Nothing, 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', tcdKindSig = sig, + 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) = rnContext data_doc ds `thenM` \ ds' -> - returnM (Just ds', extractHsCtxtTyNames ds') + rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' -> + returnM (Just ds', extractHsTyNames_s ds') rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty}) = lookupLocatedTopBndrRn name `thenM` \ name' -> @@ -608,13 +640,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 +666,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. @@ -677,3 +711,19 @@ rnHsTyVars doc tvs = mappM (rnHsTyvar doc) tvs rnHsTyvar doc tyvar = lookupOccRn tyvar \end{code} + +%********************************************************* +%* * + Splices +%* * +%********************************************************* + +\begin{code} +rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) +rnSplice (HsSplice n expr) + = checkTH expr "splice" `thenM_` + getSrcSpanM `thenM` \ loc -> + newLocalsRn [L loc n] `thenM` \ [n'] -> + rnLExpr expr `thenM` \ (expr', fvs) -> + returnM (HsSplice n' expr', fvs) +\end{code}