free variables.
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
module RnExpr (
rnLExpr, rnExpr, rnStmts
) where
import RnBinds ( rnLocalBindsAndThen, rnValBinds,
rnMatchGroup, trimWith )
import HsSyn
-import RnHsSyn
import TcRnMonad
import RnEnv
import HscTypes ( availNames )
-import OccName ( plusOccEnv )
import RnNames ( getLocalDeclBinders, extendRdrEnvRn )
import RnTypes ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit,
mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec,
- dupFieldErr, checkTupSize )
+ rnHsRecFields, checkTupSize )
import DynFlags ( DynFlag(..) )
import BasicTypes ( FixityDirection(..) )
import SrcLoc ( SrcSpan )
import ListSetOps ( removeDups )
import Maybes ( expectJust )
import Outputable
-import SrcLoc ( Located(..), unLoc, getLoc, cmpLocated )
+import SrcLoc ( Located(..), unLoc, getLoc )
import FastString
import List ( unzip4 )
rnExpr (HsVar v)
= do name <- lookupOccRn v
- localRdrEnv <- getLocalRdrEnv
- lclEnv <- getLclEnv
ignore_asserts <- doptM Opt_IgnoreAsserts
- ignore_breakpoints <- doptM Opt_IgnoreBreakpoints
- ghcMode <- getGhcMode
- let conds = [ (name `hasKey` assertIdKey
- && not ignore_asserts,
- do (e, fvs) <- mkAssertErrorExpr
- return (e, fvs `addOneFV` name))
- ]
- case lookup True conds of
- Just action -> action
- Nothing -> return (HsVar name, unitFV name)
+ finish_var ignore_asserts name
+ where
+ finish_var ignore_asserts name
+ | ignore_asserts || not (name `hasKey` assertIdKey)
+ = return (HsVar name, unitFV name)
+ | otherwise
+ = do { (e, fvs) <- mkAssertErrorExpr
+ ; return (e, fvs `addOneFV` name) }
rnExpr (HsIPVar v)
= newIPNameRn v `thenM` \ name ->
returnM (HsIPVar name, emptyFVs)
+rnExpr (HsLit lit@(HsString s))
+ = do {
+ opt_OverloadedStrings <- doptM Opt_OverloadedStrings
+ ; if opt_OverloadedStrings then
+ rnExpr (HsOverLit (mkHsIsString s))
+ else -- Same as below
+ rnLit lit `thenM_`
+ returnM (HsLit lit, emptyFVs)
+ }
+
rnExpr (HsLit lit)
= rnLit lit `thenM_`
returnM (HsLit lit, emptyFVs)
rnExpr (ExplicitList _ exps)
= rnExprs exps `thenM` \ (exps', fvs) ->
- returnM (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
+ returnM (ExplicitList placeHolderType exps', fvs)
rnExpr (ExplicitPArr _ exps)
= rnExprs exps `thenM` \ (exps', fvs) ->
returnM (ExplicitPArr placeHolderType exps', fvs)
rnExpr e@(ExplicitTuple exps boxity)
- = checkTupSize tup_size `thenM_`
+ = checkTupSize (length exps) `thenM_`
rnExprs exps `thenM` \ (exps', fvs) ->
- returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
- where
- tup_size = length exps
- tycon_name = tupleTyCon_name boxity tup_size
+ returnM (ExplicitTuple exps' boxity, fvs)
rnExpr (RecordCon con_id _ rbinds)
- = lookupLocatedOccRn con_id `thenM` \ conname ->
- rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) ->
- returnM (RecordCon conname noPostTcExpr rbinds',
- fvRbinds `addOneFV` unLoc conname)
-
-rnExpr (RecordUpd expr rbinds _ _)
- = rnLExpr expr `thenM` \ (expr', fvExpr) ->
- rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) ->
- returnM (RecordUpd expr' rbinds' placeHolderType placeHolderType,
- fvExpr `plusFV` fvRbinds)
+ = do { conname <- lookupLocatedOccRn con_id
+ ; (rbinds', fvRbinds) <- rnHsRecFields "construction" (Just conname)
+ rnLExpr HsVar rbinds
+ ; return (RecordCon conname noPostTcExpr rbinds',
+ fvRbinds `addOneFV` unLoc conname) }
+
+rnExpr (RecordUpd expr rbinds _ _ _)
+ = do { (expr', fvExpr) <- rnLExpr expr
+ ; (rbinds', fvRbinds) <- rnHsRecFields "update" Nothing rnLExpr HsVar rbinds
+ ; return (RecordUpd expr' rbinds' [] [] [],
+ fvExpr `plusFV` fvRbinds) }
rnExpr (ExprWithTySig expr pty)
= do { (pty', fvTy) <- rnHsTypeFVs doc pty
plusFVs [fvExpr1, fvExpr2, fvExpr3])
\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
-%* *
-%************************************************************************
-
-\begin{code}
-rnRbinds str rbinds
- = mappM_ field_dup_err dup_fields `thenM_`
- mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) ->
- returnM (rbinds', fvRbind)
- where
- (_, dup_fields) = removeDups cmpLocated [ f | (f,_) <- rbinds ]
-
- field_dup_err dups = mappM_ (\f -> addLocErr f (dupFieldErr str)) dups
-
- rn_rbind (field, expr)
- = lookupLocatedGlobalOccRn field `thenM` \ fieldname ->
- rnLExpr expr `thenM` \ (expr', fvExpr) ->
- returnM ((fieldname, expr'), fvExpr `addOneFV` unLoc fieldname)
-\end{code}
-
%************************************************************************
%* *
Template Haskell brackets
doc = text "In a recursive do statement"
rnStmt ctxt (ParStmt segs) thing_inside
- = do { opt_GlasgowExts <- doptM Opt_GlasgowExts
- ; checkM opt_GlasgowExts parStmtErr
+ = do { parallel_list_comp <- doptM Opt_ParallelListComp
+ ; checkM parallel_list_comp parStmtErr
; orig_lcl_env <- getLocalRdrEnv
; ((segs',thing), fvs) <- go orig_lcl_env [] segs
; return ((ParStmt segs', thing), fvs) }
nest 4 (ppr e)])
; return (EWildPat, emptyFVs) }
-parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglasgow-exts"))
+parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -XParallelListComp"))
badIpBinds what binds
= hang (ptext SLIT("Implicit-parameter bindings illegal in") <+> what)