#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
tyvars_in_sigs = rhs_sig_tyvars `unionLists` tyvars_in_pats
rhs_sig_tyvars = case maybe_rhs_sig of
Nothing -> []
- Just ty -> extractHsTyRdrNames ty
+ Just ty -> extractHsTyRdrTyVars ty
tyvars_in_pats = extractPatsTyVars pats
forall_tyvars = filter (not . (`elemFM` name_env)) tyvars_in_sigs
- doc = text "a pattern type-signature"
+ doc_sig = text "a pattern type-signature"
+ doc_pats = text "in a pattern match"
in
- bindTyVarsFVRn doc (map UserTyVar forall_tyvars) $ \ sig_tyvars ->
+ bindTyVarsFVRn doc_sig (map UserTyVar forall_tyvars) $ \ sig_tyvars ->
-- Note that we do a single bindLocalsRn for all the
-- matches together, so that we spot the repeated variable in
-- f x x = 1
- bindLocalsFVRn doc (collectPatsBinders pats) $ \ new_binders ->
+ bindLocalsFVRn doc_pats (collectPatsBinders pats) $ \ new_binders ->
mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) ->
rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) ->
(case maybe_rhs_sig of
Nothing -> returnRn (Nothing, emptyFVs)
- Just ty | opt_GlasgowExts -> rnHsType doc ty `thenRn` \ (ty', ty_fvs) ->
+ Just ty | opt_GlasgowExts -> rnHsPolyType doc_sig ty `thenRn` \ (ty', ty_fvs) ->
returnRn (Just ty', ty_fvs)
| otherwise -> addErrRn (patSigErr ty) `thenRn_`
returnRn (Nothing, emptyFVs)
-- The normal case
returnRn (HsVar name, unitFV name)
+rnExpr (HsIPVar v)
+ = getIPName v `thenRn` \ name ->
+ returnRn (HsIPVar name, emptyFVs)
+
rnExpr (HsLit lit)
= litOccurrence lit `thenRn` \ fvs ->
returnRn (HsLit lit, fvs)
= rnExpr e `thenRn` \ (e', fvs_e) ->
returnRn (HsPar e', fvs_e)
-rnExpr (SectionL expr op)
- = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
- rnExpr op `thenRn` \ (op', fvs_op) ->
+rnExpr section@(SectionL expr op)
+ = rnExpr expr `thenRn` \ (expr', fvs_expr) ->
+ rnExpr op `thenRn` \ (op', fvs_op) ->
+ checkSectionPrec "left" section op' expr' `thenRn_`
returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr)
-rnExpr (SectionR op expr)
- = rnExpr op `thenRn` \ (op', fvs_op) ->
- rnExpr expr `thenRn` \ (expr', fvs_expr) ->
+rnExpr section@(SectionR op expr)
+ = rnExpr op `thenRn` \ (op', fvs_op) ->
+ rnExpr expr `thenRn` \ (expr', fvs_expr) ->
+ checkSectionPrec "right" section op' expr' `thenRn_`
returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
-rnExpr (CCall fun args may_gc is_casm fake_result_ty)
+rnExpr (HsCCall fun args may_gc is_casm fake_result_ty)
-- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
= lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc ->
lookupImplicitOccRn creturnableClass_RDR `thenRn` \ cr ->
lookupImplicitOccRn ioDataCon_RDR `thenRn` \ io ->
rnExprs args `thenRn` \ (args', fvs_args) ->
- returnRn (CCall fun args' may_gc is_casm fake_result_ty,
+ returnRn (HsCCall fun args' may_gc is_casm fake_result_ty,
fvs_args `addOneFV` cc `addOneFV` cr `addOneFV` io)
rnExpr (HsSCC lbl expr)
rnExpr expr `thenRn` \ (expr',fvExpr) ->
returnRn (HsLet binds' expr', fvExpr)
-rnExpr (HsDo do_or_lc stmts src_loc)
+rnExpr (HsWith expr binds)
+ = rnExpr expr `thenRn` \ (expr',fvExpr) ->
+ rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
+ returnRn (HsWith expr' binds', fvExpr `plusFV` fvBinds)
+
+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)
%************************************************************************
%* *
+\subsubsection{@rnIPBinds@s: in implicit parameter bindings} *
+%* *
+%************************************************************************
+
+\begin{code}
+rnIPBinds [] = returnRn ([], emptyFVs)
+rnIPBinds ((n, expr) : binds)
+ = getIPName n `thenRn` \ name ->
+ rnExpr expr `thenRn` \ (expr',fvExpr) ->
+ rnIPBinds binds `thenRn` \ (binds',fvBinds) ->
+ returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds)
+
+\end{code}
+
+%************************************************************************
+%* *
\subsubsection{@Stmt@s: in @do@ 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_`
+ = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op 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 (pp_prefix_minus,negateFixity) (ppr_op 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 (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_`
+ returnRn (OpApp e1 op1 fix1 e2)
+ where
+ (_, 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)
-get (HsVar n) = n
-
-- 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
mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
op2 fix2 p2
| nofix_error
- = addErrRn (precParseErr (op1,fix1) (op2,fix2)) `thenRn_`
+ = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op 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!
- = addErrRn (precParseNegPatErr (op2,fix2)) `thenRn_`
+ | prec2 > negatePrecedence -- Precedence of unary - is wired in
+ = addErrRn (precParseNegPatErr (ppr_op op2,fix2)) `thenRn_`
returnRn (ConOpPatIn p1 op2 fix2 p2)
mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment
checkPrecMatch False fn match
= returnRn ()
-checkPrecMatch True op (Match _ [p1,p2] _ _)
+checkPrecMatch True op (Match _ (p1:p2:_) _ _)
+ -- True indicates an infix lhs
= getModeRn `thenRn` \ mode ->
-- See comments with rnExpr (OpApp ...)
case mode of
(op1_dir == InfixR && op_dir == InfixR && right ||
op1_dir == InfixL && op_dir == InfixL && not right))
- info = (op,op_fix)
- info1 = (op1,op1_fix)
+ info = (ppr_op op, op_fix)
+ info1 = (ppr_op op1, op1_fix)
(infol, infor) = if right then (info, info1) else (info1, info)
in
checkRn inf_ok (precParseErr infol infor)
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 (ppr_op op,op_fix))
checkPrec op pat right
= returnRn ()
+
+-- Check precedence of (arg op) or (op arg) respectively
+-- If arg is itself an operator application, its precedence should
+-- be higher than that of op
+checkSectionPrec left_or_right section op arg
+ = case arg of
+ OpApp _ op fix _ -> go_for_it (ppr_op op) fix
+ NegApp _ op -> go_for_it pp_prefix_minus negateFixity
+ other -> returnRn ()
+ where
+ HsVar op_name = op
+ go_for_it pp_arg_op arg_fix@(Fixity arg_prec _)
+ = lookupFixity op_name `thenRn` \ op_fix@(Fixity op_prec _) ->
+ checkRn (op_prec < arg_prec)
+ (sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section)
\end{code}
Consider
%************************************************************************
\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)
= hsep [ptext SLIT("duplicate field name"),
quotes (ppr dup),
ptext SLIT("in record"), text str]
negPatErr pat
- = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), quotes (ppr pat)]
+ = sep [pp_prefix_minus <+> ptext SLIT("not applied to literal in pattern"),
+ quotes (ppr pat)]
precParseNegPatErr op
= hang (ptext SLIT("precedence parsing error"))
- 4 (hsep [ptext SLIT("prefix `-' has lower precedence than"),
- quotes (pp_op op),
+ 4 (hsep [pp_prefix_minus <+> ptext SLIT("has lower precedence than"),
+ ppr_opfix 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"), 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)")
= (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
$$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
-pp_op (op, fix) = hcat [ppr op, space, parens (ppr fix)]
-
patSynErr e
= sep [ptext SLIT("Pattern syntax in expression context:"),
nest 4 (ppr e)]
+
+doStmtListErr e
+ = sep [ptext SLIT("`do' statements must end in expression:"),
+ nest 4 (ppr e)]
\end{code}