free variables.
\begin{code}
+{-# OPTIONS_GHC -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/WorkingConventions#Warnings
+-- for details
+
module RnExpr (
rnLExpr, rnExpr, rnStmts
) where
import RnBinds ( rnLocalBindsAndThen, rnValBinds,
rnMatchGroup, trimWith )
import HsSyn
-import RnHsSyn
import TcRnMonad
import RnEnv
-import OccName ( plusOccEnv )
+import HscTypes ( availNames )
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 PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName,
loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
negateName, thenMName, bindMName, failMName )
-#if defined(GHCI) && defined(BREAKPOINT)
-import PrelNames ( breakpointJumpName, breakpointCondJumpName
- , undefined_RDR, breakpointIdKey, breakpointCondIdKey )
-import UniqFM ( eltsUFM )
-import DynFlags ( GhcMode(..) )
-import Name ( isTyVarName )
-#endif
+
import Name ( Name, nameOccName, nameIsLocalOrFrom )
import NameSet
-import RdrName ( RdrName, emptyGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals )
+import RdrName ( RdrName, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals )
import LoadIface ( loadInterfaceForName )
import UniqFM ( isNullUFM )
import UniqSet ( emptyUniqSet )
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))
-#if defined(GHCI) && defined(BREAKPOINT)
- , (name `hasKey` breakpointIdKey
- && not ignore_breakpoints
- && ghcMode == Interactive,
- do let isWantedName = not.isTyVarName
- (e, fvs) <- mkBreakpointExpr (filter isWantedName (eltsUFM localRdrEnv))
- return (e, fvs `addOneFV` name)
- )
- , (name `hasKey` breakpointCondIdKey
- && not ignore_breakpoints
- && ghcMode == Interactive,
- do let isWantedName = not.isTyVarName
- (e, fvs) <- mkBreakpointCondExpr (filter isWantedName (eltsUFM localRdrEnv))
- return (e, fvs `addOneFV` name)
- )
-#endif
- ]
- 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 (HsSCC lbl expr)
= rnLExpr expr `thenM` \ (expr', fvs_expr) ->
returnM (HsSCC lbl expr', fvs_expr)
+rnExpr (HsTickPragma info expr)
+ = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
+ returnM (HsTickPragma info expr', fvs_expr)
rnExpr (HsLam matches)
= rnMatchGroup LambdaExpr matches `thenM` \ (matches', fvMatch) ->
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)
- = rnLExpr expr `thenM` \ (expr', fvExpr) ->
- rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) ->
- returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
+ = do { (pty', fvTy) <- rnHsTypeFVs doc pty
+ ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
+ rnLExpr expr
+ ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
where
doc = text "In an expression type signature"
returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
- -- HsCoerce
+ -- HsWrap
\end{code}
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
-- confuse the Names for the current module.
-- By using a pretend module, thFAKE, we keep them safely out of the way.
- ; names <- getLocalDeclBinders gbl_env1 group
+ ; avails <- getLocalDeclBinders gbl_env1 group
+ ; let names = concatMap availNames avails
; let new_occs = map nameOccName names
trimmed_rdr_env = hideSomeUnquals (tcg_rdr_env gbl_env) new_occs
- ; rdr_env' <- extendRdrEnvRn trimmed_rdr_env names
+ ; rdr_env' <- extendRdrEnvRn trimmed_rdr_env avails
-- In this situation we want to *shadow* top-level bindings.
-- foo = 1
-- bar = [d| foo = 1|]
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) }
%************************************************************************
%* *
-\subsubsection{breakpoint utils}
+\subsubsection{Assertion utils}
%* *
%************************************************************************
\begin{code}
-#if defined(GHCI) && defined(BREAKPOINT)
-mkBreakpointExpr :: [Name] -> RnM (HsExpr Name, FreeVars)
-mkBreakpointExpr = mkBreakpointExpr' breakpointJumpName
-
-mkBreakpointCondExpr :: [Name] -> RnM (HsExpr Name, FreeVars)
-mkBreakpointCondExpr = mkBreakpointExpr' breakpointCondJumpName
-
-mkBreakpointExpr' :: Name -> [Name] -> RnM (HsExpr Name, FreeVars)
-mkBreakpointExpr' breakpointFunc scope
- = do sloc <- getSrcSpanM
- undef <- lookupOccRn undefined_RDR
- let inLoc = L sloc
- lHsApp x y = inLoc (HsApp x y)
- mkExpr fnName args = mkExpr' fnName (reverse args)
- mkExpr' fnName [] = inLoc (HsVar fnName)
- mkExpr' fnName (arg:args)
- = lHsApp (mkExpr' fnName args) (inLoc arg)
- expr = unLoc $ mkExpr breakpointFunc [mkScopeArg scope, HsVar undef, msg]
- mkScopeArg args = unLoc $ mkExpr undef (map HsVar args)
- msg = srcSpanLit sloc
- return (expr, emptyFVs)
-#endif
-
-srcSpanLit :: SrcSpan -> HsExpr Name
-srcSpanLit span = HsLit (HsString (mkFastString (showSDoc (ppr span))))
-
srcSpanPrimLit :: SrcSpan -> HsExpr Name
srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDoc (ppr span))))
-\end{code}
-%************************************************************************
-%* *
-\subsubsection{Assertion utils}
-%* *
-%************************************************************************
-
-\begin{code}
mkAssertErrorExpr :: RnM (HsExpr Name, FreeVars)
-- Return an expression for (assertError "Foo.hs:27")
mkAssertErrorExpr
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)
2 (ppr binds)
\end{code}
+
+
projects / ghc-hetmet.git / blobdiff