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