[project @ 1997-05-26 03:33:27 by sof]
[ghc-hetmet.git] / ghc / compiler / rename / RnExpr.lhs
index 613b37b..8462995 100644 (file)
@@ -25,14 +25,16 @@ import RdrHsSyn
 import RnHsSyn
 import RnMonad
 import RnEnv
+import CmdLineOpts     ( opt_GlasgowExts )
 import PrelInfo                ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR,
-                         creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR,
-                         negate_RDR
+                         creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
+                         ratioDataCon_RDR, negate_RDR
                        )
 import TysPrim         ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, 
                          floatPrimTyCon, doublePrimTyCon
                        )
 import TyCon           ( TyCon )
+import Id              ( GenId )
 import ErrUtils                ( addErrLoc, addShortErrLocLine )
 import Name
 import Pretty
@@ -41,7 +43,10 @@ import UniqSet               ( emptyUniqSet, unitUniqSet,
                          unionUniqSets, unionManyUniqSets,
                          SYN_IE(UniqSet)
                        )
-import Util            ( Ord3(..), removeDups, panic )
+import PprStyle                ( PprStyle(..) )
+import Util            ( Ord3(..), removeDups, panic, pprPanic, assertPanic )
+import Outputable
+
 \end{code}
 
 
@@ -57,7 +62,7 @@ rnPat :: RdrNamePat -> RnMS s RenamedPat
 rnPat WildPatIn = returnRn WildPatIn
 
 rnPat (VarPatIn name)
-  = lookupRn name      `thenRn` \ vname ->
+  = lookupBndrRn  name                 `thenRn` \ vname ->
     returnRn (VarPatIn vname)
 
 rnPat (LitPatIn lit) 
@@ -71,16 +76,20 @@ rnPat (LazyPatIn pat)
 
 rnPat (AsPatIn name pat)
   = rnPat pat          `thenRn` \ pat' ->
-    lookupRn name      `thenRn` \ vname ->
+    lookupBndrRn name  `thenRn` \ vname ->
     returnRn (AsPatIn vname pat')
 
 rnPat (ConPatIn con pats)
-  = lookupRn con       `thenRn` \ con' ->
+  = lookupOccRn con    `thenRn` \ con' ->
     mapRn rnPat pats   `thenRn` \ patslist ->
     returnRn (ConPatIn con' patslist)
 
-rnPat (ConOpPatIn pat1 con pat2)
-  = rnOpPat pat1 con pat2
+rnPat (ConOpPatIn pat1 con _ pat2)
+  = rnPat pat1         `thenRn` \ pat1' ->
+    lookupOccRn con    `thenRn` \ con' ->
+    lookupFixity con   `thenRn` \ fixity ->
+    rnPat pat2         `thenRn` \ pat2' ->
+    mkConOpPatRn pat1' con' fixity pat2'
 
 -- Negated patters can only be literals, and they are dealt with
 -- by negating the literal at compile time, not by using the negation
@@ -100,6 +109,12 @@ rnPat (ParPatIn pat)
   = rnPat pat          `thenRn` \ pat' ->
     returnRn (ParPatIn pat')
 
+rnPat (NPlusKPatIn name lit)
+  = litOccurrence lit                  `thenRn_`
+    lookupImplicitOccRn ordClass_RDR   `thenRn_`
+    lookupBndrRn name                  `thenRn` \ name' ->
+    returnRn (NPlusKPatIn name' lit)
+
 rnPat (ListPatIn pats)
   = addImplicitOccRn listType_name     `thenRn_` 
     mapRn rnPat pats                   `thenRn` \ patslist ->
@@ -111,7 +126,7 @@ rnPat (TuplePatIn pats)
     returnRn (TuplePatIn patslist)
 
 rnPat (RecPatIn con rpats)
-  = lookupRn con       `thenRn` \ con' ->
+  = lookupOccRn con    `thenRn` \ con' ->
     rnRpats rpats      `thenRn` \ rpats' ->
     returnRn (RecPatIn con' rpats')
 \end{code}
@@ -123,7 +138,7 @@ rnPat (RecPatIn con rpats)
 ************************************************************************
 
 \begin{code}
-rnMatch :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
+--rnMatch :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
 
 rnMatch (PatMatch pat match)
   = bindLocalsRn "pattern" binders     $ \ new_binders ->
@@ -145,7 +160,7 @@ rnMatch (GRHSMatch grhss_and_binds)
 %************************************************************************
 
 \begin{code}
-rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnMS s (RenamedGRHSsAndBinds, FreeVars)
+--rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnMS s (RenamedGRHSsAndBinds, FreeVars)
 
 rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
   = rnBinds binds              $ \ binds' ->
@@ -161,14 +176,30 @@ rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
 
     rnGRHS (GRHS guard expr locn)
       = pushSrcLocRn locn $                
-       rnExpr guard    `thenRn` \ (guard', fvsg) ->
+       (if not (opt_GlasgowExts || is_standard_guard guard) then
+               addWarnRn (nonStdGuardErr guard)
+        else
+               returnRn ()
+       )               `thenRn_`
+
+       (rnStmts rnExpr guard   $ \ guard' ->
+               -- This nested thing deals with scope and
+               -- the free vars of the guard, and knocking off the
+               -- free vars of the rhs that are bound by the guard
+
        rnExpr expr     `thenRn` \ (expr',  fvse) ->
-       returnRn (GRHS guard' expr' locn, fvsg `unionNameSets` fvse)
+       returnRn (GRHS guard' expr' locn, fvse))
 
     rnGRHS (OtherwiseGRHS expr locn)
       = pushSrcLocRn locn $
        rnExpr expr     `thenRn` \ (expr', fvs) ->
-       returnRn (OtherwiseGRHS expr' locn, fvs)
+       returnRn (GRHS [] expr' locn, fvs)
+
+       -- Standard Haskell 1.4 guards are just a single boolean
+       -- expression, rather than a list of qualifiers as in the
+       -- Glasgow extension
+    is_standard_guard [GuardStmt _ _] = True
+    is_standard_guard other          = False
 \end{code}
 
 %************************************************************************
@@ -178,14 +209,16 @@ rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
 %************************************************************************
 
 \begin{code}
-rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars)
-
-rnExprs [] = returnRn ([], emptyNameSet)
-
-rnExprs (expr:exprs)
-  = rnExpr expr        `thenRn` \ (expr', fvExpr) ->
-    rnExprs exprs      `thenRn` \ (exprs', fvExprs) ->
-    returnRn (expr':exprs', fvExpr `unionNameSets` fvExprs)
+--rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars)
+rnExprs ls =
+ rnExprs' ls [] `thenRn` \  (exprs, fvExprs) ->
+ returnRn (exprs, unionManyNameSets fvExprs)
+
+rnExprs' [] acc = returnRn ([], acc)
+rnExprs' (expr:exprs) acc
+  = rnExpr expr                `thenRn` \ (expr', fvExpr) ->
+    rnExprs' exprs (fvExpr:acc)        `thenRn` \ (exprs', fvExprs) ->
+    returnRn (expr':exprs', fvExprs)
 \end{code}
 
 Variables. We look up the variable and return the resulting name.  The
@@ -217,9 +250,28 @@ rnExpr (HsApp fun arg)
     rnExpr arg         `thenRn` \ (arg',fvArg) ->
     returnRn (HsApp fun' arg', fvFun `unionNameSets` fvArg)
 
-rnExpr (OpApp e1 (HsVar op) e2) = rnOpApp e1 op e2
+rnExpr (OpApp e1 op@(HsVar op_name) _ e2) 
+  = rnExpr e1                          `thenRn` \ (e1', fv_e1) ->
+    rnExpr e2                          `thenRn` \ (e2', fv_e2) ->
+    rnExpr op                          `thenRn` \ (op', fv_op) ->
 
-rnExpr (NegApp e n) = completeNegApp (rnExpr e)
+       -- Deal wth fixity
+    lookupFixity op_name               `thenRn` \ fixity ->
+    getModeRn                          `thenRn` \ mode -> 
+    (case mode of
+       SourceMode    -> mkOpAppRn e1' op' fixity e2'
+       InterfaceMode -> returnRn (OpApp e1' op' fixity e2')
+    )                                  `thenRn` \ final_e -> 
+
+    returnRn (final_e,
+             fv_e1 `unionNameSets` fv_op `unionNameSets` fv_e2)
+
+rnExpr (NegApp e n)
+  = rnExpr e                           `thenRn` \ (e', fv_e) ->
+    lookupImplicitOccRn negate_RDR     `thenRn` \ neg ->
+    getModeRn                          `thenRn` \ mode -> 
+    mkNegAppRn mode e' (HsVar neg)     `thenRn` \ final_e ->
+    returnRn (final_e, fv_e)
 
 rnExpr (HsPar e)
   = rnExpr e           `thenRn` \ (e', fvs_e) ->
@@ -256,16 +308,11 @@ rnExpr (HsLet binds expr)
     rnExpr expr                         `thenRn` \ (expr',fvExpr) ->
     returnRn (HsLet binds' expr', fvExpr)
 
-rnExpr (HsDo stmts src_loc)
+rnExpr (HsDo do_or_lc stmts src_loc)
   = pushSrcLocRn src_loc $
     lookupImplicitOccRn monadZeroClass_RDR     `thenRn_`       -- Forces Monad to come too
-    rnStmts stmts                              `thenRn` \ (stmts', fvStmts) ->
-    returnRn (HsDo stmts' src_loc, fvStmts)
-
-rnExpr (ListComp expr quals)
-  = addImplicitOccRn listType_name     `thenRn_` 
-    rnQuals expr quals                         `thenRn` \ ((expr', quals'), fvs) ->
-    returnRn (ListComp expr' quals', fvs)
+    (rnStmts rnExpr stmts                      $ \ stmts' ->
+    returnRn (HsDo do_or_lc stmts' src_loc, emptyNameSet))
 
 rnExpr (ExplicitList exps)
   = addImplicitOccRn listType_name     `thenRn_` 
@@ -288,8 +335,8 @@ rnExpr (RecordUpd expr rbinds)
     returnRn (RecordUpd expr' rbinds', fvExpr `unionNameSets` fvRbinds)
 
 rnExpr (ExprWithTySig expr pty)
-  = rnExpr expr                                `thenRn` \ (expr', fvExpr) ->
-    rnHsType pty                       `thenRn` \ pty' ->
+  = rnExpr expr                                                `thenRn` \ (expr', fvExpr) ->
+    rnHsSigType (\ sty -> text "an expression") pty    `thenRn` \ pty' ->
     returnRn (ExprWithTySig expr' pty', fvExpr)
 
 rnExpr (HsIf p b1 b2 src_loc)
@@ -343,7 +390,7 @@ rnRbinds str rbinds
     field_dup_err dups = addErrRn (dupFieldErr str dups)
 
     rn_rbind (field, expr, pun)
-      = lookupOccRn field      `thenRn` \ fieldname ->
+      = lookupGlobalOccRn field        `thenRn` \ fieldname ->
        rnExpr expr             `thenRn` \ (expr', fvExpr) ->
        returnRn ((fieldname, expr', pun), fvExpr)
 
@@ -356,14 +403,14 @@ rnRpats rpats
     field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
 
     rn_rpat (field, pat, pun)
-      = lookupOccRn field      `thenRn` \ fieldname ->
+      = lookupGlobalOccRn field        `thenRn` \ fieldname ->
        rnPat pat               `thenRn` \ pat' ->
        returnRn (fieldname, pat', pun)
 \end{code}
 
 %************************************************************************
 %*                                                                     *
-\subsubsection{@Qualifier@s: in list comprehensions}
+\subsubsection{@Stmt@s: in @do@ expressions}
 %*                                                                     *
 %************************************************************************
 
@@ -376,72 +423,27 @@ be @{r}@, and the free var set for the entire Quals will be @{r}@. This
 Quals.
 
 \begin{code}
-rnQuals :: RdrNameHsExpr -> [RdrNameQual]
-        -> RnMS s ((RenamedHsExpr, [RenamedQual]), FreeVars)
-
-rnQuals expr [qual]                            -- must be at least one qual
-  = rnQual qual                        $ \ new_qual ->
-    rnExpr expr                                `thenRn` \ (expr', fvs) ->
-    returnRn ((expr', [new_qual]), fvs)
+type RnExprTy s = RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
 
-rnQuals expr (qual: quals)
-  = rnQual qual                        $ \ qual' ->
-    rnQuals expr quals         `thenRn` \ ((expr', quals'), fv_quals) ->
-    returnRn ((expr', qual' : quals'), fv_quals)
+rnStmts :: RnExprTy s
+       -> [RdrNameStmt] 
+       -> ([RenamedStmt] -> RnMS s (a, FreeVars))
+       -> RnMS s (a, FreeVars)
 
+rnStmts rn_expr [] thing_inside 
+  = thing_inside []
 
--- rnQual :: RdrNameQual
---        -> (RenamedQual -> RnMS s (a,FreeVars))
---        -> RnMS s (a,FreeVars)
--- Because of mutual recursion the actual type is a bit less general than this [Haskell 1.2]
+rnStmts rn_expr (stmt:stmts) thing_inside
+  = rnStmt rn_expr stmt                                $ \ stmt' ->
+    rnStmts rn_expr stmts                      $ \ stmts' ->
+    thing_inside (stmt' : stmts')
 
-rnQual (GeneratorQual pat expr) thing_inside
-  = rnExpr expr                                                        `thenRn` \ (expr', fv_expr) ->
-    bindLocalsRn "pattern in list comprehension" binders       $ \ new_binders ->
-    rnPat pat                                                  `thenRn` \ pat' ->
-
-    thing_inside (GeneratorQual pat' expr')            `thenRn` \ (result, fvs) ->     
-    returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders))
-  where
-    binders = collectPatBinders pat
-
-rnQual (FilterQual expr) thing_inside
-  = rnExpr expr                                `thenRn` \ (expr', fv_expr) ->
-    thing_inside (FilterQual expr')    `thenRn` \ (result, fvs) ->
-    returnRn (result, fv_expr `unionNameSets` fvs)
-
-rnQual (LetQual binds) thing_inside
-  = rnBinds binds                      $ \ binds' ->
-    thing_inside (LetQual binds')
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
-\subsubsection{@Stmt@s: in @do@ expressions}
-%*                                                                     *
-%************************************************************************
+rnStmt :: RnExprTy s -> RdrNameStmt -> (RenamedStmt -> RnMS s (a, FreeVars)) -> RnMS s (a, FreeVars)
+-- Because of mutual recursion we have to pass in rnExpr.
 
-\begin{code}
-rnStmts :: [RdrNameStmt] -> RnMS s ([RenamedStmt], FreeVars)
-
-rnStmts [stmt@(ExprStmt expr src_loc)]         -- last stmt must be ExprStmt
-  = pushSrcLocRn src_loc $
-    rnExpr expr                                `thenRn` \ (expr', fv_expr) ->
-    returnRn ([ExprStmt expr' src_loc], fv_expr)
-
-rnStmts (stmt:stmts)
-  = rnStmt stmt                                $ \ stmt' ->
-    rnStmts stmts                      `thenRn` \ (stmts', fv_stmts) ->
-    returnRn (stmt':stmts', fv_stmts)
-
-
--- rnStmt :: RdrNameStmt -> (RenamedStmt -> RnMS s (a, FreeVars)) -> RnMS s (a, FreeVars)
--- Because of mutual recursion the actual type is a bit less general than this [Haskell 1.2]
-
-rnStmt (BindStmt pat expr src_loc) thing_inside
+rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside
   = pushSrcLocRn src_loc $
-    rnExpr expr                                                `thenRn` \ (expr', fv_expr) ->
+    rn_expr expr                                       `thenRn` \ (expr', fv_expr) ->
     bindLocalsRn "pattern in do binding" binders       $ \ new_binders ->
     rnPat pat                                          `thenRn` \ pat' ->
 
@@ -450,13 +452,24 @@ rnStmt (BindStmt pat expr src_loc) thing_inside
   where
     binders = collectPatBinders pat
 
-rnStmt (ExprStmt expr src_loc) thing_inside
+rnStmt rn_expr (ExprStmt expr src_loc) thing_inside
   = pushSrcLocRn src_loc $
-    rnExpr expr                                        `thenRn` \ (expr', fv_expr) ->
+    rn_expr expr                               `thenRn` \ (expr', fv_expr) ->
     thing_inside (ExprStmt expr' src_loc)      `thenRn` \ (result, fvs) ->
     returnRn (result, fv_expr `unionNameSets` fvs)
 
-rnStmt (LetStmt binds) thing_inside
+rnStmt rn_expr (GuardStmt expr src_loc) thing_inside
+  = pushSrcLocRn src_loc $
+    rn_expr expr                               `thenRn` \ (expr', fv_expr) ->
+    thing_inside (GuardStmt expr' src_loc)     `thenRn` \ (result, fvs) ->
+    returnRn (result, fv_expr `unionNameSets` fvs)
+
+rnStmt rn_expr (ReturnStmt expr) thing_inside
+  = rn_expr expr                               `thenRn` \ (expr', fv_expr) ->
+    thing_inside (ReturnStmt expr')            `thenRn` \ (result, fvs) ->
+    returnRn (result, fv_expr `unionNameSets` fvs)
+
+rnStmt rn_expr (LetStmt binds) thing_inside
   = rnBinds binds              $ \ binds' ->
     thing_inside (LetStmt binds')
 \end{code}
@@ -467,85 +480,102 @@ rnStmt (LetStmt binds) thing_inside
 %*                                                                     *
 %************************************************************************
 
-@rnOpApp@ deals with operator applications.  It does some rearrangement of
-the expression so that the precedences are right.  This must be done on the
-expression *before* renaming, because fixity info applies to the things
-the programmer actually wrote.
+@mkOpAppRn@ deals with operator fixities.  The argument expressions
+are assumed to be already correctly arranged.  It needs the fixities
+recorded in the OpApp nodes, because fixity info applies to the things
+the programmer actually wrote, so you can't find it out from the Name.
+
+Furthermore, the second argument is guaranteed not to be another
+operator application.  Why? Because the parser parses all
+operator appications left-associatively.
 
 \begin{code}
-rnOpApp (NegApp e11 n) op e2
-  = lookupFixity op            `thenRn` \ (Fixity op_prec op_dir) ->
-    if op_prec > 6 then                
-       -- negate precedence 6 wired in
-       -- (-x)*y  ==> -(x*y)
-       completeNegApp (rnOpApp e11 op e2)
-    else
-       completeOpApp (completeNegApp (rnExpr e11)) op (rnExpr e2)
-
-rnOpApp (OpApp e11 (HsVar op1) e12) op e2
-  = lookupFixity op             `thenRn` \ op_fix@(Fixity op_prec  op_dir) ->
-    lookupFixity op1            `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
-    -- pprTrace "rnOpApp:" (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_dir, op_dir) of
-               (InfixR, InfixR) -> rearrange
-               (InfixL, InfixL) -> dont_rearrange
-               _ -> addErrRn (precParseErr (op1,op1_fix) (op,op_fix))  `thenRn_`
-                    dont_rearrange
-      GT__ -> dont_rearrange
+mkOpAppRn :: RenamedHsExpr -> RenamedHsExpr -> Fixity -> RenamedHsExpr
+         -> RnMS s RenamedHsExpr
+
+mkOpAppRn e1@(OpApp e11 op1 fix1 e12) 
+         op2 fix2 e2
+  | nofix_error
+  = addErrRn (precParseErr (get op1,fix1) (get op2,fix2))      `thenRn_`
+    returnRn (OpApp e1 op2 fix2 e2)
+
+  | rearrange_me
+  = mkOpAppRn e12 op2 fix2 e2          `thenRn` \ new_e ->
+    returnRn (OpApp e11 op1 fix1 new_e)
+  where
+    (nofix_error, rearrange_me) = compareFixity fix1 fix2
+
+mkOpAppRn e1@(NegApp neg_arg neg_op) 
+         op2 
+         fix2@(Fixity prec2 dir2)
+         e2
+  | nofix_error
+  = addErrRn (precParseErr (get neg_op,fix_neg) (get op2,fix2))        `thenRn_`
+    returnRn (OpApp e1 op2 fix2 e2)
+
+  | rearrange_me
+  = mkOpAppRn neg_arg op2 fix2 e2      `thenRn` \ new_e ->
+    returnRn (NegApp new_e neg_op)
   where
-    rearrange      = rnOpApp e11 op1 (OpApp e12 (HsVar op) e2)
-    dont_rearrange = completeOpApp (rnOpApp e11 op1 e12) op (rnExpr e2)
+    fix_neg = Fixity 6 InfixL          -- Precedence of unary negate is wired in as infixl 6!
+    (nofix_error, rearrange_me) = compareFixity fix_neg fix2
 
-rnOpApp e1 op e2 = completeOpApp (rnExpr e1) op (rnExpr e2)
+mkOpAppRn e1 op fix e2                         -- Default case, no rearrangment
+  = ASSERT( right_op_ok fix e2 )
+    returnRn (OpApp e1 op fix e2)
 
-completeOpApp rn_e1 op rn_e2
-  = rn_e1              `thenRn` \ (e1', fvs1) ->
-    rn_e2              `thenRn` \ (e2', fvs2) ->
-    rnExpr (HsVar op)  `thenRn` \ (op', fvs3) ->
-    returnRn (OpApp e1' op' e2', fvs1 `unionNameSets` fvs2 `unionNameSets` fvs3)
+get (HsVar n) = n
 
-completeNegApp rn_expr
-  = rn_expr                            `thenRn` \ (e', fvs_e) ->
-    lookupImplicitOccRn negate_RDR     `thenRn` \ neg ->
-    returnRn (NegApp e' (HsVar neg), fvs_e)
+-- Parser left-associates everything, but 
+-- derived instances may have correctly-associated things to
+-- in the right operarand.  So we just check that the right operand is OK
+right_op_ok fix1 (OpApp _ _ fix2 _)
+  = not error_please && associate_right
+  where
+    (error_please, associate_right) = compareFixity fix1 fix2
+right_op_ok fix1 other
+  = True
+
+-- Parser initially makes negation bind more tightly than any other operator
+mkNegAppRn mode neg_arg neg_op
+  = ASSERT( not_op_app mode neg_arg )
+    returnRn (NegApp neg_arg neg_op)
+
+not_op_app SourceMode (OpApp _ _ _ _) = False
+not_op_app mode other                = True
 \end{code}
 
 \begin{code}
-rnOpPat p1@(NegPatIn p11) op p2
-  = lookupFixity op            `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
-    if op_prec > 6 then        
-       -- negate precedence 6 wired in
-       addErrRn (precParseNegPatErr (op,op_fix))       `thenRn_`
-       rnOpPat p11 op p2                               `thenRn` \ op_pat ->
-       returnRn (NegPatIn op_pat)
-    else
-       completeOpPat (rnPat p1) op (rnPat p2)
-
-rnOpPat (ConOpPatIn p11 op1 p12) op p2
-  = lookupFixity op             `thenRn` \  op_fix@(Fixity op_prec  op_dir) ->
-    lookupFixity op1            `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
-    case (op1_prec `cmp` op_prec) of
-      LT_  -> rearrange
-      EQ_  -> case (op1_dir, op_dir) of
-               (InfixR, InfixR) -> rearrange
-               (InfixL, InfixL) -> dont_rearrange
-               _ -> addErrRn (precParseErr (op1,op1_fix) (op,op_fix))  `thenRn_`
-                    dont_rearrange
-      GT__ -> dont_rearrange
-  where
-    rearrange      = rnOpPat p11 op1 (ConOpPatIn p12 op p2)
-    dont_rearrange = completeOpPat (rnOpPat p11 op1 p12) op (rnPat p2)
+mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
+            -> RnMS s RenamedPat
 
+mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12) 
+            op2 fix2 p2
+  | nofix_error
+  = addErrRn (precParseErr (op1,fix1) (op2,fix2))      `thenRn_`
+    returnRn (ConOpPatIn p1 op2 fix2 p2)
 
-rnOpPat p1 op p2 = completeOpPat (rnPat p1) op (rnPat p2)
+  | rearrange_me
+  = mkConOpPatRn p12 op2 fix2 p2               `thenRn` \ new_p ->
+    returnRn (ConOpPatIn p11 op1 fix1 new_p)
 
-completeOpPat rn_p1 op rn_p2
-  = rn_p1              `thenRn` \ p1' ->
-    rn_p2              `thenRn` \ p2' -> 
-    lookupRn op                `thenRn` \ op' ->
-    returnRn (ConOpPatIn p1' op' p2')
+  where
+    (nofix_error, rearrange_me) = compareFixity fix1 fix2
+
+mkConOpPatRn p1@(NegPatIn neg_arg) 
+         op2 
+         fix2@(Fixity prec2 dir2)
+         p2
+  | prec2 > 6  -- Precedence of unary - is wired in as 6!
+  = addErrRn (precParseNegPatErr (op2,fix2))   `thenRn_`
+    returnRn (ConOpPatIn p1 op2 fix2 p2)
+
+mkConOpPatRn p1 op fix p2                      -- Default case, no rearrangment
+  = ASSERT( not_op_pat p2 )
+    returnRn (ConOpPatIn p1 op fix p2)
+
+not_op_pat (ConOpPatIn _ _ _ _) = False
+not_op_pat other               = True
 \end{code}
 
 \begin{code}
@@ -559,7 +589,7 @@ checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _)))
 checkPrecMatch True op _
   = panic "checkPrecMatch"
 
-checkPrec op (ConOpPatIn _ op1 _) right
+checkPrec op (ConOpPatIn _ op1 _ _) right
   = lookupFixity op    `thenRn` \  op_fix@(Fixity op_prec  op_dir) ->
     lookupFixity op1   `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
     let
@@ -582,6 +612,30 @@ checkPrec op pat right
   = returnRn ()
 \end{code}
 
+Consider
+       a `op1` b `op2` c
+
+(compareFixity op1 op2) tells which way to arrange appication, or
+whether there's an error.
+
+\begin{code}
+compareFixity :: Fixity -> Fixity
+             -> (Bool,         -- Error please
+                 Bool)         -- Associate to the right: a op1 (b op2 c)
+compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
+  = case prec1 `cmp` prec2 of
+       GT_ -> left
+       LT_ -> right
+       EQ_ -> case (dir1, dir2) of
+                       (InfixR, InfixR) -> right
+                       (InfixL, InfixL) -> left
+                       _                -> error_please
+  where
+    right       = (False, True)
+    left         = (False, False)
+    error_please = (True,  False)
+\end{code}
+
 %************************************************************************
 %*                                                                     *
 \subsubsection{Literals}
@@ -606,13 +660,15 @@ litOccurrence (HsStringPrim _)
   = addImplicitOccRn (getName addrPrimTyCon)
 
 litOccurrence (HsInt _)
-  = lookupImplicitOccRn numClass_RDR   `thenRn_`       -- Int and Integer are forced in by Num
-    returnRn ()
+  = lookupImplicitOccRn numClass_RDR                   -- Int and Integer are forced in by Num
 
 litOccurrence (HsFrac _)
-  = lookupImplicitOccRn fractionalClass_RDR    `thenRn_`       -- ... similarly Rational
-    returnRn ()
-
+  = lookupImplicitOccRn fractionalClass_RDR    `thenRn_`
+    lookupImplicitOccRn ratioDataCon_RDR
+       -- We have to make sure that the Ratio type is imported with
+       -- its constructor, because literals of type Ratio t are
+       -- built with that constructor. 
+    
 litOccurrence (HsIntPrim _)
   = addImplicitOccRn (getName intPrimTyCon)
 
@@ -623,8 +679,7 @@ litOccurrence (HsDoublePrim _)
   = addImplicitOccRn (getName doublePrimTyCon)
 
 litOccurrence (HsLitLit _)
-  = lookupImplicitOccRn ccallableClass_RDR     `thenRn_`
-    returnRn ()
+  = lookupImplicitOccRn ccallableClass_RDR
 \end{code}
 
 
@@ -636,19 +691,27 @@ litOccurrence (HsLitLit _)
 
 \begin{code}
 dupFieldErr str (dup:rest) sty
-  = ppBesides [ppStr "duplicate field name `", ppr sty dup, ppStr "' in record ", ppStr str]
+  = hcat [ptext SLIT("duplicate field name `"), 
+               ppr sty dup, 
+              ptext SLIT("' in record "), text str]
 
 negPatErr pat  sty
-  = ppSep [ppStr "prefix `-' not applied to literal in pattern", ppr sty pat]
+  = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), ppr sty pat]
 
 precParseNegPatErr op sty 
-  = ppHang (ppStr "precedence parsing error")
-      4 (ppBesides [ppStr "prefix `-' has lower precedence than ", pp_op sty op, ppStr " in pattern"])
+  = hang (ptext SLIT("precedence parsing error"))
+      4 (hcat [ptext SLIT("prefix `-' has lower precedence than "), 
+                   pp_op sty op, 
+                   ptext SLIT(" in pattern")])
 
 precParseErr op1 op2  sty
-  = ppHang (ppStr "precedence parsing error")
-      4 (ppBesides [ppStr "cannot mix ", pp_op sty op1, ppStr " and ", pp_op sty op2,
-                   ppStr " in the same infix expression"])
+  = hang (ptext SLIT("precedence parsing error"))
+      4 (hcat [ptext SLIT("cannot mix "), pp_op sty op1, ptext SLIT(" and "), pp_op sty op2,
+                   ptext SLIT(" in the same infix expression")])
+
+nonStdGuardErr guard sty
+  = hang (ptext SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)"))
+      4 (ppr sty guard)
 
-pp_op sty (op, fix) = ppBesides [pprSym sty op, ppLparen, ppr sty fix, ppRparen]
+pp_op sty (op, fix) = hcat [ppr sty op, space, parens (ppr sty fix)]
 \end{code}