ghc/compiler/rename/RnExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[RnExpr]{Renaming of expressions}
   5
   6 Basically dependency analysis.
   7
   8 Handles @Match@, @GRHSsAndBinds@, @HsExpr@, and @Qual@ datatypes.  In
   9 general, all of these functions return a renamed thing, and a set of
  10 free variables.
  11
  12 \begin{code}
  13 #include "HsVersions.h"
  14
  15 module RnExpr (
  16         rnMatch, rnGRHSsAndBinds, rnPat,
  17         checkPrecMatch
  18    ) where
  19
  20 import Ubiq
  21 import RnLoop           -- break the RnPass/RnExpr/RnBinds loops
  22
  23 import HsSyn
  24 import RdrHsSyn
  25 import RnHsSyn
  26 import RnMonad
  27
  28 import ErrUtils         ( addErrLoc )
  29 import Name             ( isLocallyDefinedName, pprSym, Name, RdrName )
  30 import Pretty
  31 import UniqFM           ( lookupUFM )
  32 import UniqSet          ( emptyUniqSet, unitUniqSet,
  33                           unionUniqSets, unionManyUniqSets,
  34                           UniqSet(..) )
  35 import Util             ( Ord3(..), panic )
  36 \end{code}
  37
  38
  39 *********************************************************
  40 *                                                       *
  41 \subsection{Patterns}
  42 *                                                       *
  43 *********************************************************
  44
  45 \begin{code}
  46 rnPat :: RdrNamePat -> RnM_Fixes s RenamedPat
  47
  48 rnPat WildPatIn = returnRn WildPatIn
  49
  50 rnPat (VarPatIn name)
  51   = lookupValue name    `thenRn` \ vname ->
  52     returnRn (VarPatIn vname)
  53
  54 rnPat (LitPatIn n) = returnRn (LitPatIn n)
  55
  56 rnPat (LazyPatIn pat)
  57   = rnPat pat           `thenRn` \ pat' ->
  58     returnRn (LazyPatIn pat')
  59
  60 rnPat (AsPatIn name pat)
  61   = rnPat pat   `thenRn` \ pat' ->
  62     lookupValue name    `thenRn` \ vname ->
  63     returnRn (AsPatIn vname pat')
  64
  65 rnPat (ConPatIn name pats)
  66   = lookupValue name    `thenRn` \ name' ->
  67     mapRn rnPat pats    `thenRn` \ patslist ->
  68     returnRn (ConPatIn name' patslist)
  69
  70 rnPat (ConOpPatIn pat1 name pat2)
  71   = lookupValue name    `thenRn` \ name' ->
  72     rnPat pat1          `thenRn` \ pat1' ->
  73     rnPat pat2          `thenRn` \ pat2' ->
  74     precParsePat (ConOpPatIn pat1' name' pat2')
  75
  76 rnPat neg@(NegPatIn pat)
  77   = getSrcLocRn         `thenRn` \ src_loc ->
  78     addErrIfRn (not (valid_neg_pat pat)) (negPatErr neg src_loc)
  79                         `thenRn_`
  80     rnPat pat           `thenRn` \ pat' ->
  81     returnRn (NegPatIn pat')
  82   where
  83     valid_neg_pat (LitPatIn (HsInt  _)) = True
  84     valid_neg_pat (LitPatIn (HsFrac _)) = True
  85     valid_neg_pat _                     = False
  86
  87 rnPat (ParPatIn pat)
  88   = rnPat pat           `thenRn` \ pat' ->
  89     returnRn (ParPatIn pat')
  90
  91 rnPat (ListPatIn pats)
  92   = mapRn rnPat pats    `thenRn` \ patslist ->
  93     returnRn (ListPatIn patslist)
  94
  95 rnPat (TuplePatIn pats)
  96   = mapRn rnPat pats    `thenRn` \ patslist ->
  97     returnRn (TuplePatIn patslist)
  98
  99 rnPat (RecPatIn con rpats)
 100   = panic "rnPat:RecPatIn"
 101
 102 \end{code}
 103
 104 ************************************************************************
 105 *                                                                       *
 106 \subsection{Match}
 107 *                                                                       *
 108 ************************************************************************
 109
 110 \begin{code}
 111 rnMatch :: RdrNameMatch -> RnM_Fixes s (RenamedMatch, FreeVars)
 112
 113 rnMatch match
 114   = getSrcLocRn                 `thenRn` \ src_loc ->
 115     newLocalNames "variable in pattern"
 116          (binders `zip` repeat src_loc) `thenRn` \ new_binders ->
 117     extendSS2 new_binders (rnMatch_aux match)
 118   where
 119     binders = collect_binders match
 120
 121     collect_binders :: RdrNameMatch -> [RdrName]
 122
 123     collect_binders (GRHSMatch _) = []
 124     collect_binders (PatMatch pat match)
 125       = collectPatBinders pat ++ collect_binders match
 126
 127 rnMatch_aux (PatMatch pat match)
 128   = rnPat pat           `thenRn` \ pat' ->
 129     rnMatch_aux match   `thenRn` \ (match', fvMatch) ->
 130     returnRn (PatMatch pat' match', fvMatch)
 131
 132 rnMatch_aux (GRHSMatch grhss_and_binds)
 133   = rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
 134     returnRn (GRHSMatch grhss_and_binds', fvs)
 135 \end{code}
 136
 137 %************************************************************************
 138 %*                                                                      *
 139 \subsubsection{Guarded right-hand sides (GRHSsAndBinds)}
 140 %*                                                                      *
 141 %************************************************************************
 142
 143 \begin{code}
 144 rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnM_Fixes s (RenamedGRHSsAndBinds, FreeVars)
 145
 146 rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
 147   = rnBinds binds                       `thenRn` \ (binds', fvBinds, scope) ->
 148     extendSS2 scope (rnGRHSs grhss)     `thenRn` \ (grhss', fvGRHS) ->
 149     returnRn (GRHSsAndBindsIn grhss' binds', fvBinds `unionUniqSets` fvGRHS)
 150   where
 151     rnGRHSs [] = returnRn ([], emptyUniqSet)
 152
 153     rnGRHSs (grhs:grhss)
 154       = rnGRHS  grhs   `thenRn` \ (grhs',  fvs) ->
 155         rnGRHSs grhss  `thenRn` \ (grhss', fvss) ->
 156         returnRn (grhs' : grhss', fvs `unionUniqSets` fvss)
 157
 158     rnGRHS (GRHS guard expr locn)
 159       = pushSrcLocRn locn $
 160         rnExpr guard    `thenRn` \ (guard', fvsg) ->
 161         rnExpr expr     `thenRn` \ (expr',  fvse) ->
 162         returnRn (GRHS guard' expr' locn, fvsg `unionUniqSets` fvse)
 163
 164     rnGRHS (OtherwiseGRHS expr locn)
 165       = pushSrcLocRn locn $
 166         rnExpr expr     `thenRn` \ (expr', fvs) ->
 167         returnRn (OtherwiseGRHS expr' locn, fvs)
 168 \end{code}
 169
 170 %************************************************************************
 171 %*                                                                      *
 172 \subsubsection{Expressions}
 173 %*                                                                      *
 174 %************************************************************************
 175
 176 \begin{code}
 177 rnExprs :: [RdrNameHsExpr] -> RnM_Fixes s ([RenamedHsExpr], FreeVars)
 178
 179 rnExprs [] = returnRn ([], emptyUniqSet)
 180
 181 rnExprs (expr:exprs)
 182   = rnExpr expr         `thenRn` \ (expr', fvExpr) ->
 183     rnExprs exprs       `thenRn` \ (exprs', fvExprs) ->
 184     returnRn (expr':exprs', fvExpr `unionUniqSets` fvExprs)
 185 \end{code}
 186
 187 Variables. We look up the variable and return the resulting name.  The
 188 interesting question is what the free-variable set should be.  We
 189 don't want to return imported or prelude things as free vars.  So we
 190 look at the RnName returned from the lookup, and make it part of the
 191 free-var set iff if it's a LocallyDefined RnName.
 192
 193 ToDo: what about RnClassOps ???
 194 \end{itemize}
 195
 196 \begin{code}
 197 rnExpr :: RdrNameHsExpr -> RnM_Fixes s (RenamedHsExpr, FreeVars)
 198
 199 rnExpr (HsVar v)
 200   = lookupValue v       `thenRn` \ vname ->
 201     returnRn (HsVar vname, fv_set vname)
 202   where
 203     fv_set vname@(RnName n)
 204       | isLocallyDefinedName n = unitUniqSet vname
 205     fv_set _                   = emptyUniqSet
 206
 207 rnExpr (HsLit lit)
 208   = returnRn (HsLit lit, emptyUniqSet)
 209
 210 rnExpr (HsLam match)
 211   = rnMatch match       `thenRn` \ (match', fvMatch) ->
 212     returnRn (HsLam match', fvMatch)
 213
 214 rnExpr (HsApp fun arg)
 215   = rnExpr fun          `thenRn` \ (fun',fvFun) ->
 216     rnExpr arg          `thenRn` \ (arg',fvArg) ->
 217     returnRn (HsApp fun' arg', fvFun `unionUniqSets` fvArg)
 218
 219 rnExpr (OpApp e1 op e2)
 220   = rnExpr e1           `thenRn` \ (e1', fvs_e1) ->
 221     rnExpr op           `thenRn` \ (op', fvs_op) ->
 222     rnExpr e2           `thenRn` \ (e2', fvs_e2) ->
 223     precParseExpr (OpApp e1' op' e2') `thenRn` \ exp ->
 224     returnRn (exp, (fvs_op `unionUniqSets` fvs_e1) `unionUniqSets` fvs_e2)
 225
 226 rnExpr (NegApp e)
 227   = rnExpr e            `thenRn` \ (e', fvs_e) ->
 228     returnRn (NegApp e', fvs_e)
 229
 230 rnExpr (HsPar e)
 231   = rnExpr e            `thenRn` \ (e', fvs_e) ->
 232     returnRn (HsPar e', fvs_e)
 233
 234 rnExpr (SectionL expr op)
 235   = rnExpr expr         `thenRn` \ (expr', fvs_expr) ->
 236     rnExpr op           `thenRn` \ (op', fvs_op) ->
 237     returnRn (SectionL expr' op', fvs_op `unionUniqSets` fvs_expr)
 238
 239 rnExpr (SectionR op expr)
 240   = rnExpr op           `thenRn` \ (op',   fvs_op) ->
 241     rnExpr expr         `thenRn` \ (expr', fvs_expr) ->
 242     returnRn (SectionR op' expr', fvs_op `unionUniqSets` fvs_expr)
 243
 244 rnExpr (CCall fun args may_gc is_casm fake_result_ty)
 245   = rnExprs args        `thenRn` \ (args', fvs_args) ->
 246     returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
 247
 248 rnExpr (HsSCC label expr)
 249   = rnExpr expr         `thenRn` \ (expr', fvs_expr) ->
 250     returnRn (HsSCC label expr', fvs_expr)
 251
 252 rnExpr (HsCase expr ms src_loc)
 253   = pushSrcLocRn src_loc $
 254     rnExpr expr                 `thenRn` \ (new_expr, e_fvs) ->
 255     mapAndUnzipRn rnMatch ms    `thenRn` \ (new_ms, ms_fvs) ->
 256     returnRn (HsCase new_expr new_ms src_loc, unionManyUniqSets (e_fvs : ms_fvs))
 257
 258 rnExpr (HsLet binds expr)
 259   = rnBinds binds               `thenRn` \ (binds', fvBinds, new_binders) ->
 260     extendSS2 new_binders (rnExpr expr) `thenRn` \ (expr',fvExpr) ->
 261     returnRn (HsLet binds' expr', fvBinds `unionUniqSets` fvExpr)
 262
 263 rnExpr (HsDo stmts src_loc)
 264   = pushSrcLocRn src_loc $
 265     rnStmts stmts               `thenRn` \ (stmts', fvStmts) ->
 266     returnRn (HsDo stmts' src_loc, fvStmts)
 267
 268 rnExpr (ListComp expr quals)
 269   = rnQuals quals               `thenRn` \ ((quals', qual_binders), fvQuals) ->
 270     extendSS2 qual_binders (rnExpr expr) `thenRn` \ (expr', fvExpr) ->
 271     returnRn (ListComp expr' quals', fvExpr `unionUniqSets` fvQuals)
 272
 273 rnExpr (ExplicitList exps)
 274   = rnExprs exps                `thenRn` \ (exps', fvs) ->
 275     returnRn  (ExplicitList exps', fvs)
 276
 277 rnExpr (ExplicitTuple exps)
 278   = rnExprs exps                `thenRn` \ (exps', fvExps) ->
 279     returnRn (ExplicitTuple exps', fvExps)
 280
 281 rnExpr (RecordCon con rbinds)
 282   = panic "rnExpr:RecordCon"
 283 rnExpr (RecordUpd exp rbinds)
 284   = panic "rnExpr:RecordUpd"
 285
 286 rnExpr (ExprWithTySig expr pty)
 287   = rnExpr expr                         `thenRn` \ (expr', fvExpr) ->
 288     rnPolyType nullTyVarNamesEnv pty `thenRn` \ pty' ->
 289     returnRn (ExprWithTySig expr' pty', fvExpr)
 290
 291 rnExpr (HsIf p b1 b2 src_loc)
 292   = pushSrcLocRn src_loc $
 293     rnExpr p            `thenRn` \ (p', fvP) ->
 294     rnExpr b1           `thenRn` \ (b1', fvB1) ->
 295     rnExpr b2           `thenRn` \ (b2', fvB2) ->
 296     returnRn (HsIf p' b1' b2' src_loc, unionManyUniqSets [fvP, fvB1, fvB2])
 297
 298 rnExpr (ArithSeqIn seq)
 299   = rn_seq seq          `thenRn` \ (new_seq, fvs) ->
 300     returnRn (ArithSeqIn new_seq, fvs)
 301   where
 302     rn_seq (From expr)
 303      = rnExpr expr      `thenRn` \ (expr', fvExpr) ->
 304        returnRn (From expr', fvExpr)
 305
 306     rn_seq (FromThen expr1 expr2)
 307      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 308        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 309        returnRn (FromThen expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
 310
 311     rn_seq (FromTo expr1 expr2)
 312      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 313        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 314        returnRn (FromTo expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
 315
 316     rn_seq (FromThenTo expr1 expr2 expr3)
 317      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 318        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 319        rnExpr expr3     `thenRn` \ (expr3', fvExpr3) ->
 320        returnRn (FromThenTo expr1' expr2' expr3',
 321                   unionManyUniqSets [fvExpr1, fvExpr2, fvExpr3])
 322
 323 \end{code}
 324
 325 %************************************************************************
 326 %*                                                                      *
 327 \subsubsection{@Qual@s: in list comprehensions}
 328 %*                                                                      *
 329 %************************************************************************
 330
 331 Note that although some bound vars may appear in the free var set for
 332 the first qual, these will eventually be removed by the caller. For
 333 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
 334 @[q <- r, p <- q]@, the free var set for @q <- r@ will
 335 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
 336 @r@ will be removed only when we finally return from examining all the
 337 Quals.
 338
 339 \begin{code}
 340 rnQuals :: [RdrNameQual]
 341          -> RnM_Fixes s (([RenamedQual],        -- renamed qualifiers
 342                          [RnName]),             -- qualifiers' binders
 343                          FreeVars)              -- free variables
 344
 345 rnQuals [qual]                          -- must be at least one qual
 346   = rnQual qual `thenRn` \ ((new_qual, bs), fvs) ->
 347     returnRn (([new_qual], bs), fvs)
 348
 349 rnQuals (qual: quals)
 350   = rnQual qual                         `thenRn` \ ((qual',  bs1), fvQuals1) ->
 351     extendSS2 bs1 (rnQuals quals)       `thenRn` \ ((quals', bs2), fvQuals2) ->
 352     returnRn
 353        ((qual' : quals', bs2 ++ bs1),   -- The ones on the right (bs2) shadow the
 354                                         -- ones on the left (bs1)
 355         fvQuals1 `unionUniqSets` fvQuals2)
 356
 357 rnQual (GeneratorQual pat expr)
 358   = rnExpr expr          `thenRn` \ (expr', fvExpr) ->
 359     let
 360         binders = collectPatBinders pat
 361     in
 362     getSrcLocRn          `thenRn` \ src_loc ->
 363     newLocalNames "variable in list-comprehension-generator pattern"
 364          (binders `zip` repeat src_loc)   `thenRn` \ new_binders ->
 365     extendSS new_binders (rnPat pat) `thenRn` \ pat' ->
 366
 367     returnRn ((GeneratorQual pat' expr', new_binders), fvExpr)
 368
 369 rnQual (FilterQual expr)
 370   = rnExpr expr  `thenRn` \ (expr', fvs) ->
 371     returnRn ((FilterQual expr', []), fvs)
 372
 373 rnQual (LetQual binds)
 374   = rnBinds binds       `thenRn` \ (binds', binds_fvs, new_binders) ->
 375     returnRn ((LetQual binds', new_binders), binds_fvs)
 376 \end{code}
 377
 378
 379 %************************************************************************
 380 %*                                                                      *
 381 \subsubsection{@Stmt@s: in @do@ expressions}
 382 %*                                                                      *
 383 %************************************************************************
 384
 385 \begin{code}
 386 rnStmts :: [RdrNameStmt] -> RnM_Fixes s ([RenamedStmt], FreeVars)
 387
 388 rnStmts [stmt@(ExprStmt _ _)]           -- last stmt must be ExprStmt
 389   = rnStmt stmt                         `thenRn` \ ((stmt',[]), fvStmt) ->
 390     returnRn ([stmt'], fvStmt)
 391
 392 rnStmts (stmt:stmts)
 393   = rnStmt stmt                         `thenRn` \ ((stmt',bs), fvStmt) ->
 394     extendSS2 bs (rnStmts stmts)        `thenRn` \ (stmts',     fvStmts) ->
 395     returnRn (stmt':stmts', fvStmt `unionUniqSets` fvStmts)
 396
 397
 398 rnStmt (BindStmt pat expr src_loc)
 399   = pushSrcLocRn src_loc $
 400     rnExpr expr                         `thenRn` \ (expr', fvExpr) ->
 401     let
 402         binders = collectPatBinders pat
 403     in
 404     newLocalNames "variable in do binding"
 405          (binders `zip` repeat src_loc) `thenRn` \ new_binders ->
 406     extendSS new_binders (rnPat pat)    `thenRn` \ pat' ->
 407
 408     returnRn ((BindStmt pat' expr' src_loc, new_binders), fvExpr)
 409
 410 rnStmt (ExprStmt expr src_loc)
 411   =
 412     rnExpr expr                         `thenRn` \ (expr', fvs) ->
 413     returnRn ((ExprStmt expr' src_loc, []), fvs)
 414
 415 rnStmt (LetStmt binds)
 416   = rnBinds binds       `thenRn` \ (binds', binds_fvs, new_binders) ->
 417     returnRn ((LetStmt binds', new_binders), binds_fvs)
 418
 419 \end{code}
 420
 421 %************************************************************************
 422 %*                                                                      *
 423 \subsubsection{Precedence Parsing}
 424 %*                                                                      *
 425 %************************************************************************
 426
 427 \begin{code}
 428 precParseExpr :: RenamedHsExpr -> RnM_Fixes s RenamedHsExpr
 429 precParsePat  :: RenamedPat -> RnM_Fixes s RenamedPat
 430
 431 precParseExpr exp@(OpApp (NegApp e1) (HsVar op) e2)
 432   = lookupFixity op             `thenRn` \ (op_fix, op_prec) ->
 433     if 6 < op_prec then
 434         -- negate precedence 6 wired in
 435         -- (-x)*y  ==> -(x*y)
 436         precParseExpr (OpApp e1 (HsVar op) e2) `thenRn` \ op_app ->
 437         returnRn (NegApp op_app)
 438     else
 439         returnRn exp
 440
 441 precParseExpr exp@(OpApp (OpApp e11 (HsVar op1) e12) (HsVar op) e2)
 442   = lookupFixity op              `thenRn` \ (op_fix, op_prec) ->
 443     lookupFixity op1             `thenRn` \ (op1_fix, op1_prec) ->
 444     case cmp op1_prec op_prec of
 445       LT_  -> rearrange
 446       EQ_  -> case (op1_fix, op_fix) of
 447                 (INFIXR, INFIXR) -> rearrange
 448                 (INFIXL, INFIXL) -> returnRn exp
 449                 _ -> getSrcLocRn `thenRn` \ src_loc ->
 450                      failButContinueRn exp
 451                      (precParseErr (op1,op1_fix,op1_prec) (op,op_fix,op_prec) src_loc)
 452       GT__ -> returnRn exp
 453   where
 454     rearrange = precParseExpr (OpApp e12 (HsVar op) e2) `thenRn` \ e2' ->
 455                 returnRn (OpApp e11 (HsVar op1) e2')
 456
 457 precParseExpr exp = returnRn exp
 458
 459
 460 precParsePat pat@(ConOpPatIn (NegPatIn e1) op e2)
 461   = lookupFixity op             `thenRn` \ (op_fix, op_prec) ->
 462     if 6 < op_prec then
 463         -- negate precedence 6 wired in
 464         getSrcLocRn `thenRn` \ src_loc ->
 465         failButContinueRn pat (precParseNegPatErr (op,op_fix,op_prec) src_loc)
 466     else
 467         returnRn pat
 468
 469 precParsePat pat@(ConOpPatIn (ConOpPatIn p11 op1 p12) op p2)
 470   = lookupFixity op              `thenRn` \ (op_fix, op_prec) ->
 471     lookupFixity op1             `thenRn` \ (op1_fix, op1_prec) ->
 472     case cmp op1_prec op_prec of
 473       LT_  -> rearrange
 474       EQ_  -> case (op1_fix, op_fix) of
 475                 (INFIXR, INFIXR) -> rearrange
 476                 (INFIXL, INFIXL) -> returnRn pat
 477                 _ -> getSrcLocRn `thenRn` \ src_loc ->
 478                      failButContinueRn pat
 479                        (precParseErr (op1,op1_fix,op1_prec) (op,op_fix,op_prec) src_loc)
 480       GT__ -> returnRn pat
 481   where
 482     rearrange = precParsePat (ConOpPatIn p12 op p2) `thenRn` \ p2' ->
 483                 returnRn (ConOpPatIn p11 op1 p2')
 484
 485 precParsePat pat = returnRn pat
 486
 487
 488 data INFIX = INFIXL | INFIXR | INFIXN deriving Eq
 489
 490 lookupFixity :: RnName -> RnM_Fixes s (INFIX, Int)
 491 lookupFixity op
 492   = getExtraRn `thenRn` \ fixity_fm ->
 493     case lookupUFM fixity_fm op of
 494       Nothing           -> returnRn (INFIXL, 9)
 495       Just (InfixL _ n) -> returnRn (INFIXL, n)
 496       Just (InfixR _ n) -> returnRn (INFIXR, n)
 497       Just (InfixN _ n) -> returnRn (INFIXN, n)
 498 \end{code}
 499
 500 \begin{code}
 501 checkPrecMatch :: Bool -> RnName -> RenamedMatch -> RnM_Fixes s ()
 502
 503 checkPrecMatch False fn match
 504   = returnRn ()
 505 checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _)))
 506   = checkPrec op p1 False       `thenRn_`
 507     checkPrec op p2 True
 508 checkPrecMatch True op _
 509   = panic "checkPrecMatch"
 510
 511 checkPrec op (ConOpPatIn _ op1 _) right
 512   = lookupFixity op     `thenRn` \ (op_fix, op_prec) ->
 513     lookupFixity op1    `thenRn` \ (op1_fix, op1_prec) ->
 514     getSrcLocRn         `thenRn` \ src_loc ->
 515     let
 516         inf_ok = op1_prec > op_prec ||
 517                  (op1_prec == op_prec &&
 518                   (op1_fix == INFIXR && op_fix == INFIXR && right ||
 519                    op1_fix == INFIXL && op_fix == INFIXL && not right))
 520
 521         info  = (op,op_fix,op_prec)
 522         info1 = (op1,op1_fix,op1_prec)
 523         (infol, infor) = if right then (info, info1) else (info1, info)
 524     in
 525     addErrIfRn (not inf_ok) (precParseErr infol infor src_loc)
 526
 527 checkPrec op (NegPatIn _) right
 528   = lookupFixity op     `thenRn` \ (op_fix, op_prec) ->
 529     getSrcLocRn         `thenRn` \ src_loc ->
 530     addErrIfRn (6 < op_prec) (precParseNegPatErr (op,op_fix,op_prec) src_loc)
 531
 532 checkPrec op pat right
 533   = returnRn ()
 534 \end{code}
 535
 536 \begin{code}
 537 negPatErr pat src_loc
 538   = addErrLoc src_loc "prefix `-' not applied to literal in pattern" ( \sty ->
 539     ppr sty pat)
 540
 541 precParseNegPatErr op src_loc
 542   = addErrLoc src_loc "precedence parsing error" (\ sty ->
 543     ppBesides [ppStr "prefix `-' has lower precedence than ", pp_op sty op, ppStr " in pattern"])
 544
 545 precParseErr op1 op2 src_loc
 546   = addErrLoc src_loc "precedence parsing error" (\ sty ->
 547     ppBesides [ppStr "cannot mix ", pp_op sty op1, ppStr " and ", pp_op sty op2,
 548                ppStr " in the same infix expression"])
 549
 550 pp_op sty (op, fix, prec) = ppBesides [pprSym sty op, ppLparen, pp_fix fix, ppSP, ppInt prec, ppRparen]
 551 pp_fix INFIXL = ppStr "infixl"
 552 pp_fix INFIXR = ppStr "infixr"
 553 pp_fix INFIXN = ppStr "infix"
 554 \end{code}