[project @ 2001-01-18 12:54:16 by simonmar]
[ghc-hetmet.git] / ghc / compiler / rename / RnEnv.lhs
index 4fc26e1..b835791 100644 (file)
@@ -10,17 +10,17 @@ module RnEnv where          -- Export everything
 
 import HsSyn
 import RdrHsSyn                ( RdrNameIE )
-import RdrName         ( RdrName, rdrNameModule, rdrNameOcc, isQual, isSourceQual, isUnqual, isIface,
-                         mkRdrUnqual, mkRdrIfaceUnqual, qualifyRdrName, lookupRdrEnv
+import RdrName         ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
+                         mkRdrUnqual, mkRdrQual, qualifyRdrName, lookupRdrEnv, foldRdrEnv
                        )
 import HsTypes         ( hsTyVarName, replaceTyVarName )
 import HscTypes                ( Provenance(..), pprNameProvenance, hasBetterProv,
                          ImportReason(..), GlobalRdrEnv, AvailEnv,
-                         AvailInfo, Avails, GenAvailInfo(..), RdrAvailInfo )
+                         AvailInfo, Avails, GenAvailInfo(..), NameSupply(..) )
 import RnMonad
-import Name            ( Name, NamedThing(..),
+import Name            ( Name,
                          getSrcLoc, 
-                         mkLocalName, mkImportedLocalName, mkGlobalName,
+                         mkLocalName, mkGlobalName,
                          mkIPName, nameOccName, nameModule_maybe,
                          setNameModuleAndLoc
                        )
@@ -57,20 +57,21 @@ newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name
 
 newTopBinder mod rdr_name loc
   =    -- First check the cache
-    traceRn (text "newTopBinder" <+> ppr mod <+> ppr loc) `thenRn_`
+    -- traceRn (text "newTopBinder" <+> ppr mod <+> ppr loc) `thenRn_`
 
        -- There should never be a qualified name in a binding position (except in instance decls)
        -- The parser doesn't check this because the same parser parses instance decls
-    (if isSourceQual rdr_name then
+    (if isQual rdr_name then
        qualNameErr (text "its declaration") (rdr_name,loc)
      else
        returnRn ()
     )                          `thenRn_`
 
-    getNameSupplyRn            `thenRn` \ (us, cache, ipcache) ->
+    getNameSupplyRn            `thenRn` \ name_supply -> 
     let 
        occ = rdrNameOcc rdr_name
        key = (moduleName mod, occ)
+       cache = nsNames name_supply
     in
     case lookupFM cache key of
 
@@ -85,7 +86,7 @@ newTopBinder mod rdr_name loc
                        new_name  = setNameModuleAndLoc name mod loc
                        new_cache = addToFM cache key new_name
                     in
-                    setNameSupplyRn (us, new_cache, ipcache)   `thenRn_`
+                    setNameSupplyRn (name_supply {nsNames = new_cache})        `thenRn_`
                     traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
                     returnRn new_name
                     
@@ -94,12 +95,12 @@ newTopBinder mod rdr_name loc
        -- Even for locally-defined names we use implicitImportProvenance; 
        -- updateProvenances will set it to rights
        Nothing -> let
-                       (us', us1) = splitUniqSupply us
+                       (us', us1) = splitUniqSupply (nsUniqs name_supply)
                        uniq       = uniqFromSupply us1
                        new_name   = mkGlobalName uniq mod occ loc
                        new_cache  = addToFM cache key new_name
                   in
-                  setNameSupplyRn (us', new_cache, ipcache)    `thenRn_`
+                  setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache})   `thenRn_`
                   traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
                   returnRn new_name
 
@@ -123,32 +124,36 @@ newGlobalName :: ModuleName -> OccName -> RnM d Name
   -- (but since it affects DLL-ery it does matter that we get it right
   --  in the end).
 newGlobalName mod_name occ
-  = getNameSupplyRn            `thenRn` \ (us, cache, ipcache) ->
+  = getNameSupplyRn            `thenRn` \ name_supply ->
     let
        key = (mod_name, occ)
+       cache = nsNames name_supply
     in
     case lookupFM cache key of
-       Just name -> traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_`
+       Just name -> -- traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_`
                     returnRn name
 
-       Nothing   -> setNameSupplyRn (us', new_cache, ipcache)          `thenRn_`
-                    traceRn (text "newGlobalName: new" <+> ppr name)   `thenRn_`
+       Nothing   -> setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache})  `thenRn_`
+                    -- traceRn (text "newGlobalName: new" <+> ppr name)                  `thenRn_`
                     returnRn name
                  where
-                    (us', us1) = splitUniqSupply us
+                    (us', us1) = splitUniqSupply (nsUniqs name_supply)
                     uniq       = uniqFromSupply us1
                     mod        = mkVanillaModule mod_name
                     name       = mkGlobalName uniq mod occ noSrcLoc
                     new_cache  = addToFM cache key name
 
 newIPName rdr_name
-  = getNameSupplyRn            `thenRn` \ (us, cache, ipcache) ->
+  = getNameSupplyRn            `thenRn` \ name_supply ->
+    let
+       ipcache = nsIPs name_supply
+    in
     case lookupFM ipcache key of
        Just name -> returnRn name
-       Nothing   -> setNameSupplyRn (us', cache, new_ipcache)  `thenRn_`
+       Nothing   -> setNameSupplyRn (name_supply {nsUniqs = us', nsIPs = new_ipcache}) `thenRn_`
                     returnRn name
                  where
-                    (us', us1)  = splitUniqSupply us
+                    (us', us1)  = splitUniqSupply (nsUniqs name_supply)
                     uniq        = uniqFromSupply us1
                     name        = mkIPName uniq key
                     new_ipcache = addToFM ipcache key name
@@ -171,15 +176,16 @@ lookupBndrRn rdr_name
          Nothing   -> lookupTopBndrRn rdr_name
 
 lookupTopBndrRn rdr_name
-  | isIface rdr_name
-  = lookupOrigName rdr_name
-
-  | otherwise  -- Source mode, so look up a *qualified* version
-  =            -- of the name, so that we get the right one even
-               -- if there are many with the same occ name
-               -- There must *be* a binding
-    getModuleRn                `thenRn` \ mod ->
-    lookupSrcGlobalOcc (qualifyRdrName (moduleName mod) rdr_name)
+  = getModeRn  `thenRn` \ mode ->
+    if isInterfaceMode mode
+       then lookupIfaceName rdr_name   
+       else     -- Source mode, so look up a *qualified* version
+                -- of the name, so that we get the right one even
+                -- if there are many with the same occ name
+                -- There must *be* a binding
+               getModuleRn             `thenRn` \ mod ->
+               getGlobalNameEnv        `thenRn` \ global_env ->
+               lookupSrcName global_env (qualifyRdrName (moduleName mod) rdr_name)
 
 -- lookupSigOccRn is used for type signatures and pragmas
 -- Is this valid?
@@ -208,32 +214,67 @@ lookupOccRn rdr_name
 --     class op names in class and instance decls
 
 lookupGlobalOccRn rdr_name
-  | isIface rdr_name
+  = getModeRn          `thenRn` \ mode ->
+    if (isInterfaceMode mode)
+       then lookupIfaceName rdr_name
+       else 
+
+    getGlobalNameEnv   `thenRn` \ global_env ->
+    case mode of 
+       SourceMode -> lookupSrcName global_env rdr_name
+
+       CmdLineMode
+        | not (isQual rdr_name) -> 
+               lookupSrcName global_env rdr_name
+
+               -- We allow qualified names on the command line to refer to 
+               -- *any* name exported by any module in scope, just as if 
+               -- there was an "import qualified M" declaration for every 
+               -- module.
+               --
+               -- First look up the name in the normal environment.  If
+               -- it isn't there, we manufacture a new occurrence of an
+               -- original name.
+        | otherwise -> 
+               case lookupRdrEnv global_env rdr_name of
+                      Just _  -> lookupSrcName global_env rdr_name
+                      Nothing -> newGlobalName (rdrNameModule rdr_name)
+                                               (rdrNameOcc rdr_name)
+
+
+lookupSrcName :: GlobalRdrEnv -> RdrName -> RnM d Name
+-- NB: passed GlobalEnv explicitly, not necessarily in RnMS monad
+lookupSrcName global_env rdr_name
+  | isOrig rdr_name    -- Can occur in source code too
   = lookupOrigName rdr_name
 
   | otherwise
-  = lookupSrcGlobalOcc rdr_name
-
-lookupSrcGlobalOcc rdr_name
-  -- Lookup a source-code rdr-name
-  = getGlobalNameEnv                   `thenRn` \ global_env ->
-    case lookupRdrEnv global_env rdr_name of
+  = case lookupRdrEnv global_env rdr_name of
        Just [(name,_)]         -> returnRn name
        Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff     `thenRn_`
                                   returnRn name
        Nothing                 -> failWithRn (mkUnboundName rdr_name)
                                              (unknownNameErr rdr_name)
 
-lookupGlobalRn :: GlobalRdrEnv -> RdrName -> RnM d (Maybe Name)
-  -- Checks that there is exactly one
-lookupGlobalRn global_env rdr_name
-  = case lookupRdrEnv global_env rdr_name of
-       Just [(name,_)]         -> returnRn (Just name)
-       Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff     `thenRn_`
-                                  returnRn (Just name)
-       Nothing                 -> returnRn Nothing
+lookupOrigName :: RdrName -> RnM d Name 
+lookupOrigName rdr_name
+  = ASSERT( isOrig rdr_name )
+    newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
+
+lookupIfaceUnqual :: RdrName -> RnM d Name
+lookupIfaceUnqual rdr_name
+  = ASSERT( isUnqual rdr_name )
+       -- An Unqual is allowed; interface files contain 
+       -- unqualified names for locally-defined things, such as
+       -- constructors of a data type.
+    getModuleRn                        `thenRn ` \ mod ->
+    newGlobalName (moduleName mod) (rdrNameOcc rdr_name)
+
+lookupIfaceName :: RdrName -> RnM d Name
+lookupIfaceName rdr_name
+  | isUnqual rdr_name = lookupIfaceUnqual rdr_name
+  | otherwise        = lookupOrigName rdr_name
 \end{code}
-%
 
 @lookupOrigName@ takes an RdrName representing an {\em original}
 name, and adds it to the occurrence pool so that it'll be loaded
@@ -249,34 +290,17 @@ calls it at all I think).
 
   \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}}
 
-For List and Tuple types it's important to get the correct
-@isLocallyDefined@ flag, which is used in turn when deciding
-whether there are any instance decls in this module are ``special''.
-The name cache should have the correct provenance, though.
-
 \begin{code}
-lookupOrigName :: RdrName -> RnM d Name 
-lookupOrigName rdr_name
-  = ASSERT( isIface rdr_name )
-    if isQual rdr_name then
-       newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
-    else
-       -- An Unqual is allowed; interface files contain 
-       -- unqualified names for locally-defined things, such as
-       -- constructors of a data type.
-       getModuleRn                     `thenRn ` \ mod ->
-       newGlobalName (moduleName mod) (rdrNameOcc rdr_name)
-
 lookupOrigNames :: [RdrName] -> RnM d NameSet
 lookupOrigNames rdr_names
   = mapRn lookupOrigName rdr_names     `thenRn` \ names ->
     returnRn (mkNameSet names)
 \end{code}
 
-lookupSysBinder is used for the "system binders" of a type, class, or instance decl.
-It ensures that the module is set correctly in the name cache, and sets the provenance
-on the returned name too.  The returned name will end up actually in the type, class,
-or instance.
+lookupSysBinder is used for the "system binders" of a type, class, or
+instance decl.  It ensures that the module is set correctly in the
+name cache, and sets the provenance on the returned name too.  The
+returned name will end up actually in the type, class, or instance.
 
 \begin{code}
 lookupSysBinder rdr_name
@@ -287,7 +311,6 @@ lookupSysBinder rdr_name
 \end{code}
 
 
-
 %*********************************************************
 %*                                                     *
 \subsection{Binding}
@@ -298,16 +321,16 @@ lookupSysBinder rdr_name
 newLocalsRn :: [(RdrName,SrcLoc)]
            -> RnMS [Name]
 newLocalsRn rdr_names_w_loc
- =  getNameSupplyRn            `thenRn` \ (us, cache, ipcache) ->
+ =  getNameSupplyRn            `thenRn` \ name_supply ->
     let
        n          = length rdr_names_w_loc
-       (us', us1) = splitUniqSupply us
+       (us', us1) = splitUniqSupply (nsUniqs name_supply)
        uniqs      = uniqsFromSupply n us1
        names      = [ mkLocalName uniq (rdrNameOcc rdr_name) loc
                     | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
                     ]
     in
-    setNameSupplyRn (us', cache, ipcache)      `thenRn_`
+    setNameSupplyRn (name_supply {nsUniqs = us'})      `thenRn_`
     returnRn names
 
 
@@ -353,13 +376,13 @@ bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a
 bindCoreLocalRn rdr_name enclosed_scope
   = getSrcLocRn                `thenRn` \ loc ->
     getLocalNameEnv            `thenRn` \ name_env ->
-    getNameSupplyRn            `thenRn` \ (us, cache, ipcache) ->
+    getNameSupplyRn            `thenRn` \ name_supply ->
     let
-       (us', us1) = splitUniqSupply us
+       (us', us1) = splitUniqSupply (nsUniqs name_supply)
        uniq       = uniqFromSupply us1
-       name       = mkImportedLocalName uniq (rdrNameOcc rdr_name) loc
+       name       = mkLocalName uniq (rdrNameOcc rdr_name) loc
     in
-    setNameSupplyRn (us', cache, ipcache)      `thenRn_`
+    setNameSupplyRn (name_supply {nsUniqs = us'})      `thenRn_`
     let
        new_name_env = extendRdrEnv name_env rdr_name name
     in
@@ -371,17 +394,17 @@ bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b  $ \ name' ->
                                       thing_inside (name':names')
 
 bindLocalNames names enclosed_scope
-  = getModeRn                  `thenRn` \ mode ->
-    let
-       -- This is gruesome, but I can't think of a better way just now
-       mk_rdr_name = case mode of
-                       SourceMode    -> mkRdrUnqual
-                       InterfaceMode -> mkRdrIfaceUnqual
-       pairs = [(mk_rdr_name (nameOccName n), n) | n <- names]
-    in
-    getLocalNameEnv            `thenRn` \ name_env ->
+  = getLocalNameEnv            `thenRn` \ name_env ->
     setLocalNameEnv (addListToRdrEnv name_env pairs)
                    enclosed_scope
+  where
+    pairs = [(mkRdrUnqual (nameOccName n), n) | n <- names]
+
+bindLocalNamesFV names enclosed_scope
+  = bindLocalNames names $
+    enclosed_scope `thenRn` \ (thing, fvs) ->
+    returnRn (thing, delListFromNameSet fvs names)
+
 
 -------------------------------------
 bindLocalRn doc rdr_name enclosed_scope
@@ -404,12 +427,8 @@ bindLocalsFVRn doc rdr_names enclosed_scope
     returnRn (thing, delListFromNameSet fvs names)
 
 -------------------------------------
-bindUVarRn :: RdrName -> (Name -> RnMS a) -> RnMS a
-bindUVarRn = bindCoreLocalRn
-
--------------------------------------
 extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars)
-       -- This tiresome function is used only in rnDecl on InstDecl
+       -- This tiresome function is used only in rnSourceDecl on InstDecl
 extendTyVarEnvFVRn tyvars enclosed_scope
   = bindLocalNames tyvars enclosed_scope       `thenRn` \ (thing, fvs) -> 
     returnRn (thing, delListFromNameSet fvs tyvars)
@@ -473,7 +492,7 @@ checkDupOrQualNames doc_str rdr_names_w_loc
     mapRn_ (qualNameErr doc_str) quals         `thenRn_`
     checkDupNames doc_str rdr_names_w_loc
   where
-    quals = filter (isSourceQual . fst) rdr_names_w_loc
+    quals = filter (isQual . fst) rdr_names_w_loc
     
 checkDupNames doc_str rdr_names_w_loc
   =    -- Check for duplicated names in a binding group
@@ -490,6 +509,60 @@ checkDupNames doc_str rdr_names_w_loc
 %************************************************************************
 
 \begin{code}
+mkGlobalRdrEnv :: ModuleName           -- Imported module (after doing the "as M" name change)
+              -> Bool                  -- True <=> want unqualified import
+              -> Bool                  -- True <=> want qualified import
+              -> [AvailInfo]           -- What's to be hidden (but only the unqualified 
+                                       --      version is hidden)
+              -> (Name -> Provenance)
+              -> Avails                -- Whats imported and how
+              -> GlobalRdrEnv
+
+mkGlobalRdrEnv this_mod unqual_imp qual_imp hides mk_provenance avails
+  = gbl_env2
+  where
+       -- Make the name environment.  We're talking about a 
+       -- single module here, so there must be no name clashes.
+       -- In practice there only ever will be if it's the module
+       -- being compiled.
+
+       -- Add the things that are available
+    gbl_env1 = foldl add_avail emptyRdrEnv avails
+
+       -- Delete things that are hidden
+    gbl_env2 = foldl del_avail gbl_env1 hides
+
+    add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv
+    add_avail env avail = foldl add_name env (availNames avail)
+
+    add_name env name
+       | qual_imp && unqual_imp = env3
+       | unqual_imp             = env2
+       | qual_imp               = env1
+       | otherwise              = env
+       where
+         env1 = addOneToGlobalRdrEnv env  (mkRdrQual this_mod occ) (name,prov)
+         env2 = addOneToGlobalRdrEnv env  (mkRdrUnqual occ)        (name,prov)
+         env3 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ)        (name,prov)
+         occ  = nameOccName name
+         prov = mk_provenance name
+
+    del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names
+                       where
+                         rdr_names = map (mkRdrUnqual . nameOccName) (availNames avail)
+
+mkIfaceGlobalRdrEnv :: [(ModuleName,Avails)] -> GlobalRdrEnv
+-- Used to construct a GlobalRdrEnv for an interface that we've
+-- read from a .hi file.  We can't construct the original top-level
+-- environment because we don't have enough info, but we compromise
+-- by making an environment from its exports
+mkIfaceGlobalRdrEnv m_avails
+  = foldl add emptyRdrEnv m_avails
+  where
+    add env (mod,avails) = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True False [] (\n -> LocalDef) avails)
+\end{code}
+
+\begin{code}
 plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
 plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2
 
@@ -539,11 +612,12 @@ in error messages.
 \begin{code}
 unQualInScope :: GlobalRdrEnv -> Name -> Bool
 unQualInScope env
-  = lookup
+  = (`elemNameSet` unqual_names)
   where
-    lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of
-                          Just [(name',_)] -> name == name'
-                          other            -> False
+    unqual_names :: NameSet
+    unqual_names = foldRdrEnv add emptyNameSet env
+    add rdr_name [(name,_)] unquals | isUnqual rdr_name = addOneToNameSet unquals name
+    add _        _          unquals                    = unquals
 \end{code}
 
 
@@ -558,7 +632,7 @@ plusAvail (Avail n1)           (Avail n2)       = Avail n1
 plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2))
 -- Added SOF 4/97
 #ifdef DEBUG
-plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [pprAvail a1,pprAvail a2])
+plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
 #endif
 
 addAvail :: AvailEnv -> AvailInfo -> AvailEnv
@@ -588,18 +662,6 @@ availNames (Avail n)      = [n]
 availNames (AvailTC n ns) = ns
 
 -------------------------------------
-addSysAvails :: AvailInfo -> [Name] -> AvailInfo
-addSysAvails avail          []  = avail
-addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns)
-
--------------------------------------
-rdrAvailInfo :: AvailInfo -> RdrAvailInfo
--- Used when building the avails we are going to put in an interface file
--- We sort the components to reduce needless wobbling of interfaces
-rdrAvailInfo (Avail n)     = Avail   (nameOccName n)
-rdrAvailInfo (AvailTC n ns) = AvailTC (nameOccName n) (sortLt (<) (map nameOccName ns))
-
--------------------------------------
 filterAvail :: RdrNameIE       -- Wanted
            -> AvailInfo        -- Available
            -> Maybe AvailInfo  -- Resulting available; 
@@ -649,26 +711,29 @@ groupAvails this_mod avails
        -- get a canonical ordering
     groupFM = foldl add emptyFM avails
 
-    add env avail = addToFM_C combine env mod_fs [avail]
+    add env avail = addToFM_C combine env mod_fs [avail']
                  where
                    mod_fs = moduleNameFS (moduleName avail_mod)
                    avail_mod = case nameModule_maybe (availName avail) of
                                          Just m  -> m
                                          Nothing -> this_mod
-                   combine old _ = avail:old
+                   combine old _ = avail':old
+                   avail'        = sortAvail avail
 
     a1 `lt` a2 = occ1 < occ2
               where
                 occ1  = nameOccName (availName a1)
                 occ2  = nameOccName (availName a2)
-                               
--------------------------------------
-pprAvail :: AvailInfo -> SDoc
-pprAvail (AvailTC n ns) = ppr n <> case filter (/= n) ns of
-                                       []  -> empty
-                                       ns' -> parens (hsep (punctuate comma (map ppr ns')))
 
-pprAvail (Avail n) = ppr n
+sortAvail :: AvailInfo -> AvailInfo
+-- Sort the sub-names into canonical order.
+-- The canonical order has the "main name" at the beginning 
+-- (if it's there at all)
+sortAvail (Avail n) = Avail n
+sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) ns))
+                        | otherwise   = AvailTC n (    sortLt lt ns)
+                        where
+                          n1 `lt` n2 = nameOccName n1 < nameOccName n2
 \end{code}
 
 
@@ -750,7 +815,7 @@ warnUnusedGroup names
        = case prov1 of
                LocalDef -> (True, getSrcLoc name1, text "Defined but not used")
 
-               NonLocalDef (UserImport mod loc _) _ 
+               NonLocalDef (UserImport mod loc _)
                        -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used")
 
     reportable (name,_) = case occNameUserString (nameOccName name) of