From 5e6242927839c8ddc73a55eb7828c0b7e4cc3ab2 Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 20 Feb 2001 09:40:45 +0000 Subject: [PATCH] [project @ 2001-02-20 09:40:43 by simonpj] Decoupling the Prelude [HsExpr, HsLit, HsPat, ParseUtil, Parser.y, PrelNames, ~~~~~~~~~~~~~~~~~~~~~~ Rename, RnEnv, RnExpr, RnHsSyn, Inst, TcEnv, TcMonad, TcPat, TcExpr] The -fno-implicit-prelude flag is meant to arrange that when you write 3 you get fromInt 3 where 'fromInt' is whatever fromInt is in scope at the top level of the module being compiled. Similarly for * numeric patterns * n+k patterns * negation This used to work, but broke when we made the static/dynamic flag distinction. It's now tidied up a lot. Here's the plan: - PrelNames contains sugarList :: SugarList, which maps built-in names to the RdrName that should replace them. - The renamer makes a finite map :: SugarMap, which maps the built-in names to the Name of the re-mapped thing - The typechecker consults this map via tcLookupSyntaxId when it is doing numeric things At present I've only decoupled numeric syntax, since that is the main demand, but the scheme is much more robustly extensible than the previous method. As a result some HsSyn constructors don't need to carry names in them (notably HsOverLit, NegApp, NPlusKPatIn) --- ghc/compiler/hsSyn/HsExpr.lhs | 5 +- ghc/compiler/hsSyn/HsLit.lhs | 30 +++--- ghc/compiler/hsSyn/HsPat.lhs | 14 +-- ghc/compiler/parser/ParseUtil.lhs | 4 +- ghc/compiler/parser/Parser.y | 10 +- ghc/compiler/prelude/PrelNames.lhs | 48 +++++++++ ghc/compiler/rename/Rename.lhs | 178 ++++++++------------------------- ghc/compiler/rename/RnEnv.lhs | 194 +++++++++++++++++++++++++++++------- ghc/compiler/rename/RnExpr.lhs | 56 +++++------ ghc/compiler/rename/RnHsSyn.lhs | 1 - ghc/compiler/typecheck/Inst.lhs | 26 ++--- ghc/compiler/typecheck/TcEnv.lhs | 27 ++++- ghc/compiler/typecheck/TcExpr.lhs | 9 +- ghc/compiler/typecheck/TcMonad.lhs | 7 +- ghc/compiler/typecheck/TcPat.lhs | 13 +-- 15 files changed, 353 insertions(+), 269 deletions(-) diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 4ba2e2a..5c5f095 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -38,7 +38,7 @@ import SrcLoc ( SrcLoc ) data HsExpr id pat = HsVar id -- variable | HsIPVar id -- implicit parameter - | HsOverLit (HsOverLit id) -- Overloaded literals; eliminated by type checker + | HsOverLit HsOverLit -- Overloaded literals; eliminated by type checker | HsLit HsLit -- Simple (non-overloaded) literals | HsLam (Match id pat) -- lambda @@ -60,7 +60,6 @@ data HsExpr id pat -- They are eventually removed by the type checker. | NegApp (HsExpr id pat) -- negated expr - id -- the negate id (in a HsVar) | HsPar (HsExpr id pat) -- parenthesised expr @@ -250,7 +249,7 @@ ppr_expr (OpApp e1 op fixity e2) | otherwise = char '`' <> ppr v <> char '`' -- Put it in backquotes if it's not an operator already -ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e +ppr_expr (NegApp e) = char '-' <+> pprParendExpr e ppr_expr (HsPar e) = parens (ppr_expr e) diff --git a/ghc/compiler/hsSyn/HsLit.lhs b/ghc/compiler/hsSyn/HsLit.lhs index f75c0a7..7111cbd 100644 --- a/ghc/compiler/hsSyn/HsLit.lhs +++ b/ghc/compiler/hsSyn/HsLit.lhs @@ -41,21 +41,19 @@ data HsLit -- before the typechecker it's just an error value deriving( Eq ) -data HsOverLit name -- An overloaded literal - = HsIntegral Integer name -- Integer-looking literals; - -- The names is "fromInteger" - | HsFractional Rational name -- Frac-looking literals - -- The name is "fromRational" +data HsOverLit -- An overloaded literal + = HsIntegral Integer -- Integer-looking literals; + | HsFractional Rational -- Frac-looking literals -instance Eq (HsOverLit name) where - (HsIntegral i1 _) == (HsIntegral i2 _) = i1 == i2 - (HsFractional f1 _) == (HsFractional f2 _) = f1 == f2 +instance Eq HsOverLit where + (HsIntegral i1) == (HsIntegral i2) = i1 == i2 + (HsFractional f1) == (HsFractional f2) = f1 == f2 -instance Ord (HsOverLit name) where - compare (HsIntegral i1 _) (HsIntegral i2 _) = i1 `compare` i2 - compare (HsIntegral _ _) (HsFractional _ _) = LT - compare (HsFractional f1 _) (HsFractional f2 _) = f1 `compare` f2 - compare (HsFractional f1 _) (HsIntegral _ _) = GT +instance Ord HsOverLit where + compare (HsIntegral i1) (HsIntegral i2) = i1 `compare` i2 + compare (HsIntegral _) (HsFractional _) = LT + compare (HsFractional f1) (HsFractional f2) = f1 `compare` f2 + compare (HsFractional f1) (HsIntegral _) = GT \end{code} \begin{code} @@ -73,9 +71,9 @@ instance Outputable HsLit where ppr (HsIntPrim i) = integer i <> char '#' ppr (HsLitLit s _) = hcat [text "``", ptext s, text "''"] -instance Outputable (HsOverLit name) where - ppr (HsIntegral i _) = integer i - ppr (HsFractional f _) = rational f +instance Outputable HsOverLit where + ppr (HsIntegral i) = integer i + ppr (HsFractional f) = rational f \end{code} diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index 62c4600..e8c9296 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -52,14 +52,10 @@ data InPat name Fixity -- c.f. OpApp in HsExpr (InPat name) - | NPatIn (HsOverLit name) + | NPatIn HsOverLit | NPlusKPatIn name -- n+k pattern - (HsOverLit name) -- It'll always be an HsIntegral, but - -- we need those names to support -fuser-numerics - name -- Name for "-"; this supports -fuser-numerics - -- We don't do the same for >= because that isn't - -- affected by -fuser-numerics + HsOverLit -- It'll always be an HsIntegral -- We preserve prefix negation and parenthesis for the precedence parser. @@ -154,7 +150,7 @@ pprInPat (AsPatIn name pat) = parens (hcat [ppr name, char '@', ppr pat]) pprInPat (ParPatIn pat) = parens (pprInPat pat) pprInPat (ListPatIn pats) = brackets (interpp'SP pats) pprInPat (TuplePatIn pats bx) = tupleParens bx (interpp'SP pats) -pprInPat (NPlusKPatIn n k _) = parens (hcat [ppr n, char '+', ppr k]) +pprInPat (NPlusKPatIn n k) = parens (hcat [ppr n, char '+', ppr k]) pprInPat (NPatIn l) = ppr l pprInPat (ConPatIn c pats) @@ -320,7 +316,7 @@ collect (LitPatIn _) bndrs = bndrs collect (SigPatIn pat _) bndrs = collect pat bndrs collect (LazyPatIn pat) bndrs = collect pat bndrs collect (AsPatIn a pat) bndrs = a : collect pat bndrs -collect (NPlusKPatIn n _ _) bndrs = n : bndrs +collect (NPlusKPatIn n _) bndrs = n : bndrs collect (NPatIn _) bndrs = bndrs collect (ConPatIn c pats) bndrs = foldr collect bndrs pats collect (ConOpPatIn p1 c f p2) bndrs = collect p1 (collect p2 bndrs) @@ -344,7 +340,7 @@ collect_pat (LitPatIn _) acc = acc collect_pat (LazyPatIn pat) acc = collect_pat pat acc collect_pat (AsPatIn a pat) acc = collect_pat pat acc collect_pat (NPatIn _) acc = acc -collect_pat (NPlusKPatIn n _ _) acc = acc +collect_pat (NPlusKPatIn n _) acc = acc collect_pat (ConPatIn c pats) acc = foldr collect_pat acc pats collect_pat (ConOpPatIn p1 c f p2) acc = collect_pat p1 (collect_pat p2 acc) collect_pat (ParPatIn pat) acc = collect_pat pat acc diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index a040db9..6e2de99 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -200,9 +200,9 @@ checkPat e [] = case e of in returnP (SigPatIn e t') - OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral k _)) + OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral k)) | plus == plus_RDR - -> returnP (NPlusKPatIn n lit minus_RDR) + -> returnP (NPlusKPatIn n lit) where plus_RDR = mkUnqual varName SLIT("+") -- Hack diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 5264cad..2bb9d39 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.52 2001/02/11 09:36:00 qrczak Exp $ +$Id: Parser.y,v 1.53 2001/02/20 09:40:43 simonpj Exp $ Haskell grammar. @@ -18,7 +18,9 @@ import RdrHsSyn import Lex import ParseUtil import RdrName -import PrelNames +import PrelNames ( mAIN_Name, unitTyCon_RDR, funTyCon_RDR, listTyCon_RDR, + tupleTyCon_RDR, unitCon_RDR, nilCon_RDR, tupleCon_RDR + ) import OccName ( UserFS, varName, ipName, tcName, dataName, tcClsName, tvName ) import SrcLoc ( SrcLoc ) import Module @@ -737,8 +739,8 @@ aexp1 :: { RdrNameHsExpr } : ipvar { HsIPVar $1 } | var_or_con { $1 } | literal { HsLit $1 } - | INTEGER { HsOverLit (HsIntegral $1 fromInteger_RDR) } - | RATIONAL { HsOverLit (HsFractional $1 fromRational_RDR) } + | INTEGER { HsOverLit (HsIntegral $1) } + | RATIONAL { HsOverLit (HsFractional $1) } | '(' exp ')' { HsPar $2 } | '(' exp ',' texps ')' { ExplicitTuple ($2 : reverse $4) Boxed} | '(#' texps '#)' { ExplicitTuple (reverse $2) Unboxed } diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index 91530c6..cf2e96d 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -22,6 +22,8 @@ module PrelNames ( knownKeyNames, mkTupNameStr, mkTupConRdrName, + SyntaxMap, vanillaSyntaxMap, SyntaxList, syntaxList, + ------------------------------------------------------------ -- Goups of classes and types needsDataDeclCtxtClassKeys, cCallishClassKeys, noDictClassKeys, @@ -109,6 +111,7 @@ knownKeyNames -- ClassOps fromIntName, fromIntegerName, + negateName, geName, minusName, enumFromName, @@ -376,6 +379,7 @@ numClassName = clsQual pREL_NUM_Name SLIT("Num") numClassKey fromIntName = varQual pREL_NUM_Name SLIT("fromInt") fromIntClassOpKey fromIntegerName = varQual pREL_NUM_Name SLIT("fromInteger") fromIntegerClassOpKey minusName = varQual pREL_NUM_Name SLIT("-") minusClassOpKey +negateName = varQual pREL_NUM_Name SLIT("negate") negateClassOpKey plusIntegerName = varQual pREL_NUM_Name SLIT("plusInteger") plusIntegerIdKey timesIntegerName = varQual pREL_NUM_Name SLIT("timesInteger") timesIntegerIdKey integerTyConName = tcQual pREL_NUM_Name SLIT("Integer") integerTyConKey @@ -814,6 +818,7 @@ enumFromToClassOpKey = mkPreludeMiscIdUnique 107 enumFromThenToClassOpKey = mkPreludeMiscIdUnique 108 eqClassOpKey = mkPreludeMiscIdUnique 109 geClassOpKey = mkPreludeMiscIdUnique 110 +negateClassOpKey = mkPreludeMiscIdUnique 111 failMClassOpKey = mkPreludeMiscIdUnique 112 thenMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=) -- Just a place holder for unbound variables produced by the renamer: @@ -873,6 +878,49 @@ cCallishTyKeys = %************************************************************************ %* * +\subsection{Re-bindable desugaring names} +%* * +%************************************************************************ + +Haskell 98 says that when you say "3" you get the "fromInt" 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.fromInt" +happens to be in scope. Then you can + import Prelude () + import MyPrelude as Prelude +to get the desired effect. + +The SyntaxNames record gives all the names you can rebind in this way. +This record of names needs to go through the renamer to map RdrNames to +Names (i.e. look up the names in the in-scope environment), to suck in +their type signatures from interface file(s). + +\begin{code} +type SyntaxList = [(Name, RdrName)] + -- Maps a Name, which identifies the standard built-in thing + -- to a RdrName for the re-mapped version of the built-in thing + +syntaxList :: SyntaxList +syntaxList =[ (fromIntName, mkUnqual varName SLIT("fromInt")) + , (fromIntegerName, mkUnqual varName SLIT("fromInteger")) + , (fromRationalName, mkUnqual varName SLIT("fromRational")) + , (negateName, mkUnqual varName SLIT("negate")) + , (minusName, mkUnqual varName SLIT("-")) + -- For now that's all. We may add booleans and lists later. + ] + + +type SyntaxMap = Name -> Name + -- Maps a standard built-in name, such as PrelNum.fromInt + -- to its re-mapped version, such as MyPrelude.fromInt + +vanillaSyntaxMap name = name +\end{code} + + +%************************************************************************ +%* * \subsection[Class-std-groups]{Standard groups of Prelude classes} %* * %************************************************************************ diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 06f0a08..90027bb 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -23,45 +23,36 @@ import RnExpr ( rnExpr ) import RnNames ( getGlobalNames, exportsFromAvail ) import RnSource ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl ) import RnIfaces ( slurpImpDecls, mkImportInfo, recordLocalSlurps, - getInterfaceExports, closeDecls, + closeDecls, RecompileRequired, outOfDate, recompileRequired ) import RnHiFiles ( readIface, removeContext, loadInterface, loadExports, loadFixDecls, loadDeprecs, tryLoadInterface ) -import RnEnv ( availsToNameSet, availName, mkIfaceGlobalRdrEnv, +import RnEnv ( availsToNameSet, mkIfaceGlobalRdrEnv, emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, groupAvails, warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules, - lookupOrigNames, lookupSrcName, - newGlobalName, unQualInScope + lookupSrcName, addImplicitFVs, + newGlobalName, unQualInScope,, ubiquitousNames ) import Module ( Module, ModuleName, WhereFrom(..), moduleNameUserString, moduleName, moduleEnvElts ) -import Name ( Name, NamedThing(..), getSrcLoc, +import Name ( Name, NamedThing(..), nameIsLocalOrFrom, nameOccName, nameModule, ) import Name ( mkNameEnv, nameEnvElts, extendNameEnv ) import RdrName ( foldRdrEnv, isQual ) -import OccName ( occNameFlavour ) import NameSet -import TysWiredIn ( unitTyCon, intTyCon, boolTyCon ) -import PrelNames ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name, - ioTyConName, printName, - unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, - eqStringName - ) -import PrelInfo ( derivingOccurrences ) -import Type ( funTyCon ) +import PrelNames ( SyntaxMap, pRELUDE_Name ) import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass, printErrorsAndWarnings, errorsFound ) import Bag ( bagToList ) import FiniteMap ( FiniteMap, fmToList, emptyFM, lookupFM, addToFM_C, elemFM, addToFM ) -import UniqFM ( lookupWithDefaultUFM ) import Maybes ( maybeToBool, catMaybes ) import Outputable import IO ( openFile, IOMode(..) ) @@ -69,10 +60,10 @@ import HscTypes ( PersistentCompilerState, HomeIfaceTable, HomeSymbolTable, ModIface(..), WhatsImported(..), VersionInfo(..), ImportVersion, IsExported, IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, - GlobalRdrEnv, pprGlobalRdrEnv, + GlobalRdrEnv, GlobalRdrElt(..), pprGlobalRdrEnv, AvailEnv, GenAvailInfo(..), AvailInfo, Avails, Provenance(..), ImportReason(..), initialVersionInfo, - Deprecations(..), lookupDeprec, lookupIface + Deprecations(..) ) import CmStaticInfo ( GhciMode(..) ) import List ( partition, nub ) @@ -92,7 +83,8 @@ renameModule :: DynFlags -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState -> Module -> RdrNameHsModule - -> IO (PersistentCompilerState, Maybe (PrintUnqualified, (IsExported, ModIface, [RenamedHsDecl]))) + -> IO (PersistentCompilerState, + Maybe (PrintUnqualified, (IsExported, ModIface, (SyntaxMap, [RenamedHsDecl])))) -- Nothing => some error occurred in the renamer renameModule dflags hit hst pcs this_module rdr_module @@ -107,7 +99,7 @@ renameExpr :: DynFlags -> PersistentCompilerState -> Module -> RdrNameHsExpr -> IO ( PersistentCompilerState, - Maybe (PrintUnqualified, (RenamedHsExpr, [RenamedHsDecl])) + Maybe (PrintUnqualified, (SyntaxMap, RenamedHsExpr, [RenamedHsDecl])) ) renameExpr dflags hit hst pcs this_module expr @@ -136,16 +128,11 @@ renameExpr dflags hit hst pcs this_module expr returnRn Nothing else - let - implicit_fvs = fvs `plusFV` string_names - `plusFV` default_tycon_names - `plusFV` unitFV printName - -- print :: a -> IO () may be needed later - in - slurpImpDecls (fvs `plusFV` implicit_fvs) `thenRn` \ decls -> + addImplicitFVs rdr_env Nothing fvs `thenRn` \ (slurp_fvs, syntax_map) -> + slurpImpDecls slurp_fvs `thenRn` \ decls -> doDump e decls `thenRn_` - returnRn (Just (print_unqual, (e, decls))) + returnRn (Just (print_unqual, (syntax_map, e, decls))) } where doc = text "context for compiling expression" @@ -195,7 +182,8 @@ renameSource dflags hit hst old_pcs this_module thing_inside \end{code} \begin{code} -rename :: Module -> RdrNameHsModule -> RnMG (Maybe (PrintUnqualified, (IsExported, ModIface, [RenamedHsDecl]))) +rename :: Module -> RdrNameHsModule + -> RnMG (Maybe (PrintUnqualified, (IsExported, ModIface, (SyntaxMap, [RenamedHsDecl])))) rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec loc) = pushSrcLocRn loc $ @@ -239,13 +227,8 @@ rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec else -- SLURP IN ALL THE NEEDED DECLARATIONS - implicitFVs mod_name rn_local_decls `thenRn` \ implicit_fvs -> - let - slurp_fvs = implicit_fvs `plusFV` source_fvs - -- It's important to do the "plus" this way round, so that - -- when compiling the prelude, locally-defined (), Bool, etc - -- override the implicit ones. - in + addImplicitFVs gbl_env (Just (mod_name, rn_local_decls)) + source_fvs `thenRn` \ (slurp_fvs, sugar_map) -> traceRn (text "Source FVs:" <+> fsep (map ppr (nameSetToList slurp_fvs))) `thenRn_` slurpImpDecls slurp_fvs `thenRn` \ rn_imp_decls -> @@ -290,47 +273,11 @@ rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec imports global_avail_env source_fvs export_avails rn_imp_decls `thenRn_` - returnRn (Just (print_unqualified, (is_exported, mod_iface, final_decls))) + returnRn (Just (print_unqualified, (is_exported, mod_iface, (sugar_map, final_decls)))) where mod_name = moduleName this_module \end{code} -@implicitFVs@ forces the renamer to slurp in some things which aren't -mentioned explicitly, but which might be needed by the type checker. - -\begin{code} -implicitFVs mod_name decls - = lookupOrigNames deriv_occs `thenRn` \ deriving_names -> - returnRn (default_tycon_names `plusFV` - string_names `plusFV` - deriving_names `plusFV` - implicit_main) - where - - -- Add occurrences for IO or PrimIO - implicit_main | mod_name == mAIN_Name - || mod_name == pREL_MAIN_Name = unitFV ioTyConName - | otherwise = emptyFVs - - deriv_occs = [occ | TyClD (TyData {tcdDerivs = Just deriv_classes}) <- decls, - cls <- deriv_classes, - occ <- lookupWithDefaultUFM derivingOccurrences [] cls ] - --- Virtually every program has error messages in it somewhere -string_names = mkFVs [unpackCStringName, unpackCStringFoldrName, - unpackCStringUtf8Name, eqStringName] - --- Add occurrences for Int, and (), because they --- are the types to which ambigious type variables may be defaulted by --- the type checker; so they won't always appear explicitly. --- [The () one is a GHC extension for defaulting CCall results.] --- ALSO: funTyCon, since it occurs implicitly everywhere! --- (we don't want to be bothered with making funTyCon a --- free var at every function application!) --- Double is dealt with separately in getGates -default_tycon_names = mkFVs (map getName [unitTyCon, funTyCon, boolTyCon, intTyCon]) -\end{code} - \begin{code} isOrphanDecl this_mod (InstD (InstDecl inst_ty _ _ _ _)) = not (foldNameSet ((||) . nameIsLocalOrFrom this_mod) False @@ -351,7 +298,7 @@ isOrphanDecl this_mod (RuleD (HsRule _ _ _ lhs _ _)) check (HsLit _) = False check (HsOverLit _) = False check (OpApp l o _ r) = check l && check o && check r - check (NegApp e _) = check e + check (NegApp e) = check e check (HsPar e) = check e check (SectionL e o) = check e && check o check (SectionR o e) = check e && check o @@ -610,9 +557,9 @@ closeIfaceDecls dflags hit hst pcs rnDump [] closed_decls `thenRn_` returnRn closed_decls where - implicit_fvs = string_names -- Data type decls with record selectors, - -- which may appear in the decls, need unpackCString - -- and friends. It's easier to just grab them right now. + implicit_fvs = ubiquitousNames -- Data type decls with record selectors, + -- which may appear in the decls, need unpackCString + -- and friends. It's easier to just grab them right now. \end{code} %********************************************************* @@ -634,14 +581,10 @@ reportUnusedNames my_mod_iface unqual imports avail_env = warnUnusedModules unused_imp_mods `thenRn_` warnUnusedLocalBinds bad_locals `thenRn_` warnUnusedImports bad_imp_names `thenRn_` - printMinimalImports this_mod unqual minimal_imports `thenRn_` - warnDeprecations this_mod export_avails my_deprecs - really_used_names - + printMinimalImports this_mod unqual minimal_imports where this_mod = mi_module my_mod_iface gbl_env = mi_globals my_mod_iface - my_deprecs = mi_deprecs my_mod_iface -- The export_fvs make the exported names look just as if they -- occurred in the source program. @@ -669,21 +612,21 @@ reportUnusedNames my_mod_iface unqual imports avail_env -- Collect the defined names from the in-scope environment -- Look for the qualified ones only, else get duplicates - defined_names :: [(Name,Provenance)] + defined_names :: [GlobalRdrElt] defined_names = foldRdrEnv add [] gbl_env add rdr_name ns acc | isQual rdr_name = ns ++ acc | otherwise = acc - defined_and_used, defined_but_not_used :: [(Name,Provenance)] + defined_and_used, defined_but_not_used :: [GlobalRdrElt] (defined_and_used, defined_but_not_used) = partition used defined_names - used (name,_) = name `elemNameSet` really_used_names + used (GRE name _ _) = name `elemNameSet` really_used_names -- Filter out the ones only defined implicitly bad_locals :: [Name] - bad_locals = [n | (n,LocalDef) <- defined_but_not_used] + bad_locals = [n | (GRE n LocalDef _) <- defined_but_not_used] bad_imp_names :: [(Name,Provenance)] - bad_imp_names = [(n,p) | (n,p@(NonLocalDef (UserImport mod _ True))) <- defined_but_not_used, + bad_imp_names = [(n,p) | GRE n p@(NonLocalDef (UserImport mod _ True)) _ <- defined_but_not_used, not (module_unused mod)] -- inst_mods are directly-imported modules that @@ -719,9 +662,9 @@ reportUnusedNames my_mod_iface unqual imports avail_env -- We've carefully preserved the provenance so that we can -- construct minimal imports that import the name by (one of) -- the same route(s) as the programmer originally did. - add_name (n,NonLocalDef (UserImport m _ _)) acc = addToFM_C plusAvailEnv acc (moduleName m) - (unitAvailEnv (mk_avail n)) - add_name (n,other_prov) acc = acc + add_name (GRE n (NonLocalDef (UserImport m _ _)) _) acc = addToFM_C plusAvailEnv acc (moduleName m) + (unitAvailEnv (mk_avail n)) + add_name (GRE n other_prov _) acc = acc mk_avail n = case lookupNameEnv avail_env n of Just (AvailTC m _) | n==m -> AvailTC n [n] @@ -747,46 +690,12 @@ reportUnusedNames my_mod_iface unqual imports avail_env module_unused :: Module -> Bool module_unused mod = moduleName mod `elem` unused_imp_mods -warnDeprecations this_mod export_avails my_deprecs used_names - = doptRn Opt_WarnDeprecations `thenRn` \ warn_drs -> - if not warn_drs then returnRn () else - - -- The home modules for things in the export list - -- may not have been loaded yet; do it now, so - -- that we can see their deprecations, if any - mapRn_ load_home export_mods `thenRn_` - - getIfacesRn `thenRn` \ ifaces -> - getHomeIfaceTableRn `thenRn` \ hit -> - let - pit = iPIT ifaces - deprecs = [ (n,txt) - | n <- nameSetToList used_names, - not (nameIsLocalOrFrom this_mod n), - Just txt <- [lookup_deprec hit pit n] ] - -- nameIsLocalOrFrom: don't complain about locally defined names - -- For a start, we may be exporting a deprecated thing - -- Also we may use a deprecated thing in the defn of another - -- deprecated things. We may even use a deprecated thing in - -- the defn of a non-deprecated thing, when changing a module's - -- interface - in - mapRn_ warnDeprec deprecs - - where - export_mods = nub [ moduleName mod - | avail <- export_avails, - let mod = nameModule (availName avail), - mod /= this_mod ] - - load_home m = loadInterface (text "Check deprecations for" <+> ppr m) m ImportBySystem - - lookup_deprec hit pit n - = case lookupIface hit pit n of - Just iface -> lookupDeprec (mi_deprecs iface) n - Nothing -> pprPanic "warnDeprecations:" (ppr n) -- ToDo: deal with original imports with 'qualified' and 'as M' clauses +printMinimalImports :: Module -- This module + -> PrintUnqualified + -> FiniteMap ModuleName AvailEnv -- Minimal imports + -> RnMG () printMinimalImports this_mod unqual imps = doptRn Opt_D_dump_minimal_imports `thenRn` \ dump_minimal -> if not dump_minimal then returnRn () else @@ -809,12 +718,15 @@ printMinimalImports this_mod unqual imps returnRn (mod, ies) to_ie :: AvailInfo -> RnMG (IE Name) + -- The main trick here is that if we're importing all the constructors + -- we want to say "T(..)", but if we're importing only a subset we want + -- to say "T(A,B,C)". So we have to find out what the module exports. to_ie (Avail n) = returnRn (IEVar n) to_ie (AvailTC n [m]) = ASSERT( n==m ) returnRn (IEThingAbs n) to_ie (AvailTC n ns) - = getInterfaceExports n_mod ImportBySystem `thenRn` \ (_, avails_by_module) -> - case [xs | (m,as) <- avails_by_module, + = loadInterface (text "Compute minimal imports from" <+> ppr n_mod) n_mod ImportBySystem `thenRn` \ iface -> + case [xs | (m,as) <- mi_exports iface, m == n_mod, AvailTC x xs <- as, x == n] of @@ -894,14 +806,6 @@ getRnStats imported_decls ifaces %************************************************************************ \begin{code} -warnDeprec :: (Name, DeprecTxt) -> RnM d () -warnDeprec (name, txt) - = pushSrcLocRn (getSrcLoc 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, diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index fc262ed..582f0aa 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -12,27 +12,38 @@ import {-# SOURCE #-} RnHiFiles import HscTypes ( ModIface(..) ) import HsSyn +import RnHsSyn ( RenamedHsDecl ) import RdrHsSyn ( RdrNameIE ) 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(..), NameSupply(..) ) + ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), AvailEnv, + AvailInfo, Avails, GenAvailInfo(..), NameSupply(..), + Deprecations(..), lookupDeprec + ) import RnMonad import Name ( Name, getSrcLoc, mkLocalName, mkGlobalName, mkIPName, nameOccName, nameModule_maybe, - setNameModuleAndLoc + setNameModuleAndLoc, mkNameEnv ) import Name ( extendNameEnv_C, plusNameEnv_C, nameEnvElts ) import NameSet import OccName ( OccName, occNameUserString, occNameFlavour ) import Module ( ModuleName, moduleName, mkVanillaModule, - mkSysModuleNameFS, moduleNameFS, - WhereFrom(..) ) + mkSysModuleNameFS, moduleNameFS, WhereFrom(..) ) +import TysWiredIn ( unitTyCon, intTyCon, boolTyCon ) +import Type ( funTyCon ) +import PrelNames ( mkUnboundName, syntaxList, SyntaxMap, vanillaSyntaxMap, + derivingOccurrences, + mAIN_Name, pREL_MAIN_Name, + ioTyConName, printName, + unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, + eqStringName + ) import FiniteMap import UniqSupply import SrcLoc ( SrcLoc, noSrcLoc ) @@ -40,7 +51,8 @@ import Outputable import ListSetOps ( removeDups, equivClasses ) import Util ( sortLt ) import List ( nub ) -import PrelNames ( mkUnboundName ) +import UniqFM ( lookupWithDefaultUFM ) +import Maybes ( orElse ) import CmdLineOpts import FastString ( FastString ) \end{code} @@ -62,7 +74,6 @@ newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name newTopBinder mod rdr_name loc = -- First check the cache - -- 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 @@ -92,7 +103,7 @@ newTopBinder mod rdr_name loc new_cache = addToFM cache key new_name in setNameSupplyRn (name_supply {nsNames = new_cache}) `thenRn_` - traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_` +-- traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_` returnRn new_name -- Miss in the cache! @@ -106,7 +117,7 @@ newTopBinder mod rdr_name loc new_cache = addToFM cache key new_name in setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_` - traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_` +-- traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_` returnRn new_name @@ -269,11 +280,13 @@ lookupSrcName global_env rdr_name | otherwise = 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) + Just [GRE name _ Nothing] -> returnRn name + Just [GRE name _ (Just deprec)] -> warnDeprec name deprec `thenRn_` + returnRn name + Just stuff@(GRE name _ _ : _) -> addNameClashErrRn rdr_name stuff `thenRn_` + returnRn name + Nothing -> failWithRn (mkUnboundName rdr_name) + (unknownNameErr rdr_name) lookupOrigName :: RdrName -> RnM d Name lookupOrigName rdr_name @@ -332,6 +345,108 @@ lookupSysBinder rdr_name %********************************************************* %* * +\subsection{Implicit free vars and sugar names} +%* * +%********************************************************* + +@addImplicitFVs@ forces the renamer to slurp in some things which aren't +mentioned explicitly, but which might be needed by the type checker. + +\begin{code} +addImplicitFVs :: GlobalRdrEnv + -> Maybe (ModuleName, [RenamedHsDecl]) -- Nothing when compling an expression + -> FreeVars -- Free in the source + -> RnMG (FreeVars, SyntaxMap) -- Augmented source free vars + +addImplicitFVs gbl_env maybe_mod source_fvs + = -- Find out what re-bindable names to use for desugaring + rnSyntaxNames gbl_env source_fvs `thenRn` \ (source_fvs1, sugar_map) -> + + -- Find implicit FVs thade + extra_implicits maybe_mod `thenRn` \ extra_fvs -> + + let + implicit_fvs = ubiquitousNames `plusFV` extra_fvs + slurp_fvs = implicit_fvs `plusFV` source_fvs1 + -- It's important to do the "plus" this way round, so that + -- when compiling the prelude, locally-defined (), Bool, etc + -- override the implicit ones. + in + returnRn (slurp_fvs, sugar_map) + + where + extra_implicits Nothing -- Compiling an expression + = returnRn (unitFV printName) -- print :: a -> IO () may be needed later + + extra_implicits (Just (mod_name, decls)) -- Compiling a module + = lookupOrigNames deriv_occs `thenRn` \ deriving_names -> + returnRn (deriving_names `plusFV` implicit_main) + where + -- Add occurrences for IO or PrimIO + implicit_main | mod_name == mAIN_Name + || mod_name == pREL_MAIN_Name = unitFV ioTyConName + | otherwise = emptyFVs + + deriv_occs = [occ | TyClD (TyData {tcdDerivs = Just deriv_classes}) <- decls, + cls <- deriv_classes, + occ <- lookupWithDefaultUFM derivingOccurrences [] cls ] + +-- ubiquitous_names are loaded regardless, because +-- they are needed in virtually every program +ubiquitousNames + = mkFVs [unpackCStringName, unpackCStringFoldrName, + unpackCStringUtf8Name, eqStringName] + -- Virtually every program has error messages in it somewhere + + `plusFV` + mkFVs (map getName [unitTyCon, funTyCon, boolTyCon, intTyCon]) + -- Add occurrences for Int, and (), because they + -- are the types to which ambigious type variables may be defaulted by + -- the type checker; so they won't always appear explicitly. + -- [The () one is a GHC extension for defaulting CCall results.] + -- ALSO: funTyCon, since it occurs implicitly everywhere! + -- (we don't want to be bothered with making funTyCon a + -- free var at every function application!) + -- Double is dealt with separately in getGates +\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) + +rnSyntaxNames gbl_env source_fvs + = doptRn Opt_NoImplicitPrelude `thenRn` \ no_prelude -> + if not no_prelude then + returnRn (source_fvs, vanillaSyntaxMap) + 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') + 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) +\end{code} + + +%********************************************************* +%* * \subsection{Binding} %* * %********************************************************* @@ -535,9 +650,11 @@ mkGlobalRdrEnv :: ModuleName -- Imported module (after doing the "as M" name ch -- version is hidden) -> (Name -> Provenance) -> Avails -- Whats imported and how + -> Deprecations -> GlobalRdrEnv -mkGlobalRdrEnv this_mod unqual_imp qual_imp hides mk_provenance avails +mkGlobalRdrEnv this_mod unqual_imp qual_imp hides + mk_provenance avails deprecs = gbl_env2 where -- Make the name environment. We're talking about a @@ -560,11 +677,11 @@ mkGlobalRdrEnv this_mod unqual_imp qual_imp hides mk_provenance avails | 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) + env1 = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) elt + env2 = addOneToGlobalRdrEnv env (mkRdrUnqual occ) elt + env3 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) elt occ = nameOccName name - prov = mk_provenance name + elt = GRE name (mk_provenance name) (lookupDeprec deprecs name) del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names where @@ -578,22 +695,24 @@ mkIfaceGlobalRdrEnv :: [(ModuleName,Avails)] -> GlobalRdrEnv mkIfaceGlobalRdrEnv m_avails = foldl add emptyRdrEnv m_avails where - add env (mod,avails) = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True False [] (\n -> LocalDef) avails) + add env (mod,avails) = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True False [] + (\n -> LocalDef) avails NoDeprecs) + -- The NoDeprecs is a bit of a hack I suppose \end{code} \begin{code} plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2 -addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> (Name,Provenance) -> GlobalRdrEnv +addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrElt -> GlobalRdrEnv addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name] delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name -combine_globals :: [(Name,Provenance)] -- Old - -> [(Name,Provenance)] -- New - -> [(Name,Provenance)] +combine_globals :: [GlobalRdrElt] -- Old + -> [GlobalRdrElt] -- New + -> [GlobalRdrElt] combine_globals ns_old ns_new -- ns_new is often short = foldr add ns_old ns_new where @@ -603,11 +722,11 @@ combine_globals ns_old ns_new -- ns_new is often short choose n m | n `beats` m = n | otherwise = m - (n,pn) `beats` (m,pm) = n==m && pn `hasBetterProv` pm + (GRE n pn _) `beats` (GRE m pm _) = n==m && pn `hasBetterProv` pm - is_duplicate :: (Name,Provenance) -> (Name,Provenance) -> Bool - is_duplicate (n1,LocalDef) (n2,LocalDef) = False - is_duplicate (n1,_) (n2,_) = n1 == n2 + is_duplicate :: GlobalRdrElt -> GlobalRdrElt -> Bool + is_duplicate (GRE n1 LocalDef _) (GRE n2 LocalDef _) = False + is_duplicate (GRE n1 _ _) (GRE n2 _ _) = n1 == n2 \end{code} We treat two bindings of a locally-defined name as a duplicate, @@ -635,8 +754,8 @@ unQualInScope env where unqual_names :: NameSet unqual_names = foldRdrEnv add emptyNameSet env - add rdr_name [(name,_)] unquals | isUnqual rdr_name = addOneToNameSet unquals name - add _ _ unquals = unquals + add rdr_name [GRE name _ _] unquals | isUnqual rdr_name = addOneToNameSet unquals name + add _ _ unquals = unquals \end{code} @@ -851,12 +970,7 @@ addNameClashErrRn rdr_name (np1:nps) where msg1 = ptext SLIT("either") <+> mk_ref np1 msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps] - mk_ref (name,prov) = quotes (ppr name) <> comma <+> pprNameProvenance name prov - -fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2))) - = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)]) - 4 (vcat [ppr how_in_scope1, - ppr how_in_scope2]) + mk_ref (GRE name prov _) = quotes (ppr name) <> comma <+> pprNameProvenance name prov shadowedNameWarn shadow = hsep [ptext SLIT("This binding for"), @@ -880,4 +994,12 @@ dupNamesErr descriptor ((name,loc) : dup_things) addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) $$ (ptext SLIT("in") <+> descriptor)) + +warnDeprec :: Name -> DeprecTxt -> RnM d () +warnDeprec name txt + = doptRn Opt_WarnDeprecations `thenRn` \ warn_drs -> + if not warn_drs then returnRn () else + addWarnRn (sep [ text (occNameFlavour (nameOccName name)) <+> + quotes (ppr name) <+> text "is deprecated:", + nest 4 (ppr txt) ]) \end{code} diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 6270233..5cd7e5f 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -29,12 +29,13 @@ import RnHiFiles ( lookupFixityRn ) import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts ) import Literal ( inIntRange ) import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity ) -import PrelNames ( hasKey, assertIdKey, +import PrelNames ( hasKey, assertIdKey, minusName, negateName, fromIntName, eqClass_RDR, foldr_RDR, build_RDR, eqString_RDR, cCallableClass_RDR, cReturnableClass_RDR, monadClass_RDR, enumClass_RDR, ordClass_RDR, - ratioDataCon_RDR, negate_RDR, assertErr_RDR, - ioDataCon_RDR, plusInteger_RDR, timesInteger_RDR + ratioDataCon_RDR, assertErr_RDR, + ioDataCon_RDR, plusInteger_RDR, timesInteger_RDR, + fromInteger_RDR, fromRational_RDR, ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon @@ -93,12 +94,11 @@ rnPat (NPatIn lit) lookupOrigName eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern returnRn (NPatIn lit', fvs1 `addOneFV` eq) -rnPat (NPlusKPatIn name lit minus) +rnPat (NPlusKPatIn name lit) = rnOverLit lit `thenRn` \ (lit', fvs) -> lookupOrigName ordClass_RDR `thenRn` \ ord -> lookupBndrRn name `thenRn` \ name' -> - lookupOccRn minus `thenRn` \ minus' -> - returnRn (NPlusKPatIn name' lit' minus', fvs `addOneFV` ord `addOneFV` minus') + returnRn (NPlusKPatIn name' lit', fvs `addOneFV` ord `addOneFV` minusName) rnPat (LazyPatIn pat) = rnPat pat `thenRn` \ (pat', fvs) -> @@ -322,11 +322,10 @@ rnExpr (OpApp e1 op _ e2) returnRn (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) -rnExpr (NegApp e n) +rnExpr (NegApp e) = rnExpr e `thenRn` \ (e', fv_e) -> - lookupOrigName negate_RDR `thenRn` \ neg -> - mkNegAppRn e' neg `thenRn` \ final_e -> - returnRn (final_e, fv_e `addOneFV` neg) + mkNegAppRn e' `thenRn` \ final_e -> + returnRn (final_e, fv_e `addOneFV` negateName) rnExpr (HsPar e) = rnExpr e `thenRn` \ (e', fvs_e) -> @@ -648,20 +647,20 @@ mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2 --------------------------- -- (- neg_arg) `op` e2 -mkOpAppRn e1@(NegApp neg_arg neg_op) op2 fix2 e2 +mkOpAppRn e1@(NegApp neg_arg) op2 fix2 e2 | nofix_error = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenRn_` returnRn (OpApp e1 op2 fix2 e2) | associate_right = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e -> - returnRn (NegApp new_e neg_op) + returnRn (NegApp new_e) where (nofix_error, associate_right) = compareFixity negateFixity fix2 --------------------------- -- e1 `op` - neg_arg -mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg neg_op) -- NegApp can occur on the right +mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg) -- NegApp can occur on the right | not associate_right -- We *want* right association = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_` returnRn (OpApp e1 op1 fix1 e2) @@ -687,13 +686,13 @@ right_op_ok fix1 other = True -- Parser initially makes negation bind more tightly than any other operator -mkNegAppRn neg_arg neg_op +mkNegAppRn neg_arg = #ifdef DEBUG getModeRn `thenRn` \ mode -> ASSERT( not_op_app mode neg_arg ) #endif - returnRn (NegApp neg_arg neg_op) + returnRn (NegApp neg_arg) not_op_app SourceMode (OpApp _ _ _ _) = False not_op_app mode other = True @@ -765,7 +764,7 @@ checkPrec op pat right checkSectionPrec left_or_right section op arg = case arg of OpApp _ op fix _ -> go_for_it (ppr_op op) fix - NegApp _ _ -> go_for_it pp_prefix_minus negateFixity + NegApp _ -> go_for_it pp_prefix_minus negateFixity other -> returnRn () where HsVar op_name = op @@ -824,18 +823,17 @@ litFVs (HsLitLit l bogus_ty) = lookupOrigName cCallableClass_RDR `thenRn` \ cc litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear -- in post-typechecker translations -rnOverLit (HsIntegral i from_integer) - = lookupOccRn from_integer `thenRn` \ from_integer' -> - (if inIntRange i then - returnRn emptyFVs - else - lookupOrigNames [plusInteger_RDR, timesInteger_RDR] - ) `thenRn` \ ns -> - returnRn (HsIntegral i from_integer', ns `addOneFV` from_integer') - -rnOverLit (HsFractional i n) - = lookupOccRn n `thenRn` \ n' -> - lookupOrigNames [ratioDataCon_RDR, plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns' -> +rnOverLit (HsIntegral i) + | inIntRange i + = returnRn (HsIntegral i, unitFV fromIntName) + | otherwise + = lookupOrigNames [fromInteger_RDR, plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns -> + -- Big integers are built, using + and *, out of small integers + returnRn (HsIntegral i, ns) + +rnOverLit (HsFractional i) + = lookupOrigNames [fromRational_RDR, ratioDataCon_RDR, + plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns -> -- We have to make sure that the Ratio type is imported with -- its constructor, because literals of type Ratio t are -- built with that constructor. @@ -843,7 +841,7 @@ rnOverLit (HsFractional i n) -- when fractionalClass does. -- The plus/times integer operations may be needed to construct the numerator -- and denominator (see DsUtils.mkIntegerLit) - returnRn (HsFractional i n', ns' `addOneFV` n') + returnRn (HsFractional i, ns) \end{code} %************************************************************************ diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index aa599df..7d12987 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -46,7 +46,6 @@ type RenamedSig = Sig Name type RenamedStmt = Stmt Name RenamedPat type RenamedFixitySig = FixitySig Name type RenamedDeprecation = DeprecDecl Name -type RenamedHsOverLit = HsOverLit Name \end{code} %************************************************************************ diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 40d12d7..762cdec 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -35,12 +35,11 @@ module Inst ( import CmdLineOpts ( opt_NoMethodSharing ) import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..) ) -import RnHsSyn ( RenamedHsOverLit ) import TcHsSyn ( TcExpr, TcId, mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId ) import TcMonad -import TcEnv ( TcIdSet, tcGetInstEnv, tcLookupGlobalId ) +import TcEnv ( TcIdSet, tcGetInstEnv, tcLookupSyntaxId ) import InstEnv ( InstLookupResult(..), lookupInstEnv ) import TcType ( TcThetaType, TcClassContext, TcType, TcTauType, TcTyVarSet, @@ -72,7 +71,7 @@ import TysWiredIn ( isIntTy, doubleDataCon, isDoubleTy, isIntegerTy ) -import PrelNames( hasKey, fromIntName, fromIntegerClassOpKey ) +import PrelNames( fromIntName, fromIntegerName, fromRationalName ) import Util ( thenCmp, zipWithEqual, mapAccumL ) import Bag import Outputable @@ -157,8 +156,8 @@ data Inst | LitInst Id - RenamedHsOverLit -- The literal from the occurrence site - TcType -- The type at which the literal is used + HsOverLit -- The literal from the occurrence site + TcType -- The type at which the literal is used InstLoc \end{code} @@ -435,10 +434,10 @@ cases (the rest are caught in lookupInst). \begin{code} newOverloadedLit :: InstOrigin - -> RenamedHsOverLit + -> HsOverLit -> TcType -> NF_TcM (TcExpr, LIE) -newOverloadedLit orig (HsIntegral i _) ty +newOverloadedLit orig (HsIntegral i) ty | isIntTy ty && inIntRange i -- Short cut for Int = returnNF_Tc (int_lit, emptyLIE) @@ -619,7 +618,7 @@ lookupInst inst@(Method _ id tys theta _ loc) -- Literals -lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc) +lookupInst inst@(LitInst u (HsIntegral i) ty loc) | isIntTy ty && in_int_range -- Short cut for Int = returnNF_Tc (GenInst [] int_lit) -- GenInst, not SimpleInst, because int_lit is actually a constructor application @@ -628,16 +627,13 @@ lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc) = returnNF_Tc (GenInst [] integer_lit) | in_int_range -- It's overloaded but small enough to fit into an Int - && from_integer_name `hasKey` fromIntegerClassOpKey -- And it's the built-in prelude fromInteger - -- (i.e. no funny business with user-defined - -- packages of numeric classes) = -- So we can use the Prelude fromInt - tcLookupGlobalId fromIntName `thenNF_Tc` \ from_int -> + tcLookupSyntaxId fromIntName `thenNF_Tc` \ from_int -> newMethodAtLoc loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) -> returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit)) | otherwise -- Alas, it is overloaded and a big literal! - = tcLookupGlobalId from_integer_name `thenNF_Tc` \ from_integer -> + = tcLookupSyntaxId fromIntegerName `thenNF_Tc` \ from_integer -> newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) -> returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit)) where @@ -649,12 +645,12 @@ lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc) -- *definitely* a float or a double, generate the real thing here. -- This is essential (see nofib/spectral/nucleic). -lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc) +lookupInst inst@(LitInst u (HsFractional f) ty loc) | isFloatTy ty = returnNF_Tc (GenInst [] float_lit) | isDoubleTy ty = returnNF_Tc (GenInst [] double_lit) | otherwise - = tcLookupGlobalId from_rat_name `thenNF_Tc` \ from_rational -> + = tcLookupSyntaxId fromRationalName `thenNF_Tc` \ from_rational -> newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) -> let rational_ty = funArgTy (idType method_id) diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index f89e31a..0192bba 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -16,7 +16,7 @@ module TcEnv( -- Global environment tcExtendGlobalEnv, tcExtendGlobalValEnv, tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon, - tcLookupGlobal_maybe, tcLookupGlobal, + tcLookupGlobal_maybe, tcLookupGlobal, tcLookupSyntaxId, tcLookupSyntaxName, -- Local environment tcExtendKindEnv, tcLookupLocalIds, @@ -68,6 +68,7 @@ import InstEnv ( InstEnv, emptyInstEnv ) import HscTypes ( lookupType, TyThing(..) ) import Util ( zipEqual ) import SrcLoc ( SrcLoc ) +import qualified PrelNames import Outputable import IOExts ( newIORef ) @@ -85,6 +86,8 @@ type TcIdSet = IdSet data TcEnv = TcEnv { + tcSyntaxMap :: PrelNames.SyntaxMap, -- The syntax map (usually the identity) + tcGST :: Name -> Maybe TyThing, -- The type environment at the moment we began this compilation tcInsts :: InstEnv, -- All instances (both imported and in this module) @@ -138,10 +141,11 @@ data TcTyThing -- 3. Then we zonk the kind variable. -- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment -initTcEnv :: HomeSymbolTable -> PackageTypeEnv -> IO TcEnv -initTcEnv hst pte +initTcEnv :: PrelNames.SyntaxMap -> HomeSymbolTable -> PackageTypeEnv -> IO TcEnv +initTcEnv syntax_map hst pte = do { gtv_var <- newIORef emptyVarSet ; - return (TcEnv { tcGST = lookup, + return (TcEnv { tcSyntaxMap = syntax_map, + tcGST = lookup, tcGEnv = emptyNameEnv, tcInsts = emptyInstEnv, tcLEnv = emptyNameEnv, @@ -343,6 +347,21 @@ tcLookupLocalIds ns lookup lenv name = case lookupNameEnv lenv name of Just (ATcId id) -> id other -> pprPanic "tcLookupLocalIds" (ppr name) + +tcLookupSyntaxId :: Name -> NF_TcM Id +-- Lookup a name like PrelNum.fromInt, and return the corresponding Id, +-- after mapping through the SyntaxMap. This may give us the Id for +-- (say) MyPrelude.fromInt +tcLookupSyntaxId name + = tcGetEnv `thenNF_Tc` \ env -> + returnNF_Tc (case lookup_global env (tcSyntaxMap env name) of + Just (AnId id) -> id + other -> pprPanic "tcLookupSyntaxId" (ppr name)) + +tcLookupSyntaxName :: Name -> NF_TcM Name +tcLookupSyntaxName name + = tcGetEnv `thenNF_Tc` \ env -> + returnNF_Tc (tcSyntaxMap env name) \end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index a1bac30..59730b2 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -27,7 +27,7 @@ import TcBinds ( tcBindsAndThen ) import TcEnv ( TcTyThing(..), tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe, tcLookupTyCon, tcLookupDataCon, tcLookup, - tcExtendGlobalTyVars + tcExtendGlobalTyVars, tcLookupSyntaxName ) import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts ) import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt ) @@ -58,7 +58,7 @@ import TysWiredIn ( boolTy, mkListTy, listTyCon ) import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy ) import PrelNames ( cCallableClassName, cReturnableClassName, - enumFromName, enumFromThenName, + enumFromName, enumFromThenName, negateName, enumFromToName, enumFromThenToName, thenMName, failMName, returnMName, ioTyConName ) @@ -196,8 +196,9 @@ tcMonoExpr (HsLit lit) res_ty = tcLit lit res_ty tcMonoExpr (HsOverLit lit) res_ty = newOverloadedLit (LiteralOrigin lit) lit res_ty tcMonoExpr (HsPar expr) res_ty = tcMonoExpr expr res_ty -tcMonoExpr (NegApp expr neg) res_ty - = tcMonoExpr (HsApp (HsVar neg) expr) res_ty +tcMonoExpr (NegApp expr) res_ty + = tcLookupSyntaxName negateName `thenNF_Tc` \ neg -> + tcMonoExpr (HsApp (HsVar neg) expr) res_ty tcMonoExpr (HsLam match) res_ty = tcMatchLambda match res_ty `thenTc` \ (match',lie) -> diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 504f5da..d9fb249 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -47,7 +47,8 @@ module TcMonad( import {-# SOURCE #-} TcEnv ( TcEnv ) -import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr, RenamedHsOverLit ) +import HsSyn ( HsOverLit ) +import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr ) import Type ( Type, Kind, PredType, ThetaType, RhoType, TauType, ) import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg ) @@ -269,7 +270,7 @@ forkNF_Tc m down@(TcDown { tc_us = u_var }) env \begin{code} traceTc :: SDoc -> NF_TcM () traceTc doc (TcDown { tc_dflags=dflags }) env - | dopt Opt_D_dump_rn_trace dflags = printDump doc + | dopt Opt_D_dump_tc_trace dflags = printDump doc | otherwise = return () ioToTc :: IO a -> NF_TcM a @@ -670,7 +671,7 @@ data InstOrigin | InstanceDeclOrigin -- Typechecking an instance decl - | LiteralOrigin RenamedHsOverLit -- Occurrence of a literal + | LiteralOrigin HsOverLit -- Occurrence of a literal | PatOrigin RenamedPat diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 2ed45be..e5bfc93 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -20,7 +20,7 @@ import Inst ( InstOrigin(..), import Id ( mkVanillaId ) import Name ( Name ) import FieldLabel ( fieldLabelName ) -import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId ) +import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupSyntaxId ) import TcType ( TcType, TcTyVar, tcInstTyVars, newTyVarTy ) import TcMonoType ( tcHsSigType ) import TcUnify ( unifyTauTy, unifyListTy, unifyTupleTy ) @@ -35,7 +35,7 @@ import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, doublePrimTy, addrPrimTy ) import TysWiredIn ( charTy, stringTy, intTy, integerTy ) -import PrelNames ( eqStringName, eqName, geName, cCallableClassName ) +import PrelNames ( minusName, eqStringName, eqName, geName, cCallableClassName ) import BasicTypes ( isBoxed ) import Bag import Outputable @@ -285,8 +285,8 @@ tcPat tc_bndr pat@(NPatIn over_lit) pat_ty where origin = PatOrigin pat lit' = case over_lit of - HsIntegral i _ -> HsInteger i - HsFractional f _ -> HsRat f pat_ty + HsIntegral i -> HsInteger i + HsFractional f -> HsRat f pat_ty \end{code} %************************************************************************ @@ -296,9 +296,10 @@ tcPat tc_bndr pat@(NPatIn over_lit) pat_ty %************************************************************************ \begin{code} -tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus) pat_ty +tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i)) pat_ty = tc_bndr name pat_ty `thenTc` \ bndr_id -> - tcLookupGlobalId minus `thenNF_Tc` \ minus_sel_id -> + -- The '-' part is re-mappable syntax + tcLookupSyntaxId minusName `thenNF_Tc` \ minus_sel_id -> tcLookupGlobalId geName `thenNF_Tc` \ ge_sel_id -> newOverloadedLit origin lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) -> newMethod origin ge_sel_id [pat_ty] `thenNF_Tc` \ ge -> -- 1.7.10.4