#include "HsVersions.h"
-import {-# SOURCE #-} RnHiFiles
+import {-# SOURCE #-} RnHiFiles( loadInterface )
import FlattenInfo ( namesNeededForFlattening )
import HsSyn
-import RdrHsSyn ( RdrNameIE, RdrNameHsType, extractHsTyRdrTyVars )
+import RnHsSyn ( RenamedFixitySig )
+import RdrHsSyn ( RdrNameIE, RdrNameHsType, RdrNameFixitySig, extractHsTyRdrTyVars )
import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
- mkRdrUnqual, mkRdrQual,
+ mkRdrUnqual, mkRdrQual, setRdrNameOcc,
lookupRdrEnv, foldRdrEnv, rdrEnvToList, elemRdrEnv,
unqualifyRdrName
)
AvailInfo, Avails, GenAvailInfo(..), NameSupply(..),
ModIface(..), GhciMode(..),
Deprecations(..), lookupDeprec,
- extendLocalRdrEnv
+ extendLocalRdrEnv, lookupFixity
)
import RnMonad
import Name ( Name,
getSrcLoc, nameIsLocalOrFrom,
mkInternalName, mkExternalName,
mkIPName, nameOccName, nameModule_maybe,
- setNameModuleAndLoc
+ setNameModuleAndLoc, nameModule
)
import NameEnv
import NameSet
-import OccName ( OccName, occNameUserString, occNameFlavour )
+import OccName ( OccName, occNameUserString, occNameFlavour,
+ isDataSymOcc, setOccNameSpace, tcName )
import Module ( ModuleName, moduleName, mkVanillaModule,
mkSysModuleNameFS, moduleNameFS, WhereFrom(..) )
import PrelNames ( mkUnboundName,
import Outputable
import ListSetOps ( removeDups, equivClasses )
import Util ( sortLt )
-import BasicTypes ( mapIPName )
+import BasicTypes ( mapIPName, defaultFixity )
import List ( nub )
import UniqFM ( lookupWithDefaultUFM )
import Maybe ( mapMaybe )
+import Maybes ( orElse, catMaybes )
import CmdLineOpts
import FastString ( FastString )
\end{code}
Just name -> returnRn name
Nothing -> failWithRn (mkUnboundName rdr_name)
(unknownNameErr rdr_name)
- where
- lookup_local mod global_env rdr_name
- = case lookupRdrEnv global_env rdr_name of
+
+lookup_local mod global_env rdr_name
+ = case lookupRdrEnv global_env rdr_name of
Nothing -> Nothing
Just gres -> case [n | GRE n _ _ <- gres, nameIsLocalOrFrom mod n] of
[] -> Nothing
%*********************************************************
%* *
+\subsection{Looking up fixities}
+%* *
+%*********************************************************
+
+lookupFixity is a bit strange.
+
+* Nested local fixity decls are put in the local fixity env, which we
+ find with getFixtyEnv
+
+* Imported fixities are found in the HIT or PIT
+
+* Top-level fixity decls in this module may be for Names that are
+ either Global (constructors, class operations)
+ or Local/Exported (everything else)
+ (See notes with RnNames.getLocalDeclBinders for why we have this split.)
+ We put them all in the local fixity environment
+
+\begin{code}
+lookupFixityRn :: Name -> RnMS Fixity
+lookupFixityRn name
+ = getModuleRn `thenRn` \ this_mod ->
+ if nameIsLocalOrFrom this_mod name
+ then -- It's defined in this module
+ getFixityEnv `thenRn` \ local_fix_env ->
+ returnRn (lookupLocalFixity local_fix_env name)
+
+ else -- It's imported
+ -- For imported names, we have to get their fixities by doing a
+ -- loadHomeInterface, and consulting the Ifaces that comes back
+ -- from that, because the interface file for the Name might not
+ -- have been loaded yet. Why not? Suppose you import module A,
+ -- which exports a function 'f', thus;
+ -- module CurrentModule where
+ -- import A( f )
+ -- module A( f ) where
+ -- import B( f )
+ -- Then B isn't loaded right away (after all, it's possible that
+ -- nothing from B will be used). When we come across a use of
+ -- 'f', we need to know its fixity, and it's then, and only
+ -- then, that we load B.hi. That is what's happening here.
+ loadInterface doc name_mod ImportBySystem `thenRn` \ iface ->
+ returnRn (lookupFixity (mi_fixities iface) name)
+ where
+ doc = ptext SLIT("Checking fixity for") <+> ppr name
+ name_mod = moduleName (nameModule name)
+
+--------------------------------
+lookupLocalFixity :: LocalFixityEnv -> Name -> Fixity
+lookupLocalFixity env name
+ = case lookupNameEnv env name of
+ Just (FixitySig _ fix _) -> fix
+ Nothing -> defaultFixity
+
+extendNestedFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS a -> RnMS a
+-- Used for nested fixity decls
+-- No need to worry about type constructors here,
+-- Should check for duplicates but we don't
+extendNestedFixityEnv fixes enclosed_scope
+ = getFixityEnv `thenRn` \ fix_env ->
+ let
+ new_fix_env = extendNameEnvList fix_env fixes
+ in
+ setFixityEnv new_fix_env enclosed_scope
+
+mkTopFixityEnv :: GlobalRdrEnv -> [RdrNameFixitySig] -> RnMG LocalFixityEnv
+mkTopFixityEnv gbl_env fix_sigs
+ = getModuleRn `thenRn` \ mod ->
+ let
+ -- GHC extension: look up both the tycon and data con
+ -- for con-like things
+ -- If neither are in scope, report an error; otherwise
+ -- add both to the fixity env
+ go fix_env (FixitySig rdr_name fixity loc)
+ = case catMaybes (map (lookup_local mod gbl_env) rdr_names) of
+ [] -> addErrRn (unknownNameErr rdr_name) `thenRn_`
+ returnRn fix_env
+ ns -> foldlRn add fix_env ns
+
+ where
+ add fix_env name
+ = case lookupNameEnv fix_env name of
+ Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc') `thenRn_`
+ returnRn fix_env
+ Nothing -> returnRn (extendNameEnv fix_env name (FixitySig name fixity loc))
+
+ rdr_names | isDataSymOcc occ = [rdr_name, rdr_name_tc]
+ | otherwise = [rdr_name]
+
+ occ = rdrNameOcc rdr_name
+ rdr_name_tc = setRdrNameOcc rdr_name (setOccNameSpace occ tcName)
+ in
+ foldlRn go emptyLocalFixityEnv fix_sigs
+\end{code}
+
+
+%*********************************************************
+%* *
\subsection{Implicit free vars and sugar names}
%* *
%*********************************************************
addWarnRn (sep [ text (occNameFlavour (nameOccName name)) <+>
quotes (ppr name) <+> text "is deprecated:",
nest 4 (ppr txt) ])
+
+dupFixityDecl rdr_name loc1 loc2
+ = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
+ ptext SLIT("at ") <+> ppr loc1,
+ ptext SLIT("and") <+> ppr loc2]
\end{code}
projects / ghc-hetmet.git / blobdiff