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