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