Merge branch 'master' of http://darcs.haskell.org/ghc into ghc-generics
[ghc-hetmet.git] / compiler / rename / RnSource.lhs
index 2ce2170..54dc378 100644 (file)
@@ -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,25 @@ 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')
+       }
+\end{code}
+
+%*********************************************************
 %*                                                     *
 \subsection{Type, class and iface sig declarations}
 %*                                                     *
@@ -804,15 +815,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 +1221,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 +1237,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}