diff options
Diffstat (limited to 'ghc/compiler/rename/RnExpr.lhs')
| -rw-r--r-- | ghc/compiler/rename/RnExpr.lhs | 762 |
1 files changed, 402 insertions, 360 deletions
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index f48d7326b8..a4d6a35cec 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -11,18 +11,18 @@ free variables. \begin{code} module RnExpr ( - rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs, rnStmt, - checkPrecMatch + rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs, + rnStmt, rnStmts, checkPrecMatch ) where #include "HsVersions.h" -import {-# SOURCE #-} RnBinds ( rnBinds ) +import {-# SOURCE #-} RnSource ( rnSrcDecls, rnBinds ) import HsSyn import RdrHsSyn import RnHsSyn -import RnMonad +import TcRnMonad import RnEnv import RnTypes ( rnHsTypeFVs, precParseErr, sectionPrecErr ) import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts ) @@ -32,20 +32,19 @@ import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..), import PrelNames ( hasKey, assertIdKey, eqClassName, foldrName, buildName, eqStringName, cCallableClassName, cReturnableClassName, - monadClassName, enumClassName, ordClassName, + enumClassName, ordClassName, ratioDataConName, splitName, fstName, sndName, ioDataConName, plusIntegerName, timesIntegerName, - assertErr_RDR, replicatePName, mapPName, filterPName, - falseDataConName, trueDataConName, crossPName, - zipPName, lengthPName, indexPName, toPName, - enumFromToPName, enumFromThenToPName, + crossPName, zipPName, lengthPName, indexPName, toPName, + enumFromToPName, enumFromThenToPName, assertName, fromIntegerName, fromRationalName, minusName, negateName, - monadNames ) + qTyConName, monadNames ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) import TysWiredIn ( intTyCon ) -import Name ( NamedThing(..), mkSystemName, nameSrcLoc ) +import RdrName ( RdrName ) +import Name ( Name, NamedThing(..), mkSystemName, nameSrcLoc, nameOccName ) import NameSet import UnicodeUtil ( stringToUtf8 ) import UniqFM ( isNullUFM ) @@ -64,111 +63,116 @@ import FastString ********************************************************* \begin{code} -rnPat :: RdrNamePat -> RnMS (RenamedPat, FreeVars) +rnPat :: RdrNamePat -> RnM (RenamedPat, FreeVars) -rnPat WildPatIn = returnRn (WildPatIn, emptyFVs) +rnPat (WildPat _) = returnM (WildPat placeHolderType, emptyFVs) -rnPat (VarPatIn name) - = lookupBndrRn name `thenRn` \ vname -> - returnRn (VarPatIn vname, emptyFVs) +rnPat (VarPat name) + = lookupBndrRn name `thenM` \ vname -> + returnM (VarPat vname, emptyFVs) rnPat (SigPatIn pat ty) - = doptRn Opt_GlasgowExts `thenRn` \ glaExts -> + = doptM Opt_GlasgowExts `thenM` \ glaExts -> if glaExts - then rnPat pat `thenRn` \ (pat', fvs1) -> - rnHsTypeFVs doc ty `thenRn` \ (ty', fvs2) -> - returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2) + then rnPat pat `thenM` \ (pat', fvs1) -> + rnHsTypeFVs doc ty `thenM` \ (ty', fvs2) -> + returnM (SigPatIn pat' ty', fvs1 `plusFV` fvs2) - else addErrRn (patSigErr ty) `thenRn_` + else addErr (patSigErr ty) `thenM_` rnPat pat where - doc = text "a pattern type-signature" + doc = text "In a pattern type-signature" -rnPat (LitPatIn s@(HsString _)) - = returnRn (LitPatIn s, unitFV eqStringName) +rnPat (LitPat s@(HsString _)) + = returnM (LitPat s, unitFV eqStringName) -rnPat (LitPatIn lit) - = litFVs lit `thenRn` \ fvs -> - returnRn (LitPatIn lit, fvs) +rnPat (LitPat lit) + = litFVs lit `thenM` \ fvs -> + returnM (LitPat lit, fvs) rnPat (NPatIn lit mb_neg) - = rnOverLit lit `thenRn` \ (lit', fvs1) -> + = rnOverLit lit `thenM` \ (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', + Nothing -> returnM (Nothing, emptyFVs) + Just _ -> lookupSyntaxName negateName `thenM` \ (neg, fvs) -> + returnM (Just neg, fvs) + ) `thenM` \ (mb_neg', fvs2) -> + returnM (NPatIn lit' mb_neg', fvs1 `plusFV` fvs2 `addOneFV` eqClassName) -- Needed to find equality on pattern rnPat (NPlusKPatIn name lit _) - = rnOverLit lit `thenRn` \ (lit', fvs1) -> - lookupBndrRn name `thenRn` \ name' -> - lookupSyntaxName minusName `thenRn` \ (minus, fvs2) -> - returnRn (NPlusKPatIn name' lit' minus, + = rnOverLit lit `thenM` \ (lit', fvs1) -> + lookupBndrRn name `thenM` \ name' -> + lookupSyntaxName minusName `thenM` \ (minus, fvs2) -> + returnM (NPlusKPatIn name' lit' minus, fvs1 `plusFV` fvs2 `addOneFV` ordClassName) -rnPat (LazyPatIn pat) - = rnPat pat `thenRn` \ (pat', fvs) -> - returnRn (LazyPatIn pat', fvs) +rnPat (LazyPat pat) + = rnPat pat `thenM` \ (pat', fvs) -> + returnM (LazyPat pat', fvs) -rnPat (AsPatIn name pat) - = rnPat pat `thenRn` \ (pat', fvs) -> - lookupBndrRn name `thenRn` \ vname -> - returnRn (AsPatIn vname pat', fvs) +rnPat (AsPat name pat) + = rnPat pat `thenM` \ (pat', fvs) -> + lookupBndrRn name `thenM` \ vname -> + returnM (AsPat vname pat', fvs) -rnPat (ConPatIn con pats) - = lookupOccRn con `thenRn` \ con' -> - mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> - returnRn (ConPatIn con' patslist, fvs `addOneFV` con') +rnPat (ConPatIn con stuff) = rnConPat con stuff -rnPat (ConOpPatIn pat1 con _ pat2) - = rnPat pat1 `thenRn` \ (pat1', fvs1) -> - lookupOccRn con `thenRn` \ con' -> - rnPat pat2 `thenRn` \ (pat2', fvs2) -> - getModeRn `thenRn` \ mode -> - -- See comments with rnExpr (OpApp ...) - (if isInterfaceMode mode - then returnRn (ConOpPatIn pat1' con' defaultFixity pat2') - else lookupFixityRn con' `thenRn` \ fixity -> - mkConOpPatRn pat1' con' fixity pat2' - ) `thenRn` \ pat' -> - returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con') - -rnPat (ParPatIn pat) - = rnPat pat `thenRn` \ (pat', fvs) -> - returnRn (ParPatIn pat', fvs) - -rnPat (ListPatIn pats) - = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> - returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name) - -rnPat (PArrPatIn pats) - = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> - returnRn (PArrPatIn patslist, +rnPat (ParPat pat) + = rnPat pat `thenM` \ (pat', fvs) -> + returnM (ParPat pat', fvs) + +rnPat (ListPat pats _) + = mapFvRn rnPat pats `thenM` \ (patslist, fvs) -> + returnM (ListPat patslist placeHolderType, fvs `addOneFV` listTyCon_name) + +rnPat (PArrPat pats _) + = mapFvRn rnPat pats `thenM` \ (patslist, fvs) -> + returnM (PArrPat patslist placeHolderType, fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name) where implicit_fvs = mkFVs [lengthPName, indexPName] -rnPat (TuplePatIn pats boxed) - = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> - returnRn (TuplePatIn patslist boxed, fvs `addOneFV` tycon_name) +rnPat (TuplePat pats boxed) + = mapFvRn rnPat pats `thenM` \ (patslist, fvs) -> + returnM (TuplePat patslist boxed, fvs `addOneFV` tycon_name) where tycon_name = tupleTyCon_name boxed (length pats) -rnPat (RecPatIn con rpats) - = lookupOccRn con `thenRn` \ con' -> - rnRpats rpats `thenRn` \ (rpats', fvs) -> - returnRn (RecPatIn con' rpats', fvs `addOneFV` con') +rnPat (TypePat name) = + rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) -> + returnM (TypePat name', fvs) + +------------------------------ +rnConPat con (PrefixCon pats) + = lookupOccRn con `thenM` \ con' -> + mapFvRn rnPat pats `thenM` \ (pats', fvs) -> + returnM (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` con') -rnPat (TypePatIn name) - = rnHsTypeFVs (text "type pattern") name `thenRn` \ (name', fvs) -> - returnRn (TypePatIn name', fvs) +rnConPat con (RecCon rpats) + = lookupOccRn con `thenM` \ con' -> + rnRpats rpats `thenM` \ (rpats', fvs) -> + returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` con') + +rnConPat con (InfixCon pat1 pat2) + = lookupOccRn con `thenM` \ con' -> + rnPat pat1 `thenM` \ (pat1', fvs1) -> + rnPat pat2 `thenM` \ (pat2', fvs2) -> + + getModeRn `thenM` \ mode -> + -- See comments with rnExpr (OpApp ...) + (if isInterfaceMode mode + then returnM (ConPatIn con' (InfixCon pat1' pat2')) + else lookupFixityRn con' `thenM` \ fixity -> + mkConOpPatRn con' fixity pat1' pat2' + ) `thenM` \ pat' -> + returnM (pat', fvs1 `plusFV` fvs2 `addOneFV` con') \end{code} + ************************************************************************ * * \subsection{Match} @@ -176,10 +180,10 @@ rnPat (TypePatIn name) ************************************************************************ \begin{code} -rnMatch :: HsMatchContext RdrName -> RdrNameMatch -> RnMS (RenamedMatch, FreeVars) +rnMatch :: HsMatchContext RdrName -> RdrNameMatch -> RnM (RenamedMatch, FreeVars) rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) - = pushSrcLocRn (getMatchLoc match) $ + = addSrcLoc (getMatchLoc match) $ -- Bind pattern-bound type variables let @@ -197,25 +201,25 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) -- f x x = 1 bindLocalsFVRn doc_pat (collectPatsBinders pats) $ \ new_binders -> - mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) -> - rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) -> - doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts -> + mapFvRn rnPat pats `thenM` \ (pats', pat_fvs) -> + rnGRHSs grhss `thenM` \ (grhss', grhss_fvs) -> + doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> (case maybe_rhs_sig of - Nothing -> returnRn (Nothing, emptyFVs) - 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) - ) `thenRn` \ (maybe_rhs_sig', ty_fvs) -> + Nothing -> returnM (Nothing, emptyFVs) + Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenM` \ (ty', ty_fvs) -> + returnM (Just ty', ty_fvs) + | otherwise -> addErr (patSigErr ty) `thenM_` + returnM (Nothing, emptyFVs) + ) `thenM` \ (maybe_rhs_sig', ty_fvs) -> let binder_set = mkNameSet new_binders unused_binders = nameSetToList (binder_set `minusNameSet` grhss_fvs) all_fvs = grhss_fvs `plusFV` pat_fvs `plusFV` ty_fvs in - warnUnusedMatches unused_binders `thenRn_` + warnUnusedMatches unused_binders `thenM_` - returnRn (Match pats' maybe_rhs_sig' grhss', all_fvs) + returnM (Match pats' maybe_rhs_sig' grhss', all_fvs) -- The bindLocals and bindTyVars will remove the bound FVs \end{code} @@ -227,24 +231,24 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) %************************************************************************ \begin{code} -rnGRHSs :: RdrNameGRHSs -> RnMS (RenamedGRHSs, FreeVars) +rnGRHSs :: RdrNameGRHSs -> RnM (RenamedGRHSs, FreeVars) rnGRHSs (GRHSs grhss binds _) = rnBinds binds $ \ binds' -> - mapFvRn rnGRHS grhss `thenRn` \ (grhss', fvGRHSs) -> - returnRn (GRHSs grhss' binds' placeHolderType, fvGRHSs) + mapFvRn rnGRHS grhss `thenM` \ (grhss', fvGRHSs) -> + returnM (GRHSs grhss' binds' placeHolderType, fvGRHSs) rnGRHS (GRHS guarded locn) - = doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts -> - pushSrcLocRn locn $ + = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> + addSrcLoc locn $ (if not (opt_GlasgowExts || is_standard_guard guarded) then - addWarnRn (nonStdGuardErr guarded) + addWarn (nonStdGuardErr guarded) else - returnRn () - ) `thenRn_` + returnM () + ) `thenM_` - rnStmts guarded `thenRn` \ ((_, guarded'), fvs) -> - returnRn (GRHS guarded' locn, fvs) + rnStmts guarded `thenM` \ ((_, guarded'), fvs) -> + returnM (GRHS guarded' locn, fvs) where -- Standard Haskell 1.4 guards are just a single boolean -- expression, rather than a list of qualifiers as in the @@ -261,20 +265,20 @@ rnGRHS (GRHS guarded locn) %************************************************************************ \begin{code} -rnExprs :: [RdrNameHsExpr] -> RnMS ([RenamedHsExpr], FreeVars) +rnExprs :: [RdrNameHsExpr] -> RnM ([RenamedHsExpr], FreeVars) rnExprs ls = rnExprs' ls emptyUniqSet where - rnExprs' [] acc = returnRn ([], acc) + rnExprs' [] acc = returnM ([], acc) rnExprs' (expr:exprs) acc - = rnExpr expr `thenRn` \ (expr', fvExpr) -> + = rnExpr expr `thenM` \ (expr', fvExpr) -> -- Now we do a "seq" on the free vars because typically it's small -- or empty, especially in very long lists of constants let acc' = acc `plusFV` fvExpr in - (grubby_seqNameSet acc' rnExprs') exprs acc' `thenRn` \ (exprs', fvExprs) -> - returnRn (expr':exprs', fvExprs) + (grubby_seqNameSet acc' rnExprs') exprs acc' `thenM` \ (exprs', fvExprs) -> + returnM (expr':exprs', fvExprs) -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq grubby_seqNameSet ns result | isNullUFM ns = result @@ -284,216 +288,227 @@ grubby_seqNameSet ns result | isNullUFM ns = result Variables. We look up the variable and return the resulting name. \begin{code} -rnExpr :: RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars) +rnExpr :: RdrNameHsExpr -> RnM (RenamedHsExpr, FreeVars) rnExpr (HsVar v) - = lookupOccRn v `thenRn` \ name -> + = lookupOccRn v `thenM` \ name -> if name `hasKey` assertIdKey then -- We expand it to (GHCerr.assert__ location) mkAssertExpr else -- The normal case - returnRn (HsVar name, unitFV name) + returnM (HsVar name, unitFV name) rnExpr (HsIPVar v) - = newIPName v `thenRn` \ name -> + = newIPName v `thenM` \ name -> let fvs = case name of Linear _ -> mkFVs [splitName, fstName, sndName] Dupable _ -> emptyFVs in - returnRn (HsIPVar name, fvs) + returnM (HsIPVar name, fvs) rnExpr (HsLit lit) - = litFVs lit `thenRn` \ fvs -> - returnRn (HsLit lit, fvs) + = litFVs lit `thenM` \ fvs -> + returnM (HsLit lit, fvs) rnExpr (HsOverLit lit) - = rnOverLit lit `thenRn` \ (lit', fvs) -> - returnRn (HsOverLit lit', fvs) + = rnOverLit lit `thenM` \ (lit', fvs) -> + returnM (HsOverLit lit', fvs) rnExpr (HsLam match) - = rnMatch LambdaExpr match `thenRn` \ (match', fvMatch) -> - returnRn (HsLam match', fvMatch) + = rnMatch LambdaExpr match `thenM` \ (match', fvMatch) -> + returnM (HsLam match', fvMatch) rnExpr (HsApp fun arg) - = rnExpr fun `thenRn` \ (fun',fvFun) -> - rnExpr arg `thenRn` \ (arg',fvArg) -> - returnRn (HsApp fun' arg', fvFun `plusFV` fvArg) + = rnExpr fun `thenM` \ (fun',fvFun) -> + rnExpr arg `thenM` \ (arg',fvArg) -> + returnM (HsApp fun' arg', fvFun `plusFV` fvArg) rnExpr (OpApp e1 op _ e2) - = rnExpr e1 `thenRn` \ (e1', fv_e1) -> - rnExpr e2 `thenRn` \ (e2', fv_e2) -> - rnExpr op `thenRn` \ (op'@(HsVar op_name), fv_op) -> + = rnExpr e1 `thenM` \ (e1', fv_e1) -> + rnExpr e2 `thenM` \ (e2', fv_e2) -> + rnExpr op `thenM` \ (op'@(HsVar op_name), fv_op) -> -- Deal with fixity -- When renaming code synthesised from "deriving" declarations -- we're in Interface mode, and we should ignore fixity; assume -- that the deriving code generator got the association correct -- Don't even look up the fixity when in interface mode - getModeRn `thenRn` \ mode -> + getModeRn `thenM` \ mode -> (if isInterfaceMode mode - then returnRn (OpApp e1' op' defaultFixity e2') - else lookupFixityRn op_name `thenRn` \ fixity -> + then returnM (OpApp e1' op' defaultFixity e2') + else lookupFixityRn op_name `thenM` \ fixity -> mkOpAppRn e1' op' fixity e2' - ) `thenRn` \ final_e -> + ) `thenM` \ final_e -> - returnRn (final_e, + returnM (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) rnExpr (NegApp e _) - = rnExpr e `thenRn` \ (e', fv_e) -> - lookupSyntaxName negateName `thenRn` \ (neg_name, fv_neg) -> - mkNegAppRn e' neg_name `thenRn` \ final_e -> - returnRn (final_e, fv_e `plusFV` fv_neg) + = rnExpr e `thenM` \ (e', fv_e) -> + lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) -> + mkNegAppRn e' neg_name `thenM` \ final_e -> + returnM (final_e, fv_e `plusFV` fv_neg) rnExpr (HsPar e) - = rnExpr e `thenRn` \ (e', fvs_e) -> - returnRn (HsPar e', fvs_e) + = rnExpr e `thenM` \ (e', fvs_e) -> + returnM (HsPar e', fvs_e) + +-- Template Haskell extensions +rnExpr (HsBracket br_body) + = checkGHCI (thErr "bracket") `thenM_` + rnBracket br_body `thenM` \ (body', fvs_e) -> + returnM (HsBracket body', fvs_e `addOneFV` qTyConName) + -- We use the Q tycon as a proxy to haul in all the smart + -- constructors; see the hack in RnIfaces + +rnExpr (HsSplice n e) + = checkGHCI (thErr "splice") `thenM_` + getSrcLocM `thenM` \ loc -> + newLocalsRn [(n,loc)] `thenM` \ [n'] -> + rnExpr e `thenM` \ (e', fvs_e) -> + returnM (HsSplice n' e', fvs_e) rnExpr section@(SectionL expr op) - = rnExpr expr `thenRn` \ (expr', fvs_expr) -> - rnExpr op `thenRn` \ (op', fvs_op) -> - checkSectionPrec InfixL section op' expr' `thenRn_` - returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr) + = rnExpr expr `thenM` \ (expr', fvs_expr) -> + rnExpr op `thenM` \ (op', fvs_op) -> + checkSectionPrec InfixL section op' expr' `thenM_` + returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr) rnExpr section@(SectionR op expr) - = rnExpr op `thenRn` \ (op', fvs_op) -> - rnExpr expr `thenRn` \ (expr', fvs_expr) -> - checkSectionPrec InfixR section op' expr' `thenRn_` - returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr) + = rnExpr op `thenM` \ (op', fvs_op) -> + rnExpr expr `thenM` \ (expr', fvs_expr) -> + checkSectionPrec InfixR section op' expr' `thenM_` + returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr) rnExpr (HsCCall fun args may_gc is_casm _) -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls - = lookupOrigNames [] `thenRn` \ implicit_fvs -> - rnExprs args `thenRn` \ (args', fvs_args) -> - returnRn (HsCCall fun args' may_gc is_casm placeHolderType, + = rnExprs args `thenM` \ (args', fvs_args) -> + returnM (HsCCall fun args' may_gc is_casm placeHolderType, fvs_args `plusFV` mkFVs [cCallableClassName, cReturnableClassName, ioDataConName]) rnExpr (HsSCC lbl expr) - = rnExpr expr `thenRn` \ (expr', fvs_expr) -> - returnRn (HsSCC lbl expr', fvs_expr) + = rnExpr expr `thenM` \ (expr', fvs_expr) -> + returnM (HsSCC lbl expr', fvs_expr) rnExpr (HsCase expr ms src_loc) - = pushSrcLocRn src_loc $ - rnExpr expr `thenRn` \ (new_expr, e_fvs) -> - mapFvRn (rnMatch CaseAlt) ms `thenRn` \ (new_ms, ms_fvs) -> - returnRn (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs) + = addSrcLoc src_loc $ + rnExpr expr `thenM` \ (new_expr, e_fvs) -> + mapFvRn (rnMatch CaseAlt) ms `thenM` \ (new_ms, ms_fvs) -> + returnM (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs) rnExpr (HsLet binds expr) = rnBinds binds $ \ binds' -> - rnExpr expr `thenRn` \ (expr',fvExpr) -> - returnRn (HsLet binds' expr', fvExpr) + rnExpr expr `thenM` \ (expr',fvExpr) -> + returnM (HsLet binds' 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' is_with, fvExpr `plusFV` fvBinds) + = warnIf is_with withWarning `thenM_` + rnExpr expr `thenM` \ (expr',fvExpr) -> + rnIPBinds binds `thenM` \ (binds',fvBinds) -> + returnM (HsWith expr' binds' is_with, fvExpr `plusFV` fvBinds) rnExpr e@(HsDo do_or_lc stmts _ ty src_loc) - = pushSrcLocRn src_loc $ - rnStmts stmts `thenRn` \ ((_, stmts'), fvs) -> + = addSrcLoc src_loc $ + rnStmts stmts `thenM` \ ((_, stmts'), fvs) -> -- Check the statement list ends in an expression case last stmts' of { - ResultStmt _ _ -> returnRn () ; - _ -> addErrRn (doStmtListErr e) - } `thenRn_` + ResultStmt _ _ -> returnM () ; + _ -> addErr (doStmtListErr e) + } `thenM_` -- Generate the rebindable syntax for the monad (case do_or_lc of - DoExpr -> mapAndUnzipRn lookupSyntaxName monadNames - other -> returnRn ([], []) - ) `thenRn` \ (monad_names', monad_fvs) -> + DoExpr -> mapAndUnzipM lookupSyntaxName monadNames + other -> returnM ([], []) + ) `thenM` \ (monad_names', monad_fvs) -> - returnRn (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc, + returnM (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] + crossPName, zipPName] 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. + DoExpr -> emptyFVs rnExpr (ExplicitList _ exps) - = rnExprs exps `thenRn` \ (exps', fvs) -> - returnRn (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name) + = rnExprs exps `thenM` \ (exps', fvs) -> + returnM (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name) rnExpr (ExplicitPArr _ exps) - = rnExprs exps `thenRn` \ (exps', fvs) -> - returnRn (ExplicitPArr placeHolderType exps', + = rnExprs exps `thenM` \ (exps', fvs) -> + returnM (ExplicitPArr placeHolderType exps', fvs `addOneFV` toPName `addOneFV` parrTyCon_name) rnExpr (ExplicitTuple exps boxity) - = rnExprs exps `thenRn` \ (exps', fvs) -> - returnRn (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name) + = rnExprs exps `thenM` \ (exps', fvs) -> + returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name) where tycon_name = tupleTyCon_name boxity (length exps) rnExpr (RecordCon con_id rbinds) - = lookupOccRn con_id `thenRn` \ conname -> - rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) -> - returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname) + = lookupOccRn con_id `thenM` \ conname -> + rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) -> + returnM (RecordCon conname rbinds', fvRbinds `addOneFV` conname) rnExpr (RecordUpd expr rbinds) - = rnExpr expr `thenRn` \ (expr', fvExpr) -> - rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) -> - returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds) + = rnExpr expr `thenM` \ (expr', fvExpr) -> + rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) -> + returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds) rnExpr (ExprWithTySig expr pty) - = rnExpr expr `thenRn` \ (expr', fvExpr) -> - rnHsTypeFVs (text "an expression type signature") pty `thenRn` \ (pty', fvTy) -> - returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) + = rnExpr expr `thenM` \ (expr', fvExpr) -> + rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) -> + returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) + where + doc = text "In an expression type signature" rnExpr (HsIf p b1 b2 src_loc) - = pushSrcLocRn src_loc $ - rnExpr p `thenRn` \ (p', fvP) -> - rnExpr b1 `thenRn` \ (b1', fvB1) -> - rnExpr b2 `thenRn` \ (b2', fvB2) -> - returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2]) + = addSrcLoc src_loc $ + rnExpr p `thenM` \ (p', fvP) -> + rnExpr b1 `thenM` \ (b1', fvB1) -> + rnExpr b2 `thenM` \ (b2', fvB2) -> + returnM (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2]) rnExpr (HsType a) - = rnHsTypeFVs doc a `thenRn` \ (t, fvT) -> - returnRn (HsType t, fvT) + = rnHsTypeFVs doc a `thenM` \ (t, fvT) -> + returnM (HsType t, fvT) where - doc = text "in a type argument" + doc = text "In a type argument" rnExpr (ArithSeqIn seq) - = rn_seq seq `thenRn` \ (new_seq, fvs) -> - returnRn (ArithSeqIn new_seq, fvs `addOneFV` enumClassName) + = rn_seq seq `thenM` \ (new_seq, fvs) -> + returnM (ArithSeqIn new_seq, fvs `addOneFV` enumClassName) where rn_seq (From expr) - = rnExpr expr `thenRn` \ (expr', fvExpr) -> - returnRn (From expr', fvExpr) + = rnExpr expr `thenM` \ (expr', fvExpr) -> + returnM (From expr', fvExpr) rn_seq (FromThen expr1 expr2) - = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> - rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> - returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) + = rnExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenM` \ (expr2', fvExpr2) -> + returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) rn_seq (FromTo expr1 expr2) - = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> - rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> - returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) + = rnExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenM` \ (expr2', fvExpr2) -> + returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) rn_seq (FromThenTo expr1 expr2 expr3) - = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> - rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> - rnExpr expr3 `thenRn` \ (expr3', fvExpr3) -> - returnRn (FromThenTo expr1' expr2' expr3', + = rnExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenM` \ (expr2', fvExpr2) -> + rnExpr expr3 `thenM` \ (expr3', fvExpr3) -> + returnM (FromThenTo expr1' expr2' expr3', plusFVs [fvExpr1, fvExpr2, fvExpr3]) rnExpr (PArrSeqIn seq) - = rn_seq seq `thenRn` \ (new_seq, fvs) -> - returnRn (PArrSeqIn new_seq, + = rn_seq seq `thenM` \ (new_seq, fvs) -> + returnM (PArrSeqIn new_seq, fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName]) where @@ -503,14 +518,14 @@ rnExpr (PArrSeqIn seq) rn_seq (FromThen _ _) = panic "RnExpr.rnExpr: Infinite parallel array!" rn_seq (FromTo expr1 expr2) - = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> - rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> - returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) + = rnExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenM` \ (expr2', fvExpr2) -> + returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) rn_seq (FromThenTo expr1 expr2 expr3) - = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> - rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> - rnExpr expr3 `thenRn` \ (expr3', fvExpr3) -> - returnRn (FromThenTo expr1' expr2' expr3', + = rnExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenM` \ (expr2', fvExpr2) -> + rnExpr expr3 `thenM` \ (expr3', fvExpr3) -> + returnM (FromThenTo expr1' expr2' expr3', plusFVs [fvExpr1, fvExpr2, fvExpr3]) \end{code} @@ -519,14 +534,14 @@ 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@EWildPat = addErr (patSynErr e) `thenM_` + returnM (EWildPat, emptyFVs) -rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e) `thenRn_` - returnRn (EWildPat, emptyFVs) +rnExpr e@(EAsPat _ _) = addErr (patSynErr e) `thenM_` + returnM (EWildPat, emptyFVs) -rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_` - returnRn (EWildPat, emptyFVs) +rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_` + returnM (EWildPat, emptyFVs) \end{code} @@ -539,32 +554,32 @@ rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_` \begin{code} rnRbinds str rbinds - = mapRn_ field_dup_err dup_fields `thenRn_` - mapFvRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind) -> - returnRn (rbinds', fvRbind) + = mappM_ field_dup_err dup_fields `thenM_` + mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) -> + returnM (rbinds', fvRbind) where - (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ] + (_, dup_fields) = removeDups compare [ f | (f,_) <- rbinds ] - field_dup_err dups = addErrRn (dupFieldErr str dups) + field_dup_err dups = addErr (dupFieldErr str dups) - rn_rbind (field, expr, pun) - = lookupGlobalOccRn field `thenRn` \ fieldname -> - rnExpr expr `thenRn` \ (expr', fvExpr) -> - returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname) + rn_rbind (field, expr) + = lookupGlobalOccRn field `thenM` \ fieldname -> + rnExpr expr `thenM` \ (expr', fvExpr) -> + returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname) rnRpats rpats - = mapRn_ field_dup_err dup_fields `thenRn_` - mapFvRn rn_rpat rpats `thenRn` \ (rpats', fvs) -> - returnRn (rpats', fvs) + = mappM_ field_dup_err dup_fields `thenM_` + mapFvRn rn_rpat rpats `thenM` \ (rpats', fvs) -> + returnM (rpats', fvs) where - (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ] + (_, dup_fields) = removeDups compare [ f | (f,_) <- rpats ] - field_dup_err dups = addErrRn (dupFieldErr "pattern" dups) + field_dup_err dups = addErr (dupFieldErr "pattern" dups) - rn_rpat (field, pat, pun) - = lookupGlobalOccRn field `thenRn` \ fieldname -> - rnPat pat `thenRn` \ (pat', fvs) -> - returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname) + rn_rpat (field, pat) + = lookupGlobalOccRn field `thenM` \ fieldname -> + rnPat pat `thenM` \ (pat', fvs) -> + returnM ((fieldname, pat'), fvs `addOneFV` fieldname) \end{code} %************************************************************************ @@ -574,13 +589,34 @@ rnRpats rpats %************************************************************************ \begin{code} -rnIPBinds [] = returnRn ([], emptyFVs) +rnIPBinds [] = returnM ([], 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) + = newIPName n `thenM` \ name -> + rnExpr expr `thenM` \ (expr',fvExpr) -> + rnIPBinds binds `thenM` \ (binds',fvBinds) -> + returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds) + +\end{code} + +%************************************************************************ +%* * + Template Haskell brackets +%* * +%************************************************************************ +\begin{code} +rnBracket (ExpBr e) = rnExpr e `thenM` \ (e', fvs) -> + returnM (ExpBr e', fvs) +rnBracket (PatBr p) = rnPat p `thenM` \ (p', fvs) -> + returnM (PatBr p', fvs) +rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) -> + returnM (TypBr t', fvs) + where + doc = ptext SLIT("In a Template-Haskell quoted type") +rnBracket (DecBr ds) = rnSrcDecls ds `thenM` \ (tcg_env, ds', fvs) -> + -- Discard the tcg_env; it contains the extended global RdrEnv + -- because there is no scope that these decls cover (yet!) + returnM (DecBr ds', fvs) \end{code} %************************************************************************ @@ -599,66 +635,66 @@ Quals. \begin{code} rnStmts :: [RdrNameStmt] - -> RnMS (([Name], [RenamedStmt]), FreeVars) + -> RnM (([Name], [RenamedStmt]), FreeVars) rnStmts [] - = returnRn (([], []), emptyFVs) + = returnM (([], []), emptyFVs) rnStmts (stmt:stmts) - = getLocalNameEnv `thenRn` \ name_env -> + = getLocalRdrEnv `thenM` \ name_env -> rnStmt stmt $ \ stmt' -> - rnStmts stmts `thenRn` \ ((binders, stmts'), fvs) -> - returnRn ((binders, stmt' : stmts'), fvs) + rnStmts stmts `thenM` \ ((binders, stmts'), fvs) -> + returnM ((binders, stmt' : stmts'), fvs) rnStmt :: RdrNameStmt - -> (RenamedStmt -> RnMS (([Name], a), FreeVars)) - -> RnMS (([Name], a), FreeVars) + -> (RenamedStmt -> RnM (([Name], a), FreeVars)) + -> RnM (([Name], a), FreeVars) -- The thing list of names returned is the list returned by the -- thing_inside, plus the binders of the arguments stmt rnStmt (ParStmt stmtss) thing_inside - = mapFvRn rnStmts stmtss `thenRn` \ (bndrstmtss, fv_stmtss) -> + = mapFvRn rnStmts stmtss `thenM` \ (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) + = checkErr (null (intersectBy eqOcc all_bndrs bndrs)) err `thenM_` + returnM (bndrs ++ all_bndrs) eqOcc n1 n2 = nameOccName n1 == nameOccName n2 err = text "duplicate binding in parallel list comprehension" in - foldlRn checkBndrs [] binderss `thenRn` \ new_binders -> + foldlM checkBndrs [] binderss `thenM` \ new_binders -> bindLocalNamesFV new_binders $ - thing_inside (ParStmtOut bndrstmtss)`thenRn` \ ((rest_bndrs, result), fv_rest) -> - returnRn ((new_binders ++ rest_bndrs, result), fv_stmtss `plusFV` fv_rest) + thing_inside (ParStmtOut bndrstmtss)`thenM` \ ((rest_bndrs, result), fv_rest) -> + returnM ((new_binders ++ rest_bndrs, result), fv_stmtss `plusFV` fv_rest) rnStmt (BindStmt pat expr src_loc) thing_inside - = pushSrcLocRn src_loc $ - rnExpr expr `thenRn` \ (expr', fv_expr) -> + = addSrcLoc src_loc $ + rnExpr expr `thenM` \ (expr', fv_expr) -> bindPatSigTyVars (collectSigTysFromPat pat) $ bindLocalsFVRn doc (collectPatBinders pat) $ \ new_binders -> - rnPat pat `thenRn` \ (pat', fv_pat) -> - thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ ((rest_binders, result), fvs) -> - returnRn ((new_binders ++ rest_binders, result), + rnPat pat `thenM` \ (pat', fv_pat) -> + thing_inside (BindStmt pat' expr' src_loc) `thenM` \ ((rest_binders, result), fvs) -> + returnM ((new_binders ++ rest_binders, result), fv_expr `plusFV` fvs `plusFV` fv_pat) where doc = text "In a pattern in 'do' binding" rnStmt (ExprStmt expr _ src_loc) thing_inside - = pushSrcLocRn src_loc $ - rnExpr expr `thenRn` \ (expr', fv_expr) -> - thing_inside (ExprStmt expr' placeHolderType src_loc) `thenRn` \ (result, fvs) -> - returnRn (result, fv_expr `plusFV` fvs) + = addSrcLoc src_loc $ + rnExpr expr `thenM` \ (expr', fv_expr) -> + thing_inside (ExprStmt expr' placeHolderType src_loc) `thenM` \ (result, fvs) -> + returnM (result, fv_expr `plusFV` fvs) rnStmt (ResultStmt expr src_loc) thing_inside - = pushSrcLocRn src_loc $ - rnExpr expr `thenRn` \ (expr', fv_expr) -> - thing_inside (ResultStmt expr' src_loc) `thenRn` \ (result, fvs) -> - returnRn (result, fv_expr `plusFV` fvs) + = addSrcLoc src_loc $ + rnExpr expr `thenM` \ (expr', fv_expr) -> + thing_inside (ResultStmt expr' src_loc) `thenM` \ (result, fvs) -> + returnM (result, fv_expr `plusFV` fvs) rnStmt (LetStmt binds) thing_inside = rnBinds binds $ \ binds' -> let new_binders = collectHsBinders binds' in - thing_inside (LetStmt binds') `thenRn` \ ((rest_binders, result), fvs) -> - returnRn ((new_binders ++ rest_binders, result), fvs ) + thing_inside (LetStmt binds') `thenM` \ ((rest_binders, result), fvs) -> + returnM ((new_binders ++ rest_binders, result), fvs ) \end{code} %************************************************************************ @@ -682,18 +718,18 @@ mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged -> RenamedHsExpr -> Fixity -- Operator and fixity -> RenamedHsExpr -- Right operand (not an OpApp, but might -- be a NegApp) - -> RnMS RenamedHsExpr + -> RnM RenamedHsExpr --------------------------- -- (e11 `op1` e12) `op2` e2 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2 | nofix_error - = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_` - returnRn (OpApp e1 op2 fix2 e2) + = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` + returnM (OpApp e1 op2 fix2 e2) | associate_right - = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e -> - returnRn (OpApp e11 op1 fix1 new_e) + = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e -> + returnM (OpApp e11 op1 fix1 new_e) where (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -701,12 +737,12 @@ mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2 -- (- neg_arg) `op` e2 mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2 | nofix_error - = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenRn_` - returnRn (OpApp e1 op2 fix2 e2) + = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_` + returnM (OpApp e1 op2 fix2 e2) | associate_right - = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e -> - returnRn (NegApp new_e neg_name) + = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e -> + returnM (NegApp new_e neg_name) where (nofix_error, associate_right) = compareFixity negateFixity fix2 @@ -714,8 +750,8 @@ mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2 -- e1 `op` - neg_arg mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _) -- 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) + = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_` + returnM (OpApp e1 op1 fix1 e2) where (_, associate_right) = compareFixity fix1 negateFixity @@ -725,7 +761,7 @@ mkOpAppRn e1 op fix e2 -- Default case, no rearrangment = ASSERT2( right_op_ok fix e2, ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2 ) - returnRn (OpApp e1 op fix e2) + returnM (OpApp e1 op fix e2) -- Parser left-associates everything, but -- derived instances may have correctly-associated things to @@ -741,60 +777,62 @@ right_op_ok fix1 other mkNegAppRn neg_arg neg_name = #ifdef DEBUG - getModeRn `thenRn` \ mode -> + getModeRn `thenM` \ mode -> ASSERT( not_op_app mode neg_arg ) #endif - returnRn (NegApp neg_arg neg_name) + returnM (NegApp neg_arg neg_name) not_op_app SourceMode (OpApp _ _ _ _) = False not_op_app mode other = True \end{code} \begin{code} -mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat - -> RnMS RenamedPat +mkConOpPatRn :: Name -> Fixity -> RenamedPat -> RenamedPat + -> RnM RenamedPat -mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12) - op2 fix2 p2 - | nofix_error - = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_` - returnRn (ConOpPatIn p1 op2 fix2 p2) - - | associate_right - = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p -> - returnRn (ConOpPatIn p11 op1 fix1 new_p) - - where - (nofix_error, associate_right) = compareFixity fix1 fix2 +mkConOpPatRn op2 fix2 p1@(ConPatIn op1 (InfixCon p11 p12)) p2 + = lookupFixityRn op1 `thenM` \ fix1 -> + let + (nofix_error, associate_right) = compareFixity fix1 fix2 + in + if nofix_error then + addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` + returnM (ConPatIn op2 (InfixCon p1 p2)) + else + if associate_right then + mkConOpPatRn op2 fix2 p12 p2 `thenM` \ new_p -> + returnM (ConPatIn op1 (InfixCon p11 new_p)) + else + returnM (ConPatIn op2 (InfixCon p1 p2)) -mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment +mkConOpPatRn op fix p1 p2 -- Default case, no rearrangment = ASSERT( not_op_pat p2 ) - returnRn (ConOpPatIn p1 op fix p2) + returnM (ConPatIn op (InfixCon p1 p2)) -not_op_pat (ConOpPatIn _ _ _ _) = False -not_op_pat other = True +not_op_pat (ConPatIn _ (InfixCon _ _)) = False +not_op_pat other = True \end{code} \begin{code} -checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS () +checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnM () checkPrecMatch False fn match - = returnRn () + = returnM () checkPrecMatch True op (Match (p1:p2:_) _ _) -- True indicates an infix lhs - = getModeRn `thenRn` \ mode -> + = getModeRn `thenM` \ mode -> -- See comments with rnExpr (OpApp ...) if isInterfaceMode mode - then returnRn () - else checkPrec op p1 False `thenRn_` + then returnM () + else checkPrec op p1 False `thenM_` checkPrec op p2 True checkPrecMatch True op _ = panic "checkPrecMatch" -checkPrec op (ConOpPatIn _ op1 _ _) right - = lookupFixityRn op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> - lookupFixityRn op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) -> +checkPrec op (ConPatIn op1 (InfixCon _ _)) right + = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) -> + lookupFixityRn op1 `thenM` \ op1_fix@(Fixity op1_prec op1_dir) -> let inf_ok = op1_prec > op_prec || (op1_prec == op_prec && @@ -805,10 +843,10 @@ checkPrec op (ConOpPatIn _ op1 _ _) right info1 = (ppr_op op1, op1_fix) (infol, infor) = if right then (info, info1) else (info1, info) in - checkRn inf_ok (precParseErr infol infor) + checkErr inf_ok (precParseErr infol infor) checkPrec op pat right - = returnRn () + = returnM () -- Check precedence of (arg op) or (op arg) respectively -- If arg is itself an operator application, then either @@ -818,12 +856,12 @@ checkSectionPrec direction 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 () + other -> returnM () where HsVar op_name = op go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc) - = lookupFixityRn op_name `thenRn` \ op_fix@(Fixity op_prec _) -> - checkRn (op_prec < arg_prec + = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) -> + checkErr (op_prec < arg_prec || op_prec == arg_prec && direction == assoc) (sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section) @@ -842,24 +880,24 @@ are made available. \begin{code} litFVs (HsChar c) - = checkRn (inCharRange c) (bogusCharError c) `thenRn_` - 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) = returnRn (unitFV cCallableClassName) + = checkErr (inCharRange c) (bogusCharError c) `thenM_` + returnM (unitFV charTyCon_name) + +litFVs (HsCharPrim c) = returnM (unitFV (getName charPrimTyCon)) +litFVs (HsString s) = returnM (mkFVs [listTyCon_name, charTyCon_name]) +litFVs (HsStringPrim s) = returnM (unitFV (getName addrPrimTyCon)) +litFVs (HsInt i) = returnM (unitFV (getName intTyCon)) +litFVs (HsIntPrim i) = returnM (unitFV (getName intPrimTyCon)) +litFVs (HsFloatPrim f) = returnM (unitFV (getName floatPrimTyCon)) +litFVs (HsDoublePrim d) = returnM (unitFV (getName doublePrimTyCon)) +litFVs (HsLitLit l bogus_ty) = returnM (unitFV cCallableClassName) litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear -- in post-typechecker translations rnOverLit (HsIntegral i _) - = lookupSyntaxName fromIntegerName `thenRn` \ (from_integer_name, fvs) -> + = lookupSyntaxName fromIntegerName `thenM` \ (from_integer_name, fvs) -> if inIntRange i then - returnRn (HsIntegral i from_integer_name, fvs) + returnM (HsIntegral i from_integer_name, fvs) else let extra_fvs = mkFVs [plusIntegerName, timesIntegerName] -- Big integer literals are built, using + and *, @@ -868,10 +906,10 @@ rnOverLit (HsIntegral i _) -- they are used to construct the argument to fromInteger, -- which is the rebindable one.] in - returnRn (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs) + returnM (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs) rnOverLit (HsFractional i _) - = lookupSyntaxName fromRationalName `thenRn` \ (from_rat_name, fvs) -> + = lookupSyntaxName fromRationalName `thenM` \ (from_rat_name, fvs) -> let extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName] -- We have to make sure that the Ratio type is imported with @@ -882,7 +920,7 @@ rnOverLit (HsFractional i _) -- 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 `plusFV` extra_fvs) + returnM (HsFractional i from_rat_name, fvs `plusFV` extra_fvs) \end{code} %************************************************************************ @@ -892,30 +930,30 @@ rnOverLit (HsFractional i _) %************************************************************************ \begin{code} -mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars) -mkAssertExpr = - lookupOrigName assertErr_RDR `thenRn` \ name -> - getSrcLocRn `thenRn` \ sloc -> +mkAssertExpr :: RnM (RenamedHsExpr, FreeVars) +mkAssertExpr + = getSrcLocM `thenM` \ sloc -> -- if we're ignoring asserts, return (\ _ e -> e) -- if not, return (assertError "src-loc") - if opt_IgnoreAsserts then - getUniqRn `thenRn` \ uniq -> - let - vname = mkSystemName uniq FSLIT("v") - expr = HsLam ignorePredMatch - loc = nameSrcLoc vname - ignorePredMatch = mkSimpleMatch [WildPatIn, VarPatIn vname] (HsVar vname) placeHolderType loc - in - returnRn (expr, unitFV name) - else - let - expr = - HsApp (HsVar name) + if opt_IgnoreAsserts then + newUnique `thenM` \ uniq -> + let + vname = mkSystemName uniq FSLIT("v") + expr = HsLam ignorePredMatch + loc = nameSrcLoc vname + ignorePredMatch = mkSimpleMatch [WildPat placeHolderType, VarPat vname] + (HsVar vname) placeHolderType loc + in + returnM (expr, emptyFVs) + else + let + expr = + HsApp (HsVar assertName) (HsLit (HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc)))))) - in - returnRn (expr, unitFV name) + in + returnM (expr, unitFV assertName) \end{code} %************************************************************************ @@ -946,6 +984,10 @@ patSynErr e = sep [ptext SLIT("Pattern syntax in expression context:"), nest 4 (ppr e)] +thErr what + = ptext SLIT("Template Haskell") <+> text what <+> + ptext SLIT("illegal in a stage-1 compiler") + doStmtListErr e = sep [ptext SLIT("`do' statements must end in expression:"), nest 4 (ppr e)] |