import HsImpExp ( isOperator )
-- others:
+import Name ( Name )
import ForeignCall ( Safety )
import Outputable
import PprType ( pprParendType )
-- 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
| 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)
#include "HsVersions.h"
import Type ( Type )
+import Name ( Name )
import HsTypes ( PostTcType )
import Outputable
import Ratio ( Rational )
(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}
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}
import BasicTypes ( Fixity, Boxity, tupleParens )
-- others:
+import Name ( Name )
import Var ( Id, TyVar )
import DataCon ( DataCon, dataConTyCon )
import Name ( isDataSymOcc, getOccName, NamedThing )
| 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.
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
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)
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)
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
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 )
-- 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);
import RdrHsSyn ( RdrBinding(..),
RdrNameHsType, RdrNameBangType, RdrNameContext,
RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs,
- RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails
+ RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails,
+ mkNPlusKPat
)
import RdrName
import PrelNames ( unitTyCon_RDR )
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.
: 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 }
extractHsCtxtRdrTyVars, extractGenericPatTyVars,
mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl,
- mkHsNegApp,
+ mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional,
cvBinds,
cvMonoBindsAndSigs,
mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1,
mkGenOcc2,
)
+import PrelNames ( minusName, negateName, fromIntegerName, fromRationalName )
import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc,
)
import List ( nub )
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
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}
+
%************************************************************************
%* *
knownKeyNames,
mkTupNameStr, mkTupConRdrName,
- SyntaxMap, vanillaSyntaxMap, SyntaxList, syntaxList,
-
------------------------------------------------------------
-- Goups of classes and types
needsDataDeclCtxtClassKeys, cCallishClassKeys, noDictClassKeys,
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
emptyAvailEnv, unitAvailEnv, availEnvElts,
plusAvailEnv, groupAvails, warnUnusedImports,
warnUnusedLocalBinds, warnUnusedModules,
- lookupSrcName, getImplicitStmtFVs, getImplicitModuleFVs, rnSyntaxNames,
+ lookupSrcName, getImplicitStmtFVs, getImplicitModuleFVs,
newGlobalName, unQualInScope,, ubiquitousNames
)
import Module ( Module, ModuleName, WhereFrom(..),
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 )
-> 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
-> 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
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"
\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 $
-- 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
-- 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}
extendLocalRdrEnv
)
import RnMonad
-import Name ( Name,
+import Name ( Name,
getSrcLoc, nameIsLocalOrFrom,
mkLocalName, mkGlobalName,
mkIPName, nameOccName, nameModule_maybe,
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,
-- 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}
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) ->
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) ->
---------------------------
-- (- 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
= 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
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
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.
-- 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}
%************************************************************************
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,
-> 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
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}
-- 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
-- Global environment
tcExtendGlobalEnv, tcExtendGlobalValEnv, tcExtendGlobalTypeEnv,
tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
- tcLookupGlobal_maybe, tcLookupGlobal, tcLookupSyntaxId, tcLookupSyntaxName,
+ tcLookupGlobal_maybe, tcLookupGlobal,
-- Local environment
tcExtendKindEnv, tcLookupLocalIds, tcInLocalScope,
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)
-- 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,
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}
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 )
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) ->
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 ->
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
)
-> 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,
-- 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 $
-> 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 $
-> 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)
}
-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 }
-> 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 }
\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
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 )
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}
%************************************************************************
%************************************************************************
\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 ->
projects / ghc-hetmet.git / commitdiff