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