X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=6b8e5c09ba802bb66f3e77e44f1b03fb53eb23ce;hp=2ce2170f9b132df54471791d72143c7864f8a62e;hb=c1c2c25355bc462e521b2c5fb41ac79307da22ff;hpb=6ea06bbf08517d9805feb82df65cc56ecbaf23a4 diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 2ce2170..6b8e5c0 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -17,14 +17,14 @@ import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl ) import HsSyn import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc ) -import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars ) +import RdrHsSyn ( extractHsRhoRdrTyVars ) import RnHsSyn import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext, rnConDeclFields ) import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn, makeMiniFixityEnv) import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn, lookupTopBndrRn, lookupLocatedTopBndrRn, - lookupOccRn, newLocalBndrsRn, bindLocalNamesFV, + lookupOccRn, bindLocalNamesFV, bindLocatedLocalsFV, bindPatSigTyVarsFV, bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn, bindLocalNames, checkDupRdrNames, mapFvRn @@ -97,6 +97,7 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, hs_fords = foreign_decls, hs_defds = default_decls, hs_ruleds = rule_decls, + hs_vects = vect_decls, hs_docs = docs }) = do { -- (A) Process the fixity declarations, creating a mapping from @@ -169,12 +170,13 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, (rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ; (rn_rule_decls, src_fvs3) <- setOptM Opt_ScopedTypeVariables $ - rnList rnHsRuleDecl rule_decls ; - -- Inside RULES, scoped type variables are on - (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_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 ; + rnList rnHsRuleDecl rule_decls ; + -- Inside RULES, scoped type variables are on + (rn_vect_decls, src_fvs4) <- rnList rnHsVectDecl vect_decls ; + (rn_foreign_decls, src_fvs5) <- rnList rnHsForeignDecl foreign_decls ; + (rn_ann_decls, src_fvs6) <- rnList rnAnnDecl ann_decls ; + (rn_default_decls, src_fvs7) <- rnList rnDefaultDecl default_decls ; + (rn_deriv_decls, src_fvs8) <- rnList rnSrcDerivDecl deriv_decls ; -- Haddock docs; no free vars rn_docs <- mapM (wrapLocM rnDocDecl) docs ; @@ -190,13 +192,14 @@ rnSrcDecls group@(HsGroup { hs_valds = val_decls, hs_annds = rn_ann_decls, hs_defds = rn_default_decls, hs_ruleds = rn_rule_decls, + hs_vects = rn_vect_decls, hs_docs = rn_docs } ; tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ; ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ; other_def = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ; other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, - src_fvs5, src_fvs6, src_fvs7] ; + src_fvs5, src_fvs6, src_fvs7, src_fvs8] ; -- It is tiresome to gather the binders from type and class decls src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ; @@ -440,24 +443,13 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- The typechecker (not the renamer) checks that all -- the bindings are for the right class let - meth_names = collectMethodBinders mbinds (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty') in - checkDupRdrNames meth_names `thenM_` - -- Check that the same method is not given twice in the - -- same instance decl instance C T where - -- f x = ... - -- g y = ... - -- f x = ... - -- We must use checkDupRdrNames because the Name of the - -- method is the Name of the class selector, whose SrcSpan - -- points to the class declaration - extendTyVarEnvForMethodBinds inst_tyvars ( -- (Slightly strangely) the forall-d tyvars scope over -- the method bindings too rnMethodBinds cls (\_ -> []) -- No scoped tyvars - [] mbinds + mbinds ) `thenM` \ (mbinds', meth_fvs) -> -- Rename the associated types -- The typechecker (not the renamer) checks that all @@ -658,6 +650,29 @@ badRuleLhsErr name lhs bad_e %********************************************************* +%* * +\subsection{Vectorisation declarations} +%* * +%********************************************************* + +\begin{code} +rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars) +rnHsVectDecl (HsVect var Nothing) + = do { var' <- wrapLocM lookupTopBndrRn var + ; return (HsVect var' Nothing, unitFV (unLoc var')) + } +rnHsVectDecl (HsVect var (Just rhs)) + = do { var' <- wrapLocM lookupTopBndrRn var + ; (rhs', fv_rhs) <- rnLExpr rhs + ; return (HsVect var' (Just rhs'), fv_rhs `addOneFV` unLoc var') + } +rnHsVectDecl (HsNoVect var) + = do { var' <- wrapLocM lookupTopBndrRn var + ; return (HsNoVect var', unitFV (unLoc var')) + } +\end{code} + +%********************************************************* %* * \subsection{Type, class and iface sig declarations} %* * @@ -804,15 +819,11 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, -- we want to name both "x" tyvars with the same unique, so that they are -- easy to group together in the typechecker. ; (mbinds', meth_fvs) - <- extendTyVarEnvForMethodBinds tyvars' $ do - { name_env <- getLocalRdrEnv - ; let gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds, - not (unLoc tv `elemLocalRdrEnv` name_env) ] + <- extendTyVarEnvForMethodBinds tyvars' $ -- No need to check for duplicate method signatures -- since that is done by RnNames.extendGlobalRdrEnvRn -- and the methods are already in scope - ; gen_tyvars <- newLocalBndrsRn gen_rdr_tyvars_w_locs - ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds } + rnMethodBinds (unLoc cname') (mkSigTvFn sigs') mbinds -- Haddock docs ; docs' <- mapM (wrapLocM rnDocDecl) docs @@ -1214,6 +1225,8 @@ add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds = addl (gp { hs_annds = L l d : ts }) ds add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds = addl (gp { hs_ruleds = L l d : ts }) ds +add gp@(HsGroup {hs_vects = ts}) l (VectD d) ds + = addl (gp { hs_vects = L l d : ts }) ds add gp l (DocD d) ds = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds @@ -1228,4 +1241,4 @@ add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind" add_sig :: LSig a -> HsValBinds a -> HsValBinds a add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig" -\end{code} \ No newline at end of file +\end{code}