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