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