data HsExpr id pat
= HsVar id -- variable
| HsIPVar id -- implicit parameter
- | HsOverLit (HsOverLit id) -- Overloaded literals; eliminated by type checker
+ | HsOverLit HsOverLit -- Overloaded literals; eliminated by type checker
| HsLit HsLit -- Simple (non-overloaded) literals
| HsLam (Match id pat) -- lambda
-- They are eventually removed by the type checker.
| NegApp (HsExpr id pat) -- negated expr
- id -- the negate id (in a HsVar)
| HsPar (HsExpr id pat) -- parenthesised expr
| 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)
-- before the typechecker it's just an error value
deriving( Eq )
-data HsOverLit name -- An overloaded literal
- = HsIntegral Integer name -- Integer-looking literals;
- -- The names is "fromInteger"
- | HsFractional Rational name -- Frac-looking literals
- -- The name is "fromRational"
+data HsOverLit -- An overloaded literal
+ = HsIntegral Integer -- Integer-looking literals;
+ | HsFractional Rational -- Frac-looking literals
-instance Eq (HsOverLit name) where
- (HsIntegral i1 _) == (HsIntegral i2 _) = i1 == i2
- (HsFractional f1 _) == (HsFractional f2 _) = f1 == f2
+instance Eq HsOverLit where
+ (HsIntegral i1) == (HsIntegral i2) = i1 == i2
+ (HsFractional f1) == (HsFractional f2) = f1 == f2
-instance Ord (HsOverLit name) where
- compare (HsIntegral i1 _) (HsIntegral i2 _) = i1 `compare` i2
- compare (HsIntegral _ _) (HsFractional _ _) = LT
- compare (HsFractional f1 _) (HsFractional f2 _) = f1 `compare` f2
- compare (HsFractional f1 _) (HsIntegral _ _) = GT
+instance Ord HsOverLit where
+ compare (HsIntegral i1) (HsIntegral i2) = i1 `compare` i2
+ compare (HsIntegral _) (HsFractional _) = LT
+ compare (HsFractional f1) (HsFractional f2) = f1 `compare` f2
+ compare (HsFractional f1) (HsIntegral _) = GT
\end{code}
\begin{code}
ppr (HsIntPrim i) = integer i <> char '#'
ppr (HsLitLit s _) = hcat [text "``", ptext s, text "''"]
-instance Outputable (HsOverLit name) where
- ppr (HsIntegral i _) = integer i
- ppr (HsFractional f _) = rational f
+instance Outputable HsOverLit where
+ ppr (HsIntegral i) = integer i
+ ppr (HsFractional f) = rational f
\end{code}
Fixity -- c.f. OpApp in HsExpr
(InPat name)
- | NPatIn (HsOverLit name)
+ | NPatIn HsOverLit
| NPlusKPatIn name -- n+k pattern
- (HsOverLit name) -- It'll always be an HsIntegral, but
- -- we need those names to support -fuser-numerics
- name -- Name for "-"; this supports -fuser-numerics
- -- We don't do the same for >= because that isn't
- -- affected by -fuser-numerics
+ HsOverLit -- It'll always be an HsIntegral
-- We preserve prefix negation and parenthesis for the precedence parser.
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
in
returnP (SigPatIn e t')
- OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral k _))
+ OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral k))
| plus == plus_RDR
- -> returnP (NPlusKPatIn n lit minus_RDR)
+ -> returnP (NPlusKPatIn n lit)
where
plus_RDR = mkUnqual varName SLIT("+") -- Hack
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.52 2001/02/11 09:36:00 qrczak Exp $
+$Id: Parser.y,v 1.53 2001/02/20 09:40:43 simonpj Exp $
Haskell grammar.
import Lex
import ParseUtil
import RdrName
-import PrelNames
+import PrelNames ( mAIN_Name, unitTyCon_RDR, funTyCon_RDR, listTyCon_RDR,
+ tupleTyCon_RDR, unitCon_RDR, nilCon_RDR, tupleCon_RDR
+ )
import OccName ( UserFS, varName, ipName, tcName, dataName, tcClsName, tvName )
import SrcLoc ( SrcLoc )
import Module
: ipvar { HsIPVar $1 }
| var_or_con { $1 }
| literal { HsLit $1 }
- | INTEGER { HsOverLit (HsIntegral $1 fromInteger_RDR) }
- | RATIONAL { HsOverLit (HsFractional $1 fromRational_RDR) }
+ | INTEGER { HsOverLit (HsIntegral $1) }
+ | RATIONAL { HsOverLit (HsFractional $1) }
| '(' exp ')' { HsPar $2 }
| '(' exp ',' texps ')' { ExplicitTuple ($2 : reverse $4) Boxed}
| '(#' texps '#)' { ExplicitTuple (reverse $2) Unboxed }
knownKeyNames,
mkTupNameStr, mkTupConRdrName,
+ SyntaxMap, vanillaSyntaxMap, SyntaxList, syntaxList,
+
------------------------------------------------------------
-- Goups of classes and types
needsDataDeclCtxtClassKeys, cCallishClassKeys, noDictClassKeys,
-- ClassOps
fromIntName,
fromIntegerName,
+ negateName,
geName,
minusName,
enumFromName,
fromIntName = varQual pREL_NUM_Name SLIT("fromInt") fromIntClassOpKey
fromIntegerName = varQual pREL_NUM_Name SLIT("fromInteger") fromIntegerClassOpKey
minusName = varQual pREL_NUM_Name SLIT("-") minusClassOpKey
+negateName = varQual pREL_NUM_Name SLIT("negate") negateClassOpKey
plusIntegerName = varQual pREL_NUM_Name SLIT("plusInteger") plusIntegerIdKey
timesIntegerName = varQual pREL_NUM_Name SLIT("timesInteger") timesIntegerIdKey
integerTyConName = tcQual pREL_NUM_Name SLIT("Integer") integerTyConKey
enumFromThenToClassOpKey = mkPreludeMiscIdUnique 108
eqClassOpKey = mkPreludeMiscIdUnique 109
geClassOpKey = mkPreludeMiscIdUnique 110
+negateClassOpKey = mkPreludeMiscIdUnique 111
failMClassOpKey = mkPreludeMiscIdUnique 112
thenMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=)
-- Just a place holder for unbound variables produced by the renamer:
%************************************************************************
%* *
+\subsection{Re-bindable desugaring names}
+%* *
+%************************************************************************
+
+Haskell 98 says that when you say "3" you get the "fromInt" from the
+Standard Prelude, regardless of what is in scope. However, to experiment
+with having a language that is less coupled to the standard prelude, we're
+trying a non-standard extension that instead gives you whatever "Prelude.fromInt"
+happens to be in scope. Then you can
+ import Prelude ()
+ import MyPrelude as Prelude
+to get the desired effect.
+
+The SyntaxNames record gives all the names you can rebind in this way.
+This record of names needs to go through the renamer to map RdrNames to
+Names (i.e. look up the names in the in-scope environment), to suck in
+their type signatures from interface file(s).
+
+\begin{code}
+type SyntaxList = [(Name, RdrName)]
+ -- Maps a Name, which identifies the standard built-in thing
+ -- to a RdrName for the re-mapped version of the built-in thing
+
+syntaxList :: SyntaxList
+syntaxList =[ (fromIntName, mkUnqual varName SLIT("fromInt"))
+ , (fromIntegerName, mkUnqual varName SLIT("fromInteger"))
+ , (fromRationalName, mkUnqual varName SLIT("fromRational"))
+ , (negateName, mkUnqual varName SLIT("negate"))
+ , (minusName, mkUnqual varName SLIT("-"))
+ -- For now that's all. We may add booleans and lists later.
+ ]
+
+
+type SyntaxMap = Name -> Name
+ -- Maps a standard built-in name, such as PrelNum.fromInt
+ -- to its re-mapped version, such as MyPrelude.fromInt
+
+vanillaSyntaxMap name = name
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection[Class-std-groups]{Standard groups of Prelude classes}
%* *
%************************************************************************
import RnNames ( getGlobalNames, exportsFromAvail )
import RnSource ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl )
import RnIfaces ( slurpImpDecls, mkImportInfo, recordLocalSlurps,
- getInterfaceExports, closeDecls,
+ closeDecls,
RecompileRequired, outOfDate, recompileRequired
)
import RnHiFiles ( readIface, removeContext, loadInterface,
loadExports, loadFixDecls, loadDeprecs,
tryLoadInterface )
-import RnEnv ( availsToNameSet, availName, mkIfaceGlobalRdrEnv,
+import RnEnv ( availsToNameSet, mkIfaceGlobalRdrEnv,
emptyAvailEnv, unitAvailEnv, availEnvElts,
plusAvailEnv, groupAvails, warnUnusedImports,
warnUnusedLocalBinds, warnUnusedModules,
- lookupOrigNames, lookupSrcName,
- newGlobalName, unQualInScope
+ lookupSrcName, addImplicitFVs,
+ newGlobalName, unQualInScope,, ubiquitousNames
)
import Module ( Module, ModuleName, WhereFrom(..),
moduleNameUserString, moduleName,
moduleEnvElts
)
-import Name ( Name, NamedThing(..), getSrcLoc,
+import Name ( Name, NamedThing(..),
nameIsLocalOrFrom, nameOccName, nameModule,
)
import Name ( mkNameEnv, nameEnvElts, extendNameEnv )
import RdrName ( foldRdrEnv, isQual )
-import OccName ( occNameFlavour )
import NameSet
-import TysWiredIn ( unitTyCon, intTyCon, boolTyCon )
-import PrelNames ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name,
- ioTyConName, printName,
- unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name,
- eqStringName
- )
-import PrelInfo ( derivingOccurrences )
-import Type ( funTyCon )
+import PrelNames ( SyntaxMap, pRELUDE_Name )
import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass,
printErrorsAndWarnings, errorsFound )
import Bag ( bagToList )
import FiniteMap ( FiniteMap, fmToList, emptyFM, lookupFM,
addToFM_C, elemFM, addToFM
)
-import UniqFM ( lookupWithDefaultUFM )
import Maybes ( maybeToBool, catMaybes )
import Outputable
import IO ( openFile, IOMode(..) )
ModIface(..), WhatsImported(..),
VersionInfo(..), ImportVersion, IsExported,
IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
- GlobalRdrEnv, pprGlobalRdrEnv,
+ GlobalRdrEnv, GlobalRdrElt(..), pprGlobalRdrEnv,
AvailEnv, GenAvailInfo(..), AvailInfo, Avails,
Provenance(..), ImportReason(..), initialVersionInfo,
- Deprecations(..), lookupDeprec, lookupIface
+ Deprecations(..)
)
import CmStaticInfo ( GhciMode(..) )
import List ( partition, nub )
-> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
-> Module -> RdrNameHsModule
- -> IO (PersistentCompilerState, Maybe (PrintUnqualified, (IsExported, ModIface, [RenamedHsDecl])))
+ -> IO (PersistentCompilerState,
+ Maybe (PrintUnqualified, (IsExported, ModIface, (SyntaxMap, [RenamedHsDecl]))))
-- Nothing => some error occurred in the renamer
renameModule dflags hit hst pcs this_module rdr_module
-> PersistentCompilerState
-> Module -> RdrNameHsExpr
-> IO ( PersistentCompilerState,
- Maybe (PrintUnqualified, (RenamedHsExpr, [RenamedHsDecl]))
+ Maybe (PrintUnqualified, (SyntaxMap, RenamedHsExpr, [RenamedHsDecl]))
)
renameExpr dflags hit hst pcs this_module expr
returnRn Nothing
else
- let
- implicit_fvs = fvs `plusFV` string_names
- `plusFV` default_tycon_names
- `plusFV` unitFV printName
- -- print :: a -> IO () may be needed later
- in
- slurpImpDecls (fvs `plusFV` implicit_fvs) `thenRn` \ decls ->
+ addImplicitFVs rdr_env Nothing fvs `thenRn` \ (slurp_fvs, syntax_map) ->
+ slurpImpDecls slurp_fvs `thenRn` \ decls ->
doDump e decls `thenRn_`
- returnRn (Just (print_unqual, (e, decls)))
+ returnRn (Just (print_unqual, (syntax_map, e, decls)))
}
where
doc = text "context for compiling expression"
\end{code}
\begin{code}
-rename :: Module -> RdrNameHsModule -> RnMG (Maybe (PrintUnqualified, (IsExported, ModIface, [RenamedHsDecl])))
+rename :: Module -> RdrNameHsModule
+ -> RnMG (Maybe (PrintUnqualified, (IsExported, ModIface, (SyntaxMap, [RenamedHsDecl]))))
rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec loc)
= pushSrcLocRn loc $
else
-- SLURP IN ALL THE NEEDED DECLARATIONS
- implicitFVs mod_name rn_local_decls `thenRn` \ implicit_fvs ->
- let
- slurp_fvs = implicit_fvs `plusFV` source_fvs
- -- It's important to do the "plus" this way round, so that
- -- when compiling the prelude, locally-defined (), Bool, etc
- -- override the implicit ones.
- in
+ addImplicitFVs gbl_env (Just (mod_name, rn_local_decls))
+ source_fvs `thenRn` \ (slurp_fvs, sugar_map) ->
traceRn (text "Source FVs:" <+> fsep (map ppr (nameSetToList slurp_fvs))) `thenRn_`
slurpImpDecls slurp_fvs `thenRn` \ rn_imp_decls ->
imports global_avail_env
source_fvs export_avails rn_imp_decls `thenRn_`
- returnRn (Just (print_unqualified, (is_exported, mod_iface, final_decls)))
+ returnRn (Just (print_unqualified, (is_exported, mod_iface, (sugar_map, final_decls))))
where
mod_name = moduleName this_module
\end{code}
-@implicitFVs@ forces the renamer to slurp in some things which aren't
-mentioned explicitly, but which might be needed by the type checker.
-
-\begin{code}
-implicitFVs mod_name decls
- = lookupOrigNames deriv_occs `thenRn` \ deriving_names ->
- returnRn (default_tycon_names `plusFV`
- string_names `plusFV`
- deriving_names `plusFV`
- implicit_main)
- where
-
- -- Add occurrences for IO or PrimIO
- implicit_main | mod_name == mAIN_Name
- || mod_name == pREL_MAIN_Name = unitFV ioTyConName
- | otherwise = emptyFVs
-
- deriv_occs = [occ | TyClD (TyData {tcdDerivs = Just deriv_classes}) <- decls,
- cls <- deriv_classes,
- occ <- lookupWithDefaultUFM derivingOccurrences [] cls ]
-
--- Virtually every program has error messages in it somewhere
-string_names = mkFVs [unpackCStringName, unpackCStringFoldrName,
- unpackCStringUtf8Name, eqStringName]
-
--- Add occurrences for Int, and (), because they
--- are the types to which ambigious type variables may be defaulted by
--- the type checker; so they won't always appear explicitly.
--- [The () one is a GHC extension for defaulting CCall results.]
--- ALSO: funTyCon, since it occurs implicitly everywhere!
--- (we don't want to be bothered with making funTyCon a
--- free var at every function application!)
--- Double is dealt with separately in getGates
-default_tycon_names = mkFVs (map getName [unitTyCon, funTyCon, boolTyCon, intTyCon])
-\end{code}
-
\begin{code}
isOrphanDecl this_mod (InstD (InstDecl inst_ty _ _ _ _))
= not (foldNameSet ((||) . nameIsLocalOrFrom this_mod) False
check (HsLit _) = False
check (HsOverLit _) = False
check (OpApp l o _ r) = check l && check o && check r
- check (NegApp e _) = check e
+ check (NegApp e) = check e
check (HsPar e) = check e
check (SectionL e o) = check e && check o
check (SectionR o e) = check e && check o
rnDump [] closed_decls `thenRn_`
returnRn closed_decls
where
- implicit_fvs = string_names -- Data type decls with record selectors,
- -- which may appear in the decls, need unpackCString
- -- and friends. It's easier to just grab them right now.
+ implicit_fvs = ubiquitousNames -- Data type decls with record selectors,
+ -- which may appear in the decls, need unpackCString
+ -- and friends. It's easier to just grab them right now.
\end{code}
%*********************************************************
= warnUnusedModules unused_imp_mods `thenRn_`
warnUnusedLocalBinds bad_locals `thenRn_`
warnUnusedImports bad_imp_names `thenRn_`
- printMinimalImports this_mod unqual minimal_imports `thenRn_`
- warnDeprecations this_mod export_avails my_deprecs
- really_used_names
-
+ printMinimalImports this_mod unqual minimal_imports
where
this_mod = mi_module my_mod_iface
gbl_env = mi_globals my_mod_iface
- my_deprecs = mi_deprecs my_mod_iface
-- The export_fvs make the exported names look just as if they
-- occurred in the source program.
-- Collect the defined names from the in-scope environment
-- Look for the qualified ones only, else get duplicates
- defined_names :: [(Name,Provenance)]
+ defined_names :: [GlobalRdrElt]
defined_names = foldRdrEnv add [] gbl_env
add rdr_name ns acc | isQual rdr_name = ns ++ acc
| otherwise = acc
- defined_and_used, defined_but_not_used :: [(Name,Provenance)]
+ defined_and_used, defined_but_not_used :: [GlobalRdrElt]
(defined_and_used, defined_but_not_used) = partition used defined_names
- used (name,_) = name `elemNameSet` really_used_names
+ used (GRE name _ _) = name `elemNameSet` really_used_names
-- Filter out the ones only defined implicitly
bad_locals :: [Name]
- bad_locals = [n | (n,LocalDef) <- defined_but_not_used]
+ bad_locals = [n | (GRE n LocalDef _) <- defined_but_not_used]
bad_imp_names :: [(Name,Provenance)]
- bad_imp_names = [(n,p) | (n,p@(NonLocalDef (UserImport mod _ True))) <- defined_but_not_used,
+ bad_imp_names = [(n,p) | GRE n p@(NonLocalDef (UserImport mod _ True)) _ <- defined_but_not_used,
not (module_unused mod)]
-- inst_mods are directly-imported modules that
-- We've carefully preserved the provenance so that we can
-- construct minimal imports that import the name by (one of)
-- the same route(s) as the programmer originally did.
- add_name (n,NonLocalDef (UserImport m _ _)) acc = addToFM_C plusAvailEnv acc (moduleName m)
- (unitAvailEnv (mk_avail n))
- add_name (n,other_prov) acc = acc
+ add_name (GRE n (NonLocalDef (UserImport m _ _)) _) acc = addToFM_C plusAvailEnv acc (moduleName m)
+ (unitAvailEnv (mk_avail n))
+ add_name (GRE n other_prov _) acc = acc
mk_avail n = case lookupNameEnv avail_env n of
Just (AvailTC m _) | n==m -> AvailTC n [n]
module_unused :: Module -> Bool
module_unused mod = moduleName mod `elem` unused_imp_mods
-warnDeprecations this_mod export_avails my_deprecs used_names
- = doptRn Opt_WarnDeprecations `thenRn` \ warn_drs ->
- if not warn_drs then returnRn () else
-
- -- The home modules for things in the export list
- -- may not have been loaded yet; do it now, so
- -- that we can see their deprecations, if any
- mapRn_ load_home export_mods `thenRn_`
-
- getIfacesRn `thenRn` \ ifaces ->
- getHomeIfaceTableRn `thenRn` \ hit ->
- let
- pit = iPIT ifaces
- deprecs = [ (n,txt)
- | n <- nameSetToList used_names,
- not (nameIsLocalOrFrom this_mod n),
- Just txt <- [lookup_deprec hit pit n] ]
- -- nameIsLocalOrFrom: don't complain about locally defined names
- -- For a start, we may be exporting a deprecated thing
- -- Also we may use a deprecated thing in the defn of another
- -- deprecated things. We may even use a deprecated thing in
- -- the defn of a non-deprecated thing, when changing a module's
- -- interface
- in
- mapRn_ warnDeprec deprecs
-
- where
- export_mods = nub [ moduleName mod
- | avail <- export_avails,
- let mod = nameModule (availName avail),
- mod /= this_mod ]
-
- load_home m = loadInterface (text "Check deprecations for" <+> ppr m) m ImportBySystem
-
- lookup_deprec hit pit n
- = case lookupIface hit pit n of
- Just iface -> lookupDeprec (mi_deprecs iface) n
- Nothing -> pprPanic "warnDeprecations:" (ppr n)
-- ToDo: deal with original imports with 'qualified' and 'as M' clauses
+printMinimalImports :: Module -- This module
+ -> PrintUnqualified
+ -> FiniteMap ModuleName AvailEnv -- Minimal imports
+ -> RnMG ()
printMinimalImports this_mod unqual imps
= doptRn Opt_D_dump_minimal_imports `thenRn` \ dump_minimal ->
if not dump_minimal then returnRn () else
returnRn (mod, ies)
to_ie :: AvailInfo -> RnMG (IE Name)
+ -- The main trick here is that if we're importing all the constructors
+ -- we want to say "T(..)", but if we're importing only a subset we want
+ -- to say "T(A,B,C)". So we have to find out what the module exports.
to_ie (Avail n) = returnRn (IEVar n)
to_ie (AvailTC n [m]) = ASSERT( n==m )
returnRn (IEThingAbs n)
to_ie (AvailTC n ns)
- = getInterfaceExports n_mod ImportBySystem `thenRn` \ (_, avails_by_module) ->
- case [xs | (m,as) <- avails_by_module,
+ = loadInterface (text "Compute minimal imports from" <+> ppr n_mod) n_mod ImportBySystem `thenRn` \ iface ->
+ case [xs | (m,as) <- mi_exports iface,
m == n_mod,
AvailTC x xs <- as,
x == n] of
%************************************************************************
\begin{code}
-warnDeprec :: (Name, DeprecTxt) -> RnM d ()
-warnDeprec (name, txt)
- = pushSrcLocRn (getSrcLoc name) $
- addWarnRn $
- sep [ text (occNameFlavour (nameOccName name)) <+> quotes (ppr name) <+>
- text "is deprecated:", nest 4 (ppr txt) ]
-
-
dupFixityDecl rdr_name loc1 loc2
= vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
ptext SLIT("at ") <+> ppr loc1,
import HscTypes ( ModIface(..) )
import HsSyn
+import RnHsSyn ( RenamedHsDecl )
import RdrHsSyn ( RdrNameIE )
import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig,
mkRdrUnqual, mkRdrQual, qualifyRdrName, lookupRdrEnv, foldRdrEnv
)
import HsTypes ( hsTyVarName, replaceTyVarName )
import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv,
- ImportReason(..), GlobalRdrEnv, AvailEnv,
- AvailInfo, Avails, GenAvailInfo(..), NameSupply(..) )
+ ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), AvailEnv,
+ AvailInfo, Avails, GenAvailInfo(..), NameSupply(..),
+ Deprecations(..), lookupDeprec
+ )
import RnMonad
import Name ( Name,
getSrcLoc,
mkLocalName, mkGlobalName,
mkIPName, nameOccName, nameModule_maybe,
- setNameModuleAndLoc
+ setNameModuleAndLoc, mkNameEnv
)
import Name ( extendNameEnv_C, plusNameEnv_C, nameEnvElts )
import NameSet
import OccName ( OccName, occNameUserString, occNameFlavour )
import Module ( ModuleName, moduleName, mkVanillaModule,
- mkSysModuleNameFS, moduleNameFS,
- WhereFrom(..) )
+ mkSysModuleNameFS, moduleNameFS, WhereFrom(..) )
+import TysWiredIn ( unitTyCon, intTyCon, boolTyCon )
+import Type ( funTyCon )
+import PrelNames ( mkUnboundName, syntaxList, SyntaxMap, vanillaSyntaxMap,
+ derivingOccurrences,
+ mAIN_Name, pREL_MAIN_Name,
+ ioTyConName, printName,
+ unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name,
+ eqStringName
+ )
import FiniteMap
import UniqSupply
import SrcLoc ( SrcLoc, noSrcLoc )
import ListSetOps ( removeDups, equivClasses )
import Util ( sortLt )
import List ( nub )
-import PrelNames ( mkUnboundName )
+import UniqFM ( lookupWithDefaultUFM )
+import Maybes ( orElse )
import CmdLineOpts
import FastString ( FastString )
\end{code}
newTopBinder mod rdr_name loc
= -- First check the cache
- -- traceRn (text "newTopBinder" <+> ppr mod <+> ppr loc) `thenRn_`
-- There should never be a qualified name in a binding position (except in instance decls)
-- The parser doesn't check this because the same parser parses instance decls
new_cache = addToFM cache key new_name
in
setNameSupplyRn (name_supply {nsNames = new_cache}) `thenRn_`
- traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
+-- traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_`
returnRn new_name
-- Miss in the cache!
new_cache = addToFM cache key new_name
in
setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_`
- traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
+-- traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_`
returnRn new_name
| otherwise
= case lookupRdrEnv global_env rdr_name of
- Just [(name,_)] -> returnRn name
- Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff `thenRn_`
- returnRn name
- Nothing -> failWithRn (mkUnboundName rdr_name)
- (unknownNameErr rdr_name)
+ Just [GRE name _ Nothing] -> returnRn name
+ Just [GRE name _ (Just deprec)] -> warnDeprec name deprec `thenRn_`
+ returnRn name
+ Just stuff@(GRE name _ _ : _) -> addNameClashErrRn rdr_name stuff `thenRn_`
+ returnRn name
+ Nothing -> failWithRn (mkUnboundName rdr_name)
+ (unknownNameErr rdr_name)
lookupOrigName :: RdrName -> RnM d Name
lookupOrigName rdr_name
%*********************************************************
%* *
+\subsection{Implicit free vars and sugar names}
+%* *
+%*********************************************************
+
+@addImplicitFVs@ forces the renamer to slurp in some things which aren't
+mentioned explicitly, but which might be needed by the type checker.
+
+\begin{code}
+addImplicitFVs :: GlobalRdrEnv
+ -> Maybe (ModuleName, [RenamedHsDecl]) -- Nothing when compling an expression
+ -> FreeVars -- Free in the source
+ -> RnMG (FreeVars, SyntaxMap) -- Augmented source free vars
+
+addImplicitFVs gbl_env maybe_mod source_fvs
+ = -- Find out what re-bindable names to use for desugaring
+ rnSyntaxNames gbl_env source_fvs `thenRn` \ (source_fvs1, sugar_map) ->
+
+ -- Find implicit FVs thade
+ extra_implicits maybe_mod `thenRn` \ extra_fvs ->
+
+ let
+ implicit_fvs = ubiquitousNames `plusFV` extra_fvs
+ slurp_fvs = implicit_fvs `plusFV` source_fvs1
+ -- It's important to do the "plus" this way round, so that
+ -- when compiling the prelude, locally-defined (), Bool, etc
+ -- override the implicit ones.
+ in
+ returnRn (slurp_fvs, sugar_map)
+
+ where
+ extra_implicits Nothing -- Compiling an expression
+ = returnRn (unitFV printName) -- print :: a -> IO () may be needed later
+
+ extra_implicits (Just (mod_name, decls)) -- Compiling a module
+ = lookupOrigNames deriv_occs `thenRn` \ deriving_names ->
+ returnRn (deriving_names `plusFV` implicit_main)
+ where
+ -- Add occurrences for IO or PrimIO
+ implicit_main | mod_name == mAIN_Name
+ || mod_name == pREL_MAIN_Name = unitFV ioTyConName
+ | otherwise = emptyFVs
+
+ deriv_occs = [occ | TyClD (TyData {tcdDerivs = Just deriv_classes}) <- decls,
+ cls <- deriv_classes,
+ occ <- lookupWithDefaultUFM derivingOccurrences [] cls ]
+
+-- ubiquitous_names are loaded regardless, because
+-- they are needed in virtually every program
+ubiquitousNames
+ = mkFVs [unpackCStringName, unpackCStringFoldrName,
+ unpackCStringUtf8Name, eqStringName]
+ -- Virtually every program has error messages in it somewhere
+
+ `plusFV`
+ mkFVs (map getName [unitTyCon, funTyCon, boolTyCon, intTyCon])
+ -- Add occurrences for Int, and (), because they
+ -- are the types to which ambigious type variables may be defaulted by
+ -- the type checker; so they won't always appear explicitly.
+ -- [The () one is a GHC extension for defaulting CCall results.]
+ -- ALSO: funTyCon, since it occurs implicitly everywhere!
+ -- (we don't want to be bothered with making funTyCon a
+ -- free var at every function application!)
+ -- Double is dealt with separately in getGates
+\end{code}
+
+\begin{code}
+rnSyntaxNames :: GlobalRdrEnv -> FreeVars -> RnMG (FreeVars, SyntaxMap)
+-- Look up the re-bindable syntactic sugar names
+-- Any errors arising from these lookups may surprise the
+-- programmer, since they aren't explicitly mentioned, and
+-- the src line will be unhelpful (ToDo)
+
+rnSyntaxNames gbl_env source_fvs
+ = doptRn Opt_NoImplicitPrelude `thenRn` \ no_prelude ->
+ if not no_prelude then
+ returnRn (source_fvs, vanillaSyntaxMap)
+ else
+
+ -- There's a -fno-implicit-prelude flag,
+ -- so build the re-mapping function
+ let
+ reqd_syntax_list = filter is_reqd syntaxList
+ is_reqd (n,_) = n `elemNameSet` source_fvs
+ lookup (n,rn) = lookupSrcName gbl_env rn `thenRn` \ rn' ->
+ returnRn (n,rn')
+ in
+ mapRn lookup reqd_syntax_list `thenRn` \ rn_syntax_list ->
+ let
+ -- Delete the proxies and add the actuals
+ proxies = map fst rn_syntax_list
+ actuals = map snd rn_syntax_list
+ new_source_fvs = (proxies `delFVs` source_fvs) `plusFV` mkFVs actuals
+
+ syntax_env = mkNameEnv rn_syntax_list
+ syntax_map n = lookupNameEnv syntax_env n `orElse` n
+ in
+ returnRn (new_source_fvs, syntax_map)
+\end{code}
+
+
+%*********************************************************
+%* *
\subsection{Binding}
%* *
%*********************************************************
-- version is hidden)
-> (Name -> Provenance)
-> Avails -- Whats imported and how
+ -> Deprecations
-> GlobalRdrEnv
-mkGlobalRdrEnv this_mod unqual_imp qual_imp hides mk_provenance avails
+mkGlobalRdrEnv this_mod unqual_imp qual_imp hides
+ mk_provenance avails deprecs
= gbl_env2
where
-- Make the name environment. We're talking about a
| qual_imp = env1
| otherwise = env
where
- env1 = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) (name,prov)
- env2 = addOneToGlobalRdrEnv env (mkRdrUnqual occ) (name,prov)
- env3 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) (name,prov)
+ env1 = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) elt
+ env2 = addOneToGlobalRdrEnv env (mkRdrUnqual occ) elt
+ env3 = addOneToGlobalRdrEnv env1 (mkRdrUnqual occ) elt
occ = nameOccName name
- prov = mk_provenance name
+ elt = GRE name (mk_provenance name) (lookupDeprec deprecs name)
del_avail env avail = foldl delOneFromGlobalRdrEnv env rdr_names
where
mkIfaceGlobalRdrEnv m_avails
= foldl add emptyRdrEnv m_avails
where
- add env (mod,avails) = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True False [] (\n -> LocalDef) avails)
+ add env (mod,avails) = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True False []
+ (\n -> LocalDef) avails NoDeprecs)
+ -- The NoDeprecs is a bit of a hack I suppose
\end{code}
\begin{code}
plusGlobalRdrEnv :: GlobalRdrEnv -> GlobalRdrEnv -> GlobalRdrEnv
plusGlobalRdrEnv env1 env2 = plusFM_C combine_globals env1 env2
-addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> (Name,Provenance) -> GlobalRdrEnv
+addOneToGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrElt -> GlobalRdrEnv
addOneToGlobalRdrEnv env rdr_name name = addToFM_C combine_globals env rdr_name [name]
delOneFromGlobalRdrEnv :: GlobalRdrEnv -> RdrName -> GlobalRdrEnv
delOneFromGlobalRdrEnv env rdr_name = delFromFM env rdr_name
-combine_globals :: [(Name,Provenance)] -- Old
- -> [(Name,Provenance)] -- New
- -> [(Name,Provenance)]
+combine_globals :: [GlobalRdrElt] -- Old
+ -> [GlobalRdrElt] -- New
+ -> [GlobalRdrElt]
combine_globals ns_old ns_new -- ns_new is often short
= foldr add ns_old ns_new
where
choose n m | n `beats` m = n
| otherwise = m
- (n,pn) `beats` (m,pm) = n==m && pn `hasBetterProv` pm
+ (GRE n pn _) `beats` (GRE m pm _) = n==m && pn `hasBetterProv` pm
- is_duplicate :: (Name,Provenance) -> (Name,Provenance) -> Bool
- is_duplicate (n1,LocalDef) (n2,LocalDef) = False
- is_duplicate (n1,_) (n2,_) = n1 == n2
+ is_duplicate :: GlobalRdrElt -> GlobalRdrElt -> Bool
+ is_duplicate (GRE n1 LocalDef _) (GRE n2 LocalDef _) = False
+ is_duplicate (GRE n1 _ _) (GRE n2 _ _) = n1 == n2
\end{code}
We treat two bindings of a locally-defined name as a duplicate,
where
unqual_names :: NameSet
unqual_names = foldRdrEnv add emptyNameSet env
- add rdr_name [(name,_)] unquals | isUnqual rdr_name = addOneToNameSet unquals name
- add _ _ unquals = unquals
+ add rdr_name [GRE name _ _] unquals | isUnqual rdr_name = addOneToNameSet unquals name
+ add _ _ unquals = unquals
\end{code}
where
msg1 = ptext SLIT("either") <+> mk_ref np1
msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps]
- mk_ref (name,prov) = quotes (ppr name) <> comma <+> pprNameProvenance name prov
-
-fixityClashErr (rdr_name, ((_,how_in_scope1), (_, how_in_scope2)))
- = hang (hsep [ptext SLIT("Conflicting fixities for"), quotes (ppr rdr_name)])
- 4 (vcat [ppr how_in_scope1,
- ppr how_in_scope2])
+ mk_ref (GRE name prov _) = quotes (ppr name) <> comma <+> pprNameProvenance name prov
shadowedNameWarn shadow
= hsep [ptext SLIT("This binding for"),
addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name))
$$
(ptext SLIT("in") <+> descriptor))
+
+warnDeprec :: Name -> DeprecTxt -> RnM d ()
+warnDeprec name txt
+ = doptRn Opt_WarnDeprecations `thenRn` \ warn_drs ->
+ if not warn_drs then returnRn () else
+ addWarnRn (sep [ text (occNameFlavour (nameOccName name)) <+>
+ quotes (ppr name) <+> text "is deprecated:",
+ nest 4 (ppr txt) ])
\end{code}
import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts )
import Literal ( inIntRange )
import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity )
-import PrelNames ( hasKey, assertIdKey,
+import PrelNames ( hasKey, assertIdKey, minusName, negateName, fromIntName,
eqClass_RDR, foldr_RDR, build_RDR, eqString_RDR,
cCallableClass_RDR, cReturnableClass_RDR,
monadClass_RDR, enumClass_RDR, ordClass_RDR,
- ratioDataCon_RDR, negate_RDR, assertErr_RDR,
- ioDataCon_RDR, plusInteger_RDR, timesInteger_RDR
+ ratioDataCon_RDR, assertErr_RDR,
+ ioDataCon_RDR, plusInteger_RDR, timesInteger_RDR,
+ fromInteger_RDR, fromRational_RDR,
)
import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
floatPrimTyCon, doublePrimTyCon
lookupOrigName eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern
returnRn (NPatIn lit', fvs1 `addOneFV` eq)
-rnPat (NPlusKPatIn name lit minus)
+rnPat (NPlusKPatIn name lit)
= rnOverLit lit `thenRn` \ (lit', fvs) ->
lookupOrigName ordClass_RDR `thenRn` \ ord ->
lookupBndrRn name `thenRn` \ name' ->
- lookupOccRn minus `thenRn` \ minus' ->
- returnRn (NPlusKPatIn name' lit' minus', fvs `addOneFV` ord `addOneFV` minus')
+ returnRn (NPlusKPatIn name' lit', fvs `addOneFV` ord `addOneFV` minusName)
rnPat (LazyPatIn pat)
= rnPat pat `thenRn` \ (pat', fvs) ->
returnRn (final_e,
fv_e1 `plusFV` fv_op `plusFV` fv_e2)
-rnExpr (NegApp e n)
+rnExpr (NegApp e)
= rnExpr e `thenRn` \ (e', fv_e) ->
- lookupOrigName negate_RDR `thenRn` \ neg ->
- mkNegAppRn e' neg `thenRn` \ final_e ->
- returnRn (final_e, fv_e `addOneFV` neg)
+ mkNegAppRn e' `thenRn` \ final_e ->
+ returnRn (final_e, fv_e `addOneFV` negateName)
rnExpr (HsPar e)
= rnExpr e `thenRn` \ (e', fvs_e) ->
---------------------------
-- (- neg_arg) `op` e2
-mkOpAppRn e1@(NegApp neg_arg neg_op) op2 fix2 e2
+mkOpAppRn e1@(NegApp neg_arg) op2 fix2 e2
| nofix_error
= addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenRn_`
returnRn (OpApp e1 op2 fix2 e2)
| associate_right
= mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
- returnRn (NegApp new_e neg_op)
+ returnRn (NegApp new_e)
where
(nofix_error, associate_right) = compareFixity negateFixity fix2
---------------------------
-- e1 `op` - neg_arg
-mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg neg_op) -- NegApp can occur on the right
+mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg) -- NegApp can occur on the right
| not associate_right -- We *want* right association
= addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_`
returnRn (OpApp e1 op1 fix1 e2)
= True
-- Parser initially makes negation bind more tightly than any other operator
-mkNegAppRn neg_arg neg_op
+mkNegAppRn neg_arg
=
#ifdef DEBUG
getModeRn `thenRn` \ mode ->
ASSERT( not_op_app mode neg_arg )
#endif
- returnRn (NegApp neg_arg neg_op)
+ returnRn (NegApp neg_arg)
not_op_app SourceMode (OpApp _ _ _ _) = False
not_op_app mode other = True
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 from_integer)
- = lookupOccRn from_integer `thenRn` \ from_integer' ->
- (if inIntRange i then
- returnRn emptyFVs
- else
- lookupOrigNames [plusInteger_RDR, timesInteger_RDR]
- ) `thenRn` \ ns ->
- returnRn (HsIntegral i from_integer', ns `addOneFV` from_integer')
-
-rnOverLit (HsFractional i n)
- = lookupOccRn n `thenRn` \ n' ->
- lookupOrigNames [ratioDataCon_RDR, plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns' ->
+rnOverLit (HsIntegral i)
+ | inIntRange i
+ = returnRn (HsIntegral i, unitFV fromIntName)
+ | otherwise
+ = lookupOrigNames [fromInteger_RDR, plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns ->
+ -- Big integers are built, using + and *, out of small integers
+ returnRn (HsIntegral i, ns)
+
+rnOverLit (HsFractional i)
+ = lookupOrigNames [fromRational_RDR, ratioDataCon_RDR,
+ plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns ->
-- We have to make sure that the Ratio type is imported with
-- its constructor, because literals of type Ratio t are
-- built with that constructor.
-- when fractionalClass does.
-- The plus/times integer operations may be needed to construct the numerator
-- and denominator (see DsUtils.mkIntegerLit)
- returnRn (HsFractional i n', ns' `addOneFV` n')
+ returnRn (HsFractional i, ns)
\end{code}
%************************************************************************
type RenamedStmt = Stmt Name RenamedPat
type RenamedFixitySig = FixitySig Name
type RenamedDeprecation = DeprecDecl Name
-type RenamedHsOverLit = HsOverLit Name
\end{code}
%************************************************************************
import CmdLineOpts ( opt_NoMethodSharing )
import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..) )
-import RnHsSyn ( RenamedHsOverLit )
import TcHsSyn ( TcExpr, TcId,
mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId
)
import TcMonad
-import TcEnv ( TcIdSet, tcGetInstEnv, tcLookupGlobalId )
+import TcEnv ( TcIdSet, tcGetInstEnv, tcLookupSyntaxId )
import InstEnv ( InstLookupResult(..), lookupInstEnv )
import TcType ( TcThetaType, TcClassContext,
TcType, TcTauType, TcTyVarSet,
doubleDataCon, isDoubleTy,
isIntegerTy
)
-import PrelNames( hasKey, fromIntName, fromIntegerClassOpKey )
+import PrelNames( fromIntName, fromIntegerName, fromRationalName )
import Util ( thenCmp, zipWithEqual, mapAccumL )
import Bag
import Outputable
| LitInst
Id
- RenamedHsOverLit -- The literal from the occurrence site
- TcType -- The type at which the literal is used
+ HsOverLit -- The literal from the occurrence site
+ TcType -- The type at which the literal is used
InstLoc
\end{code}
\begin{code}
newOverloadedLit :: InstOrigin
- -> RenamedHsOverLit
+ -> HsOverLit
-> TcType
-> NF_TcM (TcExpr, LIE)
-newOverloadedLit orig (HsIntegral i _) ty
+newOverloadedLit orig (HsIntegral i) ty
| isIntTy ty && inIntRange i -- Short cut for Int
= returnNF_Tc (int_lit, emptyLIE)
-- Literals
-lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc)
+lookupInst inst@(LitInst u (HsIntegral i) ty loc)
| isIntTy ty && in_int_range -- Short cut for Int
= returnNF_Tc (GenInst [] int_lit)
-- GenInst, not SimpleInst, because int_lit is actually a constructor application
= returnNF_Tc (GenInst [] integer_lit)
| in_int_range -- It's overloaded but small enough to fit into an Int
- && from_integer_name `hasKey` fromIntegerClassOpKey -- And it's the built-in prelude fromInteger
- -- (i.e. no funny business with user-defined
- -- packages of numeric classes)
= -- So we can use the Prelude fromInt
- tcLookupGlobalId fromIntName `thenNF_Tc` \ from_int ->
+ tcLookupSyntaxId fromIntName `thenNF_Tc` \ from_int ->
newMethodAtLoc loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) ->
returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit))
| otherwise -- Alas, it is overloaded and a big literal!
- = tcLookupGlobalId from_integer_name `thenNF_Tc` \ from_integer ->
+ = tcLookupSyntaxId fromIntegerName `thenNF_Tc` \ from_integer ->
newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) ->
returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit))
where
-- *definitely* a float or a double, generate the real thing here.
-- This is essential (see nofib/spectral/nucleic).
-lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc)
+lookupInst inst@(LitInst u (HsFractional f) ty loc)
| isFloatTy ty = returnNF_Tc (GenInst [] float_lit)
| isDoubleTy ty = returnNF_Tc (GenInst [] double_lit)
| otherwise
- = tcLookupGlobalId from_rat_name `thenNF_Tc` \ from_rational ->
+ = tcLookupSyntaxId fromRationalName `thenNF_Tc` \ from_rational ->
newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) ->
let
rational_ty = funArgTy (idType method_id)
-- Global environment
tcExtendGlobalEnv, tcExtendGlobalValEnv,
tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon,
- tcLookupGlobal_maybe, tcLookupGlobal,
+ tcLookupGlobal_maybe, tcLookupGlobal, tcLookupSyntaxId, tcLookupSyntaxName,
-- Local environment
tcExtendKindEnv, tcLookupLocalIds,
import HscTypes ( lookupType, TyThing(..) )
import Util ( zipEqual )
import SrcLoc ( SrcLoc )
+import qualified PrelNames
import Outputable
import IOExts ( newIORef )
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 :: HomeSymbolTable -> PackageTypeEnv -> IO TcEnv
-initTcEnv hst pte
+initTcEnv :: PrelNames.SyntaxMap -> HomeSymbolTable -> PackageTypeEnv -> IO TcEnv
+initTcEnv syntax_map hst pte
= do { gtv_var <- newIORef emptyVarSet ;
- return (TcEnv { tcGST = lookup,
+ return (TcEnv { tcSyntaxMap = syntax_map,
+ tcGST = lookup,
tcGEnv = emptyNameEnv,
tcInsts = emptyInstEnv,
tcLEnv = emptyNameEnv,
lookup lenv name = case lookupNameEnv lenv name of
Just (ATcId id) -> id
other -> pprPanic "tcLookupLocalIds" (ppr name)
+
+tcLookupSyntaxId :: Name -> NF_TcM Id
+-- Lookup a name like PrelNum.fromInt, and return the corresponding Id,
+-- after mapping through the SyntaxMap. This may give us the Id for
+-- (say) MyPrelude.fromInt
+tcLookupSyntaxId name
+ = tcGetEnv `thenNF_Tc` \ env ->
+ returnNF_Tc (case lookup_global env (tcSyntaxMap env name) of
+ Just (AnId id) -> id
+ other -> pprPanic "tcLookupSyntaxId" (ppr name))
+
+tcLookupSyntaxName :: Name -> NF_TcM Name
+tcLookupSyntaxName name
+ = tcGetEnv `thenNF_Tc` \ env ->
+ returnNF_Tc (tcSyntaxMap env name)
\end{code}
import TcEnv ( TcTyThing(..),
tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe,
tcLookupTyCon, tcLookupDataCon, tcLookup,
- tcExtendGlobalTyVars
+ tcExtendGlobalTyVars, tcLookupSyntaxName
)
import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts )
import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt )
import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy )
import PrelNames ( cCallableClassName,
cReturnableClassName,
- enumFromName, enumFromThenName,
+ enumFromName, enumFromThenName, negateName,
enumFromToName, enumFromThenToName,
thenMName, failMName, returnMName, ioTyConName
)
tcMonoExpr (HsOverLit lit) res_ty = newOverloadedLit (LiteralOrigin lit) lit res_ty
tcMonoExpr (HsPar expr) res_ty = tcMonoExpr expr res_ty
-tcMonoExpr (NegApp expr neg) res_ty
- = tcMonoExpr (HsApp (HsVar neg) expr) res_ty
+tcMonoExpr (NegApp expr) res_ty
+ = tcLookupSyntaxName negateName `thenNF_Tc` \ neg ->
+ tcMonoExpr (HsApp (HsVar neg) expr) res_ty
tcMonoExpr (HsLam match) res_ty
= tcMatchLambda match res_ty `thenTc` \ (match',lie) ->
import {-# SOURCE #-} TcEnv ( TcEnv )
-import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr, RenamedHsOverLit )
+import HsSyn ( HsOverLit )
+import RnHsSyn ( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
import Type ( Type, Kind, PredType, ThetaType, RhoType, TauType,
)
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
\begin{code}
traceTc :: SDoc -> NF_TcM ()
traceTc doc (TcDown { tc_dflags=dflags }) env
- | dopt Opt_D_dump_rn_trace dflags = printDump doc
+ | dopt Opt_D_dump_tc_trace dflags = printDump doc
| otherwise = return ()
ioToTc :: IO a -> NF_TcM a
| InstanceDeclOrigin -- Typechecking an instance decl
- | LiteralOrigin RenamedHsOverLit -- Occurrence of a literal
+ | LiteralOrigin HsOverLit -- Occurrence of a literal
| PatOrigin RenamedPat
import Id ( mkVanillaId )
import Name ( Name )
import FieldLabel ( fieldLabelName )
-import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId )
+import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupSyntaxId )
import TcType ( TcType, TcTyVar, tcInstTyVars, newTyVarTy )
import TcMonoType ( tcHsSigType )
import TcUnify ( unifyTauTy, unifyListTy, unifyTupleTy )
doublePrimTy, addrPrimTy
)
import TysWiredIn ( charTy, stringTy, intTy, integerTy )
-import PrelNames ( eqStringName, eqName, geName, cCallableClassName )
+import PrelNames ( minusName, eqStringName, eqName, geName, cCallableClassName )
import BasicTypes ( isBoxed )
import Bag
import Outputable
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 _) minus) pat_ty
+tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i)) pat_ty
= tc_bndr name pat_ty `thenTc` \ bndr_id ->
- tcLookupGlobalId minus `thenNF_Tc` \ minus_sel_id ->
+ -- The '-' part is re-mappable syntax
+ tcLookupSyntaxId minusName `thenNF_Tc` \ minus_sel_id ->
tcLookupGlobalId geName `thenNF_Tc` \ ge_sel_id ->
newOverloadedLit origin lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) ->
newMethod origin ge_sel_id [pat_ty] `thenNF_Tc` \ ge ->
projects / ghc-hetmet.git / commitdiff