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