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