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