X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnExpr.lhs;h=08b176386e8af258bf9c7be426351dc8f260ad48;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=0b024e9b932d9b44d713e9beb41de6760c016a37;hpb=b4255f2c320f852d7dfb0afc0bc9f64765aece0c;p=ghc-hetmet.git

diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 0b024e9..08b1763 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -5,7 +5,7 @@
 
 Basically dependency analysis.
 
-Handles @Match@, @GRHSsAndBinds@, @HsExpr@, and @Qual@ datatypes.  In
+Handles @Match@, @GRHSsAndBinds@, @HsExpr@, and @Qualifier@ datatypes.  In
 general, all of these functions return a renamed thing, and a set of
 free variables.
 
@@ -14,25 +14,26 @@ free variables.
 
 module RnExpr (
 	rnMatch, rnGRHSsAndBinds, rnPat,
-	checkPrecInfixBind
+	checkPrecMatch
    ) where
 
-import Ubiq
-import RnLoop		-- break the RnPass4/RnExpr4/RnBinds4 loops
+IMP_Ubiq()
+IMPORT_DELOOPER(RnLoop)		-- break the RnPass/RnExpr/RnBinds loops
 
 import HsSyn
 import RdrHsSyn
 import RnHsSyn
 import RnMonad
 
-import ErrUtils		( addErrLoc )
-import Name		( isLocallyDefinedName, pprOp, Name, RdrName )
+import ErrUtils		( addErrLoc, addShortErrLocLine )
+import Name		( isLocallyDefinedName, pprSym, Name, RdrName )
 import Pretty
-import UniqFM		( lookupUFM )
+import UniqFM		( lookupUFM{-, ufmToList ToDo:rm-} )
 import UniqSet		( emptyUniqSet, unitUniqSet,
 			  unionUniqSets, unionManyUniqSets,
-			  UniqSet(..) )
-import Util		( Ord3(..), panic )
+			  SYN_IE(UniqSet)
+			)
+import Util		( Ord3(..), removeDups, panic )
 \end{code}
 
 
@@ -58,20 +59,20 @@ rnPat (LazyPatIn pat)
     returnRn (LazyPatIn pat')
 
 rnPat (AsPatIn name pat)
-  = rnPat pat	`thenRn` \ pat' ->
+  = rnPat pat		`thenRn` \ pat' ->
     lookupValue name	`thenRn` \ vname ->
     returnRn (AsPatIn vname pat')
 
-rnPat (ConPatIn name pats)
-  = lookupValue name	`thenRn` \ name' ->
+rnPat (ConPatIn con pats)
+  = lookupConstr con	`thenRn` \ con' ->
     mapRn rnPat pats  	`thenRn` \ patslist ->
-    returnRn (ConPatIn name' patslist)
+    returnRn (ConPatIn con' patslist)
 
-rnPat (ConOpPatIn pat1 name pat2)
-  = lookupValue name	`thenRn` \ name' ->
+rnPat (ConOpPatIn pat1 con pat2)
+  = lookupConstr con	`thenRn` \ con' ->
     rnPat pat1		`thenRn` \ pat1' ->
     rnPat pat2		`thenRn` \ pat2' ->
-    precParsePat (ConOpPatIn pat1' name' pat2')
+    precParsePat (ConOpPatIn pat1' con' pat2')
 
 rnPat neg@(NegPatIn pat)
   = getSrcLocRn		`thenRn` \ src_loc ->
@@ -97,8 +98,9 @@ rnPat (TuplePatIn pats)
     returnRn (TuplePatIn patslist)
 
 rnPat (RecPatIn con rpats)
-  = panic "rnPat:RecPatIn"
-
+  = lookupConstr con 	`thenRn` \ con' ->
+    rnRpats rpats	`thenRn` \ rpats' ->
+    returnRn (RecPatIn con' rpats')
 \end{code}
 
 ************************************************************************
@@ -194,15 +196,16 @@ ToDo: what about RnClassOps ???
 \end{itemize}
 
 \begin{code}
+fv_set vname@(RnName n) | isLocallyDefinedName n
+		        = unitUniqSet vname
+fv_set _		= emptyUniqSet
+
+
 rnExpr :: RdrNameHsExpr -> RnM_Fixes s (RenamedHsExpr, FreeVars)
 
 rnExpr (HsVar v)
   = lookupValue v	`thenRn` \ vname ->
     returnRn (HsVar vname, fv_set vname)
-  where
-    fv_set vname@(RnName n)
-      | isLocallyDefinedName n = unitUniqSet vname
-    fv_set _		       = emptyUniqSet
 
 rnExpr (HsLit lit)
   = returnRn (HsLit lit, emptyUniqSet)
@@ -223,9 +226,10 @@ rnExpr (OpApp e1 op e2)
     precParseExpr (OpApp e1' op' e2') `thenRn` \ exp ->
     returnRn (exp, (fvs_op `unionUniqSets` fvs_e1) `unionUniqSets` fvs_e2)
 
-rnExpr (NegApp e)
+rnExpr (NegApp e n)
   = rnExpr e 		`thenRn` \ (e', fvs_e) ->
-    returnRn (NegApp e', fvs_e)
+    rnExpr n		`thenRn` \ (n', fvs_n) ->
+    returnRn (NegApp e' n', fvs_e `unionUniqSets` fvs_n)
 
 rnExpr (HsPar e)
   = rnExpr e 		`thenRn` \ (e', fvs_e) ->
@@ -278,10 +282,15 @@ rnExpr (ExplicitTuple exps)
   = rnExprs exps	 	`thenRn` \ (exps', fvExps) ->
     returnRn (ExplicitTuple exps', fvExps)
 
-rnExpr (RecordCon con rbinds)
-  = panic "rnExpr:RecordCon"
-rnExpr (RecordUpd exp rbinds)
-  = panic "rnExpr:RecordUpd"
+rnExpr (RecordCon (HsVar con) rbinds)
+  = lookupConstr con 			`thenRn` \ conname ->
+    rnRbinds "construction" rbinds	`thenRn` \ (rbinds', fvRbinds) ->
+    returnRn (RecordCon (HsVar conname) rbinds', fvRbinds)
+
+rnExpr (RecordUpd expr rbinds)
+  = rnExpr expr			`thenRn` \ (expr', fvExpr) ->
+    rnRbinds "update" rbinds	`thenRn` \ (rbinds', fvRbinds) ->
+    returnRn (RecordUpd expr' rbinds', fvExpr `unionUniqSets` fvRbinds)
 
 rnExpr (ExprWithTySig expr pty)
   = rnExpr expr			 	`thenRn` \ (expr', fvExpr) ->
@@ -319,12 +328,48 @@ rnExpr (ArithSeqIn seq)
        rnExpr expr3	`thenRn` \ (expr3', fvExpr3) ->
        returnRn (FromThenTo expr1' expr2' expr3',
 		  unionManyUniqSets [fvExpr1, fvExpr2, fvExpr3])
+\end{code}
+
+%************************************************************************
+%*									*
+\subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
+%*									*
+%************************************************************************
+
+\begin{code}
+rnRbinds str rbinds 
+  = mapRn field_dup_err dup_fields	`thenRn_`
+    mapAndUnzipRn rn_rbind rbinds	`thenRn` \ (rbinds', fvRbind_s) ->
+    returnRn (rbinds', unionManyUniqSets fvRbind_s)
+  where
+    (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rbinds ]
+
+    field_dup_err dups = getSrcLocRn `thenRn` \ src_loc ->
+		         addErrRn (dupFieldErr str src_loc dups)
+
+    rn_rbind (field, expr, pun)
+      = lookupField field	`thenRn` \ fieldname ->
+	rnExpr expr		`thenRn` \ (expr', fvExpr) ->
+	returnRn ((fieldname, expr', pun), fvExpr)
 
+rnRpats rpats
+  = mapRn field_dup_err dup_fields 	`thenRn_`
+    mapRn rn_rpat rpats
+  where
+    (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rpats ]
+
+    field_dup_err dups = getSrcLocRn `thenRn` \ src_loc ->
+		         addErrRn (dupFieldErr "pattern" src_loc dups)
+
+    rn_rpat (field, pat, pun)
+      = lookupField field	`thenRn` \ fieldname ->
+	rnPat pat		`thenRn` \ pat' ->
+	returnRn (fieldname, pat', pun)
 \end{code}
 
 %************************************************************************
 %*									*
-\subsubsection{@Qual@s: in list comprehensions}
+\subsubsection{@Qualifier@s: in list comprehensions}
 %*									*
 %************************************************************************
 
@@ -350,7 +395,7 @@ rnQuals (qual: quals)
   = rnQual qual				`thenRn` \ ((qual',  bs1), fvQuals1) ->
     extendSS2 bs1 (rnQuals quals)	`thenRn` \ ((quals', bs2), fvQuals2) ->
     returnRn
-       ((qual' : quals', bs2 ++ bs1),	-- The ones on the right (bs2) shadow the
+       ((qual' : quals', bs1 ++ bs2),	-- The ones on the right (bs2) shadow the
 					-- ones on the left (bs1)
 	fvQuals1 `unionUniqSets` fvQuals2)
 
@@ -428,20 +473,21 @@ rnStmt (LetStmt binds)
 precParseExpr :: RenamedHsExpr -> RnM_Fixes s RenamedHsExpr
 precParsePat  :: RenamedPat -> RnM_Fixes s RenamedPat
 
-precParseExpr exp@(OpApp (NegApp e1) (HsVar op) e2)
+precParseExpr exp@(OpApp (NegApp e1 n) (HsVar op) e2)
   = lookupFixity op		`thenRn` \ (op_fix, op_prec) ->
     if 6 < op_prec then		
 	-- negate precedence 6 wired in
 	-- (-x)*y  ==> -(x*y)
 	precParseExpr (OpApp e1 (HsVar op) e2) `thenRn` \ op_app ->
-	returnRn (NegApp op_app)
+	returnRn (NegApp op_app n)
     else
 	returnRn exp
 
 precParseExpr exp@(OpApp (OpApp e11 (HsVar op1) e12) (HsVar op) e2)
   = lookupFixity op		 `thenRn` \ (op_fix, op_prec) ->
     lookupFixity op1		 `thenRn` \ (op1_fix, op1_prec) ->
-    case cmp op1_prec op_prec of
+    -- pprTrace "precParse:" (ppCat [ppr PprDebug op, ppInt op_prec, ppr PprDebug op1, ppInt op1_prec]) $
+    case (op1_prec `cmp` op_prec) of
       LT_  -> rearrange
       EQ_  -> case (op1_fix, op_fix) of
 		(INFIXR, INFIXR) -> rearrange
@@ -469,7 +515,7 @@ precParsePat pat@(ConOpPatIn (NegPatIn e1) op e2)
 precParsePat pat@(ConOpPatIn (ConOpPatIn p11 op1 p12) op p2)
   = lookupFixity op		 `thenRn` \ (op_fix, op_prec) ->
     lookupFixity op1		 `thenRn` \ (op1_fix, op1_prec) ->
-    case cmp op1_prec op_prec of
+    case (op1_prec `cmp` op_prec) of
       LT_  -> rearrange
       EQ_  -> case (op1_fix, op_fix) of
 		(INFIXR, INFIXR) -> rearrange
@@ -490,6 +536,7 @@ data INFIX = INFIXL | INFIXR | INFIXN deriving Eq
 lookupFixity :: RnName -> RnM_Fixes s (INFIX, Int)
 lookupFixity op
   = getExtraRn `thenRn` \ fixity_fm ->
+    -- pprTrace "lookupFixity:" (ppAboves [ppCat [pprUnique u, ppr PprDebug i_f] | (u,i_f) <- ufmToList fixity_fm]) $
     case lookupUFM fixity_fm op of
       Nothing           -> returnRn (INFIXL, 9)
       Just (InfixL _ n) -> returnRn (INFIXL, n)
@@ -498,13 +545,15 @@ lookupFixity op
 \end{code}
 
 \begin{code}
-checkPrecInfixBind :: Bool -> RnName -> [RenamedPat] -> RnM_Fixes s ()
+checkPrecMatch :: Bool -> RnName -> RenamedMatch -> RnM_Fixes s ()
 
-checkPrecInfixBind False fn pats
+checkPrecMatch False fn match
   = returnRn ()
-checkPrecInfixBind True op [p1,p2]
+checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _)))
   = checkPrec op p1 False	`thenRn_`
     checkPrec op p2 True
+checkPrecMatch True op _
+  = panic "checkPrecMatch"
 
 checkPrec op (ConOpPatIn _ op1 _) right
   = lookupFixity op	`thenRn` \ (op_fix, op_prec) ->
@@ -512,17 +561,15 @@ checkPrec op (ConOpPatIn _ op1 _) right
     getSrcLocRn 	`thenRn` \ src_loc ->
     let
 	inf_ok = op1_prec > op_prec || 
-	         op1_prec == op_prec &&
-		 (op1_fix == INFIXR && op_fix == INFIXR && right ||
-		  op1_fix == INFIXL && op_fix == INFIXL && not right)
+	         (op1_prec == op_prec &&
+		  (op1_fix == INFIXR && op_fix == INFIXR && right ||
+		   op1_fix == INFIXL && op_fix == INFIXL && not right))
 
 	info  = (op,op_fix,op_prec)
 	info1 = (op1,op1_fix,op1_prec)
 	(infol, infor) = if right then (info, info1) else (info1, info)
-
-	inf_err = precParseErr infol infor src_loc
     in
-    addErrIfRn (not inf_ok) inf_err
+    addErrIfRn (not inf_ok) (precParseErr infol infor src_loc)
 
 checkPrec op (NegPatIn _) right
   = lookupFixity op	`thenRn` \ (op_fix, op_prec) ->
@@ -534,9 +581,13 @@ checkPrec op pat right
 \end{code}
 
 \begin{code}
+dupFieldErr str src_loc (dup:rest)
+  = addShortErrLocLine src_loc (\ sty ->
+    ppBesides [ppStr "duplicate field name `", ppr sty dup, ppStr "' in record ", ppStr str])
+
 negPatErr pat src_loc
-  = addErrLoc src_loc "prefix `-' not applied to literal in pattern" ( \sty ->
-    ppr sty pat) 
+  = addShortErrLocLine src_loc (\ sty ->
+    ppSep [ppStr "prefix `-' not applied to literal in pattern", ppr sty pat])
 
 precParseNegPatErr op src_loc
   = addErrLoc src_loc "precedence parsing error" (\ sty ->
@@ -547,7 +598,7 @@ precParseErr op1 op2 src_loc
     ppBesides [ppStr "cannot mix ", pp_op sty op1, ppStr " and ", pp_op sty op2,
 	       ppStr " in the same infix expression"])
 
-pp_op sty (op, fix, prec) = ppBesides [pprOp sty op, ppLparen, pp_fix fix, ppSP, ppInt prec, ppRparen]
+pp_op sty (op, fix, prec) = ppBesides [pprSym sty op, ppLparen, pp_fix fix, ppSP, ppInt prec, ppRparen]
 pp_fix INFIXL = ppStr "infixl"
 pp_fix INFIXR = ppStr "infixr"
 pp_fix INFIXN = ppStr "infix"