liftTyConKey,
listTyConKey,
ltDataConKey,
+ mainKey, mainPrimIoKey,
monadClassKey,
monadPlusClassKey,
monadZeroClassKey,
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}
(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
\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}
= 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))
-- 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}
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),
= 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
= 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)
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 )
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)
\begin{code}
#include "HsVersions.h"
-module HsLit where
+module HsBasic where
IMP_Ubiq(){-uitous-}
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
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}
+
import IdInfo
import SpecEnv ( SpecEnv )
import HsCore ( UfExpr )
+import HsBasic ( Fixity )
-- others:
import Name ( pprSym, pprNonSym, getOccName, OccName )
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}
-
%************************************************************************
%* *
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}
-- friends:
import HsBinds ( HsBinds )
-import HsLit ( HsLit )
+import HsBasic ( HsLit, Fixity(..), FixityDirection(..) )
import HsMatches ( pprMatches, pprMatch, Match )
import HsTypes ( HsType )
| 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.
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])
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}
IMP_Ubiq()
-- friends:
-import HsLit ( HsLit )
+import HsBasic ( HsLit, Fixity )
IMPORT_DELOOPER(HsLoop) ( HsExpr )
-- others:
[InPat name]
| ConOpPatIn (InPat name)
name
+ Fixity -- c.f. OpApp in HsExpr
(InPat name)
-- We preserve prefix negation and parenthesis for the precedence parser.
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
\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}
EXP_MODULE(HsDecls) ,
EXP_MODULE(HsExpr) ,
EXP_MODULE(HsImpExp) ,
- EXP_MODULE(HsLit) ,
+ EXP_MODULE(HsBasic) ,
EXP_MODULE(HsMatches) ,
EXP_MODULE(HsPat) ,
EXP_MODULE(HsTypes)
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
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
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,
opt_GranMacros,
opt_Haskell_1_3,
opt_HiMap,
+ opt_HiSuffix,
opt_IgnoreIfacePragmas,
opt_IgnoreStrictnessPragmas,
opt_IrrefutableEverything,
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")
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")
= 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
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"
module PrelInfo (
-- finite maps for built-in things (for the renamer and typechecker):
- builtinNames, builtinKeys, derivingOccurrences,
+ builtinNames, derivingOccurrences,
SYN_IE(BuiltinNames),
maybeCharLikeTyCon, maybeIntLikeTyCon,
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
listToBag (map (getName.primOpName) allThePrimOps) `unionBags`
-- Other names with magic keys
- listToBag builtinKeys
+ listToBag knownKeyNames
\end{code}
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}
\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("/="))
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#"))
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}
%************************************************************************
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
primIoTyCon
= pcSynTyCon
- primIoTyConKey iO_BASE SLIT("PrimIO")
+ primIoTyConKey sT_BASE SLIT("PrimIO")
(mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind)
1 alpha_tyvar (mkPrimIoTy alphaTy)
\end{code}
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(..) )
',' : 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
= 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
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
------------
ifaceKeywordsFM :: FiniteMap String IfaceToken
ifaceKeywordsFM = listToFM [
- ("interface_", ITinterface)
+ ("/\\_", ITbiglam)
+ ,("@_", ITatsign)
+ ,("interface_", ITinterface)
,("usages_", ITusages)
,("versions_", ITversions)
,("exports_", ITexports)
,("A_", ITarity)
,("coerce_in_", ITcoerce_in)
,("coerce_out_", ITcoerce_out)
- ,("A_", ITarity)
- ,("A_", ITarity)
,("bot_", ITbottom)
,("integer_", ITinteger_lit)
,("rational_", ITrational_lit)
,("->", 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}
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]
(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)
dummyRdrVarName, dummyRdrTcName,
isUnqual, isQual,
showRdr, rdrNameOcc,
- cmpRdr
+ cmpRdr,
+ mkOpApp
) where
| 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}
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,
(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}
%************************************************************************
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 ->
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'"
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 ->
IMP_Ubiq(){-uitous-}
+import CmdLineOpts ( opt_IgnoreIfacePragmas )
+
import HsSyn -- quite a bit of stuff
import RdrHsSyn -- oodles of synonyms
import HsDecls ( HsIdInfo(..) )
{ 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 : { [] }
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
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
-- 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`
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
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))
unionUniqSets, unionManyUniqSets,
SYN_IE(UniqSet)
)
-import Util ( Ord3(..), removeDups, panic )
+import PprStyle ( PprStyle(..) )
+import Util ( Ord3(..), removeDups, panic, pprPanic, assertPanic )
\end{code}
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
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) ->
%* *
%************************************************************************
-@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}
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
= 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}
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
\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
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.
import Name
import Pretty
import PprStyle ( PprStyle(..) )
-import Util ( panic, pprTrace )
+import Util ( panic, pprTrace, assertPanic )
\end{code}
\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}
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
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
\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}
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
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}
IMP_Ubiq(){-uitous-}
-import CmdLineOpts ( opt_D_verbose_core2core,
+import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_simpl_iterations,
switchIsOn, SimplifierSwitch(..)
)
import CoreSyn
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
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
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,
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)"
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
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) )
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
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 )
tcExtendGlobalValEnv, tcExtendLocalValEnv,
tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey,
tcLookupGlobalValue, tcLookupGlobalValueByKey, tcLookupGlobalValueMaybe,
+ tcLookupGlobalValueByKeyMaybe,
newMonoIds, newLocalIds, newLocalId,
tcGetGlobalTyVars, tcExtendGlobalTyVars
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}
\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)
)
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
= 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:")
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(..) )
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}
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
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))))
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
= 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"
= 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 $
([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 [] = []
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
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}
-> 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
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}
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}
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"
IMP_Ubiq()
import TcMonad
-import TcMonoType ( tcHsType )
+import TcMonoType ( tcHsType, tcHsTypeKind )
import TcEnv ( tcLookupGlobalValue, tcExtendTyVarEnv, tcExtendGlobalValEnv,
tcLookupTyConByKey, tcLookupGlobalValueMaybe, tcLookupLocalValue
)
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')
\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"
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),
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 )
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
-- 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,
-- 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
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}
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(..) )
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) ->
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) )
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 )
\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}
$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",
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;
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
}
}
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;
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 = '';
$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;
}
$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;
}
$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;
}
# 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
#-----------------------------------------------------------------------------
-# $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
$(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
#-----------------------------------------------------------------------------
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
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'
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
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)
) where
+import Prelude
import IOBase ( IO(..) ) -- Suspicious!
import ConcBase
import STBase
) where
+import Prelude
import ConcBase
\end{code}
MVar, newMVar, newEmptyMVar, takeMVar, putMVar, readMVar, swapMVar
) where
+import Prelude
import STBase ( PrimIO(..), ST(..), State(..), StateAndPtr#(..) )
import IOBase ( IO(..) )
import GHCerr ( parError )
\begin{code}
module GHCerr where
+import Prelude
import IOBase
---------------------------------------------------------------
\begin{code}
module GHCmain( mainPrimIO ) where
+import Prelude
import qualified Main -- for type of "Main.main"
import IOBase
import STBase
--- /dev/null
+---------------------------------------------------------------------------
+-- 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;
_exports_
Main main ;
_declarations_
-1 main :: IOBase.IO PrelBase.();
+1 main :: IOBase.IO PrelBase.();;
import GHC
infixr 9 ., !!
-infixl 7 *, /
+infixl 7 *
infixl 6 +, -
infixr 5 ++, :
infix 4 ==, /=, <, <=, >=, >
import GHC
infixr 8 ^, ^^, **
-infixl 7 %, `quot`, `rem`, `div`, `mod`
+infixl 7 /, %, `quot`, `rem`, `div`, `mod`
\end{code}
cis, polar, magnitude, phase
) where
+import Prelude
infix 6 :+
\end{code}
getCurrentDirectory, setCurrentDirectory
) where
+import Prelude
import Foreign
import IOBase
import STBase ( PrimIO )
union, intersect
) where
+import Prelude
\end{code}
%*********************************************************
getArgs, getProgName, getEnv, system, exitWith
) where
+import Prelude
import Foreign ( Addr )
import IOBase ( IOError(..), thenIO_Prim, constructErrorAndFail )
import ArrBase ( indexAddrOffAddr )
projects / ghc-hetmet.git / commitdiff