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