#include "HsVersions.h"
import {-# SOURCE #-} RnBinds ( rnBinds )
-import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType )
+import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsPolyType, rnHsType )
import HsSyn
import RdrHsSyn
import RnEnv
import RnIfaces ( lookupFixity )
import CmdLineOpts ( opt_GlasgowExts, opt_IgnoreAsserts )
-import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity )
+import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity, negatePrecedence )
import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR,
ccallableClass_RDR, creturnableClass_RDR,
monadClass_RDR, enumClass_RDR, ordClass_RDR,
rnPat (SigPatIn pat ty)
| opt_GlasgowExts
= rnPat pat `thenRn` \ (pat', fvs1) ->
- rnHsType doc ty `thenRn` \ (ty', fvs2) ->
+ rnHsPolyType doc ty `thenRn` \ (ty', fvs2) ->
returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
| otherwise
rnPat pat `thenRn` \ (pat', fvs) ->
returnRn (NegPatIn pat', fvs)
where
- valid_neg_pat (LitPatIn (HsInt _)) = True
- valid_neg_pat (LitPatIn (HsFrac _)) = True
- valid_neg_pat _ = False
+ valid_neg_pat (LitPatIn (HsInt _)) = True
+ valid_neg_pat (LitPatIn (HsIntPrim _)) = True
+ valid_neg_pat (LitPatIn (HsFrac _)) = True
+ valid_neg_pat (LitPatIn (HsFloatPrim _)) = True
+ valid_neg_pat (LitPatIn (HsDoublePrim _)) = True
+ valid_neg_pat _ = False
rnPat (ParPatIn pat)
= rnPat pat `thenRn` \ (pat', fvs) ->
returnRn (final_e,
fv_e1 `plusFV` fv_op `plusFV` fv_e2)
+-- constant-fold some negate applications on unboxed literals. Since
+-- negate is a polymorphic function, we have to do these here.
+rnExpr (NegApp (HsLit (HsIntPrim i)) _) = rnExpr (HsLit (HsIntPrim (-i)))
+rnExpr (NegApp (HsLit (HsFloatPrim i)) _) = rnExpr (HsLit (HsFloatPrim (-i)))
+rnExpr (NegApp (HsLit (HsDoublePrim i)) _) = rnExpr (HsLit (HsDoublePrim (-i)))
+
rnExpr (NegApp e n)
= rnExpr e `thenRn` \ (e', fv_e) ->
lookupImplicitOccRn negate_RDR `thenRn` \ neg ->
returnRn (CCall fun args' may_gc is_casm fake_result_ty,
fvs_args `addOneFV` cc `addOneFV` cr `addOneFV` io)
-rnExpr (HsSCC label expr)
+rnExpr (HsSCC lbl expr)
= rnExpr expr `thenRn` \ (expr', fvs_expr) ->
- returnRn (HsSCC label expr', fvs_expr)
+ returnRn (HsSCC lbl expr', fvs_expr)
rnExpr (HsCase expr ms src_loc)
= pushSrcLocRn src_loc $
rnExpr expr `thenRn` \ (expr',fvExpr) ->
returnRn (HsLet binds' expr', fvExpr)
-rnExpr (HsDo do_or_lc stmts src_loc)
+rnExpr e@(HsDo do_or_lc stmts src_loc)
= pushSrcLocRn src_loc $
lookupImplicitOccRn monadClass_RDR `thenRn` \ monad ->
rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) ->
+ -- check the statement list ends in an expression
+ case last stmts' of {
+ ExprStmt _ _ -> returnRn () ;
+ ReturnStmt _ -> returnRn () ; -- for list comprehensions
+ _ -> addErrRn (doStmtListErr e)
+ } `thenRn_`
returnRn (HsDo do_or_lc stmts' src_loc, fvs `addOneFV` monad)
rnExpr (ExplicitList exps)
plusFVs [fvExpr1, fvExpr2, fvExpr3])
\end{code}
+These three are pattern syntax appearing in expressions.
+Since all the symbols are reservedops we can simply reject them.
+We return a (bogus) EWildPat in each case.
+
+\begin{code}
+rnExpr e@EWildPat = addErrRn (patSynErr e) `thenRn_`
+ returnRn (EWildPat, emptyFVs)
+
+rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e) `thenRn_`
+ returnRn (EWildPat, emptyFVs)
+
+rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_`
+ returnRn (EWildPat, emptyFVs)
+\end{code}
+
%************************************************************************
%* *
\subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
Furthermore, the second argument is guaranteed not to be another
operator application. Why? Because the parser parses all
-operator appications left-associatively.
+operator appications left-associatively, EXCEPT negation, which
+we need to handle specially.
\begin{code}
-mkOpAppRn :: RenamedHsExpr -> RenamedHsExpr -> Fixity -> RenamedHsExpr
+mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged
+ -> RenamedHsExpr -> Fixity -- Operator and fixity
+ -> RenamedHsExpr -- Right operand (not an OpApp, but might
+ -- be a NegApp)
-> RnMS RenamedHsExpr
-mkOpAppRn e1@(OpApp e11 op1 fix1 e12)
- op2 fix2 e2
+---------------------------
+-- (e11 `op1` e12) `op2` e2
+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
+ | associate_right
= mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e ->
returnRn (OpApp e11 op1 fix1 new_e)
where
- (nofix_error, rearrange_me) = compareFixity fix1 fix2
+ (nofix_error, associate_right) = compareFixity fix1 fix2
-mkOpAppRn e1@(NegApp neg_arg neg_op)
- op2
- fix2@(Fixity prec2 dir2)
- e2
+---------------------------
+-- (- neg_arg) `op` e2
+mkOpAppRn e1@(NegApp neg_arg neg_op) op2 fix2 e2
| nofix_error
- = addErrRn (precParseErr (get neg_op,fix_neg) (get op2,fix2)) `thenRn_`
+ = addErrRn (precParseErr (get neg_op,negateFixity) (get op2,fix2)) `thenRn_`
returnRn (OpApp e1 op2 fix2 e2)
- | rearrange_me
+ | associate_right
= mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
returnRn (NegApp new_e neg_op)
where
- fix_neg = Fixity 6 InfixL -- Precedence of unary negate is wired in as infixl 6!
- (nofix_error, rearrange_me) = compareFixity fix_neg fix2
+ (nofix_error, associate_right) = compareFixity negateFixity fix2
+
+---------------------------
+-- e1 `op` - neg_arg
+mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg neg_op) -- NegApp can occur on the right
+ | not associate_right -- We *want* right association
+ = addErrRn (precParseErr (get op1, fix1) (get neg_op, negateFixity)) `thenRn_`
+ returnRn (OpApp e1 op1 fix1 e2)
+ where
+ (nofix_err, associate_right) = compareFixity fix1 negateFixity
+---------------------------
+-- Default case
mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
- = ASSERT( if right_op_ok fix e2 then True
- else pprPanic "mkOpAppRn" (vcat [ppr e1, text "---", ppr op,
- text "---", ppr fix, text "---", ppr e2])
+ = ASSERT2( right_op_ok fix e2,
+ ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
)
returnRn (OpApp e1 op fix e2)
= addErrRn (precParseErr (op1,fix1) (op2,fix2)) `thenRn_`
returnRn (ConOpPatIn p1 op2 fix2 p2)
- | rearrange_me
+ | associate_right
= mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p ->
returnRn (ConOpPatIn p11 op1 fix1 new_p)
where
- (nofix_error, rearrange_me) = compareFixity fix1 fix2
+ (nofix_error, associate_right) = compareFixity fix1 fix2
mkConOpPatRn p1@(NegPatIn neg_arg)
op2
fix2@(Fixity prec2 dir2)
p2
- | prec2 > 6 -- Precedence of unary - is wired in as 6!
+ | prec2 > negatePrecedence -- Precedence of unary - is wired in
= addErrRn (precParseNegPatErr (op2,fix2)) `thenRn_`
returnRn (ConOpPatIn p1 op2 fix2 p2)
checkPrec op (NegPatIn _) right
= lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
- checkRn (op_prec <= 6) (precParseNegPatErr (op,op_fix))
+ checkRn (op_prec <= negatePrecedence) (precParseNegPatErr (op,op_fix))
checkPrec op pat right
= returnRn ()
\end{code}
Consider
+\begin{verbatim}
a `op1` b `op2` c
-
-(compareFixity op1 op2) tells which way to arrange appication, or
+\end{verbatim}
+@(compareFixity op1 op2)@ tells which way to arrange appication, or
whether there's an error.
\begin{code}
%* *
%************************************************************************
-When literals occur we have to make sure that the types and classes they involve
+When literals occur we have to make sure
+that the types and classes they involve
are made available.
\begin{code}
precParseNegPatErr op
= hang (ptext SLIT("precedence parsing error"))
4 (hsep [ptext SLIT("prefix `-' has lower precedence than"),
- quotes (pp_op op),
+ pp_op op,
ptext SLIT("in pattern")])
precParseErr op1 op2
= hang (ptext SLIT("precedence parsing error"))
- 4 (hsep [ptext SLIT("cannot mix"), quotes (pp_op op1), ptext SLIT("and"),
- quotes (pp_op op2),
+ 4 (hsep [ptext SLIT("cannot mix"), pp_op op1, ptext SLIT("and"),
+ pp_op op2,
ptext SLIT("in the same infix expression")])
nonStdGuardErr guard
- = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)"))
- 4 (ppr guard)
+ = hang (ptext
+ SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
+ ) 4 (ppr guard)
patSigErr ty
- = hang (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
- 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
+ = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
+ $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
+
+pp_op (op, fix) = hcat [quotes (ppr op), space, parens (ppr fix)]
+
+patSynErr e
+ = sep [ptext SLIT("Pattern syntax in expression context:"),
+ nest 4 (ppr e)]
-pp_op (op, fix) = hcat [ppr op, space, parens (ppr fix)]
+doStmtListErr e
+ = sep [ptext SLIT("`do' statements must end in expression:"),
+ nest 4 (ppr e)]
\end{code}