From: simonpj Date: Fri, 13 Jul 2001 13:29:58 +0000 (+0000) Subject: [project @ 2001-07-13 13:29:56 by simonpj] X-Git-Tag: Approximately_9120_patches~1562 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=d4e38936bf64bcd3dc301ec404406bbff20f01d5;p=ghc-hetmet.git [project @ 2001-07-13 13:29:56 by simonpj] ------------------------------------ Tidy up the "syntax rebinding" story ------------------------------------ I found a bug in the code that dealt with re-binding implicit numerical syntax: literals (fromInteger/fromRational) negation (negate) n+k patterns (minus) This is triggered by the -fno-implicit-prelude flag, and it used to be handled via the PrelNames.SyntaxMap. But I found a nicer way to do it that involves much less code, and doesn't have the bug. The explanation is with RnEnv.lookupSyntaxName --- diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index b7d4573..f072ca3 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -17,6 +17,7 @@ import HsTypes ( HsType ) import HsImpExp ( isOperator ) -- others: +import Name ( Name ) import ForeignCall ( Safety ) import Outputable import PprType ( pprParendType ) @@ -60,6 +61,7 @@ data HsExpr id pat -- They are eventually removed by the type checker. | NegApp (HsExpr id pat) -- negated expr + Name -- Name of 'negate' (see RnEnv.lookupSyntaxName) | HsPar (HsExpr id pat) -- parenthesised expr @@ -248,7 +250,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 39d737d..aa19b64 100644 --- a/ghc/compiler/hsSyn/HsLit.lhs +++ b/ghc/compiler/hsSyn/HsLit.lhs @@ -9,6 +9,7 @@ module HsLit where #include "HsVersions.h" import Type ( Type ) +import Name ( Name ) import HsTypes ( PostTcType ) import Outputable import Ratio ( Rational ) @@ -55,19 +56,21 @@ instance Eq HsLit where (HsLitLit x1 _) == (HsLitLit x2 _) = x1==x2 lit1 == lit2 = False -data HsOverLit -- An overloaded literal - = HsIntegral Integer -- Integer-looking literals; - | HsFractional Rational -- Frac-looking literals +data HsOverLit -- An overloaded literal + = HsIntegral Integer Name -- Integer-looking literals; + -- The name is fromInteger + | HsFractional Rational Name -- Frac-looking literals + -- The name is fromRational instance Eq HsOverLit where - (HsIntegral i1) == (HsIntegral i2) = i1 == i2 - (HsFractional f1) == (HsFractional f2) = f1 == f2 + (HsIntegral i1 _) == (HsIntegral i2 _) = i1 == i2 + (HsFractional f1 _) == (HsFractional f2 _) = f1 == f2 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 + 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} @@ -86,8 +89,8 @@ instance Outputable HsLit where ppr (HsLitLit s _) = hcat [text "``", ptext s, text "''"] instance Outputable HsOverLit where - ppr (HsIntegral i) = integer i - ppr (HsFractional f) = rational f + 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 4831614..c5fa2c7 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -26,6 +26,7 @@ import HsTypes ( HsType ) import BasicTypes ( Fixity, Boxity, tupleParens ) -- others: +import Name ( Name ) import Var ( Id, TyVar ) import DataCon ( DataCon, dataConTyCon ) import Name ( isDataSymOcc, getOccName, NamedThing ) @@ -57,6 +58,7 @@ data InPat name | NPlusKPatIn name -- n+k pattern HsOverLit -- It'll always be an HsIntegral + Name -- Name of '-' (see RnEnv.lookupSyntaxName) -- We preserve prefix negation and parenthesis for the precedence parser. @@ -112,11 +114,11 @@ data OutPat id HsLit Type -- Type of pattern - | NPat -- Used for *overloaded* literal patterns + | NPat -- Used for literal patterns where there's an equality function to call HsLit -- The literal is retained so that -- the desugarer can readily identify -- equations with identical literal-patterns - -- Always HsInt, HsRat or HsString. + -- Always HsInteger, HsRat or HsString. Type -- Type of pattern, t (HsExpr id (OutPat id)) -- Of type t -> Bool; detects match @@ -151,7 +153,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) @@ -317,7 +319,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 +346,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/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index bab8b9a..16a9c01 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -39,7 +39,7 @@ import Finder ( findModule ) import Rename ( checkOldIface, renameModule, closeIfaceDecls ) import Rules ( emptyRuleBase ) import PrelInfo ( wiredInThingEnv, wiredInThings ) -import PrelNames ( vanillaSyntaxMap, knownKeyNames ) +import PrelNames ( knownKeyNames ) import MkIface ( mkFinalIface ) import TcModule import InstEnv ( emptyInstEnv ) @@ -170,7 +170,7 @@ hscNoRecomp ghci_mode dflags have_object -- TYPECHECK maybe_tc_result - <- typecheckIface dflags pcs_cl hst old_iface (vanillaSyntaxMap, cl_hs_decls); + <- typecheckIface dflags pcs_cl hst old_iface cl_hs_decls; case maybe_tc_result of { Nothing -> return (HscFail pcs_cl); diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index 1f8a1f1..5b3def9 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -33,7 +33,8 @@ import SrcLoc import RdrHsSyn ( RdrBinding(..), RdrNameHsType, RdrNameBangType, RdrNameContext, RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs, - RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails + RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails, + mkNPlusKPat ) import RdrName import PrelNames ( unitTyCon_RDR ) @@ -194,9 +195,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 _ _)) | plus == plus_RDR - -> returnP (NPlusKPatIn n lit) + -> returnP (mkNPlusKPat n lit) where plus_RDR = mkUnqual varName SLIT("+") -- Hack diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 71b2eb5..0edcedb 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.70 2001/07/12 16:21:23 simonpj Exp $ +$Id: Parser.y,v 1.71 2001/07/13 13:29:57 simonpj Exp $ Haskell grammar. @@ -773,8 +773,8 @@ aexp1 :: { RdrNameHsExpr } : ipvar { HsIPVar $1 } | var_or_con { $1 } | literal { HsLit $1 } - | INTEGER { HsOverLit (HsIntegral $1) } - | RATIONAL { HsOverLit (HsFractional $1) } + | INTEGER { HsOverLit (mkHsIntegral $1) } + | RATIONAL { HsOverLit (mkHsFractional $1) } | '(' exp ')' { HsPar $2 } | '(' exp ',' texps ')' { ExplicitTuple ($2 : reverse $4) Boxed} | '(#' texps '#)' { ExplicitTuple (reverse $2) Unboxed } diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 8cc3afe..9bc63ea 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -49,7 +49,7 @@ module RdrHsSyn ( extractHsCtxtRdrTyVars, extractGenericPatTyVars, mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl, - mkHsNegApp, + mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional, cvBinds, cvMonoBindsAndSigs, @@ -65,6 +65,7 @@ import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc, mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1, mkGenOcc2, ) +import PrelNames ( minusName, negateName, fromIntegerName, fromRationalName ) import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, ) import List ( nub ) @@ -260,9 +261,9 @@ mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i)) mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i)) mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i)) -mkHsNegApp (HsOverLit (HsIntegral i)) = HsOverLit (HsIntegral (-i)) -mkHsNegApp (HsOverLit (HsFractional f)) = HsOverLit (HsFractional (-f)) -mkHsNegApp expr = NegApp expr +mkHsNegApp (HsOverLit (HsIntegral i n)) = HsOverLit (HsIntegral (-i) n) +mkHsNegApp (HsOverLit (HsFractional f n)) = HsOverLit (HsFractional (-f) n) +mkHsNegApp expr = NegApp expr negateName \end{code} A useful function for building @OpApps@. The operator is always a @@ -272,6 +273,15 @@ variable, and we don't know the fixity yet. mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2 \end{code} +These are the bits of syntax that contain rebindable names +See RnEnv.lookupSyntaxName + +\begin{code} +mkHsIntegral i = HsIntegral i fromIntegerName +mkHsFractional f = HsFractional f fromRationalName +mkNPlusKPat n k = NPlusKPatIn n k minusName +\end{code} + %************************************************************************ %* * diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index 26692c3..7467fac 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -22,8 +22,6 @@ module PrelNames ( knownKeyNames, mkTupNameStr, mkTupConRdrName, - SyntaxMap, vanillaSyntaxMap, SyntaxList, syntaxList, - ------------------------------------------------------------ -- Goups of classes and types needsDataDeclCtxtClassKeys, cCallishClassKeys, noDictClassKeys, @@ -912,48 +910,6 @@ cCallishTyKeys = %************************************************************************ %* * -\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. - -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 =[ (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.fromInteger - -- to its re-mapped version, such as MyPrelude.fromInteger - -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 c46b48e..209ef63 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -34,7 +34,7 @@ import RnEnv ( availsToNameSet, mkIfaceGlobalRdrEnv, emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, groupAvails, warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules, - lookupSrcName, getImplicitStmtFVs, getImplicitModuleFVs, rnSyntaxNames, + lookupSrcName, getImplicitStmtFVs, getImplicitModuleFVs, newGlobalName, unQualInScope,, ubiquitousNames ) import Module ( Module, ModuleName, WhereFrom(..), @@ -45,7 +45,7 @@ import Name ( Name, nameModule ) import NameEnv import NameSet import RdrName ( foldRdrEnv, isQual ) -import PrelNames ( SyntaxMap, vanillaSyntaxMap, pRELUDE_Name ) +import PrelNames ( pRELUDE_Name ) import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass, printErrorsAndWarnings, errorsFound ) import Bag ( bagToList ) @@ -83,7 +83,7 @@ renameModule :: DynFlags -> PersistentCompilerState -> Module -> RdrNameHsModule -> IO (PersistentCompilerState, PrintUnqualified, - Maybe (IsExported, ModIface, (SyntaxMap, [RenamedHsDecl]))) + Maybe (IsExported, ModIface, [RenamedHsDecl])) -- Nothing => some error occurred in the renamer renameModule dflags hit hst pcs this_module rdr_module @@ -102,7 +102,7 @@ renameStmt :: DynFlags -> RdrNameStmt -- parsed stmt -> IO ( PersistentCompilerState, PrintUnqualified, - Maybe ([Name], (SyntaxMap, RenamedStmt, [RenamedHsDecl])) + Maybe ([Name], (RenamedStmt, [RenamedHsDecl])) ) renameStmt dflags hit hst pcs scope_module this_module local_env stmt @@ -141,7 +141,7 @@ renameStmt dflags hit hst pcs scope_module this_module local_env stmt slurpImpDecls source_fvs `thenRn` \ decls -> doDump binders stmt decls `thenRn_` - returnRn (print_unqual, Just (binders, (vanillaSyntaxMap, stmt, decls))) + returnRn (print_unqual, Just (binders, (stmt, decls))) where doc = text "context for compiling expression" @@ -191,7 +191,7 @@ renameSource dflags hit hst old_pcs this_module thing_inside \begin{code} rename :: Module -> RdrNameHsModule - -> RnMG (PrintUnqualified, Maybe (IsExported, ModIface, (SyntaxMap, [RenamedHsDecl]))) + -> RnMG (PrintUnqualified, Maybe (IsExported, ModIface, [RenamedHsDecl])) rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec loc) = pushSrcLocRn loc $ @@ -239,10 +239,9 @@ rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec -- SLURP IN ALL THE NEEDED DECLARATIONS -- Find out what re-bindable names to use for desugaring getImplicitModuleFVs mod_name rn_local_decls `thenRn` \ implicit_fvs -> - rnSyntaxNames gbl_env source_fvs `thenRn` \ (source_fvs1, sugar_map) -> let export_fvs = availsToNameSet export_avails - source_fvs2 = source_fvs1 `plusFV` export_fvs + source_fvs2 = source_fvs `plusFV` export_fvs -- The export_fvs make the exported names look just as if they -- occurred in the source program. For the reasoning, see the -- comments with RnIfaces.mkImportInfo @@ -298,7 +297,7 @@ rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec -- NB: source_fvs2: include exports (else we get bogus -- warnings of unused things) but not implicit FVs. - returnRn (print_unqualified, Just (is_exported, mod_iface, (sugar_map, final_decls))) + returnRn (print_unqualified, Just (is_exported, mod_iface, final_decls)) where mod_name = moduleName this_module \end{code} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index a83890d..69ec8f6 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -25,7 +25,7 @@ import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, extendLocalRdrEnv ) import RnMonad -import Name ( Name, +import Name ( Name, getSrcLoc, nameIsLocalOrFrom, mkLocalName, mkGlobalName, mkIPName, nameOccName, nameModule_maybe, @@ -36,7 +36,7 @@ import NameSet 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, @@ -410,38 +410,47 @@ ubiquitousNames -- 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} +%* * +%************************************************************************ -rnSyntaxNames gbl_env source_fvs +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. + +\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} diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 1f59e86..8b9e8c4 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -94,11 +94,12 @@ rnPat (NPatIn lit) lookupOrigName eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern returnRn (NPatIn lit', fvs1 `addOneFV` eq) -rnPat (NPlusKPatIn name lit) +rnPat (NPlusKPatIn name lit minus) = rnOverLit lit `thenRn` \ (lit', fvs) -> lookupOrigName ordClass_RDR `thenRn` \ ord -> lookupBndrRn name `thenRn` \ name' -> - returnRn (NPlusKPatIn name' lit', fvs `addOneFV` ord `addOneFV` minusName) + lookupSyntaxName minus `thenRn` \ minus' -> + returnRn (NPlusKPatIn name' lit' minus', fvs `addOneFV` ord `addOneFV` minus') rnPat (LazyPatIn pat) = rnPat pat `thenRn` \ (pat', fvs) -> @@ -333,10 +334,11 @@ rnExpr (OpApp e1 op _ e2) returnRn (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) -rnExpr (NegApp e) +rnExpr (NegApp e neg_name) = rnExpr e `thenRn` \ (e', fv_e) -> - mkNegAppRn e' `thenRn` \ final_e -> - returnRn (final_e, fv_e `addOneFV` negateName) + lookupSyntaxName neg_name `thenRn` \ neg_name' -> + mkNegAppRn e' neg_name' `thenRn` \ final_e -> + returnRn (final_e, fv_e `addOneFV` neg_name') rnExpr (HsPar e) = rnExpr e `thenRn` \ (e', fvs_e) -> @@ -652,21 +654,21 @@ mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2 --------------------------- -- (- neg_arg) `op` e2 -mkOpAppRn e1@(NegApp neg_arg) op2 fix2 e2 +mkOpAppRn e1@(NegApp neg_arg neg_name) 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) + returnRn (NegApp new_e neg_name) where (nofix_error, associate_right) = compareFixity negateFixity fix2 --------------------------- -- e1 `op` - neg_arg -mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg) -- NegApp can occur on the right - | not associate_right -- We *want* right association +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) where @@ -691,13 +693,13 @@ right_op_ok fix1 other = True -- Parser initially makes negation bind more tightly than any other operator -mkNegAppRn neg_arg +mkNegAppRn neg_arg neg_name = #ifdef DEBUG getModeRn `thenRn` \ mode -> ASSERT( not_op_app mode neg_arg ) #endif - returnRn (NegApp neg_arg) + returnRn (NegApp neg_arg neg_name) not_op_app SourceMode (OpApp _ _ _ _) = False not_op_app mode other = True @@ -769,7 +771,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 @@ -831,20 +833,22 @@ 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) - | inIntRange i - = returnRn (HsIntegral i, unitFV fromIntegerName) - | otherwise - = lookupOrigNames [fromInteger_RDR, plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns -> - -- Big integers are built, using + and *, out of small integers - -- [No particular reason why we use fromIntegerName in one case can - -- fromInteger_RDR in the other; but plusInteger_RDR means we - -- can get away without plusIntegerName altogether.] - returnRn (HsIntegral i, ns) - -rnOverLit (HsFractional i) - = lookupOrigNames [fromRational_RDR, ratioDataCon_RDR, - plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns -> +rnOverLit (HsIntegral i from_integer_name) + = lookupSyntaxName from_integer_name `thenRn` \ from_integer_name' -> + if inIntRange i then + returnRn (HsIntegral i from_integer_name', unitFV from_integer_name') + else + lookupOrigNames [plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns -> + -- Big integer literals are built, using + and *, + -- out of small integers (DsUtils.mkIntegerLit) + -- [NB: plusInteger, timesInteger aren't rebindable... + -- they are used to construct the argument to fromInteger, + -- which is the rebindable one.] + returnRn (HsIntegral i from_integer_name', ns `addOneFV` from_integer_name') + +rnOverLit (HsFractional i from_rat_name) + = lookupSyntaxName from_rat_name `thenRn` \ from_rat_name' -> + lookupOrigNames [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. @@ -852,7 +856,7 @@ rnOverLit (HsFractional i) -- when fractionalClass does. -- The plus/times integer operations may be needed to construct the numerator -- and denominator (see DsUtils.mkIntegerLit) - returnRn (HsFractional i, ns) + returnRn (HsFractional i from_rat_name', ns `addOneFV` from_rat_name') \end{code} %************************************************************************ diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 5540372..ce99069 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -39,7 +39,7 @@ import TcHsSyn ( TcExpr, TcId, mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId ) import TcMonad -import TcEnv ( TcIdSet, tcGetInstEnv, tcLookupSyntaxId ) +import TcEnv ( TcIdSet, tcGetInstEnv, tcLookupId ) import InstEnv ( InstLookupResult(..), lookupInstEnv ) import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType, tcInstTyVar, tcInstType, @@ -433,18 +433,11 @@ newOverloadedLit :: InstOrigin -> HsOverLit -> TcType -> NF_TcM (TcExpr, LIE) -newOverloadedLit orig (HsIntegral i) ty - | isIntTy ty && inIntRange i -- Short cut for Int - = returnNF_Tc (int_lit, emptyLIE) +newOverloadedLit orig lit ty + | Just expr <- shortCutLit lit ty + = returnNF_Tc (expr, emptyLIE) - | isIntegerTy ty -- Short cut for Integer - = returnNF_Tc (integer_lit, emptyLIE) - - where - int_lit = HsLit (HsInt i) - integer_lit = HsLit (HsInteger i) - -newOverloadedLit orig lit ty -- The general case + | otherwise = tcGetInstLoc orig `thenNF_Tc` \ loc -> tcGetUnique `thenNF_Tc` \ new_uniq -> let @@ -452,6 +445,22 @@ newOverloadedLit orig lit ty -- The general case lit_id = mkSysLocal SLIT("lit") new_uniq ty in returnNF_Tc (HsVar (instToId lit_inst), unitLIE lit_inst) + +shortCutLit :: HsOverLit -> TcType -> Maybe TcExpr +shortCutLit (HsIntegral i fi) ty + | isIntTy ty && inIntRange i && fi == fromIntegerName -- Short cut for Int + = Just (HsLit (HsInt i)) + | isIntegerTy ty && fi == fromIntegerName -- Short cut for Integer + = Just (HsLit (HsInteger i)) + +shortCutLit (HsFractional f fr) ty + | isFloatTy ty && fr == fromRationalName + = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)]) + | isDoubleTy ty && fr == fromRationalName + = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)]) + +shortCutLit lit ty + = Nothing \end{code} @@ -590,45 +599,32 @@ lookupInst inst@(Method _ id tys theta _ loc) -- Literals -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 +-- Look for short cuts first: if the literal is *definitely* a +-- int, integer, float or a double, generate the real thing here. +-- This is essential (see nofib/spectral/nucleic). +-- [Same shortcut as in newOverloadedLit, but we +-- may have done some unification by now] - | isIntegerTy ty -- Short cut for Integer - = returnNF_Tc (GenInst [] integer_lit) +lookupInst inst@(LitInst u lit ty loc) + | Just expr <- shortCutLit lit ty + = returnNF_Tc (GenInst [] expr) -- GenInst, not SimpleInst, because + -- expr may be a constructor application - | otherwise -- Alas, it is overloaded and a big literal! - = tcLookupSyntaxId fromIntegerName `thenNF_Tc` \ from_integer -> +lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc) + = tcLookupId from_integer_name `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 - in_int_range = inIntRange i - integer_lit = HsLit (HsInteger i) - int_lit = HsLit (HsInt i) - --- similar idea for overloaded floating point literals: if the literal is --- *definitely* a float or a double, generate the real thing here. --- This is essential (see nofib/spectral/nucleic). + returnNF_Tc (GenInst [method_inst] + (HsApp (HsVar method_id) (HsLit (HsInteger i)))) -lookupInst inst@(LitInst u (HsFractional f) ty loc) - | isFloatTy ty = returnNF_Tc (GenInst [] float_lit) - | isDoubleTy ty = returnNF_Tc (GenInst [] double_lit) - | otherwise - = tcLookupSyntaxId fromRationalName `thenNF_Tc` \ from_rational -> +lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc) + = tcLookupId from_rat_name `thenNF_Tc` \ from_rational -> newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) -> let rational_ty = tcFunArgTy (idType method_id) rational_lit = HsLit (HsRat f rational_ty) in returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) rational_lit)) - - where - floatprim_lit = HsLit (HsFloatPrim f) - float_lit = mkHsConApp floatDataCon [] [floatprim_lit] - doubleprim_lit = HsLit (HsDoublePrim f) - double_lit = mkHsConApp doubleDataCon [] [doubleprim_lit] \end{code} There is a second, simpler interface, when you want an instance of a diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index bb1bf42..fb866a3 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -16,7 +16,7 @@ module TcEnv( -- Global environment tcExtendGlobalEnv, tcExtendGlobalValEnv, tcExtendGlobalTypeEnv, tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon, - tcLookupGlobal_maybe, tcLookupGlobal, tcLookupSyntaxId, tcLookupSyntaxName, + tcLookupGlobal_maybe, tcLookupGlobal, -- Local environment tcExtendKindEnv, tcLookupLocalIds, tcInLocalScope, @@ -89,8 +89,6 @@ 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) @@ -145,11 +143,10 @@ 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 :: PrelNames.SyntaxMap -> HomeSymbolTable -> PackageTypeEnv -> IO TcEnv -initTcEnv syntax_map hst pte +initTcEnv :: HomeSymbolTable -> PackageTypeEnv -> IO TcEnv +initTcEnv hst pte = do { gtv_var <- newIORef emptyVarSet ; - return (TcEnv { tcSyntaxMap = syntax_map, - tcGST = lookup, + return (TcEnv { tcGST = lookup, tcGEnv = emptyNameEnv, tcInsts = emptyInstEnv, tcLEnv = emptyNameEnv, @@ -368,21 +365,6 @@ 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.fromInteger -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 810ea72..486976d 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -26,7 +26,7 @@ import Inst ( InstOrigin(..), import TcBinds ( tcBindsAndThen ) import TcEnv ( tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe, tcLookupTyCon, tcLookupDataCon, tcLookupId, - tcExtendGlobalTyVars, tcLookupSyntaxName + tcExtendGlobalTyVars ) import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts ) import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt ) @@ -195,9 +195,8 @@ 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) res_ty - = tcLookupSyntaxName negateName `thenNF_Tc` \ neg -> - tcMonoExpr (HsApp (HsVar neg) expr) res_ty +tcMonoExpr (NegApp expr neg_name) res_ty + = tcMonoExpr (HsApp (HsVar neg_name) expr) res_ty tcMonoExpr (HsLam match) res_ty = tcMatchLambda match res_ty `thenTc` \ (match',lie) -> diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index df69c72..da3bb70 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -411,8 +411,8 @@ zonkExpr (OpApp e1 op fixity e2) zonkExpr e2 `thenNF_Tc` \ new_e2 -> returnNF_Tc (OpApp new_e1 new_op fixity new_e2) -zonkExpr (NegApp _) = panic "zonkExpr: NegApp" -zonkExpr (HsPar _) = panic "zonkExpr: HsPar" +zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp" +zonkExpr (HsPar _) = panic "zonkExpr: HsPar" zonkExpr (SectionL expr op) = zonkExpr expr `thenNF_Tc` \ new_expr -> diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 044118b..cc1c949 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -16,7 +16,7 @@ import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..), Stmt(..), InPat(..), HsMatchContext(..), HsDoContext(..), RuleDecl(..), isIfaceRuleDecl, nullBinds, andMonoBindList, mkSimpleMatch, placeHolderType ) -import PrelNames ( SyntaxMap, mAIN_Name, mainName, ioTyConName, printName, +import PrelNames ( mAIN_Name, mainName, ioTyConName, printName, returnIOName, bindIOName, failIOName, itName ) @@ -91,8 +91,7 @@ typecheckStmt -> PrintUnqualified -- For error printing -> Module -- Is this really needed -> [Name] -- Names bound by the Stmt (empty for expressions) - -> (SyntaxMap, - RenamedStmt, -- The stmt itself + -> (RenamedStmt, -- The stmt itself [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr, @@ -101,8 +100,8 @@ typecheckStmt -- The returned [Id] is the same as the input except for -- ExprStmt, in which case the returned [Name] is [itName] -typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (syn_map, stmt, iface_decls) - = typecheck dflags syn_map pcs hst unqual $ +typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (stmt, iface_decls) + = typecheck dflags pcs hst unqual $ -- use the default default settings, i.e. [Integer, Double] tcSetDefaultTys defaultDefaultTys $ @@ -235,16 +234,15 @@ typecheckExpr :: DynFlags -> TypeEnv -- The interactive context's type envt -> PrintUnqualified -- For error printing -> Module - -> (SyntaxMap, - RenamedHsExpr, -- The expression itself + -> (RenamedHsExpr, -- The expression itself [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr, [Id], -- always empty (matches typecheckStmt) Type)) -typecheckExpr dflags pcs hst ic_type_env unqual this_mod (syn_map, expr, decls) - = typecheck dflags syn_map pcs hst unqual $ +typecheckExpr dflags pcs hst ic_type_env unqual this_mod (expr, decls) + = typecheck dflags pcs hst unqual $ -- use the default default settings, i.e. [Integer, Double] tcSetDefaultTys defaultDefaultTys $ @@ -302,7 +300,7 @@ typecheckModule -> HomeSymbolTable -> ModIface -- Iface for this module -> PrintUnqualified -- For error printing - -> (SyntaxMap, [RenamedHsDecl]) + -> [RenamedHsDecl] -> IO (Maybe (PersistentCompilerState, TcResults)) -- The new PCS is Augmented with imported information, -- (but not stuff from this module) @@ -318,8 +316,8 @@ data TcResults } -typecheckModule dflags pcs hst mod_iface unqual (syn_map, decls) - = do { maybe_tc_result <- typecheck dflags syn_map pcs hst unqual $ +typecheckModule dflags pcs hst mod_iface unqual decls + = do { maybe_tc_result <- typecheck dflags pcs hst unqual $ tcModule pcs hst get_fixity this_mod decls ; printTcDump dflags unqual maybe_tc_result ; return maybe_tc_result } @@ -469,13 +467,13 @@ typecheckIface -> PersistentCompilerState -> HomeSymbolTable -> ModIface -- Iface for this module (just module & fixities) - -> (SyntaxMap, [RenamedHsDecl]) + -> [RenamedHsDecl] -> IO (Maybe (PersistentCompilerState, ModDetails)) -- The new PCS is Augmented with imported information, -- (but not stuff from this module). -typecheckIface dflags pcs hst mod_iface (syn_map, decls) - = do { maybe_tc_stuff <- typecheck dflags syn_map pcs hst alwaysQualify $ +typecheckIface dflags pcs hst mod_iface decls + = do { maybe_tc_stuff <- typecheck dflags pcs hst alwaysQualify $ tcIfaceImports pcs hst get_fixity this_mod decls ; printIfaceDump dflags maybe_tc_stuff ; return maybe_tc_stuff } @@ -645,16 +643,15 @@ noMainErr = hsep [ptext SLIT("Module") <+> quotes (ppr mAIN_Name), \begin{code} typecheck :: DynFlags - -> SyntaxMap -> PersistentCompilerState -> HomeSymbolTable -> PrintUnqualified -- For error printing -> TcM r -> IO (Maybe r) -typecheck dflags syn_map pcs hst unqual thing_inside +typecheck dflags pcs hst unqual thing_inside = do { showPass dflags "Typechecker"; - ; env <- initTcEnv syn_map hst (pcs_PTE pcs) + ; env <- initTcEnv hst (pcs_PTE pcs) ; (maybe_tc_result, errs) <- initTc dflags env thing_inside diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index d26b121..8c4197a 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -20,7 +20,7 @@ import Inst ( InstOrigin(..), import Id ( mkLocalId ) import Name ( Name ) import FieldLabel ( fieldLabelName ) -import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupSyntaxId ) +import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupId ) import TcMType ( tcInstTyVars, newTyVarTy, unifyTauTy, unifyListTy, unifyTupleTy ) import TcType ( isTauTy, mkTyConApp, mkClassPred, liftedTypeKind ) import TcMonoType ( tcHsSigType ) @@ -284,8 +284,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} %************************************************************************ @@ -295,10 +295,10 @@ tcPat tc_bndr pat@(NPatIn over_lit) pat_ty %************************************************************************ \begin{code} -tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i)) pat_ty +tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus_name) pat_ty = tc_bndr name pat_ty `thenTc` \ bndr_id -> -- The '-' part is re-mappable syntax - tcLookupSyntaxId minusName `thenNF_Tc` \ minus_sel_id -> + tcLookupId minus_name `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 ->