Improve error reporting for precedence errors

[ghc-hetmet.git] / compiler / rename / RnSource.lhs

diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 00ab971..9d0f8b4 100644 (file)
--- 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}
 
 %*********************************************************