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