X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnSource.lhs;h=f3822823cd3b9147fa33a85861fd0bd0150c5872;hb=508a505e9853984bfdaa3ad855ae3fcbc6d31787;hp=e1739071735e9a53e83d15dc8e5e8243e73f9454;hpb=40888e1d6141c919254f93545ae0d795e20ae4bf;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index e173907..f382282 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -35,13 +35,13 @@ 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 DriverPhases ( isHsBoot ) import Maybes ( seqMaybe ) import Maybe ( catMaybes, isNothing ) \end{code} @@ -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,24 +490,52 @@ 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) = rnLHsTypes data_doc ds `thenM` \ ds' -> @@ -587,14 +619,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, \begin{code} rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name] rnConDecls tycon condecls - = -- Check that there's at least one condecl, - -- or else we're reading an interface file, or -fglasgow-exts - (if null condecls then - doptM Opt_GlasgowExts `thenM` \ glaExts -> - checkErr glaExts (emptyConDeclsErr tycon) - else returnM () - ) `thenM_` - mappM (wrapLocM rnConDecl) condecls + = mappM (wrapLocM rnConDecl) condecls rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name) rnConDecl (ConDecl name tvs cxt details) @@ -608,13 +633,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 +659,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. @@ -649,10 +676,6 @@ checkConName name = checkErr (isRdrDataCon name) (badDataCon name) badDataCon name = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] - -emptyConDeclsErr tycon - = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), - nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))] \end{code} @@ -692,4 +715,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}