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