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