import RnHsSyn
import RnMonad
import RnEnv
-import RnTypes ( rnHsTypeFVs )
-import RnHiFiles ( lookupFixityRn )
+import RnTypes ( rnHsTypeFVs, precParseErr, sectionPrecErr )
import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts )
import Literal ( inIntRange, inCharRange )
import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..),
- defaultFixity, negateFixity )
+ defaultFixity, negateFixity, compareFixity )
import PrelNames ( hasKey, assertIdKey,
eqClassName, foldrName, buildName, eqStringName,
cCallableClassName, cReturnableClassName,
replicatePName, mapPName, filterPName,
falseDataConName, trueDataConName, crossPName,
zipPName, lengthPName, indexPName, toPName,
- enumFromToPName, enumFromThenToPName )
+ enumFromToPName, enumFromThenToPName,
+ fromIntegerName, fromRationalName, minusName, negateName,
+ monadNames )
import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
floatPrimTyCon, doublePrimTyCon )
import TysWiredIn ( intTyCon )
-import Name ( NamedThing(..), mkSysLocalName, nameSrcLoc )
+import Name ( NamedThing(..), mkSystemName, nameSrcLoc )
import NameSet
+import UnicodeUtil ( stringToUtf8 )
import UniqFM ( isNullUFM )
import UniqSet ( emptyUniqSet )
import List ( intersectBy )
import ListSetOps ( removeDups )
import Outputable
+import FastString
\end{code}
= litFVs lit `thenRn` \ fvs ->
returnRn (LitPatIn lit, fvs)
-rnPat (NPatIn lit)
+rnPat (NPatIn lit mb_neg)
+ = rnOverLit lit `thenRn` \ (lit', fvs1) ->
+ (case mb_neg of
+ Nothing -> returnRn (Nothing, emptyFVs)
+ Just _ -> lookupSyntaxName negateName `thenRn` \ (neg, fvs) ->
+ returnRn (Just neg, fvs)
+ ) `thenRn` \ (mb_neg', fvs2) ->
+ returnRn (NPatIn lit' mb_neg',
+ fvs1 `plusFV` fvs2 `addOneFV` eqClassName)
+ -- Needed to find equality on pattern
+
+rnPat (NPlusKPatIn name lit _)
= rnOverLit lit `thenRn` \ (lit', fvs1) ->
- returnRn (NPatIn lit', fvs1 `addOneFV` eqClassName) -- Needed to find equality on pattern
-
-rnPat (NPlusKPatIn name lit minus)
- = rnOverLit lit `thenRn` \ (lit', fvs) ->
lookupBndrRn name `thenRn` \ name' ->
- lookupSyntaxName minus `thenRn` \ minus' ->
- returnRn (NPlusKPatIn name' lit' minus', fvs `addOneFV` ordClassName `addOneFV` minus')
+ lookupSyntaxName minusName `thenRn` \ (minus, fvs2) ->
+ returnRn (NPlusKPatIn name' lit' minus,
+ fvs1 `plusFV` fvs2 `addOneFV` ordClassName)
rnPat (LazyPatIn pat)
= rnPat pat `thenRn` \ (pat', fvs) ->
rnRpats rpats `thenRn` \ (rpats', fvs) ->
returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
-rnPat (TypePatIn name) =
- rnHsTypeFVs (text "type pattern") name `thenRn` \ (name', fvs) ->
+rnPat (TypePatIn name)
+ = rnHsTypeFVs (text "type pattern") name `thenRn` \ (name', fvs) ->
returnRn (TypePatIn name', fvs)
\end{code}
returnRn (final_e,
fv_e1 `plusFV` fv_op `plusFV` fv_e2)
-rnExpr (NegApp e neg_name)
+rnExpr (NegApp e _)
= rnExpr e `thenRn` \ (e', fv_e) ->
- lookupSyntaxName neg_name `thenRn` \ neg_name' ->
- mkNegAppRn e' neg_name' `thenRn` \ final_e ->
- returnRn (final_e, fv_e `addOneFV` neg_name')
+ lookupSyntaxName negateName `thenRn` \ (neg_name, fv_neg) ->
+ mkNegAppRn e' neg_name `thenRn` \ final_e ->
+ returnRn (final_e, fv_e `plusFV` fv_neg)
rnExpr (HsPar e)
= rnExpr e `thenRn` \ (e', fvs_e) ->
rnExpr expr `thenRn` \ (expr',fvExpr) ->
returnRn (HsLet binds' expr', fvExpr)
-rnExpr (HsWith expr binds)
- = rnExpr expr `thenRn` \ (expr',fvExpr) ->
+rnExpr (HsWith expr binds is_with)
+ = warnCheckRn (not is_with) withWarning `thenRn_`
+ rnExpr expr `thenRn` \ (expr',fvExpr) ->
rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
- returnRn (HsWith expr' binds', fvExpr `plusFV` fvBinds)
+ returnRn (HsWith expr' binds' is_with, fvExpr `plusFV` fvBinds)
-rnExpr e@(HsDo do_or_lc stmts src_loc)
+rnExpr e@(HsDo do_or_lc stmts _ ty src_loc)
= pushSrcLocRn src_loc $
rnStmts stmts `thenRn` \ ((_, stmts'), fvs) ->
- -- check the statement list ends in an expression
+
+ -- Check the statement list ends in an expression
case last stmts' of {
ResultStmt _ _ -> returnRn () ;
_ -> addErrRn (doStmtListErr e)
} `thenRn_`
- returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs)
+
+ -- Generate the rebindable syntax for the monad
+ (case do_or_lc of
+ DoExpr -> mapAndUnzipRn lookupSyntaxName monadNames
+ other -> returnRn ([], [])
+ ) `thenRn` \ (monad_names', monad_fvs) ->
+
+ returnRn (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc,
+ fvs `plusFV` implicit_fvs `plusFV` plusFVs monad_fvs)
where
implicit_fvs = case do_or_lc of
PArrComp -> mkFVs [replicatePName, mapPName, filterPName,
falseDataConName, trueDataConName, crossPName,
zipPName]
- _ -> mkFVs [foldrName, buildName, monadClassName]
+ ListComp -> mkFVs [foldrName, buildName]
+ other -> emptyFVs
+ -- monadClassName pulls in the standard names
-- Monad stuff should not be necessary for a list comprehension
-- but the typechecker looks up the bind and return Ids anyway
-- Oh well.
= rnHsTypeFVs doc a `thenRn` \ (t, fvT) ->
returnRn (HsType t, fvT)
where
- doc = text "renaming a type pattern"
+ doc = text "in a type argument"
rnExpr (ArithSeqIn seq)
= rn_seq seq `thenRn` \ (new_seq, fvs) ->
(pp_arg_op, arg_fix) section)
\end{code}
-Consider
-\begin{verbatim}
- a `op1` b `op2` c
-\end{verbatim}
-@(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 `compare` 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}
%************************************************************************
%* *
litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear
-- in post-typechecker translations
-rnOverLit (HsIntegral i from_integer_name)
- = lookupSyntaxName from_integer_name `thenRn` \ from_integer_name' ->
+rnOverLit (HsIntegral i _)
+ = lookupSyntaxName fromIntegerName `thenRn` \ (from_integer_name, fvs) ->
if inIntRange i then
- returnRn (HsIntegral i from_integer_name', unitFV from_integer_name')
+ returnRn (HsIntegral i from_integer_name, fvs)
else let
- fvs = mkFVs [plusIntegerName, timesIntegerName]
+ extra_fvs = mkFVs [plusIntegerName, timesIntegerName]
-- Big integer literals are built, using + and *,
-- out of small integers (DsUtils.mkIntegerLit)
-- [NB: plusInteger, timesInteger aren't rebindable...
-- they are used to construct the argument to fromInteger,
-- which is the rebindable one.]
in
- returnRn (HsIntegral i from_integer_name', fvs `addOneFV` from_integer_name')
+ returnRn (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs)
-rnOverLit (HsFractional i from_rat_name)
- = lookupSyntaxName from_rat_name `thenRn` \ from_rat_name' ->
+rnOverLit (HsFractional i _)
+ = lookupSyntaxName fromRationalName `thenRn` \ (from_rat_name, fvs) ->
let
- fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]
+ extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName]
-- We have to make sure that the Ratio type is imported with
-- its constructor, because literals of type Ratio t are
-- built with that constructor.
-- The Rational type is needed too, but that will come in
- -- when fractionalClass does.
+ -- as part of the type for fromRational.
-- The plus/times integer operations may be needed to construct the numerator
-- and denominator (see DsUtils.mkIntegerLit)
in
- returnRn (HsFractional i from_rat_name', fvs `addOneFV` from_rat_name')
+ returnRn (HsFractional i from_rat_name, fvs `plusFV` extra_fvs)
\end{code}
%************************************************************************
if opt_IgnoreAsserts then
getUniqRn `thenRn` \ uniq ->
let
- vname = mkSysLocalName uniq SLIT("v")
+ vname = mkSystemName uniq FSLIT("v")
expr = HsLam ignorePredMatch
loc = nameSrcLoc vname
ignorePredMatch = mkSimpleMatch [WildPatIn, VarPatIn vname] (HsVar vname) placeHolderType loc
let
expr =
HsApp (HsVar name)
- (HsLit (HsString (_PK_ (showSDoc (ppr sloc)))))
-
+ (HsLit (HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))))
in
returnRn (expr, unitFV name)
-
\end{code}
%************************************************************************
\begin{code}
ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name
-ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
pp_prefix_minus = ptext SLIT("prefix `-'")
dupFieldErr str (dup:rest)
quotes (ppr dup),
ptext SLIT("in record"), text str]
-precParseErr op1 op2
- = hang (ptext SLIT("precedence parsing error"))
- 4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"),
- ppr_opfix op2,
- ptext SLIT("in the same infix expression")])
-
-sectionPrecErr op arg_op section
- = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
- nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
- nest 4 (ptext SLIT("in the section:") <+> quotes (ppr section))]
-
nonStdGuardErr guard
= hang (ptext
SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
bogusCharError c
= ptext SLIT("character literal out of range: '\\") <> int c <> char '\''
+
+withWarning
+ = sep [quotes (ptext SLIT("with")),
+ ptext SLIT("is deprecated, use"),
+ quotes (ptext SLIT("let")),
+ ptext SLIT("instead")]
\end{code}
projects / ghc-hetmet.git / blobdiff