X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=9d0f8b44b069048e8a64f86950a9fe7260d49fbf;hb=79b22beb4d2eca1877d99d55838ba6ce69658405;hp=00ab97104bb4c9c0833d368fb0e6e760d1b335c8;hpb=5f8d93baa07271687825458e01c187081bcb1ddc;p=ghc-hetmet.git

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 00ab971..9d0f8b4 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -22,8 +22,8 @@ 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,
@@ -102,6 +102,7 @@ rnSrcDecls group@(HsGroup {hs_valds  = val_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,
@@ -126,7 +127,7 @@ rnSrcDecls 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,
@@ -180,8 +181,9 @@ rnSrcDecls 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 ;
 
@@ -194,12 +196,13 @@ rnSrcDecls 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 
@@ -338,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}
 %*							*
 %*********************************************************
 
@@ -1031,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:
@@ -1046,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}
 
 %*********************************************************