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