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, rnExpr, rnExprs, rnStmts,
  15         checkPrecMatch
  16    ) where
  17
  18 #include "HsVersions.h"
  19
  20 import {-# SOURCE #-} RnSource  ( rnSrcDecls, rnBindsAndThen, rnBinds )
  21
  22 --      RnSource imports RnBinds.rnTopMonoBinds, RnExpr.rnExpr
  23 --      RnBinds  imports RnExpr.rnMatch, etc
  24 --      RnExpr   imports [boot] RnSource.rnSrcDecls, RnSource.rnBinds
  25
  26 import HsSyn
  27 import RdrHsSyn
  28 import RnHsSyn
  29 import TcRnMonad
  30 import RnEnv
  31 import RnNames          ( importsFromLocalDecls )
  32 import RnTypes          ( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen,
  33                           dupFieldErr, precParseErr, sectionPrecErr, patSigErr )
  34 import CmdLineOpts      ( DynFlag(..), opt_IgnoreAsserts )
  35 import BasicTypes       ( Fixity(..), FixityDirection(..), IPName(..),
  36                           defaultFixity, negateFixity, compareFixity )
  37 import PrelNames        ( hasKey, assertIdKey,
  38                           foldrName, buildName,
  39                           cCallableClassName, cReturnableClassName,
  40                           enumClassName,
  41                           splitName, fstName, sndName, ioDataConName,
  42                           replicatePName, mapPName, filterPName,
  43                           crossPName, zipPName, toPName,
  44                           enumFromToPName, enumFromThenToPName, assertErrorName,
  45                           negateName, monadNames, mfixName )
  46 #ifdef GHCI
  47 import DsMeta           ( qTyConName )
  48 #endif
  49 import Name             ( Name, nameOccName )
  50 import NameSet
  51 import UnicodeUtil      ( stringToUtf8 )
  52 import UniqFM           ( isNullUFM )
  53 import UniqSet          ( emptyUniqSet )
  54 import Util             ( isSingleton )
  55 import List             ( intersectBy, unzip4 )
  56 import ListSetOps       ( removeDups )
  57 import Outputable
  58 import FastString
  59 \end{code}
  60
  61
  62 ************************************************************************
  63 *                                                                       *
  64 \subsection{Match}
  65 *                                                                       *
  66 ************************************************************************
  67
  68 \begin{code}
  69 rnMatch :: HsMatchContext Name -> RdrNameMatch -> RnM (RenamedMatch, FreeVars)
  70
  71 rnMatch ctxt match@(Match pats maybe_rhs_sig grhss)
  72   = addSrcLoc (getMatchLoc match)       $
  73
  74         -- Deal with the rhs type signature
  75     bindPatSigTyVars rhs_sig_tys        $
  76     doptM Opt_GlasgowExts               `thenM` \ opt_GlasgowExts ->
  77     (case maybe_rhs_sig of
  78         Nothing -> returnM (Nothing, emptyFVs)
  79         Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty     `thenM` \ (ty', ty_fvs) ->
  80                                      returnM (Just ty', ty_fvs)
  81                 | otherwise       -> addErr (patSigErr ty)      `thenM_`
  82                                      returnM (Nothing, emptyFVs)
  83     )                                   `thenM` \ (maybe_rhs_sig', ty_fvs) ->
  84
  85         -- Now the main event
  86     rnPatsAndThen ctxt pats     $ \ pats' ->
  87     rnGRHSs ctxt grhss          `thenM` \ (grhss', grhss_fvs) ->
  88
  89     returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
  90         -- The bindPatSigTyVars and rnPatsAndThen will remove the bound FVs
  91   where
  92      rhs_sig_tys =  case maybe_rhs_sig of
  93                         Nothing -> []
  94                         Just ty -> [ty]
  95      doc_sig = text "In a result type-signature"
  96 \end{code}
  97
  98
  99 %************************************************************************
 100 %*                                                                      *
 101 \subsubsection{Guarded right-hand sides (GRHSs)}
 102 %*                                                                      *
 103 %************************************************************************
 104
 105 \begin{code}
 106 rnGRHSs :: HsMatchContext Name -> RdrNameGRHSs -> RnM (RenamedGRHSs, FreeVars)
 107
 108 rnGRHSs ctxt (GRHSs grhss binds _)
 109   = rnBindsAndThen binds        $ \ binds' ->
 110     mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) ->
 111     returnM (GRHSs grhss' binds' placeHolderType, fvGRHSs)
 112
 113 rnGRHS ctxt (GRHS guarded locn)
 114   = addSrcLoc locn $
 115     doptM Opt_GlasgowExts               `thenM` \ opt_GlasgowExts ->
 116     checkM (opt_GlasgowExts || is_standard_guard guarded)
 117            (addWarn (nonStdGuardErr guarded))   `thenM_`
 118
 119     rnStmts (PatGuard ctxt) guarded     `thenM` \ (guarded', fvs) ->
 120     returnM (GRHS guarded' locn, fvs)
 121   where
 122         -- Standard Haskell 1.4 guards are just a single boolean
 123         -- expression, rather than a list of qualifiers as in the
 124         -- Glasgow extension
 125     is_standard_guard [ResultStmt _ _]                 = True
 126     is_standard_guard [ExprStmt _ _ _, ResultStmt _ _] = True
 127     is_standard_guard other                            = False
 128 \end{code}
 129
 130 %************************************************************************
 131 %*                                                                      *
 132 \subsubsection{Expressions}
 133 %*                                                                      *
 134 %************************************************************************
 135
 136 \begin{code}
 137 rnExprs :: [RdrNameHsExpr] -> RnM ([RenamedHsExpr], FreeVars)
 138 rnExprs ls = rnExprs' ls emptyUniqSet
 139  where
 140   rnExprs' [] acc = returnM ([], acc)
 141   rnExprs' (expr:exprs) acc
 142    = rnExpr expr                `thenM` \ (expr', fvExpr) ->
 143
 144         -- Now we do a "seq" on the free vars because typically it's small
 145         -- or empty, especially in very long lists of constants
 146     let
 147         acc' = acc `plusFV` fvExpr
 148     in
 149     (grubby_seqNameSet acc' rnExprs') exprs acc'        `thenM` \ (exprs', fvExprs) ->
 150     returnM (expr':exprs', fvExprs)
 151
 152 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
 153 grubby_seqNameSet ns result | isNullUFM ns = result
 154                             | otherwise    = result
 155 \end{code}
 156
 157 Variables. We look up the variable and return the resulting name.
 158
 159 \begin{code}
 160 rnExpr :: RdrNameHsExpr -> RnM (RenamedHsExpr, FreeVars)
 161
 162 rnExpr (HsVar v)
 163   = lookupOccRn v       `thenM` \ name ->
 164     if name `hasKey` assertIdKey && not opt_IgnoreAsserts then
 165         -- We expand it to (GHC.Err.assertError location_string)
 166         mkAssertErrorExpr
 167     else
 168         -- The normal case.  Even if the Id was 'assert', if we are
 169         -- ignoring assertions we leave it as GHC.Base.assert;
 170         -- this function just ignores its first arg.
 171        returnM (HsVar name, unitFV name)
 172
 173 rnExpr (HsIPVar v)
 174   = newIPName v                 `thenM` \ name ->
 175     let
 176         fvs = case name of
 177                 Linear _  -> mkFVs [splitName, fstName, sndName]
 178                 Dupable _ -> emptyFVs
 179     in
 180     returnM (HsIPVar name, fvs)
 181
 182 rnExpr (HsLit lit)
 183   = litFVs lit          `thenM` \ fvs ->
 184     returnM (HsLit lit, fvs)
 185
 186 rnExpr (HsOverLit lit)
 187   = rnOverLit lit               `thenM` \ (lit', fvs) ->
 188     returnM (HsOverLit lit', fvs)
 189
 190 rnExpr (HsLam match)
 191   = rnMatch LambdaExpr match    `thenM` \ (match', fvMatch) ->
 192     returnM (HsLam match', fvMatch)
 193
 194 rnExpr (HsApp fun arg)
 195   = rnExpr fun          `thenM` \ (fun',fvFun) ->
 196     rnExpr arg          `thenM` \ (arg',fvArg) ->
 197     returnM (HsApp fun' arg', fvFun `plusFV` fvArg)
 198
 199 rnExpr (OpApp e1 op _ e2)
 200   = rnExpr e1                           `thenM` \ (e1', fv_e1) ->
 201     rnExpr e2                           `thenM` \ (e2', fv_e2) ->
 202     rnExpr op                           `thenM` \ (op'@(HsVar op_name), fv_op) ->
 203
 204         -- Deal with fixity
 205         -- When renaming code synthesised from "deriving" declarations
 206         -- we're in Interface mode, and we should ignore fixity; assume
 207         -- that the deriving code generator got the association correct
 208         -- Don't even look up the fixity when in interface mode
 209     getModeRn                           `thenM` \ mode ->
 210     (if isInterfaceMode mode
 211         then returnM (OpApp e1' op' defaultFixity e2')
 212         else lookupFixityRn op_name             `thenM` \ fixity ->
 213              mkOpAppRn e1' op' fixity e2'
 214     )                                   `thenM` \ final_e ->
 215
 216     returnM (final_e,
 217               fv_e1 `plusFV` fv_op `plusFV` fv_e2)
 218
 219 rnExpr (NegApp e _)
 220   = rnExpr e                    `thenM` \ (e', fv_e) ->
 221     lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
 222     mkNegAppRn e' neg_name      `thenM` \ final_e ->
 223     returnM (final_e, fv_e `plusFV` fv_neg)
 224
 225 rnExpr (HsPar e)
 226   = rnExpr e            `thenM` \ (e', fvs_e) ->
 227     returnM (HsPar e', fvs_e)
 228
 229 -- Template Haskell extensions
 230 #ifdef GHCI
 231 rnExpr (HsBracket br_body loc)
 232   = addSrcLoc loc                       $
 233     checkGHCI (thErr "bracket")         `thenM_`
 234     rnBracket br_body                   `thenM` \ (body', fvs_e) ->
 235     returnM (HsBracket body' loc, fvs_e `addOneFV` qTyConName)
 236         -- We use the Q tycon as a proxy to haul in all the smart
 237         -- constructors; see the hack in RnIfaces
 238 #endif
 239
 240 rnExpr (HsSplice n e loc)
 241   = addSrcLoc loc                       $
 242     checkGHCI (thErr "splice")          `thenM_`
 243     newLocalsRn [(n,loc)]               `thenM` \ [n'] ->
 244     rnExpr e                            `thenM` \ (e', fvs_e) ->
 245     returnM (HsSplice n' e' loc, fvs_e)
 246
 247 rnExpr section@(SectionL expr op)
 248   = rnExpr expr                                 `thenM` \ (expr', fvs_expr) ->
 249     rnExpr op                                   `thenM` \ (op', fvs_op) ->
 250     checkSectionPrec InfixL section op' expr' `thenM_`
 251     returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
 252
 253 rnExpr section@(SectionR op expr)
 254   = rnExpr op                                   `thenM` \ (op',   fvs_op) ->
 255     rnExpr expr                                 `thenM` \ (expr', fvs_expr) ->
 256     checkSectionPrec InfixR section op' expr'   `thenM_`
 257     returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
 258
 259 rnExpr (HsCCall fun args may_gc is_casm _)
 260         -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
 261   = rnExprs args                                `thenM` \ (args', fvs_args) ->
 262     returnM (HsCCall fun args' may_gc is_casm placeHolderType,
 263               fvs_args `plusFV` mkFVs [cCallableClassName,
 264                                        cReturnableClassName,
 265                                        ioDataConName])
 266
 267 rnExpr (HsSCC lbl expr)
 268   = rnExpr expr         `thenM` \ (expr', fvs_expr) ->
 269     returnM (HsSCC lbl expr', fvs_expr)
 270
 271 rnExpr (HsCase expr ms src_loc)
 272   = addSrcLoc src_loc $
 273     rnExpr expr                         `thenM` \ (new_expr, e_fvs) ->
 274     mapFvRn (rnMatch CaseAlt) ms        `thenM` \ (new_ms, ms_fvs) ->
 275     returnM (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
 276
 277 rnExpr (HsLet binds expr)
 278   = rnBindsAndThen binds        $ \ binds' ->
 279     rnExpr expr                  `thenM` \ (expr',fvExpr) ->
 280     returnM (HsLet binds' expr', fvExpr)
 281
 282 rnExpr (HsWith expr binds is_with)
 283   = warnIf is_with withWarning `thenM_`
 284     rnExpr expr                 `thenM` \ (expr',fvExpr) ->
 285     rnIPBinds binds             `thenM` \ (binds',fvBinds) ->
 286     returnM (HsWith expr' binds' is_with, fvExpr `plusFV` fvBinds)
 287
 288 rnExpr e@(HsDo do_or_lc stmts _ _ src_loc)
 289   = addSrcLoc src_loc $
 290     rnStmts do_or_lc stmts              `thenM` \ (stmts', fvs) ->
 291
 292         -- Check the statement list ends in an expression
 293     case last stmts' of {
 294         ResultStmt _ _ -> returnM () ;
 295         _              -> addErr (doStmtListErr do_or_lc e)
 296     }                                   `thenM_`
 297
 298         -- Generate the rebindable syntax for the monad
 299     mapAndUnzipM lookupSyntaxName
 300          (syntax_names do_or_lc)        `thenM` \ (monad_names', monad_fvs) ->
 301
 302     returnM (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc,
 303              fvs `plusFV` implicit_fvs do_or_lc `plusFV` plusFVs monad_fvs)
 304   where
 305     implicit_fvs PArrComp = mkFVs [replicatePName, mapPName, filterPName, crossPName, zipPName]
 306     implicit_fvs ListComp = mkFVs [foldrName, buildName]
 307     implicit_fvs DoExpr   = emptyFVs
 308     implicit_fvs MDoExpr  = emptyFVs
 309
 310     syntax_names DoExpr  = monadNames
 311     syntax_names MDoExpr = monadNames ++ [mfixName]
 312     syntax_names other   = []
 313
 314 rnExpr (ExplicitList _ exps)
 315   = rnExprs exps                        `thenM` \ (exps', fvs) ->
 316     returnM  (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
 317
 318 rnExpr (ExplicitPArr _ exps)
 319   = rnExprs exps                        `thenM` \ (exps', fvs) ->
 320     returnM  (ExplicitPArr placeHolderType exps',
 321                fvs `addOneFV` toPName `addOneFV` parrTyCon_name)
 322
 323 rnExpr (ExplicitTuple exps boxity)
 324   = rnExprs exps                                `thenM` \ (exps', fvs) ->
 325     returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
 326   where
 327     tycon_name = tupleTyCon_name boxity (length exps)
 328
 329 rnExpr (RecordCon con_id rbinds)
 330   = lookupOccRn con_id                  `thenM` \ conname ->
 331     rnRbinds "construction" rbinds      `thenM` \ (rbinds', fvRbinds) ->
 332     returnM (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
 333
 334 rnExpr (RecordUpd expr rbinds)
 335   = rnExpr expr                 `thenM` \ (expr', fvExpr) ->
 336     rnRbinds "update" rbinds    `thenM` \ (rbinds', fvRbinds) ->
 337     returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
 338
 339 rnExpr (ExprWithTySig expr pty)
 340   = rnExpr expr                 `thenM` \ (expr', fvExpr) ->
 341     rnHsTypeFVs doc pty         `thenM` \ (pty', fvTy) ->
 342     returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
 343   where
 344     doc = text "In an expression type signature"
 345
 346 rnExpr (HsIf p b1 b2 src_loc)
 347   = addSrcLoc src_loc $
 348     rnExpr p            `thenM` \ (p', fvP) ->
 349     rnExpr b1           `thenM` \ (b1', fvB1) ->
 350     rnExpr b2           `thenM` \ (b2', fvB2) ->
 351     returnM (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
 352
 353 rnExpr (HsType a)
 354   = rnHsTypeFVs doc a   `thenM` \ (t, fvT) ->
 355     returnM (HsType t, fvT)
 356   where
 357     doc = text "In a type argument"
 358
 359 rnExpr (ArithSeqIn seq)
 360   = rnArithSeq seq       `thenM` \ (new_seq, fvs) ->
 361     returnM (ArithSeqIn new_seq, fvs `addOneFV` enumClassName)
 362
 363 rnExpr (PArrSeqIn seq)
 364   = rnArithSeq seq       `thenM` \ (new_seq, fvs) ->
 365     returnM (PArrSeqIn new_seq,
 366              fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName])
 367 \end{code}
 368
 369 These three are pattern syntax appearing in expressions.
 370 Since all the symbols are reservedops we can simply reject them.
 371 We return a (bogus) EWildPat in each case.
 372
 373 \begin{code}
 374 rnExpr e@EWildPat = addErr (patSynErr e)        `thenM_`
 375                     returnM (EWildPat, emptyFVs)
 376
 377 rnExpr e@(EAsPat _ _) = addErr (patSynErr e)    `thenM_`
 378                         returnM (EWildPat, emptyFVs)
 379
 380 rnExpr e@(ELazyPat _) = addErr (patSynErr e)    `thenM_`
 381                         returnM (EWildPat, emptyFVs)
 382 \end{code}
 383
 384 %************************************************************************
 385 %*                                                                      *
 386         Arithmetic sequences
 387 %*                                                                      *
 388 %************************************************************************
 389
 390 \begin{code}
 391 rnArithSeq (From expr)
 392  = rnExpr expr  `thenM` \ (expr', fvExpr) ->
 393    returnM (From expr', fvExpr)
 394
 395 rnArithSeq (FromThen expr1 expr2)
 396  = rnExpr expr1         `thenM` \ (expr1', fvExpr1) ->
 397    rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
 398    returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 399
 400 rnArithSeq (FromTo expr1 expr2)
 401  = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
 402    rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
 403    returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 404
 405 rnArithSeq (FromThenTo expr1 expr2 expr3)
 406  = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
 407    rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
 408    rnExpr expr3 `thenM` \ (expr3', fvExpr3) ->
 409    returnM (FromThenTo expr1' expr2' expr3',
 410             plusFVs [fvExpr1, fvExpr2, fvExpr3])
 411 \end{code}
 412
 413
 414 %************************************************************************
 415 %*                                                                      *
 416 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
 417 %*                                                                      *
 418 %************************************************************************
 419
 420 \begin{code}
 421 rnRbinds str rbinds
 422   = mappM_ field_dup_err dup_fields     `thenM_`
 423     mapFvRn rn_rbind rbinds             `thenM` \ (rbinds', fvRbind) ->
 424     returnM (rbinds', fvRbind)
 425   where
 426     (_, dup_fields) = removeDups compare [ f | (f,_) <- rbinds ]
 427
 428     field_dup_err dups = addErr (dupFieldErr str dups)
 429
 430     rn_rbind (field, expr)
 431       = lookupGlobalOccRn field `thenM` \ fieldname ->
 432         rnExpr expr             `thenM` \ (expr', fvExpr) ->
 433         returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname)
 434 \end{code}
 435
 436 %************************************************************************
 437 %*                                                                      *
 438 \subsubsection{@rnIPBinds@s: in implicit parameter bindings}            *
 439 %*                                                                      *
 440 %************************************************************************
 441
 442 \begin{code}
 443 rnIPBinds [] = returnM ([], emptyFVs)
 444 rnIPBinds ((n, expr) : binds)
 445   = newIPName n                 `thenM` \ name ->
 446     rnExpr expr                 `thenM` \ (expr',fvExpr) ->
 447     rnIPBinds binds             `thenM` \ (binds',fvBinds) ->
 448     returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds)
 449
 450 \end{code}
 451
 452 %************************************************************************
 453 %*                                                                      *
 454         Template Haskell brackets
 455 %*                                                                      *
 456 %************************************************************************
 457
 458 \begin{code}
 459 rnBracket (ExpBr e) = rnExpr e          `thenM` \ (e', fvs) ->
 460                       returnM (ExpBr e', fvs)
 461 rnBracket (PatBr p) = rnPat p           `thenM` \ (p', fvs) ->
 462                       returnM (PatBr p', fvs)
 463 rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
 464                       returnM (TypBr t', fvs)
 465                     where
 466                       doc = ptext SLIT("In a Template-Haskell quoted type")
 467 rnBracket (DecBr group)
 468   = importsFromLocalDecls group `thenM` \ (rdr_env, avails) ->
 469         -- Discard avails (not useful here)
 470
 471     updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $
 472
 473     rnSrcDecls group    `thenM` \ (tcg_env, group', fvs) ->
 474         -- Discard the tcg_env; it contains only extra info about fixity
 475
 476     returnM (DecBr group', fvs)
 477 \end{code}
 478
 479 %************************************************************************
 480 %*                                                                      *
 481 \subsubsection{@Stmt@s: in @do@ expressions}
 482 %*                                                                      *
 483 %************************************************************************
 484
 485 \begin{code}
 486 rnStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
 487
 488 rnStmts MDoExpr stmts = rnMDoStmts         stmts
 489 rnStmts ctxt   stmts  = rnNormalStmts ctxt stmts
 490
 491 rnNormalStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
 492 -- Used for cases *other* than recursive mdo
 493 -- Implements nested scopes
 494
 495 rnNormalStmts ctxt [] = returnM ([], emptyFVs)
 496         -- Happens at the end of the sub-lists of a ParStmts
 497
 498 rnNormalStmts ctxt (ExprStmt expr _ src_loc : stmts)
 499   = addSrcLoc src_loc           $
 500     rnExpr expr                 `thenM` \ (expr', fv_expr) ->
 501     rnNormalStmts ctxt stmts    `thenM` \ (stmts', fvs) ->
 502     returnM (ExprStmt expr' placeHolderType src_loc : stmts',
 503              fv_expr `plusFV` fvs)
 504
 505 rnNormalStmts ctxt [ResultStmt expr src_loc]
 506   = addSrcLoc src_loc   $
 507     rnExpr expr         `thenM` \ (expr', fv_expr) ->
 508     returnM ([ResultStmt expr' src_loc], fv_expr)
 509
 510 rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts)
 511   = addSrcLoc src_loc                   $
 512     rnExpr expr                         `thenM` \ (expr', fv_expr) ->
 513         -- The binders do not scope over the expression
 514
 515     rnPatsAndThen (StmtCtxt ctxt) [pat] $ \ [pat'] ->
 516     rnNormalStmts ctxt stmts            `thenM` \ (stmts', fvs) ->
 517     returnM (BindStmt pat' expr' src_loc : stmts',
 518              fv_expr `plusFV` fvs)      -- fv_expr shouldn't really be filtered by
 519                                         -- the rnPatsAndThen, but it does not matter
 520
 521 rnNormalStmts ctxt (LetStmt binds : stmts)
 522   = rnBindsAndThen binds                $ \ binds' ->
 523     rnNormalStmts ctxt stmts            `thenM` \ (stmts', fvs) ->
 524     returnM (LetStmt binds' : stmts', fvs)
 525
 526 rnNormalStmts ctxt (ParStmt stmtss : stmts)
 527   = mapFvRn (rnNormalStmts ctxt) stmtss `thenM` \ (stmtss', fv_stmtss) ->
 528     let
 529         bndrss = map collectStmtsBinders stmtss'
 530     in
 531     foldlM checkBndrs [] bndrss         `thenM` \ new_binders ->
 532     bindLocalNamesFV new_binders        $
 533         -- Note: binders are returned in scope order, so one may
 534         --       shadow the next; e.g. x <- xs; x <- ys
 535     rnNormalStmts ctxt stmts                    `thenM` \ (stmts', fvs) ->
 536     returnM (ParStmtOut (bndrss `zip` stmtss') : stmts',
 537              fv_stmtss `plusFV` fvs)
 538
 539   where
 540     checkBndrs all_bndrs bndrs
 541           = checkErr (null common) (err (head common)) `thenM_`
 542             returnM (bndrs ++ all_bndrs)
 543         where
 544           common = intersectBy eqOcc all_bndrs bndrs
 545
 546     eqOcc n1 n2 = nameOccName n1 == nameOccName n2
 547     err v = ptext SLIT("Duplicate binding in parallel list comprehension for:")
 548             <+> quotes (ppr v)
 549
 550 rnNormalStmts ctxt stmts = pprPanic "rnNormalStmts" (ppr stmts)
 551 \end{code}
 552
 553
 554 %************************************************************************
 555 %*                                                                      *
 556 \subsubsection{Precedence Parsing}
 557 %*                                                                      *
 558 %************************************************************************
 559
 560 \begin{code}
 561 type Defs    = NameSet
 562 type Uses    = NameSet  -- Same as FreeVars really
 563 type FwdRefs = NameSet
 564 type Segment = (Defs,
 565                 Uses,           -- May include defs
 566                 FwdRefs,        -- A subset of uses that are
 567                                 --   (a) used before they are bound in this segment, or
 568                                 --   (b) used here, and bound in subsequent segments
 569                 [RenamedStmt])
 570
 571 ----------------------------------------------------
 572 rnMDoStmts :: [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
 573 rnMDoStmts stmts
 574   =     -- Step1: bring all the binders of the mdo into scope
 575     bindLocalsRn doc (collectStmtsBinders stmts)        $ \ _ ->
 576
 577         -- Step 2: Rename each individual stmt, making a
 578         --         singleton segment.  At this stage the FwdRefs field
 579         --         isn't finished: it's empty for all except a BindStmt
 580         --         for which it's the fwd refs within the bind itself
 581     mappM rn_mdo_stmt stmts                             `thenM` \ segs ->
 582     let
 583         -- Step 3: Fill in the fwd refs.
 584         --         The segments are all singletons, but their fwd-ref
 585         --         field mentions all the things used by the segment
 586         --         that are bound after their use
 587         segs_w_fwd_refs = addFwdRefs segs
 588
 589         -- Step 4: Group together the segments to make bigger segments
 590         --         Invariant: in the result, no segment uses a variable
 591         --                    bound in a later segment
 592         grouped_segs = glomSegments segs_w_fwd_refs
 593
 594         -- Step 5: Turn the segments into Stmts
 595         --         Use RecStmt when and only when there are fwd refs
 596         --         Also gather up the uses from the end towards the
 597         --         start, so we can tell the RecStmt which things are
 598         --         used 'after' the RecStmt
 599         stmts_w_fvs = segsToStmts grouped_segs
 600     in
 601     returnM stmts_w_fvs
 602   where
 603     doc = text "In a mdo-expression"
 604
 605 ----------------------------------------------------
 606 rn_mdo_stmt :: RdrNameStmt -> RnM Segment
 607         -- Assumes all binders are already in scope
 608         -- Turns each stmt into a singleton Stmt
 609
 610 rn_mdo_stmt (ExprStmt expr _ src_loc)
 611   = addSrcLoc src_loc (rnExpr expr)     `thenM` \ (expr', fvs) ->
 612     returnM (emptyNameSet, fvs, emptyNameSet,
 613              [ExprStmt expr' placeHolderType src_loc])
 614
 615 rn_mdo_stmt (ResultStmt expr src_loc)
 616   = addSrcLoc src_loc (rnExpr expr)     `thenM` \ (expr', fvs) ->
 617     returnM (emptyNameSet, fvs, emptyNameSet,
 618              [ResultStmt expr' src_loc])
 619
 620 rn_mdo_stmt (BindStmt pat expr src_loc)
 621   = addSrcLoc src_loc   $
 622     rnExpr expr         `thenM` \ (expr', fv_expr) ->
 623     rnPat pat           `thenM` \ (pat', fv_pat) ->
 624     let
 625         bndrs = mkNameSet (collectPatBinders pat')
 626         fvs   = fv_expr `plusFV` fv_pat
 627     in
 628     returnM (bndrs, fvs, bndrs `intersectNameSet` fvs,
 629              [BindStmt pat' expr' src_loc])
 630
 631 rn_mdo_stmt (LetStmt binds)
 632   = rnBinds binds               `thenM` \ (binds', fv_binds) ->
 633     returnM (mkNameSet (collectHsBinders binds'),
 634              fv_binds, emptyNameSet, [LetStmt binds'])
 635
 636 rn_mdo_stmt stmt@(ParStmt _)    -- Syntactically illegal in mdo
 637   = pprPanic "rn_mdo_stmt" (ppr stmt)
 638
 639
 640 addFwdRefs :: [Segment] -> [Segment]
 641 -- So far the segments only have forward refs *within* the Stmt
 642 --      (which happens for bind:  x <- ...x...)
 643 -- This function adds the cross-seg fwd ref info
 644
 645 addFwdRefs pairs
 646   = fst (foldr mk_seg ([], emptyNameSet) pairs)
 647   where
 648     mk_seg (defs, uses, fwds, stmts) (segs, seg_defs)
 649         = (new_seg : segs, all_defs)
 650         where
 651           new_seg = (defs, uses, new_fwds, stmts)
 652           all_defs = seg_defs `unionNameSets` defs
 653           new_fwds = fwds `unionNameSets` (uses `intersectNameSet` seg_defs)
 654                 -- Add the downstream fwd refs here
 655
 656 ----------------------------------------------------
 657 --      Glomming the singleton segments of an mdo into
 658 --      minimal recursive groups.
 659 --
 660 -- At first I thought this was just strongly connected components, but
 661 -- there's an important constraint: the order of the stmts must not change.
 662 --
 663 -- Consider
 664 --      mdo { x <- ...y...
 665 --            p <- z
 666 --            y <- ...x...
 667 --            q <- x
 668 --            z <- y
 669 --            r <- x }
 670 --
 671 -- Here, the first stmt mention 'y', which is bound in the third.
 672 -- But that means that the innocent second stmt (p <- z) gets caught
 673 -- up in the recursion.  And that in turn means that the binding for
 674 -- 'z' has to be included... and so on.
 675 --
 676 -- Start at the tail { r <- x }
 677 -- Now add the next one { z <- y ; r <- x }
 678 -- Now add one more     { q <- x ; z <- y ; r <- x }
 679 -- Now one more... but this time we have to group a bunch into rec
 680 --      { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
 681 -- Now one more, which we can add on without a rec
 682 --      { p <- z ;
 683 --        rec { y <- ...x... ; q <- x ; z <- y } ;
 684 --        r <- x }
 685 -- Finally we add the last one; since it mentions y we have to
 686 -- glom it togeher with the first two groups
 687 --      { rec { x <- ...y...; p <- z ; y <- ...x... ;
 688 --              q <- x ; z <- y } ;
 689 --        r <- x }
 690
 691 glomSegments :: [Segment] -> [Segment]
 692
 693 glomSegments [seg] = [seg]
 694 glomSegments ((defs,uses,fwds,stmts) : segs)
 695         -- Actually stmts will always be a singleton
 696   = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others
 697   where
 698     segs'            = glomSegments segs
 699     (extras, others) = grab uses segs'
 700     (ds, us, fs, ss) = unzip4 extras
 701
 702     seg_defs  = plusFVs ds `plusFV` defs
 703     seg_uses  = plusFVs us `plusFV` uses
 704     seg_fwds  = plusFVs fs `plusFV` fwds
 705     seg_stmts = stmts ++ concat ss
 706
 707     grab :: NameSet             -- The client
 708          -> [Segment]
 709          -> ([Segment],         -- Needed by the 'client'
 710              [Segment])         -- Not needed by the client
 711         -- The result is simply a split of the input
 712     grab uses dus
 713         = (reverse yeses, reverse noes)
 714         where
 715           (noes, yeses)           = span not_needed (reverse dus)
 716           not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
 717
 718
 719 ----------------------------------------------------
 720 segsToStmts :: [Segment] -> ([RenamedStmt], FreeVars)
 721
 722 segsToStmts [] = ([], emptyFVs)
 723 segsToStmts ((defs, uses, fwds, ss) : segs)
 724   = (new_stmt : later_stmts, later_uses `plusFV` uses)
 725   where
 726     (later_stmts, later_uses) = segsToStmts segs
 727     new_stmt | non_rec   = head ss
 728              | otherwise = RecStmt rec_names ss []
 729              where
 730                non_rec   = isSingleton ss && isEmptyNameSet fwds
 731                rec_names = nameSetToList (fwds `plusFV` (defs `intersectNameSet` later_uses))
 732                 -- The names for the fixpoint are
 733                 --      (a) the ones needed after the RecStmt
 734                 --      (b) the forward refs within the fixpoint
 735 \end{code}
 736
 737 %************************************************************************
 738 %*                                                                      *
 739 \subsubsection{Precedence Parsing}
 740 %*                                                                      *
 741 %************************************************************************
 742
 743 @mkOpAppRn@ deals with operator fixities.  The argument expressions
 744 are assumed to be already correctly arranged.  It needs the fixities
 745 recorded in the OpApp nodes, because fixity info applies to the things
 746 the programmer actually wrote, so you can't find it out from the Name.
 747
 748 Furthermore, the second argument is guaranteed not to be another
 749 operator application.  Why? Because the parser parses all
 750 operator appications left-associatively, EXCEPT negation, which
 751 we need to handle specially.
 752
 753 \begin{code}
 754 mkOpAppRn :: RenamedHsExpr                      -- Left operand; already rearranged
 755           -> RenamedHsExpr -> Fixity            -- Operator and fixity
 756           -> RenamedHsExpr                      -- Right operand (not an OpApp, but might
 757                                                 -- be a NegApp)
 758           -> RnM RenamedHsExpr
 759
 760 ---------------------------
 761 -- (e11 `op1` e12) `op2` e2
 762 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
 763   | nofix_error
 764   = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))   `thenM_`
 765     returnM (OpApp e1 op2 fix2 e2)
 766
 767   | associate_right
 768   = mkOpAppRn e12 op2 fix2 e2           `thenM` \ new_e ->
 769     returnM (OpApp e11 op1 fix1 new_e)
 770   where
 771     (nofix_error, associate_right) = compareFixity fix1 fix2
 772
 773 ---------------------------
 774 --      (- neg_arg) `op` e2
 775 mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2
 776   | nofix_error
 777   = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2))      `thenM_`
 778     returnM (OpApp e1 op2 fix2 e2)
 779
 780   | associate_right
 781   = mkOpAppRn neg_arg op2 fix2 e2       `thenM` \ new_e ->
 782     returnM (NegApp new_e neg_name)
 783   where
 784     (nofix_error, associate_right) = compareFixity negateFixity fix2
 785
 786 ---------------------------
 787 --      e1 `op` - neg_arg
 788 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _)     -- NegApp can occur on the right
 789   | not associate_right                         -- We *want* right association
 790   = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity))    `thenM_`
 791     returnM (OpApp e1 op1 fix1 e2)
 792   where
 793     (_, associate_right) = compareFixity fix1 negateFixity
 794
 795 ---------------------------
 796 --      Default case
 797 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
 798   = ASSERT2( right_op_ok fix e2,
 799              ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
 800     )
 801     returnM (OpApp e1 op fix e2)
 802
 803 -- Parser left-associates everything, but
 804 -- derived instances may have correctly-associated things to
 805 -- in the right operarand.  So we just check that the right operand is OK
 806 right_op_ok fix1 (OpApp _ _ fix2 _)
 807   = not error_please && associate_right
 808   where
 809     (error_please, associate_right) = compareFixity fix1 fix2
 810 right_op_ok fix1 other
 811   = True
 812
 813 -- Parser initially makes negation bind more tightly than any other operator
 814 mkNegAppRn neg_arg neg_name
 815   =
 816 #ifdef DEBUG
 817     getModeRn                   `thenM` \ mode ->
 818     ASSERT( not_op_app mode neg_arg )
 819 #endif
 820     returnM (NegApp neg_arg neg_name)
 821
 822 not_op_app SourceMode (OpApp _ _ _ _) = False
 823 not_op_app mode other                 = True
 824 \end{code}
 825
 826 \begin{code}
 827 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnM ()
 828
 829 checkPrecMatch False fn match
 830   = returnM ()
 831
 832 checkPrecMatch True op (Match (p1:p2:_) _ _)
 833         -- True indicates an infix lhs
 834   = getModeRn           `thenM` \ mode ->
 835         -- See comments with rnExpr (OpApp ...)
 836     if isInterfaceMode mode
 837         then returnM ()
 838         else checkPrec op p1 False      `thenM_`
 839              checkPrec op p2 True
 840
 841 checkPrecMatch True op _ = panic "checkPrecMatch"
 842
 843 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
 844   = lookupFixityRn op   `thenM` \  op_fix@(Fixity op_prec  op_dir) ->
 845     lookupFixityRn op1  `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
 846     let
 847         inf_ok = op1_prec > op_prec ||
 848                  (op1_prec == op_prec &&
 849                   (op1_dir == InfixR && op_dir == InfixR && right ||
 850                    op1_dir == InfixL && op_dir == InfixL && not right))
 851
 852         info  = (ppr_op op,  op_fix)
 853         info1 = (ppr_op op1, op1_fix)
 854         (infol, infor) = if right then (info, info1) else (info1, info)
 855     in
 856     checkErr inf_ok (precParseErr infol infor)
 857
 858 checkPrec op pat right
 859   = returnM ()
 860
 861 -- Check precedence of (arg op) or (op arg) respectively
 862 -- If arg is itself an operator application, then either
 863 --   (a) its precedence must be higher than that of op
 864 --   (b) its precedency & associativity must be the same as that of op
 865 checkSectionPrec direction section op arg
 866   = case arg of
 867         OpApp _ op fix _ -> go_for_it (ppr_op op)     fix
 868         NegApp _ _       -> go_for_it pp_prefix_minus negateFixity
 869         other            -> returnM ()
 870   where
 871     HsVar op_name = op
 872     go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
 873         = lookupFixityRn op_name        `thenM` \ op_fix@(Fixity op_prec _) ->
 874           checkErr (op_prec < arg_prec
 875                      || op_prec == arg_prec && direction == assoc)
 876                   (sectionPrecErr (ppr_op op_name, op_fix)
 877                   (pp_arg_op, arg_fix) section)
 878 \end{code}
 879
 880
 881 %************************************************************************
 882 %*                                                                      *
 883 \subsubsection{Assertion utils}
 884 %*                                                                      *
 885 %************************************************************************
 886
 887 \begin{code}
 888 mkAssertErrorExpr :: RnM (RenamedHsExpr, FreeVars)
 889 -- Return an expression for (assertError "Foo.hs:27")
 890 mkAssertErrorExpr
 891   = getSrcLocM                          `thenM` \ sloc ->
 892     let
 893         expr = HsApp (HsVar assertErrorName) (HsLit msg)
 894         msg  = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
 895     in
 896     returnM (expr, unitFV assertErrorName)
 897 \end{code}
 898
 899 %************************************************************************
 900 %*                                                                      *
 901 \subsubsection{Errors}
 902 %*                                                                      *
 903 %************************************************************************
 904
 905 \begin{code}
 906 ppr_op op = quotes (ppr op)     -- Here, op can be a Name or a (Var n), where n is a Name
 907 pp_prefix_minus = ptext SLIT("prefix `-'")
 908
 909 nonStdGuardErr guard
 910   = hang (ptext
 911     SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
 912     ) 4 (ppr guard)
 913
 914 patSynErr e
 915   = sep [ptext SLIT("Pattern syntax in expression context:"),
 916          nest 4 (ppr e)]
 917
 918 doStmtListErr do_or_lc e
 919   = sep [quotes (text binder_name) <+> ptext SLIT("statements must end in expression:"),
 920          nest 4 (ppr e)]
 921   where
 922     binder_name = case do_or_lc of
 923                         MDoExpr -> "mdo"
 924                         other   -> "do"
 925
 926 thErr what
 927   = ptext SLIT("Template Haskell") <+> text what <+>
 928     ptext SLIT("illegal in a stage-1 compiler")
 929
 930
 931 withWarning
 932   = sep [quotes (ptext SLIT("with")),
 933          ptext SLIT("is deprecated, use"),
 934          quotes (ptext SLIT("let")),
 935          ptext SLIT("instead")]
 936 \end{code}