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