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