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