ghc/compiler/rename/RnExpr.lhs

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