ghc/compiler/rename/RnExpr.lhs

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