[project @ 1996-04-21 13:39:09 by partain]

[ghc-hetmet.git] / ghc / compiler / rename / RnExpr.lhs

diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 04db620..19110b8 100644 (file)
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -13,11 +13,12 @@ free variables.
 #include "HsVersions.h"
 
 module RnExpr (
-       rnMatch, rnGRHSsAndBinds, rnPat
+       rnMatch, rnGRHSsAndBinds, rnPat,
+       checkPrecMatch
    ) where
 
 import Ubiq
-import RnLoop          -- break the RnPass4/RnExpr4/RnBinds4 loops
+import RnLoop          -- break the RnPass/RnExpr/RnBinds loops
 
 import HsSyn
 import RdrHsSyn
@@ -25,7 +26,7 @@ import RnHsSyn
 import RnMonad
 
 import ErrUtils                ( addErrLoc )
-import Name            ( isLocallyDefinedName, pprOp, Name, RdrName )
+import Name            ( isLocallyDefinedName, pprSym, Name, RdrName )
 import Pretty
 import UniqFM          ( lookupUFM )
 import UniqSet         ( emptyUniqSet, unitUniqSet,
@@ -74,13 +75,14 @@ rnPat (ConOpPatIn pat1 name pat2)
 
 rnPat neg@(NegPatIn pat)
   = getSrcLocRn                `thenRn` \ src_loc ->
-    addErrIfRn (not (is_lit pat)) (negPatErr neg src_loc)
+    addErrIfRn (not (valid_neg_pat pat)) (negPatErr neg src_loc)
                        `thenRn_`
     rnPat pat          `thenRn` \ pat' ->
     returnRn (NegPatIn pat')
   where
-    is_lit (LitPatIn _) = True
-    is_lit _            = False
+    valid_neg_pat (LitPatIn (HsInt  _)) = True
+    valid_neg_pat (LitPatIn (HsFrac _)) = True
+    valid_neg_pat _                     = False
 
 rnPat (ParPatIn pat)
   = rnPat pat          `thenRn` \ pat' ->
@@ -200,7 +202,7 @@ rnExpr (HsVar v)
   where
     fv_set vname@(RnName n)
       | isLocallyDefinedName n = unitUniqSet vname
-      | otherwise             = emptyUniqSet
+    fv_set _                  = emptyUniqSet
 
 rnExpr (HsLit lit)
   = returnRn (HsLit lit, emptyUniqSet)
@@ -483,7 +485,7 @@ precParsePat pat@(ConOpPatIn (ConOpPatIn p11 op1 p12) op p2)
 precParsePat pat = returnRn pat
 
 
-data INFIX = INFIXL | INFIXR | INFIXN
+data INFIX = INFIXL | INFIXR | INFIXN deriving Eq
 
 lookupFixity :: RnName -> RnM_Fixes s (INFIX, Int)
 lookupFixity op
@@ -496,6 +498,42 @@ lookupFixity op
 \end{code}
 
 \begin{code}
+checkPrecMatch :: Bool -> RnName -> RenamedMatch -> RnM_Fixes s ()
+
+checkPrecMatch False fn match
+  = returnRn ()
+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) ->
+    lookupFixity op1   `thenRn` \ (op1_fix, op1_prec) ->
+    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))
+
+       info  = (op,op_fix,op_prec)
+       info1 = (op1,op1_fix,op1_prec)
+       (infol, infor) = if right then (info, info1) else (info1, info)
+    in
+    addErrIfRn (not inf_ok) (precParseErr infol infor src_loc)
+
+checkPrec op (NegPatIn _) right
+  = lookupFixity op    `thenRn` \ (op_fix, op_prec) ->
+    getSrcLocRn        `thenRn` \ src_loc ->
+    addErrIfRn (6 < op_prec) (precParseNegPatErr (op,op_fix,op_prec) src_loc)
+
+checkPrec op pat right
+  = returnRn ()
+\end{code}
+
+\begin{code}
 negPatErr pat src_loc
   = addErrLoc src_loc "prefix `-' not applied to literal in pattern" ( \sty ->
     ppr sty pat) 
@@ -509,7 +547,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"