compiler/rename/RnBinds.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[RnBinds]{Renaming and dependency analysis of bindings}
   5
   6 This module does renaming and dependency analysis on value bindings in
   7 the abstract syntax.  It does {\em not} do cycle-checks on class or
   8 type-synonym declarations; those cannot be done at this stage because
   9 they may be affected by renaming (which isn't fully worked out yet).
  10
  11 \begin{code}
  12 module RnBinds (
  13    -- Renaming top-level bindings
  14    rnTopBinds, rnTopBindsLHS, rnTopBindsRHS,
  15
  16    -- Renaming local bindings
  17    rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
  18
  19    -- Other bindings
  20    rnMethodBinds, renameSigs, mkSigTvFn,
  21    rnMatchGroup, rnGRHSs,
  22    makeMiniFixityEnv, MiniFixityEnv,
  23    misplacedSigErr
  24    ) where
  25
  26 import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
  27
  28 import HsSyn
  29 import RdrHsSyn
  30 import RnHsSyn
  31 import TcRnMonad
  32 import RnTypes        ( rnHsSigType, rnLHsType, checkPrecMatch)
  33 import RnPat          (rnPats, rnBindPat,
  34                        NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker
  35                       )
  36
  37 import RnEnv
  38 import DynFlags
  39 import Name
  40 import NameEnv
  41 import NameSet
  42 import RdrName          ( RdrName, rdrNameOcc )
  43 import SrcLoc
  44 import ListSetOps       ( findDupsEq )
  45 import BasicTypes       ( RecFlag(..) )
  46 import Digraph          ( SCC(..), stronglyConnCompFromEdgedVertices )
  47 import Bag
  48 import Outputable
  49 import FastString
  50 import Data.List        ( partition )
  51 import Maybes           ( orElse )
  52 import Control.Monad
  53 \end{code}
  54
  55 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
  56 -- place and can be used when complaining.
  57
  58 The code tree received by the function @rnBinds@ contains definitions
  59 in where-clauses which are all apparently mutually recursive, but which may
  60 not really depend upon each other. For example, in the top level program
  61 \begin{verbatim}
  62 f x = y where a = x
  63               y = x
  64 \end{verbatim}
  65 the definitions of @a@ and @y@ do not depend on each other at all.
  66 Unfortunately, the typechecker cannot always check such definitions.
  67 \footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
  68 definitions. In Proceedings of the International Symposium on Programming,
  69 Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
  70 However, the typechecker usually can check definitions in which only the
  71 strongly connected components have been collected into recursive bindings.
  72 This is precisely what the function @rnBinds@ does.
  73
  74 ToDo: deal with case where a single monobinds binds the same variable
  75 twice.
  76
  77 The vertag tag is a unique @Int@; the tags only need to be unique
  78 within one @MonoBinds@, so that unique-Int plumbing is done explicitly
  79 (heavy monad machinery not needed).
  80
  81
  82 %************************************************************************
  83 %*                                                                      *
  84 %* naming conventions                                                   *
  85 %*                                                                      *
  86 %************************************************************************
  87
  88 \subsection[name-conventions]{Name conventions}
  89
  90 The basic algorithm involves walking over the tree and returning a tuple
  91 containing the new tree plus its free variables. Some functions, such
  92 as those walking polymorphic bindings (HsBinds) and qualifier lists in
  93 list comprehensions (@Quals@), return the variables bound in local
  94 environments. These are then used to calculate the free variables of the
  95 expression evaluated in these environments.
  96
  97 Conventions for variable names are as follows:
  98 \begin{itemize}
  99 \item
 100 new code is given a prime to distinguish it from the old.
 101
 102 \item
 103 a set of variables defined in @Exp@ is written @dvExp@
 104
 105 \item
 106 a set of variables free in @Exp@ is written @fvExp@
 107 \end{itemize}
 108
 109 %************************************************************************
 110 %*                                                                      *
 111 %* analysing polymorphic bindings (HsBindGroup, HsBind)
 112 %*                                                                      *
 113 %************************************************************************
 114
 115 \subsubsection[dep-HsBinds]{Polymorphic bindings}
 116
 117 Non-recursive expressions are reconstructed without any changes at top
 118 level, although their component expressions may have to be altered.
 119 However, non-recursive expressions are currently not expected as
 120 \Haskell{} programs, and this code should not be executed.
 121
 122 Monomorphic bindings contain information that is returned in a tuple
 123 (a @FlatMonoBinds@) containing:
 124
 125 \begin{enumerate}
 126 \item
 127 a unique @Int@ that serves as the ``vertex tag'' for this binding.
 128
 129 \item
 130 the name of a function or the names in a pattern. These are a set
 131 referred to as @dvLhs@, the defined variables of the left hand side.
 132
 133 \item
 134 the free variables of the body. These are referred to as @fvBody@.
 135
 136 \item
 137 the definition's actual code. This is referred to as just @code@.
 138 \end{enumerate}
 139
 140 The function @nonRecDvFv@ returns two sets of variables. The first is
 141 the set of variables defined in the set of monomorphic bindings, while the
 142 second is the set of free variables in those bindings.
 143
 144 The set of variables defined in a non-recursive binding is just the
 145 union of all of them, as @union@ removes duplicates. However, the
 146 free variables in each successive set of cumulative bindings is the
 147 union of those in the previous set plus those of the newest binding after
 148 the defined variables of the previous set have been removed.
 149
 150 @rnMethodBinds@ deals only with the declarations in class and
 151 instance declarations.  It expects only to see @FunMonoBind@s, and
 152 it expects the global environment to contain bindings for the binders
 153 (which are all class operations).
 154
 155 %************************************************************************
 156 %*                                                                      *
 157 \subsubsection{ Top-level bindings}
 158 %*                                                                      *
 159 %************************************************************************
 160
 161 \begin{code}
 162 -- for top-level bindings, we need to make top-level names,
 163 -- so we have a different entry point than for local bindings
 164 rnTopBindsLHS :: MiniFixityEnv
 165               -> HsValBinds RdrName
 166               -> RnM (HsValBindsLR Name RdrName)
 167 rnTopBindsLHS fix_env binds
 168   = rnValBindsLHS (topRecNameMaker fix_env) binds
 169
 170 rnTopBindsRHS :: HsValBindsLR Name RdrName
 171               -> RnM (HsValBinds Name, DefUses)
 172 rnTopBindsRHS binds
 173   = do { is_boot <- tcIsHsBoot
 174        ; if is_boot
 175          then rnTopBindsBoot binds
 176          else rnValBindsRHS noTrimFVs -- don't trim free vars
 177                             Nothing   -- Allow SPEC prags for imports
 178                             binds }
 179
 180 -- Wrapper if we don't need to do anything in between the left and right,
 181 -- or anything else in the scope of the left
 182 --
 183 -- Never used when there are fixity declarations
 184 rnTopBinds :: HsValBinds RdrName
 185            -> RnM (HsValBinds Name, DefUses)
 186 rnTopBinds b
 187   = do { nl <- rnTopBindsLHS emptyFsEnv b
 188        ; let bound_names = collectHsValBinders nl
 189        ; bindLocalNames bound_names $
 190          rnValBindsRHS noTrimFVs (Just (mkNameSet bound_names)) nl }
 191
 192
 193 rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
 194 -- A hs-boot file has no bindings.
 195 -- Return a single HsBindGroup with empty binds and renamed signatures
 196 rnTopBindsBoot (ValBindsIn mbinds sigs)
 197   = do  { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
 198         ; sigs' <- renameSigs Nothing okHsBootSig sigs
 199         ; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) }
 200 rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b)
 201 \end{code}
 202
 203
 204 %*********************************************************
 205 %*                                                      *
 206                 HsLocalBinds
 207 %*                                                      *
 208 %*********************************************************
 209
 210 \begin{code}
 211 rnLocalBindsAndThen :: HsLocalBinds RdrName
 212                     -> (HsLocalBinds Name -> RnM (result, FreeVars))
 213                     -> RnM (result, FreeVars)
 214 -- This version (a) assumes that the binding vars are *not* already in scope
 215 --               (b) removes the binders from the free vars of the thing inside
 216 -- The parser doesn't produce ThenBinds
 217 rnLocalBindsAndThen EmptyLocalBinds thing_inside
 218   = thing_inside EmptyLocalBinds
 219
 220 rnLocalBindsAndThen (HsValBinds val_binds) thing_inside
 221   = rnLocalValBindsAndThen val_binds $ \ val_binds' ->
 222       thing_inside (HsValBinds val_binds')
 223
 224 rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do
 225     (binds',fv_binds) <- rnIPBinds binds
 226     (thing, fvs_thing) <- thing_inside (HsIPBinds binds')
 227     return (thing, fvs_thing `plusFV` fv_binds)
 228
 229 rnIPBinds :: HsIPBinds RdrName -> RnM (HsIPBinds Name, FreeVars)
 230 rnIPBinds (IPBinds ip_binds _no_dict_binds) = do
 231     (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds
 232     return (IPBinds ip_binds' emptyTcEvBinds, plusFVs fvs_s)
 233
 234 rnIPBind :: IPBind RdrName -> RnM (IPBind Name, FreeVars)
 235 rnIPBind (IPBind n expr) = do
 236     name <- newIPNameRn  n
 237     (expr',fvExpr) <- rnLExpr expr
 238     return (IPBind name expr', fvExpr)
 239 \end{code}
 240
 241
 242 %************************************************************************
 243 %*                                                                      *
 244                 ValBinds
 245 %*                                                                      *
 246 %************************************************************************
 247
 248 \begin{code}
 249 -- Renaming local binding gropus
 250 -- Does duplicate/shadow check
 251 rnLocalValBindsLHS :: MiniFixityEnv
 252                    -> HsValBinds RdrName
 253                    -> RnM ([Name], HsValBindsLR Name RdrName)
 254 rnLocalValBindsLHS fix_env binds
 255   = do { -- Do error checking: we need to check for dups here because we
 256          -- don't don't bind all of the variables from the ValBinds at once
 257          -- with bindLocatedLocals any more.
 258          --
 259          -- Note that we don't want to do this at the top level, since
 260          -- sorting out duplicates and shadowing there happens elsewhere.
 261          -- The behavior is even different. For example,
 262          --   import A(f)
 263          --   f = ...
 264          -- should not produce a shadowing warning (but it will produce
 265          -- an ambiguity warning if you use f), but
 266          --   import A(f)
 267          --   g = let f = ... in f
 268          -- should.
 269        ; binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds
 270        ; let bound_names = collectHsValBinders binds'
 271        ; envs <- getRdrEnvs
 272        ; checkDupAndShadowedNames envs bound_names
 273        ; return (bound_names, binds') }
 274
 275 -- renames the left-hand sides
 276 -- generic version used both at the top level and for local binds
 277 -- does some error checking, but not what gets done elsewhere at the top level
 278 rnValBindsLHS :: NameMaker
 279               -> HsValBinds RdrName
 280               -> RnM (HsValBindsLR Name RdrName)
 281 rnValBindsLHS topP (ValBindsIn mbinds sigs)
 282   = do { mbinds' <- mapBagM (rnBindLHS topP doc) mbinds
 283        ; return $ ValBindsIn mbinds' sigs }
 284   where
 285     bndrs = collectHsBindsBinders mbinds
 286     doc   = text "In the binding group for:" <+> pprWithCommas ppr bndrs
 287
 288 rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)
 289
 290 -- General version used both from the top-level and for local things
 291 -- Assumes the LHS vars are in scope
 292 --
 293 -- Does not bind the local fixity declarations
 294 rnValBindsRHS :: (FreeVars -> FreeVars)  -- for trimming free var sets
 295                      -- The trimming function trims the free vars we attach to a
 296                      -- binding so that it stays reasonably small
 297                -> Maybe NameSet -- Names bound by the LHSes
 298                                 -- Nothing if expect sigs for imports
 299                -> HsValBindsLR Name RdrName
 300                -> RnM (HsValBinds Name, DefUses)
 301
 302 rnValBindsRHS trim mb_bound_names (ValBindsIn mbinds sigs)
 303   = do { sigs' <- renameSigs mb_bound_names okBindSig sigs
 304        ; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds
 305        ; case depAnalBinds binds_w_dus of
 306            (anal_binds, anal_dus) -> return (valbind', valbind'_dus)
 307               where
 308                 valbind' = ValBindsOut anal_binds sigs'
 309                 valbind'_dus = anal_dus `plusDU` usesOnly (hsSigsFVs sigs')
 310                                -- Put the sig uses *after* the bindings
 311                                -- so that the binders are removed from
 312                                -- the uses in the sigs
 313        }
 314
 315 rnValBindsRHS _ _ b = pprPanic "rnValBindsRHS" (ppr b)
 316
 317 noTrimFVs :: FreeVars -> FreeVars
 318 noTrimFVs fvs = fvs
 319
 320 -- Wrapper for local binds
 321 --
 322 -- The *client* of this function is responsible for checking for unused binders;
 323 -- it doesn't (and can't: we don't have the thing inside the binds) happen here
 324 --
 325 -- The client is also responsible for bringing the fixities into scope
 326 rnLocalValBindsRHS :: NameSet  -- names bound by the LHSes
 327                    -> HsValBindsLR Name RdrName
 328                    -> RnM (HsValBinds Name, DefUses)
 329 rnLocalValBindsRHS bound_names binds
 330   = rnValBindsRHS trim (Just bound_names) binds
 331   where
 332     trim fvs = intersectNameSet bound_names fvs
 333         -- Only keep the names the names from this group
 334
 335 -- for local binds
 336 -- wrapper that does both the left- and right-hand sides
 337 --
 338 -- here there are no local fixity decls passed in;
 339 -- the local fixity decls come from the ValBinds sigs
 340 rnLocalValBindsAndThen :: HsValBinds RdrName
 341                        -> (HsValBinds Name -> RnM (result, FreeVars))
 342                        -> RnM (result, FreeVars)
 343 rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside
 344  = do   {     -- (A) Create the local fixity environment
 345           new_fixities <- makeMiniFixityEnv [L loc sig | L loc (FixSig sig) <- sigs]
 346
 347               -- (B) Rename the LHSes
 348         ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds
 349
 350               --     ...and bring them (and their fixities) into scope
 351         ; bindLocalNamesFV bound_names              $
 352           addLocalFixities new_fixities bound_names $ do
 353
 354         {      -- (C) Do the RHS and thing inside
 355           (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs
 356         ; (result, result_fvs) <- thing_inside binds'
 357
 358                 -- Report unused bindings based on the (accurate)
 359                 -- findUses.  E.g.
 360                 --      let x = x in 3
 361                 -- should report 'x' unused
 362         ; let real_uses = findUses dus result_fvs
 363               -- Insert fake uses for variables introduced implicitly by wildcards (#4404)
 364               implicit_uses = hsValBindsImplicits binds'
 365         ; warnUnusedLocalBinds bound_names (real_uses `unionNameSets` implicit_uses)
 366
 367         ; let
 368             -- The variables "used" in the val binds are:
 369             --   (1) the uses of the binds (allUses)
 370             --   (2) the FVs of the thing-inside
 371             all_uses = allUses dus `plusFV` result_fvs
 372                 -- Note [Unused binding hack]
 373                 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
 374                 -- Note that *in contrast* to the above reporting of
 375                 -- unused bindings, (1) above uses duUses to return *all*
 376                 -- the uses, even if the binding is unused.  Otherwise consider:
 377                 --      x = 3
 378                 --      y = let p = x in 'x'    -- NB: p not used
 379                 -- If we don't "see" the dependency of 'y' on 'x', we may put the
 380                 -- bindings in the wrong order, and the type checker will complain
 381                 -- that x isn't in scope
 382                 --
 383                 -- But note that this means we won't report 'x' as unused,
 384                 -- whereas we would if we had { x = 3; p = x; y = 'x' }
 385
 386         ; return (result, all_uses) }}
 387                 -- The bound names are pruned out of all_uses
 388                 -- by the bindLocalNamesFV call above
 389
 390 rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs)
 391
 392
 393 -- Process the fixity declarations, making a FastString -> (Located Fixity) map
 394 -- (We keep the location around for reporting duplicate fixity declarations.)
 395 --
 396 -- Checks for duplicates, but not that only locally defined things are fixed.
 397 -- Note: for local fixity declarations, duplicates would also be checked in
 398 --       check_sigs below.  But we also use this function at the top level.
 399
 400 makeMiniFixityEnv :: [LFixitySig RdrName] -> RnM MiniFixityEnv
 401
 402 makeMiniFixityEnv decls = foldlM add_one emptyFsEnv decls
 403  where
 404    add_one env (L loc (FixitySig (L name_loc name) fixity)) = do
 405      { -- this fixity decl is a duplicate iff
 406        -- the ReaderName's OccName's FastString is already in the env
 407        -- (we only need to check the local fix_env because
 408        --  definitions of non-local will be caught elsewhere)
 409        let { fs = occNameFS (rdrNameOcc name)
 410            ; fix_item = L loc fixity };
 411
 412        case lookupFsEnv env fs of
 413          Nothing -> return $ extendFsEnv env fs fix_item
 414          Just (L loc' _) -> do
 415            { setSrcSpan loc $
 416              addErrAt name_loc (dupFixityDecl loc' name)
 417            ; return env}
 418      }
 419
 420 dupFixityDecl :: SrcSpan -> RdrName -> SDoc
 421 dupFixityDecl loc rdr_name
 422   = vcat [ptext (sLit "Multiple fixity declarations for") <+> quotes (ppr rdr_name),
 423           ptext (sLit "also at ") <+> ppr loc]
 424
 425 ---------------------
 426
 427 -- renaming a single bind
 428
 429 rnBindLHS :: NameMaker
 430           -> SDoc
 431           -> LHsBind RdrName
 432           -- returns the renamed left-hand side,
 433           -- and the FreeVars *of the LHS*
 434           -- (i.e., any free variables of the pattern)
 435           -> RnM (LHsBindLR Name RdrName)
 436
 437 rnBindLHS name_maker _ (L loc bind@(PatBind { pat_lhs = pat }))
 438   = setSrcSpan loc $ do
 439       -- we don't actually use the FV processing of rnPatsAndThen here
 440       (pat',pat'_fvs) <- rnBindPat name_maker pat
 441       return (L loc (bind { pat_lhs = pat', bind_fvs = pat'_fvs }))
 442                 -- We temporarily store the pat's FVs in bind_fvs;
 443                 -- gets updated to the FVs of the whole bind
 444                 -- when doing the RHS below
 445
 446 rnBindLHS name_maker _ (L loc bind@(FunBind { fun_id = name@(L nameLoc _) }))
 447   = setSrcSpan loc $
 448     do { newname <- applyNameMaker name_maker name
 449        ; return (L loc (bind { fun_id = L nameLoc newname })) }
 450
 451 rnBindLHS _ _ b = pprPanic "rnBindLHS" (ppr b)
 452
 453 -- assumes the left-hands-side vars are in scope
 454 rnBind :: (Name -> [Name])              -- Signature tyvar function
 455        -> (FreeVars -> FreeVars)        -- Trimming function for rhs free vars
 456        -> LHsBindLR Name RdrName
 457        -> RnM (LHsBind Name, [Name], Uses)
 458 rnBind _ trim (L loc bind@(PatBind { pat_lhs = pat
 459                                    , pat_rhs = grhss
 460                                       -- pat fvs were stored in bind_fvs
 461                                       -- after processing the LHS
 462                                    , bind_fvs = pat_fvs }))
 463   = setSrcSpan loc $
 464     do  { let bndrs = collectPatBinders pat
 465
 466         ; (grhss', fvs) <- rnGRHSs PatBindRhs grhss
 467                 -- No scoped type variables for pattern bindings
 468         ; let all_fvs = pat_fvs `plusFV` fvs
 469               fvs'    = trim all_fvs
 470
 471         ; fvs' `seq` -- See Note [Free-variable space leak]
 472           return (L loc (bind { pat_rhs  = grhss'
 473                               , bind_fvs = fvs' }),
 474                   bndrs, all_fvs) }
 475
 476 rnBind sig_fn trim
 477        (L loc bind@(FunBind { fun_id = name
 478                             , fun_infix = is_infix
 479                             , fun_matches = matches }))
 480        -- invariant: no free vars here when it's a FunBind
 481   = setSrcSpan loc $
 482     do  { let plain_name = unLoc name
 483
 484         ; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
 485                                 -- bindSigTyVars tests for Opt_ScopedTyVars
 486                              rnMatchGroup (FunRhs plain_name is_infix) matches
 487         ; let fvs' = trim fvs
 488
 489         ; when is_infix $ checkPrecMatch plain_name matches'
 490
 491         ; fvs' `seq` -- See Note [Free-variable space leak]
 492
 493           return (L loc (bind { fun_matches = matches'
 494                               , bind_fvs   = fvs' }),
 495                   [plain_name], fvs)
 496       }
 497
 498 rnBind _ _ b = pprPanic "rnBind" (ppr b)
 499
 500 {-
 501 Note [Free-variable space leak]
 502 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 503 We have
 504     fvs' = trim fvs
 505 and we seq fvs' before turning it as part of a record.
 506
 507 The reason is that trim is sometimes something like
 508     \xs -> intersectNameSet (mkNameSet bound_names) xs
 509 and we don't want to retain the list bound_names. This showed up in
 510 trac ticket #1136.
 511 -}
 512
 513 ---------------------
 514 depAnalBinds :: Bag (LHsBind Name, [Name], Uses)
 515              -> ([(RecFlag, LHsBinds Name)], DefUses)
 516 -- Dependency analysis; this is important so that
 517 -- unused-binding reporting is accurate
 518 depAnalBinds binds_w_dus
 519   = (map get_binds sccs, map get_du sccs)
 520   where
 521     sccs = stronglyConnCompFromEdgedVertices edges
 522
 523     keyd_nodes = bagToList binds_w_dus `zip` [0::Int ..]
 524
 525     edges = [ (node, key, [key | n <- nameSetToList uses,
 526                                  Just key <- [lookupNameEnv key_map n] ])
 527             | (node@(_,_,uses), key) <- keyd_nodes ]
 528
 529     key_map :: NameEnv Int      -- Which binding it comes from
 530     key_map = mkNameEnv [(bndr, key) | ((_, bndrs, _), key) <- keyd_nodes
 531                                      , bndr <- bndrs ]
 532
 533     get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind)
 534     get_binds (CyclicSCC  binds_w_dus)  = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus])
 535
 536     get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses)
 537     get_du (CyclicSCC  binds_w_dus)      = (Just defs, uses)
 538         where
 539           defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs]
 540           uses = unionManyNameSets [u | (_,_,u) <- binds_w_dus]
 541
 542
 543 ---------------------
 544 -- Bind the top-level forall'd type variables in the sigs.
 545 -- E.g  f :: a -> a
 546 --      f = rhs
 547 --      The 'a' scopes over the rhs
 548 --
 549 -- NB: there'll usually be just one (for a function binding)
 550 --     but if there are many, one may shadow the rest; too bad!
 551 --      e.g  x :: [a] -> [a]
 552 --           y :: [(a,a)] -> a
 553 --           (x,y) = e
 554 --      In e, 'a' will be in scope, and it'll be the one from 'y'!
 555
 556 mkSigTvFn :: [LSig Name] -> (Name -> [Name])
 557 -- Return a lookup function that maps an Id Name to the names
 558 -- of the type variables that should scope over its body..
 559 mkSigTvFn sigs
 560   = \n -> lookupNameEnv env n `orElse` []
 561   where
 562     env :: NameEnv [Name]
 563     env = mkNameEnv [ (name, map hsLTyVarName ltvs)
 564                     | L _ (TypeSig (L _ name)
 565                                    (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs]
 566         -- Note the pattern-match on "Explicit"; we only bind
 567         -- type variables from signatures with an explicit top-level for-all
 568 \end{code}
 569
 570
 571 @rnMethodBinds@ is used for the method bindings of a class and an instance
 572 declaration.   Like @rnBinds@ but without dependency analysis.
 573
 574 NOTA BENE: we record each {\em binder} of a method-bind group as a free variable.
 575 That's crucial when dealing with an instance decl:
 576 \begin{verbatim}
 577         instance Foo (T a) where
 578            op x = ...
 579 \end{verbatim}
 580 This might be the {\em sole} occurrence of @op@ for an imported class @Foo@,
 581 and unless @op@ occurs we won't treat the type signature of @op@ in the class
 582 decl for @Foo@ as a source of instance-decl gates.  But we should!  Indeed,
 583 in many ways the @op@ in an instance decl is just like an occurrence, not
 584 a binder.
 585
 586 \begin{code}
 587 rnMethodBinds :: Name                   -- Class name
 588               -> (Name -> [Name])       -- Signature tyvar function
 589               -> [Name]                 -- Names for generic type variables
 590               -> LHsBinds RdrName
 591               -> RnM (LHsBinds Name, FreeVars)
 592
 593 rnMethodBinds cls sig_fn gen_tyvars binds
 594   = do { checkDupRdrNames meth_names
 595              -- Check that the same method is not given twice in the
 596              -- same instance decl      instance C T where
 597              --                       f x = ...
 598              --                       g y = ...
 599              --                       f x = ...
 600              -- We must use checkDupRdrNames because the Name of the
 601              -- method is the Name of the class selector, whose SrcSpan
 602              -- points to the class declaration; and we use rnMethodBinds
 603              -- for instance decls too
 604
 605        ; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) }
 606   where
 607     meth_names  = collectMethodBinders binds
 608     do_one (binds,fvs) bind
 609        = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn gen_tyvars bind
 610             ; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) }
 611
 612 rnMethodBind :: Name
 613               -> (Name -> [Name])
 614               -> [Name]
 615               -> LHsBindLR RdrName RdrName
 616               -> RnM (Bag (LHsBindLR Name Name), FreeVars)
 617 rnMethodBind cls sig_fn gen_tyvars
 618              (L loc bind@(FunBind { fun_id = name, fun_infix = is_infix
 619                                   , fun_matches = MatchGroup matches _ }))
 620   = setSrcSpan loc $ do
 621     sel_name <- wrapLocM (lookupInstDeclBndr cls) name
 622     let plain_name = unLoc sel_name
 623         -- We use the selector name as the binder
 624
 625     (new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
 626                           mapFvRn (rn_match (FunRhs plain_name is_infix)) matches
 627     let new_group = MatchGroup new_matches placeHolderType
 628
 629     when is_infix $ checkPrecMatch plain_name new_group
 630     return (unitBag (L loc (bind { fun_id      = sel_name
 631                                  , fun_matches = new_group
 632                                  , bind_fvs    = fvs })),
 633              fvs `addOneFV` plain_name)
 634         -- The 'fvs' field isn't used for method binds
 635   where
 636         -- Truly gruesome; bring into scope the correct members of the generic
 637         -- type variables.  See comments in RnSource.rnSourceDecl(ClassDecl)
 638     rn_match info match@(L _ (Match (L _ (TypePat ty) : _) _ _))
 639         = extendTyVarEnvFVRn gen_tvs    $
 640           rnMatch info match
 641         where
 642           tvs     = map (rdrNameOcc.unLoc) (extractHsTyRdrTyVars ty)
 643           gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs]
 644
 645     rn_match info match = rnMatch info match
 646
 647 -- Can't handle method pattern-bindings which bind multiple methods.
 648 rnMethodBind _ _ _ (L loc bind@(PatBind {})) = do
 649     addErrAt loc (methodBindErr bind)
 650     return (emptyBag, emptyFVs)
 651
 652 rnMethodBind _ _ _ b = pprPanic "rnMethodBind" (ppr b)
 653 \end{code}
 654
 655
 656
 657 %************************************************************************
 658 %*                                                                      *
 659 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
 660 %*                                                                      *
 661 %************************************************************************
 662
 663 @renameSigs@ checks for:
 664 \begin{enumerate}
 665 \item more than one sig for one thing;
 666 \item signatures given for things not bound here;
 667 \end{enumerate}
 668 %
 669 At the moment we don't gather free-var info from the types in
 670 signatures.  We'd only need this if we wanted to report unused tyvars.
 671
 672 \begin{code}
 673 renameSigs :: Maybe NameSet             -- If (Just ns) complain if the sig isn't for one of ns
 674            -> (Sig Name -> Bool)        -- Complain about the wrong kind of signature if this is False
 675            -> [LSig RdrName]
 676            -> RnM [LSig Name]
 677 -- Renames the signatures and performs error checks
 678 renameSigs mb_names ok_sig sigs
 679   = do  { mapM_ dupSigDeclErr (findDupsEq eqHsSig sigs)  -- Duplicate
 680                 -- Check for duplicates on RdrName version,
 681                 -- because renamed version has unboundName for
 682                 -- not-in-scope binders, which gives bogus dup-sig errors
 683                 -- NB: in a class decl, a 'generic' sig is not considered
 684                 --     equal to an ordinary sig, so we allow, say
 685                 --           class C a where
 686                 --             op :: a -> a
 687                 --             generic op :: Eq a => a -> a
 688
 689         ; sigs' <- mapM (wrapLocM (renameSig mb_names)) sigs
 690
 691         ; let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs'
 692         ; mapM_ misplacedSigErr bad_sigs                 -- Misplaced
 693
 694         ; return good_sigs }
 695
 696 ----------------------
 697 -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
 698 -- because this won't work for:
 699 --      instance Foo T where
 700 --        {-# INLINE op #-}
 701 --        Baz.op = ...
 702 -- We'll just rename the INLINE prag to refer to whatever other 'op'
 703 -- is in scope.  (I'm assuming that Baz.op isn't in scope unqualified.)
 704 -- Doesn't seem worth much trouble to sort this.
 705
 706 renameSig :: Maybe NameSet -> Sig RdrName -> RnM (Sig Name)
 707 -- FixitySig is renamed elsewhere.
 708 renameSig _ (IdSig x)
 709   = return (IdSig x)      -- Actually this never occurs
 710 renameSig mb_names sig@(TypeSig v ty)
 711   = do  { new_v <- lookupSigOccRn mb_names sig v
 712         ; new_ty <- rnHsSigType (quotes (ppr v)) ty
 713         ; return (TypeSig new_v new_ty) }
 714
 715 renameSig mb_names sig@(GenericSig v ty)
 716   = do  { defaultSigs_on <- xoptM Opt_DefaultSignatures
 717         ; unless defaultSigs_on (addErr (defaultSigErr sig))
 718         ; new_v <- lookupSigOccRn mb_names sig v
 719         ; new_ty <- rnHsSigType (quotes (ppr v)) ty
 720         ; return (GenericSig new_v new_ty) } -- JPM: ?
 721
 722 renameSig _ (SpecInstSig ty)
 723   = do  { new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty
 724         ; return (SpecInstSig new_ty) }
 725
 726 -- {-# SPECIALISE #-} pragmas can refer to imported Ids
 727 -- so, in the top-level case (when mb_names is Nothing)
 728 -- we use lookupOccRn.  If there's both an imported and a local 'f'
 729 -- then the SPECIALISE pragma is ambiguous, unlike all other signatures
 730 renameSig mb_names sig@(SpecSig v ty inl)
 731   = do  { new_v <- case mb_names of
 732                      Just {} -> lookupSigOccRn mb_names sig v
 733                      Nothing -> lookupLocatedOccRn v
 734         ; new_ty <- rnHsSigType (quotes (ppr v)) ty
 735         ; return (SpecSig new_v new_ty inl) }
 736
 737 renameSig mb_names sig@(InlineSig v s)
 738   = do  { new_v <- lookupSigOccRn mb_names sig v
 739         ; return (InlineSig new_v s) }
 740
 741 renameSig mb_names sig@(FixSig (FixitySig v f))
 742   = do  { new_v <- lookupSigOccRn mb_names sig v
 743         ; return (FixSig (FixitySig new_v f)) }
 744 \end{code}
 745
 746
 747 %************************************************************************
 748 %*                                                                      *
 749 \subsection{Match}
 750 %*                                                                      *
 751 %************************************************************************
 752
 753 \begin{code}
 754 rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars)
 755 rnMatchGroup ctxt (MatchGroup ms _)
 756   = do { (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt) ms
 757        ; return (MatchGroup new_ms placeHolderType, ms_fvs) }
 758
 759 rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars)
 760 rnMatch ctxt  = wrapLocFstM (rnMatch' ctxt)
 761
 762 rnMatch' :: HsMatchContext Name -> Match RdrName -> RnM (Match Name, FreeVars)
 763 rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss)
 764   = do  {       -- Result type signatures are no longer supported
 765           case maybe_rhs_sig of
 766                 Nothing -> return ()
 767                 Just (L loc ty) -> addErrAt loc (resSigErr ctxt match ty)
 768
 769                -- Now the main event
 770                -- note that there are no local ficity decls for matches
 771         ; rnPats ctxt pats      $ \ pats' -> do
 772         { (grhss', grhss_fvs) <- rnGRHSs ctxt grhss
 773
 774         ; return (Match pats' Nothing grhss', grhss_fvs) }}
 775         -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs
 776
 777 resSigErr :: HsMatchContext Name -> Match RdrName -> HsType RdrName -> SDoc
 778 resSigErr ctxt match ty
 779    = vcat [ ptext (sLit "Illegal result type signature") <+> quotes (ppr ty)
 780           , nest 2 $ ptext (sLit "Result signatures are no longer supported in pattern matches")
 781           , pprMatchInCtxt ctxt match ]
 782 \end{code}
 783
 784
 785 %************************************************************************
 786 %*                                                                      *
 787 \subsubsection{Guarded right-hand sides (GRHSs)}
 788 %*                                                                      *
 789 %************************************************************************
 790
 791 \begin{code}
 792 rnGRHSs :: HsMatchContext Name -> GRHSs RdrName -> RnM (GRHSs Name, FreeVars)
 793
 794 rnGRHSs ctxt (GRHSs grhss binds)
 795   = rnLocalBindsAndThen binds   $ \ binds' -> do
 796     (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt) grhss
 797     return (GRHSs grhss' binds', fvGRHSs)
 798
 799 rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars)
 800 rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt)
 801
 802 rnGRHS' :: HsMatchContext Name -> GRHS RdrName -> RnM (GRHS Name, FreeVars)
 803 rnGRHS' ctxt (GRHS guards rhs)
 804   = do  { pattern_guards_allowed <- xoptM Opt_PatternGuards
 805         ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $ \ _ ->
 806                                     rnLExpr rhs
 807
 808         ; unless (pattern_guards_allowed || is_standard_guard guards')
 809                  (addWarn (nonStdGuardErr guards'))
 810
 811         ; return (GRHS guards' rhs', fvs) }
 812   where
 813         -- Standard Haskell 1.4 guards are just a single boolean
 814         -- expression, rather than a list of qualifiers as in the
 815         -- Glasgow extension
 816     is_standard_guard []                     = True
 817     is_standard_guard [L _ (ExprStmt _ _ _)] = True
 818     is_standard_guard _                      = False
 819 \end{code}
 820
 821 %************************************************************************
 822 %*                                                                      *
 823 \subsection{Error messages}
 824 %*                                                                      *
 825 %************************************************************************
 826
 827 \begin{code}
 828 dupSigDeclErr :: [LSig RdrName] -> RnM ()
 829 dupSigDeclErr sigs@(L loc sig : _)
 830   = addErrAt loc $
 831         vcat [ptext (sLit "Duplicate") <+> what_it_is <> colon,
 832               nest 2 (vcat (map ppr_sig sigs))]
 833   where
 834     what_it_is = hsSigDoc sig
 835     ppr_sig (L loc sig) = ppr loc <> colon <+> ppr sig
 836 dupSigDeclErr [] = panic "dupSigDeclErr"
 837
 838 misplacedSigErr :: LSig Name -> RnM ()
 839 misplacedSigErr (L loc sig)
 840   = addErrAt loc $
 841     sep [ptext (sLit "Misplaced") <+> hsSigDoc sig <> colon, ppr sig]
 842
 843 defaultSigErr :: Sig RdrName -> SDoc
 844 defaultSigErr sig = vcat [ hang (ptext (sLit "Unexpected default signature:"))
 845                               2 (ppr sig)
 846                          , ptext (sLit "Use -XDefaultSignatures to enable default signatures") ]
 847
 848 methodBindErr :: HsBindLR RdrName RdrName -> SDoc
 849 methodBindErr mbind
 850  =  hang (ptext (sLit "Pattern bindings (except simple variables) not allowed in instance declarations"))
 851        2 (ppr mbind)
 852
 853 bindsInHsBootFile :: LHsBindsLR Name RdrName -> SDoc
 854 bindsInHsBootFile mbinds
 855   = hang (ptext (sLit "Bindings in hs-boot files are not allowed"))
 856        2 (ppr mbinds)
 857
 858 nonStdGuardErr :: [LStmtLR Name Name] -> SDoc
 859 nonStdGuardErr guards
 860   = hang (ptext (sLit "accepting non-standard pattern guards (use -XPatternGuards to suppress this message)"))
 861        4 (interpp'SP guards)
 862
 863 \end{code}