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         rnLExpr, rnExpr, rnStmts
  15    ) where
  16
  17 #include "HsVersions.h"
  18
  19 #ifdef GHCI
  20 import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr )
  21 #endif  /* GHCI */
  22
  23 import RnSource  ( rnSrcDecls, findSplice )
  24 import RnBinds   ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
  25                    rnMatchGroup, makeMiniFixityEnv)
  26 import HsSyn
  27 import TcRnMonad
  28 import TcEnv            ( thRnBrack, getHetMetLevel )
  29 import RnEnv
  30 import RnTypes          ( rnHsTypeFVs, rnSplice, checkTH,
  31                           mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec)
  32 import RnPat
  33 import DynFlags
  34 import BasicTypes       ( FixityDirection(..) )
  35 import PrelNames
  36
  37 import Var              ( TyVar, varName )
  38 import Name
  39 import NameSet
  40 import RdrName
  41 import LoadIface        ( loadInterfaceForName )
  42 import UniqSet
  43 import Data.List
  44 import Util             ( isSingleton )
  45 import ListSetOps       ( removeDups )
  46 import Outputable
  47 import SrcLoc
  48 import FastString
  49 import Control.Monad
  50 \end{code}
  51
  52
  53 \begin{code}
  54 -- XXX
  55 thenM :: Monad a => a b -> (b -> a c) -> a c
  56 thenM = (>>=)
  57
  58 thenM_ :: Monad a => a b -> a c -> a c
  59 thenM_ = (>>)
  60 \end{code}
  61
  62 %************************************************************************
  63 %*                                                                      *
  64 \subsubsection{Expressions}
  65 %*                                                                      *
  66 %************************************************************************
  67
  68 \begin{code}
  69 rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars)
  70 rnExprs ls = rnExprs' ls emptyUniqSet
  71  where
  72   rnExprs' [] acc = return ([], acc)
  73   rnExprs' (expr:exprs) acc
  74    = rnLExpr expr               `thenM` \ (expr', fvExpr) ->
  75
  76         -- Now we do a "seq" on the free vars because typically it's small
  77         -- or empty, especially in very long lists of constants
  78     let
  79         acc' = acc `plusFV` fvExpr
  80     in
  81     acc' `seq` rnExprs' exprs acc' `thenM` \ (exprs', fvExprs) ->
  82     return (expr':exprs', fvExprs)
  83 \end{code}
  84
  85 Variables. We look up the variable and return the resulting name.
  86
  87 \begin{code}
  88
  89 -- during the renamer phase we only care about the length of the
  90 -- current HetMet level; the actual tyvars don't
  91 -- matter, so we use bottoms for them
  92 dummyTyVar :: TyVar
  93 dummyTyVar = error "tried to force RnExpr.dummyTyVar"
  94
  95 rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars)
  96 rnLExpr = wrapLocFstM rnExpr
  97
  98 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
  99
 100 finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
 101 -- Separated from rnExpr because it's also used
 102 -- when renaming infix expressions
 103 -- See Note [Adding the implicit parameter to 'assert']
 104 finishHsVar name
 105  = do { ignore_asserts <- doptM Opt_IgnoreAsserts
 106       ; if ignore_asserts || not (name `hasKey` assertIdKey)
 107         then return (HsVar name, unitFV name)
 108         else do { e <- mkAssertErrorExpr
 109                 ; return (e, unitFV name) } }
 110
 111 rnExpr (HsVar v)
 112   = do name <- lookupOccRn v
 113        finishHsVar name
 114
 115 rnExpr (HsIPVar v)
 116   = newIPNameRn v               `thenM` \ name ->
 117     return (HsIPVar name, emptyFVs)
 118
 119 rnExpr (HsLit lit@(HsString s))
 120   = do {
 121          opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
 122        ; if opt_OverloadedStrings then
 123             rnExpr (HsOverLit (mkHsIsString s placeHolderType))
 124          else -- Same as below
 125             rnLit lit           `thenM_`
 126             return (HsLit lit, emptyFVs)
 127        }
 128
 129 rnExpr (HsLit lit)
 130   = rnLit lit           `thenM_`
 131     return (HsLit lit, emptyFVs)
 132
 133 rnExpr (HsOverLit lit)
 134   = rnOverLit lit               `thenM` \ (lit', fvs) ->
 135     return (HsOverLit lit', fvs)
 136
 137 rnExpr (HsApp fun arg)
 138   = rnLExpr fun         `thenM` \ (fun',fvFun) ->
 139     rnLExpr arg         `thenM` \ (arg',fvArg) ->
 140     return (HsApp fun' arg', fvFun `plusFV` fvArg)
 141
 142 rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2)
 143   = do  { (e1', fv_e1) <- rnLExpr e1
 144         ; (e2', fv_e2) <- rnLExpr e2
 145         ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr)
 146         ; (op', fv_op) <- finishHsVar op_name
 147                 -- NB: op' is usually just a variable, but might be
 148                 --     an applicatoin (assert "Foo.hs:47")
 149         -- Deal with fixity
 150         -- When renaming code synthesised from "deriving" declarations
 151         -- we used to avoid fixity stuff, but we can't easily tell any
 152         -- more, so I've removed the test.  Adding HsPars in TcGenDeriv
 153         -- should prevent bad things happening.
 154         ; fixity <- lookupFixityRn op_name
 155         ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2'
 156         ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
 157 rnExpr (OpApp _ other_op _ _)
 158   = failWith (vcat [ hang (ptext (sLit "Operator application with a non-variable operator:"))
 159                         2 (ppr other_op)
 160                    , ptext (sLit "(Probably resulting from a Template Haskell splice)") ])
 161
 162 rnExpr (NegApp e _)
 163   = rnLExpr e                   `thenM` \ (e', fv_e) ->
 164     lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) ->
 165     mkNegAppRn e' neg_name      `thenM` \ final_e ->
 166     return (final_e, fv_e `plusFV` fv_neg)
 167
 168 rnExpr (HsHetMetBrak c e)
 169   = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = dummyTyVar:(tcl_hetMetLevel x) }) $ rnLExpr e
 170        ; return (HsHetMetBrak c e', fv_e)
 171        }
 172 rnExpr (HsHetMetEsc c t e)
 173   = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = tail (tcl_hetMetLevel x) }) $ rnLExpr e
 174        ; return (HsHetMetEsc c t e', fv_e)
 175        }
 176 rnExpr (HsHetMetCSP c e)
 177   = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = tail (tcl_hetMetLevel x) }) $ rnLExpr e
 178        ; return (HsHetMetCSP c e', fv_e)
 179        }
 180
 181
 182
 183 ------------------------------------------
 184 -- Template Haskell extensions
 185 -- Don't ifdef-GHCI them because we want to fail gracefully
 186 -- (not with an rnExpr crash) in a stage-1 compiler.
 187 rnExpr e@(HsBracket br_body)
 188   = checkTH e "bracket"         `thenM_`
 189     rnBracket br_body           `thenM` \ (body', fvs_e) ->
 190     return (HsBracket body', fvs_e)
 191
 192 rnExpr (HsSpliceE splice)
 193   = rnSplice splice             `thenM` \ (splice', fvs) ->
 194     return (HsSpliceE splice', fvs)
 195
 196 #ifndef GHCI
 197 rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e)
 198 #else
 199 rnExpr (HsQuasiQuoteE qq)
 200   = runQuasiQuoteExpr qq        `thenM` \ (L _ expr') ->
 201     rnExpr expr'
 202 #endif  /* GHCI */
 203
 204 ---------------------------------------------
 205 --      Sections
 206 -- See Note [Parsing sections] in Parser.y.pp
 207 rnExpr (HsPar (L loc (section@(SectionL {}))))
 208   = do  { (section', fvs) <- rnSection section
 209         ; return (HsPar (L loc section'), fvs) }
 210
 211 rnExpr (HsPar (L loc (section@(SectionR {}))))
 212   = do  { (section', fvs) <- rnSection section
 213         ; return (HsPar (L loc section'), fvs) }
 214
 215 rnExpr (HsPar e)
 216   = do  { (e', fvs_e) <- rnLExpr e
 217         ; return (HsPar e', fvs_e) }
 218
 219 rnExpr expr@(SectionL {})
 220   = do  { addErr (sectionErr expr); rnSection expr }
 221 rnExpr expr@(SectionR {})
 222   = do  { addErr (sectionErr expr); rnSection expr }
 223
 224 ---------------------------------------------
 225 rnExpr (HsCoreAnn ann expr)
 226   = rnLExpr expr `thenM` \ (expr', fvs_expr) ->
 227     return (HsCoreAnn ann expr', fvs_expr)
 228
 229 rnExpr (HsSCC lbl expr)
 230   = rnLExpr expr                `thenM` \ (expr', fvs_expr) ->
 231     return (HsSCC lbl expr', fvs_expr)
 232 rnExpr (HsTickPragma info expr)
 233   = rnLExpr expr                `thenM` \ (expr', fvs_expr) ->
 234     return (HsTickPragma info expr', fvs_expr)
 235
 236 rnExpr (HsLam matches)
 237   = rnMatchGroup LambdaExpr matches     `thenM` \ (matches', fvMatch) ->
 238     return (HsLam matches', fvMatch)
 239
 240 rnExpr (HsCase expr matches)
 241   = rnLExpr expr                        `thenM` \ (new_expr, e_fvs) ->
 242     rnMatchGroup CaseAlt matches        `thenM` \ (new_matches, ms_fvs) ->
 243     return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs)
 244
 245 rnExpr (HsLet binds expr)
 246   = rnLocalBindsAndThen binds           $ \ binds' ->
 247     rnLExpr expr                         `thenM` \ (expr',fvExpr) ->
 248     return (HsLet binds' expr', fvExpr)
 249
 250 rnExpr (HsDo do_or_lc stmts body _)
 251   = do  { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $ \ _ ->
 252                                     rnLExpr body
 253         ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) }
 254
 255 rnExpr (ExplicitList _ exps)
 256   = rnExprs exps                        `thenM` \ (exps', fvs) ->
 257     return  (ExplicitList placeHolderType exps', fvs)
 258
 259 rnExpr (ExplicitPArr _ exps)
 260   = rnExprs exps                        `thenM` \ (exps', fvs) ->
 261     return  (ExplicitPArr placeHolderType exps', fvs)
 262
 263 rnExpr (ExplicitTuple tup_args boxity)
 264   = do { checkTupleSection tup_args
 265        ; checkTupSize (length tup_args)
 266        ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args
 267        ; return (ExplicitTuple tup_args' boxity, plusFVs fvs) }
 268   where
 269     rnTupArg (Present e) = do { (e',fvs) <- rnLExpr e; return (Present e', fvs) }
 270     rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs)
 271
 272 rnExpr (RecordCon con_id _ rbinds)
 273   = do  { conname <- lookupLocatedOccRn con_id
 274         ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
 275         ; return (RecordCon conname noPostTcExpr rbinds',
 276                   fvRbinds `addOneFV` unLoc conname) }
 277
 278 rnExpr (RecordUpd expr rbinds _ _ _)
 279   = do  { (expr', fvExpr) <- rnLExpr expr
 280         ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds
 281         ; return (RecordUpd expr' rbinds' [] [] [],
 282                   fvExpr `plusFV` fvRbinds) }
 283
 284 rnExpr (ExprWithTySig expr pty)
 285   = do  { (pty', fvTy) <- rnHsTypeFVs doc pty
 286         ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $
 287                              rnLExpr expr
 288         ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
 289   where
 290     doc = text "In an expression type signature"
 291
 292 rnExpr (HsIf _ p b1 b2)
 293   = do { (p', fvP) <- rnLExpr p
 294     ; (b1', fvB1) <- rnLExpr b1
 295     ; (b2', fvB2) <- rnLExpr b2
 296     ; rebind <- xoptM Opt_RebindableSyntax
 297     ; if not rebind
 298        then return (HsIf Nothing p' b1' b2', plusFVs [fvP, fvB1, fvB2])
 299        else do { hetMetLevel <- getHetMetLevel
 300                ; n <- lookupOccRn $ mkRdrUnqual $ setOccNameDepth (length hetMetLevel) (mkVarOccFS (fsLit "ifThenElse"))
 301                ; c <- return $ HsVar n
 302                ; return (HsIf (Just c) p' b1' b2', plusFVs [fvP, fvB1, fvB2]) }}
 303
 304 rnExpr (HsType a)
 305   = rnHsTypeFVs doc a   `thenM` \ (t, fvT) ->
 306     return (HsType t, fvT)
 307   where
 308     doc = text "In a type argument"
 309
 310 rnExpr (ArithSeq _ seq)
 311   = rnArithSeq seq       `thenM` \ (new_seq, fvs) ->
 312     return (ArithSeq noPostTcExpr new_seq, fvs)
 313
 314 rnExpr (PArrSeq _ seq)
 315   = rnArithSeq seq       `thenM` \ (new_seq, fvs) ->
 316     return (PArrSeq noPostTcExpr new_seq, fvs)
 317 \end{code}
 318
 319 These three are pattern syntax appearing in expressions.
 320 Since all the symbols are reservedops we can simply reject them.
 321 We return a (bogus) EWildPat in each case.
 322
 323 \begin{code}
 324 rnExpr e@EWildPat      = patSynErr e
 325 rnExpr e@(EAsPat {})   = patSynErr e
 326 rnExpr e@(EViewPat {}) = patSynErr e
 327 rnExpr e@(ELazyPat {}) = patSynErr e
 328 \end{code}
 329
 330 %************************************************************************
 331 %*                                                                      *
 332         Arrow notation
 333 %*                                                                      *
 334 %************************************************************************
 335
 336 \begin{code}
 337 rnExpr (HsProc pat body)
 338   = newArrowScope $
 339     rnPat ProcExpr pat $ \ pat' ->
 340     rnCmdTop body                `thenM` \ (body',fvBody) ->
 341     return (HsProc pat' body', fvBody)
 342
 343 rnExpr (HsArrApp arrow arg _ ho rtl)
 344   = select_arrow_scope (rnLExpr arrow)  `thenM` \ (arrow',fvArrow) ->
 345     rnLExpr arg                         `thenM` \ (arg',fvArg) ->
 346     return (HsArrApp arrow' arg' placeHolderType ho rtl,
 347              fvArrow `plusFV` fvArg)
 348   where
 349     select_arrow_scope tc = case ho of
 350         HsHigherOrderApp -> tc
 351         HsFirstOrderApp  -> escapeArrowScope tc
 352
 353 -- infix form
 354 rnExpr (HsArrForm op (Just _) [arg1, arg2])
 355   = escapeArrowScope (rnLExpr op)
 356                         `thenM` \ (op',fv_op) ->
 357     let L _ (HsVar op_name) = op' in
 358     rnCmdTop arg1       `thenM` \ (arg1',fv_arg1) ->
 359     rnCmdTop arg2       `thenM` \ (arg2',fv_arg2) ->
 360
 361         -- Deal with fixity
 362
 363     lookupFixityRn op_name              `thenM` \ fixity ->
 364     mkOpFormRn arg1' op' fixity arg2'   `thenM` \ final_e ->
 365
 366     return (final_e,
 367               fv_arg1 `plusFV` fv_op `plusFV` fv_arg2)
 368
 369 rnExpr (HsArrForm op fixity cmds)
 370   = escapeArrowScope (rnLExpr op)       `thenM` \ (op',fvOp) ->
 371     rnCmdArgs cmds                      `thenM` \ (cmds',fvCmds) ->
 372     return (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds)
 373
 374 rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)
 375         -- HsWrap
 376
 377 ----------------------
 378 -- See Note [Parsing sections] in Parser.y.pp
 379 rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
 380 rnSection section@(SectionR op expr)
 381   = do  { (op', fvs_op)     <- rnLExpr op
 382         ; (expr', fvs_expr) <- rnLExpr expr
 383         ; checkSectionPrec InfixR section op' expr'
 384         ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) }
 385
 386 rnSection section@(SectionL expr op)
 387   = do  { (expr', fvs_expr) <- rnLExpr expr
 388         ; (op', fvs_op)     <- rnLExpr op
 389         ; checkSectionPrec InfixL section op' expr'
 390         ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) }
 391
 392 rnSection other = pprPanic "rnSection" (ppr other)
 393 \end{code}
 394
 395 %************************************************************************
 396 %*                                                                      *
 397         Records
 398 %*                                                                      *
 399 %************************************************************************
 400
 401 \begin{code}
 402 rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
 403              -> RnM (HsRecordBinds Name, FreeVars)
 404 rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
 405   = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds
 406        ; (flds', fvss) <- mapAndUnzipM rn_field flds
 407        ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
 408                  fvs `plusFV` plusFVs fvss) }
 409   where
 410     rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
 411                       ; return (fld { hsRecFieldArg = arg' }, fvs) }
 412 \end{code}
 413
 414
 415 %************************************************************************
 416 %*                                                                      *
 417         Arrow commands
 418 %*                                                                      *
 419 %************************************************************************
 420
 421 \begin{code}
 422 rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars)
 423 rnCmdArgs [] = return ([], emptyFVs)
 424 rnCmdArgs (arg:args)
 425   = rnCmdTop arg        `thenM` \ (arg',fvArg) ->
 426     rnCmdArgs args      `thenM` \ (args',fvArgs) ->
 427     return (arg':args', fvArg `plusFV` fvArgs)
 428
 429 rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars)
 430 rnCmdTop = wrapLocFstM rnCmdTop'
 431  where
 432   rnCmdTop' (HsCmdTop cmd _ _ _)
 433    = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) ->
 434      let
 435         cmd_names = [arrAName, composeAName, firstAName] ++
 436                     nameSetToList (methodNamesCmd (unLoc cmd'))
 437      in
 438         -- Generate the rebindable syntax for the monad
 439      lookupSyntaxTable cmd_names        `thenM` \ (cmd_names', cmd_fvs) ->
 440
 441      return (HsCmdTop cmd' [] placeHolderType cmd_names',
 442              fvCmd `plusFV` cmd_fvs)
 443
 444 ---------------------------------------------------
 445 -- convert OpApp's in a command context to HsArrForm's
 446
 447 convertOpFormsLCmd :: LHsCmd id -> LHsCmd id
 448 convertOpFormsLCmd = fmap convertOpFormsCmd
 449
 450 convertOpFormsCmd :: HsCmd id -> HsCmd id
 451
 452 convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e
 453 convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match)
 454 convertOpFormsCmd (OpApp c1 op fixity c2)
 455   = let
 456         arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType []
 457         arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType []
 458     in
 459     HsArrForm op (Just fixity) [arg1, arg2]
 460
 461 convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c)
 462
 463 convertOpFormsCmd (HsCase exp matches)
 464   = HsCase exp (convertOpFormsMatch matches)
 465
 466 convertOpFormsCmd (HsIf f exp c1 c2)
 467   = HsIf f exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2)
 468
 469 convertOpFormsCmd (HsLet binds cmd)
 470   = HsLet binds (convertOpFormsLCmd cmd)
 471
 472 convertOpFormsCmd (HsDo ctxt stmts body ty)
 473   = HsDo ctxt (map (fmap convertOpFormsStmt) stmts)
 474               (convertOpFormsLCmd body) ty
 475
 476 -- Anything else is unchanged.  This includes HsArrForm (already done),
 477 -- things with no sub-commands, and illegal commands (which will be
 478 -- caught by the type checker)
 479 convertOpFormsCmd c = c
 480
 481 convertOpFormsStmt :: StmtLR id id -> StmtLR id id
 482 convertOpFormsStmt (BindStmt pat cmd _ _)
 483   = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr
 484 convertOpFormsStmt (ExprStmt cmd _ _)
 485   = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType
 486 convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts })
 487   = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts }
 488 convertOpFormsStmt stmt = stmt
 489
 490 convertOpFormsMatch :: MatchGroup id -> MatchGroup id
 491 convertOpFormsMatch (MatchGroup ms ty)
 492   = MatchGroup (map (fmap convert) ms) ty
 493  where convert (Match pat mty grhss)
 494           = Match pat mty (convertOpFormsGRHSs grhss)
 495
 496 convertOpFormsGRHSs :: GRHSs id -> GRHSs id
 497 convertOpFormsGRHSs (GRHSs grhss binds)
 498   = GRHSs (map convertOpFormsGRHS grhss) binds
 499
 500 convertOpFormsGRHS :: Located (GRHS id) -> Located (GRHS id)
 501 convertOpFormsGRHS = fmap convert
 502  where
 503    convert (GRHS stmts cmd) = GRHS stmts (convertOpFormsLCmd cmd)
 504
 505 ---------------------------------------------------
 506 type CmdNeeds = FreeVars        -- Only inhabitants are
 507                                 --      appAName, choiceAName, loopAName
 508
 509 -- find what methods the Cmd needs (loop, choice, apply)
 510 methodNamesLCmd :: LHsCmd Name -> CmdNeeds
 511 methodNamesLCmd = methodNamesCmd . unLoc
 512
 513 methodNamesCmd :: HsCmd Name -> CmdNeeds
 514
 515 methodNamesCmd (HsArrApp _arrow _arg _ HsFirstOrderApp _rtl)
 516   = emptyFVs
 517 methodNamesCmd (HsArrApp _arrow _arg _ HsHigherOrderApp _rtl)
 518   = unitFV appAName
 519 methodNamesCmd (HsArrForm {}) = emptyFVs
 520
 521 methodNamesCmd (HsPar c) = methodNamesLCmd c
 522
 523 methodNamesCmd (HsIf _ _ c1 c2)
 524   = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
 525
 526 methodNamesCmd (HsLet _ c) = methodNamesLCmd c
 527
 528 methodNamesCmd (HsDo _ stmts body _)
 529   = methodNamesStmts stmts `plusFV` methodNamesLCmd body
 530
 531 methodNamesCmd (HsApp c _) = methodNamesLCmd c
 532
 533 methodNamesCmd (HsLam match) = methodNamesMatch match
 534
 535 methodNamesCmd (HsCase _ matches)
 536   = methodNamesMatch matches `addOneFV` choiceAName
 537
 538 methodNamesCmd _ = emptyFVs
 539    -- Other forms can't occur in commands, but it's not convenient
 540    -- to error here so we just do what's convenient.
 541    -- The type checker will complain later
 542
 543 ---------------------------------------------------
 544 methodNamesMatch :: MatchGroup Name -> FreeVars
 545 methodNamesMatch (MatchGroup ms _)
 546   = plusFVs (map do_one ms)
 547  where
 548     do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss
 549
 550 -------------------------------------------------
 551 -- gaw 2004
 552 methodNamesGRHSs :: GRHSs Name -> FreeVars
 553 methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss)
 554
 555 -------------------------------------------------
 556
 557 methodNamesGRHS :: Located (GRHS Name) -> CmdNeeds
 558 methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs
 559
 560 ---------------------------------------------------
 561 methodNamesStmts :: [Located (StmtLR Name Name)] -> FreeVars
 562 methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)
 563
 564 ---------------------------------------------------
 565 methodNamesLStmt :: Located (StmtLR Name Name) -> FreeVars
 566 methodNamesLStmt = methodNamesStmt . unLoc
 567
 568 methodNamesStmt :: StmtLR Name Name -> FreeVars
 569 methodNamesStmt (ExprStmt cmd _ _)               = methodNamesLCmd cmd
 570 methodNamesStmt (BindStmt _ cmd _ _)             = methodNamesLCmd cmd
 571 methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName
 572 methodNamesStmt (LetStmt _)                      = emptyFVs
 573 methodNamesStmt (ParStmt _)                      = emptyFVs
 574 methodNamesStmt (TransformStmt {})               = emptyFVs
 575 methodNamesStmt (GroupStmt {})                   = emptyFVs
 576    -- ParStmt, TransformStmt and GroupStmt 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 :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars)
 589 rnArithSeq (From expr)
 590  = rnLExpr expr         `thenM` \ (expr', fvExpr) ->
 591    return (From expr', fvExpr)
 592
 593 rnArithSeq (FromThen expr1 expr2)
 594  = rnLExpr expr1        `thenM` \ (expr1', fvExpr1) ->
 595    rnLExpr expr2        `thenM` \ (expr2', fvExpr2) ->
 596    return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 597
 598 rnArithSeq (FromTo expr1 expr2)
 599  = rnLExpr expr1        `thenM` \ (expr1', fvExpr1) ->
 600    rnLExpr expr2        `thenM` \ (expr2', fvExpr2) ->
 601    return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2)
 602
 603 rnArithSeq (FromThenTo expr1 expr2 expr3)
 604  = rnLExpr expr1        `thenM` \ (expr1', fvExpr1) ->
 605    rnLExpr expr2        `thenM` \ (expr2', fvExpr2) ->
 606    rnLExpr expr3        `thenM` \ (expr3', fvExpr3) ->
 607    return (FromThenTo expr1' expr2' expr3',
 608             plusFVs [fvExpr1, fvExpr2, fvExpr3])
 609 \end{code}
 610
 611 %************************************************************************
 612 %*                                                                      *
 613         Template Haskell brackets
 614 %*                                                                      *
 615 %************************************************************************
 616
 617 \begin{code}
 618 rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars)
 619 rnBracket (VarBr n) = do { name <- lookupOccRn n
 620                          ; this_mod <- getModule
 621                          ; unless (nameIsLocalOrFrom this_mod name) $   -- Reason: deprecation checking asumes the
 622                            do { _ <- loadInterfaceForName msg name      -- home interface is loaded, and this is the
 623                               ; return () }                             -- only way that is going to happen
 624                          ; return (VarBr name, unitFV name) }
 625                     where
 626                       msg = ptext (sLit "Need interface for Template Haskell quoted Name")
 627
 628 rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e
 629                          ; return (ExpBr e', fvs) }
 630
 631 rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs)
 632
 633 rnBracket (TypBr t) = do { (t', fvs) <- rnHsTypeFVs doc t
 634                          ; return (TypBr t', fvs) }
 635                     where
 636                       doc = ptext (sLit "In a Template-Haskell quoted type")
 637
 638 rnBracket (DecBrL decls)
 639   = do { (group, mb_splice) <- findSplice decls
 640        ; case mb_splice of
 641            Nothing -> return ()
 642            Just (SpliceDecl (L loc _) _, _)
 643               -> setSrcSpan loc $
 644                  addErr (ptext (sLit "Declaration splices are not permitted inside declaration brackets"))
 645                 -- Why not?  See Section 7.3 of the TH paper.
 646
 647        ; gbl_env  <- getGblEnv
 648        ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }
 649                           -- The emptyDUs is so that we just collect uses for this
 650                           -- group alone in the call to rnSrcDecls below
 651        ; (tcg_env, group') <- setGblEnv new_gbl_env $
 652                               setStage thRnBrack $
 653                               rnSrcDecls group
 654
 655               -- Discard the tcg_env; it contains only extra info about fixity
 656         ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env))))
 657         ; return (DecBrG group', duUses (tcg_dus tcg_env)) }
 658
 659 rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG"
 660 \end{code}
 661
 662 %************************************************************************
 663 %*                                                                      *
 664 \subsubsection{@Stmt@s: in @do@ expressions}
 665 %*                                                                      *
 666 %************************************************************************
 667
 668 \begin{code}
 669 rnStmts :: HsStmtContext Name -> [LStmt RdrName]
 670               -> ([Name] -> RnM (thing, FreeVars))
 671               -> RnM (([LStmt Name], thing), FreeVars)
 672 -- Variables bound by the Stmts, and mentioned in thing_inside,
 673 -- do not appear in the result FreeVars
 674 --
 675 -- Renaming a single RecStmt can give a sequence of smaller Stmts
 676
 677 rnStmts _ [] thing_inside
 678   = do { (res, fvs) <- thing_inside []
 679        ; return (([], res), fvs) }
 680
 681 rnStmts ctxt (stmt@(L loc _) : stmts) thing_inside
 682   = do { ((stmts1, (stmts2, thing)), fvs)
 683             <- setSrcSpan loc           $
 684                rnStmt ctxt stmt         $ \ bndrs1 ->
 685                rnStmts ctxt stmts $ \ bndrs2 ->
 686                thing_inside (bndrs1 ++ bndrs2)
 687         ; return (((stmts1 ++ stmts2), thing), fvs) }
 688
 689
 690 rnStmt :: HsStmtContext Name -> LStmt RdrName
 691        -> ([Name] -> RnM (thing, FreeVars))
 692        -> RnM (([LStmt Name], thing), FreeVars)
 693 -- Variables bound by the Stmt, and mentioned in thing_inside,
 694 -- do not appear in the result FreeVars
 695
 696 rnStmt _ (L loc (ExprStmt expr _ _)) thing_inside
 697   = do  { (expr', fv_expr) <- rnLExpr expr
 698         ; (then_op, fvs1)  <- lookupSyntaxName thenMName
 699         ; (thing, fvs2)    <- thing_inside []
 700         ; return (([L loc (ExprStmt expr' then_op placeHolderType)], thing),
 701                   fv_expr `plusFV` fvs1 `plusFV` fvs2) }
 702
 703 rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside
 704   = do  { (expr', fv_expr) <- rnLExpr expr
 705                 -- The binders do not scope over the expression
 706         ; (bind_op, fvs1) <- lookupSyntaxName bindMName
 707         ; (fail_op, fvs2) <- lookupSyntaxName failMName
 708         ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do
 709         { (thing, fvs3) <- thing_inside (collectPatBinders pat')
 710         ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing),
 711                   fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
 712        -- fv_expr shouldn't really be filtered by the rnPatsAndThen
 713         -- but it does not matter because the names are unique
 714
 715 rnStmt ctxt (L loc (LetStmt binds)) thing_inside
 716   = do  { checkLetStmt ctxt binds
 717         ; rnLocalBindsAndThen binds $ \binds' -> do
 718         { (thing, fvs) <- thing_inside (collectLocalBinders binds')
 719         ; return (([L loc (LetStmt binds')], thing), fvs) }  }
 720
 721 rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside
 722   = do  { checkRecStmt ctxt
 723
 724         -- Step1: Bring all the binders of the mdo into scope
 725         -- (Remember that this also removes the binders from the
 726         -- finally-returned free-vars.)
 727         -- And rename each individual stmt, making a
 728         -- singleton segment.  At this stage the FwdRefs field
 729         -- isn't finished: it's empty for all except a BindStmt
 730         -- for which it's the fwd refs within the bind itself
 731         -- (This set may not be empty, because we're in a recursive
 732         -- context.)
 733         ; rnRecStmtsAndThen rec_stmts   $ \ segs -> do
 734
 735         { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds))
 736                                             emptyNameSet segs
 737         ; (thing, fvs_later) <- thing_inside bndrs
 738         ; (return_op, fvs1)  <- lookupSyntaxName returnMName
 739         ; (mfix_op,   fvs2)  <- lookupSyntaxName mfixName
 740         ; (bind_op,   fvs3)  <- lookupSyntaxName bindMName
 741         ; let
 742                 -- Step 2: Fill in the fwd refs.
 743                 --         The segments are all singletons, but their fwd-ref
 744                 --         field mentions all the things used by the segment
 745                 --         that are bound after their use
 746             segs_w_fwd_refs          = addFwdRefs segs
 747
 748                 -- Step 3: Group together the segments to make bigger segments
 749                 --         Invariant: in the result, no segment uses a variable
 750                 --                    bound in a later segment
 751             grouped_segs = glomSegments segs_w_fwd_refs
 752
 753                 -- Step 4: Turn the segments into Stmts
 754                 --         Use RecStmt when and only when there are fwd refs
 755                 --         Also gather up the uses from the end towards the
 756                 --         start, so we can tell the RecStmt which things are
 757                 --         used 'after' the RecStmt
 758             empty_rec_stmt = emptyRecStmt { recS_ret_fn  = return_op
 759                                           , recS_mfix_fn = mfix_op
 760                                           , recS_bind_fn = bind_op }
 761             (rec_stmts', fvs) = segsToStmts empty_rec_stmt grouped_segs fvs_later
 762
 763         ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }
 764
 765 rnStmt ctxt (L loc (ParStmt segs)) thing_inside
 766   = do  { checkParStmt ctxt
 767         ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside
 768         ; return (([L loc (ParStmt segs')], thing), fvs) }
 769
 770 rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside
 771   = do { checkTransformStmt ctxt
 772
 773        ; (using', fvs1) <- rnLExpr using
 774
 775        ; ((stmts', (by', used_bndrs, thing)), fvs2)
 776              <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
 777                 do { (by', fvs_by) <- case by of
 778                                         Nothing -> return (Nothing, emptyFVs)
 779                                         Just e  -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) }
 780                    ; (thing, fvs_thing) <- thing_inside bndrs
 781                    ; let fvs        = fvs_by `plusFV` fvs_thing
 782                          used_bndrs = filter (`elemNameSet` fvs) bndrs
 783                          -- The paper (Fig 5) has a bug here; we must treat any free varaible of
 784                          -- the "thing inside", **or of the by-expression**, as used
 785                    ; return ((by', used_bndrs, thing), fvs) }
 786
 787        ; return (([L loc (TransformStmt stmts' used_bndrs using' by')], thing),
 788                  fvs1 `plusFV` fvs2) }
 789
 790 rnStmt ctxt (L loc (GroupStmt stmts _ by using)) thing_inside
 791   = do { checkTransformStmt ctxt
 792
 793          -- Rename the 'using' expression in the context before the transform is begun
 794        ; (using', fvs1) <- case using of
 795                              Left e  -> do { (e', fvs) <- rnLExpr e; return (Left e', fvs) }
 796                              Right _ -> do { (e', fvs) <- lookupSyntaxName groupWithName
 797                                            ; return (Right e', fvs) }
 798
 799          -- Rename the stmts and the 'by' expression
 800          -- Keep track of the variables mentioned in the 'by' expression
 801        ; ((stmts', (by', used_bndrs, thing)), fvs2)
 802              <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs ->
 803                 do { (by',   fvs_by) <- mapMaybeFvRn rnLExpr by
 804                    ; (thing, fvs_thing) <- thing_inside bndrs
 805                    ; let fvs = fvs_by `plusFV` fvs_thing
 806                          used_bndrs = filter (`elemNameSet` fvs) bndrs
 807                    ; return ((by', used_bndrs, thing), fvs) }
 808
 809        ; let all_fvs  = fvs1 `plusFV` fvs2
 810              bndr_map = used_bndrs `zip` used_bndrs
 811              -- See Note [GroupStmt binder map] in HsExpr
 812
 813        ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map)
 814        ; return (([L loc (GroupStmt stmts' bndr_map by' using')], thing), all_fvs) }
 815
 816
 817 type ParSeg id = ([LStmt id], [id])        -- The Names are bound by the Stmts
 818
 819 rnParallelStmts :: forall thing. HsStmtContext Name
 820                 -> [ParSeg RdrName]
 821                 -> ([Name] -> RnM (thing, FreeVars))
 822                 -> RnM (([ParSeg Name], thing), FreeVars)
 823 -- Note [Renaming parallel Stmts]
 824 rnParallelStmts ctxt segs thing_inside
 825   = do { orig_lcl_env <- getLocalRdrEnv
 826        ; rn_segs orig_lcl_env [] segs }
 827   where
 828     rn_segs :: LocalRdrEnv
 829             -> [Name] -> [ParSeg RdrName]
 830             -> RnM (([ParSeg Name], thing), FreeVars)
 831     rn_segs _ bndrs_so_far []
 832       = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far
 833            ; mapM_ dupErr dups
 834            ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')
 835            ; return (([], thing), fvs) }
 836
 837     rn_segs env bndrs_so_far ((stmts,_) : segs)
 838       = do { ((stmts', (used_bndrs, segs', thing)), fvs)
 839                     <- rnStmts ctxt stmts $ \ bndrs ->
 840                        setLocalRdrEnv env       $ do
 841                        { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs
 842                        ; let used_bndrs = filter (`elemNameSet` fvs) bndrs
 843                        ; return ((used_bndrs, segs', thing), fvs) }
 844
 845            ; let seg' = (stmts', used_bndrs)
 846            ; return ((seg':segs', thing), fvs) }
 847
 848     cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2
 849     dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:")
 850                     <+> quotes (ppr (head vs)))
 851 \end{code}
 852
 853 Note [Renaming parallel Stmts]
 854 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 855 Renaming parallel statements is painful.  Given, say
 856      [ a+c | a <- as, bs <- bss
 857            | c <- bs, a <- ds ]
 858 Note that
 859   (a) In order to report "Defined by not used" about 'bs', we must rename
 860       each group of Stmts with a thing_inside whose FreeVars include at least {a,c}
 861
 862   (b) We want to report that 'a' is illegally bound in both branches
 863
 864   (c) The 'bs' in the second group must obviously not be captured by
 865       the binding in the first group
 866
 867 To satisfy (a) we nest the segements.
 868 To satisfy (b) we check for duplicates just before thing_inside.
 869 To satisfy (c) we reset the LocalRdrEnv each time.
 870
 871 %************************************************************************
 872 %*                                                                      *
 873 \subsubsection{mdo expressions}
 874 %*                                                                      *
 875 %************************************************************************
 876
 877 \begin{code}
 878 type FwdRefs = NameSet
 879 type Segment stmts = (Defs,
 880                       Uses,     -- May include defs
 881                       FwdRefs,  -- A subset of uses that are
 882                                 --   (a) used before they are bound in this segment, or
 883                                 --   (b) used here, and bound in subsequent segments
 884                       stmts)    -- Either Stmt or [Stmt]
 885
 886
 887 -- wrapper that does both the left- and right-hand sides
 888 rnRecStmtsAndThen :: [LStmt RdrName]
 889                          -- assumes that the FreeVars returned includes
 890                          -- the FreeVars of the Segments
 891                       -> ([Segment (LStmt Name)] -> RnM (a, FreeVars))
 892                       -> RnM (a, FreeVars)
 893 rnRecStmtsAndThen s cont
 894   = do  { -- (A) Make the mini fixity env for all of the stmts
 895           fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)
 896
 897           -- (B) Do the LHSes
 898         ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s
 899
 900           --    ...bring them and their fixities into scope
 901         ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)
 902               -- Fake uses of variables introduced implicitly (warning suppression, see #4404)
 903               implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv)
 904         ; bindLocalNamesFV bound_names $
 905           addLocalFixities fix_env bound_names $ do
 906
 907           -- (C) do the right-hand-sides and thing-inside
 908         { segs <- rn_rec_stmts bound_names new_lhs_and_fv
 909         ; (res, fvs) <- cont segs
 910         ; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses)
 911         ; return (res, fvs) }}
 912
 913 -- get all the fixity decls in any Let stmt
 914 collectRecStmtsFixities :: [LStmtLR RdrName RdrName] -> [LFixitySig RdrName]
 915 collectRecStmtsFixities l =
 916     foldr (\ s -> \acc -> case s of
 917                             (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) ->
 918                                 foldr (\ sig -> \ acc -> case sig of
 919                                                            (L loc (FixSig s)) -> (L loc s) : acc
 920                                                            _ -> acc) acc sigs
 921                             _ -> acc) [] l
 922
 923 -- left-hand sides
 924
 925 rn_rec_stmt_lhs :: MiniFixityEnv
 926                 -> LStmt RdrName
 927                    -- rename LHS, and return its FVs
 928                    -- Warning: we will only need the FreeVars below in the case of a BindStmt,
 929                    -- so we don't bother to compute it accurately in the other cases
 930                 -> RnM [(LStmtLR Name RdrName, FreeVars)]
 931
 932 rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b),
 933                                                        -- this is actually correct
 934                                                        emptyFVs)]
 935
 936 rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b))
 937   = do
 938       -- should the ctxt be MDo instead?
 939       (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat
 940       return [(L loc (BindStmt pat' expr a b),
 941                fv_pat)]
 942
 943 rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _)))
 944   = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
 945
 946 rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds)))
 947     = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds
 948          return [(L loc (LetStmt (HsValBinds binds')),
 949                  -- Warning: this is bogus; see function invariant
 950                  emptyFVs
 951                  )]
 952
 953 -- XXX Do we need to do something with the return and mfix names?
 954 rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts }))  -- Flatten Rec inside Rec
 955     = rn_rec_stmts_lhs fix_env stmts
 956
 957 rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _))        -- Syntactically illegal in mdo
 958   = pprPanic "rn_rec_stmt" (ppr stmt)
 959
 960 rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {})) -- Syntactically illegal in mdo
 961   = pprPanic "rn_rec_stmt" (ppr stmt)
 962
 963 rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {}))     -- Syntactically illegal in mdo
 964   = pprPanic "rn_rec_stmt" (ppr stmt)
 965
 966 rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds))
 967   = panic "rn_rec_stmt LetStmt EmptyLocalBinds"
 968
 969 rn_rec_stmts_lhs :: MiniFixityEnv
 970                  -> [LStmt RdrName]
 971                  -> RnM [(LStmtLR Name RdrName, FreeVars)]
 972 rn_rec_stmts_lhs fix_env stmts
 973   = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts
 974        ; let boundNames = collectLStmtsBinders (map fst ls)
 975             -- First do error checking: we need to check for dups here because we
 976             -- don't bind all of the variables from the Stmt at once
 977             -- with bindLocatedLocals.
 978        ; checkDupNames boundNames
 979        ; return ls }
 980
 981
 982 -- right-hand-sides
 983
 984 rn_rec_stmt :: [Name] -> LStmtLR Name RdrName -> FreeVars -> RnM [Segment (LStmt Name)]
 985         -- Rename a Stmt that is inside a RecStmt (or mdo)
 986         -- Assumes all binders are already in scope
 987         -- Turns each stmt into a singleton Stmt
 988 rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _
 989   = rnLExpr expr `thenM` \ (expr', fvs) ->
 990     lookupSyntaxName thenMName  `thenM` \ (then_op, fvs1) ->
 991     return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,
 992               L loc (ExprStmt expr' then_op placeHolderType))]
 993
 994 rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat
 995   = rnLExpr expr                `thenM` \ (expr', fv_expr) ->
 996     lookupSyntaxName bindMName  `thenM` \ (bind_op, fvs1) ->
 997     lookupSyntaxName failMName  `thenM` \ (fail_op, fvs2) ->
 998     let
 999         bndrs = mkNameSet (collectPatBinders pat')
1000         fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2
1001     in
1002     return [(bndrs, fvs, bndrs `intersectNameSet` fvs,
1003               L loc (BindStmt pat' expr' bind_op fail_op))]
1004
1005 rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _
1006   = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds)
1007
1008 rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do
1009   (binds', du_binds) <-
1010       -- fixities and unused are handled above in rnRecStmtsAndThen
1011       rnLocalValBindsRHS (mkNameSet all_bndrs) binds'
1012   return [(duDefs du_binds, allUses du_binds,
1013            emptyNameSet, L loc (LetStmt (HsValBinds binds')))]
1014
1015 -- no RecStmt case becuase they get flattened above when doing the LHSes
1016 rn_rec_stmt _ stmt@(L _ (RecStmt {})) _
1017   = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)
1018
1019 rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo
1020   = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)
1021
1022 rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _   -- Syntactically illegal in mdo
1023   = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt)
1024
1025 rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _       -- Syntactically illegal in mdo
1026   = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt)
1027
1028 rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _
1029   = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"
1030
1031 rn_rec_stmts :: [Name] -> [(LStmtLR Name RdrName, FreeVars)] -> RnM [Segment (LStmt Name)]
1032 rn_rec_stmts bndrs stmts = mapM (uncurry (rn_rec_stmt bndrs)) stmts     `thenM` \ segs_s ->
1033                            return (concat segs_s)
1034
1035 ---------------------------------------------
1036 addFwdRefs :: [Segment a] -> [Segment a]
1037 -- So far the segments only have forward refs *within* the Stmt
1038 --      (which happens for bind:  x <- ...x...)
1039 -- This function adds the cross-seg fwd ref info
1040
1041 addFwdRefs pairs
1042   = fst (foldr mk_seg ([], emptyNameSet) pairs)
1043   where
1044     mk_seg (defs, uses, fwds, stmts) (segs, later_defs)
1045         = (new_seg : segs, all_defs)
1046         where
1047           new_seg = (defs, uses, new_fwds, stmts)
1048           all_defs = later_defs `unionNameSets` defs
1049           new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs)
1050                 -- Add the downstream fwd refs here
1051
1052 ----------------------------------------------------
1053 --      Glomming the singleton segments of an mdo into
1054 --      minimal recursive groups.
1055 --
1056 -- At first I thought this was just strongly connected components, but
1057 -- there's an important constraint: the order of the stmts must not change.
1058 --
1059 -- Consider
1060 --      mdo { x <- ...y...
1061 --            p <- z
1062 --            y <- ...x...
1063 --            q <- x
1064 --            z <- y
1065 --            r <- x }
1066 --
1067 -- Here, the first stmt mention 'y', which is bound in the third.
1068 -- But that means that the innocent second stmt (p <- z) gets caught
1069 -- up in the recursion.  And that in turn means that the binding for
1070 -- 'z' has to be included... and so on.
1071 --
1072 -- Start at the tail { r <- x }
1073 -- Now add the next one { z <- y ; r <- x }
1074 -- Now add one more     { q <- x ; z <- y ; r <- x }
1075 -- Now one more... but this time we have to group a bunch into rec
1076 --      { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }
1077 -- Now one more, which we can add on without a rec
1078 --      { p <- z ;
1079 --        rec { y <- ...x... ; q <- x ; z <- y } ;
1080 --        r <- x }
1081 -- Finally we add the last one; since it mentions y we have to
1082 -- glom it togeher with the first two groups
1083 --      { rec { x <- ...y...; p <- z ; y <- ...x... ;
1084 --              q <- x ; z <- y } ;
1085 --        r <- x }
1086
1087 glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]]
1088
1089 glomSegments [] = []
1090 glomSegments ((defs,uses,fwds,stmt) : segs)
1091         -- Actually stmts will always be a singleton
1092   = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others
1093   where
1094     segs'            = glomSegments segs
1095     (extras, others) = grab uses segs'
1096     (ds, us, fs, ss) = unzip4 extras
1097
1098     seg_defs  = plusFVs ds `plusFV` defs
1099     seg_uses  = plusFVs us `plusFV` uses
1100     seg_fwds  = plusFVs fs `plusFV` fwds
1101     seg_stmts = stmt : concat ss
1102
1103     grab :: NameSet             -- The client
1104          -> [Segment a]
1105          -> ([Segment a],       -- Needed by the 'client'
1106              [Segment a])       -- Not needed by the client
1107         -- The result is simply a split of the input
1108     grab uses dus
1109         = (reverse yeses, reverse noes)
1110         where
1111           (noes, yeses)           = span not_needed (reverse dus)
1112           not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)
1113
1114
1115 ----------------------------------------------------
1116 segsToStmts :: Stmt Name                -- A RecStmt with the SyntaxOps filled in
1117             -> [Segment [LStmt Name]]
1118             -> FreeVars                 -- Free vars used 'later'
1119             -> ([LStmt Name], FreeVars)
1120
1121 segsToStmts _ [] fvs_later = ([], fvs_later)
1122 segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later
1123   = ASSERT( not (null ss) )
1124     (new_stmt : later_stmts, later_uses `plusFV` uses)
1125   where
1126     (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later
1127     new_stmt | non_rec   = head ss
1128              | otherwise = L (getLoc (head ss)) rec_stmt
1129     rec_stmt = empty_rec_stmt { recS_stmts     = ss
1130                               , recS_later_ids = nameSetToList used_later
1131                               , recS_rec_ids   = nameSetToList fwds }
1132     non_rec    = isSingleton ss && isEmptyNameSet fwds
1133     used_later = defs `intersectNameSet` later_uses
1134                                 -- The ones needed after the RecStmt
1135 \end{code}
1136
1137 %************************************************************************
1138 %*                                                                      *
1139 \subsubsection{Assertion utils}
1140 %*                                                                      *
1141 %************************************************************************
1142
1143 \begin{code}
1144 srcSpanPrimLit :: SrcSpan -> HsExpr Name
1145 srcSpanPrimLit span = HsLit (HsStringPrim (mkFastString (showSDocOneLine (ppr span))))
1146
1147 mkAssertErrorExpr :: RnM (HsExpr Name)
1148 -- Return an expression for (assertError "Foo.hs:27")
1149 mkAssertErrorExpr
1150   = getSrcSpanM                         `thenM` \ sloc ->
1151     return (HsApp (L sloc (HsVar assertErrorName))
1152                   (L sloc (srcSpanPrimLit sloc)))
1153 \end{code}
1154
1155 Note [Adding the implicit parameter to 'assert']
1156 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1157 The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2).
1158 By doing this in the renamer we allow the typechecker to just see the
1159 expanded application and do the right thing. But it's not really
1160 the Right Thing because there's no way to "undo" if you want to see
1161 the original source code.  We'll have fix this in due course, when
1162 we care more about being able to reconstruct the exact original
1163 program.
1164
1165 %************************************************************************
1166 %*                                                                      *
1167 \subsubsection{Errors}
1168 %*                                                                      *
1169 %************************************************************************
1170
1171 \begin{code}
1172
1173 ----------------------
1174 -- Checking when a particular Stmt is ok
1175 checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM ()
1176 checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds)
1177 checkLetStmt _ctxt           _binds            = return ()
1178         -- We do not allow implicit-parameter bindings in a parallel
1179         -- list comprehension.  I'm not sure what it might mean.
1180
1181 ---------
1182 checkRecStmt :: HsStmtContext Name -> RnM ()
1183 checkRecStmt MDoExpr = return ()      -- Recursive stmt ok in 'mdo'
1184 checkRecStmt DoExpr  = return ()      -- and in 'do'
1185 checkRecStmt ctxt    = addErr msg
1186   where
1187     msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt
1188
1189 ---------
1190 checkParStmt :: HsStmtContext Name -> RnM ()
1191 checkParStmt _
1192   = do  { parallel_list_comp <- xoptM Opt_ParallelListComp
1193         ; checkErr parallel_list_comp msg }
1194   where
1195     msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp")
1196
1197 ---------
1198 checkTransformStmt :: HsStmtContext Name -> RnM ()
1199 checkTransformStmt ListComp  -- Ensure we are really within a list comprehension because otherwise the
1200                              -- desugarer will break when we come to operate on a parallel array
1201   = do  { transform_list_comp <- xoptM Opt_TransformListComp
1202         ; checkErr transform_list_comp msg }
1203   where
1204     msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp")
1205 checkTransformStmt (ParStmtCtxt       ctxt) = checkTransformStmt ctxt   -- Ok to nest inside a parallel comprehension
1206 checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt   -- Ok to nest inside a parallel comprehension
1207 checkTransformStmt ctxt = addErr msg
1208   where
1209     msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt
1210
1211 ---------
1212 checkTupleSection :: [HsTupArg RdrName] -> RnM ()
1213 checkTupleSection args
1214   = do  { tuple_section <- xoptM Opt_TupleSections
1215         ; checkErr (all tupArgPresent args || tuple_section) msg }
1216   where
1217     msg = ptext (sLit "Illegal tuple section: use -XTupleSections")
1218
1219 ---------
1220 sectionErr :: HsExpr RdrName -> SDoc
1221 sectionErr expr
1222   = hang (ptext (sLit "A section must be enclosed in parentheses"))
1223        2 (ptext (sLit "thus:") <+> (parens (ppr expr)))
1224
1225 patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
1226 patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"),
1227                                 nest 4 (ppr e)])
1228                  ; return (EWildPat, emptyFVs) }
1229
1230 badIpBinds :: Outputable a => SDoc -> a -> SDoc
1231 badIpBinds what binds
1232   = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what)
1233          2 (ppr binds)
1234 \end{code}