X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnExpr.lhs;h=71da0f11c87f6cd5d1cf98a7a1b6b0d1fa7af628;hp=a496c66daa3f24f2e4a4094c720a5c98273b82dd;hb=a27c5f77da8b3b3f00f9902b69a504460f234e8c;hpb=67cb409159fa9136dff942b8baaec25909416022 diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index a496c66..71da0f1 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -23,6 +23,10 @@ module RnExpr ( #include "HsVersions.h" +#ifdef GHCI +import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr ) +#endif /* GHCI */ + import RnSource ( rnSrcDecls, rnSplice, checkTH ) import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS, rnMatchGroup, makeMiniFixityEnv) @@ -30,10 +34,9 @@ import HsSyn import TcRnMonad import RnEnv import HscTypes ( availNames ) -import RnNames ( getLocalDeclBinders, extendRdrEnvRn ) import RnTypes ( rnHsTypeFVs, mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec) -import RnPat (rnOverLit, rnPatsAndThen_LocalRightwards, rnBindPat, +import RnPat (rnQuasiQuote, rnOverLit, rnPatsAndThen_LocalRightwards, rnBindPat, localRecNameMaker, rnLit, rnHsRecFields_Con, rnHsRecFields_Update, checkTupSize) import RdrName ( mkRdrUnqual ) @@ -46,11 +49,10 @@ import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName, import Name ( Name, nameOccName, nameModule, nameIsLocalOrFrom ) import NameSet -import UniqFM +import LazyUniqFM import RdrName ( RdrName, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals ) import LoadIface ( loadInterfaceForName ) -import UniqFM ( isNullUFM ) -import UniqSet ( emptyUniqSet ) +import UniqSet ( isEmptyUniqSet, emptyUniqSet ) import List ( nub ) import Util ( isSingleton ) import ListSetOps ( removeDups ) @@ -60,9 +62,31 @@ import SrcLoc ( Located(..), unLoc, getLoc, noLoc ) import FastString import List ( unzip4 ) +import Control.Monad \end{code} +\begin{code} +-- XXX +thenM :: Monad a => a b -> (b -> a c) -> a c +thenM = (>>=) + +thenM_ :: Monad a => a b -> a c -> a c +thenM_ = (>>) + +returnM :: Monad m => a -> m a +returnM = return + +mappM :: (Monad m) => (a -> m b) -> [a] -> m [b] +mappM = mapM + +mappM_ :: (Monad m) => (a -> m b) -> [a] -> m () +mappM_ = mapM_ + +checkM :: Monad m => Bool -> m () -> m () +checkM = unless +\end{code} + %************************************************************************ %* * \subsubsection{Expressions} @@ -86,7 +110,7 @@ rnExprs ls = rnExprs' ls emptyUniqSet 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 +grubby_seqNameSet ns result | isEmptyUniqSet ns = result | otherwise = result \end{code} @@ -175,6 +199,16 @@ rnExpr e@(HsSpliceE splice) = rnSplice splice `thenM` \ (splice', fvs) -> returnM (HsSpliceE splice', fvs) +#ifndef GHCI +rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e) +#else +rnExpr e@(HsQuasiQuoteE qq) + = rnQuasiQuote qq `thenM` \ (qq', fvs_qq) -> + runQuasiQuoteExpr qq' `thenM` \ (L _ expr') -> + rnExpr expr' `thenM` \ (expr'', fvs_expr) -> + returnM (expr'', fvs_qq `plusFV` fvs_expr) +#endif /* GHCI */ + rnExpr section@(SectionL expr op) = rnLExpr expr `thenM` \ (expr', fvs_expr) -> rnLExpr op `thenM` \ (op', fvs_op) -> @@ -278,6 +312,7 @@ We return a (bogus) EWildPat in each case. \begin{code} rnExpr e@EWildPat = patSynErr e rnExpr e@(EAsPat {}) = patSynErr e +rnExpr e@(EViewPat {}) = patSynErr e rnExpr e@(ELazyPat {}) = patSynErr e \end{code} @@ -376,7 +411,6 @@ convertOpFormsCmd (OpApp c1 op fixity c2) convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c) --- gaw 2004 convertOpFormsCmd (HsCase exp matches) = HsCase exp (convertOpFormsMatch matches) @@ -623,35 +657,32 @@ rnStmt ctxt (BindStmt pat expr _ _) thing_inside -- fv_expr shouldn't really be filtered by the rnPatsAndThen -- but it does not matter because the names are unique -rnStmt ctxt (LetStmt binds) thing_inside = do - checkErr (ok ctxt binds) (badIpBinds (ptext SLIT("a parallel list comprehension:")) binds) - rnLocalBindsAndThen binds $ \binds' -> do - (thing, fvs) <- thing_inside - return ((LetStmt binds', thing), fvs) - where - -- We do not allow implicit-parameter bindings in a parallel - -- list comprehension. I'm not sure what it might mean. - ok (ParStmtCtxt _) (HsIPBinds _) = False - ok _ _ = True +rnStmt ctxt (LetStmt binds) thing_inside + = do { checkLetStmt ctxt binds + ; rnLocalBindsAndThen binds $ \binds' -> do + { (thing, fvs) <- thing_inside + ; return ((LetStmt binds', thing), fvs) } } rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside - = - rn_rec_stmts_and_then rec_stmts $ \ segs -> - thing_inside `thenM` \ (thing, fvs) -> - let - segs_w_fwd_refs = addFwdRefs segs - (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs - later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs) - fwd_vars = nameSetToList (plusFVs fs) - uses = plusFVs us - rec_stmt = RecStmt rec_stmts' later_vars fwd_vars [] emptyLHsBinds - in - returnM ((rec_stmt, thing), uses `plusFV` fvs) - where - doc = text "In a recursive do statement" + = do { checkRecStmt ctxt + ; rn_rec_stmts_and_then rec_stmts $ \ segs -> do + { (thing, fvs) <- thing_inside + ; let + segs_w_fwd_refs = addFwdRefs segs + (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs + later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs) + fwd_vars = nameSetToList (plusFVs fs) + uses = plusFVs us + rec_stmt = RecStmt rec_stmts' later_vars fwd_vars [] emptyLHsBinds + ; return ((rec_stmt, thing), uses `plusFV` fvs) } } + +rnStmt ctxt (ParStmt segs) thing_inside + = do { checkParStmt ctxt + ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside + ; return ((ParStmt segs', thing), fvs) } rnStmt ctxt (TransformStmt (stmts, _) usingExpr maybeByExpr) thing_inside = do - checkIsTransformableListComp ctxt + checkTransformStmt ctxt (usingExpr', fv_usingExpr) <- rnLExpr usingExpr ((stmts', binders, (maybeByExpr', thing)), fvs) <- @@ -669,7 +700,7 @@ rnStmt ctxt (TransformStmt (stmts, _) usingExpr maybeByExpr) thing_inside = do return (Just expr', fv_expr) rnStmt ctxt (GroupStmt (stmts, _) groupByClause) thing_inside = do - checkIsTransformableListComp ctxt + checkTransformStmt ctxt -- We must rename the using expression in the context before the transform is begun groupByClauseAction <- @@ -727,13 +758,6 @@ rnStmt ctxt (GroupStmt (stmts, _) groupByClause) thing_inside = do traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr usedBinderMap) return ((GroupStmt (stmts', usedBinderMap) groupByClause', thing), fvs) -rnStmt ctxt (ParStmt segs) thing_inside - = do { parallel_list_comp <- doptM Opt_ParallelListComp - ; checkM parallel_list_comp parStmtErr - ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside - ; return ((ParStmt segs', thing), fvs) } - - rnNormalStmtsAndFindUsedBinders :: HsStmtContext Name -> [LStmt RdrName] -> ([Name] -> RnM (thing, FreeVars)) @@ -792,21 +816,6 @@ rnParallelStmts ctxt segs thing_inside = do cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 dupErr vs = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:") <+> quotes (ppr (head vs))) - - -checkIsTransformableListComp :: HsStmtContext Name -> RnM () -checkIsTransformableListComp ctxt = do - -- Ensure we are really within a list comprehension because otherwise the - -- desugarer will break when we come to operate on a parallel array - checkM (notParallelArray ctxt) transformStmtOutsideListCompErr - - -- Ensure the user has turned the correct flag on - transform_list_comp <- doptM Opt_TransformListComp - checkM transform_list_comp transformStmtErr - where - notParallelArray PArrComp = False - notParallelArray _ = True - \end{code} @@ -876,22 +885,22 @@ rn_rec_stmts_and_then :: [LStmt RdrName] -- the FreeVars of the Segments -> ([Segment (LStmt Name)] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -rn_rec_stmts_and_then s cont = do - -- (A) make the mini fixity env for all of the stmts - fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s) - - -- (B) do the LHSes - new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s +rn_rec_stmts_and_then s cont + = do { -- (A) Make the mini fixity env for all of the stmts + fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s) - -- bring them and their fixities into scope - let bound_names = map unLoc $ collectLStmtsBinders (map fst new_lhs_and_fv) - bindLocalNamesFV_WithFixities bound_names fix_env $ - warnUnusedLocalBinds bound_names $ do + -- (B) Do the LHSes + ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s - -- (C) do the right-hand-sides and thing-inside - segs <- rn_rec_stmts bound_names new_lhs_and_fv - cont segs + -- ...bring them and their fixities into scope + ; let bound_names = map unLoc $ collectLStmtsBinders (map fst new_lhs_and_fv) + ; bindLocalNamesFV_WithFixities bound_names fix_env $ do + -- (C) do the right-hand-sides and thing-inside + { segs <- rn_rec_stmts bound_names new_lhs_and_fv + ; (res, fvs) <- cont segs + ; warnUnusedLocalBinds bound_names fvs + ; return (res, fvs) }} -- get all the fixity decls in any Let stmt collectRecStmtsFixities l = @@ -904,8 +913,7 @@ collectRecStmtsFixities l = -- left-hand sides -rn_rec_stmt_lhs :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind - -- these fixities need to be brought into scope with the names +rn_rec_stmt_lhs :: MiniFixityEnv -> LStmt RdrName -- rename LHS, and return its FVs -- Warning: we will only need the FreeVars below in the case of a BindStmt, @@ -946,8 +954,7 @@ rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt _ _ _)) -- Syntactically illegal in m rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt _ _)) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt" (ppr stmt) -rn_rec_stmts_lhs :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind - -- these fixities need to be brought into scope with the names +rn_rec_stmts_lhs :: MiniFixityEnv -> [LStmt RdrName] -> RnM [(LStmtLR Name RdrName, FreeVars)] rn_rec_stmts_lhs fix_env stmts = @@ -957,7 +964,7 @@ rn_rec_stmts_lhs fix_env stmts = -- First do error checking: we need to check for dups here because we -- don't bind all of the variables from the Stmt at once -- with bindLocatedLocals. - checkDupNames doc boundNames + checkDupRdrNames doc boundNames mappM (rn_rec_stmt_lhs fix_env) stmts `thenM` \ ls -> returnM (concat ls) @@ -1141,19 +1148,54 @@ mkAssertErrorExpr %************************************************************************ \begin{code} -patSynErr e = do { addErr (sep [ptext SLIT("Pattern syntax in expression context:"), - nest 4 (ppr e)]) - ; return (EWildPat, emptyFVs) } +---------------------- +-- Checking when a particular Stmt is ok +checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM () +checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext SLIT("a parallel list comprehension:")) binds) +checkLetStmt _ctxt _binds = return () + -- We do not allow implicit-parameter bindings in a parallel + -- list comprehension. I'm not sure what it might mean. -parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -XParallelListComp")) +--------- +checkRecStmt :: HsStmtContext Name -> RnM () +checkRecStmt (MDoExpr {}) = return () -- Recursive stmt ok in 'mdo' +checkRecStmt (DoExpr {}) = return () -- ..and in 'do' but only because of arrows: + -- proc x -> do { ...rec... } + -- We don't have enough context to distinguish this situation here + -- so we leave it to the type checker +checkRecStmt ctxt = addErr msg + where + msg = ptext SLIT("Illegal 'rec' stmt in") <+> pprStmtContext ctxt -transformStmtErr = addErr (ptext SLIT("Illegal transform or grouping list comprehension: use -XTransformListComp")) -transformStmtOutsideListCompErr = addErr (ptext SLIT("Currently you may only use transform or grouping comprehensions within list comprehensions, not parallel array comprehensions")) +--------- +checkParStmt :: HsStmtContext Name -> RnM () +checkParStmt ctxt + = do { parallel_list_comp <- doptM Opt_ParallelListComp + ; checkErr parallel_list_comp msg } + where + msg = ptext SLIT("Illegal parallel list comprehension: use -XParallelListComp") + +--------- +checkTransformStmt :: HsStmtContext Name -> RnM () +checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the + -- desugarer will break when we come to operate on a parallel array + = do { transform_list_comp <- doptM Opt_TransformListComp + ; checkErr transform_list_comp msg } + where + msg = ptext SLIT("Illegal transform or grouping list comprehension: use -XTransformListComp") +checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension +checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension +checkTransformStmt ctxt = addErr msg + where + msg = ptext SLIT("Illegal transform or grouping in") <+> pprStmtContext ctxt + +--------- +patSynErr e = do { addErr (sep [ptext SLIT("Pattern syntax in expression context:"), + nest 4 (ppr e)]) + ; return (EWildPat, emptyFVs) } badIpBinds what binds = hang (ptext SLIT("Implicit-parameter bindings illegal in") <+> what) 2 (ppr binds) \end{code} - -