import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr )
#endif /* GHCI */
-import RnSource ( rnSrcDecls, rnSplice, checkTH )
+import RnSource ( rnSrcDecls )
import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS,
rnMatchGroup, makeMiniFixityEnv)
import HsSyn
import TcRnMonad
import TcEnv ( thRnBrack )
import RnEnv
-import RnTypes ( rnHsTypeFVs,
+import RnTypes ( rnHsTypeFVs, rnSplice, checkTH,
mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
import RnPat
import DynFlags ( DynFlag(..) )
import RdrName
import LoadIface ( loadInterfaceForName )
import UniqSet
-import List ( nub )
+import Data.List
import Util ( isSingleton )
import ListSetOps ( removeDups )
import Maybes ( expectJust )
import Outputable
import SrcLoc
import FastString
-
-import List ( unzip4 )
import Control.Monad
\end{code}
= rnExprs exps `thenM` \ (exps', fvs) ->
return (ExplicitPArr placeHolderType exps', fvs)
-rnExpr (ExplicitTuple exps boxity)
- = checkTupSize (length exps) `thenM_`
- rnExprs exps `thenM` \ (exps', fvs) ->
- return (ExplicitTuple exps' boxity, fvs)
+rnExpr (ExplicitTuple tup_args boxity)
+ = do { checkTupleSection tup_args
+ ; checkTupSize (length tup_args)
+ ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
+ ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
+ where
+ rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) }
+ rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs)
rnExpr (RecordCon con_id _ rbinds)
= do { conname <- lookupLocatedOccRn con_id
- ; (rbinds', fvRbinds) <- rnHsRecFields_Con conname rnLExpr rbinds
+ ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
; return (RecordCon conname noPostTcExpr rbinds',
fvRbinds `addOneFV` unLoc conname) }
rnExpr (RecordUpd expr rbinds _ _ _)
= do { (expr', fvExpr) <- rnLExpr expr
- ; (rbinds', fvRbinds) <- rnHsRecFields_Update rnLExpr rbinds
+ ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
; return (RecordUpd expr' rbinds' [] [] [],
fvExpr `plusFV` fvRbinds) }
\begin{code}
rnExpr (HsProc pat body)
= newArrowScope $
- rnPatsAndThen_LocalRightwards ProcExpr [pat] $ \ [pat'] ->
+ rnPats ProcExpr [pat] $ \ [pat'] ->
rnCmdTop body `thenM` \ (body',fvBody) ->
return (HsProc pat' body', fvBody)
%************************************************************************
%* *
+ Records
+%* *
+%************************************************************************
+
+\begin{code}
+rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
+ -> RnM (HsRecordBinds Name, FreeVars)
+rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
+ = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds
+ ; (flds', fvss) <- mapAndUnzipM rn_field flds
+ ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
+ fvs `plusFV` plusFVs fvss) }
+ where
+ rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
+ ; return (fld { hsRecFieldArg = arg' }, fvs) }
+\end{code}
+
+
+%************************************************************************
+%* *
Arrow commands
%* *
%************************************************************************
rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
rnBracket (VarBr n) = do { name <- lookupOccRn n
; this_mod <- getModule
- ; checkM (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
- do { loadInterfaceForName msg name -- home interface is loaded, and this is the
+ ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
+ do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the
; return () } -- only way that is going to happen
; return (VarBr name, unitFV name) }
where
-- The binders do not scope over the expression
; (bind_op, fvs1) <- lookupSyntaxName bindMName
; (fail_op, fvs2) <- lookupSyntaxName failMName
- ; rnPatsAndThen_LocalRightwards (StmtCtxt ctxt) [pat] $ \ [pat'] -> do
+ ; rnPats (StmtCtxt ctxt) [pat] $ \ [pat'] -> do
{ (thing, fvs3) <- thing_inside
; return ((BindStmt pat' expr' bind_op fail_op, thing),
fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
where
go orig_lcl_env bndrs [] = do
let (bndrs', dups) = removeDups cmpByOcc bndrs
- inner_env = extendLocalRdrEnv orig_lcl_env bndrs'
+ inner_env = extendLocalRdrEnvList orig_lcl_env bndrs'
- mapM dupErr dups
+ mapM_ dupErr dups
(thing, fvs) <- setLocalRdrEnv inner_env thing_inside
return (([], thing), fvs)
checkTransformStmt ctxt = addErr msg
where
msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
-
+
+---------
+checkTupleSection :: [HsTupArg RdrName] -> RnM ()
+checkTupleSection args
+ = do { tuple_section <- doptM Opt_TupleSections
+ ; checkErr (all tupArgPresent args || tuple_section) msg }
+ where
+ msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
+
---------
sectionErr :: HsExpr RdrName -> SDoc
sectionErr expr