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     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 -- 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 (HsSCC lbl expr)
 269   = rnExpr expr         `thenM` \ (expr', fvs_expr) ->
 270     returnM (HsSCC lbl expr', fvs_expr)
 271
 272 rnExpr (HsCase expr ms src_loc)
 273   = addSrcLoc src_loc $
 274     rnExpr expr                         `thenM` \ (new_expr, e_fvs) ->
 275     mapFvRn (rnMatch CaseAlt) ms        `thenM` \ (new_ms, ms_fvs) ->
 276     returnM (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs)
 277
 278 rnExpr (HsLet binds expr)
 279   = rnBindsAndThen binds        $ \ binds' ->
 280     rnExpr expr                  `thenM` \ (expr',fvExpr) ->
 281     returnM (HsLet binds' expr', fvExpr)
 282
 283 rnExpr e@(HsDo do_or_lc stmts _ _ src_loc)
 284   = addSrcLoc src_loc $
 285     rnStmts do_or_lc stmts              `thenM` \ (stmts', fvs) ->
 286
 287         -- Check the statement list ends in an expression
 288     case last stmts' of {
 289         ResultStmt _ _ -> returnM () ;
 290         _              -> addErr (doStmtListErr do_or_lc e)
 291     }                                   `thenM_`
 292
 293         -- Generate the rebindable syntax for the monad
 294     mapAndUnzipM lookupSyntaxName
 295          (syntax_names do_or_lc)        `thenM` \ (monad_names', monad_fvs) ->
 296
 297     returnM (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc,
 298              fvs `plusFV` implicit_fvs do_or_lc `plusFV` plusFVs monad_fvs)
 299   where
 300     implicit_fvs PArrComp = mkFVs [replicatePName, mapPName, filterPName, crossPName, zipPName]
 301     implicit_fvs ListComp = mkFVs [foldrName, buildName]
 302     implicit_fvs DoExpr   = emptyFVs
 303     implicit_fvs MDoExpr  = emptyFVs
 304
 305     syntax_names DoExpr  = monadNames
 306     syntax_names MDoExpr = monadNames ++ [mfixName]
 307     syntax_names other   = []
 308
 309 rnExpr (ExplicitList _ exps)
 310   = rnExprs exps                        `thenM` \ (exps', fvs) ->
 311     returnM  (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
 312
 313 rnExpr (ExplicitPArr _ exps)
 314   = rnExprs exps                        `thenM` \ (exps', fvs) ->
 315     returnM  (ExplicitPArr placeHolderType exps',
 316                fvs `addOneFV` toPName `addOneFV` parrTyCon_name)
 317
 318 rnExpr e@(ExplicitTuple exps boxity)
 319   = checkTupSize tup_size                       `thenM_`
 320     rnExprs exps                                `thenM` \ (exps', fvs) ->
 321     returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
 322   where
 323     tup_size   = length exps
 324     tycon_name = tupleTyCon_name boxity tup_size
 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         Template Haskell brackets
 436 %*                                                                      *
 437 %************************************************************************
 438
 439 \begin{code}
 440 rnBracket (ExpBr e) = rnExpr e          `thenM` \ (e', fvs) ->
 441                       returnM (ExpBr e', fvs)
 442 rnBracket (PatBr p) = rnPat p           `thenM` \ (p', fvs) ->
 443                       returnM (PatBr p', fvs)
 444 rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
 445                       returnM (TypBr t', fvs)
 446                     where
 447                       doc = ptext SLIT("In a Template-Haskell quoted type")
 448 rnBracket (DecBr group)
 449   = importsFromLocalDecls group `thenM` \ (rdr_env, avails) ->
 450         -- Discard avails (not useful here)
 451
 452     updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $
 453
 454     rnSrcDecls group    `thenM` \ (tcg_env, group', fvs) ->
 455         -- Discard the tcg_env; it contains only extra info about fixity
 456
 457     returnM (DecBr group', fvs)
 458 \end{code}
 459
 460 %************************************************************************
 461 %*                                                                      *
 462 \subsubsection{@Stmt@s: in @do@ expressions}
 463 %*                                                                      *
 464 %************************************************************************
 465
 466 \begin{code}
 467 rnStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
 468
 469 rnStmts MDoExpr stmts = rnMDoStmts         stmts
 470 rnStmts ctxt   stmts  = rnNormalStmts ctxt stmts
 471
 472 rnNormalStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
 473 -- Used for cases *other* than recursive mdo
 474 -- Implements nested scopes
 475
 476 rnNormalStmts ctxt [] = returnM ([], emptyFVs)
 477         -- Happens at the end of the sub-lists of a ParStmts
 478
 479 rnNormalStmts ctxt (ExprStmt expr _ src_loc : stmts)
 480   = addSrcLoc src_loc           $
 481     rnExpr expr                 `thenM` \ (expr', fv_expr) ->
 482     rnNormalStmts ctxt stmts    `thenM` \ (stmts', fvs) ->
 483     returnM (ExprStmt expr' placeHolderType src_loc : stmts',
 484              fv_expr `plusFV` fvs)
 485
 486 rnNormalStmts ctxt [ResultStmt expr src_loc]
 487   = addSrcLoc src_loc   $
 488     rnExpr expr         `thenM` \ (expr', fv_expr) ->
 489     returnM ([ResultStmt expr' src_loc], fv_expr)
 490
 491 rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts)
 492   = addSrcLoc src_loc                   $
 493     rnExpr expr                         `thenM` \ (expr', fv_expr) ->
 494         -- The binders do not scope over the expression
 495
 496     rnPatsAndThen (StmtCtxt ctxt) [pat] $ \ [pat'] ->
 497     rnNormalStmts ctxt stmts            `thenM` \ (stmts', fvs) ->
 498     returnM (BindStmt pat' expr' src_loc : stmts',
 499              fv_expr `plusFV` fvs)      -- fv_expr shouldn't really be filtered by
 500                                         -- the rnPatsAndThen, but it does not matter
 501
 502 rnNormalStmts ctxt (LetStmt binds : stmts)
 503   = checkErr (ok ctxt binds) (badIpBinds binds) `thenM_`
 504     rnBindsAndThen binds                        ( \ binds' ->
 505     rnNormalStmts ctxt stmts                    `thenM` \ (stmts', fvs) ->
 506     returnM (LetStmt binds' : stmts', fvs))
 507   where
 508         -- We do not allow implicit-parameter bindings in a parallel
 509         -- list comprehension.  I'm not sure what it might mean.
 510     ok (ParStmtCtxt _) (IPBinds _ _) = False
 511     ok _               _             = True
 512
 513 rnNormalStmts ctxt (ParStmt stmtss : stmts)
 514   = mapFvRn (rnNormalStmts (ParStmtCtxt ctxt)) stmtss   `thenM` \ (stmtss', fv_stmtss) ->
 515     let
 516         bndrss = map collectStmtsBinders stmtss'
 517     in
 518     foldlM checkBndrs [] bndrss         `thenM` \ new_binders ->
 519     bindLocalNamesFV new_binders        $
 520         -- Note: binders are returned in scope order, so one may
 521         --       shadow the next; e.g. x <- xs; x <- ys
 522     rnNormalStmts ctxt stmts                    `thenM` \ (stmts', fvs) ->
 523     returnM (ParStmtOut (bndrss `zip` stmtss') : stmts',
 524              fv_stmtss `plusFV` fvs)
 525
 526   where
 527     checkBndrs all_bndrs bndrs
 528           = checkErr (null common) (err (head common)) `thenM_`
 529             returnM (bndrs ++ all_bndrs)
 530         where
 531           common = intersectBy eqOcc all_bndrs bndrs
 532
 533     eqOcc n1 n2 = nameOccName n1 == nameOccName n2
 534     err v = ptext SLIT("Duplicate binding in parallel list comprehension for:")
 535             <+> quotes (ppr v)
 536
 537 rnNormalStmts ctxt stmts = pprPanic "rnNormalStmts" (ppr stmts)
 538 \end{code}
 539
 540
 541 %************************************************************************
 542 %*                                                                      *
 543 \subsubsection{Precedence Parsing}
 544 %*                                                                      *
 545 %************************************************************************
 546
 547 \begin{code}
 548 type Defs    = NameSet
 549 type Uses    = NameSet  -- Same as FreeVars really
 550 type FwdRefs = NameSet
 551 type Segment = (Defs,
 552                 Uses,           -- May include defs
 553                 FwdRefs,        -- A subset of uses that are
 554                                 --   (a) used before they are bound in this segment, or
 555                                 --   (b) used here, and bound in subsequent segments
 556                 [RenamedStmt])
 557
 558 ----------------------------------------------------
 559 rnMDoStmts :: [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
 560 rnMDoStmts stmts
 561   =     -- Step1: bring all the binders of the mdo into scope
 562     bindLocalsRn doc (collectStmtsBinders stmts)        $ \ _ ->
 563
 564         -- Step 2: Rename each individual stmt, making a
 565         --         singleton segment.  At this stage the FwdRefs field
 566         --         isn't finished: it's empty for all except a BindStmt
 567         --         for which it's the fwd refs within the bind itself
 568     mappM rn_mdo_stmt stmts                             `thenM` \ segs ->
 569     let
 570         -- Step 3: Fill in the fwd refs.
 571         --         The segments are all singletons, but their fwd-ref
 572         --         field mentions all the things used by the segment
 573         --         that are bound after their use
 574         segs_w_fwd_refs = addFwdRefs segs
 575
 576         -- Step 4: Group together the segments to make bigger segments
 577         --         Invariant: in the result, no segment uses a variable
 578         --                    bound in a later segment
 579         grouped_segs = glomSegments segs_w_fwd_refs
 580
 581         -- Step 5: Turn the segments into Stmts
 582         --         Use RecStmt when and only when there are fwd refs
 583         --         Also gather up the uses from the end towards the
 584         --         start, so we can tell the RecStmt which things are
 585         --         used 'after' the RecStmt
 586         stmts_w_fvs = segsToStmts grouped_segs
 587     in
 588     returnM stmts_w_fvs
 589   where
 590     doc = text "In a mdo-expression"
 591
 592 ----------------------------------------------------
 593 rn_mdo_stmt :: RdrNameStmt -> RnM Segment
 594         -- Assumes all binders are already in scope
 595         -- Turns each stmt into a singleton Stmt
 596
 597 rn_mdo_stmt (ExprStmt expr _ src_loc)
 598   = addSrcLoc src_loc (rnExpr expr)     `thenM` \ (expr', fvs) ->
 599     returnM (emptyNameSet, fvs, emptyNameSet,
 600              [ExprStmt expr' placeHolderType src_loc])
 601
 602 rn_mdo_stmt (ResultStmt expr src_loc)
 603   = addSrcLoc src_loc (rnExpr expr)     `thenM` \ (expr', fvs) ->
 604     returnM (emptyNameSet, fvs, emptyNameSet,
 605              [ResultStmt expr' src_loc])
 606
 607 rn_mdo_stmt (BindStmt pat expr src_loc)
 608   = addSrcLoc src_loc   $
 609     rnExpr expr         `thenM` \ (expr', fv_expr) ->
 610     rnPat pat           `thenM` \ (pat', fv_pat) ->
 611     let
 612         bndrs = mkNameSet (collectPatBinders pat')
 613         fvs   = fv_expr `plusFV` fv_pat
 614     in
 615     returnM (bndrs, fvs, bndrs `intersectNameSet` fvs,
 616              [BindStmt pat' expr' src_loc])
 617
 618 rn_mdo_stmt (LetStmt binds)
 619   = rnBinds binds               `thenM` \ (binds', fv_binds) ->
 620     returnM (mkNameSet (collectHsBinders binds'),
 621              fv_binds, emptyNameSet, [LetStmt binds'])
 622
 623 rn_mdo_stmt stmt@(ParStmt _)    -- Syntactically illegal in mdo
 624   = pprPanic "rn_mdo_stmt" (ppr stmt)
 625
 626
 627 addFwdRefs :: [Segment] -> [Segment]
 628 -- So far the segments only have forward refs *within* the Stmt
 629 --      (which happens for bind:  x <- ...x...)
 630 -- This function adds the cross-seg fwd ref info
 631
 632 addFwdRefs pairs
 633   = fst (foldr mk_seg ([], emptyNameSet) pairs)
 634   where
 635     mk_seg (defs, uses, fwds, stmts) (segs, seg_defs)
 636         = (new_seg : segs, all_defs)
 637         where
 638           new_seg = (defs, uses, new_fwds, stmts)
 639           all_defs = seg_defs `unionNameSets` defs
 640           new_fwds = fwds `unionNameSets` (uses `intersectNameSet` seg_defs)
 641                 -- Add the downstream fwd refs here
 642
 643 ----------------------------------------------------
 644 --      Glomming the singleton segments of an mdo into
 645 --      minimal recursive groups.
 646 --
 647 -- At first I thought this was just strongly connected components, but
 648 -- there's an important constraint: the order of the stmts must not change.
 649 --
 650 -- Consider
 651 --      mdo { x <- ...y...
 652 --            p <- z
 653 --            y <- ...x...
 654 --            q <- x
 655 --            z <- y
 656 --            r <- x }
 657 --
 658 -- Here, the first stmt mention 'y', which is bound in the third.
 659 -- But that means that the innocent second stmt (p <- z) gets caught
 660 -- up in the recursion.  And that in turn means that the binding for
 661 -- 'z' has to be included... and so on.
 662 --
 663 -- Start at the tail { r <- x }
 664 -- Now add the next one { z <- y ; r <- x }
 665 -- Now add one more     { q <- x ; z <- y ; r <- x }
 666 -- Now one more... but this time we have to group a bunch into rec
 667 --      { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
 668 -- Now one more, which we can add on without a rec
 669 --      { p <- z ;
 670 --        rec { y <- ...x... ; q <- x ; z <- y } ;
 671 --        r <- x }
 672 -- Finally we add the last one; since it mentions y we have to
 673 -- glom it togeher with the first two groups
 674 --      { rec { x <- ...y...; p <- z ; y <- ...x... ;
 675 --              q <- x ; z <- y } ;
 676 --        r <- x }
 677
 678 glomSegments :: [Segment] -> [Segment]
 679
 680 glomSegments [seg] = [seg]
 681 glomSegments ((defs,uses,fwds,stmts) : segs)
 682         -- Actually stmts will always be a singleton
 683   = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others
 684   where
 685     segs'            = glomSegments segs
 686     (extras, others) = grab uses segs'
 687     (ds, us, fs, ss) = unzip4 extras
 688
 689     seg_defs  = plusFVs ds `plusFV` defs
 690     seg_uses  = plusFVs us `plusFV` uses
 691     seg_fwds  = plusFVs fs `plusFV` fwds
 692     seg_stmts = stmts ++ concat ss
 693
 694     grab :: NameSet             -- The client
 695          -> [Segment]
 696          -> ([Segment],         -- Needed by the 'client'
 697              [Segment])         -- Not needed by the client
 698         -- The result is simply a split of the input
 699     grab uses dus
 700         = (reverse yeses, reverse noes)
 701         where
 702           (noes, yeses)           = span not_needed (reverse dus)
 703           not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
 704
 705
 706 ----------------------------------------------------
 707 segsToStmts :: [Segment] -> ([RenamedStmt], FreeVars)
 708
 709 segsToStmts [] = ([], emptyFVs)
 710 segsToStmts ((defs, uses, fwds, ss) : segs)
 711   = (new_stmt : later_stmts, later_uses `plusFV` uses)
 712   where
 713     (later_stmts, later_uses) = segsToStmts segs
 714     new_stmt | non_rec   = head ss
 715              | otherwise = RecStmt rec_names ss []
 716              where
 717                non_rec   = isSingleton ss && isEmptyNameSet fwds
 718                rec_names = nameSetToList (fwds `plusFV` (defs `intersectNameSet` later_uses))
 719                 -- The names for the fixpoint are
 720                 --      (a) the ones needed after the RecStmt
 721                 --      (b) the forward refs within the fixpoint
 722 \end{code}
 723
 724 %************************************************************************
 725 %*                                                                      *
 726 \subsubsection{Precedence Parsing}
 727 %*                                                                      *
 728 %************************************************************************
 729
 730 @mkOpAppRn@ deals with operator fixities.  The argument expressions
 731 are assumed to be already correctly arranged.  It needs the fixities
 732 recorded in the OpApp nodes, because fixity info applies to the things
 733 the programmer actually wrote, so you can't find it out from the Name.
 734
 735 Furthermore, the second argument is guaranteed not to be another
 736 operator application.  Why? Because the parser parses all
 737 operator appications left-associatively, EXCEPT negation, which
 738 we need to handle specially.
 739
 740 \begin{code}
 741 mkOpAppRn :: RenamedHsExpr                      -- Left operand; already rearranged
 742           -> RenamedHsExpr -> Fixity            -- Operator and fixity
 743           -> RenamedHsExpr                      -- Right operand (not an OpApp, but might
 744                                                 -- be a NegApp)
 745           -> RnM RenamedHsExpr
 746
 747 ---------------------------
 748 -- (e11 `op1` e12) `op2` e2
 749 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
 750   | nofix_error
 751   = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))   `thenM_`
 752     returnM (OpApp e1 op2 fix2 e2)
 753
 754   | associate_right
 755   = mkOpAppRn e12 op2 fix2 e2           `thenM` \ new_e ->
 756     returnM (OpApp e11 op1 fix1 new_e)
 757   where
 758     (nofix_error, associate_right) = compareFixity fix1 fix2
 759
 760 ---------------------------
 761 --      (- neg_arg) `op` e2
 762 mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2
 763   | nofix_error
 764   = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2))      `thenM_`
 765     returnM (OpApp e1 op2 fix2 e2)
 766
 767   | associate_right
 768   = mkOpAppRn neg_arg op2 fix2 e2       `thenM` \ new_e ->
 769     returnM (NegApp new_e neg_name)
 770   where
 771     (nofix_error, associate_right) = compareFixity negateFixity fix2
 772
 773 ---------------------------
 774 --      e1 `op` - neg_arg
 775 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _)     -- NegApp can occur on the right
 776   | not associate_right                         -- We *want* right association
 777   = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity))    `thenM_`
 778     returnM (OpApp e1 op1 fix1 e2)
 779   where
 780     (_, associate_right) = compareFixity fix1 negateFixity
 781
 782 ---------------------------
 783 --      Default case
 784 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
 785   = ASSERT2( right_op_ok fix e2,
 786              ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
 787     )
 788     returnM (OpApp e1 op fix e2)
 789
 790 -- Parser left-associates everything, but
 791 -- derived instances may have correctly-associated things to
 792 -- in the right operarand.  So we just check that the right operand is OK
 793 right_op_ok fix1 (OpApp _ _ fix2 _)
 794   = not error_please && associate_right
 795   where
 796     (error_please, associate_right) = compareFixity fix1 fix2
 797 right_op_ok fix1 other
 798   = True
 799
 800 -- Parser initially makes negation bind more tightly than any other operator
 801 mkNegAppRn neg_arg neg_name
 802   =
 803 #ifdef DEBUG
 804     getModeRn                   `thenM` \ mode ->
 805     ASSERT( not_op_app mode neg_arg )
 806 #endif
 807     returnM (NegApp neg_arg neg_name)
 808
 809 not_op_app SourceMode (OpApp _ _ _ _) = False
 810 not_op_app mode other                 = True
 811 \end{code}
 812
 813 \begin{code}
 814 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnM ()
 815
 816 checkPrecMatch False fn match
 817   = returnM ()
 818
 819 checkPrecMatch True op (Match (p1:p2:_) _ _)
 820         -- True indicates an infix lhs
 821   = getModeRn           `thenM` \ mode ->
 822         -- See comments with rnExpr (OpApp ...)
 823     if isInterfaceMode mode
 824         then returnM ()
 825         else checkPrec op p1 False      `thenM_`
 826              checkPrec op p2 True
 827
 828 checkPrecMatch True op _ = panic "checkPrecMatch"
 829
 830 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
 831   = lookupFixityRn op   `thenM` \  op_fix@(Fixity op_prec  op_dir) ->
 832     lookupFixityRn op1  `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
 833     let
 834         inf_ok = op1_prec > op_prec ||
 835                  (op1_prec == op_prec &&
 836                   (op1_dir == InfixR && op_dir == InfixR && right ||
 837                    op1_dir == InfixL && op_dir == InfixL && not right))
 838
 839         info  = (ppr_op op,  op_fix)
 840         info1 = (ppr_op op1, op1_fix)
 841         (infol, infor) = if right then (info, info1) else (info1, info)
 842     in
 843     checkErr inf_ok (precParseErr infol infor)
 844
 845 checkPrec op pat right
 846   = returnM ()
 847
 848 -- Check precedence of (arg op) or (op arg) respectively
 849 -- If arg is itself an operator application, then either
 850 --   (a) its precedence must be higher than that of op
 851 --   (b) its precedency & associativity must be the same as that of op
 852 checkSectionPrec direction section op arg
 853   = case arg of
 854         OpApp _ op fix _ -> go_for_it (ppr_op op)     fix
 855         NegApp _ _       -> go_for_it pp_prefix_minus negateFixity
 856         other            -> returnM ()
 857   where
 858     HsVar op_name = op
 859     go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
 860         = lookupFixityRn op_name        `thenM` \ op_fix@(Fixity op_prec _) ->
 861           checkErr (op_prec < arg_prec
 862                      || op_prec == arg_prec && direction == assoc)
 863                   (sectionPrecErr (ppr_op op_name, op_fix)
 864                   (pp_arg_op, arg_fix) section)
 865 \end{code}
 866
 867
 868 %************************************************************************
 869 %*                                                                      *
 870 \subsubsection{Assertion utils}
 871 %*                                                                      *
 872 %************************************************************************
 873
 874 \begin{code}
 875 mkAssertErrorExpr :: RnM (RenamedHsExpr, FreeVars)
 876 -- Return an expression for (assertError "Foo.hs:27")
 877 mkAssertErrorExpr
 878   = getSrcLocM                          `thenM` \ sloc ->
 879     let
 880         expr = HsApp (HsVar assertErrorName) (HsLit msg)
 881         msg  = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
 882     in
 883     returnM (expr, unitFV assertErrorName)
 884 \end{code}
 885
 886 %************************************************************************
 887 %*                                                                      *
 888 \subsubsection{Errors}
 889 %*                                                                      *
 890 %************************************************************************
 891
 892 \begin{code}
 893 ppr_op op = quotes (ppr op)     -- Here, op can be a Name or a (Var n), where n is a Name
 894 pp_prefix_minus = ptext SLIT("prefix `-'")
 895
 896 nonStdGuardErr guard
 897   = hang (ptext
 898     SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
 899     ) 4 (ppr guard)
 900
 901 patSynErr e
 902   = sep [ptext SLIT("Pattern syntax in expression context:"),
 903          nest 4 (ppr e)]
 904
 905 doStmtListErr do_or_lc e
 906   = sep [quotes (text binder_name) <+> ptext SLIT("statements must end in expression:"),
 907          nest 4 (ppr e)]
 908   where
 909     binder_name = case do_or_lc of
 910                         MDoExpr -> "mdo"
 911                         other   -> "do"
 912
 913 #ifdef GHCI
 914 checkTH e what = returnM ()     -- OK
 915 #else
 916 checkTH e what  -- Raise an error in a stage-1 compiler
 917   = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
 918                   ptext SLIT("illegal in a stage-1 compiler"),
 919                   nest 2 (ppr e)])
 920 #endif
 921
 922 badIpBinds binds
 923   = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4
 924          (ppr binds)
 925 \end{code}