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                           loopAName, choiceAName, appAName, arrAName, composeAName, firstAName,
  42                           splitName, fstName, sndName, ioDataConName,
  43                           replicatePName, mapPName, filterPName,
  44                           crossPName, zipPName, toPName,
  45                           enumFromToPName, enumFromThenToPName, assertErrorName,
  46                           negateName, monadNames, mfixName )
  47 import Name             ( Name, nameOccName )
  48 import NameSet
  49 import UnicodeUtil      ( stringToUtf8 )
  50 import UniqFM           ( isNullUFM )
  51 import UniqSet          ( emptyUniqSet )
  52 import Util             ( isSingleton, mapAndUnzip )
  53 import List             ( intersectBy, unzip4 )
  54 import ListSetOps       ( removeDups )
  55 import Outputable
  56 import SrcLoc           ( noSrcLoc )
  57 import FastString
  58 \end{code}
  59
  60
  61 ************************************************************************
  62 *                                                                       *
  63 \subsection{Match}
  64 *                                                                       *
  65 ************************************************************************
  66
  67 \begin{code}
  68 rnMatch :: HsMatchContext Name -> RdrNameMatch -> RnM (RenamedMatch, FreeVars)
  69
  70 rnMatch ctxt match@(Match pats maybe_rhs_sig grhss)
  71   = addSrcLoc (getMatchLoc match)       $
  72
  73         -- Deal with the rhs type signature
  74     bindPatSigTyVarsFV rhs_sig_tys      $
  75     doptM Opt_GlasgowExts               `thenM` \ opt_GlasgowExts ->
  76     (case maybe_rhs_sig of
  77         Nothing -> returnM (Nothing, emptyFVs)
  78         Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty     `thenM` \ (ty', ty_fvs) ->
  79                                      returnM (Just ty', ty_fvs)
  80                 | otherwise       -> addErr (patSigErr ty)      `thenM_`
  81                                      returnM (Nothing, emptyFVs)
  82     )                                   `thenM` \ (maybe_rhs_sig', ty_fvs) ->
  83
  84         -- Now the main event
  85     rnPatsAndThen ctxt pats     $ \ pats' ->
  86     rnGRHSs ctxt grhss          `thenM` \ (grhss', grhss_fvs) ->
  87
  88     returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
  89         -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs
  90   where
  91      rhs_sig_tys =  case maybe_rhs_sig of
  92                         Nothing -> []
  93                         Just ty -> [ty]
  94      doc_sig = text "In a result type-signature"
  95 \end{code}
  96
  97
  98 %************************************************************************
  99 %*                                                                      *
 100 \subsubsection{Guarded right-hand sides (GRHSs)}
 101 %*                                                                      *
 102 %************************************************************************
 103
 104 \begin{code}
 105 rnGRHSs :: HsMatchContext Name -> RdrNameGRHSs -> RnM (RenamedGRHSs, FreeVars)
 106
 107 rnGRHSs ctxt (GRHSs grhss binds _)
 108   = rnBindsAndThen binds        $ \ binds' ->
 109     mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) ->
 110     returnM (GRHSs grhss' binds' placeHolderType, fvGRHSs)
 111
 112 rnGRHS ctxt (GRHS guarded locn)
 113   = addSrcLoc locn $
 114     doptM Opt_GlasgowExts               `thenM` \ opt_GlasgowExts ->
 115     checkM (opt_GlasgowExts || is_standard_guard guarded)
 116            (addWarn (nonStdGuardErr guarded))   `thenM_`
 117
 118     rnStmts (PatGuard ctxt) guarded     `thenM` \ (guarded', fvs) ->
 119     returnM (GRHS guarded' locn, fvs)
 120   where
 121         -- Standard Haskell 1.4 guards are just a single boolean
 122         -- expression, rather than a list of qualifiers as in the
 123         -- Glasgow extension
 124     is_standard_guard [ResultStmt _ _]                 = True
 125     is_standard_guard [ExprStmt _ _ _, ResultStmt _ _] = True
 126     is_standard_guard other                            = False
 127 \end{code}
 128
 129 %************************************************************************
 130 %*                                                                      *
 131 \subsubsection{Expressions}
 132 %*                                                                      *
 133 %************************************************************************
 134
 135 \begin{code}
 136 rnExprs :: [RdrNameHsExpr] -> RnM ([RenamedHsExpr], FreeVars)
 137 rnExprs ls = rnExprs' ls emptyUniqSet
 138  where
 139   rnExprs' [] acc = returnM ([], acc)
 140   rnExprs' (expr:exprs) acc
 141    = rnExpr expr                `thenM` \ (expr', fvExpr) ->
 142
 143         -- Now we do a "seq" on the free vars because typically it's small
 144         -- or empty, especially in very long lists of constants
 145     let
 146         acc' = acc `plusFV` fvExpr
 147     in
 148     (grubby_seqNameSet acc' rnExprs') exprs acc'        `thenM` \ (exprs', fvExprs) ->
 149     returnM (expr':exprs', fvExprs)
 150
 151 -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq
 152 grubby_seqNameSet ns result | isNullUFM ns = result
 153                             | otherwise    = result
 154 \end{code}
 155
 156 Variables. We look up the variable and return the resulting name.
 157
 158 \begin{code}
 159 rnExpr :: RdrNameHsExpr -> RnM (RenamedHsExpr, FreeVars)
 160
 161 rnExpr (HsVar v)
 162   = lookupOccRn v       `thenM` \ name ->
 163     if name `hasKey` assertIdKey && not opt_IgnoreAsserts then
 164         -- We expand it to (GHC.Err.assertError location_string)
 165         mkAssertErrorExpr
 166     else
 167         -- The normal case.  Even if the Id was 'assert', if we are
 168         -- ignoring assertions we leave it as GHC.Base.assert;
 169         -- this function just ignores its first arg.
 170        returnM (HsVar name, unitFV name)
 171
 172 rnExpr (HsIPVar v)
 173   = newIPName v                 `thenM` \ name ->
 174     let
 175         fvs = case name of
 176                 Linear _  -> mkFVs [splitName, fstName, sndName]
 177                 Dupable _ -> emptyFVs
 178     in
 179     returnM (HsIPVar name, fvs)
 180
 181 rnExpr (HsLit lit)
 182   = litFVs lit          `thenM` \ fvs ->
 183     returnM (HsLit lit, fvs)
 184
 185 rnExpr (HsOverLit lit)
 186   = rnOverLit lit               `thenM` \ (lit', fvs) ->
 187     returnM (HsOverLit lit', fvs)
 188
 189 rnExpr (HsLam match)
 190   = rnMatch LambdaExpr match    `thenM` \ (match', fvMatch) ->
 191     returnM (HsLam match', fvMatch)
 192
 193 rnExpr (HsApp fun arg)
 194   = rnExpr fun          `thenM` \ (fun',fvFun) ->
 195     rnExpr arg          `thenM` \ (arg',fvArg) ->
 196     returnM (HsApp fun' arg', fvFun `plusFV` fvArg)
 197
 198 rnExpr (OpApp e1 op _ e2)
 199   = rnExpr e1                           `thenM` \ (e1', fv_e1) ->
 200     rnExpr e2                           `thenM` \ (e2', fv_e2) ->
 201     rnExpr op                           `thenM` \ (op'@(HsVar op_name), fv_op) ->
 202
 203         -- Deal with fixity
 204         -- When renaming code synthesised from "deriving" declarations
 205         -- we're in Interface mode, and we should ignore fixity; assume
 206         -- that the deriving code generator got the association correct
 207         -- Don't even look up the fixity when in interface mode
 208     getModeRn                           `thenM` \ mode ->
 209     (if isInterfaceMode mode
 210         then returnM (OpApp e1' op' defaultFixity e2')
 211         else lookupFixityRn op_name             `thenM` \ fixity ->
 212              mkOpAppRn e1' op' fixity e2'
 213     )                                   `thenM` \ final_e ->
 214
 215     returnM (final_e,
 216               fv_e1 `plusFV` fv_op `plusFV` fv_e2)
 217
 218 rnExpr (NegApp e _)
 219   = rnExpr e                    `thenM` \ (e', fv_e) ->
 220     lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
 221     mkNegAppRn e' neg_name      `thenM` \ final_e ->
 222     returnM (final_e, fv_e `plusFV` fv_neg)
 223
 224 rnExpr (HsPar e)
 225   = rnExpr e            `thenM` \ (e', fvs_e) ->
 226     returnM (HsPar e', fvs_e)
 227
 228 -- Template Haskell extensions
 229 -- Don't ifdef-GHCI them because we want to fail gracefully
 230 -- (not with an rnExpr crash) in a stage-1 compiler.
 231 rnExpr e@(HsBracket br_body loc)
 232   = addSrcLoc loc               $
 233     checkTH e "bracket"         `thenM_`
 234     rnBracket br_body           `thenM` \ (body', fvs_e) ->
 235     returnM (HsBracket body' loc, fvs_e `plusFV` thProxyName)
 236
 237 rnExpr e@(HsSplice n splice loc)
 238   = addSrcLoc loc               $
 239     checkTH e "splice"          `thenM_`
 240     newLocalsRn [(n,loc)]       `thenM` \ [n'] ->
 241     rnExpr splice               `thenM` \ (splice', fvs_e) ->
 242     returnM (HsSplice n' splice' loc, fvs_e `plusFV` thProxyName)
 243
 244 rnExpr e@(HsReify (Reify flavour name))
 245   = checkTH e "reify"           `thenM_`
 246     lookupGlobalOccRn name      `thenM` \ name' ->
 247         -- For now, we can only reify top-level things
 248     returnM (HsReify (Reify flavour name'), unitFV name' `plusFV` thProxyName)
 249
 250 rnExpr section@(SectionL expr op)
 251   = rnExpr expr                                 `thenM` \ (expr', fvs_expr) ->
 252     rnExpr op                                   `thenM` \ (op', fvs_op) ->
 253     checkSectionPrec InfixL section op' expr' `thenM_`
 254     returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr)
 255
 256 rnExpr section@(SectionR op expr)
 257   = rnExpr op                                   `thenM` \ (op',   fvs_op) ->
 258     rnExpr expr                                 `thenM` \ (expr', fvs_expr) ->
 259     checkSectionPrec InfixR section op' expr'   `thenM_`
 260     returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr)
 261
 262 rnExpr (HsCCall fun args may_gc is_casm _)
 263         -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
 264   = rnExprs args                                `thenM` \ (args', fvs_args) ->
 265     returnM (HsCCall fun args' may_gc is_casm placeHolderType,
 266               fvs_args `plusFV` mkFVs [cCallableClassName,
 267                                        cReturnableClassName,
 268                                        ioDataConName])
 269
 270 rnExpr (HsCoreAnn ann expr)
 271   = rnExpr expr `thenM` \ (expr', fvs_expr) ->
 272     returnM (HsCoreAnn ann expr', fvs_expr)
 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 e@(HsDo do_or_lc stmts _ _ src_loc)
 290   = addSrcLoc src_loc $
 291     rnStmts do_or_lc stmts              `thenM` \ (stmts', fvs) ->
 292
 293         -- Check the statement list ends in an expression
 294     case last stmts' of {
 295         ResultStmt _ _ -> returnM () ;
 296         _              -> addErr (doStmtListErr do_or_lc e)
 297     }                                   `thenM_`
 298
 299         -- Generate the rebindable syntax for the monad
 300     lookupSyntaxNames syntax_names      `thenM` \ (syntax_names', monad_fvs) ->
 301
 302     returnM (HsDo do_or_lc stmts' syntax_names' placeHolderType src_loc,
 303              fvs `plusFV` implicit_fvs do_or_lc `plusFV` monad_fvs)
 304   where
 305     implicit_fvs PArrComp = mkFVs [replicatePName, mapPName, filterPName, crossPName, zipPName]
 306     implicit_fvs ListComp = mkFVs [foldrName, buildName]
 307     implicit_fvs DoExpr   = emptyFVs
 308     implicit_fvs MDoExpr  = emptyFVs
 309
 310     syntax_names = case do_or_lc of
 311                         DoExpr  -> monadNames
 312                         MDoExpr -> monadNames ++ [mfixName]
 313                         other   -> []
 314
 315 rnExpr (ExplicitList _ exps)
 316   = rnExprs exps                        `thenM` \ (exps', fvs) ->
 317     returnM  (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name)
 318
 319 rnExpr (ExplicitPArr _ exps)
 320   = rnExprs exps                        `thenM` \ (exps', fvs) ->
 321     returnM  (ExplicitPArr placeHolderType exps',
 322                fvs `addOneFV` toPName `addOneFV` parrTyCon_name)
 323
 324 rnExpr e@(ExplicitTuple exps boxity)
 325   = checkTupSize tup_size                       `thenM_`
 326     rnExprs exps                                `thenM` \ (exps', fvs) ->
 327     returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name)
 328   where
 329     tup_size   = length exps
 330     tycon_name = tupleTyCon_name boxity tup_size
 331
 332 rnExpr (RecordCon con_id rbinds)
 333   = lookupOccRn con_id                  `thenM` \ conname ->
 334     rnRbinds "construction" rbinds      `thenM` \ (rbinds', fvRbinds) ->
 335     returnM (RecordCon conname rbinds', fvRbinds `addOneFV` conname)
 336
 337 rnExpr (RecordUpd expr rbinds)
 338   = rnExpr expr                 `thenM` \ (expr', fvExpr) ->
 339     rnRbinds "update" rbinds    `thenM` \ (rbinds', fvRbinds) ->
 340     returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds)
 341
 342 rnExpr (ExprWithTySig expr pty)
 343   = rnExpr expr                 `thenM` \ (expr', fvExpr) ->
 344     rnHsTypeFVs doc pty         `thenM` \ (pty', fvTy) ->
 345     returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy)
 346   where
 347     doc = text "In an expression type signature"
 348
 349 rnExpr (HsIf p b1 b2 src_loc)
 350   = addSrcLoc src_loc $
 351     rnExpr p            `thenM` \ (p', fvP) ->
 352     rnExpr b1           `thenM` \ (b1', fvB1) ->
 353     rnExpr b2           `thenM` \ (b2', fvB2) ->
 354     returnM (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
 355
 356 rnExpr (HsType a)
 357   = rnHsTypeFVs doc a   `thenM` \ (t, fvT) ->
 358     returnM (HsType t, fvT)
 359   where
 360     doc = text "In a type argument"
 361
 362 rnExpr (ArithSeqIn seq)
 363   = rnArithSeq seq       `thenM` \ (new_seq, fvs) ->
 364     returnM (ArithSeqIn new_seq, fvs `addOneFV` enumClassName)
 365
 366 rnExpr (PArrSeqIn seq)
 367   = rnArithSeq seq       `thenM` \ (new_seq, fvs) ->
 368     returnM (PArrSeqIn new_seq,
 369              fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName])
 370 \end{code}
 371
 372 These three are pattern syntax appearing in expressions.
 373 Since all the symbols are reservedops we can simply reject them.
 374 We return a (bogus) EWildPat in each case.
 375
 376 \begin{code}
 377 rnExpr e@EWildPat = addErr (patSynErr e)        `thenM_`
 378                     returnM (EWildPat, emptyFVs)
 379
 380 rnExpr e@(EAsPat _ _) = addErr (patSynErr e)    `thenM_`
 381                         returnM (EWildPat, emptyFVs)
 382
 383 rnExpr e@(ELazyPat _) = addErr (patSynErr e)    `thenM_`
 384                         returnM (EWildPat, emptyFVs)
 385 \end{code}
 386
 387 %************************************************************************
 388 %*                                                                      *
 389         Arrow notation
 390 %*                                                                      *
 391 %************************************************************************
 392
 393 \begin{code}
 394 rnExpr (HsProc pat body src_loc)
 395   = addSrcLoc src_loc $
 396     rnPatsAndThen ProcExpr [pat] $ \ [pat'] ->
 397     rnCmdTop body       `thenM` \ (body',fvBody) ->
 398     returnM (HsProc pat' body' src_loc, fvBody)
 399
 400 rnExpr (HsArrApp arrow arg _ ho rtl srcloc)
 401   = rnExpr arrow        `thenM` \ (arrow',fvArrow) ->
 402     rnExpr arg          `thenM` \ (arg',fvArg) ->
 403     returnM (HsArrApp arrow' arg' placeHolderType ho rtl srcloc,
 404              fvArrow `plusFV` fvArg)
 405
 406 -- infix form
 407 rnExpr (HsArrForm op (Just _) [arg1, arg2] srcloc)
 408   = rnExpr op           `thenM` \ (op'@(HsVar op_name),fv_op) ->
 409     rnCmdTop arg1       `thenM` \ (arg1',fv_arg1) ->
 410     rnCmdTop arg2       `thenM` \ (arg2',fv_arg2) ->
 411
 412         -- Deal with fixity
 413
 414     lookupFixityRn op_name              `thenM` \ fixity ->
 415     mkOpFormRn arg1' op' fixity arg2'   `thenM` \ final_e ->
 416
 417     returnM (final_e,
 418               fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
 419
 420 rnExpr (HsArrForm op fixity cmds srcloc)
 421   = rnExpr op           `thenM` \ (op',fvOp) ->
 422     rnCmdArgs cmds      `thenM` \ (cmds',fvCmds) ->
 423     returnM (HsArrForm op' fixity cmds' srcloc,
 424              fvOp `plusFV` fvCmds)
 425
 426 ---------------------------
 427 -- Deal with fixity (cf mkOpAppRn for the method)
 428
 429 mkOpFormRn :: RenamedHsCmdTop           -- Left operand; already rearranged
 430           -> RenamedHsExpr -> Fixity    -- Operator and fixity
 431           -> RenamedHsCmdTop            -- Right operand (not an infix)
 432           -> RnM RenamedHsCmd
 433
 434 ---------------------------
 435 -- (e11 `op1` e12) `op2` e2
 436 mkOpFormRn a1@(HsCmdTop (HsArrForm op1 (Just fix1) [a11,a12] loc1) _ _ _) op2 fix2 a2
 437   | nofix_error
 438   = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))   `thenM_`
 439     returnM (HsArrForm op2 (Just fix2) [a1, a2] loc1)
 440
 441   | associate_right
 442   = mkOpFormRn a12 op2 fix2 a2          `thenM` \ new_c ->
 443     returnM (HsArrForm op1 (Just fix1)
 444         [a11, HsCmdTop new_c [] placeHolderType []] loc1)
 445   where
 446     (nofix_error, associate_right) = compareFixity fix1 fix2
 447
 448 ---------------------------
 449 --      Default case
 450 mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
 451   = returnM (HsArrForm op (Just fix) [arg1, arg2] noSrcLoc)
 452
 453 \end{code}
 454
 455
 456 %************************************************************************
 457 %*                                                                      *
 458         Arrow commands
 459 %*                                                                      *
 460 %************************************************************************
 461
 462 \begin{code}
 463 rnCmdArgs [] = returnM ([], emptyFVs)
 464 rnCmdArgs (arg:args)
 465   = rnCmdTop arg        `thenM` \ (arg',fvArg) ->
 466     rnCmdArgs args      `thenM` \ (args',fvArgs) ->
 467     returnM (arg':args', fvArg `plusFV` fvArgs)
 468
 469 rnCmdTop (HsCmdTop cmd _ _ _)
 470   = rnExpr (convertOpFormsCmd cmd)      `thenM` \ (cmd', fvCmd) ->
 471     let
 472         cmd_names = [arrAName, composeAName, firstAName] ++
 473                     nameSetToList (methodNamesCmd cmd')
 474     in
 475         -- Generate the rebindable syntax for the monad
 476     lookupSyntaxNames cmd_names         `thenM` \ (cmd_names', cmd_fvs) ->
 477
 478     returnM (HsCmdTop cmd' [] placeHolderType cmd_names',
 479              fvCmd `plusFV` cmd_fvs)
 480
 481 ---------------------------------------------------
 482 -- convert OpApp's in a command context to HsArrForm's
 483
 484 convertOpFormsCmd :: HsCmd id -> HsCmd id
 485
 486 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
 487
 488 convertOpFormsCmd (OpApp c1 op fixity c2)
 489   = let
 490         arg1 = HsCmdTop (convertOpFormsCmd c1) [] placeHolderType []
 491         arg2 = HsCmdTop (convertOpFormsCmd c2) [] placeHolderType []
 492     in
 493     HsArrForm op (Just fixity) [arg1, arg2] noSrcLoc
 494
 495 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsCmd c)
 496
 497 convertOpFormsCmd (HsCase exp matches locn)
 498   = HsCase exp (map convertOpFormsMatch matches) locn
 499
 500 convertOpFormsCmd (HsIf exp c1 c2 locn)
 501   = HsIf exp (convertOpFormsCmd c1) (convertOpFormsCmd c2) locn
 502
 503 convertOpFormsCmd (HsLet binds cmd)
 504   = HsLet binds (convertOpFormsCmd cmd)
 505
 506 convertOpFormsCmd (HsDo ctxt stmts ids ty locn)
 507   = HsDo ctxt (map convertOpFormsStmt stmts) ids ty locn
 508
 509 -- Anything else is unchanged.  This includes HsArrForm (already done),
 510 -- things with no sub-commands, and illegal commands (which will be
 511 -- caught by the type checker)
 512 convertOpFormsCmd c = c
 513
 514 convertOpFormsStmt (BindStmt pat cmd locn)
 515   = BindStmt pat (convertOpFormsCmd cmd) locn
 516 convertOpFormsStmt (ResultStmt cmd locn)
 517   = ResultStmt (convertOpFormsCmd cmd) locn
 518 convertOpFormsStmt (ExprStmt cmd ty locn)
 519   = ExprStmt (convertOpFormsCmd cmd) ty locn
 520 convertOpFormsStmt (RecStmt stmts lvs rvs es)
 521   = RecStmt (map convertOpFormsStmt stmts) lvs rvs es
 522 convertOpFormsStmt stmt = stmt
 523
 524 convertOpFormsMatch (Match pat mty grhss)
 525   = Match pat mty (convertOpFormsGRHSs grhss)
 526
 527 convertOpFormsGRHSs (GRHSs grhss binds ty)
 528   = GRHSs (map convertOpFormsGRHS grhss) binds ty
 529
 530 convertOpFormsGRHS (GRHS stmts locn)
 531   = let
 532         (ResultStmt cmd locn') = last stmts
 533     in
 534     GRHS (init stmts ++ [ResultStmt (convertOpFormsCmd cmd) locn']) locn
 535
 536 ---------------------------------------------------
 537 type CmdNeeds = FreeVars        -- Only inhabitants are
 538                                 --      appAName, choiceAName, loopAName
 539
 540 -- find what methods the Cmd needs (loop, choice, apply)
 541 methodNamesCmd :: HsCmd Name -> CmdNeeds
 542
 543 methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsFirstOrderApp _rtl _srcloc)
 544   = emptyFVs
 545 methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsHigherOrderApp _rtl _srcloc)
 546   = unitFV appAName
 547 methodNamesCmd cmd@(HsArrForm {}) = emptyFVs
 548
 549 methodNamesCmd (HsPar c) = methodNamesCmd c
 550
 551 methodNamesCmd (HsIf p c1 c2 loc)
 552   = methodNamesCmd c1 `plusFV` methodNamesCmd c2 `addOneFV` choiceAName
 553
 554 methodNamesCmd (HsLet b c) = methodNamesCmd c
 555
 556 methodNamesCmd (HsDo sc stmts rbs ty loc) = methodNamesStmts stmts
 557
 558 methodNamesCmd (HsLam match) = methodNamesMatch match
 559
 560 methodNamesCmd (HsCase scrut matches loc)
 561   = plusFVs (map methodNamesMatch matches) `addOneFV` choiceAName
 562
 563 methodNamesCmd other = emptyFVs
 564    -- Other forms can't occur in commands, but it's not convenient
 565    -- to error here so we just do what's convenient.
 566    -- The type checker will complain later
 567
 568 ---------------------------------------------------
 569 methodNamesMatch (Match pats sig_ty grhss) = methodNamesGRHSs grhss
 570
 571 -------------------------------------------------
 572 methodNamesGRHSs (GRHSs grhss binds ty) = plusFVs (map methodNamesGRHS grhss)
 573
 574 -------------------------------------------------
 575 methodNamesGRHS (GRHS stmts loc) = methodNamesStmt (last stmts)
 576
 577 ---------------------------------------------------
 578 methodNamesStmts stmts = plusFVs (map methodNamesStmt stmts)
 579
 580 ---------------------------------------------------
 581 methodNamesStmt (ResultStmt cmd loc) = methodNamesCmd cmd
 582 methodNamesStmt (ExprStmt cmd ty loc) = methodNamesCmd cmd
 583 methodNamesStmt (BindStmt pat cmd loc) = methodNamesCmd cmd
 584 methodNamesStmt (RecStmt stmts lvs rvs es)
 585   = methodNamesStmts stmts `addOneFV` loopAName
 586 methodNamesStmt (LetStmt b)  = emptyFVs
 587 methodNamesStmt (ParStmt ss) = emptyFVs
 588    -- ParStmt can't occur in commands, but it's not convenient to error
 589    -- here so we just do what's convenient
 590 \end{code}
 591
 592
 593 %************************************************************************
 594 %*                                                                      *
 595         Arithmetic sequences
 596 %*                                                                      *
 597 %************************************************************************
 598
 599 \begin{code}
 600 rnArithSeq (From expr)
 601  = rnExpr expr  `thenM` \ (expr', fvExpr) ->
 602    returnM (From expr', fvExpr)
 603
 604 rnArithSeq (FromThen expr1 expr2)
 605  = rnExpr expr1         `thenM` \ (expr1', fvExpr1) ->
 606    rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
 607    returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 608
 609 rnArithSeq (FromTo expr1 expr2)
 610  = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
 611    rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
 612    returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 613
 614 rnArithSeq (FromThenTo expr1 expr2 expr3)
 615  = rnExpr expr1 `thenM` \ (expr1', fvExpr1) ->
 616    rnExpr expr2 `thenM` \ (expr2', fvExpr2) ->
 617    rnExpr expr3 `thenM` \ (expr3', fvExpr3) ->
 618    returnM (FromThenTo expr1' expr2' expr3',
 619             plusFVs [fvExpr1, fvExpr2, fvExpr3])
 620 \end{code}
 621
 622
 623 %************************************************************************
 624 %*                                                                      *
 625 \subsubsection{@Rbinds@s and @Rpats@s: in record expressions}
 626 %*                                                                      *
 627 %************************************************************************
 628
 629 \begin{code}
 630 rnRbinds str rbinds
 631   = mappM_ field_dup_err dup_fields     `thenM_`
 632     mapFvRn rn_rbind rbinds             `thenM` \ (rbinds', fvRbind) ->
 633     returnM (rbinds', fvRbind)
 634   where
 635     (_, dup_fields) = removeDups compare [ f | (f,_) <- rbinds ]
 636
 637     field_dup_err dups = addErr (dupFieldErr str dups)
 638
 639     rn_rbind (field, expr)
 640       = lookupGlobalOccRn field `thenM` \ fieldname ->
 641         rnExpr expr             `thenM` \ (expr', fvExpr) ->
 642         returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname)
 643 \end{code}
 644
 645 %************************************************************************
 646 %*                                                                      *
 647         Template Haskell brackets
 648 %*                                                                      *
 649 %************************************************************************
 650
 651 \begin{code}
 652 rnBracket (ExpBr e) = rnExpr e          `thenM` \ (e', fvs) ->
 653                       returnM (ExpBr e', fvs)
 654 rnBracket (PatBr p) = rnPat p           `thenM` \ (p', fvs) ->
 655                       returnM (PatBr p', fvs)
 656 rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) ->
 657                       returnM (TypBr t', fvs)
 658                     where
 659                       doc = ptext SLIT("In a Template-Haskell quoted type")
 660 rnBracket (DecBr group)
 661   = importsFromLocalDecls group `thenM` \ (rdr_env, avails) ->
 662         -- Discard avails (not useful here)
 663
 664     updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl }) $
 665
 666     rnSrcDecls group    `thenM` \ (tcg_env, group', dus) ->
 667         -- Discard the tcg_env; it contains only extra info about fixity
 668
 669     returnM (DecBr group', duUses dus `minusNameSet` duDefs dus)
 670 \end{code}
 671
 672 %************************************************************************
 673 %*                                                                      *
 674 \subsubsection{@Stmt@s: in @do@ expressions}
 675 %*                                                                      *
 676 %************************************************************************
 677
 678 \begin{code}
 679 rnStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
 680
 681 rnStmts MDoExpr stmts = rnMDoStmts         stmts
 682 rnStmts ctxt   stmts  = rnNormalStmts ctxt stmts
 683
 684 rnNormalStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
 685 -- Used for cases *other* than recursive mdo
 686 -- Implements nested scopes
 687
 688 rnNormalStmts ctxt [] = returnM ([], emptyFVs)
 689         -- Happens at the end of the sub-lists of a ParStmts
 690
 691 rnNormalStmts ctxt (ExprStmt expr _ src_loc : stmts)
 692   = addSrcLoc src_loc           $
 693     rnExpr expr                 `thenM` \ (expr', fv_expr) ->
 694     rnNormalStmts ctxt stmts    `thenM` \ (stmts', fvs) ->
 695     returnM (ExprStmt expr' placeHolderType src_loc : stmts',
 696              fv_expr `plusFV` fvs)
 697
 698 rnNormalStmts ctxt [ResultStmt expr src_loc]
 699   = addSrcLoc src_loc   $
 700     rnExpr expr         `thenM` \ (expr', fv_expr) ->
 701     returnM ([ResultStmt expr' src_loc], fv_expr)
 702
 703 rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts)
 704   = addSrcLoc src_loc                   $
 705     rnExpr expr                         `thenM` \ (expr', fv_expr) ->
 706         -- The binders do not scope over the expression
 707
 708     rnPatsAndThen (StmtCtxt ctxt) [pat] $ \ [pat'] ->
 709     rnNormalStmts ctxt stmts            `thenM` \ (stmts', fvs) ->
 710     returnM (BindStmt pat' expr' src_loc : stmts',
 711              fv_expr `plusFV` fvs)      -- fv_expr shouldn't really be filtered by
 712                                         -- the rnPatsAndThen, but it does not matter
 713
 714 rnNormalStmts ctxt (LetStmt binds : stmts)
 715   = checkErr (ok ctxt binds) (badIpBinds binds) `thenM_`
 716     rnBindsAndThen binds                        ( \ binds' ->
 717     rnNormalStmts ctxt stmts                    `thenM` \ (stmts', fvs) ->
 718     returnM (LetStmt binds' : stmts', fvs))
 719   where
 720         -- We do not allow implicit-parameter bindings in a parallel
 721         -- list comprehension.  I'm not sure what it might mean.
 722     ok (ParStmtCtxt _) (IPBinds _ _) = False
 723     ok _               _             = True
 724
 725 rnNormalStmts ctxt (ParStmt stmtss : stmts)
 726   = doptM Opt_GlasgowExts               `thenM` \ opt_GlasgowExts ->
 727     checkM opt_GlasgowExts parStmtErr   `thenM_`
 728     mapFvRn rn_branch stmtss            `thenM` \ (stmtss', fv_stmtss) ->
 729     let
 730         bndrss :: [[Name]]      -- NB: Name, not RdrName
 731         bndrss        = map collectStmtsBinders stmtss'
 732         (bndrs, dups) = removeDups cmpByOcc (concat bndrss)
 733     in
 734     mappM dupErr dups                   `thenM` \ _ ->
 735     bindLocalNamesFV bndrs              $
 736         -- Note: binders are returned in scope order, so one may
 737         --       shadow the next; e.g. x <- xs; x <- ys
 738     rnNormalStmts ctxt stmts                    `thenM` \ (stmts', fvs) ->
 739
 740         -- Cut down the exported binders to just the ones neede in the body
 741     let
 742         used_bndrs_s = map (filter (`elemNameSet` fvs)) bndrss
 743     in
 744     returnM (ParStmt (stmtss' `zip` used_bndrs_s) : stmts',
 745              fv_stmtss `plusFV` fvs)
 746
 747   where
 748     rn_branch (stmts, _) = rnNormalStmts (ParStmtCtxt ctxt) stmts
 749
 750     cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
 751     dupErr (v:_) = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:")
 752                             <+> quotes (ppr v))
 753
 754 rnNormalStmts ctxt (RecStmt rec_stmts _ _ _ : stmts)
 755   = bindLocalsRn doc (collectStmtsBinders rec_stmts)    $ \ _ ->
 756     rn_rec_stmts rec_stmts                              `thenM` \ segs ->
 757     rnNormalStmts ctxt stmts                            `thenM` \ (stmts', fvs) ->
 758     let
 759         segs_w_fwd_refs          = addFwdRefs segs
 760         (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
 761         later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
 762         fwd_vars   = nameSetToList (plusFVs fs)
 763         uses       = plusFVs us
 764     in
 765     returnM (RecStmt rec_stmts' later_vars fwd_vars [] : stmts', uses `plusFV` fvs)
 766   where
 767     doc = text "In a recursive do statement"
 768 \end{code}
 769
 770
 771 %************************************************************************
 772 %*                                                                      *
 773 \subsubsection{mdo expressions}
 774 %*                                                                      *
 775 %************************************************************************
 776
 777 \begin{code}
 778 type FwdRefs = NameSet
 779 type Segment stmts = (Defs,
 780                       Uses,     -- May include defs
 781                       FwdRefs,  -- A subset of uses that are
 782                                 --   (a) used before they are bound in this segment, or
 783                                 --   (b) used here, and bound in subsequent segments
 784                       stmts)    -- Either Stmt or [Stmt]
 785
 786
 787 ----------------------------------------------------
 788 rnMDoStmts :: [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars)
 789 rnMDoStmts stmts
 790   =     -- Step1: bring all the binders of the mdo into scope
 791         -- Remember that this also removes the binders from the
 792         -- finally-returned free-vars
 793     bindLocalsRn doc (collectStmtsBinders stmts)        $ \ _ ->
 794
 795         -- Step 2: Rename each individual stmt, making a
 796         --         singleton segment.  At this stage the FwdRefs field
 797         --         isn't finished: it's empty for all except a BindStmt
 798         --         for which it's the fwd refs within the bind itself
 799         --         (This set may not be empty, because we're in a recursive
 800         --          context.)
 801     rn_rec_stmts stmts                                  `thenM` \ segs ->
 802     let
 803         -- Step 3: Fill in the fwd refs.
 804         --         The segments are all singletons, but their fwd-ref
 805         --         field mentions all the things used by the segment
 806         --         that are bound after their use
 807         segs_w_fwd_refs = addFwdRefs segs
 808
 809         -- Step 4: Group together the segments to make bigger segments
 810         --         Invariant: in the result, no segment uses a variable
 811         --                    bound in a later segment
 812         grouped_segs = glomSegments segs_w_fwd_refs
 813
 814         -- Step 5: Turn the segments into Stmts
 815         --         Use RecStmt when and only when there are fwd refs
 816         --         Also gather up the uses from the end towards the
 817         --         start, so we can tell the RecStmt which things are
 818         --         used 'after' the RecStmt
 819         stmts_w_fvs = segsToStmts grouped_segs
 820     in
 821     returnM stmts_w_fvs
 822   where
 823     doc = text "In a mdo-expression"
 824
 825
 826 ----------------------------------------------------
 827 rn_rec_stmt :: RdrNameStmt -> RnM [Segment RenamedStmt]
 828         -- Rename a Stmt that is inside a RecStmt (or mdo)
 829         -- Assumes all binders are already in scope
 830         -- Turns each stmt into a singleton Stmt
 831
 832 rn_rec_stmt (ExprStmt expr _ src_loc)
 833   = addSrcLoc src_loc (rnExpr expr)     `thenM` \ (expr', fvs) ->
 834     returnM [(emptyNameSet, fvs, emptyNameSet,
 835               ExprStmt expr' placeHolderType src_loc)]
 836
 837 rn_rec_stmt (ResultStmt expr src_loc)
 838   = addSrcLoc src_loc (rnExpr expr)     `thenM` \ (expr', fvs) ->
 839     returnM [(emptyNameSet, fvs, emptyNameSet,
 840               ResultStmt expr' src_loc)]
 841
 842 rn_rec_stmt (BindStmt pat expr src_loc)
 843   = addSrcLoc src_loc   $
 844     rnExpr expr         `thenM` \ (expr', fv_expr) ->
 845     rnPat pat           `thenM` \ (pat', fv_pat) ->
 846     let
 847         bndrs = mkNameSet (collectPatBinders pat')
 848         fvs   = fv_expr `plusFV` fv_pat
 849     in
 850     returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs,
 851               BindStmt pat' expr' src_loc)]
 852
 853 rn_rec_stmt (LetStmt binds)
 854   = rnBinds binds               `thenM` \ (binds', du_binds) ->
 855     returnM [(duDefs du_binds, duUses du_binds,
 856               emptyNameSet, LetStmt binds')]
 857
 858 rn_rec_stmt (RecStmt stmts _ _ _)       -- Flatten Rec inside Rec
 859   = rn_rec_stmts stmts
 860
 861 rn_rec_stmt stmt@(ParStmt _)    -- Syntactically illegal in mdo
 862   = pprPanic "rn_rec_stmt" (ppr stmt)
 863
 864 ---------------------------------------------
 865 rn_rec_stmts :: [RdrNameStmt] -> RnM [Segment RenamedStmt]
 866 rn_rec_stmts stmts = mappM rn_rec_stmt stmts    `thenM` \ segs_s ->
 867                      returnM (concat segs_s)
 868
 869
 870 ---------------------------------------------
 871 addFwdRefs :: [Segment a] -> [Segment a]
 872 -- So far the segments only have forward refs *within* the Stmt
 873 --      (which happens for bind:  x <- ...x...)
 874 -- This function adds the cross-seg fwd ref info
 875
 876 addFwdRefs pairs
 877   = fst (foldr mk_seg ([], emptyNameSet) pairs)
 878   where
 879     mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
 880         = (new_seg : segs, all_defs)
 881         where
 882           new_seg = (defs, uses, new_fwds, stmts)
 883           all_defs = later_defs `unionNameSets` defs
 884           new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
 885                 -- Add the downstream fwd refs here
 886
 887 ----------------------------------------------------
 888 --      Glomming the singleton segments of an mdo into
 889 --      minimal recursive groups.
 890 --
 891 -- At first I thought this was just strongly connected components, but
 892 -- there's an important constraint: the order of the stmts must not change.
 893 --
 894 -- Consider
 895 --      mdo { x <- ...y...
 896 --            p <- z
 897 --            y <- ...x...
 898 --            q <- x
 899 --            z <- y
 900 --            r <- x }
 901 --
 902 -- Here, the first stmt mention 'y', which is bound in the third.
 903 -- But that means that the innocent second stmt (p <- z) gets caught
 904 -- up in the recursion.  And that in turn means that the binding for
 905 -- 'z' has to be included... and so on.
 906 --
 907 -- Start at the tail { r <- x }
 908 -- Now add the next one { z <- y ; r <- x }
 909 -- Now add one more     { q <- x ; z <- y ; r <- x }
 910 -- Now one more... but this time we have to group a bunch into rec
 911 --      { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
 912 -- Now one more, which we can add on without a rec
 913 --      { p <- z ;
 914 --        rec { y <- ...x... ; q <- x ; z <- y } ;
 915 --        r <- x }
 916 -- Finally we add the last one; since it mentions y we have to
 917 -- glom it togeher with the first two groups
 918 --      { rec { x <- ...y...; p <- z ; y <- ...x... ;
 919 --              q <- x ; z <- y } ;
 920 --        r <- x }
 921
 922 glomSegments :: [Segment RenamedStmt] -> [Segment [RenamedStmt]]
 923
 924 glomSegments [] = []
 925 glomSegments ((defs,uses,fwds,stmt) : segs)
 926         -- Actually stmts will always be a singleton
 927   = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others
 928   where
 929     segs'            = glomSegments segs
 930     (extras, others) = grab uses segs'
 931     (ds, us, fs, ss) = unzip4 extras
 932
 933     seg_defs  = plusFVs ds `plusFV` defs
 934     seg_uses  = plusFVs us `plusFV` uses
 935     seg_fwds  = plusFVs fs `plusFV` fwds
 936     seg_stmts = stmt : concat ss
 937
 938     grab :: NameSet             -- The client
 939          -> [Segment a]
 940          -> ([Segment a],       -- Needed by the 'client'
 941              [Segment a])       -- Not needed by the client
 942         -- The result is simply a split of the input
 943     grab uses dus
 944         = (reverse yeses, reverse noes)
 945         where
 946           (noes, yeses)           = span not_needed (reverse dus)
 947           not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
 948
 949
 950 ----------------------------------------------------
 951 segsToStmts :: [Segment [RenamedStmt]] -> ([RenamedStmt], FreeVars)
 952
 953 segsToStmts [] = ([], emptyFVs)
 954 segsToStmts ((defs, uses, fwds, ss) : segs)
 955   = (new_stmt : later_stmts, later_uses `plusFV` uses)
 956   where
 957     (later_stmts, later_uses) = segsToStmts segs
 958     new_stmt | non_rec   = head ss
 959              | otherwise = RecStmt ss (nameSetToList used_later) (nameSetToList fwds) []
 960              where
 961                non_rec    = isSingleton ss && isEmptyNameSet fwds
 962                used_later = defs `intersectNameSet` later_uses
 963                                 -- The ones needed after the RecStmt
 964 \end{code}
 965
 966 %************************************************************************
 967 %*                                                                      *
 968 \subsubsection{Precedence Parsing}
 969 %*                                                                      *
 970 %************************************************************************
 971
 972 @mkOpAppRn@ deals with operator fixities.  The argument expressions
 973 are assumed to be already correctly arranged.  It needs the fixities
 974 recorded in the OpApp nodes, because fixity info applies to the things
 975 the programmer actually wrote, so you can't find it out from the Name.
 976
 977 Furthermore, the second argument is guaranteed not to be another
 978 operator application.  Why? Because the parser parses all
 979 operator appications left-associatively, EXCEPT negation, which
 980 we need to handle specially.
 981
 982 \begin{code}
 983 mkOpAppRn :: RenamedHsExpr                      -- Left operand; already rearranged
 984           -> RenamedHsExpr -> Fixity            -- Operator and fixity
 985           -> RenamedHsExpr                      -- Right operand (not an OpApp, but might
 986                                                 -- be a NegApp)
 987           -> RnM RenamedHsExpr
 988
 989 ---------------------------
 990 -- (e11 `op1` e12) `op2` e2
 991 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
 992   | nofix_error
 993   = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))   `thenM_`
 994     returnM (OpApp e1 op2 fix2 e2)
 995
 996   | associate_right
 997   = mkOpAppRn e12 op2 fix2 e2           `thenM` \ new_e ->
 998     returnM (OpApp e11 op1 fix1 new_e)
 999   where
1000     (nofix_error, associate_right) = compareFixity fix1 fix2
1001
1002 ---------------------------
1003 --      (- neg_arg) `op` e2
1004 mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2
1005   | nofix_error
1006   = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2))      `thenM_`
1007     returnM (OpApp e1 op2 fix2 e2)
1008
1009   | associate_right
1010   = mkOpAppRn neg_arg op2 fix2 e2       `thenM` \ new_e ->
1011     returnM (NegApp new_e neg_name)
1012   where
1013     (nofix_error, associate_right) = compareFixity negateFixity fix2
1014
1015 ---------------------------
1016 --      e1 `op` - neg_arg
1017 mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _)     -- NegApp can occur on the right
1018   | not associate_right                         -- We *want* right association
1019   = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity))    `thenM_`
1020     returnM (OpApp e1 op1 fix1 e2)
1021   where
1022     (_, associate_right) = compareFixity fix1 negateFixity
1023
1024 ---------------------------
1025 --      Default case
1026 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
1027   = ASSERT2( right_op_ok fix e2,
1028              ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
1029     )
1030     returnM (OpApp e1 op fix e2)
1031
1032 -- Parser left-associates everything, but
1033 -- derived instances may have correctly-associated things to
1034 -- in the right operarand.  So we just check that the right operand is OK
1035 right_op_ok fix1 (OpApp _ _ fix2 _)
1036   = not error_please && associate_right
1037   where
1038     (error_please, associate_right) = compareFixity fix1 fix2
1039 right_op_ok fix1 other
1040   = True
1041
1042 -- Parser initially makes negation bind more tightly than any other operator
1043 mkNegAppRn neg_arg neg_name
1044   =
1045 #ifdef DEBUG
1046     getModeRn                   `thenM` \ mode ->
1047     ASSERT( not_op_app mode neg_arg )
1048 #endif
1049     returnM (NegApp neg_arg neg_name)
1050
1051 not_op_app SourceMode (OpApp _ _ _ _) = False
1052 not_op_app mode other                 = True
1053 \end{code}
1054
1055 \begin{code}
1056 checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnM ()
1057
1058 checkPrecMatch False fn match
1059   = returnM ()
1060
1061 checkPrecMatch True op (Match (p1:p2:_) _ _)
1062         -- True indicates an infix lhs
1063   = getModeRn           `thenM` \ mode ->
1064         -- See comments with rnExpr (OpApp ...)
1065     if isInterfaceMode mode
1066         then returnM ()
1067         else checkPrec op p1 False      `thenM_`
1068              checkPrec op p2 True
1069
1070 checkPrecMatch True op _ = panic "checkPrecMatch"
1071
1072 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
1073   = lookupFixityRn op   `thenM` \  op_fix@(Fixity op_prec  op_dir) ->
1074     lookupFixityRn op1  `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
1075     let
1076         inf_ok = op1_prec > op_prec ||
1077                  (op1_prec == op_prec &&
1078                   (op1_dir == InfixR && op_dir == InfixR && right ||
1079                    op1_dir == InfixL && op_dir == InfixL && not right))
1080
1081         info  = (ppr_op op,  op_fix)
1082         info1 = (ppr_op op1, op1_fix)
1083         (infol, infor) = if right then (info, info1) else (info1, info)
1084     in
1085     checkErr inf_ok (precParseErr infol infor)
1086
1087 checkPrec op pat right
1088   = returnM ()
1089
1090 -- Check precedence of (arg op) or (op arg) respectively
1091 -- If arg is itself an operator application, then either
1092 --   (a) its precedence must be higher than that of op
1093 --   (b) its precedency & associativity must be the same as that of op
1094 checkSectionPrec direction section op arg
1095   = case arg of
1096         OpApp _ op fix _ -> go_for_it (ppr_op op)     fix
1097         NegApp _ _       -> go_for_it pp_prefix_minus negateFixity
1098         other            -> returnM ()
1099   where
1100     HsVar op_name = op
1101     go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
1102         = lookupFixityRn op_name        `thenM` \ op_fix@(Fixity op_prec _) ->
1103           checkErr (op_prec < arg_prec
1104                      || op_prec == arg_prec && direction == assoc)
1105                   (sectionPrecErr (ppr_op op_name, op_fix)
1106                   (pp_arg_op, arg_fix) section)
1107 \end{code}
1108
1109
1110 %************************************************************************
1111 %*                                                                      *
1112 \subsubsection{Assertion utils}
1113 %*                                                                      *
1114 %************************************************************************
1115
1116 \begin{code}
1117 mkAssertErrorExpr :: RnM (RenamedHsExpr, FreeVars)
1118 -- Return an expression for (assertError "Foo.hs:27")
1119 mkAssertErrorExpr
1120   = getSrcLocM                          `thenM` \ sloc ->
1121     let
1122         expr = HsApp (HsVar assertErrorName) (HsLit msg)
1123         msg  = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
1124     in
1125     returnM (expr, unitFV assertErrorName)
1126 \end{code}
1127
1128 %************************************************************************
1129 %*                                                                      *
1130 \subsubsection{Errors}
1131 %*                                                                      *
1132 %************************************************************************
1133
1134 \begin{code}
1135 ppr_op op = quotes (ppr op)     -- Here, op can be a Name or a (Var n), where n is a Name
1136 pp_prefix_minus = ptext SLIT("prefix `-'")
1137
1138 nonStdGuardErr guard
1139   = hang (ptext
1140     SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
1141     ) 4 (ppr guard)
1142
1143 patSynErr e
1144   = sep [ptext SLIT("Pattern syntax in expression context:"),
1145          nest 4 (ppr e)]
1146
1147 doStmtListErr do_or_lc e
1148   = sep [quotes (text binder_name) <+> ptext SLIT("statements must end in expression:"),
1149          nest 4 (ppr e)]
1150   where
1151     binder_name = case do_or_lc of
1152                         MDoExpr -> "mdo"
1153                         other   -> "do"
1154
1155 #ifdef GHCI
1156 checkTH e what = returnM ()     -- OK
1157 #else
1158 checkTH e what  -- Raise an error in a stage-1 compiler
1159   = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
1160                   ptext SLIT("illegal in a stage-1 compiler"),
1161                   nest 2 (ppr e)])
1162 #endif
1163
1164 parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglagow-exts"))
1165
1166 badIpBinds binds
1167   = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4
1168          (ppr binds)
1169 \end{code}