X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Frename%2FRnExpr.lhs;h=bccd2e22af3abbde579b66b018af73b4165ee7ca;hb=17b297d97d327620ed6bfab942f8992b2446f1bf;hp=1c80bc0101bb4c28af993991731ced3f96ece765;hpb=3a99fa889bdff0c86df20cb18c71d30e30a79b43;p=ghc-hetmet.git

diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 1c80bc0..bccd2e2 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -10,6 +10,13 @@ general, all of these functions return a renamed thing, and a set of
 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
@@ -20,15 +27,13 @@ import RnSource  ( rnSrcDecls, rnSplice, checkTH )
 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 )
@@ -47,7 +52,7 @@ import Util		( isSingleton )
 import ListSetOps	( removeDups )
 import Maybes		( expectJust )
 import Outputable
-import SrcLoc		( Located(..), unLoc, getLoc, cmpLocated )
+import SrcLoc		( Located(..), unLoc, getLoc )
 import FastString
 
 import List		( unzip4 )
@@ -91,24 +96,30 @@ rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
 
 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)
@@ -179,6 +190,9 @@ rnExpr (HsCoreAnn ann expr)
 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) ->
@@ -201,31 +215,29 @@ rnExpr e@(HsDo do_or_lc stmts body _)
 
 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
@@ -497,29 +509,6 @@ rnArithSeq (FromThenTo expr1 expr2 expr3)
 	    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
@@ -663,8 +652,8 @@ rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside
     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) }
@@ -953,7 +942,7 @@ patSynErr e = do { addErr (sep [ptext SLIT("Pattern syntax in expression context
 			 	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)