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   = 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   = do  { gbl_env  <- getGblEnv
 644         ; names    <- getLocalDeclBinders gbl_env group
 645         ; rdr_env' <- extendRdrEnvRn (tcg_mod gbl_env) emptyGlobalRdrEnv names
 646
 647         ; setGblEnv (gbl_env { tcg_rdr_env = tcg_rdr_env gbl_env `plusOccEnv` rdr_env',
 648                                tcg_dus = emptyDUs }) $ do
 649                 -- Notice plusOccEnv, not plusGlobalRdrEnv.  In this situation we want
 650                 -- to *shadow* top-level bindings.  E.g.
 651                 --      foo = 1
 652                 --      bar = [d| foo = 1|]
 653                 -- So we drop down to plusOccEnv.  (Perhaps there should be a fn in RdrName.)
 654                 --
 655                 -- The emptyDUs is so that we just collect uses for this group alone
 656
 657         { (tcg_env, group') <- rnSrcDecls group
 658                 -- Discard the tcg_env; it contains only extra info about fixity
 659         ; return (DecBr group', allUses (tcg_dus tcg_env)) } }
 660 \end{code}
 661
 662 %************************************************************************
 663 %*                                                                      *
 664 \subsubsection{@Stmt@s: in @do@ expressions}
 665 %*                                                                      *
 666 %************************************************************************
 667
 668 \begin{code}
 669 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
 670         -> RnM (thing, FreeVars)
 671         -> RnM (([LStmt Name], thing), FreeVars)
 672
 673 rnStmts (MDoExpr _) = rnMDoStmts
 674 rnStmts ctxt        = rnNormalStmts ctxt
 675
 676 rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName]
 677               -> RnM (thing, FreeVars)
 678               -> RnM (([LStmt Name], thing), FreeVars)
 679 -- Used for cases *other* than recursive mdo
 680 -- Implements nested scopes
 681
 682 rnNormalStmts ctxt [] thing_inside
 683   = do  { (thing, fvs) <- thing_inside
 684         ; return (([],thing), fvs) }
 685
 686 rnNormalStmts ctxt (L loc stmt : stmts) thing_inside
 687   = do  { ((stmt', (stmts', thing)), fvs)
 688                 <- rnStmt ctxt stmt     $
 689                    rnNormalStmts ctxt stmts thing_inside
 690         ; return (((L loc stmt' : stmts'), thing), fvs) }
 691
 692 rnStmt :: HsStmtContext Name -> Stmt RdrName
 693        -> RnM (thing, FreeVars)
 694        -> RnM ((Stmt Name, thing), FreeVars)
 695
 696 rnStmt ctxt (ExprStmt expr _ _) thing_inside
 697   = do  { (expr', fv_expr) <- rnLExpr expr
 698         ; (then_op, fvs1)  <- lookupSyntaxName thenMName
 699         ; (thing, fvs2)    <- thing_inside
 700         ; return ((ExprStmt expr' then_op placeHolderType, thing),
 701                   fv_expr `plusFV` fvs1 `plusFV` fvs2) }
 702
 703 rnStmt ctxt (BindStmt pat expr _ _) thing_inside
 704   = do  { (expr', fv_expr) <- rnLExpr expr
 705                 -- The binders do not scope over the expression
 706         ; (bind_op, fvs1) <- lookupSyntaxName bindMName
 707         ; (fail_op, fvs2) <- lookupSyntaxName failMName
 708
 709         ; let reportUnused = case ctxt of
 710                                  ParStmtCtxt{} -> False
 711                                  _ -> True
 712         ; rnPatsAndThen (StmtCtxt ctxt) reportUnused [pat] $ \ [pat'] -> do
 713         { (thing, fvs3) <- thing_inside
 714         ; return ((BindStmt pat' expr' bind_op fail_op, thing),
 715                   fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
 716         -- fv_expr shouldn't really be filtered by
 717         -- the rnPatsAndThen, but it does not matter
 718
 719 rnStmt ctxt (LetStmt binds) thing_inside
 720   = do  { checkErr (ok ctxt binds) (badIpBinds binds)
 721         ; rnBindGroupsAndThen binds             $ \ binds' -> do
 722         { (thing, fvs) <- thing_inside
 723         ; return ((LetStmt binds', thing), fvs) }}
 724   where
 725         -- We do not allow implicit-parameter bindings in a parallel
 726         -- list comprehension.  I'm not sure what it might mean.
 727     ok (ParStmtCtxt _) binds = not (any is_ip_bind binds)
 728     ok _               _     = True
 729
 730     is_ip_bind (HsIPBinds _) = True
 731     is_ip_bind _             = False
 732
 733 rnStmt ctxt (ParStmt stmtss) thing_inside
 734   = do  { opt_GlasgowExts <- doptM Opt_GlasgowExts
 735         ; checkM opt_GlasgowExts parStmtErr
 736         ; (stmtss'_w_unit, fv_stmtss) <- mapFvRn rn_branch stmtss
 737         ; let
 738             bndrss :: [[Name]]  -- NB: Name, not RdrName
 739             bndrss        = map (map unLoc . collectLStmtsBinders) stmtss'
 740             (bndrs, dups) = removeDups cmpByOcc (concat bndrss)
 741             stmtss'       = map fst stmtss'_w_unit
 742         ; mappM dupErr dups
 743
 744         ; bindLocalNamesFV bndrs $ do
 745         { (thing, fvs) <- thing_inside
 746         -- Note: binders are returned in scope order, so one may
 747         --       shadow the next; e.g. x <- xs; x <- ys
 748
 749         -- Cut down the exported binders to just the ones needed in the body
 750         ; let   used_bndrs_s = map (filter (`elemNameSet` fvs)) bndrss
 751                 unused_bndrs = filter (not . (`elemNameSet` fvs)) bndrs
 752
 753      -- With processing of the branches and the tail of comprehension done,
 754      -- we can finally compute&report any unused ParStmt binders.
 755         ; warnUnusedMatches unused_bndrs
 756         ; return ((ParStmt (stmtss' `zip` used_bndrs_s), thing),
 757                   fv_stmtss `plusFV` fvs) }}
 758   where
 759     rn_branch (stmts, _) = rnNormalStmts (ParStmtCtxt ctxt) stmts $
 760                            return ((), emptyFVs)
 761
 762     cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
 763     dupErr vs = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:")
 764                         <+> quotes (ppr (head vs)))
 765
 766 rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside
 767   = bindLocatedLocalsRn doc (collectLStmtsBinders rec_stmts)    $ \ _ ->
 768     rn_rec_stmts rec_stmts              `thenM` \ segs ->
 769     thing_inside                        `thenM` \ (thing, fvs) ->
 770     let
 771         segs_w_fwd_refs          = addFwdRefs segs
 772         (ds, us, fs, rec_stmts') = unzip4 segs_w_fwd_refs
 773         later_vars = nameSetToList (plusFVs ds `intersectNameSet` fvs)
 774         fwd_vars   = nameSetToList (plusFVs fs)
 775         uses       = plusFVs us
 776         rec_stmt   = RecStmt rec_stmts' later_vars fwd_vars [] emptyLHsBinds
 777     in
 778     returnM ((rec_stmt, thing), uses `plusFV` fvs)
 779   where
 780     doc = text "In a recursive do statement"
 781 \end{code}
 782
 783
 784 %************************************************************************
 785 %*                                                                      *
 786 \subsubsection{mdo expressions}
 787 %*                                                                      *
 788 %************************************************************************
 789
 790 \begin{code}
 791 type FwdRefs = NameSet
 792 type Segment stmts = (Defs,
 793                       Uses,     -- May include defs
 794                       FwdRefs,  -- A subset of uses that are
 795                                 --   (a) used before they are bound in this segment, or
 796                                 --   (b) used here, and bound in subsequent segments
 797                       stmts)    -- Either Stmt or [Stmt]
 798
 799
 800 ----------------------------------------------------
 801 rnMDoStmts :: [LStmt RdrName]
 802            -> RnM (thing, FreeVars)
 803            -> RnM (([LStmt Name], thing), FreeVars)
 804 rnMDoStmts stmts thing_inside
 805   =     -- Step1: bring all the binders of the mdo into scope
 806         -- Remember that this also removes the binders from the
 807         -- finally-returned free-vars
 808     bindLocatedLocalsRn doc (collectLStmtsBinders stmts)        $ \ _ ->
 809     do  {
 810         -- Step 2: Rename each individual stmt, making a
 811         --         singleton segment.  At this stage the FwdRefs field
 812         --         isn't finished: it's empty for all except a BindStmt
 813         --         for which it's the fwd refs within the bind itself
 814         --         (This set may not be empty, because we're in a recursive
 815         --          context.)
 816           segs <- rn_rec_stmts stmts
 817
 818         ; (thing, fvs_later) <- thing_inside
 819
 820         ; let
 821         -- Step 3: Fill in the fwd refs.
 822         --         The segments are all singletons, but their fwd-ref
 823         --         field mentions all the things used by the segment
 824         --         that are bound after their use
 825             segs_w_fwd_refs = addFwdRefs segs
 826
 827         -- Step 4: Group together the segments to make bigger segments
 828         --         Invariant: in the result, no segment uses a variable
 829         --                    bound in a later segment
 830             grouped_segs = glomSegments segs_w_fwd_refs
 831
 832         -- Step 5: Turn the segments into Stmts
 833         --         Use RecStmt when and only when there are fwd refs
 834         --         Also gather up the uses from the end towards the
 835         --         start, so we can tell the RecStmt which things are
 836         --         used 'after' the RecStmt
 837             (stmts', fvs) = segsToStmts grouped_segs fvs_later
 838
 839         ; return ((stmts', thing), fvs) }
 840   where
 841     doc = text "In a recursive mdo-expression"
 842
 843
 844 ----------------------------------------------------
 845 rn_rec_stmt :: LStmt RdrName -> RnM [Segment (LStmt Name)]
 846         -- Rename a Stmt that is inside a RecStmt (or mdo)
 847         -- Assumes all binders are already in scope
 848         -- Turns each stmt into a singleton Stmt
 849
 850 rn_rec_stmt (L loc (ExprStmt expr _ _))
 851   = rnLExpr expr                `thenM` \ (expr', fvs) ->
 852     lookupSyntaxName thenMName  `thenM` \ (then_op, fvs1) ->
 853     returnM [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
 854               L loc (ExprStmt expr' then_op placeHolderType))]
 855
 856 rn_rec_stmt (L loc (BindStmt pat expr _ _))
 857   = rnLExpr expr                `thenM` \ (expr', fv_expr) ->
 858     rnLPat pat                  `thenM` \ (pat', fv_pat) ->
 859     lookupSyntaxName bindMName  `thenM` \ (bind_op, fvs1) ->
 860     lookupSyntaxName failMName  `thenM` \ (fail_op, fvs2) ->
 861     let
 862         bndrs = mkNameSet (collectPatBinders pat')
 863         fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
 864     in
 865     returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs,
 866               L loc (BindStmt pat' expr' bind_op fail_op))]
 867
 868 rn_rec_stmt (L loc (LetStmt binds))
 869   = rnBindGroups binds          `thenM` \ (binds', du_binds) ->
 870     returnM [(duDefs du_binds, duUses du_binds,
 871               emptyNameSet, L loc (LetStmt binds'))]
 872
 873 rn_rec_stmt (L loc (RecStmt stmts _ _ _ _))     -- Flatten Rec inside Rec
 874   = rn_rec_stmts stmts
 875
 876 rn_rec_stmt stmt@(L _ (ParStmt _))      -- Syntactically illegal in mdo
 877   = pprPanic "rn_rec_stmt" (ppr stmt)
 878
 879 ---------------------------------------------
 880 rn_rec_stmts :: [LStmt RdrName] -> RnM [Segment (LStmt Name)]
 881 rn_rec_stmts stmts = mappM rn_rec_stmt stmts    `thenM` \ segs_s ->
 882                      returnM (concat segs_s)
 883
 884
 885 ---------------------------------------------
 886 addFwdRefs :: [Segment a] -> [Segment a]
 887 -- So far the segments only have forward refs *within* the Stmt
 888 --      (which happens for bind:  x <- ...x...)
 889 -- This function adds the cross-seg fwd ref info
 890
 891 addFwdRefs pairs
 892   = fst (foldr mk_seg ([], emptyNameSet) pairs)
 893   where
 894     mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
 895         = (new_seg : segs, all_defs)
 896         where
 897           new_seg = (defs, uses, new_fwds, stmts)
 898           all_defs = later_defs `unionNameSets` defs
 899           new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
 900                 -- Add the downstream fwd refs here
 901
 902 ----------------------------------------------------
 903 --      Glomming the singleton segments of an mdo into
 904 --      minimal recursive groups.
 905 --
 906 -- At first I thought this was just strongly connected components, but
 907 -- there's an important constraint: the order of the stmts must not change.
 908 --
 909 -- Consider
 910 --      mdo { x <- ...y...
 911 --            p <- z
 912 --            y <- ...x...
 913 --            q <- x
 914 --            z <- y
 915 --            r <- x }
 916 --
 917 -- Here, the first stmt mention 'y', which is bound in the third.
 918 -- But that means that the innocent second stmt (p <- z) gets caught
 919 -- up in the recursion.  And that in turn means that the binding for
 920 -- 'z' has to be included... and so on.
 921 --
 922 -- Start at the tail { r <- x }
 923 -- Now add the next one { z <- y ; r <- x }
 924 -- Now add one more     { q <- x ; z <- y ; r <- x }
 925 -- Now one more... but this time we have to group a bunch into rec
 926 --      { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
 927 -- Now one more, which we can add on without a rec
 928 --      { p <- z ;
 929 --        rec { y <- ...x... ; q <- x ; z <- y } ;
 930 --        r <- x }
 931 -- Finally we add the last one; since it mentions y we have to
 932 -- glom it togeher with the first two groups
 933 --      { rec { x <- ...y...; p <- z ; y <- ...x... ;
 934 --              q <- x ; z <- y } ;
 935 --        r <- x }
 936
 937 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
 938
 939 glomSegments [] = []
 940 glomSegments ((defs,uses,fwds,stmt) : segs)
 941         -- Actually stmts will always be a singleton
 942   = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others
 943   where
 944     segs'            = glomSegments segs
 945     (extras, others) = grab uses segs'
 946     (ds, us, fs, ss) = unzip4 extras
 947
 948     seg_defs  = plusFVs ds `plusFV` defs
 949     seg_uses  = plusFVs us `plusFV` uses
 950     seg_fwds  = plusFVs fs `plusFV` fwds
 951     seg_stmts = stmt : concat ss
 952
 953     grab :: NameSet             -- The client
 954          -> [Segment a]
 955          -> ([Segment a],       -- Needed by the 'client'
 956              [Segment a])       -- Not needed by the client
 957         -- The result is simply a split of the input
 958     grab uses dus
 959         = (reverse yeses, reverse noes)
 960         where
 961           (noes, yeses)           = span not_needed (reverse dus)
 962           not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
 963
 964
 965 ----------------------------------------------------
 966 segsToStmts :: [Segment [LStmt Name]]
 967             -> FreeVars                 -- Free vars used 'later'
 968             -> ([LStmt Name], FreeVars)
 969
 970 segsToStmts [] fvs_later = ([], fvs_later)
 971 segsToStmts ((defs, uses, fwds, ss) : segs) fvs_later
 972   = ASSERT( not (null ss) )
 973     (new_stmt : later_stmts, later_uses `plusFV` uses)
 974   where
 975     (later_stmts, later_uses) = segsToStmts segs fvs_later
 976     new_stmt | non_rec   = head ss
 977              | otherwise = L (getLoc (head ss)) $
 978                            RecStmt ss (nameSetToList used_later) (nameSetToList fwds)
 979                                       [] emptyLHsBinds
 980              where
 981                non_rec    = isSingleton ss && isEmptyNameSet fwds
 982                used_later = defs `intersectNameSet` later_uses
 983                                 -- The ones needed after the RecStmt
 984 \end{code}
 985
 986 %************************************************************************
 987 %*                                                                      *
 988 \subsubsection{Precedence Parsing}
 989 %*                                                                      *
 990 %************************************************************************
 991
 992 @mkOpAppRn@ deals with operator fixities.  The argument expressions
 993 are assumed to be already correctly arranged.  It needs the fixities
 994 recorded in the OpApp nodes, because fixity info applies to the things
 995 the programmer actually wrote, so you can't find it out from the Name.
 996
 997 Furthermore, the second argument is guaranteed not to be another
 998 operator application.  Why? Because the parser parses all
 999 operator appications left-associatively, EXCEPT negation, which
1000 we need to handle specially.
1001
1002 \begin{code}
1003 mkOpAppRn :: LHsExpr Name                       -- Left operand; already rearranged
1004           -> LHsExpr Name -> Fixity             -- Operator and fixity
1005           -> LHsExpr Name                       -- Right operand (not an OpApp, but might
1006                                                 -- be a NegApp)
1007           -> RnM (HsExpr Name)
1008
1009 ---------------------------
1010 -- (e11 `op1` e12) `op2` e2
1011 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
1012   | nofix_error
1013   = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))   `thenM_`
1014     returnM (OpApp e1 op2 fix2 e2)
1015
1016   | associate_right
1017   = mkOpAppRn e12 op2 fix2 e2           `thenM` \ new_e ->
1018     returnM (OpApp e11 op1 fix1 (L loc' new_e))
1019   where
1020     loc'= combineLocs e12 e2
1021     (nofix_error, associate_right) = compareFixity fix1 fix2
1022
1023 ---------------------------
1024 --      (- neg_arg) `op` e2
1025 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
1026   | nofix_error
1027   = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2))      `thenM_`
1028     returnM (OpApp e1 op2 fix2 e2)
1029
1030   | associate_right
1031   = mkOpAppRn neg_arg op2 fix2 e2       `thenM` \ new_e ->
1032     returnM (NegApp (L loc' new_e) neg_name)
1033   where
1034     loc' = combineLocs neg_arg e2
1035     (nofix_error, associate_right) = compareFixity negateFixity fix2
1036
1037 ---------------------------
1038 --      e1 `op` - neg_arg
1039 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp neg_arg _))       -- NegApp can occur on the right
1040   | not associate_right                         -- We *want* right association
1041   = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity))    `thenM_`
1042     returnM (OpApp e1 op1 fix1 e2)
1043   where
1044     (_, associate_right) = compareFixity fix1 negateFixity
1045
1046 ---------------------------
1047 --      Default case
1048 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
1049   = ASSERT2( right_op_ok fix (unLoc e2),
1050              ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
1051     )
1052     returnM (OpApp e1 op fix e2)
1053
1054 -- Parser left-associates everything, but
1055 -- derived instances may have correctly-associated things to
1056 -- in the right operarand.  So we just check that the right operand is OK
1057 right_op_ok fix1 (OpApp _ _ fix2 _)
1058   = not error_please && associate_right
1059   where
1060     (error_please, associate_right) = compareFixity fix1 fix2
1061 right_op_ok fix1 other
1062   = True
1063
1064 -- Parser initially makes negation bind more tightly than any other operator
1065 -- And "deriving" code should respect this (use HsPar if not)
1066 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
1067 mkNegAppRn neg_arg neg_name
1068   = ASSERT( not_op_app (unLoc neg_arg) )
1069     returnM (NegApp neg_arg neg_name)
1070
1071 not_op_app (OpApp _ _ _ _) = False
1072 not_op_app other           = True
1073 \end{code}
1074
1075 \begin{code}
1076 checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM ()
1077         -- True indicates an infix lhs
1078         -- See comments with rnExpr (OpApp ...) about "deriving"
1079
1080 checkPrecMatch False fn match
1081   = returnM ()
1082 checkPrecMatch True op (MatchGroup ms _)
1083   = mapM_ check ms
1084   where
1085     check (L _ (Match (p1:p2:_) _ _))
1086       = checkPrec op (unLoc p1) False   `thenM_`
1087         checkPrec op (unLoc p2) True
1088
1089     check _ = panic "checkPrecMatch"
1090
1091 checkPrec op (ConPatIn op1 (InfixCon _ _)) right
1092   = lookupFixityRn op           `thenM` \  op_fix@(Fixity op_prec  op_dir) ->
1093     lookupFixityRn (unLoc op1)  `thenM` \ op1_fix@(Fixity op1_prec op1_dir) ->
1094     let
1095         inf_ok = op1_prec > op_prec ||
1096                  (op1_prec == op_prec &&
1097                   (op1_dir == InfixR && op_dir == InfixR && right ||
1098                    op1_dir == InfixL && op_dir == InfixL && not right))
1099
1100         info  = (ppr_op op,  op_fix)
1101         info1 = (ppr_op op1, op1_fix)
1102         (infol, infor) = if right then (info, info1) else (info1, info)
1103     in
1104     checkErr inf_ok (precParseErr infol infor)
1105
1106 checkPrec op pat right
1107   = returnM ()
1108
1109 -- Check precedence of (arg op) or (op arg) respectively
1110 -- If arg is itself an operator application, then either
1111 --   (a) its precedence must be higher than that of op
1112 --   (b) its precedency & associativity must be the same as that of op
1113 checkSectionPrec :: FixityDirection -> HsExpr RdrName
1114         -> LHsExpr Name -> LHsExpr Name -> RnM ()
1115 checkSectionPrec direction section op arg
1116   = case unLoc arg of
1117         OpApp _ op fix _ -> go_for_it (ppr_op op)     fix
1118         NegApp _ _       -> go_for_it pp_prefix_minus negateFixity
1119         other            -> returnM ()
1120   where
1121     L _ (HsVar op_name) = op
1122     go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc)
1123         = lookupFixityRn op_name        `thenM` \ op_fix@(Fixity op_prec _) ->
1124           checkErr (op_prec < arg_prec
1125                      || op_prec == arg_prec && direction == assoc)
1126                   (sectionPrecErr (ppr_op op_name, op_fix)
1127                   (pp_arg_op, arg_fix) section)
1128 \end{code}
1129
1130
1131 %************************************************************************
1132 %*                                                                      *
1133 \subsubsection{Assertion utils}
1134 %*                                                                      *
1135 %************************************************************************
1136
1137 \begin{code}
1138 mkAssertErrorExpr :: RnM (HsExpr Name, FreeVars)
1139 -- Return an expression for (assertError "Foo.hs:27")
1140 mkAssertErrorExpr
1141   = getSrcSpanM                         `thenM` \ sloc ->
1142     let
1143         expr = HsApp (L sloc (HsVar assertErrorName)) (L sloc (HsLit msg))
1144         msg  = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc))))
1145     in
1146     returnM (expr, emptyFVs)
1147 \end{code}
1148
1149 %************************************************************************
1150 %*                                                                      *
1151 \subsubsection{Errors}
1152 %*                                                                      *
1153 %************************************************************************
1154
1155 \begin{code}
1156 ppr_op op = quotes (ppr op)     -- Here, op can be a Name or a (Var n), where n is a Name
1157 pp_prefix_minus = ptext SLIT("prefix `-'")
1158
1159 nonStdGuardErr guard
1160   = hang (ptext
1161     SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
1162     ) 4 (ppr guard)
1163
1164 patSynErr e
1165   = sep [ptext SLIT("Pattern syntax in expression context:"),
1166          nest 4 (ppr e)]
1167
1168 #ifdef GHCI
1169 checkTH e what = returnM ()     -- OK
1170 #else
1171 checkTH e what  -- Raise an error in a stage-1 compiler
1172   = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
1173                   ptext SLIT("illegal in a stage-1 compiler"),
1174                   nest 2 (ppr e)])
1175 #endif
1176
1177 parStmtErr = addErr (ptext SLIT("Illegal parallel list comprehension: use -fglasgow-exts"))
1178
1179 badIpBinds binds
1180   = hang (ptext SLIT("Implicit-parameter bindings illegal in a parallel list comprehension:")) 4
1181          (ppr binds)
1182 \end{code}