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