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 "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 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   = rnBindsAndThen binds                $ \ binds' ->
 511     rnNormalStmts ctxt stmts            `thenM` \ (stmts', fvs) ->
 512     returnM (LetStmt binds' : stmts', fvs)
 513
 514 rnNormalStmts ctxt (ParStmt stmtss : stmts)
 515   = mapFvRn (rnNormalStmts ctxt) stmtss `thenM` \ (stmtss', fv_stmtss) ->
 516     let
 517         bndrss = map collectStmtsBinders stmtss'
 518     in
 519     foldlM checkBndrs [] bndrss         `thenM` \ new_binders ->
 520     bindLocalNamesFV new_binders        $
 521         -- Note: binders are returned in scope order, so one may
 522         --       shadow the next; e.g. x <- xs; x <- ys
 523     rnNormalStmts ctxt stmts                    `thenM` \ (stmts', fvs) ->
 524     returnM (ParStmtOut (bndrss `zip` stmtss') : stmts',
 525              fv_stmtss `plusFV` fvs)
 526
 527   where
 528     checkBndrs all_bndrs bndrs
 529           = checkErr (null common) (err (head common)) `thenM_`
 530             returnM (bndrs ++ all_bndrs)
 531         where
 532           common = intersectBy eqOcc all_bndrs bndrs
 533
 534     eqOcc n1 n2 = nameOccName n1 == nameOccName n2
 535     err v = ptext SLIT("Duplicate binding in parallel list comprehension for:")
 536             <+> quotes (ppr v)
 537
 538 rnNormalStmts ctxt stmts = pprPanic "rnNormalStmts" (ppr stmts)
 539 \end{code}
 540
 541
 542 %************************************************************************
 543 %*                                                                      *
 544 \subsubsection{Precedence Parsing}
 545 %*                                                                      *
 546 %************************************************************************
 547
 548 \begin{code}
 549 type Defs    = NameSet
 550 type Uses    = NameSet  -- Same as FreeVars really
 551 type FwdRefs = NameSet
 552 type Segment = (Defs,
 553                 Uses,           -- May include defs
 554                 FwdRefs,        -- A subset of uses that are
 555                                 --   (a) used before they are bound in this segment, or
 556                                 --   (b) used here, and bound in subsequent segments
 557                 [RenamedStmt])
 558
 559 ----------------------------------------------------
 560 rnMDoStmts :: [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
 561 rnMDoStmts stmts
 562   =     -- Step1: bring all the binders of the mdo into scope
 563     bindLocalsRn doc (collectStmtsBinders stmts)        $ \ _ ->
 564
 565         -- Step 2: Rename each individual stmt, making a
 566         --         singleton segment.  At this stage the FwdRefs field
 567         --         isn't finished: it's empty for all except a BindStmt
 568         --         for which it's the fwd refs within the bind itself
 569     mappM rn_mdo_stmt stmts                             `thenM` \ segs ->
 570     let
 571         -- Step 3: Fill in the fwd refs.
 572         --         The segments are all singletons, but their fwd-ref
 573         --         field mentions all the things used by the segment
 574         --         that are bound after their use
 575         segs_w_fwd_refs = addFwdRefs segs
 576
 577         -- Step 4: Group together the segments to make bigger segments
 578         --         Invariant: in the result, no segment uses a variable
 579         --                    bound in a later segment
 580         grouped_segs = glomSegments segs_w_fwd_refs
 581
 582         -- Step 5: Turn the segments into Stmts
 583         --         Use RecStmt when and only when there are fwd refs
 584         --         Also gather up the uses from the end towards the
 585         --         start, so we can tell the RecStmt which things are
 586         --         used 'after' the RecStmt
 587         stmts_w_fvs = segsToStmts grouped_segs
 588     in
 589     returnM stmts_w_fvs
 590   where
 591     doc = text "In a mdo-expression"
 592
 593 ----------------------------------------------------
 594 rn_mdo_stmt :: RdrNameStmt -> RnM Segment
 595         -- Assumes all binders are already in scope
 596         -- Turns each stmt into a singleton Stmt
 597
 598 rn_mdo_stmt (ExprStmt expr _ src_loc)
 599   = addSrcLoc src_loc (rnExpr expr)     `thenM` \ (expr', fvs) ->
 600     returnM (emptyNameSet, fvs, emptyNameSet,
 601              [ExprStmt expr' placeHolderType src_loc])
 602
 603 rn_mdo_stmt (ResultStmt expr src_loc)
 604   = addSrcLoc src_loc (rnExpr expr)     `thenM` \ (expr', fvs) ->
 605     returnM (emptyNameSet, fvs, emptyNameSet,
 606              [ResultStmt expr' src_loc])
 607
 608 rn_mdo_stmt (BindStmt pat expr src_loc)
 609   = addSrcLoc src_loc   $
 610     rnExpr expr         `thenM` \ (expr', fv_expr) ->
 611     rnPat pat           `thenM` \ (pat', fv_pat) ->
 612     let
 613         bndrs = mkNameSet (collectPatBinders pat')
 614         fvs   = fv_expr `plusFV` fv_pat
 615     in
 616     returnM (bndrs, fvs, bndrs `intersectNameSet` fvs,
 617              [BindStmt pat' expr' src_loc])
 618
 619 rn_mdo_stmt (LetStmt binds)
 620   = rnBinds binds               `thenM` \ (binds', fv_binds) ->
 621     returnM (mkNameSet (collectHsBinders binds'),
 622              fv_binds, emptyNameSet, [LetStmt binds'])
 623
 624 rn_mdo_stmt stmt@(ParStmt _)    -- Syntactically illegal in mdo
 625   = pprPanic "rn_mdo_stmt" (ppr stmt)
 626
 627
 628 addFwdRefs :: [Segment] -> [Segment]
 629 -- So far the segments only have forward refs *within* the Stmt
 630 --      (which happens for bind:  x <- ...x...)
 631 -- This function adds the cross-seg fwd ref info
 632
 633 addFwdRefs pairs
 634   = fst (foldr mk_seg ([], emptyNameSet) pairs)
 635   where
 636     mk_seg (defs, uses, fwds, stmts) (segs, seg_defs)
 637         = (new_seg : segs, all_defs)
 638         where
 639           new_seg = (defs, uses, new_fwds, stmts)
 640           all_defs = seg_defs `unionNameSets` defs
 641           new_fwds = fwds `unionNameSets` (uses `intersectNameSet` seg_defs)
 642                 -- Add the downstream fwd refs here
 643
 644 ----------------------------------------------------
 645 --      Glomming the singleton segments of an mdo into
 646 --      minimal recursive groups.
 647 --
 648 -- At first I thought this was just strongly connected components, but
 649 -- there's an important constraint: the order of the stmts must not change.
 650 --
 651 -- Consider
 652 --      mdo { x <- ...y...
 653 --            p <- z
 654 --            y <- ...x...
 655 --            q <- x
 656 --            z <- y
 657 --            r <- x }
 658 --
 659 -- Here, the first stmt mention 'y', which is bound in the third.
 660 -- But that means that the innocent second stmt (p <- z) gets caught
 661 -- up in the recursion.  And that in turn means that the binding for
 662 -- 'z' has to be included... and so on.
 663 --
 664 -- Start at the tail { r <- x }
 665 -- Now add the next one { z <- y ; r <- x }
 666 -- Now add one more     { q <- x ; z <- y ; r <- x }
 667 -- Now one more... but this time we have to group a bunch into rec
 668 --      { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
 669 -- Now one more, which we can add on without a rec
 670 --      { p <- z ;
 671 --        rec { y <- ...x... ; q <- x ; z <- y } ;
 672 --        r <- x }
 673 -- Finally we add the last one; since it mentions y we have to
 674 -- glom it togeher with the first two groups
 675 --      { rec { x <- ...y...; p <- z ; y <- ...x... ;
 676 --              q <- x ; z <- y } ;
 677 --        r <- x }
 678
 679 glomSegments :: [Segment] -> [Segment]
 680
 681 glomSegments [seg] = [seg]
 682 glomSegments ((defs,uses,fwds,stmts) : segs)
 683         -- Actually stmts will always be a singleton
 684   = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others
 685   where
 686     segs'            = glomSegments segs
 687     (extras, others) = grab uses segs'
 688     (ds, us, fs, ss) = unzip4 extras
 689
 690     seg_defs  = plusFVs ds `plusFV` defs
 691     seg_uses  = plusFVs us `plusFV` uses
 692     seg_fwds  = plusFVs fs `plusFV` fwds
 693     seg_stmts = stmts ++ concat ss
 694
 695     grab :: NameSet             -- The client
 696          -> [Segment]
 697          -> ([Segment],         -- Needed by the 'client'
 698              [Segment])         -- Not needed by the client
 699         -- The result is simply a split of the input
 700     grab uses dus
 701         = (reverse yeses, reverse noes)
 702         where
 703           (noes, yeses)           = span not_needed (reverse dus)
 704           not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
 705
 706
 707 ----------------------------------------------------
 708 segsToStmts :: [Segment] -> ([RenamedStmt], FreeVars)
 709
 710 segsToStmts [] = ([], emptyFVs)
 711 segsToStmts ((defs, uses, fwds, ss) : segs)
 712   = (new_stmt : later_stmts, later_uses `plusFV` uses)
 713   where
 714     (later_stmts, later_uses) = segsToStmts segs
 715     new_stmt | non_rec   = head ss
 716              | otherwise = RecStmt rec_names ss
 717              where
 718                non_rec   = isSingleton ss && isEmptyNameSet fwds
 719                rec_names = nameSetToList (fwds `plusFV` (defs `intersectNameSet` later_uses))
 720                 -- The names for the fixpoint are
 721                 --      (a) the ones needed after the RecStmt
 722                 --      (b) the forward refs within the fixpoint
 723 \end{code}
 724
 725 %************************************************************************
 726 %*                                                                      *
 727 \subsubsection{Precedence Parsing}
 728 %*                                                                      *
 729 %************************************************************************
 730
 731 @mkOpAppRn@ deals with operator fixities.  The argument expressions
 732 are assumed to be already correctly arranged.  It needs the fixities
 733 recorded in the OpApp nodes, because fixity info applies to the things
 734 the programmer actually wrote, so you can't find it out from the Name.
 735
 736 Furthermore, the second argument is guaranteed not to be another
 737 operator application.  Why? Because the parser parses all
 738 operator appications left-associatively, EXCEPT negation, which
 739 we need to handle specially.
 740
 741 \begin{code}
 742 mkOpAppRn :: RenamedHsExpr                      -- Left operand; already rearranged
 743           -> RenamedHsExpr -> Fixity            -- Operator and fixity
 744           -> RenamedHsExpr                      -- Right operand (not an OpApp, but might
 745                                                 -- be a NegApp)
 746           -> RnM RenamedHsExpr
 747
 748 ---------------------------
 749 -- (e11 `op1` e12) `op2` e2
 750 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
 751   | nofix_error
 752   = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))   `thenM_`
 753     returnM (OpApp e1 op2 fix2 e2)
 754
 755   | associate_right
 756   = mkOpAppRn e12 op2 fix2 e2           `thenM` \ new_e ->
 757     returnM (OpApp e11 op1 fix1 new_e)
 758   where
 759     (nofix_error, associate_right) = compareFixity fix1 fix2
 760
 761 ---------------------------
 762 --      (- neg_arg) `op` e2
 763 mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2
 764   | nofix_error
 765   = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2))      `thenM_`
 766     returnM (OpApp e1 op2 fix2 e2)
 767
 768   | associate_right
 769   = mkOpAppRn neg_arg op2 fix2 e2       `thenM` \ new_e ->
 770     returnM (NegApp new_e neg_name)
 771   where
 772     (nofix_error, associate_right) = compareFixity negateFixity fix2
 773
 774 ---------------------------
 775 --      e1 `op` - neg_arg
 776 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _)     -- NegApp can occur on the right
 777   | not associate_right                         -- We *want* right association
 778   = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity))    `thenM_`
 779     returnM (OpApp e1 op1 fix1 e2)
 780   where
 781     (_, associate_right) = compareFixity fix1 negateFixity
 782
 783 ---------------------------
 784 --      Default case
 785 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
 786   = ASSERT2( right_op_ok fix e2,
 787              ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
 788     )
 789     returnM (OpApp e1 op fix e2)
 790
 791 -- Parser left-associates everything, but
 792 -- derived instances may have correctly-associated things to
 793 -- in the right operarand.  So we just check that the right operand is OK
 794 right_op_ok fix1 (OpApp _ _ fix2 _)
 795   = not error_please && associate_right
 796   where
 797     (error_please, associate_right) = compareFixity fix1 fix2
 798 right_op_ok fix1 other
 799   = True
 800
 801 -- Parser initially makes negation bind more tightly than any other operator
 802 mkNegAppRn neg_arg neg_name
 803   =
 804 #ifdef DEBUG
 805     getModeRn                   `thenM` \ mode ->
 806     ASSERT( not_op_app mode neg_arg )
 807 #endif
 808     returnM (NegApp neg_arg neg_name)
 809
 810 not_op_app SourceMode (OpApp _ _ _ _) = False
 811 not_op_app mode other                 = True
 812 \end{code}
 813
 814 \begin{code}
 815 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnM ()
 816
 817 checkPrecMatch False fn match
 818   = returnM ()
 819
 820 checkPrecMatch True op (Match (p1:p2:_) _ _)
 821         -- True indicates an infix lhs
 822   = getModeRn           `thenM` \ mode ->
 823         -- See comments with rnExpr (OpApp ...)
 824     if isInterfaceMode mode
 825         then returnM ()
 826         else checkPrec op p1 False      `thenM_`
 827              checkPrec op p2 True
 828
 829 checkPrecMatch True op _ = panic "checkPrecMatch"
 830
 831 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
 832   = lookupFixityRn op   `thenM` \  op_fix@(Fixity op_prec  op_dir) ->
 833     lookupFixityRn op1  `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
 834     let
 835         inf_ok = op1_prec > op_prec ||
 836                  (op1_prec == op_prec &&
 837                   (op1_dir == InfixR && op_dir == InfixR && right ||
 838                    op1_dir == InfixL && op_dir == InfixL && not right))
 839
 840         info  = (ppr_op op,  op_fix)
 841         info1 = (ppr_op op1, op1_fix)
 842         (infol, infor) = if right then (info, info1) else (info1, info)
 843     in
 844     checkErr inf_ok (precParseErr infol infor)
 845
 846 checkPrec op pat right
 847   = returnM ()
 848
 849 -- Check precedence of (arg op) or (op arg) respectively
 850 -- If arg is itself an operator application, then either
 851 --   (a) its precedence must be higher than that of op
 852 --   (b) its precedency & associativity must be the same as that of op
 853 checkSectionPrec direction section op arg
 854   = case arg of
 855         OpApp _ op fix _ -> go_for_it (ppr_op op)     fix
 856         NegApp _ _       -> go_for_it pp_prefix_minus negateFixity
 857         other            -> returnM ()
 858   where
 859     HsVar op_name = op
 860     go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
 861         = lookupFixityRn op_name        `thenM` \ op_fix@(Fixity op_prec _) ->
 862           checkErr (op_prec < arg_prec
 863                      || op_prec == arg_prec && direction == assoc)
 864                   (sectionPrecErr (ppr_op op_name, op_fix)
 865                   (pp_arg_op, arg_fix) section)
 866 \end{code}
 867
 868
 869 %************************************************************************
 870 %*                                                                      *
 871 \subsubsection{Assertion utils}
 872 %*                                                                      *
 873 %************************************************************************
 874
 875 \begin{code}
 876 mkAssertErrorExpr :: RnM (RenamedHsExpr, FreeVars)
 877 -- Return an expression for (assertError "Foo.hs:27")
 878 mkAssertErrorExpr
 879   = getSrcLocM                          `thenM` \ sloc ->
 880     let
 881         expr = HsApp (HsVar assertErrorName) (HsLit msg)
 882         msg  = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
 883     in
 884     returnM (expr, unitFV assertErrorName)
 885 \end{code}
 886
 887 %************************************************************************
 888 %*                                                                      *
 889 \subsubsection{Errors}
 890 %*                                                                      *
 891 %************************************************************************
 892
 893 \begin{code}
 894 ppr_op op = quotes (ppr op)     -- Here, op can be a Name or a (Var n), where n is a Name
 895 pp_prefix_minus = ptext SLIT("prefix `-'")
 896
 897 nonStdGuardErr guard
 898   = hang (ptext
 899     SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
 900     ) 4 (ppr guard)
 901
 902 patSynErr e
 903   = sep [ptext SLIT("Pattern syntax in expression context:"),
 904          nest 4 (ppr e)]
 905
 906 doStmtListErr name e
 907   = sep [quotes (text name) <+> ptext SLIT("statements must end in expression:"),
 908          nest 4 (ppr e)]
 909
 910 thErr what
 911   = ptext SLIT("Template Haskell") <+> text what <+>
 912     ptext SLIT("illegal in a stage-1 compiler")
 913
 914
 915 withWarning
 916   = sep [quotes (ptext SLIT("with")),
 917          ptext SLIT("is deprecated, use"),
 918          quotes (ptext SLIT("let")),
 919          ptext SLIT("instead")]
 920 \end{code}