diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index 0d4fb494369d5d7cda959042675d727b71ea76eb..a482b689d747fe15de5fdb1107aa1410017eb69e 100644
--- a/ghc/compiler/basicTypes/Unique.lhs
+++ b/ghc/compiler/basicTypes/Unique.lhs
@@ -113,6 +113,7 @@ module Unique (
liftTyConKey,
listTyConKey,
ltDataConKey,
+ mainKey, mainPrimIoKey,
monadClassKey,
monadPlusClassKey,
monadZeroClassKey,
@@ -669,4 +670,7 @@ thenMClassOpKey = mkPreludeMiscIdUnique 63 -- (>>=)
unboundKey = mkPreludeMiscIdUnique 64 -- Just a place holder for unbound
-- variables produced by the renamer
fromEnumClassOpKey = mkPreludeMiscIdUnique 65
+
+mainKey = mkPreludeMiscIdUnique 66
+mainPrimIoKey = mkPreludeMiscIdUnique 67
\end{code}
diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 55bf40b54237791f168a522b7acdd2234d475d52..d7dd1240771cdc539c926751ade25f31c3974d82 100644
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -267,7 +267,7 @@ ppr_expr pe expr@(Lam _ _)
(uvars, tyvars, vars, body) = collectBinders expr
in
ppHang (ppCat [pp_vars SLIT("/u\\") (pUVar pe) uvars,
- pp_vars SLIT("/\\") (pTyVarB pe) tyvars,
+ pp_vars SLIT("_/\\_") (pTyVarB pe) tyvars,
pp_vars SLIT("\\") (pMinBndr pe) vars])
4 (ppr_expr pe body)
where
@@ -393,7 +393,7 @@ ppr_default pe (BindDefault val_bdr expr)
\begin{code}
ppr_arg pe (LitArg lit) = pLit pe lit
ppr_arg pe (VarArg v) = pOcc pe v
-ppr_arg pe (TyArg ty) = ppStr "@ " `ppBeside` pTy pe ty
+ppr_arg pe (TyArg ty) = ppStr "_@_ " `ppBeside` pTy pe ty
ppr_arg pe (UsageArg use) = pUse pe use
\end{code}
@@ -405,9 +405,8 @@ pprBigCoreBinder sty binder
= ppAboves [sig, pragmas, ppr sty binder]
where
sig = ifnotPprShowAll sty (
- ppHang (ppCat [ppr sty binder, ppStr "::"])
+ ppHang (ppCat [ppr sty binder, ppDcolon])
4 (ppr sty (idType binder)))
-
pragmas =
ifnotPprForUser sty
(ppIdInfo sty False{-no specs, thanks-} (getIdInfo binder))
@@ -424,5 +423,9 @@ pprBabyCoreBinder sty binder
-- ppStr ("{- " ++ (showList xx "") ++ " -}")
pprTypedCoreBinder sty binder
- = ppBesides [ppr sty binder, ppStr "::", pprParendGenType sty (idType binder)]
+ = ppBesides [ppr sty binder, ppDcolon, pprParendGenType sty (idType binder)]
+
+ppDcolon = ppStr " :: "
+ -- The space before the :: is important; it helps the lexer
+ -- when reading inferfaces. Otherwise it would lex "a::b" as one thing.
\end{code}
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 0afd0bc83992a2f887963c0f2382eba09201c026..2efca382c94d16bf2d99b88ce8ae651059a59af4 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -13,7 +13,7 @@ IMPORT_DELOOPER(DsLoop) -- partly to get dsBinds, partly to chk dsExpr
import HsSyn ( failureFreePat,
HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..),
- Stmt(..), Match(..), Qualifier, HsBinds, HsType,
+ Stmt(..), Match(..), Qualifier, HsBinds, HsType, Fixity,
GRHSsAndBinds
)
import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds),
@@ -188,8 +188,8 @@ dsExpr expr@(HsLam a_Match)
= matchWrapper LambdaMatch [a_Match] "lambda" `thenDs` \ (binders, matching_code) ->
returnDs ( mkValLam binders matching_code )
-dsExpr expr@(HsApp e1 e2) = dsApp expr []
-dsExpr expr@(OpApp e1 op e2) = dsApp expr []
+dsExpr expr@(HsApp e1 e2) = dsApp expr []
+dsExpr expr@(OpApp e1 op _ e2) = dsApp expr []
\end{code}
Operator sections. At first it looks as if we can convert
@@ -549,7 +549,7 @@ dsApp (HsApp e1 e2) args
= dsExpr e2 `thenDs` \ core_e2 ->
dsApp e1 (VarArg core_e2 : args)
-dsApp (OpApp e1 op e2) args
+dsApp (OpApp e1 op _ e2) args
= dsExpr e1 `thenDs` \ core_e1 ->
dsExpr e2 `thenDs` \ core_e2 ->
dsApp op (VarArg core_e1 : VarArg core_e2 : args)
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index 3b767bb2a22b75ba75905af42f1e92df887ff34e..ff2ec5fe45a545a034580b2e3e29f80e24c5816b 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -30,7 +30,7 @@ module DsUtils (
IMP_Ubiq()
IMPORT_DELOOPER(DsLoop) ( match, matchSimply )
-import HsSyn ( HsExpr(..), OutPat(..), HsLit(..),
+import HsSyn ( HsExpr(..), OutPat(..), HsLit(..), Fixity,
Match, HsBinds, Stmt, Qualifier, HsType, ArithSeqInfo )
import TcHsSyn ( SYN_IE(TypecheckedPat) )
import DsHsSyn ( outPatType )
diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs
index 53ef74dff37e66c7caa447f58677f212dc4507a0..a4ed52d685a89b087bbe6ac27b4288c52ff1846c 100644
--- a/ghc/compiler/deSugar/MatchLit.lhs
+++ b/ghc/compiler/deSugar/MatchLit.lhs
@@ -11,7 +11,7 @@ module MatchLit ( matchLiterals ) where
IMP_Ubiq()
IMPORT_DELOOPER(DsLoop) -- break match-ish and dsExpr-ish loops
-import HsSyn ( HsLit(..), OutPat(..), HsExpr(..),
+import HsSyn ( HsLit(..), OutPat(..), HsExpr(..), Fixity,
Match, HsBinds, Stmt, Qualifier, HsType, ArithSeqInfo )
import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds),
SYN_IE(TypecheckedPat)
diff --git a/ghc/compiler/hsSyn/HsLit.lhs b/ghc/compiler/hsSyn/HsBasic.lhs
similarity index 61%
rename from ghc/compiler/hsSyn/HsLit.lhs
rename to ghc/compiler/hsSyn/HsBasic.lhs
index e0f736433a37defc747a80c602a49b7ab45dc5e2..114721a7073719473ec907781cfe3fe74086de1b 100644
--- a/ghc/compiler/hsSyn/HsLit.lhs
+++ b/ghc/compiler/hsSyn/HsBasic.lhs
@@ -6,7 +6,7 @@
\begin{code}
#include "HsVersions.h"
-module HsLit where
+module HsBasic where
IMP_Ubiq(){-uitous-}
IMPORT_1_3(Ratio(Rational))
@@ -14,6 +14,23 @@ IMPORT_1_3(Ratio(Rational))
import Pretty
\end{code}
+%************************************************************************
+%* *
+\subsection[Version]{Module and identifier version numbers}
+%* *
+%************************************************************************
+
+\begin{code}
+type Version = Int
+\end{code}
+
+%************************************************************************
+%* *
+\subsection[HsLit]{Literals}
+%* *
+%************************************************************************
+
+
\begin{code}
data HsLit
= HsChar Char -- characters
@@ -59,3 +76,27 @@ instance Outputable HsLit where
ppr sty (HsIntPrim i) = ppBeside (ppInteger i) (ppChar '#')
ppr sty (HsLitLit s) = ppBesides [ppStr "``", ppPStr s, ppStr "''"]
\end{code}
+
+%************************************************************************
+%* *
+\subsection[Fixity]{Fixity info}
+%* *
+%************************************************************************
+
+\begin{code}
+data Fixity = Fixity Int FixityDirection
+data FixityDirection = InfixL | InfixR | InfixN
+ deriving(Eq)
+
+instance Outputable Fixity where
+ ppr sty (Fixity prec dir) = ppBesides [ppr sty dir, ppSP, ppInt prec]
+
+instance Outputable FixityDirection where
+ ppr sty InfixL = ppStr "infixl"
+ ppr sty InfixR = ppStr "infixr"
+ ppr sty InfixN = ppStr "infix"
+
+instance Eq Fixity where -- Used to determine if two fixities conflict
+ (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2
+\end{code}
+
diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index 486a1889beb680a6e46019180eef03fbeb195f11..9f9073560e22796080aacaa73997a62404b38b1e 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -22,6 +22,7 @@ import HsTypes
import IdInfo
import SpecEnv ( SpecEnv )
import HsCore ( UfExpr )
+import HsBasic ( Fixity )
-- others:
import Name ( pprSym, pprNonSym, getOccName, OccName )
@@ -86,26 +87,6 @@ instance Outputable name => Outputable (FixityDecl name) where
ppr sty (FixityDecl name fixity loc) = ppSep [ppr sty fixity, ppr sty name]
\end{code}
-It's convenient to keep the source location in the @Fixity@; it makes error reporting
-in the renamer easier.
-
-\begin{code}
-data Fixity = Fixity Int FixityDirection
-data FixityDirection = InfixL | InfixR | InfixN
- deriving(Eq)
-
-instance Outputable Fixity where
- ppr sty (Fixity prec dir) = ppBesides [ppr sty dir, ppSP, ppInt prec]
-
-instance Outputable FixityDirection where
- ppr sty InfixL = ppStr "infixl"
- ppr sty InfixR = ppStr "infixr"
- ppr sty InfixN = ppStr "infix"
-
-instance Eq Fixity where -- Used to determine if two fixities conflict
- (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2
-\end{code}
-
%************************************************************************
%* *
@@ -252,7 +233,10 @@ instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
pp_field (ns, ty) = ppCat [ppCat (map (ppr sty . getOccName) ns),
ppPStr SLIT("::"), ppr_bang sty ty]
-ppr_bang sty (Banged ty) = ppBeside (ppChar '!') (pprParendHsType sty ty)
+ppr_bang sty (Banged ty) = ppBeside (ppStr "! ") (pprParendHsType sty ty)
+ -- The extra space helps the lexical analyser that lexes
+ -- interface files; it doesn't make the rigid operator/identifier
+ -- distinction, so "!a" is a valid identifier so far as it is concerned
ppr_bang sty (Unbanged ty) = pprParendHsType sty ty
\end{code}
diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index 8f6b0999a3e13dd356f119b197331cba07d51951..b08debd8a1dcd7f2577ad213075d0adf3fef5842 100644
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -13,7 +13,7 @@ IMPORT_DELOOPER(HsLoop) -- for paranoia checking
-- friends:
import HsBinds ( HsBinds )
-import HsLit ( HsLit )
+import HsBasic ( HsLit, Fixity(..), FixityDirection(..) )
import HsMatches ( pprMatches, pprMatch, Match )
import HsTypes ( HsType )
@@ -54,6 +54,7 @@ data HsExpr tyvar uvar id pat
| OpApp (HsExpr tyvar uvar id pat) -- left operand
(HsExpr tyvar uvar id pat) -- operator
+ Fixity -- Renamer adds fixity; bottom until then
(HsExpr tyvar uvar id pat) -- right operand
-- We preserve prefix negation and parenthesis for the precedence parser.
@@ -208,13 +209,13 @@ pprExpr sty expr@(HsApp e1 e2)
collect_args (HsApp fun arg) args = collect_args fun (arg:args)
collect_args fun args = (fun, args)
-pprExpr sty (OpApp e1 op e2)
+pprExpr sty (OpApp e1 op fixity e2)
= case op of
HsVar v -> pp_infixly v
_ -> pp_prefixly
where
- pp_e1 = pprExpr sty e1
- pp_e2 = pprExpr sty e2
+ pp_e1 = pprParendExpr sty e1 -- Add parens to make precedence clear
+ pp_e2 = pprParendExpr sty e2
pp_prefixly
= ppHang (pprExpr sty op) 4 (ppSep [pp_e1, pp_e2])
@@ -374,10 +375,13 @@ pprParendExpr sty expr
case expr of
HsLit l -> ppr sty l
HsLitOut l _ -> ppr sty l
+
HsVar _ -> pp_as_was
ExplicitList _ -> pp_as_was
ExplicitListOut _ _ -> pp_as_was
ExplicitTuple _ -> pp_as_was
+ HsPar _ -> pp_as_was
+
_ -> ppParens pp_as_was
\end{code}
diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs
index d90dd1e695ae75242f40b513b02a79c5284f2e6d..da42d1ce89068a8e76977d673a5ec1d601f8c258 100644
--- a/ghc/compiler/hsSyn/HsPat.lhs
+++ b/ghc/compiler/hsSyn/HsPat.lhs
@@ -20,7 +20,7 @@ module HsPat (
IMP_Ubiq()
-- friends:
-import HsLit ( HsLit )
+import HsBasic ( HsLit, Fixity )
IMPORT_DELOOPER(HsLoop) ( HsExpr )
-- others:
@@ -47,6 +47,7 @@ data InPat name
[InPat name]
| ConOpPatIn (InPat name)
name
+ Fixity -- c.f. OpApp in HsExpr
(InPat name)
-- We preserve prefix negation and parenthesis for the precedence parser.
@@ -127,7 +128,7 @@ pprInPat sty (ConPatIn c pats)
else
ppCat [ppr sty c, interppSP sty pats] -- ParPats put in the parens
-pprInPat sty (ConOpPatIn pat1 op pat2)
+pprInPat sty (ConOpPatIn pat1 op fixity pat2)
= ppCat [ppr sty pat1, ppr sty op, ppr sty pat2] -- ParPats put in parens
-- ToDo: use pprSym to print op (but this involves fiddling various
@@ -290,16 +291,16 @@ collected is important; see @HsBinds.lhs@.
\begin{code}
collectPatBinders :: InPat a -> [a]
-collectPatBinders WildPatIn = []
-collectPatBinders (VarPatIn var) = [var]
-collectPatBinders (LitPatIn _) = []
-collectPatBinders (LazyPatIn pat) = collectPatBinders pat
-collectPatBinders (AsPatIn a pat) = a : collectPatBinders pat
-collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats)
-collectPatBinders (ConOpPatIn p1 c p2)= collectPatBinders p1 ++ collectPatBinders p2
-collectPatBinders (NegPatIn pat) = collectPatBinders pat
-collectPatBinders (ParPatIn pat) = collectPatBinders pat
-collectPatBinders (ListPatIn pats) = concat (map collectPatBinders pats)
-collectPatBinders (TuplePatIn pats) = concat (map collectPatBinders pats)
-collectPatBinders (RecPatIn c fields) = concat (map (\ (f,pat,_) -> collectPatBinders pat) fields)
+collectPatBinders WildPatIn = []
+collectPatBinders (VarPatIn var) = [var]
+collectPatBinders (LitPatIn _) = []
+collectPatBinders (LazyPatIn pat) = collectPatBinders pat
+collectPatBinders (AsPatIn a pat) = a : collectPatBinders pat
+collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats)
+collectPatBinders (ConOpPatIn p1 c f p2) = collectPatBinders p1 ++ collectPatBinders p2
+collectPatBinders (NegPatIn pat) = collectPatBinders pat
+collectPatBinders (ParPatIn pat) = collectPatBinders pat
+collectPatBinders (ListPatIn pats) = concat (map collectPatBinders pats)
+collectPatBinders (TuplePatIn pats) = concat (map collectPatBinders pats)
+collectPatBinders (RecPatIn c fields) = concat (map (\ (f,pat,_) -> collectPatBinders pat) fields)
\end{code}
diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs
index 9e57b8d42d0c84cf9c72b235b57d2688ef3e18c7..2702f8aa3bc6024ed5296f17adb295e6f9890111 100644
--- a/ghc/compiler/hsSyn/HsSyn.lhs
+++ b/ghc/compiler/hsSyn/HsSyn.lhs
@@ -20,7 +20,7 @@ module HsSyn (
EXP_MODULE(HsDecls) ,
EXP_MODULE(HsExpr) ,
EXP_MODULE(HsImpExp) ,
- EXP_MODULE(HsLit) ,
+ EXP_MODULE(HsBasic) ,
EXP_MODULE(HsMatches) ,
EXP_MODULE(HsPat) ,
EXP_MODULE(HsTypes)
@@ -32,14 +32,14 @@ IMP_Ubiq()
import HsBinds
import HsDecls ( HsDecl(..), TyDecl(..), InstDecl(..), ClassDecl(..),
DefaultDecl(..),
- FixityDecl(..), Fixity(..), FixityDirection(..),
+ FixityDecl(..),
ConDecl(..), BangType(..),
IfaceSig(..), HsIdInfo, SpecDataSig(..), SpecInstSig(..),
hsDeclName
)
import HsExpr
import HsImpExp
-import HsLit
+import HsBasic
import HsMatches
import HsPat
import HsTypes
@@ -63,8 +63,6 @@ instance Outputable Fake
All we actually declare here is the top-level structure for a module.
\begin{code}
-type Version = Int
-
data HsModule tyvar uvar name pat
= HsModule
Module -- module name
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 183c3990c7079dece1f2446e1103c0c7cdbb946a..b695f4caf0ae04f7e9892f30b214571093c655d9 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -34,6 +34,7 @@ module CmdLineOpts (
opt_D_dump_realC,
opt_D_dump_rn,
opt_D_dump_simpl,
+ opt_D_dump_simpl_iterations,
opt_D_dump_spec,
opt_D_dump_stg,
opt_D_dump_stranal,
@@ -56,6 +57,7 @@ module CmdLineOpts (
opt_GranMacros,
opt_Haskell_1_3,
opt_HiMap,
+ opt_HiSuffix,
opt_IgnoreIfacePragmas,
opt_IgnoreStrictnessPragmas,
opt_IrrefutableEverything,
@@ -267,6 +269,7 @@ opt_D_dump_rdr = lookUp SLIT("-ddump-rdr")
opt_D_dump_realC = lookUp SLIT("-ddump-realC")
opt_D_dump_rn = lookUp SLIT("-ddump-rn")
opt_D_dump_simpl = lookUp SLIT("-ddump-simpl")
+opt_D_dump_simpl_iterations = lookUp SLIT("-ddump-simpl_iterations")
opt_D_dump_spec = lookUp SLIT("-ddump-spec")
opt_D_dump_stg = lookUp SLIT("-ddump-stg")
opt_D_dump_stranal = lookUp SLIT("-ddump-stranal")
@@ -289,6 +292,7 @@ opt_GranMacros = lookUp SLIT("-fgransim")
opt_GlasgowExts = lookUp SLIT("-fglasgow-exts")
opt_Haskell_1_3 = lookUp SLIT("-fhaskell-1.3")
opt_HiMap = lookup_str "-himap=" -- file saying where to look for .hi files
+opt_HiSuffix = lookup_str "-hisuf="
opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas")
opt_IgnoreStrictnessPragmas = lookUp SLIT("-fignore-strictness-pragmas")
opt_IrrefutableEverything = lookUp SLIT("-firrefutable-everything")
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 59c32a05e8c6ef9cbe8689cfda63a3553c03b8fd..5bc488d7b63573c5359c7a9987e743477b94fa45 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -251,7 +251,7 @@ ifaceId get_idinfo needed_ids is_rec id rhs
= Nothing -- Well, that was easy!
ifaceId get_idinfo needed_ids is_rec id rhs
- = Just (ppCat [sig_pretty, prag_pretty, ppSemi], new_needed_ids)
+ = Just (ppCat [sig_pretty, prag_pretty, ppStr ";;"], new_needed_ids)
where
idinfo = get_idinfo id
inline_pragma = idWantsToBeINLINEd id
@@ -383,9 +383,9 @@ upp_export names = uppBesides [uppStr "(",
uppIntersperse uppSP (map (upp_occname . getOccName) names),
uppStr ")"]
-upp_fixity (occ, Fixity prec dir, prov) = uppBesides [upp_dir dir, uppSP,
- uppInt prec, uppSP,
- upp_occname occ, uppSemi]
+upp_fixity (occ, (Fixity prec dir, prov)) = uppBesides [upp_dir dir, uppSP,
+ uppInt prec, uppSP,
+ upp_occname occ, uppSemi]
upp_dir InfixR = uppStr "infixr"
upp_dir InfixL = uppStr "infixl"
upp_dir InfixN = uppStr "infix"
diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs
index ed2bec583cb148c394933dd102b38e1f2975441e..7001a7bd0161d916314f4e47f419fad364f62161 100644
--- a/ghc/compiler/prelude/PrelInfo.lhs
+++ b/ghc/compiler/prelude/PrelInfo.lhs
@@ -8,7 +8,7 @@
module PrelInfo (
-- finite maps for built-in things (for the renamer and typechecker):
- builtinNames, builtinKeys, derivingOccurrences,
+ builtinNames, derivingOccurrences,
SYN_IE(BuiltinNames),
maybeCharLikeTyCon, maybeIntLikeTyCon,
@@ -27,6 +27,8 @@ module PrelInfo (
numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, creturnableClass_RDR,
monadZeroClass_RDR, enumClass_RDR, evalClass_RDR, ordClass_RDR,
+ main_NAME, mainPrimIO_NAME, ioTyCon_NAME, primIoTyCon_NAME,
+
needsDataDeclCtxtClassKeys, cCallishClassKeys, isNoDictClass,
isNumericClass, isStandardClass, isCcallishClass
) where
@@ -82,7 +84,7 @@ builtinNames
listToBag (map (getName.primOpName) allThePrimOps) `unionBags`
-- Other names with magic keys
- listToBag builtinKeys
+ listToBag knownKeyNames
\end{code}
@@ -243,58 +245,62 @@ wired_in_ids
Ids, Synonyms, Classes and ClassOps with builtin keys.
\begin{code}
-getKeyOrig :: (Module, OccName, Unique) -> Name
-getKeyOrig (mod, occ, uniq) = mkGlobalName uniq mod occ VanillaDefn Implicit
-
-builtinKeys :: [Name]
-builtinKeys
- = map getKeyOrig
+mkKnownKeyGlobal :: (RdrName, Unique) -> Name
+mkKnownKeyGlobal (Qual mod occ, uniq) = mkGlobalName uniq mod occ VanillaDefn Implicit
+
+main_NAME = mkKnownKeyGlobal (main_RDR, mainKey)
+mainPrimIO_NAME = mkKnownKeyGlobal (mainPrimIO_RDR, mainPrimIoKey)
+ioTyCon_NAME = mkKnownKeyGlobal (ioTyCon_RDR, iOTyConKey)
+primIoTyCon_NAME = getName primIoTyCon
+
+knownKeyNames :: [Name]
+knownKeyNames
+ = [main_NAME, mainPrimIO_NAME, ioTyCon_NAME]
+ ++
+ map mkKnownKeyGlobal
[
-- Type constructors (synonyms especially)
- (iO_BASE, TCOcc SLIT("IO"), iOTyConKey)
- , (pREL_BASE, TCOcc SLIT("Ordering"), orderingTyConKey)
- , (pREL_NUM, TCOcc SLIT("Rational"), rationalTyConKey)
- , (pREL_NUM, TCOcc SLIT("Ratio"), ratioTyConKey)
-
+ (orderingTyCon_RDR, orderingTyConKey)
+ , (rationalTyCon_RDR, rationalTyConKey)
+ , (ratioTyCon_RDR, ratioTyConKey)
-- Classes. *Must* include:
-- classes that are grabbed by key (e.g., eqClassKey)
-- classes in "Class.standardClassKeys" (quite a few)
- , (pREL_BASE, TCOcc SLIT("Eq"), eqClassKey) -- mentioned, derivable
- , (pREL_BASE, TCOcc SLIT("Eval"), evalClassKey) -- mentioned
- , (pREL_BASE, TCOcc SLIT("Ord"), ordClassKey) -- derivable
- , (pREL_BASE, TCOcc SLIT("Bounded"), boundedClassKey) -- derivable
- , (pREL_BASE, TCOcc SLIT("Num"), numClassKey) -- mentioned, numeric
- , (pREL_BASE, TCOcc SLIT("Enum"), enumClassKey) -- derivable
- , (pREL_BASE, TCOcc SLIT("Monad"), monadClassKey)
- , (pREL_BASE, TCOcc SLIT("MonadZero"), monadZeroClassKey)
- , (pREL_BASE, TCOcc SLIT("MonadPlus"), monadPlusClassKey)
- , (pREL_BASE, TCOcc SLIT("Functor"), functorClassKey)
- , (pREL_BASE, TCOcc SLIT("Show"), showClassKey) -- derivable
- , (pREL_NUM, TCOcc SLIT("Real"), realClassKey) -- numeric
- , (pREL_NUM, TCOcc SLIT("Integral"), integralClassKey) -- numeric
- , (pREL_NUM, TCOcc SLIT("Fractional"), fractionalClassKey) -- numeric
- , (pREL_NUM, TCOcc SLIT("Floating"), floatingClassKey) -- numeric
- , (pREL_NUM, TCOcc SLIT("RealFrac"), realFracClassKey) -- numeric
- , (pREL_NUM, TCOcc SLIT("RealFloat"), realFloatClassKey) -- numeric
- , (pREL_READ, TCOcc SLIT("Read"), readClassKey) -- derivable
- , (iX, TCOcc SLIT("Ix"), ixClassKey) -- derivable (but it isn't Prelude.Ix; hmmm)
- , (fOREIGN, TCOcc SLIT("CCallable"), cCallableClassKey) -- mentioned, ccallish
- , (fOREIGN, TCOcc SLIT("CReturnable"), cReturnableClassKey) -- mentioned, ccallish
-
+ , (eqClass_RDR, eqClassKey) -- mentioned, derivable
+ , (ordClass_RDR, ordClassKey) -- derivable
+ , (evalClass_RDR, evalClassKey) -- mentioned
+ , (boundedClass_RDR, boundedClassKey) -- derivable
+ , (numClass_RDR, numClassKey) -- mentioned, numeric
+ , (enumClass_RDR, enumClassKey) -- derivable
+ , (monadClass_RDR, monadClassKey)
+ , (monadZeroClass_RDR, monadZeroClassKey)
+ , (monadPlusClass_RDR, monadPlusClassKey)
+ , (functorClass_RDR, functorClassKey)
+ , (showClass_RDR, showClassKey) -- derivable
+ , (realClass_RDR, realClassKey) -- numeric
+ , (integralClass_RDR, integralClassKey) -- numeric
+ , (fractionalClass_RDR, fractionalClassKey) -- numeric
+ , (floatingClass_RDR, floatingClassKey) -- numeric
+ , (realFracClass_RDR, realFracClassKey) -- numeric
+ , (realFloatClass_RDR, realFloatClassKey) -- numeric
+ , (readClass_RDR, readClassKey) -- derivable
+ , (ixClass_RDR, ixClassKey) -- derivable (but it isn't Prelude.Ix; hmmm)
+ , (ccallableClass_RDR, cCallableClassKey) -- mentioned, ccallish
+ , (creturnableClass_RDR, cReturnableClassKey) -- mentioned, ccallish
-- ClassOps
- , (pREL_BASE, VarOcc SLIT("fromInt"), fromIntClassOpKey)
- , (pREL_BASE, VarOcc SLIT("fromInteger"), fromIntegerClassOpKey)
- , (pREL_BASE, VarOcc SLIT("enumFrom"), enumFromClassOpKey)
- , (pREL_BASE, VarOcc SLIT("enumFromThen"), enumFromThenClassOpKey)
- , (pREL_BASE, VarOcc SLIT("enumFromTo"), enumFromToClassOpKey)
- , (pREL_BASE, VarOcc SLIT("enumFromThenTo"), enumFromThenToClassOpKey)
- , (pREL_BASE, VarOcc SLIT("fromEnum"), fromEnumClassOpKey)
- , (pREL_BASE, VarOcc SLIT("=="), eqClassOpKey)
- , (pREL_BASE, VarOcc SLIT(">>="), thenMClassOpKey)
- , (pREL_BASE, VarOcc SLIT("zero"), zeroClassOpKey)
- , (pREL_NUM, VarOcc SLIT("fromRational"), fromRationalClassOpKey)
+ , (fromInt_RDR, fromIntClassOpKey)
+ , (fromInteger_RDR, fromIntegerClassOpKey)
+ , (enumFrom_RDR, enumFromClassOpKey)
+ , (enumFromThen_RDR, enumFromThenClassOpKey)
+ , (enumFromTo_RDR, enumFromToClassOpKey)
+ , (enumFromThenTo_RDR, enumFromThenToClassOpKey)
+ , (fromEnum_RDR, fromEnumClassOpKey)
+ , (eq_RDR, eqClassOpKey)
+ , (thenM_RDR, thenMClassOpKey)
+ , (zeroM_RDR, zeroClassOpKey)
+ , (fromRational_RDR, fromRationalClassOpKey)
]
\end{code}
@@ -318,16 +324,46 @@ to write them all down in one place.
\begin{code}
prelude_primop op = qual (modAndOcc (primOpName op))
+intTyCon_RDR = qual (modAndOcc intTyCon)
+ioTyCon_RDR = tcQual (iO_BASE, SLIT("IO"))
+orderingTyCon_RDR = tcQual (pREL_BASE, SLIT("Ordering"))
+rationalTyCon_RDR = tcQual (pREL_NUM, SLIT("Rational"))
+ratioTyCon_RDR = tcQual (pREL_NUM, SLIT("Ratio"))
+
eqClass_RDR = tcQual (pREL_BASE, SLIT("Eq"))
ordClass_RDR = tcQual (pREL_BASE, SLIT("Ord"))
evalClass_RDR = tcQual (pREL_BASE, SLIT("Eval"))
-monadZeroClass_RDR = tcQual (pREL_BASE, SLIT("MonadZero"))
-enumClass_RDR = tcQual (pREL_BASE, SLIT("Enum"))
+boundedClass_RDR = tcQual (pREL_BASE, SLIT("Bounded"))
numClass_RDR = tcQual (pREL_BASE, SLIT("Num"))
+enumClass_RDR = tcQual (pREL_BASE, SLIT("Enum"))
+monadClass_RDR = tcQual (pREL_BASE, SLIT("Monad"))
+monadZeroClass_RDR = tcQual (pREL_BASE, SLIT("MonadZero"))
+monadPlusClass_RDR = tcQual (pREL_BASE, SLIT("MonadPlus"))
+functorClass_RDR = tcQual (pREL_BASE, SLIT("Functor"))
+showClass_RDR = tcQual (pREL_BASE, SLIT("Show"))
+realClass_RDR = tcQual (pREL_NUM, SLIT("Real"))
+integralClass_RDR = tcQual (pREL_NUM, SLIT("Integral"))
fractionalClass_RDR = tcQual (pREL_NUM, SLIT("Fractional"))
+floatingClass_RDR = tcQual (pREL_NUM, SLIT("Floating"))
+realFracClass_RDR = tcQual (pREL_NUM, SLIT("RealFrac"))
+realFloatClass_RDR = tcQual (pREL_NUM, SLIT("RealFloat"))
+readClass_RDR = tcQual (pREL_READ, SLIT("Read"))
+ixClass_RDR = tcQual (iX, SLIT("Ix"))
ccallableClass_RDR = tcQual (fOREIGN, SLIT("CCallable"))
creturnableClass_RDR = tcQual (fOREIGN, SLIT("CReturnable"))
+fromInt_RDR = varQual (pREL_BASE, SLIT("fromInt"))
+fromInteger_RDR = varQual (pREL_BASE, SLIT("fromInteger"))
+fromEnum_RDR = varQual (pREL_BASE, SLIT("fromEnum"))
+enumFrom_RDR = varQual (pREL_BASE, SLIT("enumFrom"))
+enumFromTo_RDR = varQual (pREL_BASE, SLIT("enumFromTo"))
+enumFromThen_RDR = varQual (pREL_BASE, SLIT("enumFromThen"))
+enumFromThenTo_RDR = varQual (pREL_BASE, SLIT("enumFromThenTo"))
+
+thenM_RDR = varQual (pREL_BASE, SLIT(">>="))
+zeroM_RDR = varQual (pREL_BASE, SLIT("zero"))
+fromRational_RDR = varQual (pREL_NUM, SLIT("fromRational"))
+
negate_RDR = varQual (pREL_BASE, SLIT("negate"))
eq_RDR = varQual (pREL_BASE, SLIT("=="))
ne_RDR = varQual (pREL_BASE, SLIT("/="))
@@ -368,11 +404,6 @@ readParen_RDR = varQual (pREL_READ, SLIT("readParen"))
lex_RDR = varQual (pREL_READ, SLIT("lex"))
readList___RDR = varQual (pREL_READ, SLIT("readList__"))
-fromEnum_RDR = varQual (pREL_BASE, SLIT("fromEnum"))
-enumFrom_RDR = varQual (pREL_BASE, SLIT("enumFrom"))
-enumFromTo_RDR = varQual (pREL_BASE, SLIT("enumFromTo"))
-enumFromThen_RDR = varQual (pREL_BASE, SLIT("enumFromThen"))
-enumFromThenTo_RDR = varQual (pREL_BASE, SLIT("enumFromThenTo"))
plus_RDR = varQual (pREL_BASE, SLIT("+"))
times_RDR = varQual (pREL_BASE, SLIT("*"))
mkInt_RDR = varQual (pREL_BASE, SLIT("I#"))
@@ -395,7 +426,8 @@ geH_RDR = prelude_primop IntGeOp
leH_RDR = prelude_primop IntLeOp
minusH_RDR = prelude_primop IntSubOp
-intType_RDR = qual (modAndOcc intTyCon)
+main_RDR = varQual (mAIN, SLIT("main"))
+mainPrimIO_RDR = varQual (gHC_MAIN, SLIT("mainPrimIO"))
\end{code}
%************************************************************************
@@ -423,18 +455,18 @@ derivingOccurrences = listToUFM deriving_occ_info
derivableClassKeys = map fst deriving_occ_info
deriving_occ_info
- = [ (eqClassKey, [intType_RDR, and_RDR, not_RDR])
- , (ordClassKey, [intType_RDR, compose_RDR])
- , (enumClassKey, [intType_RDR, map_RDR])
- , (evalClassKey, [intType_RDR])
- , (boundedClassKey, [intType_RDR])
- , (showClassKey, [intType_RDR, numClass_RDR, ordClass_RDR, compose_RDR, showString_RDR,
+ = [ (eqClassKey, [intTyCon_RDR, and_RDR, not_RDR])
+ , (ordClassKey, [intTyCon_RDR, compose_RDR])
+ , (enumClassKey, [intTyCon_RDR, map_RDR])
+ , (evalClassKey, [intTyCon_RDR])
+ , (boundedClassKey, [intTyCon_RDR])
+ , (showClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR, compose_RDR, showString_RDR,
showParen_RDR, showSpace_RDR, showList___RDR])
- , (readClassKey, [intType_RDR, numClass_RDR, ordClass_RDR, append_RDR,
+ , (readClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR, append_RDR,
lex_RDR, readParen_RDR, readList___RDR])
- , (ixClassKey, [intType_RDR, numClass_RDR, and_RDR, map_RDR])
+ , (ixClassKey, [intTyCon_RDR, numClass_RDR, and_RDR, map_RDR])
]
- -- intType: Practically any deriving needs Int, either for index calculations,
+ -- intTyCon: Practically any deriving needs Int, either for index calculations,
-- or for taggery.
-- ordClass: really it's the methods that are actually used.
-- numClass: for Int literals
diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs
index 06c91a35fa0125822fd5bf1abb8edb9cfe39517a..742510f0699fee19d73ba65a62c4ce9022eb469f 100644
--- a/ghc/compiler/prelude/TysWiredIn.lhs
+++ b/ghc/compiler/prelude/TysWiredIn.lhs
@@ -510,7 +510,7 @@ mkPrimIoTy a = mkStateTransformerTy realWorldTy a
primIoTyCon
= pcSynTyCon
- primIoTyConKey iO_BASE SLIT("PrimIO")
+ primIoTyConKey sT_BASE SLIT("PrimIO")
(mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind)
1 alpha_tyvar (mkPrimIoTy alphaTy)
\end{code}
diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs
index b5e035a0667cf2d6b4375505aa2408b9c5c50305..ec761e4659f25f0c3a2222b661dae876eecd371c 100644
--- a/ghc/compiler/reader/Lex.lhs
+++ b/ghc/compiler/reader/Lex.lhs
@@ -20,6 +20,7 @@ module Lex (
IMPORT_1_3(Char(isDigit, isAlpha, isAlphanum, isUpper))
+import CmdLineOpts ( opt_IgnoreIfacePragmas )
import Demand ( Demand {- instance Read -} )
import FiniteMap ( FiniteMap, listToFM, lookupFM )
import Maybes ( Maybe(..), MaybeErr(..) )
@@ -210,7 +211,6 @@ lexIface input
',' : cs -> ITcomma : lexIface cs
':' : ':' : cs -> ITdcolon : lexIface cs
';' : cs -> ITsemi : lexIface cs
- '@' : cs -> ITatsign : lexIface cs
'\"' : cs -> case reads input of
[(str, rest)] -> ITstring (_PK_ (str::String)) : lexIface rest
'\'' : cs -> case reads input of
@@ -254,11 +254,13 @@ lexIface input
= case (span is_kwd_mod_char str) of { (kw, rest) ->
case (lookupFM ifaceKeywordsFM kw) of
Nothing -> panic ("lex_keyword:"++str)
- Just xx -> xx : lexIface rest
+
+ Just xx | startDiscard xx &&
+ opt_IgnoreIfacePragmas -> lexIface (doDiscard rest)
+ | otherwise -> xx : lexIface rest
}
- is_kwd_mod_char '_' = True
- is_kwd_mod_char c = isAlphanum c
+ is_kwd_mod_char c = isAlphanum c || c `elem` "_@/\\"
-----------
lex_cstring so_far ('\'' : '\'' : cs) = ITstring (_PK_ (reverse (so_far::String))) : lexIface cs
@@ -272,10 +274,8 @@ lexIface input
go n (')':cs) = end_lex_id module_dot (ITconid (mkTupNameStr n)) cs
go n other = panic ("lex_tuple" ++ orig_cs)
- -- NB: ':' isn't valid inside an identifier, only at the start.
- -- otherwise we get confused by a::t!
-- Similarly ' itself is ok inside an identifier, but not at the start
- is_id_char c = isAlphanum c || c `elem` "_'!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
+ is_id_char c = isAlphanum c || c `elem` ":_'!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
lex_id cs = go [] cs
where
@@ -319,7 +319,9 @@ lexIface input
------------
ifaceKeywordsFM :: FiniteMap String IfaceToken
ifaceKeywordsFM = listToFM [
- ("interface_", ITinterface)
+ ("/\\_", ITbiglam)
+ ,("@_", ITatsign)
+ ,("interface_", ITinterface)
,("usages_", ITusages)
,("versions_", ITversions)
,("exports_", ITexports)
@@ -333,8 +335,6 @@ lexIface input
,("A_", ITarity)
,("coerce_in_", ITcoerce_in)
,("coerce_out_", ITcoerce_out)
- ,("A_", ITarity)
- ,("A_", ITarity)
,("bot_", ITbottom)
,("integer_", ITinteger_lit)
,("rational_", ITrational_lit)
@@ -368,12 +368,22 @@ lexIface input
,("->", ITrarrow)
,("\\", ITlam)
- ,("/\\", ITbiglam)
,("|", ITvbar)
,("!", ITbang)
,("=>", ITdarrow)
,("=", ITequal)
]
+
+startDiscard ITarity = True
+startDiscard ITunfold = True
+startDiscard ITstrict = True
+startDiscard other = False
+
+-- doDiscard rips along really fast looking for a double semicolon,
+-- indicating the end of the pragma we're skipping
+doDiscard rest@(';' : ';' : _) = rest
+doDiscard ( _ : rest) = doDiscard rest
+doDiscard [] = []
\end{code}
diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs
index 61da9a225a6aa54183b87389c2044d4948775c01..9b72fa5f2a6c316c69184d0543505761ec61245c 100644
--- a/ghc/compiler/reader/PrefixToHs.lhs
+++ b/ghc/compiler/reader/PrefixToHs.lhs
@@ -150,9 +150,9 @@ cvFunMonoBind sf matches
get_mdef (RdrMatch_NoGuard _ sfun pat _ _) = get_pdef pat
get_mdef (RdrMatch_Guards _ sfun pat _ _) = get_pdef pat
- get_pdef (ConPatIn fn _) = (fn, False)
- get_pdef (ConOpPatIn _ op _) = (op, True)
- get_pdef (ParPatIn pat) = get_pdef pat
+ get_pdef (ConPatIn fn _) = (fn, False)
+ get_pdef (ConOpPatIn _ op _ _) = (op, True)
+ get_pdef (ParPatIn pat) = get_pdef pat
cvMatches :: SrcFile -> Bool -> [RdrMatch] -> [RdrNameMatch]
@@ -172,9 +172,9 @@ cvMatch sf is_case rdr_match
(if is_case then -- just one pattern: leave it untouched...
[pat]
else -- function pattern; extract arg patterns...
- case pat of ConPatIn fn pats -> pats
- ConOpPatIn p1 op p2 -> [p1,p2]
- ParPatIn pat -> panic "PrefixToHs.cvMatch:ParPatIn"
+ case pat of ConPatIn fn pats -> pats
+ ConOpPatIn p1 op _ p2 -> [p1,p2]
+ ParPatIn pat -> panic "PrefixToHs.cvMatch:ParPatIn"
)
where
(pat, binding, guarded_exprs)
diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs
index 776ccfc7f143a2359ea227bf4db13d0edd10cbdb..ab07b885e6ae40604f3ba0d29f830e2840dcc316 100644
--- a/ghc/compiler/reader/RdrHsSyn.lhs
+++ b/ghc/compiler/reader/RdrHsSyn.lhs
@@ -52,7 +52,8 @@ module RdrHsSyn (
dummyRdrVarName, dummyRdrTcName,
isUnqual, isQual,
showRdr, rdrNameOcc,
- cmpRdr
+ cmpRdr,
+ mkOpApp
) where
@@ -132,7 +133,15 @@ extractHsTyVars ty
| otherwise = other : acc
\end{code}
-
+
+A useful function for building @OpApps@. The operator is always a variable,
+and we don't know the fixity yet.
+
+\begin{code}
+mkOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2
+\end{code}
+
+
%************************************************************************
%* *
\subsection[RdrName]{The @RdrName@ datatype; names read from files}
diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs
index 9dd701776b1fc1b7114efe14b2f82afc0aa20e22..2098692e77a6497d6445865e477e157fc7e30e0a 100644
--- a/ghc/compiler/reader/ReadPrefix.lhs
+++ b/ghc/compiler/reader/ReadPrefix.lhs
@@ -121,7 +121,7 @@ rdModule
wlkBinding hmodlist `thenUgn` \ binding ->
let
- val_decl = ValD (add_main_sig modname (cvBinds srcfile cvValSig binding))
+ val_decl = ValD (cvBinds srcfile cvValSig binding)
other_decls = cvOtherDecls binding
in
returnUgn (modname,
@@ -133,28 +133,6 @@ rdModule
(val_decl: other_decls)
src_loc
)
- where
- add_main_sig modname binds
- = if modname == mAIN then
- let
- s = Sig (varUnqual SLIT("main")) (io_ty SLIT("IO")) mkGeneratedSrcLoc
- in
- add_sig binds s
-
- else if modname == gHC_MAIN then
- let
- s = Sig (varUnqual SLIT("mainPrimIO")) (io_ty SLIT("PrimIO")) mkGeneratedSrcLoc
- in
- add_sig binds s
-
- else -- add nothing
- binds
- where
- add_sig (SingleBind b) s = BindWith b [s]
- add_sig (BindWith b ss) s = BindWith b (s:ss)
- add_sig _ _ = panic "rdModule:add_sig"
-
- io_ty t = MonoTyApp (MonoTyVar (Unqual (TCOcc t))) (MonoTupleTy dummyRdrTcName [])
\end{code}
%************************************************************************
@@ -335,7 +313,7 @@ wlkExpr expr
wlkVarId fun `thenUgn` \ op ->
wlkExpr arg1 `thenUgn` \ expr1 ->
wlkExpr arg2 `thenUgn` \ expr2 ->
- returnUgn (OpApp expr1 (HsVar op) expr2)
+ returnUgn (mkOpApp expr1 op expr2)
U_negate nexp -> -- prefix negation
wlkExpr nexp `thenUgn` \ expr ->
@@ -426,9 +404,9 @@ wlkPat pat
wlkPat r `thenUgn` \ rpat ->
collect_pats l [rpat] `thenUgn` \ (lpat,lpats) ->
(case lpat of
- VarPatIn x -> returnUgn (x, lpats)
- ConPatIn x [] -> returnUgn (x, lpats)
- ConOpPatIn x op y -> returnUgn (op, x:y:lpats)
+ VarPatIn x -> returnUgn (x, lpats)
+ ConPatIn x [] -> returnUgn (x, lpats)
+ ConOpPatIn x op _ y -> returnUgn (op, x:y:lpats)
_ -> getSrcLocUgn `thenUgn` \ loc ->
let
err = addErrLoc loc "Illegal pattern `application'"
@@ -460,7 +438,7 @@ wlkPat pat
wlkVarId fun `thenUgn` \ op ->
wlkPat arg1 `thenUgn` \ pat1 ->
wlkPat arg2 `thenUgn` \ pat2 ->
- returnUgn (ConOpPatIn pat1 op pat2)
+ returnUgn (ConOpPatIn pat1 op (error "ConOpPatIn:fixity") pat2)
U_negate npat -> -- negated pattern
wlkPat npat `thenUgn` \ pat ->
diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y
index 5e1b2c5427d1c03816671d07dbf4aadb02307d87..0faa5494536b6f4992204828c09381c2a02268fd 100644
--- a/ghc/compiler/rename/ParseIface.y
+++ b/ghc/compiler/rename/ParseIface.y
@@ -5,6 +5,8 @@ module ParseIface ( parseIface ) where
IMP_Ubiq(){-uitous-}
+import CmdLineOpts ( opt_IgnoreIfacePragmas )
+
import HsSyn -- quite a bit of stuff
import RdrHsSyn -- oodles of synonyms
import HsDecls ( HsIdInfo(..) )
@@ -223,8 +225,12 @@ topdecl : TYPE tc_name tv_bndrs EQUAL type SEMI
{ TyD (TyNew $2 $3 $4 $6 $7 noDataPragmas mkIfaceSrcLoc) }
| CLASS decl_context tc_name tv_bndr csigs SEMI
{ ClD (ClassDecl $2 $3 $4 $5 EmptyMonoBinds noClassPragmas mkIfaceSrcLoc) }
- | var_name DCOLON type id_info SEMI
- { SigD (IfaceSig $1 $3 $4 mkIfaceSrcLoc) }
+ | var_name DCOLON type id_info SEMI SEMI
+ { {- Double semicolon allows easy pragma discard in lexer -}
+ let
+ id_info = if opt_IgnoreIfacePragmas then [] else $4
+ in
+ SigD (IfaceSig $1 $3 id_info mkIfaceSrcLoc) }
decl_context :: { RdrNameContext }
decl_context : { [] }
diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs
index 5964faa49aba1fa0b5a1e137a6ef8902597a4f08..d66596bc3fd3847865c0d0066b704711d2379119 100644
--- a/ghc/compiler/rename/Rename.lhs
+++ b/ghc/compiler/rename/Rename.lhs
@@ -24,14 +24,17 @@ import RnSource ( rnDecl )
import RnIfaces ( getImportedInstDecls, getDecl, getImportVersions, getSpecialInstModules,
mkSearchPath, getWiredInDecl
)
-import RnEnv ( availsToNameSet, addAvailToNameSet, addImplicitOccsRn )
+import RnEnv ( availsToNameSet, addAvailToNameSet,
+ addImplicitOccsRn, lookupImplicitOccRn )
import Id ( GenId {- instance NamedThing -} )
import Name ( Name, Provenance, ExportFlag(..), isLocallyDefined,
NameSet(..), elemNameSet, mkNameSet, unionNameSets, nameSetToList,
isWiredInName, modAndOcc
)
import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon )
+import PrelInfo ( ioTyCon_NAME, primIoTyCon_NAME )
import TyCon ( TyCon )
+import PrelMods ( mAIN, gHC_MAIN )
import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) )
import FiniteMap ( emptyFM, eltsFM, fmToList, addToFM, FiniteMap )
import Pretty
@@ -72,14 +75,10 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_
Just (export_env, rn_env, local_avails) ->
-- RENAME THE SOURCE
- -- We also add occurrences for Int, Double, and (), because they
- -- are the types to which ambigious type variables may be defaulted by
- -- the type checker; so they won't every appear explicitly.
- -- [The () one is a GHC extension for defaulting CCall results.]
- initRnMS rn_env mod_name SourceMode (mapRn rnDecl local_decls) `thenRn` \ rn_local_decls ->
- addImplicitOccsRn [getName intTyCon,
- getName doubleTyCon,
- getName unitTyCon] `thenRn_`
+ initRnMS rn_env mod_name SourceMode (
+ addImplicits mod_name `thenRn_`
+ mapRn rnDecl local_decls
+ ) `thenRn` \ rn_local_decls ->
-- SLURP IN ALL THE NEEDED DECLARATIONS
-- Notice that the rnEnv starts empty
@@ -93,7 +92,7 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_
-- We do another closeDecls, so that we can slurp info for the dictionary functions
-- for the instance declaration. These are *not* optional because the version number on
-- the dfun acts as the version number for the instance declaration itself; if the
- -- instance decl changes, so will it's dfun version number.
+ -- instance decl changes, so will its dfun version number.
getImportedInstDecls `thenRn` \ imported_insts ->
let
all_big_names = mkNameSet [name | Avail name _ <- local_avails] `unionNameSets`
@@ -148,6 +147,26 @@ renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_
trashed_fixities = []
\end{code}
+@addImplicits@ forces the renamer to slurp in some things which aren't
+mentioned explicitly, but which might be needed by the type checker.
+
+\begin{code}
+addImplicits mod_name
+ = addImplicitOccsRn (implicit_main ++ default_tys)
+ where
+ -- Add occurrences for Int, Double, and (), because they
+ -- are the types to which ambigious type variables may be defaulted by
+ -- the type checker; so they won't every appear explicitly.
+ -- [The () one is a GHC extension for defaulting CCall results.]
+ default_tys = [getName intTyCon, getName doubleTyCon, getName unitTyCon]
+
+ -- Add occurrences for IO or PrimIO
+ implicit_main | mod_name == mAIN = [ioTyCon_NAME]
+ | mod_name == gHC_MAIN = [primIoTyCon_NAME]
+ | otherwise = []
+\end{code}
+
+
\begin{code}
closeDecls :: [RenamedHsDecl] -- Declarations got so far
-> NameSet -- Names bound by those declarations
diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs
index fa90d3fd4fc67523299b01a5ae9fec2d16aae420..da4fed92c0a0b20534dba863027b5c98dd0f918d 100644
--- a/ghc/compiler/rename/RnEnv.lhs
+++ b/ghc/compiler/rename/RnEnv.lhs
@@ -272,7 +272,6 @@ addImplicitOccRn name = addOccurrenceName Compulsory name
addImplicitOccsRn :: [Name] -> RnM s d ()
addImplicitOccsRn names = addOccurrenceNames Compulsory names
-intType_RDR = qual (modAndOcc (getName intTyCon))
listType_RDR = qual (modAndOcc listType_name)
tupleType_RDR n = qual (modAndOcc (tupleType_name n))
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 613b37be92d35e2bac91607d54ae28d5c8fde047..73b1c44692febfb6a9670a563917095b30ecc6f0 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -41,7 +41,8 @@ import UniqSet ( emptyUniqSet, unitUniqSet,
unionUniqSets, unionManyUniqSets,
SYN_IE(UniqSet)
)
-import Util ( Ord3(..), removeDups, panic )
+import PprStyle ( PprStyle(..) )
+import Util ( Ord3(..), removeDups, panic, pprPanic, assertPanic )
\end{code}
@@ -79,8 +80,12 @@ rnPat (ConPatIn con pats)
mapRn rnPat pats `thenRn` \ patslist ->
returnRn (ConPatIn con' patslist)
-rnPat (ConOpPatIn pat1 con pat2)
- = rnOpPat pat1 con pat2
+rnPat (ConOpPatIn pat1 con _ pat2)
+ = rnPat pat1 `thenRn` \ pat1' ->
+ lookupRn con `thenRn` \ con' ->
+ lookupFixity con `thenRn` \ fixity ->
+ rnPat pat2 `thenRn` \ pat2' ->
+ mkConOpPatRn pat1' con' fixity pat2'
-- Negated patters can only be literals, and they are dealt with
-- by negating the literal at compile time, not by using the negation
@@ -217,9 +222,28 @@ rnExpr (HsApp fun arg)
rnExpr arg `thenRn` \ (arg',fvArg) ->
returnRn (HsApp fun' arg', fvFun `unionNameSets` fvArg)
-rnExpr (OpApp e1 (HsVar op) e2) = rnOpApp e1 op e2
+rnExpr (OpApp e1 op@(HsVar op_name) _ e2)
+ = rnExpr e1 `thenRn` \ (e1', fv_e1) ->
+ rnExpr e2 `thenRn` \ (e2', fv_e2) ->
+ rnExpr op `thenRn` \ (op', fv_op) ->
-rnExpr (NegApp e n) = completeNegApp (rnExpr e)
+ -- Deal wth fixity
+ lookupFixity op_name `thenRn` \ fixity ->
+ getModeRn `thenRn` \ mode ->
+ (case mode of
+ SourceMode -> mkOpAppRn e1' op' fixity e2'
+ InterfaceMode -> returnRn (OpApp e1' op' fixity e2')
+ ) `thenRn` \ final_e ->
+
+ returnRn (final_e,
+ fv_e1 `unionNameSets` fv_op `unionNameSets` fv_e2)
+
+rnExpr (NegApp e n)
+ = rnExpr e `thenRn` \ (e', fv_e) ->
+ lookupImplicitOccRn negate_RDR `thenRn` \ neg ->
+ getModeRn `thenRn` \ mode ->
+ mkNegAppRn mode e' (HsVar neg) `thenRn` \ final_e ->
+ returnRn (final_e, fv_e)
rnExpr (HsPar e)
= rnExpr e `thenRn` \ (e', fvs_e) ->
@@ -467,85 +491,94 @@ rnStmt (LetStmt binds) thing_inside
%* *
%************************************************************************
-@rnOpApp@ deals with operator applications. It does some rearrangement of
-the expression so that the precedences are right. This must be done on the
-expression *before* renaming, because fixity info applies to the things
-the programmer actually wrote.
+@mkOpAppRn@ deals with operator fixities. The argument expressions
+are assumed to be already correctly arranged. It needs the fixities
+recorded in the OpApp nodes, because fixity info applies to the things
+the programmer actually wrote, so you can't find it out from the Name.
+
+Furthermore, the second argument is guaranteed not to be another
+operator application. Why? Because the parser parses all
+operator appications left-associatively.
\begin{code}
-rnOpApp (NegApp e11 n) op e2
- = lookupFixity op `thenRn` \ (Fixity op_prec op_dir) ->
- if op_prec > 6 then
- -- negate precedence 6 wired in
- -- (-x)*y ==> -(x*y)
- completeNegApp (rnOpApp e11 op e2)
- else
- completeOpApp (completeNegApp (rnExpr e11)) op (rnExpr e2)
-
-rnOpApp (OpApp e11 (HsVar op1) e12) op e2
- = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
- lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
- -- pprTrace "rnOpApp:" (ppCat [ppr PprDebug op, ppInt op_prec, ppr PprDebug op1, ppInt op1_prec]) $
- case (op1_prec `cmp` op_prec) of
- LT_ -> rearrange
- EQ_ -> case (op1_dir, op_dir) of
- (InfixR, InfixR) -> rearrange
- (InfixL, InfixL) -> dont_rearrange
- _ -> addErrRn (precParseErr (op1,op1_fix) (op,op_fix)) `thenRn_`
- dont_rearrange
- GT__ -> dont_rearrange
+mkOpAppRn :: RenamedHsExpr -> RenamedHsExpr -> Fixity -> RenamedHsExpr
+ -> RnMS s RenamedHsExpr
+
+mkOpAppRn e1@(OpApp e11 op1 fix1 e12)
+ op2 fix2 e2
+ | nofix_error
+ = addErrRn (precParseErr (get op1,fix1) (get op2,fix2)) `thenRn_`
+ returnRn (OpApp e1 op2 fix2 e2)
+
+ | rearrange_me
+ = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e ->
+ returnRn (OpApp e11 op1 fix1 new_e)
where
- rearrange = rnOpApp e11 op1 (OpApp e12 (HsVar op) e2)
- dont_rearrange = completeOpApp (rnOpApp e11 op1 e12) op (rnExpr e2)
-
-rnOpApp e1 op e2 = completeOpApp (rnExpr e1) op (rnExpr e2)
+ (nofix_error, rearrange_me) = compareFixity fix1 fix2
+ get (HsVar n) = n
+
+mkOpAppRn e1@(NegApp neg_arg neg_id)
+ op2
+ fix2@(Fixity prec2 dir2)
+ e2
+ | prec2 > 6 -- Precedence of unary - is wired in as 6!
+ = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
+ returnRn (NegApp new_e neg_id)
+
+mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
+ = ASSERT( right_op_ok fix e2 )
+ returnRn (OpApp e1 op fix e2)
+
+-- Parser left-associates everything, but
+-- derived instances may have correctly-associated things to
+-- in the right operarand. So we just check that the right operand is OK
+right_op_ok fix1 (OpApp _ _ fix2 _)
+ = not error_please && associate_right
+ where
+ (error_please, associate_right) = compareFixity fix1 fix2
+right_op_ok fix1 other
+ = True
-completeOpApp rn_e1 op rn_e2
- = rn_e1 `thenRn` \ (e1', fvs1) ->
- rn_e2 `thenRn` \ (e2', fvs2) ->
- rnExpr (HsVar op) `thenRn` \ (op', fvs3) ->
- returnRn (OpApp e1' op' e2', fvs1 `unionNameSets` fvs2 `unionNameSets` fvs3)
+-- Parser initially makes negation bind more tightly than any other operator
+mkNegAppRn mode neg_arg neg_id
+ = ASSERT( not_op_app mode neg_arg )
+ returnRn (NegApp neg_arg neg_id)
-completeNegApp rn_expr
- = rn_expr `thenRn` \ (e', fvs_e) ->
- lookupImplicitOccRn negate_RDR `thenRn` \ neg ->
- returnRn (NegApp e' (HsVar neg), fvs_e)
+not_op_app SourceMode (OpApp _ _ _ _) = False
+not_op_app mode other = True
\end{code}
\begin{code}
-rnOpPat p1@(NegPatIn p11) op p2
- = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
- if op_prec > 6 then
- -- negate precedence 6 wired in
- addErrRn (precParseNegPatErr (op,op_fix)) `thenRn_`
- rnOpPat p11 op p2 `thenRn` \ op_pat ->
- returnRn (NegPatIn op_pat)
- else
- completeOpPat (rnPat p1) op (rnPat p2)
-
-rnOpPat (ConOpPatIn p11 op1 p12) op p2
- = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
- lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
- case (op1_prec `cmp` op_prec) of
- LT_ -> rearrange
- EQ_ -> case (op1_dir, op_dir) of
- (InfixR, InfixR) -> rearrange
- (InfixL, InfixL) -> dont_rearrange
- _ -> addErrRn (precParseErr (op1,op1_fix) (op,op_fix)) `thenRn_`
- dont_rearrange
- GT__ -> dont_rearrange
- where
- rearrange = rnOpPat p11 op1 (ConOpPatIn p12 op p2)
- dont_rearrange = completeOpPat (rnOpPat p11 op1 p12) op (rnPat p2)
+mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
+ -> RnMS s RenamedPat
+mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
+ op2 fix2 p2
+ | nofix_error
+ = addErrRn (precParseErr (op1,fix1) (op2,fix2)) `thenRn_`
+ returnRn (ConOpPatIn p1 op2 fix2 p2)
-rnOpPat p1 op p2 = completeOpPat (rnPat p1) op (rnPat p2)
+ | rearrange_me
+ = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p ->
+ returnRn (ConOpPatIn p11 op1 fix1 new_p)
-completeOpPat rn_p1 op rn_p2
- = rn_p1 `thenRn` \ p1' ->
- rn_p2 `thenRn` \ p2' ->
- lookupRn op `thenRn` \ op' ->
- returnRn (ConOpPatIn p1' op' p2')
+ where
+ (nofix_error, rearrange_me) = compareFixity fix1 fix2
+
+mkConOpPatRn p1@(NegPatIn neg_arg)
+ op2
+ fix2@(Fixity prec2 dir2)
+ p2
+ | prec2 > 6 -- Precedence of unary - is wired in as 6!
+ = addErrRn (precParseNegPatErr (op2,fix2)) `thenRn_`
+ returnRn (ConOpPatIn p1 op2 fix2 p2)
+
+mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment
+ = ASSERT( not_op_pat p2 )
+ returnRn (ConOpPatIn p1 op fix p2)
+
+not_op_pat (ConOpPatIn _ _ _ _) = False
+not_op_pat other = True
\end{code}
\begin{code}
@@ -559,7 +592,7 @@ checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _)))
checkPrecMatch True op _
= panic "checkPrecMatch"
-checkPrec op (ConOpPatIn _ op1 _) right
+checkPrec op (ConOpPatIn _ op1 _ _) right
= lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
let
@@ -582,6 +615,30 @@ checkPrec op pat right
= returnRn ()
\end{code}
+Consider
+ a `op1` b `op2` c
+
+(compareFixity op1 op2) tells which way to arrange appication, or
+whether there's an error.
+
+\begin{code}
+compareFixity :: Fixity -> Fixity
+ -> (Bool, -- Error please
+ Bool) -- Associate to the right: a op1 (b op2 c)
+compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
+ = case prec1 `cmp` prec2 of
+ GT_ -> left
+ LT_ -> right
+ EQ_ -> case (dir1, dir2) of
+ (InfixR, InfixR) -> right
+ (InfixL, InfixL) -> left
+ _ -> error_please
+ where
+ right = (False, True)
+ left = (False, False)
+ error_please = (True, False)
+\end{code}
+
%************************************************************************
%* *
\subsubsection{Literals}
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index b6f45211e9c943ab0a81588e95ef8654f1337380..8b804f279b4249a707201167e2c37f1f0340115d 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -22,6 +22,7 @@ module RnIfaces (
IMP_Ubiq()
+-- import CmdLineOpts ( opt_HiSuffix )
import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, Bind, HsExpr, Sig(..),
HsBinds(..), MonoBinds, DefaultDecl, ConDecl(..), HsType, BangType, IfaceSig(..),
FixityDecl(..), Fixity, Fake, InPat, InstDecl(..), SYN_IE(Version), HsIdInfo
@@ -572,7 +573,7 @@ mkSearchPath (Just s)
\begin{code}
noIfaceErr mod sty
- = ppBesides [ppStr "Could not find interface for ", ppQuote (pprModule sty mod)]
+ = ppBesides [ppStr "Could not find valid interface file for ", ppQuote (pprModule sty mod)]
-- , ppStr " in"]) 4 (ppAboves (map ppStr dirs))
cannaeReadFile file err sty
diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs
index a2cc06aece992c22f99412244aab757835ac2c05..62f789de8117607bb611470c9bef4a84001725b4 100644
--- a/ghc/compiler/rename/RnMonad.lhs
+++ b/ghc/compiler/rename/RnMonad.lhs
@@ -145,7 +145,7 @@ emptyFixityEnv = emptyFM
data ExportEnv = ExportEnv Avails Fixities
type Avails = [AvailInfo]
-type Fixities = [(OccName, Fixity, Provenance)]
+type Fixities = [(OccName, (Fixity, Provenance))]
-- Can contain duplicates, if one module defines the same fixity,
-- or the same type/class/id, more than once. Hence a boring old list.
-- This allows us to report duplicates in just one place, namely plusRnEnv.
diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs
index 51b84246bf686c41a9aba8db0c2a390cfea9cff6..754dfd29b001c250a5d7f5c8b38784254b866743 100644
--- a/ghc/compiler/rename/RnNames.lhs
+++ b/ghc/compiler/rename/RnNames.lhs
@@ -34,7 +34,7 @@ import Maybes ( maybeToBool, expectJust )
import Name
import Pretty
import PprStyle ( PprStyle(..) )
-import Util ( panic, pprTrace )
+import Util ( panic, pprTrace, assertPanic )
\end{code}
@@ -111,18 +111,19 @@ getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc)
\begin{code}
checkEarlyExit mod
- = if not opt_SourceUnchanged then
- -- Source code changed; look no further
+ = checkErrsRn `thenRn` \ no_errs_so_far ->
+ if not no_errs_so_far then
+ -- Found errors already, so exit now
+ returnRn True
+ else
+ if not opt_SourceUnchanged then
+ -- Source code changed and no errors yet... carry on
returnRn False
else
- -- Unchanged source; look further
- -- We check for
- -- (a) errors so far. These can arise if a module imports
- -- something that's no longer exported by the imported module
- -- (b) usage information up to date
- checkErrsRn `thenRn` \ no_errs_so_far ->
+ -- Unchanged source, and no errors yet; see if usage info
+ -- up to date, and exit if so
checkUpToDate mod `thenRn` \ up_to_date ->
- returnRn (no_errs_so_far && up_to_date)
+ returnRn up_to_date
\end{code}
@@ -138,7 +139,7 @@ importsFromImportDecl (ImportDecl mod qual_only as_mod import_spec loc)
filtered_avails' = [ Avail (set_name_prov n) (map set_name_prov ns)
| Avail n ns <- filtered_avails
]
- fixities' = [ (occ,fixity,provenance) | (occ,fixity) <- fixities ]
+ fixities' = [ (occ,(fixity,provenance)) | (occ,fixity) <- fixities ]
in
qualifyImports mod
True -- Want qualified names
@@ -293,7 +294,7 @@ qualifyImports this_mod qual_imp unqual_imp as_mod (ExportEnv avails fixities)
both = unqual_only `thenRn` \ env' ->
add_fn env' (Qual qual_mod occ) thing
- add_fixity name_env fixity_env (occ_name, fixity, provenance)
+ add_fixity name_env fixity_env (occ_name, (fixity, provenance))
| maybeToBool (lookupFM name_env rdr_name) -- It's imported
= add_to_env addOneToFixityEnvRn fixity_env occ_name (fixity,provenance)
| otherwise -- It ain't imported
@@ -320,10 +321,10 @@ unQualify fm = addListToFM fm [(Unqual occ, elt) | (Qual _ occ, elt) <- fmToList
\begin{code}
-fixityFromFixDecl :: RdrNameFixityDecl -> RnMG (OccName, Fixity, Provenance)
+fixityFromFixDecl :: RdrNameFixityDecl -> RnMG (OccName, (Fixity, Provenance))
fixityFromFixDecl (FixityDecl rdr_name fixity loc)
- = returnRn (rdrNameOcc rdr_name, fixity, LocalDef (panic "export-flag") loc)
+ = returnRn (rdrNameOcc rdr_name, (fixity, LocalDef (panic "export-flag") loc))
\end{code}
@@ -426,12 +427,46 @@ exportsFromAvail this_mod (Just export_items) all_avails (RnEnv name_env fixity_
enough_avail = case export_avail of {NotAvailable -> False; other -> True}
-- We export a fixity iff we export a thing with the same (qualified) RdrName
- mk_exported_fixities :: NameSet -> [(OccName, Fixity, Provenance)]
+ mk_exported_fixities :: NameSet -> [(OccName, (Fixity, Provenance))]
mk_exported_fixities exports
- = [ (rdrNameOcc rdr_name, fixity, prov)
- | (rdr_name, (fixity, prov)) <- fmToList fixity_env,
- export_fixity name_env exports rdr_name
- ]
+ = fmToList (foldr (perhaps_add_fixity exports)
+ emptyFM
+ (fmToList fixity_env))
+
+ perhaps_add_fixity :: NameSet -> (RdrName, (Fixity, Provenance))
+ -> FiniteMap OccName (Fixity,Provenance)
+ -> FiniteMap OccName (Fixity,Provenance)
+ perhaps_add_fixity exports (rdr_name, (fixity, prov)) fix_env
+ = let
+ do_nothing = fix_env -- The default is to pass on the env unchanged
+ in
+ -- Step 1: check whether the rdr_name is in scope; if so find its Name
+ case lookupFM name_env rdr_name of {
+ Nothing -> do_nothing;
+ Just fixity_name ->
+
+ -- Step 2: check whether the fixity thing is exported
+ if not (fixity_name `elemNameSet` exports) then
+ do_nothing
+ else
+
+ -- Step 3: check whether we already have a fixity for the
+ -- Name's OccName in the fix_env we are building up. This can easily
+ -- happen. the original fixity_env might contain bindings for
+ -- M.a and N.a, if a was imported via M and N.
+ -- If this does happen, we expect the fixity to be the same either way.
+ let
+ occ_name = rdrNameOcc rdr_name
+ in
+ case lookupFM fix_env occ_name of {
+ Just (fixity1, prov1) -> -- Got it already
+ ASSERT( fixity == fixity1 )
+ do_nothing;
+ Nothing ->
+
+ -- Step 3: add it to the outgoing fix_env
+ addToFM fix_env occ_name (fixity,prov)
+ }}
mk_export_fn :: [AvailInfo] -> (Name -> ExportFlag)
mk_export_fn avails
@@ -441,14 +476,6 @@ mk_export_fn avails
where
exported_names :: NameSet
exported_names = availsToNameSet avails
-
-export_fixity :: NameEnv -> NameSet -> RdrName -> Bool
-export_fixity name_env exports rdr_name
- = case lookupFM name_env rdr_name of
- Just fixity_name -> fixity_name `elemNameSet` exports
- -- Check whether the exported thing is
- -- the one to which the fixity attaches
- other -> False -- Not even in scope
\end{code}
diff --git a/ghc/compiler/simplCore/SimplPgm.lhs b/ghc/compiler/simplCore/SimplPgm.lhs
index fc95fffee298325919750f3a14fabfda5455a8c5..506ec80fe3c4e2744b347c2f783e3ea9a643bcff 100644
--- a/ghc/compiler/simplCore/SimplPgm.lhs
+++ b/ghc/compiler/simplCore/SimplPgm.lhs
@@ -10,7 +10,7 @@ module SimplPgm ( simplifyPgm ) where
IMP_Ubiq(){-uitous-}
-import CmdLineOpts ( opt_D_verbose_core2core,
+import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_simpl_iterations,
switchIsOn, SimplifierSwitch(..)
)
import CoreSyn
@@ -68,10 +68,13 @@ simplifyPgm binds s_sw_chkr simpl_stats us
simplCount `thenSmpl` \ r ->
detailedSimplCount `thenSmpl` \ dr ->
let
- show_status = pprTrace "NewSimpl: " (ppAboves [
- ppBesides [ppInt iterations, ppChar '/', ppInt max_simpl_iterations],
- ppStr (showSimplCount dr)
--- DEBUG , ppAboves (map (pprCoreBinding PprDebug) new_pgm)
+ show_status = pprTrace "Simplifer run: " (ppAboves [
+ ppBesides [ppStr "iteration ", ppInt iterations, ppStr " out of ", ppInt max_simpl_iterations],
+ ppStr (showSimplCount dr),
+ if opt_D_dump_simpl_iterations then
+ ppAboves (map (pprCoreBinding PprDebug) new_pgm)
+ else
+ ppNil
])
in
@@ -81,10 +84,12 @@ simplifyPgm binds s_sw_chkr simpl_stats us
else id)
(let stop_now = r == n {-nothing happened-}
- || (if iterations > max_simpl_iterations then
+ || (if iterations >= max_simpl_iterations then
(if max_simpl_iterations > 1 {-otherwise too boring-} then
trace
- ("NOTE: Simplifier still going after "++show max_simpl_iterations++" iterations; bailing out.")
+ ("NOTE: Simplifier still going after " ++
+ show max_simpl_iterations ++
+ " iterations; baling out.")
else id)
True
else
diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index f76ed75b1475c1dd417e9157f4a2207b26b39acd..80ecd77ea2cbece63353b800ae62473a09804fcc 100644
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -57,7 +57,7 @@ import Pretty ( ppHang, ppCat, ppStr, ppAboves, ppBesides,
import PrimOp ( PrimOp(..) )
import SpecUtils
import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, getAppDataTyConExpandingDicts,
- tyVarsOfTypes, applyTypeEnvToTy, isUnboxedType
+ tyVarsOfTypes, applyTypeEnvToTy, isUnboxedType, isDictTy
)
import TyCon ( TyCon{-instance Eq-} )
import TyVar ( cloneTyVar, mkSysTyVar,
@@ -82,7 +82,6 @@ addIdSpecialisation = panic "Specialise.addIdSpecialisation (ToDo)"
cmpUniTypeMaybeList = panic "Specialise.cmpUniTypeMaybeList (ToDo)"
getIdSpecialisation = panic "Specialise.getIdSpecialisation (ToDo)"
isClassOpId = panic "Specialise.isClassOpId (ToDo)"
-isDictTy = panic "Specialise.isDictTy (ToDo)"
isLocalGenTyCon = panic "Specialise.isLocalGenTyCon (ToDo)"
isLocalSpecTyCon = panic "Specialise.isLocalSpecTyCon (ToDo)"
isSpecId_maybe = panic "Specialise.isSpecId_maybe (ToDo)"
diff --git a/ghc/compiler/typecheck/GenSpecEtc.lhs b/ghc/compiler/typecheck/GenSpecEtc.lhs
index 08e8367ed57991bbcd36b41b5f7148a32ea3aa13..f231f897fc7287e9ded16c2f26954cbee7c63b6d 100644
--- a/ghc/compiler/typecheck/GenSpecEtc.lhs
+++ b/ghc/compiler/typecheck/GenSpecEtc.lhs
@@ -158,7 +158,7 @@ genBinds binder_names mono_ids bind lie sig_infos prag_info_fn
resolveOverloading tyvars_to_gen lie bind tysig_vars (head thetas)
`thenTc` \ (lie', reduced_tyvars_to_gen, dict_binds, dicts_bound) ->
- -- Check for generaliseation over unboxed types, and
+ -- Check for generalisation over unboxed types, and
-- default any TypeKind TyVars to BoxedTypeKind
let
tyvars = tyVarSetToList reduced_tyvars_to_gen -- Commit to a particular order
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index 74e5bfa1a7ed0682653c0a9df5ec43271597934a..0c6d0c51926c2a0fe1760e46eb7c8de903477aa9 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -31,7 +31,7 @@ module Inst (
IMP_Ubiq()
IMPORT_1_3(Ratio(Rational))
-import HsSyn ( HsLit(..), HsExpr(..), HsBinds,
+import HsSyn ( HsLit(..), HsExpr(..), HsBinds, Fixity,
InPat, OutPat, Stmt, Qualifier, Match,
ArithSeqInfo, HsType, Fake )
import RnHsSyn ( SYN_IE(RenamedArithSeqInfo), SYN_IE(RenamedHsExpr) )
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 3ce5967cea96554ed69739e0044431428383162f..ffafeb71d7ccd99e92996b76acaf7e38187d03ab 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -336,7 +336,7 @@ stuff. If we simplify only at the f-binding (not the xs-binding)
we'll know that the literals are all Ints, and we can just produce
Int literals!
-Find all the type variables involved in overloading, the "constrained_tyvars"
+Find all the type variables involved in overloading, the "constrained_tyvars".
These are the ones we *aren't* going to generalise.
We must be careful about doing this:
(a) If we fail to generalise a tyvar which is not actually
diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 48af28e0e09147fbf9c0146078c39924d28b6458..da8ea9562cb28c01cdbeb746a0f0bb2338a3e006 100644
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -12,7 +12,7 @@ IMP_Ubiq()
import HsSyn ( HsDecl(..), ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..),
Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..),
- DefaultDecl, TyDecl, InstDecl, IfaceSig,
+ DefaultDecl, TyDecl, InstDecl, IfaceSig, Fixity,
HsLit(..), OutPat(..), Sig(..), HsType(..), HsTyVar,
Stmt, Qualifier, ArithSeqInfo, InPat, Fake )
import HsTypes ( getTyVarName )
diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs
index a13c8aa3c6de39afe8c4063b25582b1a538087ce..473ce91be40926de25b2a4c9626fbc8434cd8e85 100644
--- a/ghc/compiler/typecheck/TcEnv.lhs
+++ b/ghc/compiler/typecheck/TcEnv.lhs
@@ -15,6 +15,7 @@ module TcEnv(
tcExtendGlobalValEnv, tcExtendLocalValEnv,
tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey,
tcLookupGlobalValue, tcLookupGlobalValueByKey, tcLookupGlobalValueMaybe,
+ tcLookupGlobalValueByKeyMaybe,
newMonoIds, newLocalIds, newLocalId,
tcGetGlobalTyVars, tcExtendGlobalTyVars
@@ -275,6 +276,10 @@ tcLookupGlobalValueByKey uniq
def = panic "tcLookupGlobalValueByKey"
#endif
+tcLookupGlobalValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id)
+tcLookupGlobalValueByKeyMaybe uniq
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+ returnNF_Tc (lookupUFM_Directly gve uniq)
\end{code}
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 70f8070831e6c78cf1988759fcc2041ca8eb6232..65738ee6f9b0b12aeb9f55c7a966b2323802cc93 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -6,15 +6,15 @@
\begin{code}
#include "HsVersions.h"
-module TcExpr ( tcExpr ) where
+module TcExpr ( tcExpr, tcId ) where
IMP_Ubiq()
import HsSyn ( HsExpr(..), Qualifier(..), Stmt(..),
HsBinds(..), Bind(..), MonoBinds(..),
ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
- Match, Fake, InPat, OutPat, HsType,
- failureFreePat, collectPatBinders )
+ Match, Fake, InPat, OutPat, HsType, Fixity,
+ pprParendExpr, failureFreePat, collectPatBinders )
import RnHsSyn ( SYN_IE(RenamedHsExpr), SYN_IE(RenamedQual),
SYN_IE(RenamedStmt), SYN_IE(RenamedRecordBinds)
)
@@ -187,9 +187,9 @@ tcExpr (HsApp e1 e2) = accum e1 [e2]
returnTc (foldl HsApp fun' args', lie, res_ty)
-- equivalent to (op e1) e2:
-tcExpr (OpApp arg1 op arg2)
+tcExpr (OpApp arg1 op fix arg2)
= tcApp op [arg1,arg2] `thenTc` \ (op', [arg1', arg2'], lie, res_ty) ->
- returnTc (OpApp arg1' op' arg2', lie, res_ty)
+ returnTc (OpApp arg1' op' fix arg2', lie, res_ty)
\end{code}
Note that the operators in sections are expected to be binary, and
@@ -928,8 +928,9 @@ sectionLAppCtxt expr sty
= ppHang (ppStr "In a left section:") 4 (ppr sty expr)
funAppCtxt fun arg_no arg sty
- = ppHang (ppCat [ ppStr "In the", speakNth arg_no, ppStr "argument of", ppr sty fun])
- 4 (ppCat [ppStr "namely", ppr sty arg])
+ = ppHang (ppCat [ ppStr "In the", speakNth arg_no, ppStr "argument of",
+ ppr sty fun `ppBeside` ppStr ", namely"])
+ 4 (pprParendExpr sty arg)
qualCtxt qual sty
= ppHang (ppStr "In a list-comprehension qualifer:")
diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs
index d6c7513f9bee3fa9c8d37d6564530844185ccfe2..856ad7c0a596e6ae86c3f52516aeac73b403945a 100644
--- a/ghc/compiler/typecheck/TcGenDeriv.lhs
+++ b/ghc/compiler/typecheck/TcGenDeriv.lhs
@@ -32,8 +32,8 @@ IMPORT_1_3(List(partition))
import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qualifier(..), Stmt,
- ArithSeqInfo, Sig, HsType, FixityDecl, Fake )
-import RdrHsSyn ( RdrName(..), varQual, varUnqual,
+ ArithSeqInfo, Sig, HsType, FixityDecl, Fixity, Fake )
+import RdrHsSyn ( RdrName(..), varQual, varUnqual, mkOpApp,
SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat)
)
-- import RnHsSyn ( RenamedFixityDecl(..) )
@@ -175,7 +175,7 @@ gen_Eq_binds tycon
where
nested_eq_expr [] [] [] = true_Expr
nested_eq_expr tys as bs
- = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
+ = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
where
nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
\end{code}
@@ -553,7 +553,7 @@ gen_Ix_binds tycon
grhs = [OtherwiseGRHS (mk_easy_App mkInt_RDR [c_RDR]) tycon_loc]
in
HsCase
- (HsPar (OpApp (HsVar dh_RDR) (HsVar minusH_RDR) (HsVar ah_RDR)))
+ (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
[PatMatch (VarPatIn c_RDR)
(GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
tycon_loc
@@ -568,8 +568,8 @@ gen_Ix_binds tycon
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(b_RDR, bh_RDR)] (
untag_Expr tycon [(c_RDR, ch_RDR)] (
- HsIf (HsPar (OpApp (HsVar ch_RDR) (HsVar geH_RDR) (HsVar ah_RDR))) (
- (OpApp (HsVar ch_RDR) (HsVar leH_RDR) (HsVar bh_RDR))
+ HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
+ (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
) {-else-} (
false_Expr
) tycon_loc))))
@@ -610,19 +610,19 @@ gen_Ix_binds tycon
foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
where
mk_index multiply_by (l, u, i)
- =OpApp (
+ = genOpApp (
(HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
- ) (HsVar plus_RDR) (
- OpApp (
+ ) plus_RDR (
+ genOpApp (
(HsApp (HsVar rangeSize_RDR) (ExplicitTuple [HsVar l, HsVar u]))
- ) (HsVar times_RDR) multiply_by
+ ) times_RDR multiply_by
)
range_size
= mk_easy_FunMonoBind tycon_loc rangeSize_RDR [TuplePatIn [a_Pat, b_Pat]] [] (
- OpApp (
+ genOpApp (
(HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
- ) (HsVar plus_RDR) (HsLit (HsInt 1)))
+ ) plus_RDR (HsLit (HsInt 1)))
------------------
single_con_inRange
@@ -659,7 +659,7 @@ gen_Read_binds tycon
= map read_con (tyConDataCons tycon)
in
mk_easy_FunMonoBind tycon_loc readsPrec_RDR [a_Pat, b_Pat] [] (
- foldl1 append_Expr read_con_comprehensions
+ foldr1 append_Expr read_con_comprehensions
)
where
read_con data_con -- note: "b" is the string being "read"
@@ -683,7 +683,7 @@ gen_Read_binds tycon
= if nullary_con then -- must be False (parens are surely optional)
false_Expr
else -- parens depend on precedence...
- HsPar (OpApp a_Expr (HsVar gt_RDR) (HsLit (HsInt 9)))
+ HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt 9)))
in
HsApp (
readParen_Expr read_paren_arg $ HsPar $
@@ -747,7 +747,7 @@ gen_Show_binds tycon
([a_Pat, con_pat], show_con)
else
([a_Pat, con_pat],
- showParen_Expr (HsPar (OpApp a_Expr (HsVar ge_RDR) (HsLit (HsInt 10))))
+ showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt 10))))
(HsPar (nested_compose_Expr show_thingies)))
where
spacified [] = []
@@ -912,9 +912,9 @@ careful_compare_Case ty lt eq gt a b
compare_gen_Case compare_RDR lt eq gt a b
else -- we have to do something special for primitive things...
- HsIf (HsPar (OpApp a (HsVar relevant_eq_op) b))
+ HsIf (genOpApp a relevant_eq_op b)
eq
- (HsIf (HsPar (OpApp a (HsVar relevant_lt_op) b)) lt gt mkGeneratedSrcLoc)
+ (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc)
mkGeneratedSrcLoc
where
relevant_eq_op = assoc_ty_id eq_op_tbl ty
@@ -948,17 +948,17 @@ lt_op_tbl =
and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
-and_Expr a b = OpApp a (HsVar and_RDR) b
-append_Expr a b = OpApp a (HsVar append_RDR) b
+and_Expr a b = genOpApp a and_RDR b
+append_Expr a b = genOpApp a append_RDR b
-----------------------------------------------------------------------
eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
eq_Expr ty a b
= if not (isPrimType ty) then
- OpApp a (HsVar eq_RDR) b
+ genOpApp a eq_RDR b
else -- we have to do something special for primitive things...
- OpApp a (HsVar relevant_eq_op) b
+ genOpApp a relevant_eq_op b
where
relevant_eq_op = assoc_ty_id eq_op_tbl ty
\end{code}
@@ -981,7 +981,7 @@ cmp_tags_Expr :: RdrName -- Comparison op
-> RdrNameHsExpr
cmp_tags_Expr op a b true_case false_case
- = HsIf (HsPar (OpApp (HsVar a) (HsVar op) (HsVar b))) true_case false_case mkGeneratedSrcLoc
+ = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc
enum_from_to_Expr
:: RdrNameHsExpr -> RdrNameHsExpr
@@ -1008,6 +1008,13 @@ nested_compose_Expr (e:es)
parenify e@(HsVar _) = e
parenify e = HsPar e
+
+-- genOpApp wraps brackets round the operator application, so that the
+-- renamer won't subsequently try to re-associate it.
+-- For some reason the renamer doesn't reassociate it right, and I can't
+-- be bothered to find out why just now.
+
+genOpApp e1 op e2 = mkOpApp e1 op e2
\end{code}
\begin{code}
@@ -1050,26 +1057,4 @@ con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
con2tag_RDR tycon = varUnqual (SLIT("con2tag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
tag2con_RDR tycon = varUnqual (SLIT("tag2con_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
maxtag_RDR tycon = varUnqual (SLIT("maxtag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
-
-
-{- OLD, and wrong; the renamer doesn't like qualified names for locals.
-
-con2tag_RDR tycon
- = let (mod, nm) = modAndOcc tycon
- con2tag = SLIT("con2tag_") _APPEND_ occNameString nm _APPEND_ SLIT("#")
- in
- varQual (mod, con2tag)
-
-tag2con_RDR tycon
- = let (mod, nm) = modAndOcc tycon
- tag2con = SLIT("tag2con_") _APPEND_ occNameString nm _APPEND_ SLIT("#")
- in
- varQual (mod, tag2con)
-
-maxtag_RDR tycon
- = let (mod, nm) = modAndOcc tycon
- maxtag = SLIT("maxtag_") _APPEND_ occNameString nm _APPEND_ SLIT("#")
- in
- varQual (mod, maxtag)
--}
\end{code}
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 67681204949e1f8eb502a0be7a280e8715ee183e..a1662a025c16fae81f81887c92e796aa4b15547c 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -373,11 +373,11 @@ zonkExpr te ve (HsApp e1 e2)
zonkExpr te ve e2 `thenNF_Tc` \ new_e2 ->
returnNF_Tc (HsApp new_e1 new_e2)
-zonkExpr te ve (OpApp e1 op e2)
+zonkExpr te ve (OpApp e1 op fixity e2)
= zonkExpr te ve e1 `thenNF_Tc` \ new_e1 ->
zonkExpr te ve op `thenNF_Tc` \ new_op ->
zonkExpr te ve e2 `thenNF_Tc` \ new_e2 ->
- returnNF_Tc (OpApp new_e1 new_op new_e2)
+ returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
zonkExpr te ve (NegApp _ _) = panic "zonkExpr te ve:NegApp"
zonkExpr te ve (HsPar _) = panic "zonkExpr te ve:HsPar"
diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 102af84a1674553613da4fd95c9cd3bbae156d59..47b3e77298297a6385385aeadd5c515b1013f832 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -11,7 +11,7 @@ module TcIfaceSig ( tcInterfaceSigs ) where
IMP_Ubiq()
import TcMonad
-import TcMonoType ( tcHsType )
+import TcMonoType ( tcHsType, tcHsTypeKind )
import TcEnv ( tcLookupGlobalValue, tcExtendTyVarEnv, tcExtendGlobalValEnv,
tcLookupTyConByKey, tcLookupGlobalValueMaybe, tcLookupLocalValue
)
@@ -218,7 +218,7 @@ tcCoreExpr (UfSCC cc expr)
tcCoreExpr(UfCoerce coercion ty body)
= tcCoercion coercion `thenTc` \ coercion' ->
- tcHsType ty `thenTc` \ ty' ->
+ tcHsTypeKind ty `thenTc` \ (_,ty') ->
tcCoreExpr body `thenTc` \ body' ->
returnTc (Coerce coercion' ty' body')
@@ -284,7 +284,7 @@ tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders
\begin{code}
tcCoreArg (UfVarArg v) = tcVar v `thenTc` \ v' -> returnTc (VarArg v')
-tcCoreArg (UfTyArg ty) = tcHsType ty `thenTc` \ ty' -> returnTc (TyArg ty')
+tcCoreArg (UfTyArg ty) = tcHsTypeKind ty `thenTc` \ (_,ty') -> returnTc (TyArg ty')
tcCoreArg (UfLitArg lit) = returnTc (LitArg lit)
tcCoreArg (UfUsageArg u) = error "tcCoreArg: usage"
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 63b280d8c3ab73b275b3da5a1ddbbb2c6a36f031..c129ae5cf7475c6e5b893c7392823f38de804c95 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -20,7 +20,7 @@ import HsSyn ( HsDecl(..), InstDecl(..), TyDecl, ClassDecl, DefaultDecl,
SpecInstSig(..), HsBinds(..), Bind(..),
MonoBinds(..), GRHSsAndBinds, Match,
InPat(..), OutPat(..), HsExpr(..), HsLit(..),
- Stmt, Qualifier, ArithSeqInfo, Fake,
+ Stmt, Qualifier, ArithSeqInfo, Fake, Fixity,
HsType(..), HsTyVar )
import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds),
SYN_IE(RenamedInstDecl), SYN_IE(RenamedFixityDecl),
diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 09140f16986e3438eeb3a541728cf2ef4d3341be..a5c3197f5ac008def5ef860d5c9f126fa775dd76 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -31,15 +31,19 @@ import TcBinds ( tcBindsAndThen )
import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults )
import TcEnv ( tcExtendGlobalValEnv, getEnv_LocalIds,
- getEnv_TyCons, getEnv_Classes,
- tcLookupLocalValueByKey, tcLookupTyConByKey )
+ getEnv_TyCons, getEnv_Classes, tcLookupLocalValue,
+ tcLookupLocalValueByKey, tcLookupTyCon,
+ tcLookupGlobalValueByKeyMaybe )
import SpecEnv ( SpecEnv )
+import TcExpr ( tcId )
import TcIfaceSig ( tcInterfaceSigs )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
import TcInstUtil ( buildInstanceEnvs, InstInfo )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls1 )
import TcTyDecls ( mkDataBinds )
+import TcType ( SYN_IE(TcType), tcInstType )
+import TcKind ( TcKind )
import RnMonad ( RnNameSupply(..) )
import Bag ( listToBag )
@@ -47,17 +51,21 @@ import Class ( GenClass, classSelIds )
import ErrUtils ( SYN_IE(Warning), SYN_IE(Error) )
import Id ( idType, GenId, SYN_IE(IdEnv), nullIdEnv )
import Maybes ( catMaybes )
-import Name ( isLocallyDefined )
+import Name ( Name, isLocallyDefined, pprModule )
import Pretty
-import TyCon ( TyCon )
-import Type ( applyTyCon )
-import TysWiredIn ( unitTy, mkPrimIoTy )
-import TyVar ( SYN_IE(TyVarEnv), nullTyVarEnv )
+import TyCon ( TyCon, isSynTyCon )
+import Type ( applyTyCon, mkSynTy )
+import PprType ( GenType, GenTyVar )
+import TysWiredIn ( unitTy )
+import PrelMods ( gHC_MAIN, mAIN )
+import PrelInfo ( main_NAME, mainPrimIO_NAME, ioTyCon_NAME, primIoTyCon_NAME )
+import TyVar ( GenTyVar, SYN_IE(TyVarEnv), nullTyVarEnv )
import Unify ( unifyTauTy )
import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly,
filterUFM, eltsUFM )
-import Unique ( iOTyConKey )
+import Unique ( Unique )
import Util
+import Bag ( Bag, isEmptyBag )
import FiniteMap ( emptyFM, FiniteMap )
tycon_specs = emptyFM
@@ -200,6 +208,7 @@ tcModule rn_name_supply
-- trace "tc8" $
tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
+ tcCheckMainSig mod_name `thenTc_`
tcGetEnv `thenNF_Tc` \ env ->
returnTc ( (EmptyBinds, (inst_binds, cls_binds, env)),
lie_instdecls `plusLIE` lie_clasdecls,
@@ -216,6 +225,7 @@ tcModule rn_name_supply
-- trace "tc9" $
tcSimplifyTop lie_alldecls `thenTc` \ const_insts ->
+
-- Backsubstitution. Monomorphic top-level decls may have
-- been instantiated by subsequent decls, and the final
-- simplification step may have instantiated some
@@ -254,3 +264,56 @@ tcModule rn_name_supply
get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
\end{code}
+
+
+\begin{code}
+tcCheckMainSig mod_name
+ | not is_main && not is_ghc_main
+ = returnTc () -- A non-main module
+
+ | otherwise
+ = -- Check that main is defined
+ tcLookupTyCon tycon_name `thenTc` \ (_,_,tycon) ->
+ tcLookupLocalValue main_name `thenNF_Tc` \ maybe_main_id ->
+ case maybe_main_id of {
+ Nothing -> failTc (noMainErr mod_name main_name);
+ Just main_id ->
+
+ -- Check that it has the right type (or a more general one)
+ let
+ expected_ty | isSynTyCon tycon = mkSynTy tycon [unitTy]
+ | otherwise = applyTyCon tycon [unitTy]
+ -- This is bizarre. There ought to be a suitable function in Type.lhs!
+ in
+ tcInstType [] expected_ty `thenNF_Tc` \ expected_tau ->
+ tcId main_name `thenNF_Tc` \ (_, lie, main_tau) ->
+ tcSetErrCtxt (mainTyCheckCtxt main_name) $
+ unifyTauTy expected_tau
+ main_tau `thenTc_`
+ checkTc (isEmptyBag lie) (mainTyMisMatch main_name expected_ty (idType main_id))
+ }
+ where
+ is_main = mod_name == mAIN
+ is_ghc_main = mod_name == gHC_MAIN
+
+ main_name | is_main = main_NAME
+ | otherwise = mainPrimIO_NAME
+
+ tycon_name | is_main = ioTyCon_NAME
+ | otherwise = primIoTyCon_NAME
+
+mainTyCheckCtxt main_name sty
+ = ppCat [ppStr "When checking that", ppr sty main_name, ppStr "has the required type"]
+
+noMainErr mod_name main_name sty
+ = ppCat [ppStr "Module", pprModule sty mod_name,
+ ppStr "must include a definition for", ppr sty main_name]
+
+mainTyMisMatch :: Name -> Type -> TcType s -> Error
+mainTyMisMatch main_name expected actual sty
+ = ppHang (ppCat [ppr sty main_name, ppStr "has the wrong type"])
+ 4 (ppAboves [
+ ppCat [ppStr "Expected:", ppr sty expected],
+ ppCat [ppStr "Inferred:", ppr sty actual]
+ ])
+\end{code}
diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 1a5f05514f700f3450707fcd2566be69f787fb0c..db3060e7503b0d577263b99db3d4f7c5c5690bb2 100644
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -11,7 +11,7 @@ module TcPat ( tcPat ) where
IMP_Ubiq(){-uitous-}
import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
- Match, HsBinds, Qualifier, HsType,
+ Match, HsBinds, Qualifier, HsType, Fixity,
ArithSeqInfo, Stmt, Fake )
import RnHsSyn ( SYN_IE(RenamedPat) )
import TcHsSyn ( SYN_IE(TcPat), TcIdOcc(..) )
@@ -174,7 +174,7 @@ tcPat pat_in@(ConPatIn name pats)
lie,
data_ty)
-tcPat pat_in@(ConOpPatIn pat1 op pat2) -- in binary-op form...
+tcPat pat_in@(ConOpPatIn pat1 op _ pat2) -- in binary-op form...
= tcPat pat1 `thenTc` \ (pat1', lie1, ty1) ->
tcPat pat2 `thenTc` \ (pat2', lie2, ty2) ->
diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs
index 93f04cd545449d805f9f335d4cfdc2ebe5c6cff8..a589499cca79b61f7660eb2935cf41c2ba1784ff 100644
--- a/ghc/compiler/typecheck/TcSimplify.lhs
+++ b/ghc/compiler/typecheck/TcSimplify.lhs
@@ -15,7 +15,7 @@ module TcSimplify (
IMP_Ubiq()
import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit,
- Match, HsBinds, Qualifier, HsType, ArithSeqInfo,
+ Match, HsBinds, Qualifier, HsType, ArithSeqInfo, Fixity,
GRHSsAndBinds, Stmt, Fake )
import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr), SYN_IE(TcMonoBinds) )
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index 960e2e54826d6e63fef5011fd9c8fa41006f7cdb..00f16116e424a1e81e9f327002fa13a488f011df 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -17,7 +17,7 @@ IMP_Ubiq(){-uitous-}
import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..),
Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..),
HsBinds(..), HsLit, Stmt, Qualifier, ArithSeqInfo,
- HsType, Fake, InPat, HsTyVar,
+ HsType, Fake, InPat, HsTyVar, Fixity,
Bind(..), MonoBinds(..), Sig
)
import HsTypes ( getTyVarName )
diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs
index aef320822a43391f6ee420b0551d0dbb38040b74..a0adc7dc8f677853cec82275b3b7ac5f6c3c8009 100644
--- a/ghc/compiler/types/PprType.lhs
+++ b/ghc/compiler/types/PprType.lhs
@@ -291,7 +291,8 @@ We print type-variable binders with their kinds in interface files.
\begin{code}
pprTyVarBndr sty@PprInterface tyvar@(TyVar uniq kind name usage)
| not (isBoxedTypeKind kind)
- = ppBesides [pprGenTyVar sty tyvar, ppStr "::", pprParendKind kind]
+ = ppBesides [pprGenTyVar sty tyvar, ppStr " :: ", pprParendKind kind]
+ -- See comments with ppDcolon in PprCore.lhs
pprTyVarBndr sty tyvar = pprGenTyVar sty tyvar
\end{code}
diff --git a/ghc/driver/ghc-iface.lprl b/ghc/driver/ghc-iface.lprl
index 7c6d01690745ff8de7e7233bb790cfb7355bc8cf..4fa4b8a3686773eb6d05d627b4618f44fcf818e6 100644
--- a/ghc/driver/ghc-iface.lprl
+++ b/ghc/driver/ghc-iface.lprl
@@ -22,14 +22,15 @@ sub postprocessHiFile {
$going_interactive) = @_;
local($new_hi) = "$Tmp_prefix.hi-new";
+ local($show_hi_diffs) = $HiDiff_flag && ! $HiOnStdout && ! $going_interactive && -f $hifile_target;
# print STDERR "*** New hi file follows...\n";
# print STDERR `$Cat $hsc_hi`;
- &constructNewHiFile($hsc_hi, $hifile_target, $new_hi);
+ &constructNewHiFile($hsc_hi, $hifile_target, $new_hi, $show_hi_diffs);
# run diff if they asked for it
- if ($HiDiff_flag && ! $HiOnStdout && ! $going_interactive && -f $hifile_target) {
+ if ($show_hi_diffs) {
if ( $HiDiff_flag eq 'usages' ) {
# lots of near-useless info; but if you want it...
&run_something("$Cmp -s $hifile_target $new_hi || $Diff $hifile_target $new_hi 1>&2 || exit 0",
@@ -90,7 +91,8 @@ sub deUsagifyHi {
sub constructNewHiFile {
local($hsc_hi, # The iface info produced by hsc.
$hifile_target, # Pre-existing .hi filename (if it exists)
- $new_hi) = @_; # Filename for new one
+ $new_hi, # Filename for new one
+ $show_hi_diffs) = @_;
&readHiFile('old',$hifile_target) unless $HiHasBeenRead{'old'} == 1;
&readHiFile('new',$hsc_hi) unless $HiHasBeenRead{'new'} == 1;
@@ -128,7 +130,7 @@ sub constructNewHiFile {
print NEWHI "_declarations_\n";
foreach $v (@decl_names) {
- &printNewItemVersion(NEWHI, $v, $new_module_version); # Print new version number
+ &printNewItemVersion(NEWHI, $v, $new_module_version, $show_hi_diffs); # Print new version number
print NEWHI $Decl{"new:$v"}; # Print the new decl itself
}
@@ -287,24 +289,24 @@ sub mv_change {
}
sub printNewItemVersion {
- local($hifile, $item, $mod_version) = @_;
+ local($hifile, $item, $mod_version, $show_hi_diffs) = @_;
local($idecl) = $Decl{"new:$item"};
if (! defined($Decl{"old:$item"})) { # Old decl doesn't exist
- print STDERR "new: $item\n";
+ if ($show_hi_diffs) {print STDERR "new: $item\n";}
print $hifile "$mod_version "; # Use module version
} elsif ($idecl ne $Decl{"old:$item"}) { # Old decl differs from new decl
local($odecl) = $Decl{"old:$item"};
-# print STDERR "changed: $item\nOld: $odecl\nNew: $idecl\n";
+ if ($show_hi_diffs) {print STDERR "changed: $item\nOld: $odecl\nNew: $idecl\n";}
print $hifile "$mod_version "; # Use module version
} elsif (! defined($OldVersion{"$item"}) ) {
- print STDERR "$item: no old version?!\n";
+ if ($show_hi_diffs) {print STDERR "$item: no old version?!\n";}
print $hifile "$mod_version "; # Use module version
} else { # Identical decls, so use old version number
- print STDERR "$item: unchanged\n";
+ if ($show_hi_diffs) {print STDERR "$item: unchanged\n";}
print $hifile $OldVersion{"$item"}, " ";
}
return;
diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl
index 71124c037880628470e3f7787817acb1ad85ec33..628233df43ffbde8430e9d4b0128932f891ec587 100644
--- a/ghc/driver/ghc.lprl
+++ b/ghc/driver/ghc.lprl
@@ -207,7 +207,7 @@ which are filled in later, using these.
These are the default values, which may be changed by user flags.
\begin{code}
$Oopt_UnfoldingUseThreshold = '-funfolding-use-threshold8';
-$Oopt_MaxSimplifierIterations = '-fmax-simplifier-iterations4';
+$Oopt_MaxSimplifierIterations = '-fmax-simplifier-iterations5';
$Oopt_PedanticBottoms = '-fpedantic-bottoms'; # ON by default
$Oopt_MonadEtaExpansion = '';
$Oopt_FinalStgProfilingMassage = '';
@@ -2170,7 +2170,7 @@ sub runHscAndProcessInterfaces {
$i_atime,$i_mtime,$i_ctime,$i_blksize,$i_blocks) = stat($ifile);
if ( ! -f $ofile_target ) {
- print STDERR "$Pgm:compile:Output file $ofile_target doesn't exist\n";
+# print STDERR "$Pgm:compile:Output file $ofile_target doesn't exist\n";
$source_unchanged = 0;
}
@@ -2178,7 +2178,7 @@ sub runHscAndProcessInterfaces {
$o_atime,$o_mtime,$o_ctime,$o_blksize,$o_blocks) = stat(_); # stat info from -f test
if ( ! -f $hifile_target ) {
- print STDERR "$Pgm:compile:Interface file $hifile_target doesn't exist\n";
+# print STDERR "$Pgm:compile:Interface file $hifile_target doesn't exist\n";
$source_unchanged = 0;
}
@@ -2186,7 +2186,7 @@ sub runHscAndProcessInterfaces {
$hi_atime,$hi_mtime,$hi_ctime,$hi_blksize,$hi_blocks) = stat(_); # stat info from -f test
if ($i_mtime > $o_mtime) {
- print STDERR "$Pgm:recompile:Input file $ifile newer than $ofile_target\n";
+# print STDERR "$Pgm:recompile:Input file $ifile newer than $ofile_target\n";
$source_unchanged = 0;
}
diff --git a/ghc/lib/MODULES b/ghc/lib/MODULES
index fab3e1dbc22b1ea48519013055c254103ee5dde5..24d4a5dd666f39b6d8af5b15dcd93394df49863f 100644
--- a/ghc/lib/MODULES
+++ b/ghc/lib/MODULES
@@ -1,26 +1,2 @@
# Modules that the user is allowed to mention.
# 'mkdependHS' consults this list.
-Array
-Channel
-ChannelVar
-Char
-Complex
-Concurrent
-Directory
-GHCbase
-GHCio
-GHCmain
-GHCps
-IO
-Ix
-List
-Maybe
-Merge
-Monad
-Parallel
-Prelude
-PreludeGlaST
-Ratio
-SampleVar
-Semaphore
-System
diff --git a/ghc/lib/Makefile.libHS b/ghc/lib/Makefile.libHS
index d112d45cd231cbd22b1b6b9e941d287c64fd40f6..55e3561341106aba7a039e9a17517a55f21fa7b4 100644
--- a/ghc/lib/Makefile.libHS
+++ b/ghc/lib/Makefile.libHS
@@ -1,5 +1,5 @@
#-----------------------------------------------------------------------------
-# $Id: Makefile.libHS,v 1.6 1997/01/07 13:20:35 simonm Exp $
+# $Id: Makefile.libHS,v 1.7 1997/01/18 10:04:27 simonpj Exp $
TOP = ../..
include $(TOP)/ghc/mk/ghc.mk
@@ -42,12 +42,12 @@ ifneq ($(GhcWithHscBuiltViaC),YES)
$(LIB_GHC) $($*_flags) $*.lhs
%.$(suffix)_o : %.lhs
- $(LIB_GHC) $(GHC_OPTS_$(suffix)) $($*_flags) $*.hs
+ $(LIB_GHC) $(GHC_OPTS_$(suffix)) $($*_flags) $*.lhs
else # $(GhcWithHscBuiltViaC) == YES
%.$(suffix)_o : %.hc
- $(LIB_GHC) $(GHC_OPTS_$(suffix)) $($*_flags) $*.hs
+ $(LIB_GHC) $(GHC_OPTS_$(suffix)) $($*_flags) $*.hc
endif
#-----------------------------------------------------------------------------
@@ -59,8 +59,12 @@ else
ARCHIVE = libHS_$(suffix).a
endif
-SRCS = $(wildcard prelude/*.hs required/*.hs concurrent/*.hs)
-LIBOBJS = $(SRCS:.hs=.$(suffix)_o)
+SRCS = $(wildcard ghc/*.lhs glaExts/*.lhs required/*.lhs concurrent/*.lhs)
+ifeq ($(suffix), norm)
+LIBOBJS = $(SRCS:.lhs=.o)
+else
+LIBOBJS = $(SRCS:.lhs=.$(suffix)_o)
+endif
DESTDIR = $(INSTLIBDIR_GHC)
include $(TOP)/mk/lib.mk
@@ -75,6 +79,10 @@ ghc/PackedString_flags = '-\#include"cbits/stgio.h"' -monly-3-regs
required/Directory_flags = '-\#include"cbits/stgio.h"' -monly-3-regs
required/System_flags = '-\#include"cbits/stgio.h"'
+concurrent/Merge_flags = -iconcurrent
+concurrent/Parallel_flags = -fglasgow-exts
+concurrent/Concurrent_flags = -iconcurrent
+
ghc/ArrBase_flags = '-fno-implicit-prelude'
ghc/IOBase_flags = '-fno-implicit-prelude'
ghc/IOHandle_flags = '-fno-implicit-prelude'
@@ -96,9 +104,6 @@ required/Maybe_flags = '-fno-implicit-prelude'
required/Monad_flags = '-fno-implicit-prelude'
required/Ratio_flags = '-fno-implicit-prelude'
-concurrent/Merge_flags = -iconcurrent
-concurrent/Parallel_flags = -fglasgow-exts
-concurrent/Concurrent_flags = -iconcurrent
#-----------------------------------------------------------------------------
# Depend and install stuff
@@ -111,13 +116,19 @@ MKDEPENDHS_OPTS += $(foreach way,$(WAY_SUFFIXES),-s .$(way))
depend :: $(SRCS)
$(MKDEPENDHS) $(MKDEPENDHSFLAGS) -- $(GHCFLAGS) -- -f .depend $(SRCS)
+# Copy the crucial IOBase hi file over
+hiboot ::
+ cp ghc/IOBase.hi-boot ghc/IOBase.hi
+ cp ghc/Main.hi-boot ghc/Main.hi
+ cp ghc/GHC.hi-boot ghc/GHC.hi
+
#-----------------------------------------------------------------------------
# install hi files
ifeq ($(suffix),norm)
-HI_FILES = $(SRCS:.hs=.hi)
+HI_FILES = $(SRCS:.lhs=.hi)
else
-HI_FILES = $(SRCS:.hs=.$(suffix)_hi)
+HI_FILES = $(SRCS:.lhs=.$(suffix)_hi)
endif
install :: $(HI_FILES)
diff --git a/ghc/lib/concurrent/Channel.lhs b/ghc/lib/concurrent/Channel.lhs
index 2a947bb72704abfd44c1e1a9bc1e50af89219ebe..2d0c93550ce676a68862a25cf88e70644c6bb983 100644
--- a/ghc/lib/concurrent/Channel.lhs
+++ b/ghc/lib/concurrent/Channel.lhs
@@ -26,6 +26,7 @@ module Channel
) where
+import Prelude
import IOBase ( IO(..) ) -- Suspicious!
import ConcBase
import STBase
diff --git a/ghc/lib/concurrent/ChannelVar.lhs b/ghc/lib/concurrent/ChannelVar.lhs
index cf3b5c90f5292a68d081c38403bf18d8cdd7e094..ee21c87e12d678a7dab1fc435cef799884cd3154 100644
--- a/ghc/lib/concurrent/ChannelVar.lhs
+++ b/ghc/lib/concurrent/ChannelVar.lhs
@@ -18,6 +18,7 @@ module ChannelVar
) where
+import Prelude
import ConcBase
\end{code}
diff --git a/ghc/lib/ghc/ConcBase.lhs b/ghc/lib/ghc/ConcBase.lhs
index 9969dbc716216d2f3bcbd95c00c6a4ad8346acdf..3a5327163c5bdec86326a3feee9c2f25e1911b82 100644
--- a/ghc/lib/ghc/ConcBase.lhs
+++ b/ghc/lib/ghc/ConcBase.lhs
@@ -19,6 +19,7 @@ module ConcBase(
MVar, newMVar, newEmptyMVar, takeMVar, putMVar, readMVar, swapMVar
) where
+import Prelude
import STBase ( PrimIO(..), ST(..), State(..), StateAndPtr#(..) )
import IOBase ( IO(..) )
import GHCerr ( parError )
diff --git a/ghc/lib/ghc/GHC.hi b/ghc/lib/ghc/GHC.hi-boot
similarity index 100%
rename from ghc/lib/ghc/GHC.hi
rename to ghc/lib/ghc/GHC.hi-boot
diff --git a/ghc/lib/ghc/GHCerr.lhs b/ghc/lib/ghc/GHCerr.lhs
index bad972352a70302f3009713aa485f50e0b13a451..c0d508d6c02301e0dceba86be6dc1c88cec000f0 100644
--- a/ghc/lib/ghc/GHCerr.lhs
+++ b/ghc/lib/ghc/GHCerr.lhs
@@ -14,6 +14,7 @@ with what the typechecker figures out.
\begin{code}
module GHCerr where
+import Prelude
import IOBase
---------------------------------------------------------------
diff --git a/ghc/lib/ghc/GHCmain.lhs b/ghc/lib/ghc/GHCmain.lhs
index 88de160de51cd1dbaf1d2a115e5ad470a315b1e8..3926ba93dc5d0e709ed3627fedbbf091d506c8a9 100644
--- a/ghc/lib/ghc/GHCmain.lhs
+++ b/ghc/lib/ghc/GHCmain.lhs
@@ -5,6 +5,7 @@ This is the mainPrimIO that must be used for Haskell~1.3.
\begin{code}
module GHCmain( mainPrimIO ) where
+import Prelude
import qualified Main -- for type of "Main.main"
import IOBase
import STBase
diff --git a/ghc/lib/ghc/IOBase.hi-boot b/ghc/lib/ghc/IOBase.hi-boot
new file mode 100644
index 0000000000000000000000000000000000000000..002fe549dc1971edc537deca24aec2be1d4fe024
--- /dev/null
+++ b/ghc/lib/ghc/IOBase.hi-boot
@@ -0,0 +1,12 @@
+---------------------------------------------------------------------------
+-- IOBase.hi-boot
+--
+-- This hand-written interface file is the initial bootstrap version
+-- for IOBase.hi.
+-- It doesn't need to give "error" a type signature,
+-- because it's wired into the compiler
+---------------------------------------------------------------------------
+
+_interface_ IOBase 1
+_exports_
+IOBase error;
diff --git a/ghc/lib/ghc/Main.hi b/ghc/lib/ghc/Main.hi-boot
similarity index 92%
rename from ghc/lib/ghc/Main.hi
rename to ghc/lib/ghc/Main.hi-boot
index ff65f047ce781a46b8331958582181d31cbd022a..0358a0de22c3f5012794935cbd9a2d1ae7ebb88b 100644
--- a/ghc/lib/ghc/Main.hi
+++ b/ghc/lib/ghc/Main.hi-boot
@@ -10,4 +10,4 @@ _interface_ Main 1
_exports_
Main main ;
_declarations_
-1 main :: IOBase.IO PrelBase.();
+1 main :: IOBase.IO PrelBase.();;
diff --git a/ghc/lib/ghc/PrelBase.lhs b/ghc/lib/ghc/PrelBase.lhs
index 601500af7a1e4f8658ffb67644b14fddd8677f09..e83a39180256619713e20088c5669570d310d32d 100644
--- a/ghc/lib/ghc/PrelBase.lhs
+++ b/ghc/lib/ghc/PrelBase.lhs
@@ -13,7 +13,7 @@ import {-# SOURCE #-} IOBase ( error )
import GHC
infixr 9 ., !!
-infixl 7 *, /
+infixl 7 *
infixl 6 +, -
infixr 5 ++, :
infix 4 ==, /=, <, <=, >=, >
diff --git a/ghc/lib/ghc/PrelNum.lhs b/ghc/lib/ghc/PrelNum.lhs
index bf16dc0824fde96c2559e4f1b86876369f1074fd..940a57b73a9cf6623a74f12bc4ef62d4d6873464 100644
--- a/ghc/lib/ghc/PrelNum.lhs
+++ b/ghc/lib/ghc/PrelNum.lhs
@@ -24,7 +24,7 @@ import PrelBase
import GHC
infixr 8 ^, ^^, **
-infixl 7 %, `quot`, `rem`, `div`, `mod`
+infixl 7 /, %, `quot`, `rem`, `div`, `mod`
\end{code}
diff --git a/ghc/lib/required/Complex.lhs b/ghc/lib/required/Complex.lhs
index fe66d2dcb9f17ade3ec85b9cf60efe82b92c1cfc..69e753e0c81b64cba0e37b2b2fd295151e293694 100644
--- a/ghc/lib/required/Complex.lhs
+++ b/ghc/lib/required/Complex.lhs
@@ -12,6 +12,7 @@ module Complex (
cis, polar, magnitude, phase
) where
+import Prelude
infix 6 :+
\end{code}
diff --git a/ghc/lib/required/Directory.lhs b/ghc/lib/required/Directory.lhs
index 3f8b365d35b59d643b9ffe6965fdd6b96c1c4245..20d05dd3d571fff8d21f6c950c5b33a34d110d1e 100644
--- a/ghc/lib/required/Directory.lhs
+++ b/ghc/lib/required/Directory.lhs
@@ -24,6 +24,7 @@ module Directory (
getCurrentDirectory, setCurrentDirectory
) where
+import Prelude
import Foreign
import IOBase
import STBase ( PrimIO )
diff --git a/ghc/lib/required/List.lhs b/ghc/lib/required/List.lhs
index e742b0eb6d8b78e1f5506dd38e9054ab6481fe16..026039332b6d2cd67b4a39f81079ad6e5904f576 100644
--- a/ghc/lib/required/List.lhs
+++ b/ghc/lib/required/List.lhs
@@ -20,6 +20,7 @@ module List (
union, intersect
) where
+import Prelude
\end{code}
%*********************************************************
diff --git a/ghc/lib/required/System.lhs b/ghc/lib/required/System.lhs
index 77d82a3eb2f7b625d4d2cc6687792e6865b4b55b..1bdaa1fe7c6c62e596608eed137c182e08c76b29 100644
--- a/ghc/lib/required/System.lhs
+++ b/ghc/lib/required/System.lhs
@@ -10,6 +10,7 @@ module System (
getArgs, getProgName, getEnv, system, exitWith
) where
+import Prelude
import Foreign ( Addr )
import IOBase ( IOError(..), thenIO_Prim, constructErrorAndFail )
import ArrBase ( indexAddrOffAddr )