import {-# SOURCE #-} RnHiFiles
import HsSyn
-import RdrHsSyn ( RdrNameIE )
+import RdrHsSyn ( RdrNameIE, RdrNameHsType, extractHsTyRdrTyVars )
import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
- mkRdrUnqual, mkRdrQual, lookupRdrEnv, foldRdrEnv, rdrEnvToList,
+ mkRdrUnqual, mkRdrQual,
+ lookupRdrEnv, foldRdrEnv, rdrEnvToList, elemRdrEnv,
unqualifyRdrName
)
import HsTypes ( hsTyVarName, replaceTyVarName )
extendLocalRdrEnv
)
import RnMonad
-import Name ( Name,
+import Name ( Name,
getSrcLoc, nameIsLocalOrFrom,
- mkLocalName, mkGlobalName,
+ mkLocalName, mkGlobalName, nameModule,
mkIPName, nameOccName, nameModule_maybe,
setNameModuleAndLoc
)
import OccName ( OccName, occNameUserString, occNameFlavour )
import Module ( ModuleName, moduleName, mkVanillaModule,
mkSysModuleNameFS, moduleNameFS, WhereFrom(..) )
-import PrelNames ( mkUnboundName, syntaxList, SyntaxMap, vanillaSyntaxMap,
+import PrelNames ( mkUnboundName,
derivingOccurrences,
mAIN_Name, pREL_MAIN_Name,
ioTyConName, intTyConName,
import Outputable
import ListSetOps ( removeDups, equivClasses )
import Util ( sortLt )
+import BasicTypes ( mapIPName )
import List ( nub )
import UniqFM ( lookupWithDefaultUFM )
-import Maybes ( orElse )
import CmdLineOpts
import FastString ( FastString )
\end{code}
-- 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 isQual rdr_name then
- qualNameErr (text "its declaration") (rdr_name,loc)
+ qualNameErr (text "In its declaration") (rdr_name,loc)
else
returnRn ()
) `thenRn_`
name = mkGlobalName uniq mod occ noSrcLoc
new_cache = addToFM cache key name
-newIPName rdr_name
+newIPName rdr_name_ip
= getNameSupplyRn `thenRn` \ name_supply ->
let
ipcache = nsIPs name_supply
in
case lookupFM ipcache key of
- Just name -> returnRn name
- Nothing -> setNameSupplyRn (name_supply {nsUniqs = us', nsIPs = new_ipcache}) `thenRn_`
- returnRn name
+ Just name_ip -> returnRn name_ip
+ Nothing -> setNameSupplyRn new_ns `thenRn_`
+ returnRn name_ip
where
(us', us1) = splitUniqSupply (nsUniqs name_supply)
uniq = uniqFromSupply us1
- name = mkIPName uniq key
- new_ipcache = addToFM ipcache key name
- where key = (rdrNameOcc rdr_name)
+ name_ip = mapIPName mk_name rdr_name_ip
+ mk_name rdr_name = mkIPName uniq (rdrNameOcc rdr_name)
+ new_ipcache = addToFM ipcache key name_ip
+ new_ns = name_supply {nsUniqs = us', nsIPs = new_ipcache}
+ where
+ key = rdr_name_ip -- Ensures that ?x and %x get distinct Names
\end{code}
%*********************************************************
lookupSigOccRn :: RdrName -> RnMS Name
lookupSigOccRn = lookupBndrRn
+-- lookupInstDeclBndr is used for the binders in an
+-- instance declaration. Here we use the class name to
+-- disambiguate.
+
+lookupInstDeclBndr :: Name -> RdrName -> RnMS Name
+ -- We use the selector name as the binder
+lookupInstDeclBndr cls_name rdr_name
+ | isOrig rdr_name -- Occurs in derived instances, where we just
+ -- refer diectly to the right method
+ = lookupOrigName rdr_name
+
+ | otherwise
+ = getGlobalAvails `thenRn` \ avail_env ->
+ case lookupNameEnv avail_env cls_name of
+ -- class not in scope; don't fail as later checks will catch this,
+ -- but just return (bogus) name. Icky.
+ Nothing -> returnRn (mkUnboundName rdr_name)
+ Just (AvailTC _ ns) -> case [n | n <- ns, nameOccName n == occ] of
+ (n:ns)-> ASSERT( null ns ) returnRn n
+ [] -> failWithRn (mkUnboundName rdr_name)
+ (unknownNameErr rdr_name)
+ other -> pprPanic "lookupInstDeclBndr" (ppr cls_name)
+ where
+ occ = rdrNameOcc rdr_name
+
-- lookupOccRn looks up an occurrence of a RdrName
lookupOccRn :: RdrName -> RnMS Name
lookupOccRn rdr_name
-- free var at every function application!)
\end{code}
-\begin{code}
-rnSyntaxNames :: GlobalRdrEnv -> FreeVars -> RnMG (FreeVars, SyntaxMap)
--- Look up the re-bindable syntactic sugar names
--- Any errors arising from these lookups may surprise the
--- programmer, since they aren't explicitly mentioned, and
--- the src line will be unhelpful (ToDo)
+%************************************************************************
+%* *
+\subsection{Re-bindable desugaring names}
+%* *
+%************************************************************************
+
+Haskell 98 says that when you say "3" you get the "fromInteger" from the
+Standard Prelude, regardless of what is in scope. However, to experiment
+with having a language that is less coupled to the standard prelude, we're
+trying a non-standard extension that instead gives you whatever "Prelude.fromInteger"
+happens to be in scope. Then you can
+ import Prelude ()
+ import MyPrelude as Prelude
+to get the desired effect.
+
+At the moment this just happens for
+ * fromInteger, fromRational on literals (in expressions and patterns)
+ * negate (in expressions)
+ * minus (arising from n+k patterns)
+
+We store the relevant Name in the HsSyn tree, in
+ * HsIntegral/HsFractional
+ * NegApp
+ * NPlusKPatIn
+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.
-rnSyntaxNames gbl_env source_fvs
+\begin{code}
+lookupSyntaxName :: Name -- The standard name
+ -> RnMS Name -- Possibly a non-standard name
+lookupSyntaxName std_name
= doptRn Opt_NoImplicitPrelude `thenRn` \ no_prelude ->
if not no_prelude then
- returnRn (source_fvs, vanillaSyntaxMap)
+ returnRn std_name -- Normal case
else
-
- -- There's a -fno-implicit-prelude flag,
- -- so build the re-mapping function
let
- reqd_syntax_list = filter is_reqd syntaxList
- is_reqd (n,_) = n `elemNameSet` source_fvs
- lookup (n,rn) = lookupSrcName gbl_env rn `thenRn` \ rn' ->
- returnRn (n,rn')
+ rdr_name = mkRdrUnqual (nameOccName std_name)
+ -- Get the similarly named thing from the local environment
in
- mapRn lookup reqd_syntax_list `thenRn` \ rn_syntax_list ->
- let
- -- Delete the proxies and add the actuals
- proxies = map fst rn_syntax_list
- actuals = map snd rn_syntax_list
- new_source_fvs = (proxies `delFVs` source_fvs) `plusFV` mkFVs actuals
-
- syntax_env = mkNameEnv rn_syntax_list
- syntax_map n = lookupNameEnv syntax_env n `orElse` n
- in
- returnRn (new_source_fvs, syntax_map)
+ lookupOccRn rdr_name
\end{code}
-> RnMS a
bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
= getModeRn `thenRn` \ mode ->
- getLocalNameEnv `thenRn` \ name_env ->
+ getLocalNameEnv `thenRn` \ local_env ->
+ getGlobalNameEnv `thenRn` \ global_env ->
-- Check for duplicate names
checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
-- Warn about shadowing, but only in source modules
+ let
+ check_shadow (rdr_name,loc)
+ | rdr_name `elemRdrEnv` local_env
+ || rdr_name `elemRdrEnv` global_env
+ = pushSrcLocRn loc $ addWarnRn (shadowedNameWarn rdr_name)
+ | otherwise
+ = returnRn ()
+ in
+
(case mode of
SourceMode -> ifOptRn Opt_WarnNameShadowing $
- mapRn_ (check_shadow name_env) rdr_names_w_loc
+ mapRn_ check_shadow rdr_names_w_loc
other -> returnRn ()
) `thenRn_`
-
+
newLocalsRn rdr_names_w_loc `thenRn` \ names ->
let
- new_local_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
+ new_local_env = addListToRdrEnv local_env (map fst rdr_names_w_loc `zip` names)
in
setLocalNameEnv new_local_env (enclosed_scope names)
- where
- check_shadow name_env (rdr_name,loc)
- = case lookupRdrEnv name_env rdr_name of
- Nothing -> returnRn ()
- Just name -> pushSrcLocRn loc $
- addWarnRn (shadowedNameWarn rdr_name)
-
bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a
-- A specialised variant when renaming stuff from interface
-- files (of which there is a lot)
bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
enclosed_scope names (zipWith replaceTyVarName tyvar_names names)
-bindTyVarsFVRn :: SDoc -> [HsTyVarBndr RdrName]
- -> ([HsTyVarBndr Name] -> RnMS (a, FreeVars))
- -> RnMS (a, FreeVars)
-bindTyVarsFVRn doc_str rdr_names enclosed_scope
- = bindTyVars2Rn doc_str rdr_names $ \ names tyvars ->
- enclosed_scope tyvars `thenRn` \ (thing, fvs) ->
- returnRn (thing, delListFromNameSet fvs names)
-
-bindTyVarsFV2Rn :: SDoc -> [HsTyVarBndr RdrName]
- -> ([Name] -> [HsTyVarBndr Name] -> RnMS (a, FreeVars))
- -> RnMS (a, FreeVars)
-bindTyVarsFV2Rn doc_str rdr_names enclosed_scope
- = bindTyVars2Rn doc_str rdr_names $ \ names tyvars ->
- enclosed_scope names tyvars `thenRn` \ (thing, fvs) ->
- returnRn (thing, delListFromNameSet fvs names)
+bindPatSigTyVars :: [RdrNameHsType]
+ -> RnMS (a, FreeVars)
+ -> RnMS (a, FreeVars)
+ -- Find the type variables in the pattern type
+ -- signatures that must be brought into scope
-bindNakedTyVarsFVRn :: SDoc -> [RdrName]
- -> ([Name] -> RnMS (a, FreeVars))
- -> RnMS (a, FreeVars)
-bindNakedTyVarsFVRn doc_str tyvar_names enclosed_scope
- = getSrcLocRn `thenRn` \ loc ->
+bindPatSigTyVars tys enclosed_scope
+ = getLocalNameEnv `thenRn` \ name_env ->
+ getSrcLocRn `thenRn` \ loc ->
let
- located_tyvars = [(tv, loc) | tv <- tyvar_names]
+ forall_tyvars = nub [ tv | ty <- tys,
+ tv <- extractHsTyRdrTyVars ty,
+ not (tv `elemFM` name_env)
+ ]
+ -- The 'nub' is important. For example:
+ -- f (x :: t) (y :: t) = ....
+ -- We don't want to complain about binding t twice!
+
+ located_tyvars = [(tv, loc) | tv <- forall_tyvars]
+ doc_sig = text "In a pattern type-signature"
in
- bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
- enclosed_scope names `thenRn` \ (thing, fvs) ->
+ bindLocatedLocalsRn doc_sig located_tyvars $ \ names ->
+ enclosed_scope `thenRn` \ (thing, fvs) ->
returnRn (thing, delListFromNameSet fvs names)
addAvail :: AvailEnv -> AvailInfo -> AvailEnv
addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail
-emptyAvailEnv = emptyNameEnv
unitAvailEnv :: AvailInfo -> AvailEnv
unitAvailEnv a = unitNameEnv (availName a) a
qualNameErr descriptor (name,loc)
= pushSrcLocRn loc $
- addErrRn (hsep [ ptext SLIT("Invalid use of qualified name"),
- quotes (ppr name),
- ptext SLIT("in"),
+ addErrRn (vcat [ ptext SLIT("Invalid use of qualified name") <+> quotes (ppr name),
descriptor])
dupNamesErr descriptor ((name,loc) : dup_things)
projects / ghc-hetmet.git / blobdiff