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, MiniFixityEnv
  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
  40 import DynFlags ( DynFlag(..) )
  41 import HscTypes         (FixItem(..))
  42 import Name
  43 import NameEnv
  44 import LazyUniqFM
  45 import NameSet
  46 import PrelNames        ( isUnboundName )
  47 import RdrName          ( RdrName, rdrNameOcc )
  48 import SrcLoc           ( Located(..), unLoc, noLoc )
  49 import ListSetOps       ( findDupsEq )
  50 import BasicTypes       ( RecFlag(..) )
  51 import Digraph          ( SCC(..), stronglyConnComp )
  52 import Bag
  53 import Outputable
  54 import FastString
  55 import Maybes           ( orElse )
  56 import Util             ( filterOut )
  57 import Monad            ( foldM, unless )
  58 \end{code}
  59
  60 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
  61 -- place and can be used when complaining.
  62
  63 The code tree received by the function @rnBinds@ contains definitions
  64 in where-clauses which are all apparently mutually recursive, but which may
  65 not really depend upon each other. For example, in the top level program
  66 \begin{verbatim}
  67 f x = y where a = x
  68               y = x
  69 \end{verbatim}
  70 the definitions of @a@ and @y@ do not depend on each other at all.
  71 Unfortunately, the typechecker cannot always check such definitions.
  72 \footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
  73 definitions. In Proceedings of the International Symposium on Programming,
  74 Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
  75 However, the typechecker usually can check definitions in which only the
  76 strongly connected components have been collected into recursive bindings.
  77 This is precisely what the function @rnBinds@ does.
  78
  79 ToDo: deal with case where a single monobinds binds the same variable
  80 twice.
  81
  82 The vertag tag is a unique @Int@; the tags only need to be unique
  83 within one @MonoBinds@, so that unique-Int plumbing is done explicitly
  84 (heavy monad machinery not needed).
  85
  86
  87 %************************************************************************
  88 %*                                                                      *
  89 %* naming conventions                                                   *
  90 %*                                                                      *
  91 %************************************************************************
  92
  93 \subsection[name-conventions]{Name conventions}
  94
  95 The basic algorithm involves walking over the tree and returning a tuple
  96 containing the new tree plus its free variables. Some functions, such
  97 as those walking polymorphic bindings (HsBinds) and qualifier lists in
  98 list comprehensions (@Quals@), return the variables bound in local
  99 environments. These are then used to calculate the free variables of the
 100 expression evaluated in these environments.
 101
 102 Conventions for variable names are as follows:
 103 \begin{itemize}
 104 \item
 105 new code is given a prime to distinguish it from the old.
 106
 107 \item
 108 a set of variables defined in @Exp@ is written @dvExp@
 109
 110 \item
 111 a set of variables free in @Exp@ is written @fvExp@
 112 \end{itemize}
 113
 114 %************************************************************************
 115 %*                                                                      *
 116 %* analysing polymorphic bindings (HsBindGroup, HsBind)
 117 %*                                                                      *
 118 %************************************************************************
 119
 120 \subsubsection[dep-HsBinds]{Polymorphic bindings}
 121
 122 Non-recursive expressions are reconstructed without any changes at top
 123 level, although their component expressions may have to be altered.
 124 However, non-recursive expressions are currently not expected as
 125 \Haskell{} programs, and this code should not be executed.
 126
 127 Monomorphic bindings contain information that is returned in a tuple
 128 (a @FlatMonoBinds@) containing:
 129
 130 \begin{enumerate}
 131 \item
 132 a unique @Int@ that serves as the ``vertex tag'' for this binding.
 133
 134 \item
 135 the name of a function or the names in a pattern. These are a set
 136 referred to as @dvLhs@, the defined variables of the left hand side.
 137
 138 \item
 139 the free variables of the body. These are referred to as @fvBody@.
 140
 141 \item
 142 the definition's actual code. This is referred to as just @code@.
 143 \end{enumerate}
 144
 145 The function @nonRecDvFv@ returns two sets of variables. The first is
 146 the set of variables defined in the set of monomorphic bindings, while the
 147 second is the set of free variables in those bindings.
 148
 149 The set of variables defined in a non-recursive binding is just the
 150 union of all of them, as @union@ removes duplicates. However, the
 151 free variables in each successive set of cumulative bindings is the
 152 union of those in the previous set plus those of the newest binding after
 153 the defined variables of the previous set have been removed.
 154
 155 @rnMethodBinds@ deals only with the declarations in class and
 156 instance declarations.  It expects only to see @FunMonoBind@s, and
 157 it expects the global environment to contain bindings for the binders
 158 (which are all class operations).
 159
 160 %************************************************************************
 161 %*                                                                      *
 162 \subsubsection{ Top-level bindings}
 163 %*                                                                      *
 164 %************************************************************************
 165
 166 \begin{code}
 167 -- for top-level bindings, we need to make top-level names,
 168 -- so we have a different entry point than for local bindings
 169 rnTopBindsLHS :: MiniFixityEnv
 170               -> HsValBinds RdrName
 171               -> RnM (HsValBindsLR Name RdrName)
 172 rnTopBindsLHS fix_env binds =
 173     (uncurry $ rnValBindsLHSFromDoc (topRecNameMaker fix_env)) (bindersAndDoc binds) binds
 174
 175 rnTopBindsRHS :: [Name] -- the names bound by these binds
 176               -> HsValBindsLR Name RdrName
 177               -> RnM (HsValBinds Name, DefUses)
 178 rnTopBindsRHS bound_names binds =
 179     do { is_boot <- tcIsHsBoot
 180        ; if is_boot
 181          then rnTopBindsBoot binds
 182          else rnValBindsRHSGen (\x -> x) -- don't trim free vars
 183                                bound_names binds }
 184
 185
 186 -- wrapper if we don't need to do anything in between the left and right,
 187 -- or anything else in the scope of the left
 188 --
 189 -- never used when there are fixity declarations
 190 rnTopBinds :: HsValBinds RdrName
 191            -> RnM (HsValBinds Name, DefUses)
 192 rnTopBinds b =
 193   do nl <- rnTopBindsLHS emptyOccEnv b
 194      let bound_names = map unLoc (collectHsValBinders nl)
 195      bindLocalNames bound_names  $ rnTopBindsRHS bound_names nl
 196
 197
 198 rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
 199 -- A hs-boot file has no bindings.
 200 -- Return a single HsBindGroup with empty binds and renamed signatures
 201 rnTopBindsBoot (ValBindsIn mbinds sigs)
 202   = do  { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
 203         ; sigs' <- renameSigs okHsBootSig sigs
 204         ; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) }
 205 \end{code}
 206
 207
 208
 209 %*********************************************************
 210 %*                                                      *
 211                 HsLocalBinds
 212 %*                                                      *
 213 %*********************************************************
 214
 215 \begin{code}
 216 rnLocalBindsAndThen :: HsLocalBinds RdrName
 217                     -> (HsLocalBinds Name -> RnM (result, FreeVars))
 218                     -> RnM (result, FreeVars)
 219 -- This version (a) assumes that the binding vars are *not* already in scope
 220 --               (b) removes the binders from the free vars of the thing inside
 221 -- The parser doesn't produce ThenBinds
 222 rnLocalBindsAndThen EmptyLocalBinds thing_inside
 223   = thing_inside EmptyLocalBinds
 224
 225 rnLocalBindsAndThen (HsValBinds val_binds) thing_inside
 226   = rnValBindsAndThen val_binds $ \ val_binds' ->
 227       thing_inside (HsValBinds val_binds')
 228
 229 rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do
 230     (binds',fv_binds) <- rnIPBinds binds
 231     (thing, fvs_thing) <- thing_inside (HsIPBinds binds')
 232     return (thing, fvs_thing `plusFV` fv_binds)
 233
 234
 235 rnIPBinds (IPBinds ip_binds _no_dict_binds) = do
 236     (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds
 237     return (IPBinds ip_binds' emptyLHsBinds, plusFVs fvs_s)
 238
 239 rnIPBind (IPBind n expr) = do
 240     name <- newIPNameRn  n
 241     (expr',fvExpr) <- rnLExpr expr
 242     return (IPBind name expr', fvExpr)
 243 \end{code}
 244
 245
 246 %************************************************************************
 247 %*                                                                      *
 248                 ValBinds
 249 %*                                                                      *
 250 %************************************************************************
 251
 252 \begin{code}
 253 -- wrapper for local binds
 254 -- creates the documentation info and calls the helper below
 255 rnValBindsLHS :: MiniFixityEnv
 256               -> HsValBinds RdrName
 257               -> RnM (HsValBindsLR Name RdrName)
 258 rnValBindsLHS fix_env binds =
 259     let (boundNames,doc) = bindersAndDoc binds
 260     in rnValBindsLHSFromDoc_Local boundNames doc fix_env binds
 261
 262 -- a helper used for local binds that does the duplicates check,
 263 -- just so we don't forget to do it somewhere
 264 rnValBindsLHSFromDoc_Local :: [Located RdrName] -- RdrNames of the LHS (so we don't have to gather them twice)
 265                            -> SDoc              -- doc string for dup names and shadowing
 266                            -> MiniFixityEnv
 267                            -> HsValBinds RdrName
 268                            -> RnM (HsValBindsLR Name RdrName)
 269
 270 rnValBindsLHSFromDoc_Local boundNames doc fix_env binds = do
 271      -- Do error checking: we need to check for dups here because we
 272      -- don't don't bind all of the variables from the ValBinds at once
 273      -- with bindLocatedLocals any more.
 274      checkDupAndShadowedRdrNames doc boundNames
 275
 276      -- (Note that we don't want to do this at the top level, since
 277      -- sorting out duplicates and shadowing there happens elsewhere.
 278      -- The behavior is even different. For example,
 279      --   import A(f)
 280      --   f = ...
 281      -- should not produce a shadowing warning (but it will produce
 282      -- an ambiguity warning if you use f), but
 283      --   import A(f)
 284      --   g = let f = ... in f
 285      -- should.
 286      rnValBindsLHSFromDoc (localRecNameMaker fix_env) boundNames doc binds
 287
 288 bindersAndDoc :: HsValBinds RdrName -> ([Located RdrName], SDoc)
 289 bindersAndDoc binds =
 290     let
 291         -- the unrenamed bndrs for error checking and reporting
 292         orig = collectHsValBinders binds
 293         doc = text "In the binding group for:" <+> pprWithCommas ppr (map unLoc orig)
 294     in
 295       (orig, doc)
 296
 297 -- renames the left-hand sides
 298 -- generic version used both at the top level and for local binds
 299 -- does some error checking, but not what gets done elsewhere at the top level
 300 rnValBindsLHSFromDoc :: NameMaker
 301                      -> [Located RdrName] -- RdrNames of the LHS (so we don't have to gather them twice)
 302                      -> SDoc              -- doc string for dup names and shadowing
 303                      -> HsValBinds RdrName
 304                      -> RnM (HsValBindsLR Name RdrName)
 305 rnValBindsLHSFromDoc topP original_bndrs doc binds@(ValBindsIn mbinds sigs) = do
 306      -- rename the LHSes
 307      mbinds' <- mapBagM (rnBindLHS topP doc) mbinds
 308      return $ ValBindsIn mbinds' sigs
 309
 310 -- assumes the LHS vars are in scope
 311 -- general version used both from the top-level and for local things
 312 --
 313 -- does not bind the local fixity declarations
 314 rnValBindsRHSGen :: (FreeVars -> FreeVars)  -- for trimming free var sets
 315                      -- The trimming function trims the free vars we attach to a
 316                      -- binding so that it stays reasonably small
 317                  -> [Name]  -- names bound by the LHSes
 318                  -> HsValBindsLR Name RdrName
 319                  -> RnM (HsValBinds Name, DefUses)
 320
 321 rnValBindsRHSGen trim bound_names binds@(ValBindsIn mbinds sigs) = do
 322    -- rename the sigs
 323    env <- getGblEnv
 324    traceRn (ptext SLIT("Rename sigs") <+> ppr (tcg_rdr_env env))
 325    sigs' <- rename_sigs sigs
 326    -- rename the RHSes
 327    binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds
 328    let (anal_binds, anal_dus) = depAnalBinds binds_w_dus
 329        (valbind', valbind'_dus) = (ValBindsOut anal_binds sigs',
 330                                    usesOnly (hsSigsFVs sigs') `plusDU` anal_dus)
 331    -- We do the check-sigs after renaming the bindings,
 332    -- so that we have convenient access to the binders
 333    check_sigs (okBindSig (duDefs anal_dus)) sigs'
 334    return (valbind', valbind'_dus)
 335
 336 -- Wrapper for local binds
 337 --
 338 -- The *client* of this function is responsible for checking for unused binders;
 339 -- it doesn't (and can't: we don't have the thing inside the binds) happen here
 340 --
 341 -- The client is also responsible for bringing the fixities into scope
 342 rnValBindsRHS :: [Name]  -- names bound by the LHSes
 343               -> HsValBindsLR Name RdrName
 344               -> RnM (HsValBinds Name, DefUses)
 345 rnValBindsRHS bound_names binds =
 346   rnValBindsRHSGen (\ fvs -> -- only keep the names the names from this group
 347                     intersectNameSet (mkNameSet bound_names) fvs) bound_names binds
 348
 349
 350 -- for local binds
 351 -- wrapper that does both the left- and right-hand sides
 352 --
 353 -- here there are no local fixity decls passed in;
 354 -- the local fixity decls come from the ValBinds sigs
 355 rnValBindsAndThen :: HsValBinds RdrName
 356                   -> (HsValBinds Name -> RnM (result, FreeVars))
 357                   -> RnM (result, FreeVars)
 358 rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside
 359  = do   { let (original_bndrs, doc) = bindersAndDoc binds
 360
 361               -- (A) Create the local fixity environment
 362         ; new_fixities <- makeMiniFixityEnv [L loc sig | L loc (FixSig sig) <- sigs]
 363
 364               -- (B) Rename the LHSes
 365         ; new_lhs <- rnValBindsLHSFromDoc_Local original_bndrs doc new_fixities binds
 366         ; let bound_names = map unLoc $ collectHsValBinders new_lhs
 367
 368               --     ...and bring them (and their fixities) into scope
 369         ; bindLocalNamesFV_WithFixities bound_names new_fixities $ do
 370
 371         {      -- (C) Do the RHS and thing inside
 372           (binds', dus) <- rnValBindsRHS bound_names new_lhs
 373         ; (result, result_fvs) <- thing_inside binds'
 374
 375                 -- Report unused bindings based on the (accurate)
 376                 -- findUses.  E.g.
 377                 --      let x = x in 3
 378                 -- should report 'x' unused
 379         ; let real_uses = findUses dus result_fvs
 380         ; warnUnusedLocalBinds bound_names real_uses
 381
 382         ; let
 383             -- The variables "used" in the val binds are:
 384             --   (1) the uses of the binds (duUses)
 385             --   (2) the FVs of the thing-inside
 386             all_uses = duUses dus `plusFV` result_fvs
 387                 -- Note [Unused binding hack]
 388                 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
 389                 -- Note that *in contrast* to the above reporting of
 390                 -- unused bindings, (1) above uses duUses to return *all*
 391                 -- the uses, even if the binding is unused.  Otherwise consider:
 392                 --      x = 3
 393                 --      y = let p = x in 'x'    -- NB: p not used
 394                 -- If we don't "see" the dependency of 'y' on 'x', we may put the
 395                 -- bindings in the wrong order, and the type checker will complain
 396                 -- that x isn't in scope
 397                 --
 398                 -- But note that this means we won't report 'x' as unused,
 399                 -- whereas we would if we had { x = 3; p = x; y = 'x' }
 400
 401         ; return (result, all_uses) }}
 402                 -- The bound names are pruned out of all_uses
 403                 -- by the bindLocalNamesFV call above
 404
 405
 406
 407 -- Process the fixity declarations, making a FastString -> (Located Fixity) map
 408 -- (We keep the location around for reporting duplicate fixity declarations.)
 409 --
 410 -- Checks for duplicates, but not that only locally defined things are fixed.
 411 -- Note: for local fixity declarations, duplicates would also be checked in
 412 --       check_sigs below.  But we also use this function at the top level.
 413
 414 makeMiniFixityEnv :: [LFixitySig RdrName] -> RnM MiniFixityEnv
 415
 416 makeMiniFixityEnv decls = foldlM add_one emptyOccEnv decls
 417  where
 418    add_one env (L loc (FixitySig (L name_loc name) fixity)) = do
 419      { -- this fixity decl is a duplicate iff
 420        -- the ReaderName's OccName's FastString is already in the env
 421        -- (we only need to check the local fix_env because
 422        --  definitions of non-local will be caught elsewhere)
 423        let {occ = rdrNameOcc name;
 424             fix_item = L loc fixity};
 425
 426        case lookupOccEnv env occ of
 427          Nothing -> return $ extendOccEnv env occ 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}