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