X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnExpr.lhs;h=009facdb55c771619732e5987855c66d04469996;hb=cbf5bb17365e9228f3f724b87f958982c4b66cba;hp=ad4a4085901d142c67ab5e207bce79be9b0c0a8b;hpb=3df40b7b78044206bbcffe3e2c0a57d901baf5e8;p=ghc-hetmet.git diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index ad4a408..009facd 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -18,35 +18,35 @@ module RnExpr ( #include "HsVersions.h" import {-# SOURCE #-} RnBinds ( rnBinds ) -import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsPolyType, rnHsType ) +import {-# SOURCE #-} RnSource ( rnHsTypeFVs ) import HsSyn import RdrHsSyn import RnHsSyn import RnMonad import RnEnv -import RnIfaces ( lookupFixity ) -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, +import RnHiFiles ( lookupFixityRn ) +import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts ) +import Literal ( inIntRange ) +import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity ) +import PrelNames ( hasKey, assertIdKey, + eqClass_RDR, foldr_RDR, build_RDR, eqString_RDR, + cCallableClass_RDR, cReturnableClass_RDR, monadClass_RDR, enumClass_RDR, ordClass_RDR, ratioDataCon_RDR, negate_RDR, assertErr_RDR, - ioDataCon_RDR + ioDataCon_RDR, plusInteger_RDR, timesInteger_RDR ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) -import Name ( nameUnique, isLocallyDefined, NamedThing(..) - , mkSysLocalName, nameSrcLoc - ) +import TysWiredIn ( intTyCon ) +import Name ( NamedThing(..), mkSysLocalName, nameSrcLoc ) import NameSet import UniqFM ( isNullUFM ) import FiniteMap ( elemFM ) -import UniqSet ( emptyUniqSet, UniqSet ) -import Unique ( assertIdKey ) -import Util ( removeDups ) -import ListSetOps ( unionLists ) +import UniqSet ( emptyUniqSet ) +import List ( intersectBy ) +import ListSetOps ( unionLists, removeDups ) import Maybes ( maybeToBool ) import Outputable \end{code} @@ -68,21 +68,37 @@ rnPat (VarPatIn name) returnRn (VarPatIn vname, emptyFVs) rnPat (SigPatIn pat ty) - | opt_GlasgowExts - = rnPat pat `thenRn` \ (pat', fvs1) -> - rnHsPolyType doc ty `thenRn` \ (ty', fvs2) -> - returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2) - - | otherwise - = addErrRn (patSigErr ty) `thenRn_` - rnPat pat + = doptRn Opt_GlasgowExts `thenRn` \ glaExts -> + + if glaExts + then rnPat pat `thenRn` \ (pat', fvs1) -> + rnHsTypeFVs doc ty `thenRn` \ (ty', fvs2) -> + returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2) + + else addErrRn (patSigErr ty) `thenRn_` + rnPat pat where doc = text "a pattern type-signature" +rnPat (LitPatIn s@(HsString _)) + = lookupOrigName eqString_RDR `thenRn` \ eq -> + returnRn (LitPatIn s, unitFV eq) + rnPat (LitPatIn lit) - = litOccurrence lit `thenRn` \ fvs1 -> - lookupImplicitOccRn eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern - returnRn (LitPatIn lit, fvs1 `addOneFV` eq) + = litFVs lit `thenRn` \ fvs -> + returnRn (LitPatIn lit, fvs) + +rnPat (NPatIn lit) + = rnOverLit lit `thenRn` \ (lit', fvs1) -> + lookupOrigName eqClass_RDR `thenRn` \ eq -> -- Needed to find equality on pattern + returnRn (NPatIn lit', fvs1 `addOneFV` eq) + +rnPat (NPlusKPatIn name lit minus) + = rnOverLit lit `thenRn` \ (lit', fvs) -> + lookupOrigName ordClass_RDR `thenRn` \ ord -> + lookupBndrRn name `thenRn` \ name' -> + lookupOccRn minus `thenRn` \ minus' -> + returnRn (NPlusKPatIn name' lit' minus', fvs `addOneFV` ord `addOneFV` minus') rnPat (LazyPatIn pat) = rnPat pat `thenRn` \ (pat', fvs) -> @@ -107,38 +123,15 @@ rnPat (ConOpPatIn pat1 con _ pat2) -- 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') --- Negated patters can only be literals, and they are dealt with --- by negating the literal at compile time, not by using the negation --- operation in Num. So we don't need to make an implicit reference --- to negate_RDR. -rnPat neg@(NegPatIn pat) - = checkRn (valid_neg_pat pat) (negPatErr neg) - `thenRn_` - rnPat pat `thenRn` \ (pat', fvs) -> - returnRn (NegPatIn pat', fvs) - where - 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 (ParPatIn pat', fvs) -rnPat (NPlusKPatIn name lit) - = litOccurrence lit `thenRn` \ fvs -> - lookupImplicitOccRn ordClass_RDR `thenRn` \ ord -> - lookupBndrRn name `thenRn` \ name' -> - returnRn (NPlusKPatIn name' lit, fvs `addOneFV` ord) - rnPat (ListPatIn pats) = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name) @@ -153,6 +146,9 @@ rnPat (RecPatIn con rpats) = lookupOccRn con `thenRn` \ con' -> rnRpats rpats `thenRn` \ (rpats', fvs) -> returnRn (RecPatIn con' rpats', fvs `addOneFV` con') +rnPat (TypePatIn name) = + (rnHsTypeFVs (text "type pattern") name) `thenRn` \ (name', fvs) -> + returnRn (TypePatIn name', fvs) \end{code} ************************************************************************ @@ -174,23 +170,25 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) 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 -> + bindNakedTyVarsFVRn doc_sig 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) -> + doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts -> (case maybe_rhs_sig of Nothing -> returnRn (Nothing, emptyFVs) - Just ty | opt_GlasgowExts -> rnHsType doc ty `thenRn` \ (ty', ty_fvs) -> + Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenRn` \ (ty', ty_fvs) -> returnRn (Just ty', ty_fvs) | otherwise -> addErrRn (patSigErr ty) `thenRn_` returnRn (Nothing, emptyFVs) @@ -223,14 +221,15 @@ rnGRHSs (GRHSs grhss binds maybe_ty) returnRn (GRHSs grhss' binds' Nothing, fvGRHSs) rnGRHS (GRHS guarded locn) - = pushSrcLocRn locn $ + = doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts -> + pushSrcLocRn locn $ (if not (opt_GlasgowExts || is_standard_guard guarded) then addWarnRn (nonStdGuardErr guarded) else returnRn () ) `thenRn_` - rnStmts rnExpr guarded `thenRn` \ (guarded', fvs) -> + rnStmts rnExpr guarded `thenRn` \ ((_, guarded'), fvs) -> returnRn (GRHS guarded' locn, fvs) where -- Standard Haskell 1.4 guards are just a single boolean @@ -275,17 +274,25 @@ rnExpr :: RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars) 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) + = newIPName v `thenRn` \ name -> + returnRn (HsIPVar name, emptyFVs) + rnExpr (HsLit lit) - = litOccurrence lit `thenRn` \ fvs -> + = litFVs lit `thenRn` \ fvs -> returnRn (HsLit lit, fvs) +rnExpr (HsOverLit lit) + = rnOverLit lit `thenRn` \ (lit', fvs) -> + returnRn (HsOverLit lit', fvs) + rnExpr (HsLam match) = rnMatch match `thenRn` \ (match', fvMatch) -> returnRn (HsLam match', fvMatch) @@ -307,7 +314,7 @@ rnExpr (OpApp e1 op _ e2) -- 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 -> @@ -315,40 +322,36 @@ rnExpr (OpApp e1 op _ e2) 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 -> - mkNegAppRn e' (HsVar neg) `thenRn` \ final_e -> + = rnExpr e `thenRn` \ (e', fv_e) -> + lookupOrigName negate_RDR `thenRn` \ neg -> + mkNegAppRn e' neg `thenRn` \ final_e -> returnRn (final_e, fv_e `addOneFV` neg) rnExpr (HsPar 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 -> + = lookupOrigNames [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) -> @@ -365,21 +368,38 @@ rnExpr (HsLet binds 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) -> - returnRn (HsDo do_or_lc stmts' src_loc, fvs `addOneFV` monad) + lookupOrigNames implicit_rdr_names `thenRn` \ implicit_fvs -> + 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 `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 -> @@ -392,8 +412,8 @@ rnExpr (RecordUpd expr rbinds) returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds) rnExpr (ExprWithTySig expr pty) - = rnExpr expr `thenRn` \ (expr', fvExpr) -> - rnHsSigType (text "an expression") pty `thenRn` \ (pty', fvTy) -> + = rnExpr expr `thenRn` \ (expr', fvExpr) -> + rnHsTypeFVs (text "an expression type signature") pty `thenRn` \ (pty', fvTy) -> returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) rnExpr (HsIf p b1 b2 src_loc) @@ -403,8 +423,14 @@ rnExpr (HsIf p b1 b2 src_loc) rnExpr b2 `thenRn` \ (b2', fvB2) -> returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2]) +rnExpr (HsType a) + = rnHsTypeFVs doc a `thenRn` \ (t, fvT) -> + returnRn (HsType t, fvT) + where + doc = text "renaming a type pattern" + rnExpr (ArithSeqIn seq) - = lookupImplicitOccRn enumClass_RDR `thenRn` \ enum -> + = lookupOrigName enumClass_RDR `thenRn` \ enum -> rn_seq seq `thenRn` \ (new_seq, fvs) -> returnRn (ArithSeqIn new_seq, fvs `addOneFV` enum) where @@ -445,6 +471,8 @@ rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_` returnRn (EWildPat, emptyFVs) \end{code} + + %************************************************************************ %* * \subsubsection{@Rbinds@s and @Rpats@s: in record expressions} @@ -483,6 +511,22 @@ rnRpats rpats %************************************************************************ %* * +\subsubsection{@rnIPBinds@s: in implicit parameter bindings} * +%* * +%************************************************************************ + +\begin{code} +rnIPBinds [] = returnRn ([], emptyFVs) +rnIPBinds ((n, expr) : binds) + = newIPName 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} %* * %************************************************************************ @@ -499,29 +543,46 @@ Quals. type RnExprTy = RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars) rnStmts :: RnExprTy - -> [RdrNameStmt] - -> RnMS ([RenamedStmt], FreeVars) + -> [RdrNameStmt] + -> RnMS (([Name], [RenamedStmt]), FreeVars) rnStmts rn_expr [] - = returnRn ([], emptyFVs) + = returnRn (([], []), emptyFVs) rnStmts rn_expr (stmt:stmts) - = rnStmt rn_expr stmt $ \ stmt' -> - rnStmts rn_expr stmts `thenRn` \ (stmts', fvs) -> - returnRn (stmt' : stmts', fvs) + = getLocalNameEnv `thenRn` \ name_env -> + rnStmt rn_expr stmt $ \ stmt' -> + rnStmts rn_expr stmts `thenRn` \ ((binders, stmts'), fvs) -> + returnRn ((binders, stmt' : stmts'), fvs) rnStmt :: RnExprTy -> RdrNameStmt - -> (RenamedStmt -> RnMS (a, FreeVars)) - -> RnMS (a, FreeVars) + -> (RenamedStmt -> RnMS (([Name], a), FreeVars)) + -> RnMS (([Name], a), FreeVars) -- Because of mutual recursion we have to pass in rnExpr. +rnStmt rn_expr (ParStmt stmtss) thing_inside + = mapFvRn (rnStmts rn_expr) stmtss `thenRn` \ (bndrstmtss, fv_stmtss) -> + let binderss = map fst bndrstmtss + checkBndrs all_bndrs bndrs + = checkRn (null (intersectBy eqOcc all_bndrs bndrs)) err `thenRn_` + returnRn (bndrs ++ all_bndrs) + eqOcc n1 n2 = nameOccName n1 == nameOccName n2 + err = text "duplicate binding in parallel list comprehension" + in + foldlRn checkBndrs [] binderss `thenRn` \ binders -> + bindLocalNamesFV binders $ + thing_inside (ParStmtOut bndrstmtss)`thenRn` \ ((rest_bndrs, result), fv_rest) -> + returnRn ((rest_bndrs ++ binders, result), fv_stmtss `plusFV` fv_rest) + rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside = pushSrcLocRn src_loc $ - rn_expr expr `thenRn` \ (expr', fv_expr) -> - bindLocalsFVRn doc binders $ \ new_binders -> - rnPat pat `thenRn` \ (pat', fv_pat) -> - thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) -> - returnRn (result, fv_expr `plusFV` fvs `plusFV` fv_pat) + rn_expr expr `thenRn` \ (expr', fv_expr) -> + bindLocalsFVRn doc binders $ \ new_binders -> + rnPat pat `thenRn` \ (pat', fv_pat) -> + thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ ((rest_binders, result), fvs) -> + -- ZZ is shadowing handled correctly? + returnRn ((rest_binders ++ new_binders, result), + fv_expr `plusFV` fvs `plusFV` fv_pat) where binders = collectPatBinders pat doc = text "a pattern in do binding" @@ -544,8 +605,9 @@ rnStmt rn_expr (ReturnStmt expr) thing_inside returnRn (result, fv_expr `plusFV` fvs) rnStmt rn_expr (LetStmt binds) thing_inside - = rnBinds binds $ \ binds' -> + = rnBinds binds $ \ binds' -> thing_inside (LetStmt binds') + \end{code} %************************************************************************ @@ -575,7 +637,7 @@ mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged -- (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 @@ -588,7 +650,7 @@ mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2 -- (- 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 @@ -601,10 +663,10 @@ mkOpAppRn e1@(NegApp neg_arg neg_op) op2 fix2 e2 -- 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 @@ -614,8 +676,6 @@ mkOpAppRn e1 op fix e2 -- Default case, no rearrangment ) 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 @@ -646,7 +706,7 @@ mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat 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 @@ -656,14 +716,6 @@ mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12) where (nofix_error, associate_right) = compareFixity fix1 fix2 -mkConOpPatRn p1@(NegPatIn neg_arg) - op2 - fix2@(Fixity prec2 dir2) - p2 - | prec2 > negatePrecedence -- Precedence of unary - is wired in - = 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) @@ -678,7 +730,8 @@ checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS () 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 @@ -689,26 +742,37 @@ checkPrecMatch True op (Match _ [p1,p2] _ _) 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)) - 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 _ _ -> 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 @@ -747,44 +811,39 @@ that the types and classes they involve are made available. \begin{code} -litOccurrence (HsChar _) - = returnRn (unitFV charTyCon_name) - -litOccurrence (HsCharPrim _) - = returnRn (unitFV (getName charPrimTyCon)) - -litOccurrence (HsString _) - = returnRn (unitFV listTyCon_name `plusFV` unitFV charTyCon_name) - -litOccurrence (HsStringPrim _) - = returnRn (unitFV (getName addrPrimTyCon)) - -litOccurrence (HsInt _) - = lookupImplicitOccRn numClass_RDR `thenRn` \ num -> - returnRn (unitFV num) -- Int and Integer are forced in by Num +litFVs (HsChar c) = returnRn (unitFV charTyCon_name) +litFVs (HsCharPrim c) = returnRn (unitFV (getName charPrimTyCon)) +litFVs (HsString s) = returnRn (mkFVs [listTyCon_name, charTyCon_name]) +litFVs (HsStringPrim s) = returnRn (unitFV (getName addrPrimTyCon)) +litFVs (HsInt i) = returnRn (unitFV (getName intTyCon)) +litFVs (HsIntPrim i) = returnRn (unitFV (getName intPrimTyCon)) +litFVs (HsFloatPrim f) = returnRn (unitFV (getName floatPrimTyCon)) +litFVs (HsDoublePrim d) = returnRn (unitFV (getName doublePrimTyCon)) +litFVs (HsLitLit l bogus_ty) = lookupOrigName cCallableClass_RDR `thenRn` \ cc -> + returnRn (unitFV cc) +litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear + -- in post-typechecker translations + +rnOverLit (HsIntegral i from_integer) + = lookupOccRn from_integer `thenRn` \ from_integer' -> + (if inIntRange i then + returnRn emptyFVs + else + lookupOrigNames [plusInteger_RDR, timesInteger_RDR] + ) `thenRn` \ ns -> + returnRn (HsIntegral i from_integer', ns `addOneFV` from_integer') -litOccurrence (HsFrac _) - = lookupImplicitOccRn fractionalClass_RDR `thenRn` \ frac -> - lookupImplicitOccRn ratioDataCon_RDR `thenRn` \ ratio -> - returnRn (unitFV frac `plusFV` unitFV ratio) +rnOverLit (HsFractional i n) + = lookupOccRn n `thenRn` \ n' -> + lookupOrigNames [ratioDataCon_RDR, plusInteger_RDR, timesInteger_RDR] `thenRn` \ ns' -> -- 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. - -litOccurrence (HsIntPrim _) - = returnRn (unitFV (getName intPrimTyCon)) - -litOccurrence (HsFloatPrim _) - = returnRn (unitFV (getName floatPrimTyCon)) - -litOccurrence (HsDoublePrim _) - = returnRn (unitFV (getName doublePrimTyCon)) - -litOccurrence (HsLitLit _) - = lookupImplicitOccRn ccallableClass_RDR `thenRn` \ cc -> - returnRn (unitFV cc) + -- The plus/times integer operations may be needed to construct the numerator + -- and denominator (see DsUtils.mkIntegerLit) + returnRn (HsFractional i n', ns' `addOneFV` n') \end{code} %************************************************************************ @@ -796,8 +855,8 @@ litOccurrence (HsLitLit _) \begin{code} mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars) mkAssertExpr = - mkImportedGlobalFromRdrName assertErr_RDR `thenRn` \ name -> - getSrcLocRn `thenRn` \ sloc -> + lookupOrigName assertErr_RDR `thenRn` \ name -> + getSrcLocRn `thenRn` \ sloc -> -- if we're ignoring asserts, return (\ _ e -> e) -- if not, return (assertError "src-loc") @@ -831,26 +890,26 @@ mkAssertExpr = %************************************************************************ \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)] - -precParseNegPatErr op - = hang (ptext SLIT("precedence parsing error")) - 4 (hsep [ptext SLIT("prefix `-' has lower precedence than"), - pp_op 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)") @@ -860,9 +919,11 @@ patSigErr ty = (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)] + +doStmtListErr e + = sep [ptext SLIT("`do' statements must end in expression:"), + nest 4 (ppr e)] \end{code}