Fix Trac #3955: renamer and type variables

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

diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index c6d5052..1a05139 100644 (file)
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -20,14 +20,14 @@ module RnEnv (
        newLocalBndrRn, newLocalBndrsRn, newIPNameRn,
        bindLocalName, bindLocalNames, bindLocalNamesFV, 
        MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv,
-       bindLocalNamesFV_WithFixities,
+       addLocalFixities,
        bindLocatedLocalsFV, bindLocatedLocalsRn,
        bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV,
-       bindTyVarsRn, extendTyVarEnvFVRn,
+       bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn,
 
        checkDupRdrNames, checkDupAndShadowedRdrNames,
-        checkDupAndShadowedNames, 
-       mapFvRn, mapFvRnCPS,
+        checkDupNames, checkDupAndShadowedNames, 
+       addFvRn, mapFvRn, mapMaybeFvRn, mapFvRnCPS,
        warnUnusedMatches, warnUnusedModules, warnUnusedImports, 
        warnUnusedTopBinds, warnUnusedLocalBinds,
        dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg
@@ -48,7 +48,7 @@ import Name           ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName,
                          nameSrcLoc, nameSrcSpan, nameOccName, nameModule, isExternalName )
 import NameSet
 import NameEnv
-import LazyUniqFM
+import UniqFM
 import DataCon         ( dataConFieldLabels )
 import OccName
 import Module          ( Module, ModuleName )
@@ -651,22 +651,17 @@ type MiniFixityEnv = FastStringEnv (Located Fixity)
 --------------------------------
 -- Used for nested fixity decls to bind names along with their fixities.
 -- the fixities are given as a UFM from an OccName's FastString to a fixity decl
-bindLocalNamesFV_WithFixities :: [Name]
-                             -> MiniFixityEnv
-                             -> RnM (a, FreeVars) -> RnM (a, FreeVars)
-bindLocalNamesFV_WithFixities names fixities thing_inside
-  = bindLocalNamesFV names $
-    extendFixityEnv boundFixities $ 
-    thing_inside
+
+addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a
+addLocalFixities mini_fix_env names thing_inside
+  = extendFixityEnv (mapCatMaybes find_fixity names) thing_inside
   where
-    -- find the names that have fixity decls
-    boundFixities = foldr 
-                        (\ name -> \ acc -> 
-                         -- check whether this name has a fixity decl
-                          case lookupFsEnv fixities (occNameFS (nameOccName name)) of
-                               Just (L _ fix) -> (name, FixItem (nameOccName name) fix) : acc
-                               Nothing -> acc) [] names
-    -- bind the names; extend the fixity env; do the thing inside
+    find_fixity name 
+      = case lookupFsEnv mini_fix_env (occNameFS occ) of
+          Just (L _ fix) -> Just (name, FixItem occ fix)
+          Nothing        -> Nothing
+      where
+        occ = nameOccName name
 \end{code}
 
 --------------------------------
@@ -841,7 +836,7 @@ bindLocalName name enclosed_scope
 bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
 bindLocalNamesFV names enclosed_scope
   = do { (result, fvs) <- bindLocalNames names enclosed_scope
-       ; return (result, delListFromNameSet fvs names) }
+       ; return (result, delFVs names fvs) }
 
 
 -------------------------------------
@@ -852,9 +847,17 @@ bindLocatedLocalsFV :: [Located RdrName]
 bindLocatedLocalsFV rdr_names enclosed_scope
   = bindLocatedLocalsRn rdr_names      $ \ names ->
     enclosed_scope names               `thenM` \ (thing, fvs) ->
-    return (thing, delListFromNameSet fvs names)
+    return (thing, delFVs names fvs)
 
 -------------------------------------
+bindTyVarsFV ::  [LHsTyVarBndr RdrName]
+             -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
+             -> RnM (a, FreeVars)
+bindTyVarsFV tyvars thing_inside
+  = bindTyVarsRn tyvars $ \ tyvars' ->
+    do { (res, fvs) <- thing_inside tyvars'
+       ; return (res, delFVs (map hsLTyVarName tyvars') fvs) }
+
 bindTyVarsRn ::  [LHsTyVarBndr RdrName]
              -> ([LHsTyVarBndr Name] -> RnM a)
              -> RnM a
@@ -989,11 +992,19 @@ checkShadowedOccs (global_env,local_env) loc_occs
 
 \begin{code}
 -- A useful utility
+addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)
+addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside
+                               ; return (res, fvs1 `plusFV` fvs2) }
+
 mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
 mapFvRn f xs = do stuff <- mapM f xs
                   case unzip stuff of
                       (ys, fvs_s) -> return (ys, plusFVs fvs_s)
 
+mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)
+mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs)
+mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) }
+
 -- because some of the rename functions are CPSed:
 -- maps the function across the list from left to right; 
 -- collects all the free vars into one set