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