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