#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,
derivingOccurrences,
mAIN_Name, main_RDR_Unqual,
- runMainName, intTyConName,
+ runIOName, intTyConName,
boolTyConName, funTyConName,
unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name,
eqStringName, printName,
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}
-- The parser reads the special syntax and returns an Orig RdrName
-- But the global_env contains only Qual RdrNames, so we won't
-- find it there; instead just get the name via the Orig route
- = lookupOrigName rdr_name
+ --
+ = -- This is a binding site for the name, so check first that it
+ -- the current module is the correct one; otherwise GHC can get
+ -- very confused indeed. This test rejects code like
+ -- data T = (,) Int Int
+ -- unless we are in GHC.Tup
+ getModuleRn `thenRn` \ mod ->
+ checkRn (moduleName mod == rdrNameModule rdr_name)
+ (badOrigBinding rdr_name) `thenRn_`
+ lookupOrigName rdr_name
| otherwise
= getModeRn `thenRn` \ mode ->
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
+ [] -> pushSrcLocRn loc $
+ 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}
%* *
%*********************************************************
checkMain ghci_mode mod_name gbl_env
-- LOOKUP main IF WE'RE IN MODULE Main
-- The main point of this is to drag in the declaration for 'main',
- -- its in another module, and for the Prelude function 'runMain',
+ -- its in another module, and for the Prelude function 'runIO',
-- so that the type checker will find them
--
-- We have to return the main_name separately, because it's a
| otherwise
= lookupSrcName gbl_env main_RDR_Unqual `thenRn` \ main_name ->
- returnRn (Just main_name, unitFV main_name, unitFV runMainName)
+ returnRn (Just main_name, unitFV main_name, unitFV runIOName)
where
complain_no_main | ghci_mode == Interactive = addWarnRn noMainMsg
* fromInteger, fromRational on literals (in expressions and patterns)
* negate (in expressions)
* minus (arising from n+k patterns)
+ * "do" notation
We store the relevant Name in the HsSyn tree, in
* HsIntegral/HsFractional
* NegApp
* NPlusKPatIn
+ * HsDo
respectively. Initially, we just store the "standard" name (PrelNames.fromIntegralName,
fromRationalName etc), but the renamer changes this to the appropriate user
name if Opt_NoImplicitPrelude is on. That is what lookupSyntaxName does.
+We treat the orignal (standard) names as free-vars too, because the type checker
+checks the type of the user thing against the type of the standard thing.
+
\begin{code}
-lookupSyntaxName :: Name -- The standard name
- -> RnMS Name -- Possibly a non-standard name
+lookupSyntaxName :: Name -- The standard name
+ -> RnMS (Name, FreeVars) -- Possibly a non-standard name
lookupSyntaxName std_name
- = doptRn Opt_NoImplicitPrelude `thenRn` \ no_prelude ->
+ = getModeRn `thenRn` \ mode ->
+ case mode of {
+ InterfaceMode -> returnRn (std_name, unitFV std_name) ;
+ -- Happens for 'derived' code
+ -- where we don't want to rebind
+ other ->
+
+ doptRn Opt_NoImplicitPrelude `thenRn` \ no_prelude ->
if not no_prelude then
- returnRn std_name -- Normal case
+ returnRn (std_name, unitFV std_name) -- Normal case
else
- let
- rdr_name = mkRdrUnqual (nameOccName std_name)
-- Get the similarly named thing from the local environment
- in
- lookupOccRn rdr_name
+ lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenRn` \ usr_name ->
+ returnRn (usr_name, mkFVs [usr_name, std_name]) }
\end{code}
where
flavour = occNameFlavour (rdrNameOcc name)
+badOrigBinding name
+ = ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name)
+ -- The rdrNameOcc is because we don't want to print Prelude.(,)
+
qualNameErr descriptor (name,loc)
= pushSrcLocRn loc $
addErrRn (vcat [ ptext SLIT("Invalid use of qualified name") <+> quotes (ppr name),
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