Commit d4e38936 authored by simonpj's avatar simonpj
Browse files

[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
parent b5f35df4
......@@ -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)
......
......@@ -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}
......@@ -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
......
......@@ -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);
......
......@@ -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
......
{-
-----------------------------------------------------------------------------
$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 }
......
......@@ -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}
%************************************************************************
%* *
......
......@@ -22,8 +22,6 @@ module PrelNames (
knownKeyNames,
mkTupNameStr, mkTupConRdrName,
SyntaxMap, vanillaSyntaxMap, SyntaxList, syntaxList,
------------------------------------------------------------
-- Goups of classes and types
needsDataDeclCtxtClassKeys, cCallishClassKeys, noDictClassKeys,
......@@ -910,48 +908,6 @@ cCallishTyKeys =
\end{code}
%************************************************************************
%* *
\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}
......
......@@ -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}
......
......@@ -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}
......
......@@ -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}
%************************************************************************
......
......@@ -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