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