-- Don't drop a binding for an exported Id,
-- if it otherwise looks dead.
isExportedId :: Id -> Bool
-isExportedId id = case idFlavour id of
+isExportedId id = isUserExportedId id -- Try this
+{-
+ case idFlavour id of
VanillaId -> False
other -> True -- All the others are no-discard
+-}
-- Say if an Id was exported by the user
-- Implies isExportedId (see mkId above)
import OccName -- All of it
import Module ( Module, moduleName, mkVanillaModule,
printModulePrefix, isModuleInThisPackage )
-import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule )
+import RdrName ( RdrName, mkRdrOrig, mkRdrIfaceUnqual, rdrNameOcc, rdrNameModule )
import CmdLineOpts ( opt_Static, opt_OmitInterfacePragmas, opt_EnsureSplittableC )
import SrcLoc ( builtinSrcLoc, noSrcLoc, SrcLoc )
import Unique ( Unique, Uniquable(..), u2i, pprUnique, pprUnique10 )
System -> localise -- System local Ids
Local -> localise -- User non-exported Ids
Exported -> globalise -- User-exported things
- Global _ -> no_op -- Constructors, class selectors etc
+ Global _ -> no_op -- Constructors, class selectors, default methods
where
no_op = (env, name)
nameRdrName :: Name -> RdrName
-- Makes a qualified name for top-level (Global) names, whether locally defined or not
-- and an unqualified name just for Locals
-nameRdrName (Name { n_occ = occ, n_sort = Global mod }) = mkRdrQual (moduleName mod) occ
-nameRdrName (Name { n_occ = occ }) = mkRdrUnqual occ
-
-ifaceNameRdrName :: Name -> RdrName
--- Makes a qualified naem for imported things,
--- and an unqualified one for local things
-ifaceNameRdrName n | isLocallyDefined n = mkRdrUnqual (nameOccName n)
- | otherwise = mkRdrQual (moduleName (nameModule n)) (nameOccName n)
+nameRdrName (Name { n_occ = occ, n_sort = Global mod }) = mkRdrOrig (moduleName mod) occ
+nameRdrName (Name { n_occ = occ }) = mkRdrIfaceUnqual occ
isDllName :: Name -> Bool
-- Does this name refer to something in a different DLL?
| otherwise = pprOccName occ
pprGlobal sty uniq mod occ
- | codeStyle sty = ppr (moduleName mod) <> char '_' <> pprOccName occ
+ | codeStyle sty
+ || ifaceStyle sty = ppr (moduleName mod) <> char '_' <> pprOccName occ
+
| debugStyle sty = ppr (moduleName mod) <> dot <> pprOccName occ <>
text "{-" <> pprUnique10 uniq <> text "-}"
+
| printModulePrefix mod = ppr (moduleName mod) <> dot <> pprOccName occ
| otherwise = pprOccName occ
pprSysLocal sty uniq occ
| codeStyle sty = pprUnique uniq
| otherwise = pprOccName occ <> char '_' <> pprUnique uniq
+
+{-
+pprNameBndr :: Name -> SDoc
+-- Print a binding occurrence of a name.
+-- In interface files we can omit the "M." prefix, which tides things up a lot
+pprNameBndr name
+ = getPprStyle $ \ sty ->
+ case sort of
+ Global mod | ifaceStyle sty -> pprLocal sty uniq occ empty
+ | otherwise -> pprGlobal sty uniq mod occ
+ System -> pprSysLocal sty uniq occ
+ Local -> pprLocal sty uniq occ empty
+ Exported -> pprLocal sty uniq occ (char 'x')
+-}
\end{code}
getSrcLoc = nameSrcLoc . getName
isLocallyDefined = nameIsLocallyDefined . getName
getOccString = occNameString . getOccName
-toRdrName = ifaceNameRdrName . getName
+toRdrName = nameRdrName . getName
isFrom mod x = nameIsFrom mod (getName x)
isLocalOrFrom mod x = nameIsLocalOrFrom mod ( getName x)
\end{code}
RdrName,
-- Construction
- mkRdrUnqual, mkRdrQual,
- mkUnqual, mkQual,
- mkSysUnqual, mkSysQual,
- mkPreludeQual, qualifyRdrName, mkRdrNameWkr,
+ mkRdrUnqual, mkRdrQual, mkRdrOrig, mkRdrIfaceUnqual,
+ mkUnqual, mkQual, mkIfaceOrig, mkOrig,
+ qualifyRdrName, mkRdrNameWkr,
dummyRdrVarName, dummyRdrTcName,
-- Destruction
rdrNameModule, rdrNameOcc, setRdrNameOcc,
- isRdrDataCon, isRdrTyVar, isQual, isUnqual,
+ isRdrDataCon, isRdrTyVar, isQual, isSourceQual, isUnqual, isIface,
-- Environment
RdrNameEnv,
#include "HsVersions.h"
import OccName ( NameSpace, tcName,
- OccName, UserFS,
+ OccName, UserFS, EncodedFS,
mkSysOccFS,
mkOccFS, mkVarOcc,
isDataOcc, isTvOcc, mkWorkerOcc
data RdrName = RdrName Qual OccName
data Qual = Unqual
- | Qual ModuleName -- The (encoded) module name
+
+ | IfaceUnqual -- An unqualified name from an interface file;
+ -- implicitly its module is that of the enclosing
+ -- interface file; don't look it up in the environment
+
+ | Qual ModuleName -- A qualified name written by the user in source code
+ -- The module isn't necessarily the module where
+ -- the thing is defined; just the one from which it
+ -- is imported
+
+ | Orig ModuleName -- This is an *original* name; the module is the place
+ -- where the thing was defined
\end{code}
\begin{code}
rdrNameModule :: RdrName -> ModuleName
rdrNameModule (RdrName (Qual m) _) = m
+rdrNameModule (RdrName (Orig m) _) = m
rdrNameOcc :: RdrName -> OccName
rdrNameOcc (RdrName _ occ) = occ
mkRdrUnqual :: OccName -> RdrName
mkRdrUnqual occ = RdrName Unqual occ
+mkRdrIfaceUnqual :: OccName -> RdrName
+mkRdrIfaceUnqual occ = RdrName IfaceUnqual occ
+
mkRdrQual :: ModuleName -> OccName -> RdrName
mkRdrQual mod occ = RdrName (Qual mod) occ
+mkRdrOrig :: ModuleName -> OccName -> RdrName
+mkRdrOrig mod occ = RdrName (Orig mod) occ
+
+mkIfaceOrig :: NameSpace -> (EncodedFS, EncodedFS) -> RdrName
+mkIfaceOrig ns (m,n) = RdrName (Orig (mkSysModuleNameFS m)) (mkSysOccFS ns n)
+
+
-- These two are used when parsing source files
-- They do encode the module and occurrence names
mkUnqual :: NameSpace -> FAST_STRING -> RdrName
mkQual :: NameSpace -> (UserFS, UserFS) -> RdrName
mkQual sp (m, n) = RdrName (Qual (mkModuleNameFS m)) (mkOccFS sp n)
- -- These two are used when parsing interface files
- -- They do not encode the module and occurrence name
-mkSysUnqual :: NameSpace -> FAST_STRING -> RdrName
-mkSysUnqual sp n = RdrName Unqual (mkSysOccFS sp n)
-
-mkSysQual :: NameSpace -> (FAST_STRING, FAST_STRING) -> RdrName
-mkSysQual sp (m,n) = RdrName (Qual (mkSysModuleNameFS m)) (mkSysOccFS sp n)
-
-mkPreludeQual :: NameSpace -> ModuleName -> FAST_STRING -> RdrName
-mkPreludeQual sp mod n = RdrName (Qual mod) (mkOccFS sp n)
+mkOrig :: NameSpace -> ModuleName -> UserFS -> RdrName
+mkOrig sp mod n = RdrName (Orig mod) (mkOccFS sp n)
qualifyRdrName :: ModuleName -> RdrName -> RdrName
-- Sets the module name of a RdrName, even if it has one already
isRdrDataCon (RdrName _ occ) = isDataOcc occ
isRdrTyVar (RdrName _ occ) = isTvOcc occ
-isUnqual (RdrName Unqual _) = True
-isUnqual other = False
+isUnqual (RdrName Unqual _) = True
+isUnqual (RdrName IfaceUnqual _) = True
+isUnqual other = False
isQual rdr_name = not (isUnqual rdr_name)
+
+isSourceQual (RdrName (Qual _) _) = True
+isSourceQual _ = False
+
+isIface (RdrName (Orig _) _) = True
+isIface (RdrName IfaceUnqual _) = True
+isIface other = False
\end{code}
instance Outputable RdrName where
ppr (RdrName qual occ) = pp_qual qual <> ppr occ
where
- pp_qual Unqual = empty
- pp_qual (Qual mod) = ppr mod <> dot
+ pp_qual Unqual = empty
+ pp_qual IfaceUnqual = empty
+ pp_qual (Qual mod) = ppr mod <> dot
+ pp_qual (Orig mod) = ppr mod <> dot
pprUnqualRdrName (RdrName qual occ) = ppr occ
= (o1 `compare` o2) `thenCmp`
(q1 `cmpQual` q2)
-cmpQual Unqual Unqual = EQ
-cmpQual Unqual (Qual _) = LT
-cmpQual (Qual _) Unqual = GT
-cmpQual (Qual m1) (Qual m2) = m1 `compare` m2
+cmpQual Unqual Unqual = EQ
+cmpQual IfaceUnqual IfaceUnqual = EQ
+cmpQual (Qual m1) (Qual m2) = m1 `compare` m2
+cmpQual (Orig m1) (Orig m2) = m1 `compare` m2
+cmpQual Unqual _ = LT
+cmpQual IfaceUnqual (Qual _) = LT
+cmpQual IfaceUnqual (Orig _) = LT
+cmpQual (Qual _) (Orig _) = LT
+cmpQual _ _ = GT
\end{code}
opt_IgnoreAsserts,
opt_IgnoreIfacePragmas,
opt_NoHiCheck,
- opt_NoImplicitPrelude,
opt_OmitBlackHoling,
opt_OmitInterfacePragmas,
opt_NoPruneTyDecls,
| Opt_AllowUndecidableInstances
| Opt_GlasgowExts
| Opt_Generics
+ | Opt_NoImplicitPrelude
-- misc
| Opt_ReportCompile
opt_IgnoreAsserts = lookUp SLIT("-fignore-asserts")
opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas")
opt_NoHiCheck = lookUp SLIT("-fno-hi-version-check")
-opt_NoImplicitPrelude = lookUp SLIT("-fno-implicit-prelude")
opt_OmitBlackHoling = lookUp SLIT("-dno-black-holing")
opt_OmitInterfacePragmas = lookUp SLIT("-fomit-interface-pragmas")
"fticky-ticky",
"fall-strict",
"fdicts-strict",
- "fgenerics",
"firrefutable-tuples",
"fnumbers-strict",
"fparallel",
-----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.13 2000/10/27 15:11:37 sewardj Exp $
+-- $Id: DriverFlags.hs,v 1.14 2000/10/31 17:30:17 simonpj Exp $
--
-- Driver flags
--
------ Compiler flags -----------------------------------------------
, ( "fglasgow-exts", NoArg (setDynFlag Opt_GlasgowExts) )
+ , ( "fno-implicit-prelude", NoArg (setDynFlag Opt_NoImplicitPrelude) )
, ( "fallow-overlapping-instances",
NoArg (setDynFlag Opt_AllowOverlappingInstances) )
import Lex
import HsSyn -- Lots of it
import SrcLoc
-import RdrHsSyn ( mkNPlusKPatIn, unitTyCon_RDR,
- RdrBinding(..),
+import RdrHsSyn ( RdrBinding(..),
RdrNameHsType, RdrNameBangType, RdrNameContext,
RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs,
RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails
)
import RdrName
+import PrelNames ( unitTyCon_RDR, minus_RDR )
import CallConv
import OccName ( dataName, varName, tcClsName,
occNameSpace, setOccNameSpace, occNameUserString )
OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral k _))
| plus == plus_RDR
- -> returnP (mkNPlusKPatIn n lit)
+ -> returnP (NPlusKPatIn n lit minus_RDR)
+ where
+ plus_RDR = mkUnqual varName SLIT("+") -- Hack
OpApp l op fix r -> checkPat l [] `thenP` \l ->
checkPat r [] `thenP` \r ->
= case bind of
RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds
other -> bind `RdrAndBindings` group Nothing binds
-
-plus_RDR = mkUnqual varName SLIT("+")
\end{code}
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.45 2000/10/26 16:51:44 sewardj Exp $
+$Id: Parser.y,v 1.46 2000/10/31 17:30:17 simonpj Exp $
Haskell grammar.
import Lex
import ParseUtil
import RdrName
-import PrelInfo ( mAIN_Name )
+import PrelNames
import OccName ( UserFS, varName, ipName, tcName, dataName, tcClsName, tvName )
import SrcLoc ( SrcLoc )
import Module
: ipvar { HsIPVar $1 }
| var_or_con { $1 }
| literal { HsLit $1 }
- | INTEGER { HsOverLit (mkHsIntegralLit $1) }
- | RATIONAL { HsOverLit (mkHsFractionalLit $1) }
+ | INTEGER { HsOverLit (HsIntegral $1 fromInteger_RDR) }
+ | RATIONAL { HsOverLit (HsFractional $1 fromRational_RDR) }
| '(' exp ')' { HsPar $2 }
| '(' exp ',' texps ')' { ExplicitTuple ($2 : reverse $4) Boxed}
| '(#' texps '#)' { ExplicitTuple (reverse $2) Unboxed }
extractHsCtxtRdrTyVars, extractGenericPatTyVars,
mkHsOpApp, mkClassDecl, mkClassOpSig, mkConDecl,
- mkHsNegApp, mkHsIntegralLit, mkHsFractionalLit, mkNPlusKPatIn,
-
-
- -- some built-in names (all :: RdrName)
- unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR,
- tupleCon_RDR, tupleTyCon_RDR, ubxTupleCon_RDR, ubxTupleTyCon_RDR,
- funTyCon_RDR,
+ mkHsNegApp,
cvBinds,
cvMonoBindsAndSigs,
#include "HsVersions.h"
import HsSyn -- Lots of it
-import CmdLineOpts ( opt_NoImplicitPrelude )
import HsPat ( collectSigTysFromPats )
import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc,
mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
- mkGenOcc2, varName, dataName, tcName
+ mkGenOcc2,
)
-import PrelNames ( pRELUDE_Name, mkTupNameStr )
-import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc,
- mkUnqual, mkPreludeQual
+import PrelNames ( negate_RDR )
+import RdrName ( RdrName, isRdrTyVar, mkRdrIfaceUnqual, rdrNameOcc,
)
import List ( nub )
-import BasicTypes ( Boxity(..), RecFlag(..) )
+import BasicTypes ( RecFlag(..) )
import Class ( DefMeth (..) )
\end{code}
where
cls_occ = rdrNameOcc cname
data_occ = mkClassDataConOcc cls_occ
- dname = mkRdrUnqual data_occ
- dwname = mkRdrUnqual (mkWorkerOcc data_occ)
- tname = mkRdrUnqual (mkClassTyConOcc cls_occ)
- sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ)
+ dname = mkRdrIfaceUnqual data_occ
+ dwname = mkRdrIfaceUnqual (mkWorkerOcc data_occ)
+ tname = mkRdrIfaceUnqual (mkClassTyConOcc cls_occ)
+ sc_sel_names = [ mkRdrIfaceUnqual (mkSuperDictSelOcc n cls_occ)
| n <- [1..length cxt]]
-- We number off the superclass selectors, 1, 2, 3 etc so that we
-- can construct names for the selectors. Thus
-- mkTyData :: ??
mkTyData new_or_data context tname list_var list_con i maybe src
= let t_occ = rdrNameOcc tname
- name1 = mkRdrUnqual (mkGenOcc1 t_occ)
- name2 = mkRdrUnqual (mkGenOcc2 t_occ)
+ name1 = mkRdrIfaceUnqual (mkGenOcc1 t_occ)
+ name2 = mkRdrIfaceUnqual (mkGenOcc2 t_occ)
in TyData new_or_data context
tname list_var list_con i maybe src name1 name2
mkClassOpSig (DefMeth x) op ty loc
= ClassOpSig op (Just (DefMeth dm_rn)) ty loc
where
- dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op))
+ dm_rn = mkRdrIfaceUnqual (mkDefaultMethodOcc (rdrNameOcc op))
mkClassOpSig x op ty loc =
ClassOpSig op (Just x) ty loc
mkConDecl cname ex_vars cxt details loc
= ConDecl cname wkr_name ex_vars cxt details loc
where
- wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname))
+ wkr_name = mkRdrIfaceUnqual (mkWorkerOcc (rdrNameOcc cname))
\end{code}
\begin{code}
mkHsNegApp (HsOverLit (HsIntegral i n)) = HsOverLit (HsIntegral (-i) n)
mkHsNegApp (HsOverLit (HsFractional f n)) = HsOverLit (HsFractional (-f) n)
-
-mkHsNegApp expr = NegApp expr (prelQual varName SLIT("negate"))
-\end{code}
-
-\begin{code}
-mkHsIntegralLit :: Integer -> HsOverLit RdrName
-mkHsIntegralLit i = HsIntegral i (prelQual varName SLIT("fromInteger"))
-
-mkHsFractionalLit :: Rational -> HsOverLit RdrName
-mkHsFractionalLit f = HsFractional f (prelQual varName SLIT("fromRational"))
-
-mkNPlusKPatIn :: RdrName -> HsOverLit RdrName -> RdrNamePat
-mkNPlusKPatIn n k = NPlusKPatIn n k (prelQual varName SLIT("-"))
+mkHsNegApp expr = NegApp expr negate_RDR
\end{code}
A useful function for building @OpApps@. The operator is always a
mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
\end{code}
-\begin{code}
------------------------------------------------------------------------------
--- Built-in names
--- Qualified Prelude names are always in scope; so we can just say Prelude.[]
--- for the list type constructor, say. But it's not so easy when we say
--- -fno-implicit-prelude. Then you just get whatever "[]" happens to be in scope.
-
-unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR :: RdrName
-tupleCon_RDR, tupleTyCon_RDR :: Int -> RdrName
-ubxTupleCon_RDR, ubxTupleTyCon_RDR :: Int -> RdrName
-
-unitCon_RDR = prelQual dataName SLIT("()")
-unitTyCon_RDR = prelQual tcName SLIT("()")
-nilCon_RDR = prelQual dataName SLIT("[]")
-listTyCon_RDR = prelQual tcName SLIT("[]")
-funTyCon_RDR = prelQual tcName SLIT("(->)")
-tupleCon_RDR arity = prelQual dataName (snd (mkTupNameStr Boxed arity))
-tupleTyCon_RDR arity = prelQual tcName (snd (mkTupNameStr Boxed arity))
-ubxTupleCon_RDR arity = prelQual dataName (snd (mkTupNameStr Unboxed arity))
-ubxTupleTyCon_RDR arity = prelQual tcName (snd (mkTupNameStr Unboxed arity))
-
-prelQual ns occ | opt_NoImplicitPrelude = mkUnqual ns occ
- | otherwise = mkPreludeQual ns pRELUDE_Name occ
-\end{code}
%************************************************************************
%* *
#include "HsVersions.h"
import Module ( ModuleName, mkPrelModule, mkModuleName )
-import OccName ( NameSpace, varName, dataName, tcName, clsName )
-import RdrName ( RdrName, mkPreludeQual )
+import OccName ( NameSpace, UserFS, varName, dataName, tcName, clsName )
+import RdrName ( RdrName, mkOrig )
import UniqFM
import Unique ( Unique, Uniquable(..), hasKey,
mkPreludeMiscIdUnique, mkPreludeDataConUnique,
%************************************************************************
\begin{code}
-mkTupNameStr :: Boxity -> Int -> (ModuleName, FAST_STRING)
+mkTupNameStr :: Boxity -> Int -> (ModuleName, UserFS)
mkTupNameStr Boxed 0 = (pREL_BASE_Name, SLIT("()"))
mkTupNameStr Boxed 1 = panic "Name.mkTupNameStr: 1 ???"
mkTupConRdrName :: NameSpace -> Boxity -> Arity -> RdrName
mkTupConRdrName space boxity arity = case mkTupNameStr boxity arity of
- (mod, occ) -> mkPreludeQual space mod occ
+ (mod, occ) -> mkOrig space mod occ
\end{code}
%* *
%************************************************************************
-These RdrNames are not really "built in", but some parts of the
+Many of these Names are not really "built in", but some parts of the
compiler (notably the deriving mechanism) need to mention their names,
and it's convenient to write them all down in one place.
pre-assigned keys. Mostly these names are used in generating deriving
code, which is passed through the renamer anyway.
+ THEY ARE ALL ORIGINAL NAMES, HOWEVER
+
\begin{code}
-unpackCString_RDR = varQual_RDR pREL_BASE_Name SLIT("unpackCString#")
-unpackCStringFoldr_RDR = varQual_RDR pREL_BASE_Name SLIT("unpackFoldrCString#")
-unpackCStringUtf8_RDR = varQual_RDR pREL_BASE_Name SLIT("unpackCStringUtf8#")
-deRefStablePtr_RDR = varQual_RDR pREL_STABLE_Name SLIT("deRefStablePtr")
-makeStablePtr_RDR = varQual_RDR pREL_STABLE_Name SLIT("makeStablePtr")
-bindIO_RDR = varQual_RDR pREL_IO_BASE_Name SLIT("bindIO")
-returnIO_RDR = varQual_RDR pREL_IO_BASE_Name SLIT("returnIO")
-
-main_RDR = varQual_RDR mAIN_Name SLIT("main")
+-- Lists and tuples
+tupleCon_RDR, tupleTyCon_RDR :: Int -> RdrName
+ubxTupleCon_RDR, ubxTupleTyCon_RDR :: Int -> RdrName
+
+tupleCon_RDR = mkTupConRdrName dataName Boxed
+tupleTyCon_RDR = mkTupConRdrName tcName Boxed
+ubxTupleCon_RDR = mkTupConRdrName dataName Unboxed
+ubxTupleTyCon_RDR = mkTupConRdrName tcName Unboxed
+
+unitCon_RDR = dataQual_RDR pREL_BASE_Name SLIT("()")
+unitTyCon_RDR = tcQual_RDR pREL_BASE_Name SLIT("()")
+
and_RDR = varQual_RDR pREL_BASE_Name SLIT("&&")
not_RDR = varQual_RDR pREL_BASE_Name SLIT("not")
compose_RDR = varQual_RDR pREL_BASE_Name SLIT(".")
assertErr_RDR = varQual_RDR pREL_ERR_Name SLIT("assertError")
\end{code}
+These RDR names also have known keys, so we need to get back the RDR names to
+populate the occurrence list above.
+
+\begin{code}
+funTyCon_RDR = nameRdrName funTyConName
+nilCon_RDR = nameRdrName nilDataConName
+listTyCon_RDR = nameRdrName listTyConName
+ioTyCon_RDR = nameRdrName ioTyConName
+intTyCon_RDR = nameRdrName intTyConName
+eq_RDR = nameRdrName eqName
+ge_RDR = nameRdrName geName
+numClass_RDR = nameRdrName numClassName
+ordClass_RDR = nameRdrName ordClassName
+map_RDR = nameRdrName mapName
+append_RDR = nameRdrName appendName
+foldr_RDR = nameRdrName foldrName
+build_RDR = nameRdrName buildName
+enumFromTo_RDR = nameRdrName enumFromToName
+returnM_RDR = nameRdrName returnMName
+thenM_RDR = nameRdrName thenMName
+failM_RDR = nameRdrName failMName
+false_RDR = nameRdrName falseDataConName
+true_RDR = nameRdrName trueDataConName
+error_RDR = nameRdrName errorName
+getTag_RDR = nameRdrName getTagName
+fromEnum_RDR = nameRdrName fromEnumName
+toEnum_RDR = nameRdrName toEnumName
+enumFrom_RDR = nameRdrName enumFromName
+mkInt_RDR = nameRdrName intDataConName
+enumFromThen_RDR = nameRdrName enumFromThenName
+enumFromThenTo_RDR = nameRdrName enumFromThenToName
+ratioDataCon_RDR = nameRdrName ratioDataConName
+plusInteger_RDR = nameRdrName plusIntegerName
+timesInteger_RDR = nameRdrName timesIntegerName
+enumClass_RDR = nameRdrName enumClassName
+monadClass_RDR = nameRdrName monadClassName
+ioDataCon_RDR = nameRdrName ioDataConName
+cCallableClass_RDR = nameRdrName cCallableClassName
+cReturnableClass_RDR = nameRdrName cReturnableClassName
+eqClass_RDR = nameRdrName eqClassName
+eqString_RDR = nameRdrName eqStringName
+unpackCString_RDR = nameRdrName unpackCStringName
+unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName
+unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name
+deRefStablePtr_RDR = nameRdrName deRefStablePtrName
+makeStablePtr_RDR = nameRdrName makeStablePtrName
+bindIO_RDR = nameRdrName bindIOName
+returnIO_RDR = nameRdrName returnIOName
+main_RDR = nameRdrName mainName
+fromInteger_RDR = nameRdrName fromIntegerName
+fromRational_RDR = nameRdrName fromRationalName
+minus_RDR = nameRdrName minusName
+\end{code}
+
%************************************************************************
%* *
\subsection{Local helpers}
%* *
%************************************************************************
-\begin{code}
-varQual mod str uq = mkKnownKeyGlobal (mkPreludeQual varName mod str) uq
-dataQual mod str uq = mkKnownKeyGlobal (mkPreludeQual dataName mod str) uq
-tcQual mod str uq = mkKnownKeyGlobal (mkPreludeQual tcName mod str) uq
-clsQual mod str uq = mkKnownKeyGlobal (mkPreludeQual clsName mod str) uq
+All these are original names; hence mkOrig
-varQual_RDR mod str = mkPreludeQual varName mod str
-dataQual_RDR mod str = mkPreludeQual dataName mod str
+\begin{code}
+varQual mod str uq = mkKnownKeyGlobal (varQual_RDR mod str) uq
+dataQual mod str uq = mkKnownKeyGlobal (dataQual_RDR mod str) uq
+tcQual mod str uq = mkKnownKeyGlobal (tcQual_RDR mod str) uq
+clsQual mod str uq = mkKnownKeyGlobal (clsQual_RDR mod str) uq
+
+varQual_RDR mod str = mkOrig varName mod str
+tcQual_RDR mod str = mkOrig tcName mod str
+clsQual_RDR mod str = mkOrig clsName mod str
+dataQual_RDR mod str = mkOrig dataName mod str
\end{code}
%************************************************************************
-- or for taggery.
-- ordClass: really it's the methods that are actually used.
-- numClass: for Int literals
-
--- these RDR names also have known keys, so we need to get back the RDR names to
--- populate the occurrence list above.
-ioTyCon_RDR = nameRdrName ioTyConName
-intTyCon_RDR = nameRdrName intTyConName
-eq_RDR = nameRdrName eqName
-ge_RDR = nameRdrName geName
-numClass_RDR = nameRdrName numClassName
-ordClass_RDR = nameRdrName ordClassName
-map_RDR = nameRdrName mapName
-append_RDR = nameRdrName appendName
-foldr_RDR = nameRdrName foldrName
-build_RDR = nameRdrName buildName
-enumFromTo_RDR = nameRdrName enumFromToName
-returnM_RDR = nameRdrName returnMName
-thenM_RDR = nameRdrName thenMName
-failM_RDR = nameRdrName failMName
-false_RDR = nameRdrName falseDataConName
-true_RDR = nameRdrName trueDataConName
-error_RDR = nameRdrName errorName
-getTag_RDR = nameRdrName getTagName
-fromEnum_RDR = nameRdrName fromEnumName
-toEnum_RDR = nameRdrName toEnumName
-enumFrom_RDR = nameRdrName enumFromName
-mkInt_RDR = nameRdrName intDataConName
-enumFromThen_RDR = nameRdrName enumFromThenName
-enumFromThenTo_RDR = nameRdrName enumFromThenToName
-ratioDataCon_RDR = nameRdrName ratioDataConName
-plusInteger_RDR = nameRdrName plusIntegerName
-timesInteger_RDR = nameRdrName timesIntegerName
-enumClass_RDR = nameRdrName enumClassName
-monadClass_RDR = nameRdrName monadClassName
-ioDataCon_RDR = nameRdrName ioDataConName
-cCallableClass_RDR = nameRdrName cCallableClassName
-cReturnableClass_RDR = nameRdrName cReturnableClassName
-eqClass_RDR = nameRdrName eqClassName
-eqString_RDR = nameRdrName eqStringName
\end{code}
import Var ( TyVar )
import CallConv ( CallConv, pprCallConv )
import Name ( Name, mkWiredInName )
-import RdrName ( RdrName, mkRdrQual )
+import RdrName ( RdrName, mkRdrOrig )
import OccName ( OccName, pprOccName, mkVarOcc )
import TyCon ( TyCon, tyConArity )
import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, mkTyVarTys,
= mkWiredInName pREL_GHC (primOpOcc op) (mkPrimOpIdUnique (primOpTag op))
primOpRdrName :: PrimOp -> RdrName
-primOpRdrName op = mkRdrQual pREL_GHC_Name (primOpOcc op)
+primOpRdrName op = mkRdrOrig pREL_GHC_Name (primOpOcc op)
primOpOcc :: PrimOp -> OccName
primOpOcc op = case (primOpInfo op) of
)
import Unique ( Unique, mkAlphaTyVarUnique )
import Name ( mkKnownKeyGlobal )
-import RdrName ( mkPreludeQual )
+import RdrName ( mkOrig )
import PrelNames
import Outputable
\end{code}
pcPrimTyCon key str arity arg_vrcs rep
= the_tycon
where
- name = mkKnownKeyGlobal (mkPreludeQual tcName pREL_GHC_Name str) key
+ name = mkKnownKeyGlobal (mkOrig tcName pREL_GHC_Name str) key
the_tycon = mkPrimTyCon name kind arity arg_vrcs rep
kind = mkArrowKinds (take arity (repeat boxedTypeKind)) result_kind
result_kind | isFollowableRep rep = boxedTypeKind -- Represented by a GC-ish ptr
ImportVersion, WhatsImported(..),
RdrAvailInfo )
-import RdrName ( RdrName, mkRdrUnqual, mkSysQual, mkSysUnqual )
+import RdrName ( RdrName, mkRdrIfaceUnqual, mkIfaceOrig )
import Name ( OccName )
import OccName ( mkSysOccFS,
tcName, varName, ipName, dataName, clsName, tvName, uvName,
: var_fs { mkSysOccFS varName $1 }
var_name :: { RdrName }
-var_name : var_occ { mkRdrUnqual $1 }
+var_name : var_occ { mkRdrIfaceUnqual $1 }
qvar_name :: { RdrName }
qvar_name : var_name { $1 }
- | qvar_fs { mkSysQual varName $1 }
+ | qvar_fs { mkIfaceOrig varName $1 }
ipvar_name :: { RdrName }
- : IPVARID { mkSysUnqual ipName (tailFS $1) }
+ : IPVARID { mkRdrIfaceUnqual (mkSysOccFS ipName (tailFS $1)) }
var_names :: { [RdrName] }
var_names : { [] }
: data_fs { mkSysOccFS dataName $1 }
data_name :: { RdrName }
- : data_occ { mkRdrUnqual $1 }
+ : data_occ { mkRdrIfaceUnqual $1 }
qdata_name :: { RdrName }
qdata_name : data_name { $1 }
- | qdata_fs { mkSysQual dataName $1 }
+ | qdata_fs { mkIfaceOrig dataName $1 }
var_or_data_name :: { RdrName }
: var_name { $1 }
| data_name { $1 }
---------------------------------------------------
-tc_fs :: { EncodedFS }
- : data_fs { $1 }
-
tc_occ :: { OccName }
- : tc_fs { mkSysOccFS tcName $1 }
+ : data_fs { mkSysOccFS tcName $1 }
tc_name :: { RdrName }
- : tc_occ { mkRdrUnqual $1 }
+ : tc_occ { mkRdrIfaceUnqual $1 }
qtc_name :: { RdrName }
: tc_name { $1 }
- | qdata_fs { mkSysQual tcName $1 }
+ | qdata_fs { mkIfaceOrig tcName $1 }
---------------------------------------------------
cls_name :: { RdrName }
- : data_fs { mkSysUnqual clsName $1 }
+ : data_fs { mkRdrIfaceUnqual (mkSysOccFS clsName $1) }
qcls_name :: { RdrName }
: cls_name { $1 }
- | qdata_fs { mkSysQual clsName $1 }
+ | qdata_fs { mkIfaceOrig clsName $1 }
---------------------------------------------------
uv_name :: { RdrName }
- : VARID { mkSysUnqual uvName $1 }
+ : VARID { mkRdrIfaceUnqual (mkSysOccFS uvName $1) }
uv_bndr :: { RdrName }
: uv_name { $1 }
---------------------------------------------------
tv_name :: { RdrName }
- : VARID { mkSysUnqual tvName $1 }
- | VARSYM { mkSysUnqual tvName $1 {- Allow t2 as a tyvar -} }
+ : VARID { mkRdrIfaceUnqual (mkSysOccFS tvName $1) }
+ | VARSYM { mkRdrIfaceUnqual (mkSysOccFS tvName $1) {- Allow t2 as a tyvar -} }
tv_bndr :: { HsTyVarBndr RdrName }
: tv_name '::' akind { IfaceTyVar $1 $3 }
import HsSyn
import RdrHsSyn ( RdrNameIE )
-import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual,
- mkRdrUnqual, qualifyRdrName, lookupRdrEnv
+import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isSourceQual, isUnqual, isIface,
+ mkRdrUnqual, mkRdrIfaceUnqual, qualifyRdrName, lookupRdrEnv
)
import HsTypes ( hsTyVarName, replaceTyVarName )
import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv,
import OccName ( OccName, occNameUserString, occNameFlavour )
import Module ( ModuleName, moduleName, mkVanillaModule, mkSysModuleNameFS, moduleNameFS )
import FiniteMap
-import Unique ( Unique )
import UniqSupply
import SrcLoc ( SrcLoc, noSrcLoc )
import Outputable
-- 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
+ (if isSourceQual rdr_name then
qualNameErr (text "its declaration") (rdr_name,loc)
else
returnRn ()
Nothing -> lookupTopBndrRn rdr_name
lookupTopBndrRn rdr_name
- = getModeRn `thenRn` \ mode ->
- case mode of
- InterfaceMode -> -- Look in the global name cache
- lookupOrigName rdr_name
-
- SourceMode -> -- 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 ->
- case lookupRdrEnv global_env (qualifyRdrName (moduleName mod) rdr_name) of
- Just ((name,_):rest) -> ASSERT( null rest )
- returnRn name
- Nothing -> -- Almost always this case is a compiler bug.
- -- But consider a type signature that doesn't have
- -- a corresponding binder:
- -- module M where { f :: Int->Int }
- -- We use lookupSigOccRn, which uses lookupBndrRn (for good reasons)
- -- and we don't want to panic. So we report an out-of-scope error
- failWithRn (mkUnboundName rdr_name)
- (unknownNameErr 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)
-- lookupSigOccRn is used for type signatures and pragmas
-- Is this valid?
-- environment. It's used only for
-- record field names
-- class op names in class and instance decls
+
lookupGlobalOccRn rdr_name
- = getModeRn `thenRn` \ mode ->
- case mode of {
- -- When processing interface files, the global env
- -- is always empty, so go straight to the name cache
- InterfaceMode -> lookupOrigName rdr_name ;
+ | isIface rdr_name
+ = lookupOrigName rdr_name
- SourceMode ->
+ | otherwise
+ = lookupSrcGlobalOcc rdr_name
- getGlobalNameEnv `thenRn` \ global_env ->
+lookupSrcGlobalOcc rdr_name
+ -- Lookup a source-code rdr-name
+ = getGlobalNameEnv `thenRn` \ global_env ->
case lookupRdrEnv global_env rdr_name of
- Just [(name,_)] -> returnRn name
- Just stuff@((name,_):_)
- -> addNameClashErrRn rdr_name stuff `thenRn_`
- returnRn name
- Nothing -> -- Not found when processing source code; so fail
- failWithRn (mkUnboundName rdr_name)
- (unknownNameErr rdr_name)
- }
+ 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
\begin{code}
lookupOrigName :: RdrName -> RnM d Name
lookupOrigName rdr_name
- | isQual rdr_name
- = newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
-
- | otherwise
- = -- An Unqual is allowed; interface files contain
+ = 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)
+ getModuleRn `thenRn ` \ mod ->
+ newGlobalName (moduleName mod) (rdrNameOcc rdr_name)
lookupOrigNames :: [RdrName] -> RnM d NameSet
lookupOrigNames rdr_names
%*********************************************************
\begin{code}
-newLocalsRn :: (Unique -> OccName -> SrcLoc -> Name)
- -> [(RdrName,SrcLoc)]
+newLocalsRn :: [(RdrName,SrcLoc)]
-> RnMS [Name]
-newLocalsRn mk_name rdr_names_w_loc
+newLocalsRn rdr_names_w_loc
= getNameSupplyRn `thenRn` \ (us, cache, ipcache) ->
let
n = length rdr_names_w_loc
(us', us1) = splitUniqSupply us
uniqs = uniqsFromSupply n us1
- names = [ mk_name uniq (rdrNameOcc rdr_name) loc
+ names = [ mkLocalName uniq (rdrNameOcc rdr_name) loc
| ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs
]
in
-- Check for duplicate names
checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
- doptRn Opt_WarnNameShadowing `thenRn` \ warn_shadow ->
+ doptRn Opt_WarnNameShadowing `thenRn` \ warn_shadow ->
-- Warn about shadowing, but only in source modules
(case mode of
other -> returnRn ()
) `thenRn_`
- let
- mk_name = case mode of
- SourceMode -> mkLocalName
- InterfaceMode -> mkImportedLocalName
- -- Keep track of whether the name originally came from
- -- an interface file.
- in
- newLocalsRn mk_name rdr_names_w_loc `thenRn` \ names ->
+ newLocalsRn rdr_names_w_loc `thenRn` \ names ->
let
new_local_env = addListToRdrEnv name_env (map fst rdr_names_w_loc `zip` names)
in
thing_inside (name':names')
bindLocalNames names enclosed_scope
- = getLocalNameEnv `thenRn` \ name_env ->
+ = 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 ->
setLocalNameEnv (addListToRdrEnv name_env pairs)
enclosed_scope
- where
- pairs = [(mkRdrUnqual (nameOccName n), n) | n <- names]
-------------------------------------
bindLocalRn doc rdr_name enclosed_scope
mapRn_ (qualNameErr doc_str) quals `thenRn_`
checkDupNames doc_str rdr_names_w_loc
where
- quals = filter (isQual.fst) rdr_names_w_loc
+ quals = filter (isSourceQual . fst) rdr_names_w_loc
checkDupNames doc_str rdr_names_w_loc
= -- Check for duplicated names in a binding group
#include "HsVersions.h"
-import CmdLineOpts ( DynFlag(..), opt_NoImplicitPrelude )
+import CmdLineOpts ( DynFlag(..) )
import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..),
ForeignDecl(..), ForKind(..), isDynamicExtName,
-- PROCESS IMPORT DECLS
-- Do the non {- SOURCE -} ones first, so that we get a helpful
-- warning for {- SOURCE -} ones that are unnecessary
+ doptRn Opt_NoImplicitPrelude `thenRn` \ opt_no_prelude ->
let
+ all_imports = mk_prel_imports opt_no_prelude ++ imports
(source, ordinary) = partition is_source_import all_imports
is_source_import (ImportDecl _ ImportByUserSource _ _ _ _) = True
is_source_import other = False
)
where
this_mod_name = moduleName this_mod
- all_imports = prel_imports ++ imports
-- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();
-- because the former doesn't even look at Prelude.hi for instance declarations,
-- whereas the latter does.
- prel_imports | this_mod_name == pRELUDE_Name ||
- explicit_prelude_import ||
- opt_NoImplicitPrelude
- = []
-
- | otherwise = [ImportDecl pRELUDE_Name
- ImportByUser
- False {- Not qualified -}
- Nothing {- No "as" -}
- Nothing {- No import list -}
- mod_loc]
+ mk_prel_imports no_prelude
+ | this_mod_name == pRELUDE_Name ||
+ explicit_prelude_import ||
+ no_prelude
+ = []
+
+ | otherwise = [ImportDecl pRELUDE_Name
+ ImportByUser
+ False {- Not qualified -}
+ Nothing {- No "as" -}
+ Nothing {- No import list -}
+ mod_loc]
explicit_prelude_import
= not (null [ () | (ImportDecl mod _ _ _ _ _) <- imports, mod == pRELUDE_Name ])
returnRn [avail]
| otherwise -- a foreign export
- = lookupOrigName nm `thenRn_`
- returnRn []
+ = returnRn []
where
binds_haskell_name (FoImport _) = True
binds_haskell_name FoLabel = True
not (tv `elemRdrEnv` name_env)]
in
checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_`
- newLocalsRn mkLocalName gen_rdr_tyvars_w_locs `thenRn` \ gen_tyvars ->
+ newLocalsRn gen_rdr_tyvars_w_locs `thenRn` \ gen_tyvars ->
rnMethodBinds gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) ->
returnRn (ClassDecl context cname tyvars fds sigs mbinds' names src_loc, meth_fvs)
where
-- for the fromT and toT conversion functions.
mkTyConGenInfo dflags tycon from_name to_name
- | dopt Opt_Generics dflags
+ | not (dopt Opt_Generics dflags)
= Nothing
| null datacons -- Abstractly imported types don't have
go env msgs [] = (env, msgs)
go env msgs (dfun:dfuns) = case addToInstEnv dflags env dfun of
Succeeded new_env -> go new_env msgs dfuns
- Failed dfun' -> go env (msg:msgs) infos
+ Failed dfun' -> go env (msg:msgs) dfuns
where
msg = dupInstErr dfun dfun'
projects / ghc-hetmet.git / commitdiff