#include "HsVersions.h"
+#ifdef GHCI
+import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr )
+#endif /* GHCI */
+
import RnSource ( rnSrcDecls, rnSplice, checkTH )
import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS,
rnMatchGroup, makeMiniFixityEnv)
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 )
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 )
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}
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}
= 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) ->
convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
--- gaw 2004
convertOpFormsCmd (HsCase exp matches)
= HsCase exp (convertOpFormsMatch matches)
-- 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) <-
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 <-
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))
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}
-- 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 =
-- 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,
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 =
-- 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)
%************************************************************************
\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}
-
-
projects / ghc-hetmet.git / blobdiff