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