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