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