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)
 232   = checkGHCI (thErr "bracket")         `thenM_`
 233     rnBracket br_body                   `thenM` \ (body', fvs_e) ->
 234     returnM (HsBracket body', fvs_e `addOneFV` qTyConName)
 235         -- We use the Q tycon as a proxy to haul in all the smart
 236         -- constructors; see the hack in RnIfaces
 237 #endif
 238
 239 rnExpr (HsSplice n e)
 240   = checkGHCI (thErr "splice")          `thenM_`
 241     getSrcLocM                          `thenM` \ loc ->
 242     newLocalsRn [(n,loc)]               `thenM` \ [n'] ->
 243     rnExpr e                            `thenM` \ (e', fvs_e) ->
 244     returnM (HsSplice n' e', fvs_e)
 245
 246 rnExpr section@(SectionL expr op)
 247   = rnExpr expr                                 `thenM` \ (expr', fvs_expr) ->
 248     rnExpr op                                   `thenM` \ (op', fvs_op) ->
 249     checkSectionPrec InfixL section op' expr' `thenM_`
 250     returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
 251
 252 rnExpr section@(SectionR op expr)
 253   = rnExpr op                                   `thenM` \ (op',   fvs_op) ->
 254     rnExpr expr                                 `thenM` \ (expr', fvs_expr) ->
 255     checkSectionPrec InfixR section op' expr'   `thenM_`
 256     returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
 257
 258 rnExpr (HsCCall fun args may_gc is_casm _)
 259         -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
 260   = rnExprs args                                `thenM` \ (args', fvs_args) ->
 261     returnM (HsCCall fun args' may_gc is_casm placeHolderType,
 262               fvs_args `plusFV` mkFVs [cCallableClassName,
 263                                        cReturnableClassName,
 264                                        ioDataConName])
 265
 266 rnExpr (HsSCC lbl expr)
 267   = rnExpr expr         `thenM` \ (expr', fvs_expr) ->
 268     returnM (HsSCC lbl expr', fvs_expr)
 269
 270 rnExpr (HsCase expr ms src_loc)
 271   = addSrcLoc src_loc $
 272     rnExpr expr                         `thenM` \ (new_expr, e_fvs) ->
 273     mapFvRn (rnMatch CaseAlt) ms        `thenM` \ (new_ms, ms_fvs) ->
 274     returnM (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
 275
 276 rnExpr (HsLet binds expr)
 277   = rnBindsAndThen binds        $ \ binds' ->
 278     rnExpr expr                  `thenM` \ (expr',fvExpr) ->
 279     returnM (HsLet binds' expr', fvExpr)
 280
 281 rnExpr (HsWith expr binds is_with)
 282   = warnIf is_with withWarning `thenM_`
 283     rnExpr expr                 `thenM` \ (expr',fvExpr) ->
 284     rnIPBinds binds             `thenM` \ (binds',fvBinds) ->
 285     returnM (HsWith expr' binds' is_with, fvExpr `plusFV` fvBinds)
 286
 287 rnExpr e@(HsDo do_or_lc stmts _ _ src_loc)
 288   = addSrcLoc src_loc $
 289     rnStmts do_or_lc stmts              `thenM` \ (stmts', fvs) ->
 290
 291         -- Check the statement list ends in an expression
 292     case last stmts' of {
 293         ResultStmt _ _ -> returnM () ;
 294         _              -> addErr (doStmtListErr do_or_lc e)
 295     }                                   `thenM_`
 296
 297         -- Generate the rebindable syntax for the monad
 298     mapAndUnzipM lookupSyntaxName
 299          (syntax_names do_or_lc)        `thenM` \ (monad_names', monad_fvs) ->
 300
 301     returnM (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc,
 302              fvs `plusFV` implicit_fvs do_or_lc `plusFV` plusFVs monad_fvs)
 303   where
 304     implicit_fvs PArrComp = mkFVs [replicatePName, mapPName, filterPName, crossPName, zipPName]
 305     implicit_fvs ListComp = mkFVs [foldrName, buildName]
 306     implicit_fvs DoExpr   = emptyFVs
 307     implicit_fvs MDoExpr  = emptyFVs
 308
 309     syntax_names DoExpr  = monadNames
 310     syntax_names MDoExpr = monadNames ++ [mfixName]
 311     syntax_names other   = []
 312
 313 rnExpr (ExplicitList _ exps)
 314   = rnExprs exps                        `thenM` \ (exps', fvs) ->
 315     returnM  (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
 316
 317 rnExpr (ExplicitPArr _ exps)
 318   = rnExprs exps                        `thenM` \ (exps', fvs) ->
 319     returnM  (ExplicitPArr placeHolderType exps',
 320                fvs `addOneFV` toPName `addOneFV` parrTyCon_name)
 321
 322 rnExpr (ExplicitTuple exps boxity)
 323   = rnExprs exps                                `thenM` \ (exps', fvs) ->
 324     returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
 325   where
 326     tycon_name = tupleTyCon_name boxity (length exps)
 327
 328 rnExpr (RecordCon con_id rbinds)
 329   = lookupOccRn con_id                  `thenM` \ conname ->
 330     rnRbinds "construction" rbinds      `thenM` \ (rbinds', fvRbinds) ->
 331     returnM (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
 332
 333 rnExpr (RecordUpd expr rbinds)
 334   = rnExpr expr                 `thenM` \ (expr', fvExpr) ->
 335     rnRbinds "update" rbinds    `thenM` \ (rbinds', fvRbinds) ->
 336     returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
 337
 338 rnExpr (ExprWithTySig expr pty)
 339   = rnExpr expr                 `thenM` \ (expr', fvExpr) ->
 340     rnHsTypeFVs doc pty         `thenM` \ (pty', fvTy) ->
 341     returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
 342   where
 343     doc = text "In an expression type signature"
 344
 345 rnExpr (HsIf p b1 b2 src_loc)
 346   = addSrcLoc src_loc $
 347     rnExpr p            `thenM` \ (p', fvP) ->
 348     rnExpr b1           `thenM` \ (b1', fvB1) ->
 349     rnExpr b2           `thenM` \ (b2', fvB2) ->
 350     returnM (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
 351
 352 rnExpr (HsType a)
 353   = rnHsTypeFVs doc a   `thenM` \ (t, fvT) ->
 354     returnM (HsType t, fvT)
 355   where
 356     doc = text "In a type argument"
 357
 358 rnExpr (ArithSeqIn seq)
 359   = rnArithSeq seq       `thenM` \ (new_seq, fvs) ->
 360     returnM (ArithSeqIn new_seq, fvs `addOneFV` enumClassName)
 361
 362 rnExpr (PArrSeqIn seq)
 363   = rnArithSeq seq       `thenM` \ (new_seq, fvs) ->
 364     returnM (PArrSeqIn new_seq,
 365              fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName])
 366 \end{code}
 367
 368 These three are pattern syntax appearing in expressions.
 369 Since all the symbols are reservedops we can simply reject them.
 370 We return a (bogus) EWildPat in each case.
 371
 372 \begin{code}
 373 rnExpr e@EWildPat = addErr (patSynErr e)        `thenM_`
 374                     returnM (EWildPat, emptyFVs)
 375
 376 rnExpr e@(EAsPat _ _) = addErr (patSynErr e)    `thenM_`
 377                         returnM (EWildPat, emptyFVs)
 378
 379 rnExpr e@(ELazyPat _) = addErr (patSynErr e)    `thenM_`
 380                         returnM (EWildPat, emptyFVs)
 381 \end{code}
 382
 383 %************************************************************************
 384 %*                                                                      *
 385         Arithmetic sequences
 386 %*                                                                      *
 387 %************************************************************************
 388
 389 \begin{code}
 390 rnArithSeq (From expr)
 391  = rnExpr expr  `thenM` \ (expr', fvExpr) ->
 392    returnM (From expr', fvExpr)
 393
 394 rnArithSeq (FromThen expr1 expr2)
 395  = rnExpr expr1         `thenM` \ (expr1', fvExpr1) ->
 396    rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
 397    returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 398
 399 rnArithSeq (FromTo expr1 expr2)
 400  = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
 401    rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
 402    returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 403
 404 rnArithSeq (FromThenTo expr1 expr2 expr3)
 405  = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
 406    rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
 407    rnExpr expr3 `thenM` \ (expr3', fvExpr3) ->
 408    returnM (FromThenTo expr1' expr2' expr3',
 409             plusFVs [fvExpr1, fvExpr2, fvExpr3])
 410 \end{code}
 411
 412
 413 %************************************************************************
 414 %*                                                                      *
 415 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
 416 %*                                                                      *
 417 %************************************************************************
 418
 419 \begin{code}
 420 rnRbinds str rbinds
 421   = mappM_ field_dup_err dup_fields     `thenM_`
 422     mapFvRn rn_rbind rbinds             `thenM` \ (rbinds', fvRbind) ->
 423     returnM (rbinds', fvRbind)
 424   where
 425     (_, dup_fields) = removeDups compare [ f | (f,_) <- rbinds ]
 426
 427     field_dup_err dups = addErr (dupFieldErr str dups)
 428
 429     rn_rbind (field, expr)
 430       = lookupGlobalOccRn field `thenM` \ fieldname ->
 431         rnExpr expr             `thenM` \ (expr', fvExpr) ->
 432         returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname)
 433 \end{code}
 434
 435 %************************************************************************
 436 %*                                                                      *
 437 \subsubsection{@rnIPBinds@s: in implicit parameter bindings}            *
 438 %*                                                                      *
 439 %************************************************************************
 440
 441 \begin{code}
 442 rnIPBinds [] = returnM ([], emptyFVs)
 443 rnIPBinds ((n, expr) : binds)
 444   = newIPName n                 `thenM` \ name ->
 445     rnExpr expr                 `thenM` \ (expr',fvExpr) ->
 446     rnIPBinds binds             `thenM` \ (binds',fvBinds) ->
 447     returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds)
 448
 449 \end{code}
 450
 451 %************************************************************************
 452 %*                                                                      *
 453         Template Haskell brackets
 454 %*                                                                      *
 455 %************************************************************************
 456
 457 \begin{code}
 458 rnBracket (ExpBr e) = rnExpr e          `thenM` \ (e', fvs) ->
 459                       returnM (ExpBr e', fvs)
 460 rnBracket (PatBr p) = rnPat p           `thenM` \ (p', fvs) ->
 461                       returnM (PatBr p', fvs)
 462 rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
 463                       returnM (TypBr t', fvs)
 464                     where
 465                       doc = ptext SLIT("In a Template-Haskell quoted type")
 466 rnBracket (DecBr group)
 467   = importsFromLocalDecls group `thenM` \ (rdr_env, avails) ->
 468         -- Discard avails (not useful here)
 469
 470     updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $
 471
 472     rnSrcDecls group    `thenM` \ (tcg_env, group', fvs) ->
 473         -- Discard the tcg_env; it contains only extra info about fixity
 474
 475     returnM (DecBr group', fvs)
 476 \end{code}
 477
 478 %************************************************************************
 479 %*                                                                      *
 480 \subsubsection{@Stmt@s: in @do@ expressions}
 481 %*                                                                      *
 482 %************************************************************************
 483
 484 \begin{code}
 485 rnStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
 486
 487 rnStmts MDoExpr stmts = rnMDoStmts         stmts
 488 rnStmts ctxt   stmts  = rnNormalStmts ctxt stmts
 489
 490 rnNormalStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
 491 -- Used for cases *other* than recursive mdo
 492 -- Implements nested scopes
 493
 494 rnNormalStmts ctxt [] = returnM ([], emptyFVs)
 495         -- Happens at the end of the sub-lists of a ParStmts
 496
 497 rnNormalStmts ctxt (ExprStmt expr _ src_loc : stmts)
 498   = addSrcLoc src_loc           $
 499     rnExpr expr                 `thenM` \ (expr', fv_expr) ->
 500     rnNormalStmts ctxt stmts    `thenM` \ (stmts', fvs) ->
 501     returnM (ExprStmt expr' placeHolderType src_loc : stmts',
 502              fv_expr `plusFV` fvs)
 503
 504 rnNormalStmts ctxt [ResultStmt expr src_loc]
 505   = addSrcLoc src_loc   $
 506     rnExpr expr         `thenM` \ (expr', fv_expr) ->
 507     returnM ([ResultStmt expr' src_loc], fv_expr)
 508
 509 rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts)
 510   = addSrcLoc src_loc                   $
 511     rnExpr expr                         `thenM` \ (expr', fv_expr) ->
 512         -- The binders do not scope over the expression
 513
 514     rnPatsAndThen (StmtCtxt ctxt) [pat] $ \ [pat'] ->
 515     rnNormalStmts ctxt stmts            `thenM` \ (stmts', fvs) ->
 516     returnM (BindStmt pat' expr' src_loc : stmts',
 517              fv_expr `plusFV` fvs)      -- fv_expr shouldn't really be filtered by
 518                                         -- the rnPatsAndThen, but it does not matter
 519
 520 rnNormalStmts ctxt (LetStmt binds : stmts)
 521   = rnBindsAndThen binds                $ \ binds' ->
 522     rnNormalStmts ctxt stmts            `thenM` \ (stmts', fvs) ->
 523     returnM (LetStmt binds' : stmts', fvs)
 524
 525 rnNormalStmts ctxt (ParStmt stmtss : stmts)
 526   = mapFvRn (rnNormalStmts ctxt) stmtss `thenM` \ (stmtss', fv_stmtss) ->
 527     let
 528         bndrss = map collectStmtsBinders stmtss'
 529     in
 530     foldlM checkBndrs [] bndrss         `thenM` \ new_binders ->
 531     bindLocalNamesFV new_binders        $
 532         -- Note: binders are returned in scope order, so one may
 533         --       shadow the next; e.g. x <- xs; x <- ys
 534     rnNormalStmts ctxt stmts                    `thenM` \ (stmts', fvs) ->
 535     returnM (ParStmtOut (bndrss `zip` stmtss') : stmts',
 536              fv_stmtss `plusFV` fvs)
 537
 538   where
 539     checkBndrs all_bndrs bndrs
 540           = checkErr (null common) (err (head common)) `thenM_`
 541             returnM (bndrs ++ all_bndrs)
 542         where
 543           common = intersectBy eqOcc all_bndrs bndrs
 544
 545     eqOcc n1 n2 = nameOccName n1 == nameOccName n2
 546     err v = ptext SLIT("Duplicate binding in parallel list comprehension for:")
 547             <+> quotes (ppr v)
 548
 549 rnNormalStmts ctxt stmts = pprPanic "rnNormalStmts" (ppr stmts)
 550 \end{code}
 551
 552
 553 %************************************************************************
 554 %*                                                                      *
 555 \subsubsection{Precedence Parsing}
 556 %*                                                                      *
 557 %************************************************************************
 558
 559 \begin{code}
 560 type Defs    = NameSet
 561 type Uses    = NameSet  -- Same as FreeVars really
 562 type FwdRefs = NameSet
 563 type Segment = (Defs,
 564                 Uses,           -- May include defs
 565                 FwdRefs,        -- A subset of uses that are
 566                                 --   (a) used before they are bound in this segment, or
 567                                 --   (b) used here, and bound in subsequent segments
 568                 [RenamedStmt])
 569
 570 ----------------------------------------------------
 571 rnMDoStmts :: [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
 572 rnMDoStmts stmts
 573   =     -- Step1: bring all the binders of the mdo into scope
 574     bindLocalsRn doc (collectStmtsBinders stmts)        $ \ _ ->
 575
 576         -- Step 2: Rename each individual stmt, making a
 577         --         singleton segment.  At this stage the FwdRefs field
 578         --         isn't finished: it's empty for all except a BindStmt
 579         --         for which it's the fwd refs within the bind itself
 580     mappM rn_mdo_stmt stmts                             `thenM` \ segs ->
 581     let
 582         -- Step 3: Fill in the fwd refs.
 583         --         The segments are all singletons, but their fwd-ref
 584         --         field mentions all the things used by the segment
 585         --         that are bound after their use
 586         segs_w_fwd_refs = addFwdRefs segs
 587
 588         -- Step 4: Group together the segments to make bigger segments
 589         --         Invariant: in the result, no segment uses a variable
 590         --                    bound in a later segment
 591         grouped_segs = glomSegments segs_w_fwd_refs
 592
 593         -- Step 5: Turn the segments into Stmts
 594         --         Use RecStmt when and only when there are fwd refs
 595         --         Also gather up the uses from the end towards the
 596         --         start, so we can tell the RecStmt which things are
 597         --         used 'after' the RecStmt
 598         stmts_w_fvs = segsToStmts grouped_segs
 599     in
 600     returnM stmts_w_fvs
 601   where
 602     doc = text "In a mdo-expression"
 603
 604 ----------------------------------------------------
 605 rn_mdo_stmt :: RdrNameStmt -> RnM Segment
 606         -- Assumes all binders are already in scope
 607         -- Turns each stmt into a singleton Stmt
 608
 609 rn_mdo_stmt (ExprStmt expr _ src_loc)
 610   = addSrcLoc src_loc (rnExpr expr)     `thenM` \ (expr', fvs) ->
 611     returnM (emptyNameSet, fvs, emptyNameSet,
 612              [ExprStmt expr' placeHolderType src_loc])
 613
 614 rn_mdo_stmt (ResultStmt expr src_loc)
 615   = addSrcLoc src_loc (rnExpr expr)     `thenM` \ (expr', fvs) ->
 616     returnM (emptyNameSet, fvs, emptyNameSet,
 617              [ResultStmt expr' src_loc])
 618
 619 rn_mdo_stmt (BindStmt pat expr src_loc)
 620   = addSrcLoc src_loc   $
 621     rnExpr expr         `thenM` \ (expr', fv_expr) ->
 622     rnPat pat           `thenM` \ (pat', fv_pat) ->
 623     let
 624         bndrs = mkNameSet (collectPatBinders pat')
 625         fvs   = fv_expr `plusFV` fv_pat
 626     in
 627     returnM (bndrs, fvs, bndrs `intersectNameSet` fvs,
 628              [BindStmt pat' expr' src_loc])
 629
 630 rn_mdo_stmt (LetStmt binds)
 631   = rnBinds binds               `thenM` \ (binds', fv_binds) ->
 632     returnM (mkNameSet (collectHsBinders binds'),
 633              fv_binds, emptyNameSet, [LetStmt binds'])
 634
 635 rn_mdo_stmt stmt@(ParStmt _)    -- Syntactically illegal in mdo
 636   = pprPanic "rn_mdo_stmt" (ppr stmt)
 637
 638
 639 addFwdRefs :: [Segment] -> [Segment]
 640 -- So far the segments only have forward refs *within* the Stmt
 641 --      (which happens for bind:  x <- ...x...)
 642 -- This function adds the cross-seg fwd ref info
 643
 644 addFwdRefs pairs
 645   = fst (foldr mk_seg ([], emptyNameSet) pairs)
 646   where
 647     mk_seg (defs, uses, fwds, stmts) (segs, seg_defs)
 648         = (new_seg : segs, all_defs)
 649         where
 650           new_seg = (defs, uses, new_fwds, stmts)
 651           all_defs = seg_defs `unionNameSets` defs
 652           new_fwds = fwds `unionNameSets` (uses `intersectNameSet` seg_defs)
 653                 -- Add the downstream fwd refs here
 654
 655 ----------------------------------------------------
 656 --      Glomming the singleton segments of an mdo into
 657 --      minimal recursive groups.
 658 --
 659 -- At first I thought this was just strongly connected components, but
 660 -- there's an important constraint: the order of the stmts must not change.
 661 --
 662 -- Consider
 663 --      mdo { x <- ...y...
 664 --            p <- z
 665 --            y <- ...x...
 666 --            q <- x
 667 --            z <- y
 668 --            r <- x }
 669 --
 670 -- Here, the first stmt mention 'y', which is bound in the third.
 671 -- But that means that the innocent second stmt (p <- z) gets caught
 672 -- up in the recursion.  And that in turn means that the binding for
 673 -- 'z' has to be included... and so on.
 674 --
 675 -- Start at the tail { r <- x }
 676 -- Now add the next one { z <- y ; r <- x }
 677 -- Now add one more     { q <- x ; z <- y ; r <- x }
 678 -- Now one more... but this time we have to group a bunch into rec
 679 --      { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
 680 -- Now one more, which we can add on without a rec
 681 --      { p <- z ;
 682 --        rec { y <- ...x... ; q <- x ; z <- y } ;
 683 --        r <- x }
 684 -- Finally we add the last one; since it mentions y we have to
 685 -- glom it togeher with the first two groups
 686 --      { rec { x <- ...y...; p <- z ; y <- ...x... ;
 687 --              q <- x ; z <- y } ;
 688 --        r <- x }
 689
 690 glomSegments :: [Segment] -> [Segment]
 691
 692 glomSegments [seg] = [seg]
 693 glomSegments ((defs,uses,fwds,stmts) : segs)
 694         -- Actually stmts will always be a singleton
 695   = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others
 696   where
 697     segs'            = glomSegments segs
 698     (extras, others) = grab uses segs'
 699     (ds, us, fs, ss) = unzip4 extras
 700
 701     seg_defs  = plusFVs ds `plusFV` defs
 702     seg_uses  = plusFVs us `plusFV` uses
 703     seg_fwds  = plusFVs fs `plusFV` fwds
 704     seg_stmts = stmts ++ concat ss
 705
 706     grab :: NameSet             -- The client
 707          -> [Segment]
 708          -> ([Segment],         -- Needed by the 'client'
 709              [Segment])         -- Not needed by the client
 710         -- The result is simply a split of the input
 711     grab uses dus
 712         = (reverse yeses, reverse noes)
 713         where
 714           (noes, yeses)           = span not_needed (reverse dus)
 715           not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
 716
 717
 718 ----------------------------------------------------
 719 segsToStmts :: [Segment] -> ([RenamedStmt], FreeVars)
 720
 721 segsToStmts [] = ([], emptyFVs)
 722 segsToStmts ((defs, uses, fwds, ss) : segs)
 723   = (new_stmt : later_stmts, later_uses `plusFV` uses)
 724   where
 725     (later_stmts, later_uses) = segsToStmts segs
 726     new_stmt | non_rec   = head ss
 727              | otherwise = RecStmt rec_names ss
 728              where
 729                non_rec   = isSingleton ss && isEmptyNameSet fwds
 730                rec_names = nameSetToList (fwds `plusFV` (defs `intersectNameSet` later_uses))
 731                 -- The names for the fixpoint are
 732                 --      (a) the ones needed after the RecStmt
 733                 --      (b) the forward refs within the fixpoint
 734 \end{code}
 735
 736 %************************************************************************
 737 %*                                                                      *
 738 \subsubsection{Precedence Parsing}
 739 %*                                                                      *
 740 %************************************************************************
 741
 742 @mkOpAppRn@ deals with operator fixities.  The argument expressions
 743 are assumed to be already correctly arranged.  It needs the fixities
 744 recorded in the OpApp nodes, because fixity info applies to the things
 745 the programmer actually wrote, so you can't find it out from the Name.
 746
 747 Furthermore, the second argument is guaranteed not to be another
 748 operator application.  Why? Because the parser parses all
 749 operator appications left-associatively, EXCEPT negation, which
 750 we need to handle specially.
 751
 752 \begin{code}
 753 mkOpAppRn :: RenamedHsExpr                      -- Left operand; already rearranged
 754           -> RenamedHsExpr -> Fixity            -- Operator and fixity
 755           -> RenamedHsExpr                      -- Right operand (not an OpApp, but might
 756                                                 -- be a NegApp)
 757           -> RnM RenamedHsExpr
 758
 759 ---------------------------
 760 -- (e11 `op1` e12) `op2` e2
 761 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
 762   | nofix_error
 763   = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))   `thenM_`
 764     returnM (OpApp e1 op2 fix2 e2)
 765
 766   | associate_right
 767   = mkOpAppRn e12 op2 fix2 e2           `thenM` \ new_e ->
 768     returnM (OpApp e11 op1 fix1 new_e)
 769   where
 770     (nofix_error, associate_right) = compareFixity fix1 fix2
 771
 772 ---------------------------
 773 --      (- neg_arg) `op` e2
 774 mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2
 775   | nofix_error
 776   = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2))      `thenM_`
 777     returnM (OpApp e1 op2 fix2 e2)
 778
 779   | associate_right
 780   = mkOpAppRn neg_arg op2 fix2 e2       `thenM` \ new_e ->
 781     returnM (NegApp new_e neg_name)
 782   where
 783     (nofix_error, associate_right) = compareFixity negateFixity fix2
 784
 785 ---------------------------
 786 --      e1 `op` - neg_arg
 787 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _)     -- NegApp can occur on the right
 788   | not associate_right                         -- We *want* right association
 789   = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity))    `thenM_`
 790     returnM (OpApp e1 op1 fix1 e2)
 791   where
 792     (_, associate_right) = compareFixity fix1 negateFixity
 793
 794 ---------------------------
 795 --      Default case
 796 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
 797   = ASSERT2( right_op_ok fix e2,
 798              ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
 799     )
 800     returnM (OpApp e1 op fix e2)
 801
 802 -- Parser left-associates everything, but
 803 -- derived instances may have correctly-associated things to
 804 -- in the right operarand.  So we just check that the right operand is OK
 805 right_op_ok fix1 (OpApp _ _ fix2 _)
 806   = not error_please && associate_right
 807   where
 808     (error_please, associate_right) = compareFixity fix1 fix2
 809 right_op_ok fix1 other
 810   = True
 811
 812 -- Parser initially makes negation bind more tightly than any other operator
 813 mkNegAppRn neg_arg neg_name
 814   =
 815 #ifdef DEBUG
 816     getModeRn                   `thenM` \ mode ->
 817     ASSERT( not_op_app mode neg_arg )
 818 #endif
 819     returnM (NegApp neg_arg neg_name)
 820
 821 not_op_app SourceMode (OpApp _ _ _ _) = False
 822 not_op_app mode other                 = True
 823 \end{code}
 824
 825 \begin{code}
 826 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnM ()
 827
 828 checkPrecMatch False fn match
 829   = returnM ()
 830
 831 checkPrecMatch True op (Match (p1:p2:_) _ _)
 832         -- True indicates an infix lhs
 833   = getModeRn           `thenM` \ mode ->
 834         -- See comments with rnExpr (OpApp ...)
 835     if isInterfaceMode mode
 836         then returnM ()
 837         else checkPrec op p1 False      `thenM_`
 838              checkPrec op p2 True
 839
 840 checkPrecMatch True op _ = panic "checkPrecMatch"
 841
 842 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
 843   = lookupFixityRn op   `thenM` \  op_fix@(Fixity op_prec  op_dir) ->
 844     lookupFixityRn op1  `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
 845     let
 846         inf_ok = op1_prec > op_prec ||
 847                  (op1_prec == op_prec &&
 848                   (op1_dir == InfixR && op_dir == InfixR && right ||
 849                    op1_dir == InfixL && op_dir == InfixL && not right))
 850
 851         info  = (ppr_op op,  op_fix)
 852         info1 = (ppr_op op1, op1_fix)
 853         (infol, infor) = if right then (info, info1) else (info1, info)
 854     in
 855     checkErr inf_ok (precParseErr infol infor)
 856
 857 checkPrec op pat right
 858   = returnM ()
 859
 860 -- Check precedence of (arg op) or (op arg) respectively
 861 -- If arg is itself an operator application, then either
 862 --   (a) its precedence must be higher than that of op
 863 --   (b) its precedency & associativity must be the same as that of op
 864 checkSectionPrec direction section op arg
 865   = case arg of
 866         OpApp _ op fix _ -> go_for_it (ppr_op op)     fix
 867         NegApp _ _       -> go_for_it pp_prefix_minus negateFixity
 868         other            -> returnM ()
 869   where
 870     HsVar op_name = op
 871     go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
 872         = lookupFixityRn op_name        `thenM` \ op_fix@(Fixity op_prec _) ->
 873           checkErr (op_prec < arg_prec
 874                      || op_prec == arg_prec && direction == assoc)
 875                   (sectionPrecErr (ppr_op op_name, op_fix)
 876                   (pp_arg_op, arg_fix) section)
 877 \end{code}
 878
 879
 880 %************************************************************************
 881 %*                                                                      *
 882 \subsubsection{Assertion utils}
 883 %*                                                                      *
 884 %************************************************************************
 885
 886 \begin{code}
 887 mkAssertErrorExpr :: RnM (RenamedHsExpr, FreeVars)
 888 -- Return an expression for (assertError "Foo.hs:27")
 889 mkAssertErrorExpr
 890   = getSrcLocM                          `thenM` \ sloc ->
 891     let
 892         expr = HsApp (HsVar assertErrorName) (HsLit msg)
 893         msg  = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
 894     in
 895     returnM (expr, unitFV assertErrorName)
 896 \end{code}
 897
 898 %************************************************************************
 899 %*                                                                      *
 900 \subsubsection{Errors}
 901 %*                                                                      *
 902 %************************************************************************
 903
 904 \begin{code}
 905 ppr_op op = quotes (ppr op)     -- Here, op can be a Name or a (Var n), where n is a Name
 906 pp_prefix_minus = ptext SLIT("prefix `-'")
 907
 908 nonStdGuardErr guard
 909   = hang (ptext
 910     SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
 911     ) 4 (ppr guard)
 912
 913 patSynErr e
 914   = sep [ptext SLIT("Pattern syntax in expression context:"),
 915          nest 4 (ppr e)]
 916
 917 doStmtListErr do_or_lc e
 918   = sep [quotes (text binder_name) <+> ptext SLIT("statements must end in expression:"),
 919          nest 4 (ppr e)]
 920   where
 921     binder_name = case do_or_lc of
 922                         MDoExpr -> "mdo"
 923                         other   -> "do"
 924
 925 thErr what
 926   = ptext SLIT("Template Haskell") <+> text what <+>
 927     ptext SLIT("illegal in a stage-1 compiler")
 928
 929
 930 withWarning
 931   = sep [quotes (ptext SLIT("with")),
 932          ptext SLIT("is deprecated, use"),
 933          quotes (ptext SLIT("let")),
 934          ptext SLIT("instead")]
 935 \end{code}