ghc/compiler/rename/RnExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[RnExpr]{Renaming of expressions}
   5
   6 Basically dependency analysis.
   7
   8 Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In
   9 general, all of these functions return a renamed thing, and a set of
  10 free variables.
  11
  12 \begin{code}
  13 module RnExpr (
  14         rnMatch, rnGRHSs, rnExpr, rnExprs, rnStmts,
  15         checkPrecMatch
  16    ) where
  17
  18 #include "HsVersions.h"
  19
  20 import {-# SOURCE #-} RnSource  ( rnSrcDecls, rnBindsAndThen, rnBinds )
  21
  22 --      RnSource imports RnBinds.rnTopMonoBinds, RnExpr.rnExpr
  23 --      RnBinds  imports RnExpr.rnMatch, etc
  24 --      RnExpr   imports [boot] RnSource.rnSrcDecls, RnSource.rnBinds
  25
  26 import HsSyn
  27 import RdrHsSyn
  28 import RnHsSyn
  29 import TcRnMonad
  30 import RnEnv
  31 import RnNames          ( importsFromLocalDecls )
  32 import RnTypes          ( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen,
  33                           dupFieldErr, precParseErr, sectionPrecErr, patSigErr, checkTupSize )
  34 import CmdLineOpts      ( DynFlag(..), opt_IgnoreAsserts )
  35 import BasicTypes       ( Fixity(..), FixityDirection(..), IPName(..),
  36                           defaultFixity, negateFixity, compareFixity )
  37 import PrelNames        ( hasKey, assertIdKey,
  38                           foldrName, buildName,
  39                           cCallableClassName, cReturnableClassName,
  40                           enumClassName,
  41                           splitName, fstName, sndName, ioDataConName,
  42                           replicatePName, mapPName, filterPName,
  43                           crossPName, zipPName, toPName,
  44                           enumFromToPName, enumFromThenToPName, assertErrorName,
  45                           negateName, monadNames, mfixName )
  46 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     bindPatSigTyVarsFV 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 bindPatSigTyVarsFV 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 -- Don't ifdef-GHCI them because we want to fail gracefully
 228 -- (not with an rnExpr crash) in a stage-1 compiler.
 229 rnExpr e@(HsBracket br_body loc)
 230   = addSrcLoc loc               $
 231     checkTH e "bracket"         `thenM_`
 232     rnBracket br_body           `thenM` \ (body', fvs_e) ->
 233     returnM (HsBracket body' loc, fvs_e `plusFV` thProxyName)
 234
 235 rnExpr e@(HsSplice n splice loc)
 236   = addSrcLoc loc               $
 237     checkTH e "splice"          `thenM_`
 238     newLocalsRn [(n,loc)]       `thenM` \ [n'] ->
 239     rnExpr splice               `thenM` \ (splice', fvs_e) ->
 240     returnM (HsSplice n' splice' loc, fvs_e `plusFV` thProxyName)
 241
 242 rnExpr e@(HsReify (Reify flavour name))
 243   = checkTH e "reify"           `thenM_`
 244     lookupGlobalOccRn name      `thenM` \ name' ->
 245         -- For now, we can only reify top-level things
 246     returnM (HsReify (Reify flavour name'), unitFV name' `plusFV` thProxyName)
 247
 248 rnExpr section@(SectionL expr op)
 249   = rnExpr expr                                 `thenM` \ (expr', fvs_expr) ->
 250     rnExpr op                                   `thenM` \ (op', fvs_op) ->
 251     checkSectionPrec InfixL section op' expr' `thenM_`
 252     returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
 253
 254 rnExpr section@(SectionR op expr)
 255   = rnExpr op                                   `thenM` \ (op',   fvs_op) ->
 256     rnExpr expr                                 `thenM` \ (expr', fvs_expr) ->
 257     checkSectionPrec InfixR section op' expr'   `thenM_`
 258     returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
 259
 260 rnExpr (HsCCall fun args may_gc is_casm _)
 261         -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
 262   = rnExprs args                                `thenM` \ (args', fvs_args) ->
 263     returnM (HsCCall fun args' may_gc is_casm placeHolderType,
 264               fvs_args `plusFV` mkFVs [cCallableClassName,
 265                                        cReturnableClassName,
 266                                        ioDataConName])
 267
 268 rnExpr (HsCoreAnn ann expr)
 269   = rnExpr expr `thenM` \ (expr', fvs_expr) ->
 270     returnM (HsCoreAnn ann expr', fvs_expr)
 271
 272 rnExpr (HsSCC lbl expr)
 273   = rnExpr expr         `thenM` \ (expr', fvs_expr) ->
 274     returnM (HsSCC lbl expr', fvs_expr)
 275
 276 rnExpr (HsCase expr ms src_loc)
 277   = addSrcLoc src_loc $
 278     rnExpr expr                         `thenM` \ (new_expr, e_fvs) ->
 279     mapFvRn (rnMatch CaseAlt) ms        `thenM` \ (new_ms, ms_fvs) ->
 280     returnM (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
 281
 282 rnExpr (HsLet binds expr)
 283   = rnBindsAndThen binds        $ \ binds' ->
 284     rnExpr expr                  `thenM` \ (expr',fvExpr) ->
 285     returnM (HsLet binds' expr', fvExpr)
 286
 287 rnExpr e@(HsDo do_or_lc stmts _ _ src_loc)
 288   = addSrcLoc src_loc $
 289     rnStmts do_or_lc stmts              `thenM` \ (stmts', fvs) ->
 290
 291         -- Check the statement list ends in an expression
 292     case last stmts' of {
 293         ResultStmt _ _ -> returnM () ;
 294         _              -> addErr (doStmtListErr do_or_lc e)
 295     }                                   `thenM_`
 296
 297         -- Generate the rebindable syntax for the monad
 298     mapAndUnzipM lookupSyntaxName
 299          (syntax_names do_or_lc)        `thenM` \ (monad_names', monad_fvs) ->
 300
 301     returnM (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc,
 302              fvs `plusFV` implicit_fvs do_or_lc `plusFV` plusFVs monad_fvs)
 303   where
 304     implicit_fvs PArrComp = mkFVs [replicatePName, mapPName, filterPName, crossPName, zipPName]
 305     implicit_fvs ListComp = mkFVs [foldrName, buildName]
 306     implicit_fvs DoExpr   = emptyFVs
 307     implicit_fvs MDoExpr  = emptyFVs
 308
 309     syntax_names DoExpr  = monadNames
 310     syntax_names MDoExpr = monadNames ++ [mfixName]
 311     syntax_names other   = []
 312
 313 rnExpr (ExplicitList _ exps)
 314   = rnExprs exps                        `thenM` \ (exps', fvs) ->
 315     returnM  (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
 316
 317 rnExpr (ExplicitPArr _ exps)
 318   = rnExprs exps                        `thenM` \ (exps', fvs) ->
 319     returnM  (ExplicitPArr placeHolderType exps',
 320                fvs `addOneFV` toPName `addOneFV` parrTyCon_name)
 321
 322 rnExpr e@(ExplicitTuple exps boxity)
 323   = checkTupSize tup_size                       `thenM_`
 324     rnExprs exps                                `thenM` \ (exps', fvs) ->
 325     returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
 326   where
 327     tup_size   = length exps
 328     tycon_name = tupleTyCon_name boxity tup_size
 329
 330 rnExpr (RecordCon con_id rbinds)
 331   = lookupOccRn con_id                  `thenM` \ conname ->
 332     rnRbinds "construction" rbinds      `thenM` \ (rbinds', fvRbinds) ->
 333     returnM (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
 334
 335 rnExpr (RecordUpd expr rbinds)
 336   = rnExpr expr                 `thenM` \ (expr', fvExpr) ->
 337     rnRbinds "update" rbinds    `thenM` \ (rbinds', fvRbinds) ->
 338     returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
 339
 340 rnExpr (ExprWithTySig expr pty)
 341   = rnExpr expr                 `thenM` \ (expr', fvExpr) ->
 342     rnHsTypeFVs doc pty         `thenM` \ (pty', fvTy) ->
 343     returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
 344   where
 345     doc = text "In an expression type signature"
 346
 347 rnExpr (HsIf p b1 b2 src_loc)
 348   = addSrcLoc src_loc $
 349     rnExpr p            `thenM` \ (p', fvP) ->
 350     rnExpr b1           `thenM` \ (b1', fvB1) ->
 351     rnExpr b2           `thenM` \ (b2', fvB2) ->
 352     returnM (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
 353
 354 rnExpr (HsType a)
 355   = rnHsTypeFVs doc a   `thenM` \ (t, fvT) ->
 356     returnM (HsType t, fvT)
 357   where
 358     doc = text "In a type argument"
 359
 360 rnExpr (ArithSeqIn seq)
 361   = rnArithSeq seq       `thenM` \ (new_seq, fvs) ->
 362     returnM (ArithSeqIn new_seq, fvs `addOneFV` enumClassName)
 363
 364 rnExpr (PArrSeqIn seq)
 365   = rnArithSeq seq       `thenM` \ (new_seq, fvs) ->
 366     returnM (PArrSeqIn new_seq,
 367              fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName])
 368 \end{code}
 369
 370 These three are pattern syntax appearing in expressions.
 371 Since all the symbols are reservedops we can simply reject them.
 372 We return a (bogus) EWildPat in each case.
 373
 374 \begin{code}
 375 rnExpr e@EWildPat = addErr (patSynErr e)        `thenM_`
 376                     returnM (EWildPat, emptyFVs)
 377
 378 rnExpr e@(EAsPat _ _) = addErr (patSynErr e)    `thenM_`
 379                         returnM (EWildPat, emptyFVs)
 380
 381 rnExpr e@(ELazyPat _) = addErr (patSynErr e)    `thenM_`
 382                         returnM (EWildPat, emptyFVs)
 383 \end{code}
 384
 385 %************************************************************************
 386 %*                                                                      *
 387         Arithmetic sequences
 388 %*                                                                      *
 389 %************************************************************************
 390
 391 \begin{code}
 392 rnArithSeq (From expr)
 393  = rnExpr expr  `thenM` \ (expr', fvExpr) ->
 394    returnM (From expr', fvExpr)
 395
 396 rnArithSeq (FromThen expr1 expr2)
 397  = rnExpr expr1         `thenM` \ (expr1', fvExpr1) ->
 398    rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
 399    returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 400
 401 rnArithSeq (FromTo expr1 expr2)
 402  = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
 403    rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
 404    returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 405
 406 rnArithSeq (FromThenTo expr1 expr2 expr3)
 407  = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
 408    rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
 409    rnExpr expr3 `thenM` \ (expr3', fvExpr3) ->
 410    returnM (FromThenTo expr1' expr2' expr3',
 411             plusFVs [fvExpr1, fvExpr2, fvExpr3])
 412 \end{code}
 413
 414
 415 %************************************************************************
 416 %*                                                                      *
 417 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
 418 %*                                                                      *
 419 %************************************************************************
 420
 421 \begin{code}
 422 rnRbinds str rbinds
 423   = mappM_ field_dup_err dup_fields     `thenM_`
 424     mapFvRn rn_rbind rbinds             `thenM` \ (rbinds', fvRbind) ->
 425     returnM (rbinds', fvRbind)
 426   where
 427     (_, dup_fields) = removeDups compare [ f | (f,_) <- rbinds ]
 428
 429     field_dup_err dups = addErr (dupFieldErr str dups)
 430
 431     rn_rbind (field, expr)
 432       = lookupGlobalOccRn field `thenM` \ fieldname ->
 433         rnExpr expr             `thenM` \ (expr', fvExpr) ->
 434         returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname)
 435 \end{code}
 436
 437 %************************************************************************
 438 %*                                                                      *
 439         Template Haskell brackets
 440 %*                                                                      *
 441 %************************************************************************
 442
 443 \begin{code}
 444 rnBracket (ExpBr e) = rnExpr e          `thenM` \ (e', fvs) ->
 445                       returnM (ExpBr e', fvs)
 446 rnBracket (PatBr p) = rnPat p           `thenM` \ (p', fvs) ->
 447                       returnM (PatBr p', fvs)
 448 rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
 449                       returnM (TypBr t', fvs)
 450                     where
 451                       doc = ptext SLIT("In a Template-Haskell quoted type")
 452 rnBracket (DecBr group)
 453   = importsFromLocalDecls group `thenM` \ (rdr_env, avails) ->
 454         -- Discard avails (not useful here)
 455
 456     updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $
 457
 458     rnSrcDecls group    `thenM` \ (tcg_env, group', dus) ->
 459         -- Discard the tcg_env; it contains only extra info about fixity
 460
 461     returnM (DecBr group', duUses dus `minusNameSet` duDefs dus)
 462 \end{code}
 463
 464 %************************************************************************
 465 %*                                                                      *
 466 \subsubsection{@Stmt@s: in @do@ expressions}
 467 %*                                                                      *
 468 %************************************************************************
 469
 470 \begin{code}
 471 rnStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
 472
 473 rnStmts MDoExpr stmts = rnMDoStmts         stmts
 474 rnStmts ctxt   stmts  = rnNormalStmts ctxt stmts
 475
 476 rnNormalStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
 477 -- Used for cases *other* than recursive mdo
 478 -- Implements nested scopes
 479
 480 rnNormalStmts ctxt [] = returnM ([], emptyFVs)
 481         -- Happens at the end of the sub-lists of a ParStmts
 482
 483 rnNormalStmts ctxt (ExprStmt expr _ src_loc : stmts)
 484   = addSrcLoc src_loc           $
 485     rnExpr expr                 `thenM` \ (expr', fv_expr) ->
 486     rnNormalStmts ctxt stmts    `thenM` \ (stmts', fvs) ->
 487     returnM (ExprStmt expr' placeHolderType src_loc : stmts',
 488              fv_expr `plusFV` fvs)
 489
 490 rnNormalStmts ctxt [ResultStmt expr src_loc]
 491   = addSrcLoc src_loc   $
 492     rnExpr expr         `thenM` \ (expr', fv_expr) ->
 493     returnM ([ResultStmt expr' src_loc], fv_expr)
 494
 495 rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts)
 496   = addSrcLoc src_loc                   $
 497     rnExpr expr                         `thenM` \ (expr', fv_expr) ->
 498         -- The binders do not scope over the expression
 499
 500     rnPatsAndThen (StmtCtxt ctxt) [pat] $ \ [pat'] ->
 501     rnNormalStmts ctxt stmts            `thenM` \ (stmts', fvs) ->
 502     returnM (BindStmt pat' expr' src_loc : stmts',
 503              fv_expr `plusFV` fvs)      -- fv_expr shouldn't really be filtered by
 504                                         -- the rnPatsAndThen, but it does not matter
 505
 506 rnNormalStmts ctxt (LetStmt binds : stmts)
 507   = checkErr (ok ctxt binds) (badIpBinds binds) `thenM_`
 508     rnBindsAndThen binds                        ( \ binds' ->
 509     rnNormalStmts ctxt stmts                    `thenM` \ (stmts', fvs) ->
 510     returnM (LetStmt binds' : stmts', fvs))
 511   where
 512         -- We do not allow implicit-parameter bindings in a parallel
 513         -- list comprehension.  I'm not sure what it might mean.
 514     ok (ParStmtCtxt _) (IPBinds _ _) = False
 515     ok _               _             = True
 516
 517 rnNormalStmts ctxt (ParStmt stmtss : stmts)
 518   = doptM Opt_GlasgowExts               `thenM` \ opt_GlasgowExts ->
 519     checkM opt_GlasgowExts parStmtErr   `thenM_`
 520     mapFvRn (rnNormalStmts (ParStmtCtxt ctxt)) stmtss   `thenM` \ (stmtss', fv_stmtss) ->
 521     let
 522         bndrss = map collectStmtsBinders stmtss'
 523     in
 524     foldlM checkBndrs [] bndrss         `thenM` \ new_binders ->
 525     bindLocalNamesFV new_binders        $
 526         -- Note: binders are returned in scope order, so one may
 527         --       shadow the next; e.g. x <- xs; x <- ys
 528     rnNormalStmts ctxt stmts                    `thenM` \ (stmts', fvs) ->
 529     returnM (ParStmtOut (bndrss `zip` stmtss') : stmts',
 530              fv_stmtss `plusFV` fvs)
 531
 532   where
 533     checkBndrs all_bndrs bndrs
 534           = checkErr (null common) (err (head common)) `thenM_`
 535             returnM (bndrs ++ all_bndrs)
 536         where
 537           common = intersectBy eqOcc all_bndrs bndrs
 538
 539     eqOcc n1 n2 = nameOccName n1 == nameOccName n2
 540     err v = ptext SLIT("Duplicate binding in parallel list comprehension for:")
 541             <+> quotes (ppr v)
 542
 543 rnNormalStmts ctxt stmts = pprPanic "rnNormalStmts" (ppr stmts)
 544 \end{code}
 545
 546
 547 %************************************************************************
 548 %*                                                                      *
 549 \subsubsection{Precedence Parsing}
 550 %*                                                                      *
 551 %************************************************************************
 552
 553 \begin{code}
 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', du_binds) ->
 624     returnM (duDefs du_binds, duUses du_binds,
 625              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 do_or_lc e
 910   = sep [quotes (text binder_name) <+> ptext SLIT("statements must end in expression:"),
 911          nest 4 (ppr e)]
 912   where
 913     binder_name = case do_or_lc of
 914                         MDoExpr -> "mdo"
 915                         other   -> "do"
 916
 917 #ifdef GHCI
 918 checkTH e what = returnM ()     -- OK
 919 #else
 920 checkTH e what  -- Raise an error in a stage-1 compiler
 921   = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
 922                   ptext SLIT("illegal in a stage-1 compiler"),
 923                   nest 2 (ppr e)])
 924 #endif
 925
 926 parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglagow-exts"))
 927
 928 badIpBinds binds
 929   = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4
 930          (ppr binds)
 931 \end{code}