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