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