X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=9d0f8b44b069048e8a64f86950a9fe7260d49fbf;hb=57217f68d74c803a189942eb99eed56610ad296b;hp=cebc6746c6ba6cbd51720db28c99525df47ff95a;hpb=24b1e13657c3e06e7c97eeab9a6c4f2a0cdd9193;p=ghc-hetmet.git diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index cebc674..9d0f8b4 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -22,15 +22,15 @@ import RnHsSyn import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext ) import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn, makeMiniFixityEnv) -import RnEnv ( lookupLocalDataTcNames, - lookupLocatedTopBndrRn, lookupLocatedOccRn, +import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn, + lookupTopBndrRn, lookupLocatedTopBndrRn, lookupOccRn, newLocalsRn, bindLocatedLocalsFV, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, bindLocalNames, checkDupRdrNames, mapFvRn, ) import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn ) -import HscTypes ( GenAvailInfo(..) ) +import HscTypes ( GenAvailInfo(..), availsToNameSet ) import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) import TcRnMonad @@ -43,12 +43,13 @@ import OccName import Outputable import Bag import FastString -import SrcLoc ( Located(..), unLoc, noLoc ) +import SrcLoc import DynFlags ( DynFlag(..) ) import Maybe ( isNothing ) import BasicTypes ( Boxity(..) ) import ListSetOps (findDupsEq) +import List import Control.Monad \end{code} @@ -93,18 +94,15 @@ 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) +-- Rename a HsGroup; used for normal source files *and* hs-boot files +rnSrcDecls group@(HsGroup {hs_valds = val_decls, hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_derivds = deriv_decls, hs_fixds = fix_decls, hs_warnds = warn_decls, + hs_annds = ann_decls, hs_fords = foreign_decls, hs_defds = default_decls, hs_ruleds = rule_decls, @@ -117,8 +115,10 @@ 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 ; + -- However *do* include class ops, data constructors + -- And for hs-boot files *do* include the value signatures + tc_avails <- getLocalNonValBinders group ; + tc_envs <- extendGlobalRdrEnvRn tc_avails local_fix_env ; setEnvs tc_envs $ do { failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations @@ -127,7 +127,7 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls, -- extend the record field env. -- This depends on the data constructors and field names being in -- scope from (B) above - inNewEnv (extendRecordFieldEnv tycl_decls) $ \ _ -> do { + inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do { -- (D) Rename the left-hand sides of the value bindings. -- This depends on everything from (B) being in scope, @@ -135,10 +135,12 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls, -- It uses the fixity env from (A) to bind fixities for view patterns. new_lhs <- rnTopBindsLHS local_fix_env val_decls ; -- bind the LHSes (and their fixities) in the global rdr environment - let { lhs_binders = map unLoc $ collectHsValBinders new_lhs; - lhs_avails = map Avail lhs_binders + let { val_binders = map unLoc $ collectHsValBinders new_lhs ; + val_bndr_set = mkNameSet val_binders ; + all_bndr_set = val_bndr_set `unionNameSets` availsToNameSet tc_avails ; + val_avails = map Avail val_binders } ; - (tcg_env, tcl_env) <- extendGlobalRdrEnvRn shadowP lhs_avails local_fix_env ; + (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ; setEnvs (tcg_env, tcl_env) $ do { -- Now everything is in scope, as the remaining renaming assumes. @@ -158,18 +160,19 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls, -- (F) Rename Value declarations right-hand sides traceRn (text "Start rnmono") ; - (rn_val_decls, bind_dus) <- rnTopBindsRHS lhs_binders new_lhs ; + (rn_val_decls, bind_dus) <- rnTopBindsRHS val_bndr_set new_lhs ; traceRn (text "finish rnmono" <+> ppr rn_val_decls) ; -- (G) Rename Fixity and deprecations - -- rename fixity declarations and error if we try to + -- Rename fixity declarations and error if we try to -- fix something from another module (duplicates were checked in (A)) - rn_fix_decls <- rnSrcFixityDecls fix_decls ; - -- rename deprec decls; + rn_fix_decls <- rnSrcFixityDecls all_bndr_set fix_decls ; + + -- Rename deprec decls; -- check for duplicates and ensure that deprecated things are defined locally -- at the moment, we don't keep these around past renaming - rn_warns <- rnSrcWarnDecls warn_decls ; + rn_warns <- rnSrcWarnDecls all_bndr_set warn_decls ; -- (H) Rename Everything else @@ -178,8 +181,9 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls, rnList rnHsRuleDecl rule_decls ; -- Inside RULES, scoped type variables are on (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ; - (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl default_decls ; - (rn_deriv_decls, src_fvs6) <- rnList rnSrcDerivDecl deriv_decls ; + (rn_ann_decls, src_fvs5) <- rnList rnAnnDecl ann_decls ; + (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl default_decls ; + (rn_deriv_decls, src_fvs7) <- rnList rnSrcDerivDecl deriv_decls ; -- Haddock docs; no free vars rn_docs <- mapM (wrapLocM rnDocDecl) docs ; @@ -192,12 +196,13 @@ rnSrcDecls shadowP group@(HsGroup {hs_valds = val_decls, hs_warnds = [], -- warns are returned in the tcg_env -- (see below) not in the HsGroup hs_fords = rn_foreign_decls, + hs_annds = rn_ann_decls, hs_defds = rn_default_decls, hs_ruleds = rn_rule_decls, hs_docs = rn_docs } ; - other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs6, src_fvs3, - src_fvs4, src_fvs5] ; + other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, + src_fvs5, src_fvs6, src_fvs7] ; 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 @@ -263,14 +268,14 @@ rnDocDecl (DocGroup lev doc) = do %********************************************************* \begin{code} -rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM [LFixitySig Name] +rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name] -- Rename the fixity decls, so we can put -- the renamed decls in the renamed syntax tree -- Errors if the thing being fixed is not defined locally. -- -- The returned FixitySigs are not actually used for anything, -- except perhaps the GHCi API -rnSrcFixityDecls fix_decls +rnSrcFixityDecls bound_names fix_decls = do fix_decls <- mapM rn_decl fix_decls return (concat fix_decls) where @@ -282,9 +287,10 @@ rnSrcFixityDecls fix_decls rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity)) = setSrcSpan name_loc $ -- this lookup will fail if the definition isn't local - do names <- lookupLocalDataTcNames rdr_name + do names <- lookupLocalDataTcNames bound_names what rdr_name return [ L loc (FixitySig (L name_loc name) fixity) - | name <- names ] + | name <- names ] + what = ptext (sLit "fixity signature") \end{code} @@ -302,11 +308,11 @@ gather them together. \begin{code} -- checks that the deprecations are defined locally, and that there are no duplicates -rnSrcWarnDecls :: [LWarnDecl RdrName] -> RnM Warnings -rnSrcWarnDecls [] +rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings +rnSrcWarnDecls _bound_names [] = returnM NoWarnings -rnSrcWarnDecls decls +rnSrcWarnDecls bound_names decls = do { -- check for duplicates ; mappM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupWarnDecl lrdr')) warn_rdr_dups ; mappM (addLocM rn_deprec) decls `thenM` \ pairs_s -> @@ -314,9 +320,11 @@ rnSrcWarnDecls decls where rn_deprec (Warning rdr_name txt) -- ensures that the names are defined locally - = lookupLocalDataTcNames rdr_name `thenM` \ names -> + = lookupLocalDataTcNames bound_names what rdr_name `thenM` \ names -> returnM [(nameOccName name, txt) | name <- names] + what = ptext (sLit "deprecation") + -- look for duplicates among the OccNames; -- we check that the names are defined above -- invt: the lists returned by findDupsEq always have at least two elements @@ -333,7 +341,26 @@ dupWarnDecl (L loc _) rdr_name %********************************************************* %* * -\subsection{Source code declarations} +\subsection{Annotation declarations} +%* * +%********************************************************* + +\begin{code} +rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars) +rnAnnDecl (HsAnnotation provenance expr) = do + (provenance', provenance_fvs) <- rnAnnProvenance provenance + (expr', expr_fvs) <- rnLExpr expr + return (HsAnnotation provenance' expr', provenance_fvs `plusFV` expr_fvs) + +rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars) +rnAnnProvenance provenance = do + provenance' <- modifyAnnProvenanceNameM lookupTopBndrRn provenance + return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) +\end{code} + +%********************************************************* +%* * +\subsection{Default declarations} %* * %********************************************************* @@ -640,8 +667,9 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, | 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' -> - do { tycon' <- if isFamInstDecl tydecl + do { tyvars <- pruneTyVars tydecl + ; 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 @@ -661,26 +689,29 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, (if isFamInstDecl tydecl then unitFV (unLoc tycon') -- type instance => use else emptyFVs)) - } + } } | 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` @@ -694,10 +725,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) @@ -705,10 +732,11 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, returnM (Just ds', extractHsTyNames_s ds') -- "type" and "type instance" declarations -rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars, +rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyPats = typatsMaybe, tcdSynRhs = ty}) - = bindTyVarsRn syn_doc tyvars $ \ tyvars' -> - do { name' <- if isFamInstDecl tydecl + = do { tyvars <- pruneTyVars tydecl + ; bindTyVarsRn syn_doc tyvars $ \ tyvars' -> do + { name' <- if isFamInstDecl tydecl then lookupLocatedOccRn name -- may be imported family else lookupLocatedTopBndrRn name ; typats' <- rnTyPats syn_doc typatsMaybe @@ -720,7 +748,7 @@ rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars, (if isFamInstDecl tydecl then unitFV (unLoc name') -- type instance => use else emptyFVs)) - } + } } where syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name) @@ -799,6 +827,37 @@ 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) @@ -994,10 +1053,10 @@ badDataCon name Get the mapping from constructors to fields for this module. It's convenient to do this after the data type decls have been renamed \begin{code} -extendRecordFieldEnv :: [LTyClDecl RdrName] -> TcM TcGblEnv -extendRecordFieldEnv decls +extendRecordFieldEnv :: [LTyClDecl RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv +extendRecordFieldEnv tycl_decls inst_decls = do { tcg_env <- getGblEnv - ; field_env' <- foldrM get (tcg_field_env tcg_env) decls + ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons ; return (tcg_env { tcg_field_env = field_env' }) } where -- we want to lookup: @@ -1009,15 +1068,21 @@ extendRecordFieldEnv decls lookup x = do { x' <- lookupLocatedTopBndrRn x ; return $ unLoc x'} - get (L _ (TyData { tcdCons = cons })) env = foldrM get_con env cons - get _ env = return env + all_data_cons :: [ConDecl RdrName] + all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls + , L _ con <- cons ] + all_tycl_decls = at_tycl_decls ++ tycl_decls + at_tycl_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats] + -- Do not forget associated types! - get_con (L _ (ConDecl { con_name = con, con_details = RecCon flds })) env + get_con (ConDecl { con_name = con, con_details = RecCon flds }) + (RecFields env fld_set) = do { con' <- lookup con - ; flds' <- mappM lookup (map cd_fld_name flds) - ; return $ extendNameEnv env con' flds' } - get_con _ env - = return env + ; flds' <- mappM lookup (map cd_fld_name flds) + ; let env' = extendNameEnv env con' flds' + fld_set' = addListToNameSet fld_set flds' + ; return $ (RecFields env' fld_set') } + get_con _ env = return env \end{code} %*********************************************************