#include "HsVersions.h"
import {-# SOURCE #-} RnBinds ( rnBinds )
-import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsPolyType, rnHsType )
+import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType )
import HsSyn
import RdrHsSyn
import RnHsSyn
import RnMonad
import RnEnv
-import RnIfaces ( lookupFixity )
+import RnIfaces ( lookupFixityRn )
import CmdLineOpts ( opt_GlasgowExts, opt_IgnoreAsserts )
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,
ratioDataCon_RDR, negate_RDR, assertErr_RDR,
- ioDataCon_RDR
+ ioDataCon_RDR, addr2Integer_RDR,
+ foldr_RDR, build_RDR
)
import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
floatPrimTyCon, doublePrimTyCon
import UniqFM ( isNullUFM )
import FiniteMap ( elemFM )
import UniqSet ( emptyUniqSet, UniqSet )
-import Unique ( assertIdKey )
+import Unique ( hasKey, assertIdKey )
import Util ( removeDups )
import ListSetOps ( unionLists )
import Maybes ( maybeToBool )
rnPat (SigPatIn pat ty)
| opt_GlasgowExts
= rnPat pat `thenRn` \ (pat', fvs1) ->
- rnHsPolyType doc ty `thenRn` \ (ty', fvs2) ->
+ rnHsType doc ty `thenRn` \ (ty', fvs2) ->
returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
| otherwise
-- See comments with rnExpr (OpApp ...)
(case mode of
InterfaceMode -> returnRn (ConOpPatIn pat1' con' defaultFixity pat2')
- SourceMode -> lookupFixity con' `thenRn` \ fixity ->
+ SourceMode -> lookupFixityRn con' `thenRn` \ fixity ->
mkConOpPatRn pat1' con' fixity pat2'
) `thenRn` \ pat' ->
returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con')
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 -> rnHsType doc_sig ty `thenRn` \ (ty', ty_fvs) ->
returnRn (Just ty', ty_fvs)
| otherwise -> addErrRn (patSigErr ty) `thenRn_`
returnRn (Nothing, emptyFVs)
rnExpr (HsVar v)
= lookupOccRn v `thenRn` \ name ->
- if nameUnique name == assertIdKey then
+ if name `hasKey` assertIdKey then
-- We expand it to (GHCerr.assert__ location)
mkAssertExpr
else
-- 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)
-- Don't even look up the fixity when in interface mode
getModeRn `thenRn` \ mode ->
(case mode of
- SourceMode -> lookupFixity op_name `thenRn` \ fixity ->
+ SourceMode -> lookupFixityRn op_name `thenRn` \ fixity ->
mkOpAppRn e1' op' fixity e2'
InterfaceMode -> returnRn (OpApp e1' op' defaultFixity e2')
) `thenRn` \ final_e ->
= 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 ->
+ = lookupImplicitOccsRn [ccallableClass_RDR,
+ creturnableClass_RDR,
+ ioDataCon_RDR] `thenRn` \ implicit_fvs ->
rnExprs args `thenRn` \ (args', fvs_args) ->
- returnRn (CCall fun args' may_gc is_casm fake_result_ty,
- fvs_args `addOneFV` cc `addOneFV` cr `addOneFV` io)
+ returnRn (HsCCall fun args' may_gc is_casm fake_result_ty,
+ fvs_args `plusFV` implicit_fvs)
rnExpr (HsSCC lbl expr)
= rnExpr expr `thenRn` \ (expr', fvs_expr) ->
rnExpr expr `thenRn` \ (expr',fvExpr) ->
returnRn (HsLet binds' expr', fvExpr)
+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 ->
+ lookupImplicitOccsRn implicit_rdr_names `thenRn` \ implicit_fvs ->
rnStmts rnExpr stmts `thenRn` \ (stmts', fvs) ->
-- check the statement list ends in an expression
case last stmts' of {
ReturnStmt _ -> returnRn () ; -- for list comprehensions
_ -> addErrRn (doStmtListErr e)
} `thenRn_`
- returnRn (HsDo do_or_lc stmts' src_loc, fvs `addOneFV` monad)
+ returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs)
+ where
+ implicit_rdr_names = [foldr_RDR, build_RDR, monadClass_RDR]
+ -- Monad stuff should not be necessary for a list comprehension
+ -- but the typechecker looks up the bind and return Ids anyway
+ -- Oh well.
+
rnExpr (ExplicitList exps)
= rnExprs exps `thenRn` \ (exps', fvs) ->
returnRn (ExplicitList exps', fvs `addOneFV` listTyCon_name)
-rnExpr (ExplicitTuple exps boxed)
+rnExpr (ExplicitTuple exps boxity)
= rnExprs exps `thenRn` \ (exps', fvs) ->
- returnRn (ExplicitTuple exps' boxed, fvs `addOneFV` tycon_name)
+ returnRn (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
where
- tycon_name = tupleTyCon_name boxed (length exps)
+ tycon_name = tupleTyCon_name boxity (length exps)
rnExpr (RecordCon con_id rbinds)
= lookupOccRn con_id `thenRn` \ conname ->
%************************************************************************
%* *
+\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}
%* *
%************************************************************************
-- (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)
| associate_right
-- (- neg_arg) `op` e2
mkOpAppRn e1@(NegApp neg_arg neg_op) op2 fix2 e2
| nofix_error
- = addErrRn (precParseErr (get neg_op,negateFixity) (get op2,fix2)) `thenRn_`
+ = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenRn_`
returnRn (OpApp e1 op2 fix2 e2)
| associate_right
-- 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_`
+ = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_`
returnRn (OpApp e1 op1 fix1 e2)
where
- (nofix_err, associate_right) = compareFixity fix1 negateFixity
+ (_, associate_right) = compareFixity fix1 negateFixity
---------------------------
-- Default case
)
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)
| associate_right
fix2@(Fixity prec2 dir2)
p2
| prec2 > negatePrecedence -- Precedence of unary - is wired in
- = addErrRn (precParseNegPatErr (op2,fix2)) `thenRn_`
+ = 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
checkPrecMatch True op _ = panic "checkPrecMatch"
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) ->
+ = lookupFixityRn op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
+ lookupFixityRn op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
let
inf_ok = op1_prec > op_prec ||
(op1_prec == op_prec &&
(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 <= negatePrecedence) (precParseNegPatErr (op,op_fix))
+ = lookupFixityRn op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
+ 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 _)
+ = lookupFixityRn 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
= returnRn (unitFV (getName addrPrimTyCon))
litOccurrence (HsInt _)
- = lookupImplicitOccRn numClass_RDR `thenRn` \ num ->
- returnRn (unitFV num) -- Int and Integer are forced in by Num
+ = lookupImplicitOccsRn [numClass_RDR, addr2Integer_RDR]
+ -- Int and Integer are forced in by Num
litOccurrence (HsFrac _)
- = lookupImplicitOccRn fractionalClass_RDR `thenRn` \ frac ->
- lookupImplicitOccRn ratioDataCon_RDR `thenRn` \ ratio ->
- returnRn (unitFV frac `plusFV` unitFV ratio)
+ = lookupImplicitOccsRn [fractionalClass_RDR,ratioDataCon_RDR,addr2Integer_RDR]
-- 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.
%************************************************************************
\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"),
- 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"), pp_op op1, ptext SLIT("and"),
- 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 [quotes (ppr op), space, parens (ppr fix)]
-
patSynErr e
= sep [ptext SLIT("Pattern syntax in expression context:"),
nest 4 (ppr e)]
projects / ghc-hetmet.git / blobdiff