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 import RnEnv
  28 import PrelInfo         ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR,
  29                           creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, ordClass_RDR,
  30                           negate_RDR
  31                         )
  32 import TysPrim          ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
  33                           floatPrimTyCon, doublePrimTyCon
  34                         )
  35 import TyCon            ( TyCon )
  36 import Id               ( GenId )
  37 import ErrUtils         ( addErrLoc, addShortErrLocLine )
  38 import Name
  39 import Pretty
  40 import Unique           ( Unique, otherwiseIdKey )
  41 import UniqFM           ( lookupUFM{-, ufmToList ToDo:rm-} )
  42 import UniqSet          ( emptyUniqSet, unitUniqSet,
  43                           unionUniqSets, unionManyUniqSets,
  44                           SYN_IE(UniqSet)
  45                         )
  46 import PprStyle         ( PprStyle(..) )
  47 import Util             ( Ord3(..), removeDups, panic, pprPanic, assertPanic )
  48 \end{code}
  49
  50
  51 *********************************************************
  52 *                                                       *
  53 \subsection{Patterns}
  54 *                                                       *
  55 *********************************************************
  56
  57 \begin{code}
  58 rnPat :: RdrNamePat -> RnMS s RenamedPat
  59
  60 rnPat WildPatIn = returnRn WildPatIn
  61
  62 rnPat (VarPatIn name)
  63   = lookupBndrRn  name                  `thenRn` \ vname ->
  64     returnRn (VarPatIn vname)
  65
  66 rnPat (LitPatIn lit)
  67   = litOccurrence lit                   `thenRn_`
  68     lookupImplicitOccRn eqClass_RDR     `thenRn_`       -- Needed to find equality on pattern
  69     returnRn (LitPatIn lit)
  70
  71 rnPat (LazyPatIn pat)
  72   = rnPat pat           `thenRn` \ pat' ->
  73     returnRn (LazyPatIn pat')
  74
  75 rnPat (AsPatIn name pat)
  76   = rnPat pat           `thenRn` \ pat' ->
  77     lookupBndrRn name   `thenRn` \ vname ->
  78     returnRn (AsPatIn vname pat')
  79
  80 rnPat (ConPatIn con pats)
  81   = lookupOccRn con     `thenRn` \ con' ->
  82     mapRn rnPat pats    `thenRn` \ patslist ->
  83     returnRn (ConPatIn con' patslist)
  84
  85 rnPat (ConOpPatIn pat1 con _ pat2)
  86   = rnPat pat1          `thenRn` \ pat1' ->
  87     lookupOccRn con     `thenRn` \ con' ->
  88     lookupFixity con    `thenRn` \ fixity ->
  89     rnPat pat2          `thenRn` \ pat2' ->
  90     mkConOpPatRn pat1' con' fixity pat2'
  91
  92 -- Negated patters can only be literals, and they are dealt with
  93 -- by negating the literal at compile time, not by using the negation
  94 -- operation in Num.  So we don't need to make an implicit reference
  95 -- to negate_RDR.
  96 rnPat neg@(NegPatIn pat)
  97   = checkRn (valid_neg_pat pat) (negPatErr neg)
  98                         `thenRn_`
  99     rnPat pat           `thenRn` \ pat' ->
 100     returnRn (NegPatIn pat')
 101   where
 102     valid_neg_pat (LitPatIn (HsInt  _)) = True
 103     valid_neg_pat (LitPatIn (HsFrac _)) = True
 104     valid_neg_pat _                     = False
 105
 106 rnPat (ParPatIn pat)
 107   = rnPat pat           `thenRn` \ pat' ->
 108     returnRn (ParPatIn pat')
 109
 110 rnPat (NPlusKPatIn name lit)
 111   = litOccurrence lit                   `thenRn_`
 112     lookupImplicitOccRn ordClass_RDR    `thenRn_`
 113     lookupBndrRn name                   `thenRn` \ name' ->
 114     returnRn (NPlusKPatIn name' lit)
 115
 116 rnPat (ListPatIn pats)
 117   = addImplicitOccRn listType_name      `thenRn_`
 118     mapRn rnPat pats                    `thenRn` \ patslist ->
 119     returnRn (ListPatIn patslist)
 120
 121 rnPat (TuplePatIn pats)
 122   = addImplicitOccRn (tupleType_name (length pats))     `thenRn_`
 123     mapRn rnPat pats                                    `thenRn` \ patslist ->
 124     returnRn (TuplePatIn patslist)
 125
 126 rnPat (RecPatIn con rpats)
 127   = lookupOccRn con     `thenRn` \ con' ->
 128     rnRpats rpats       `thenRn` \ rpats' ->
 129     returnRn (RecPatIn con' rpats')
 130 \end{code}
 131
 132 ************************************************************************
 133 *                                                                       *
 134 \subsection{Match}
 135 *                                                                       *
 136 ************************************************************************
 137
 138 \begin{code}
 139 rnMatch :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
 140
 141 rnMatch (PatMatch pat match)
 142   = bindLocalsRn "pattern" binders      $ \ new_binders ->
 143     rnPat pat                           `thenRn` \ pat' ->
 144     rnMatch match                       `thenRn` \ (match', fvMatch) ->
 145     returnRn (PatMatch pat' match', fvMatch `minusNameSet` mkNameSet new_binders)
 146  where
 147     binders = collectPatBinders pat
 148
 149 rnMatch (GRHSMatch grhss_and_binds)
 150   = rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
 151     returnRn (GRHSMatch grhss_and_binds', fvs)
 152 \end{code}
 153
 154 %************************************************************************
 155 %*                                                                      *
 156 \subsubsection{Guarded right-hand sides (GRHSsAndBinds)}
 157 %*                                                                      *
 158 %************************************************************************
 159
 160 \begin{code}
 161 rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnMS s (RenamedGRHSsAndBinds, FreeVars)
 162
 163 rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
 164   = rnBinds binds               $ \ binds' ->
 165     rnGRHSs grhss               `thenRn` \ (grhss', fvGRHS) ->
 166     returnRn (GRHSsAndBindsIn grhss' binds', fvGRHS)
 167   where
 168     rnGRHSs [] = returnRn ([], emptyNameSet)
 169
 170     rnGRHSs (grhs:grhss)
 171       = rnGRHS  grhs   `thenRn` \ (grhs',  fvs) ->
 172         rnGRHSs grhss  `thenRn` \ (grhss', fvss) ->
 173         returnRn (grhs' : grhss', fvs `unionNameSets` fvss)
 174
 175     rnGRHS (GRHS guard expr locn)
 176       = pushSrcLocRn locn $
 177         rnExpr guard    `thenRn` \ (guard', fvsg) ->
 178         rnExpr expr     `thenRn` \ (expr',  fvse) ->
 179
 180         -- Turn an "otherwise" guard into an OtherwiseGRHS.
 181         -- This is the first moment that we can be sure we havn't got a shadowed binding
 182         -- of "otherwise".
 183         let grhs' = case guard' of
 184                         HsVar v | uniqueOf v == otherwiseIdKey -> OtherwiseGRHS expr' locn
 185                         other                                  -> GRHS guard' expr' locn
 186         in
 187         returnRn (grhs', fvsg `unionNameSets` fvse)
 188
 189     rnGRHS (OtherwiseGRHS expr locn)
 190       = pushSrcLocRn locn $
 191         rnExpr expr     `thenRn` \ (expr', fvs) ->
 192         returnRn (OtherwiseGRHS expr' locn, fvs)
 193 \end{code}
 194
 195 %************************************************************************
 196 %*                                                                      *
 197 \subsubsection{Expressions}
 198 %*                                                                      *
 199 %************************************************************************
 200
 201 \begin{code}
 202 rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars)
 203 rnExprs ls =
 204  rnExprs' ls [] `thenRn` \  (exprs, fvExprs) ->
 205  returnRn (exprs, unionManyNameSets fvExprs)
 206
 207 rnExprs' [] acc = returnRn ([], acc)
 208 rnExprs' (expr:exprs) acc
 209   = rnExpr expr                 `thenRn` \ (expr', fvExpr) ->
 210     rnExprs' exprs (fvExpr:acc) `thenRn` \ (exprs', fvExprs) ->
 211     returnRn (expr':exprs', fvExprs)
 212 \end{code}
 213
 214 Variables. We look up the variable and return the resulting name.  The
 215 interesting question is what the free-variable set should be.  We
 216 don't want to return imported or prelude things as free vars.  So we
 217 look at the Name returned from the lookup, and make it part of the
 218 free-var set iff if it's a LocallyDefined Name.
 219 \end{itemize}
 220
 221 \begin{code}
 222 rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
 223
 224 rnExpr (HsVar v)
 225   = lookupOccRn v       `thenRn` \ vname ->
 226     returnRn (HsVar vname, if isLocallyDefined vname
 227                            then unitNameSet vname
 228                            else emptyUniqSet)
 229
 230 rnExpr (HsLit lit)
 231   = litOccurrence lit           `thenRn_`
 232     returnRn (HsLit lit, emptyNameSet)
 233
 234 rnExpr (HsLam match)
 235   = rnMatch match       `thenRn` \ (match', fvMatch) ->
 236     returnRn (HsLam match', fvMatch)
 237
 238 rnExpr (HsApp fun arg)
 239   = rnExpr fun          `thenRn` \ (fun',fvFun) ->
 240     rnExpr arg          `thenRn` \ (arg',fvArg) ->
 241     returnRn (HsApp fun' arg', fvFun `unionNameSets` fvArg)
 242
 243 rnExpr (OpApp e1 op@(HsVar op_name) _ e2)
 244   = rnExpr e1                           `thenRn` \ (e1', fv_e1) ->
 245     rnExpr e2                           `thenRn` \ (e2', fv_e2) ->
 246     rnExpr op                           `thenRn` \ (op', fv_op) ->
 247
 248         -- Deal wth fixity
 249     lookupFixity op_name                `thenRn` \ fixity ->
 250     getModeRn                           `thenRn` \ mode ->
 251     (case mode of
 252         SourceMode    -> mkOpAppRn e1' op' fixity e2'
 253         InterfaceMode -> returnRn (OpApp e1' op' fixity e2')
 254     )                                   `thenRn` \ final_e ->
 255
 256     returnRn (final_e,
 257               fv_e1 `unionNameSets` fv_op `unionNameSets` fv_e2)
 258
 259 rnExpr (NegApp e n)
 260   = rnExpr e                            `thenRn` \ (e', fv_e) ->
 261     lookupImplicitOccRn negate_RDR      `thenRn` \ neg ->
 262     getModeRn                           `thenRn` \ mode ->
 263     mkNegAppRn mode e' (HsVar neg)      `thenRn` \ final_e ->
 264     returnRn (final_e, fv_e)
 265
 266 rnExpr (HsPar e)
 267   = rnExpr e            `thenRn` \ (e', fvs_e) ->
 268     returnRn (HsPar e', fvs_e)
 269
 270 rnExpr (SectionL expr op)
 271   = rnExpr expr         `thenRn` \ (expr', fvs_expr) ->
 272     rnExpr op           `thenRn` \ (op', fvs_op) ->
 273     returnRn (SectionL expr' op', fvs_op `unionNameSets` fvs_expr)
 274
 275 rnExpr (SectionR op expr)
 276   = rnExpr op           `thenRn` \ (op',   fvs_op) ->
 277     rnExpr expr         `thenRn` \ (expr', fvs_expr) ->
 278     returnRn (SectionR op' expr', fvs_op `unionNameSets` fvs_expr)
 279
 280 rnExpr (CCall fun args may_gc is_casm fake_result_ty)
 281   = lookupImplicitOccRn ccallableClass_RDR      `thenRn_`
 282     lookupImplicitOccRn creturnableClass_RDR    `thenRn_`
 283     rnExprs args                                `thenRn` \ (args', fvs_args) ->
 284     returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
 285
 286 rnExpr (HsSCC label expr)
 287   = rnExpr expr         `thenRn` \ (expr', fvs_expr) ->
 288     returnRn (HsSCC label expr', fvs_expr)
 289
 290 rnExpr (HsCase expr ms src_loc)
 291   = pushSrcLocRn src_loc $
 292     rnExpr expr                 `thenRn` \ (new_expr, e_fvs) ->
 293     mapAndUnzipRn rnMatch ms    `thenRn` \ (new_ms, ms_fvs) ->
 294     returnRn (HsCase new_expr new_ms src_loc, unionManyNameSets (e_fvs : ms_fvs))
 295
 296 rnExpr (HsLet binds expr)
 297   = rnBinds binds               $ \ binds' ->
 298     rnExpr expr                  `thenRn` \ (expr',fvExpr) ->
 299     returnRn (HsLet binds' expr', fvExpr)
 300
 301 rnExpr (HsDo do_or_lc stmts src_loc)
 302   = pushSrcLocRn src_loc $
 303     lookupImplicitOccRn monadZeroClass_RDR      `thenRn_`       -- Forces Monad to come too
 304     rnStmts stmts                               `thenRn` \ (stmts', fvStmts) ->
 305     returnRn (HsDo do_or_lc stmts' src_loc, fvStmts)
 306
 307 rnExpr (ExplicitList exps)
 308   = addImplicitOccRn listType_name      `thenRn_`
 309     rnExprs exps                        `thenRn` \ (exps', fvs) ->
 310     returnRn  (ExplicitList exps', fvs)
 311
 312 rnExpr (ExplicitTuple exps)
 313   = addImplicitOccRn (tupleType_name (length exps))     `thenRn_`
 314     rnExprs exps                                        `thenRn` \ (exps', fvExps) ->
 315     returnRn (ExplicitTuple exps', fvExps)
 316
 317 rnExpr (RecordCon (HsVar con) rbinds)
 318   = lookupOccRn con                     `thenRn` \ conname ->
 319     rnRbinds "construction" rbinds      `thenRn` \ (rbinds', fvRbinds) ->
 320     returnRn (RecordCon (HsVar conname) rbinds', fvRbinds)
 321
 322 rnExpr (RecordUpd expr rbinds)
 323   = rnExpr expr                 `thenRn` \ (expr', fvExpr) ->
 324     rnRbinds "update" rbinds    `thenRn` \ (rbinds', fvRbinds) ->
 325     returnRn (RecordUpd expr' rbinds', fvExpr `unionNameSets` fvRbinds)
 326
 327 rnExpr (ExprWithTySig expr pty)
 328   = rnExpr expr                         `thenRn` \ (expr', fvExpr) ->
 329     rnHsType pty                        `thenRn` \ pty' ->
 330     returnRn (ExprWithTySig expr' pty', fvExpr)
 331
 332 rnExpr (HsIf p b1 b2 src_loc)
 333   = pushSrcLocRn src_loc $
 334     rnExpr p            `thenRn` \ (p', fvP) ->
 335     rnExpr b1           `thenRn` \ (b1', fvB1) ->
 336     rnExpr b2           `thenRn` \ (b2', fvB2) ->
 337     returnRn (HsIf p' b1' b2' src_loc, unionManyNameSets [fvP, fvB1, fvB2])
 338
 339 rnExpr (ArithSeqIn seq)
 340   = lookupImplicitOccRn enumClass_RDR   `thenRn_`
 341     rn_seq seq                          `thenRn` \ (new_seq, fvs) ->
 342     returnRn (ArithSeqIn new_seq, fvs)
 343   where
 344     rn_seq (From expr)
 345      = rnExpr expr      `thenRn` \ (expr', fvExpr) ->
 346        returnRn (From expr', fvExpr)
 347
 348     rn_seq (FromThen expr1 expr2)
 349      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 350        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 351        returnRn (FromThen expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
 352
 353     rn_seq (FromTo expr1 expr2)
 354      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 355        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 356        returnRn (FromTo expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
 357
 358     rn_seq (FromThenTo expr1 expr2 expr3)
 359      = rnExpr expr1     `thenRn` \ (expr1', fvExpr1) ->
 360        rnExpr expr2     `thenRn` \ (expr2', fvExpr2) ->
 361        rnExpr expr3     `thenRn` \ (expr3', fvExpr3) ->
 362        returnRn (FromThenTo expr1' expr2' expr3',
 363                   unionManyNameSets [fvExpr1, fvExpr2, fvExpr3])
 364 \end{code}
 365
 366 %************************************************************************
 367 %*                                                                      *
 368 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
 369 %*                                                                      *
 370 %************************************************************************
 371
 372 \begin{code}
 373 rnRbinds str rbinds
 374   = mapRn field_dup_err dup_fields      `thenRn_`
 375     mapAndUnzipRn rn_rbind rbinds       `thenRn` \ (rbinds', fvRbind_s) ->
 376     returnRn (rbinds', unionManyNameSets fvRbind_s)
 377   where
 378     (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rbinds ]
 379
 380     field_dup_err dups = addErrRn (dupFieldErr str dups)
 381
 382     rn_rbind (field, expr, pun)
 383       = lookupGlobalOccRn field `thenRn` \ fieldname ->
 384         rnExpr expr             `thenRn` \ (expr', fvExpr) ->
 385         returnRn ((fieldname, expr', pun), fvExpr)
 386
 387 rnRpats rpats
 388   = mapRn field_dup_err dup_fields      `thenRn_`
 389     mapRn rn_rpat rpats
 390   where
 391     (_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rpats ]
 392
 393     field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
 394
 395     rn_rpat (field, pat, pun)
 396       = lookupGlobalOccRn field `thenRn` \ fieldname ->
 397         rnPat pat               `thenRn` \ pat' ->
 398         returnRn (fieldname, pat', pun)
 399 \end{code}
 400
 401 %************************************************************************
 402 %*                                                                      *
 403 \subsubsection{@Stmt@s: in @do@ expressions}
 404 %*                                                                      *
 405 %************************************************************************
 406
 407 Note that although some bound vars may appear in the free var set for
 408 the first qual, these will eventually be removed by the caller. For
 409 example, if we have @[p | r <- s, q <- r, p <- q]@, when doing
 410 @[q <- r, p <- q]@, the free var set for @q <- r@ will
 411 be @{r}@, and the free var set for the entire Quals will be @{r}@. This
 412 @r@ will be removed only when we finally return from examining all the
 413 Quals.
 414
 415 \begin{code}
 416 rnStmts :: [RdrNameStmt] -> RnMS s ([RenamedStmt], FreeVars)
 417
 418 rnStmts [] = returnRn ([], emptyNameSet)
 419
 420 rnStmts (stmt:stmts)
 421   = rnStmt stmt                         $ \ stmt' ->
 422     rnStmts stmts                       `thenRn` \ (stmts', fv_stmts) ->
 423     returnRn (stmt':stmts', fv_stmts)
 424
 425
 426 -- rnStmt :: RdrNameStmt -> (RenamedStmt -> RnMS s (a, FreeVars)) -> RnMS s (a, FreeVars)
 427 -- Because of mutual recursion the actual type is a bit less general than this [Haskell 1.2]
 428
 429 rnStmt (BindStmt pat expr src_loc) thing_inside
 430   = pushSrcLocRn src_loc $
 431     rnExpr expr                                         `thenRn` \ (expr', fv_expr) ->
 432     bindLocalsRn "pattern in do binding" binders        $ \ new_binders ->
 433     rnPat pat                                           `thenRn` \ pat' ->
 434
 435     thing_inside (BindStmt pat' expr' src_loc)          `thenRn` \ (result, fvs) ->
 436     returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders))
 437   where
 438     binders = collectPatBinders pat
 439
 440 rnStmt (ExprStmt expr src_loc) thing_inside
 441   = pushSrcLocRn src_loc $
 442     rnExpr expr                                 `thenRn` \ (expr', fv_expr) ->
 443     thing_inside (ExprStmt expr' src_loc)       `thenRn` \ (result, fvs) ->
 444     returnRn (result, fv_expr `unionNameSets` fvs)
 445
 446 rnStmt (GuardStmt expr src_loc) thing_inside
 447   = pushSrcLocRn src_loc $
 448     rnExpr expr                                 `thenRn` \ (expr', fv_expr) ->
 449     thing_inside (GuardStmt expr' src_loc)      `thenRn` \ (result, fvs) ->
 450     returnRn (result, fv_expr `unionNameSets` fvs)
 451
 452 rnStmt (ReturnStmt expr) thing_inside
 453   = rnExpr expr                                 `thenRn` \ (expr', fv_expr) ->
 454     thing_inside (ReturnStmt expr')             `thenRn` \ (result, fvs) ->
 455     returnRn (result, fv_expr `unionNameSets` fvs)
 456
 457 rnStmt (LetStmt binds) thing_inside
 458   = rnBinds binds               $ \ binds' ->
 459     thing_inside (LetStmt binds')
 460 \end{code}
 461
 462 %************************************************************************
 463 %*                                                                      *
 464 \subsubsection{Precedence Parsing}
 465 %*                                                                      *
 466 %************************************************************************
 467
 468 @mkOpAppRn@ deals with operator fixities.  The argument expressions
 469 are assumed to be already correctly arranged.  It needs the fixities
 470 recorded in the OpApp nodes, because fixity info applies to the things
 471 the programmer actually wrote, so you can't find it out from the Name.
 472
 473 Furthermore, the second argument is guaranteed not to be another
 474 operator application.  Why? Because the parser parses all
 475 operator appications left-associatively.
 476
 477 \begin{code}
 478 mkOpAppRn :: RenamedHsExpr -> RenamedHsExpr -> Fixity -> RenamedHsExpr
 479           -> RnMS s RenamedHsExpr
 480
 481 mkOpAppRn e1@(OpApp e11 op1 fix1 e12)
 482           op2 fix2 e2
 483   | nofix_error
 484   = addErrRn (precParseErr (get op1,fix1) (get op2,fix2))       `thenRn_`
 485     returnRn (OpApp e1 op2 fix2 e2)
 486
 487   | rearrange_me
 488   = mkOpAppRn e12 op2 fix2 e2           `thenRn` \ new_e ->
 489     returnRn (OpApp e11 op1 fix1 new_e)
 490   where
 491     (nofix_error, rearrange_me) = compareFixity fix1 fix2
 492     get (HsVar n) = n
 493
 494 mkOpAppRn e1@(NegApp neg_arg neg_id)
 495           op2
 496           fix2@(Fixity prec2 dir2)
 497           e2
 498   | prec2 > 6   -- Precedence of unary - is wired in as 6!
 499   = mkOpAppRn neg_arg op2 fix2 e2       `thenRn` \ new_e ->
 500     returnRn (NegApp new_e neg_id)
 501
 502 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
 503   = ASSERT( right_op_ok fix e2 )
 504     returnRn (OpApp e1 op fix e2)
 505
 506 -- Parser left-associates everything, but
 507 -- derived instances may have correctly-associated things to
 508 -- in the right operarand.  So we just check that the right operand is OK
 509 right_op_ok fix1 (OpApp _ _ fix2 _)
 510   = not error_please && associate_right
 511   where
 512     (error_please, associate_right) = compareFixity fix1 fix2
 513 right_op_ok fix1 other
 514   = True
 515
 516 -- Parser initially makes negation bind more tightly than any other operator
 517 mkNegAppRn mode neg_arg neg_id
 518   = ASSERT( not_op_app mode neg_arg )
 519     returnRn (NegApp neg_arg neg_id)
 520
 521 not_op_app SourceMode (OpApp _ _ _ _) = False
 522 not_op_app mode other                 = True
 523 \end{code}
 524
 525 \begin{code}
 526 mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
 527              -> RnMS s RenamedPat
 528
 529 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12)
 530              op2 fix2 p2
 531   | nofix_error
 532   = addErrRn (precParseErr (op1,fix1) (op2,fix2))       `thenRn_`
 533     returnRn (ConOpPatIn p1 op2 fix2 p2)
 534
 535   | rearrange_me
 536   = mkConOpPatRn p12 op2 fix2 p2                `thenRn` \ new_p ->
 537     returnRn (ConOpPatIn p11 op1 fix1 new_p)
 538
 539   where
 540     (nofix_error, rearrange_me) = compareFixity fix1 fix2
 541
 542 mkConOpPatRn p1@(NegPatIn neg_arg)
 543           op2
 544           fix2@(Fixity prec2 dir2)
 545           p2
 546   | prec2 > 6   -- Precedence of unary - is wired in as 6!
 547   = addErrRn (precParseNegPatErr (op2,fix2))    `thenRn_`
 548     returnRn (ConOpPatIn p1 op2 fix2 p2)
 549
 550 mkConOpPatRn p1 op fix p2                       -- Default case, no rearrangment
 551   = ASSERT( not_op_pat p2 )
 552     returnRn (ConOpPatIn p1 op fix p2)
 553
 554 not_op_pat (ConOpPatIn _ _ _ _) = False
 555 not_op_pat other                = True
 556 \end{code}
 557
 558 \begin{code}
 559 checkPrecMatch :: Bool -> RdrName -> RdrNameMatch -> RnMS s ()
 560
 561 checkPrecMatch False fn match
 562   = returnRn ()
 563 checkPrecMatch True op (PatMatch p1 (PatMatch p2 (GRHSMatch _)))
 564   = checkPrec op p1 False       `thenRn_`
 565     checkPrec op p2 True
 566 checkPrecMatch True op _
 567   = panic "checkPrecMatch"
 568
 569 checkPrec op (ConOpPatIn _ op1 _ _) right
 570   = lookupFixity op     `thenRn` \  op_fix@(Fixity op_prec  op_dir) ->
 571     lookupFixity op1    `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
 572     let
 573         inf_ok = op1_prec > op_prec ||
 574                  (op1_prec == op_prec &&
 575                   (op1_dir == InfixR && op_dir == InfixR && right ||
 576                    op1_dir == InfixL && op_dir == InfixL && not right))
 577
 578         info  = (op,op_fix)
 579         info1 = (op1,op1_fix)
 580         (infol, infor) = if right then (info, info1) else (info1, info)
 581     in
 582     checkRn inf_ok (precParseErr infol infor)
 583
 584 checkPrec op (NegPatIn _) right
 585   = lookupFixity op     `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
 586     checkRn (op_prec <= 6) (precParseNegPatErr (op,op_fix))
 587
 588 checkPrec op pat right
 589   = returnRn ()
 590 \end{code}
 591
 592 Consider
 593         a `op1` b `op2` c
 594
 595 (compareFixity op1 op2) tells which way to arrange appication, or
 596 whether there's an error.
 597
 598 \begin{code}
 599 compareFixity :: Fixity -> Fixity
 600               -> (Bool,         -- Error please
 601                   Bool)         -- Associate to the right: a op1 (b op2 c)
 602 compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
 603   = case prec1 `cmp` prec2 of
 604         GT_ -> left
 605         LT_ -> right
 606         EQ_ -> case (dir1, dir2) of
 607                         (InfixR, InfixR) -> right
 608                         (InfixL, InfixL) -> left
 609                         _                -> error_please
 610   where
 611     right        = (False, True)
 612     left         = (False, False)
 613     error_please = (True,  False)
 614 \end{code}
 615
 616 %************************************************************************
 617 %*                                                                      *
 618 \subsubsection{Literals}
 619 %*                                                                      *
 620 %************************************************************************
 621
 622 When literals occur we have to make sure that the types and classes they involve
 623 are made available.
 624
 625 \begin{code}
 626 litOccurrence (HsChar _)
 627   = addImplicitOccRn charType_name
 628
 629 litOccurrence (HsCharPrim _)
 630   = addImplicitOccRn (getName charPrimTyCon)
 631
 632 litOccurrence (HsString _)
 633   = addImplicitOccRn listType_name      `thenRn_`
 634     addImplicitOccRn charType_name
 635
 636 litOccurrence (HsStringPrim _)
 637   = addImplicitOccRn (getName addrPrimTyCon)
 638
 639 litOccurrence (HsInt _)
 640   = lookupImplicitOccRn numClass_RDR                    -- Int and Integer are forced in by Num
 641
 642 litOccurrence (HsFrac _)
 643   = lookupImplicitOccRn fractionalClass_RDR             -- ... similarly Rational
 644
 645 litOccurrence (HsIntPrim _)
 646   = addImplicitOccRn (getName intPrimTyCon)
 647
 648 litOccurrence (HsFloatPrim _)
 649   = addImplicitOccRn (getName floatPrimTyCon)
 650
 651 litOccurrence (HsDoublePrim _)
 652   = addImplicitOccRn (getName doublePrimTyCon)
 653
 654 litOccurrence (HsLitLit _)
 655   = lookupImplicitOccRn ccallableClass_RDR
 656 \end{code}
 657
 658
 659 %************************************************************************
 660 %*                                                                      *
 661 \subsubsection{Errors}
 662 %*                                                                      *
 663 %************************************************************************
 664
 665 \begin{code}
 666 dupFieldErr str (dup:rest) sty
 667   = ppBesides [ppPStr SLIT("duplicate field name `"),
 668                ppr sty dup,
 669                ppPStr SLIT("' in record "), ppStr str]
 670
 671 negPatErr pat  sty
 672   = ppSep [ppPStr SLIT("prefix `-' not applied to literal in pattern"), ppr sty pat]
 673
 674 precParseNegPatErr op sty
 675   = ppHang (ppPStr SLIT("precedence parsing error"))
 676       4 (ppBesides [ppPStr SLIT("prefix `-' has lower precedence than "),
 677                     pp_op sty op,
 678                     ppPStr SLIT(" in pattern")])
 679
 680 precParseErr op1 op2  sty
 681   = ppHang (ppPStr SLIT("precedence parsing error"))
 682       4 (ppBesides [ppPStr SLIT("cannot mix "), pp_op sty op1, ppPStr SLIT(" and "), pp_op sty op2,
 683                     ppPStr SLIT(" in the same infix expression")])
 684
 685 pp_op sty (op, fix) = ppBesides [pprSym sty op, ppLparen, ppr sty fix, ppRparen]
 686 \end{code}