X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=9f8ea7dbbe61672dd3b56550627357a242f2de9b;hp=d47125743d139a754a37f7b16bb158bb25e9b884;hb=1e50fd4185479a62e02d987bdfcb1c62712859ca;hpb=f0c99958649b8909612b1b9c9b48aad970dfce05 diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index d471257..9f8ea7d 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -5,9 +5,7 @@ \begin{code} module RnSource ( - rnSrcDecls, addTcgDUs, - rnTyClDecls, - rnSplice, checkTH + rnSrcDecls, addTcgDUs, rnTyClDecls ) where #include "HsVersions.h" @@ -15,11 +13,10 @@ module RnSource ( import {-# SOURCE #-} RnExpr( rnLExpr ) import HsSyn -import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, - globalRdrEnvElts, GlobalRdrElt(..), isLocalGRE, rdrNameOcc ) +import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc ) import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars ) import RnHsSyn -import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext ) +import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext, rnConDeclFields ) import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn, makeMiniFixityEnv) import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn, @@ -40,19 +37,17 @@ import Class ( FunDep ) import Name ( Name, nameOccName ) import NameSet import NameEnv -import OccName import Outputable import Bag import FastString import SrcLoc import DynFlags ( DynFlag(..) ) -import Maybe ( isNothing ) import BasicTypes ( Boxity(..) ) import ListSetOps (findDupsEq) -import List import Control.Monad +import Data.Maybe \end{code} \begin{code} @@ -220,6 +215,8 @@ rnTyClDecls tycl_decls = do (decls', _fvs) <- rnList rnTyClDecl tycl_decls return decls' addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv +-- This function could be defined lower down in the module hierarchy, +-- but there doesn't seem anywhere very logical to put it. addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars) @@ -601,7 +598,6 @@ validRuleLhs foralls lhs check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2 check_e (NegApp e _) = checkl_e e check_e (ExplicitList _ es) = checkl_es es - check_e (ExplicitTuple es _) = checkl_es es check_e other = Just other -- Fails checkl_es es = foldr (mplus . checkl_e) Nothing es @@ -649,24 +645,24 @@ rnTyClDecl (tydecl@TyFamily {}) = rnFamily tydecl bindTyVarsRn -- "data", "newtype", "data instance, and "newtype instance" declarations -rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, +rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, tcdTyVars = tyvars, tcdTyPats = typatsMaybe, tcdCons = condecls, - tcdKindSig = sig, tcdDerivs = derivs}) + 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 - do { tyvars <- pruneTyVars tydecl - ; bindTyVarsRn data_doc tyvars $ \ tyvars' -> do + -- data type is syntactically illegal + ASSERT( distinctTyVarBndrs tyvars ) -- Tyvars should be distinct + do { bindTyVarsRn data_doc tyvars $ \ tyvars' -> do { tycon' <- if isFamInstDecl tydecl then lookupLocatedOccRn tycon -- may be imported family else lookupLocatedTopBndrRn tycon ; context' <- rnContext data_doc context ; typats' <- rnTyPats data_doc typatsMaybe - ; (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 + ; (derivs', deriv_fvs) <- rn_derivs derivs ; return (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon', tcdTyVars = tyvars', tcdTyPats = typats', tcdKindSig = Nothing, @@ -693,11 +689,11 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, -- 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 + ; (derivs', deriv_fvs) <- rn_derivs derivs ; return (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon', tcdTyVars = tyvars', tcdTyPats = typats', tcdKindSig = sig, @@ -721,10 +717,10 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, return (Just ds', extractHsTyNames_s ds') -- "type" and "type instance" declarations -rnTyClDecl tydecl@(TySynonym {tcdLName = name, +rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdTyPats = typatsMaybe, tcdSynRhs = ty}) - = do { tyvars <- pruneTyVars tydecl - ; bindTyVarsRn syn_doc tyvars $ \ tyvars' -> do + = ASSERT( distinctTyVarBndrs tyvars ) -- Tyvars should be distinct + do { bindTyVarsRn syn_doc tyvars $ \ tyvars' -> do { name' <- if isFamInstDecl tydecl then lookupLocatedOccRn name -- may be imported family else lookupLocatedTopBndrRn name @@ -803,12 +799,20 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, cls_doc = text "In the declaration for class" <+> ppr cname sig_doc = text "In the signatures for class" <+> ppr cname +distinctTyVarBndrs :: [LHsTyVarBndr RdrName] -> Bool +-- The tyvar binders should have distinct names +distinctTyVarBndrs tvs + = null (findDupsEq eq tvs) + where + eq (L _ v1) (L _ v2) = hsTyVarName v1 == hsTyVarName v2 + badGadtStupidTheta :: Located RdrName -> SDoc badGadtStupidTheta _ = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"), ptext (sLit "(You can put a context on each contructor, though.)")] \end{code} + %********************************************************* %* * \subsection{Support code for type/data declarations} @@ -816,37 +820,6 @@ badGadtStupidTheta _ %********************************************************* \begin{code} --- Remove any duplicate type variables in family instances may have non-linear --- left-hand sides. Complain if any, but the first occurence of a type --- variable has a user-supplied kind signature. --- -pruneTyVars :: TyClDecl RdrName -> RnM [LHsTyVarBndr RdrName] -pruneTyVars tydecl - | isFamInstDecl tydecl - = do { let pruned_tyvars = nubBy eqLTyVar tyvars - ; assertNoSigsInRepeats tyvars - ; return pruned_tyvars - } - | otherwise - = return tyvars - where - tyvars = tcdTyVars tydecl - - assertNoSigsInRepeats [] = return () - assertNoSigsInRepeats (tv:tvs) - = do { let offending_tvs = [ tv' | tv'@(L _ (KindedTyVar _ _)) <- tvs - , tv' `eqLTyVar` tv] - ; checkErr (null offending_tvs) $ - illegalKindSig (head offending_tvs) - ; assertNoSigsInRepeats tvs - } - - illegalKindSig tv - = hsep [ptext (sLit "Repeat variable occurrence may not have a"), - ptext (sLit "kind signature:"), quotes (ppr tv)] - - tv1 `eqLTyVar` tv2 = hsLTyVarLocName tv1 `eqLocated` hsLTyVarLocName tv2 - -- Although, we are processing type patterns here, all type variables will -- already be in scope (they are the same as in the 'tcdTyVars' field of the -- type declaration to which these patterns belong) @@ -860,8 +833,12 @@ rnConDecls _tycon condecls = mapM (wrapLocM rnConDecl) condecls rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name) -rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc) +rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs + , con_cxt = cxt, con_details = details + , con_res = res_ty, con_doc = mb_doc + , con_old_rec = old_rec, con_explicit = expl }) = do { addLocM checkConName name + ; when old_rec (addWarn (deprecRecSyntax decl)) ; new_name <- lookupLocatedTopBndrRn name ; name_env <- getLocalRdrEnv @@ -872,20 +849,21 @@ rnConDecl (ConDecl name expl tvs cxt details res_ty mb_doc) ; let not_in_scope = not . (`elemLocalRdrEnv` name_env) . unLoc arg_tys = hsConDeclArgTys details implicit_tvs = case res_ty of - ResTyH98 -> filter not_in_scope $ + ResTyH98 -> filter not_in_scope $ get_rdr_tvs arg_tys ResTyGADT ty -> get_rdr_tvs (ty : arg_tys) - tvs' = case expl of - Explicit -> tvs - Implicit -> userHsTyVarBndrs implicit_tvs + new_tvs = case expl of + Explicit -> tvs + Implicit -> userHsTyVarBndrs implicit_tvs - ; mb_doc' <- rnMbLHsDoc mb_doc + ; mb_doc' <- rnMbLHsDoc mb_doc - ; bindTyVarsRn doc tvs' $ \new_tyvars -> do + ; bindTyVarsRn doc new_tvs $ \new_tyvars -> do { new_context <- rnContext doc cxt - ; new_details <- rnConDeclDetails doc details + ; new_details <- rnConDeclDetails doc details ; (new_details', new_res_ty) <- rnConResult doc new_details res_ty - ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty mb_doc') }} + ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context + , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }} where doc = text "In the definition of data constructor" <+> quotes (ppr name) get_rdr_tvs tys = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys)) @@ -896,15 +874,22 @@ rnConResult :: SDoc -> RnM (HsConDetails (LHsType Name) [ConDeclField Name], ResType Name) rnConResult _ details ResTyH98 = return (details, ResTyH98) - -rnConResult doc details (ResTyGADT ty) = do - ty' <- rnHsSigType doc ty - let (arg_tys, res_ty) = splitHsFunType ty' - -- We can split it up, now the renamer has dealt with fixities - case details of - PrefixCon _xs -> ASSERT( null _xs ) return (PrefixCon arg_tys, ResTyGADT res_ty) - RecCon _ -> return (details, ResTyGADT ty') - InfixCon {} -> panic "rnConResult" +rnConResult doc details (ResTyGADT ty) + = do { ty' <- rnLHsType doc ty + ; let (arg_tys, res_ty) = splitHsFunType ty' + -- We can finally split it up, + -- now the renamer has dealt with fixities + -- See Note [Sorting out the result type] in RdrHsSyn + + details' = case details of + RecCon {} -> details + PrefixCon {} -> PrefixCon arg_tys + InfixCon {} -> pprPanic "rnConResult" (ppr ty) + -- See Note [Sorting out the result type] in RdrHsSyn + + ; when (not (null arg_tys) && case details of { RecCon {} -> True; _ -> False }) + (addErr (badRecResTy doc)) + ; return (details', ResTyGADT res_ty) } rnConDeclDetails :: SDoc -> HsConDetails (LHsType RdrName) [ConDeclField RdrName] @@ -919,18 +904,11 @@ rnConDeclDetails doc (InfixCon ty1 ty2) return (InfixCon new_ty1 new_ty2) rnConDeclDetails doc (RecCon fields) - = do { new_fields <- mapM (rnField doc) fields + = do { new_fields <- rnConDeclFields doc fields -- No need to check for duplicate fields -- since that is done by RnNames.extendGlobalRdrEnvRn ; return (RecCon new_fields) } -rnField :: SDoc -> ConDeclField RdrName -> RnM (ConDeclField Name) -rnField doc (ConDeclField name ty haddock_doc) - = lookupLocatedTopBndrRn name `thenM` \ new_name -> - rnLHsType doc ty `thenM` \ new_ty -> - rnMbLHsDoc haddock_doc `thenM` \ new_haddock_doc -> - return (ConDeclField new_name new_ty new_haddock_doc) - -- Rename family declarations -- -- * This function is parametrised by the routine handling the index @@ -946,25 +924,17 @@ rnFamily :: TyClDecl RdrName rnFamily (tydecl@TyFamily {tcdFlavour = flavour, tcdLName = tycon, tcdTyVars = tyvars}) bindIdxVars = - do { checkM (isDataFlavour flavour -- for synonyms, - || not (null tyvars)) $ addErr needOneIdx -- no. of indexes >= 1 - ; bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do { + do { bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do { ; tycon' <- lookupLocatedTopBndrRn tycon ; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon', tcdTyVars = tyvars', tcdKind = tcdKind tydecl}, emptyFVs) } } - where - isDataFlavour DataFamily = True - isDataFlavour _ = False rnFamily d _ = pprPanic "rnFamily" (ppr d) family_doc :: Located RdrName -> SDoc family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon) -needOneIdx :: SDoc -needOneIdx = text "Type family declarations requires at least one type index" - -- Rename associated type declarations (in classes) -- -- * This can be family declarations and (default) type instances @@ -1006,6 +976,16 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats | rdrName == hsTyVarName tv = True | otherwise = rdrName `ltvElem` ltvs +deprecRecSyntax :: ConDecl RdrName -> SDoc +deprecRecSyntax decl + = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl)) + <+> ptext (sLit "uses deprecated syntax") + , ptext (sLit "Instead, use the form") + , nest 2 (ppr decl) ] -- Pretty printer uses new form + +badRecResTy :: SDoc -> SDoc +badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc + noPatterns :: SDoc noPatterns = text "Default definition for an associated synonym cannot have" <+> text "type pattern" @@ -1099,55 +1079,3 @@ rnHsTyVar _doc tyvar = lookupOccRn tyvar \end{code} -%********************************************************* -%* * - Splices -%* * -%********************************************************* - -Note [Splices] -~~~~~~~~~~~~~~ -Consider - f = ... - h = ...$(thing "f")... - -The splice can expand into literally anything, so when we do dependency -analysis we must assume that it might mention 'f'. So we simply treat -all locally-defined names as mentioned by any splice. This is terribly -brutal, but I don't see what else to do. For example, it'll mean -that every locally-defined thing will appear to be used, so no unused-binding -warnings. But if we miss the dependency, then we might typecheck 'h' before 'f', -and that will crash the type checker because 'f' isn't in scope. - -Currently, I'm not treating a splice as also mentioning every import, -which is a bit inconsistent -- but there are a lot of them. We might -thereby get some bogus unused-import warnings, but we won't crash the -type checker. Not very satisfactory really. - -\begin{code} -rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) -rnSplice (HsSplice n expr) - = do { checkTH expr "splice" - ; loc <- getSrcSpanM - ; [n'] <- newLocalsRn [L loc n] - ; (expr', fvs) <- rnLExpr expr - - -- Ugh! See Note [Splices] above - ; lcl_rdr <- getLocalRdrEnv - ; gbl_rdr <- getGlobalRdrEnv - ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, - isLocalGRE gre] - lcl_names = mkNameSet (occEnvElts lcl_rdr) - - ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) } - -checkTH :: Outputable a => a -> String -> RnM () -#ifdef GHCI -checkTH _ _ = return () -- OK -#else -checkTH e what -- Raise an error in a stage-1 compiler - = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+> - ptext (sLit "illegal in a stage-1 compiler"), - nest 2 (ppr e)]) -#endif -\end{code}