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