ghc/compiler/rename/RnBinds.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[RnBinds]{Renaming and dependency analysis of bindings}
   5
   6 This module does renaming and dependency analysis on value bindings in
   7 the abstract syntax.  It does {\em not} do cycle-checks on class or
   8 type-synonym declarations; those cannot be done at this stage because
   9 they may be affected by renaming (which isn't fully worked out yet).
  10
  11 \begin{code}
  12 module RnBinds (
  13         rnTopBinds,
  14         rnLocalBindsAndThen, rnValBindsAndThen, rnValBinds, trimWith,
  15         rnMethodBinds, renameSigs,
  16         rnMatchGroup, rnGRHSs
  17    ) where
  18
  19 #include "HsVersions.h"
  20
  21 import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
  22
  23 import HsSyn
  24 import HsBinds          ( hsSigDoc, eqHsSig )
  25 import RdrHsSyn
  26 import RnHsSyn
  27 import TcRnMonad
  28 import RnTypes          ( rnHsSigType, rnLHsType, rnHsTypeFVs,
  29                           rnLPat, rnPatsAndThen, patSigErr, checkPrecMatch )
  30 import RnEnv            ( bindLocatedLocalsRn, lookupLocatedBndrRn,
  31                           lookupLocatedInstDeclBndr, newIPNameRn,
  32                           lookupLocatedSigOccRn, bindPatSigTyVars, bindPatSigTyVarsFV,
  33                           bindLocalFixities, bindSigTyVarsFV,
  34                           warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
  35                         )
  36 import DynFlags ( DynFlag(..) )
  37 import Name             ( Name, nameOccName, nameSrcLoc )
  38 import NameEnv
  39 import NameSet
  40 import PrelNames        ( isUnboundName )
  41 import RdrName          ( RdrName, rdrNameOcc )
  42 import SrcLoc           ( mkSrcSpan, Located(..), unLoc )
  43 import ListSetOps       ( findDupsEq )
  44 import Bag
  45 import Outputable
  46 import Maybes           ( orElse )
  47 import Monad            ( foldM )
  48 \end{code}
  49
  50 -- ToDo: Put the annotations into the monad, so that they arrive in the proper
  51 -- place and can be used when complaining.
  52
  53 The code tree received by the function @rnBinds@ contains definitions
  54 in where-clauses which are all apparently mutually recursive, but which may
  55 not really depend upon each other. For example, in the top level program
  56 \begin{verbatim}
  57 f x = y where a = x
  58               y = x
  59 \end{verbatim}
  60 the definitions of @a@ and @y@ do not depend on each other at all.
  61 Unfortunately, the typechecker cannot always check such definitions.
  62 \footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive
  63 definitions. In Proceedings of the International Symposium on Programming,
  64 Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}
  65 However, the typechecker usually can check definitions in which only the
  66 strongly connected components have been collected into recursive bindings.
  67 This is precisely what the function @rnBinds@ does.
  68
  69 ToDo: deal with case where a single monobinds binds the same variable
  70 twice.
  71
  72 The vertag tag is a unique @Int@; the tags only need to be unique
  73 within one @MonoBinds@, so that unique-Int plumbing is done explicitly
  74 (heavy monad machinery not needed).
  75
  76
  77 %************************************************************************
  78 %*                                                                      *
  79 %* naming conventions                                                   *
  80 %*                                                                      *
  81 %************************************************************************
  82
  83 \subsection[name-conventions]{Name conventions}
  84
  85 The basic algorithm involves walking over the tree and returning a tuple
  86 containing the new tree plus its free variables. Some functions, such
  87 as those walking polymorphic bindings (HsBinds) and qualifier lists in
  88 list comprehensions (@Quals@), return the variables bound in local
  89 environments. These are then used to calculate the free variables of the
  90 expression evaluated in these environments.
  91
  92 Conventions for variable names are as follows:
  93 \begin{itemize}
  94 \item
  95 new code is given a prime to distinguish it from the old.
  96
  97 \item
  98 a set of variables defined in @Exp@ is written @dvExp@
  99
 100 \item
 101 a set of variables free in @Exp@ is written @fvExp@
 102 \end{itemize}
 103
 104 %************************************************************************
 105 %*                                                                      *
 106 %* analysing polymorphic bindings (HsBindGroup, HsBind)
 107 %*                                                                      *
 108 %************************************************************************
 109
 110 \subsubsection[dep-HsBinds]{Polymorphic bindings}
 111
 112 Non-recursive expressions are reconstructed without any changes at top
 113 level, although their component expressions may have to be altered.
 114 However, non-recursive expressions are currently not expected as
 115 \Haskell{} programs, and this code should not be executed.
 116
 117 Monomorphic bindings contain information that is returned in a tuple
 118 (a @FlatMonoBinds@) containing:
 119
 120 \begin{enumerate}
 121 \item
 122 a unique @Int@ that serves as the ``vertex tag'' for this binding.
 123
 124 \item
 125 the name of a function or the names in a pattern. These are a set
 126 referred to as @dvLhs@, the defined variables of the left hand side.
 127
 128 \item
 129 the free variables of the body. These are referred to as @fvBody@.
 130
 131 \item
 132 the definition's actual code. This is referred to as just @code@.
 133 \end{enumerate}
 134
 135 The function @nonRecDvFv@ returns two sets of variables. The first is
 136 the set of variables defined in the set of monomorphic bindings, while the
 137 second is the set of free variables in those bindings.
 138
 139 The set of variables defined in a non-recursive binding is just the
 140 union of all of them, as @union@ removes duplicates. However, the
 141 free variables in each successive set of cumulative bindings is the
 142 union of those in the previous set plus those of the newest binding after
 143 the defined variables of the previous set have been removed.
 144
 145 @rnMethodBinds@ deals only with the declarations in class and
 146 instance declarations.  It expects only to see @FunMonoBind@s, and
 147 it expects the global environment to contain bindings for the binders
 148 (which are all class operations).
 149
 150 %************************************************************************
 151 %*                                                                      *
 152 \subsubsection{ Top-level bindings}
 153 %*                                                                      *
 154 %************************************************************************
 155
 156 @rnTopMonoBinds@ assumes that the environment already
 157 contains bindings for the binders of this particular binding.
 158
 159 \begin{code}
 160 rnTopBinds :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses)
 161
 162 -- The binders of the binding are in scope already;
 163 -- the top level scope resolution does that
 164
 165 rnTopBinds binds
 166  =  do  { is_boot <- tcIsHsBoot
 167         ; if is_boot then rnTopBindsBoot binds
 168                      else rnTopBindsSrc  binds }
 169
 170 rnTopBindsBoot :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses)
 171 -- A hs-boot file has no bindings.
 172 -- Return a single HsBindGroup with empty binds and renamed signatures
 173 rnTopBindsBoot (ValBindsIn mbinds sigs)
 174   = do  { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
 175         ; sigs' <- renameSigs okHsBootSig sigs
 176         ; return (ValBindsIn emptyLHsBinds sigs', usesOnly (hsSigsFVs sigs')) }
 177
 178 rnTopBindsSrc :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses)
 179 rnTopBindsSrc binds@(ValBindsIn mbinds _)
 180   = bindPatSigTyVars (collectSigTysFromHsBinds (bagToList mbinds)) $ \ _ ->
 181         -- Hmm; by analogy with Ids, this doesn't look right
 182         -- Top-level bound type vars should really scope over
 183         -- everything, but we only scope them over the other bindings
 184
 185     do  { (binds', dus) <- rnValBinds noTrim binds
 186
 187                 -- Warn about missing signatures,
 188         ; let   { ValBindsIn _ sigs' = binds'
 189                 ; ty_sig_vars = mkNameSet [ unLoc n | L _ (Sig n _) <- sigs']
 190                 ; un_sigd_bndrs = duDefs dus `minusNameSet` ty_sig_vars }
 191
 192         ; warn_missing_sigs <- doptM Opt_WarnMissingSigs
 193         ; ifM (warn_missing_sigs)
 194               (mappM_ missingSigWarn (nameSetToList un_sigd_bndrs))
 195
 196         ; return (binds', dus)
 197         }
 198 \end{code}
 199
 200
 201
 202 %*********************************************************
 203 %*                                                      *
 204                 HsLocalBinds
 205 %*                                                      *
 206 %*********************************************************
 207
 208 \begin{code}
 209 rnLocalBindsAndThen
 210   :: HsLocalBinds RdrName
 211   -> (HsLocalBinds Name -> RnM (result, FreeVars))
 212   -> RnM (result, FreeVars)
 213 -- This version (a) assumes that the binding vars are not already in scope
 214 --              (b) removes the binders from the free vars of the thing inside
 215 -- The parser doesn't produce ThenBinds
 216 rnLocalBindsAndThen EmptyLocalBinds thing_inside
 217   = thing_inside EmptyLocalBinds
 218
 219 rnLocalBindsAndThen (HsValBinds val_binds) thing_inside
 220   = rnValBindsAndThen val_binds $ \ val_binds' ->
 221     thing_inside (HsValBinds val_binds')
 222
 223 rnLocalBindsAndThen (HsIPBinds binds) thing_inside
 224   = rnIPBinds binds                     `thenM` \ (binds',fv_binds) ->
 225     thing_inside (HsIPBinds binds')     `thenM` \ (thing, fvs_thing) ->
 226     returnM (thing, fvs_thing `plusFV` fv_binds)
 227
 228 -------------
 229 rnIPBinds (IPBinds ip_binds _no_dict_binds)
 230   = do  { (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds
 231         ; return (IPBinds ip_binds' emptyLHsBinds, plusFVs fvs_s) }
 232
 233 rnIPBind (IPBind n expr)
 234   = newIPNameRn  n              `thenM` \ name ->
 235     rnLExpr expr                `thenM` \ (expr',fvExpr) ->
 236     return (IPBind name expr', fvExpr)
 237 \end{code}
 238
 239
 240 %************************************************************************
 241 %*                                                                      *
 242                 ValBinds
 243 %*                                                                      *
 244 %************************************************************************
 245
 246 \begin{code}
 247 rnValBindsAndThen :: HsValBinds RdrName
 248                   -> (HsValBinds Name -> RnM (result, FreeVars))
 249                   -> RnM (result, FreeVars)
 250
 251 rnValBindsAndThen binds@(ValBindsIn mbinds sigs) thing_inside
 252   =     -- Extract all the binders in this group, and extend the
 253         -- current scope, inventing new names for the new binders
 254         -- This also checks that the names form a set
 255     bindLocatedLocalsRn doc mbinders_w_srclocs                  $ \ bndrs ->
 256     bindPatSigTyVarsFV (collectSigTysFromHsBinds (bagToList mbinds))    $
 257
 258         -- Then install local fixity declarations
 259         -- Notice that they scope over thing_inside too
 260     bindLocalFixities [sig | L _ (FixSig sig) <- sigs ]         $
 261
 262         -- Do the business
 263     rnValBinds (trimWith bndrs) binds   `thenM` \ (binds, bind_dus) ->
 264
 265         -- Now do the "thing inside"
 266     thing_inside binds                  `thenM` \ (result,result_fvs) ->
 267
 268         -- Final error checking
 269     let
 270         all_uses     = duUses bind_dus `plusFV` result_fvs
 271         unused_bndrs = [ b | b <- bndrs, not (b `elemNameSet` all_uses)]
 272     in
 273     warnUnusedLocalBinds unused_bndrs   `thenM_`
 274
 275     returnM (result, delListFromNameSet all_uses bndrs)
 276         -- duUses: It's important to return all the uses, not the 'real uses'
 277         -- used for warning about unused bindings.  Otherwise consider:
 278         --      x = 3
 279         --      y = let p = x in 'x'    -- NB: p not used
 280         -- If we don't "see" the dependency of 'y' on 'x', we may put the
 281         -- bindings in the wrong order, and the type checker will complain
 282         -- that x isn't in scope
 283   where
 284     mbinders_w_srclocs = collectHsBindLocatedBinders mbinds
 285     doc = text "In the binding group for:"
 286           <+> pprWithCommas ppr (map unLoc mbinders_w_srclocs)
 287
 288 ---------------------
 289 rnValBinds :: (FreeVars -> FreeVars)
 290            -> HsValBinds RdrName
 291            -> RnM (HsValBinds Name, DefUses)
 292 -- Assumes the binders of the binding are in scope already
 293
 294 rnValBinds trim (ValBindsIn mbinds sigs)
 295   = do  { sigs' <- rename_sigs sigs
 296
 297         ; let { rn_bind = wrapLocFstM (rnBind sig_fn trim)
 298               ; sig_fn = mkSigTvFn sigs' }
 299
 300         ; (mbinds', du_bag) <- mapAndUnzipBagM rn_bind mbinds
 301
 302         ; let defs, uses :: NameSet
 303               (defs, uses) = foldrBag plus (emptyNameSet, emptyNameSet) du_bag
 304               plus (ds1,us1) (ds2,us2) = (ds1 `unionNameSets` ds2,
 305                                           us1 `unionNameSets` us2)
 306
 307         ; check_sigs (okBindSig defs) sigs'
 308
 309         ; traceRn (text "rnValBind" <+> (ppr defs $$ ppr uses))
 310         ; return (ValBindsIn mbinds' sigs',
 311                   [(Just defs, uses `plusFV` hsSigsFVs sigs')]) }
 312
 313 ---------------------
 314 -- Bind the top-level forall'd type variables in the sigs.
 315 -- E.g  f :: a -> a
 316 --      f = rhs
 317 --      The 'a' scopes over the rhs
 318 --
 319 -- NB: there'll usually be just one (for a function binding)
 320 --     but if there are many, one may shadow the rest; too bad!
 321 --      e.g  x :: [a] -> [a]
 322 --           y :: [(a,a)] -> a
 323 --           (x,y) = e
 324 --      In e, 'a' will be in scope, and it'll be the one from 'y'!
 325
 326 mkSigTvFn :: [LSig Name] -> (Name -> [Name])
 327 -- Return a lookup function that maps an Id Name to the names
 328 -- of the type variables that should scope over its body..
 329 mkSigTvFn sigs
 330   = \n -> lookupNameEnv env n `orElse` []
 331   where
 332     env :: NameEnv [Name]
 333     env = mkNameEnv [ (name, map hsLTyVarName ltvs)
 334                     | L _ (Sig (L _ name)
 335                                (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs]
 336         -- Note the pattern-match on "Explicit"; we only bind
 337         -- type variables from signatures with an explicit top-level for-all
 338
 339 -- The trimming function trims the free vars we attach to a
 340 -- binding so that it stays reasonably small
 341 noTrim :: FreeVars -> FreeVars
 342 noTrim fvs = fvs        -- Used at top level
 343
 344 trimWith :: [Name] -> FreeVars -> FreeVars
 345 -- Nested bindings; trim by intersection with the names bound here
 346 trimWith bndrs = intersectNameSet (mkNameSet bndrs)
 347
 348 ---------------------
 349 rnBind :: (Name -> [Name])              -- Signature tyvar function
 350        -> (FreeVars -> FreeVars)        -- Trimming function for rhs free vars
 351        -> HsBind RdrName
 352        -> RnM (HsBind Name, (Defs, Uses))
 353 rnBind sig_fn trim (PatBind pat grhss ty _)
 354   = do  { (pat', pat_fvs) <- rnLPat pat
 355
 356         ; let bndrs = collectPatBinders pat'
 357
 358         ; (grhss', fvs) <- bindSigTyVarsFV (concatMap sig_fn bndrs) $
 359                            rnGRHSs PatBindRhs grhss
 360
 361         ; return (PatBind pat' grhss' ty (trim fvs),
 362                   (mkNameSet bndrs, pat_fvs `plusFV` fvs)) }
 363
 364 rnBind sig_fn trim (FunBind name inf matches _)
 365   = do  { new_name <- lookupLocatedBndrRn name
 366         ; let { plain_name = unLoc new_name
 367               ; bndrs      = unitNameSet plain_name }
 368
 369         ; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
 370                              rnMatchGroup (FunRhs plain_name) matches
 371
 372         ; checkPrecMatch inf plain_name matches'
 373
 374         ; return (FunBind new_name inf matches' (trim fvs),
 375                   (bndrs, fvs))
 376       }
 377 \end{code}
 378
 379
 380 @rnMethodBinds@ is used for the method bindings of a class and an instance
 381 declaration.   Like @rnBinds@ but without dependency analysis.
 382
 383 NOTA BENE: we record each {\em binder} of a method-bind group as a free variable.
 384 That's crucial when dealing with an instance decl:
 385 \begin{verbatim}
 386         instance Foo (T a) where
 387            op x = ...
 388 \end{verbatim}
 389 This might be the {\em sole} occurrence of @op@ for an imported class @Foo@,
 390 and unless @op@ occurs we won't treat the type signature of @op@ in the class
 391 decl for @Foo@ as a source of instance-decl gates.  But we should!  Indeed,
 392 in many ways the @op@ in an instance decl is just like an occurrence, not
 393 a binder.
 394
 395 \begin{code}
 396 rnMethodBinds :: Name                   -- Class name
 397               -> [Name]                 -- Names for generic type variables
 398               -> LHsBinds RdrName
 399               -> RnM (LHsBinds Name, FreeVars)
 400
 401 rnMethodBinds cls gen_tyvars binds
 402   = foldM do_one (emptyBag,emptyFVs) (bagToList binds)
 403   where do_one (binds,fvs) bind = do
 404            (bind', fvs_bind) <- rnMethodBind cls gen_tyvars bind
 405            return (bind' `unionBags` binds, fvs_bind `plusFV` fvs)
 406
 407 rnMethodBind cls gen_tyvars (L loc (FunBind name inf (MatchGroup matches _) _))
 408   =  setSrcSpan loc $
 409      lookupLocatedInstDeclBndr cls name                 `thenM` \ sel_name ->
 410      let plain_name = unLoc sel_name in
 411         -- We use the selector name as the binder
 412
 413     mapFvRn (rn_match plain_name) matches               `thenM` \ (new_matches, fvs) ->
 414     let
 415         new_group = MatchGroup new_matches placeHolderType
 416     in
 417     checkPrecMatch inf plain_name new_group             `thenM_`
 418     returnM (unitBag (L loc (FunBind sel_name inf new_group fvs)), fvs `addOneFV` plain_name)
 419         -- The 'fvs' field isn't used for method binds
 420   where
 421         -- Truly gruesome; bring into scope the correct members of the generic
 422         -- type variables.  See comments in RnSource.rnSourceDecl(ClassDecl)
 423     rn_match sel_name match@(L _ (Match (L _ (TypePat ty) : _) _ _))
 424         = extendTyVarEnvFVRn gen_tvs    $
 425           rnMatch (FunRhs sel_name) match
 426         where
 427           tvs     = map (rdrNameOcc.unLoc) (extractHsTyRdrTyVars ty)
 428           gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs]
 429
 430     rn_match sel_name match = rnMatch (FunRhs sel_name) match
 431
 432
 433 -- Can't handle method pattern-bindings which bind multiple methods.
 434 rnMethodBind cls gen_tyvars mbind@(L loc (PatBind other_pat _ _ _))
 435   = addLocErr mbind methodBindErr       `thenM_`
 436     returnM (emptyBag, emptyFVs)
 437 \end{code}
 438
 439
 440 %************************************************************************
 441 %*                                                                      *
 442 \subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}
 443 %*                                                                      *
 444 %************************************************************************
 445
 446 @renameSigs@ checks for:
 447 \begin{enumerate}
 448 \item more than one sig for one thing;
 449 \item signatures given for things not bound here;
 450 \item with suitably flaggery, that all top-level things have type signatures.
 451 \end{enumerate}
 452 %
 453 At the moment we don't gather free-var info from the types in
 454 signatures.  We'd only need this if we wanted to report unused tyvars.
 455
 456 \begin{code}
 457 renameSigs :: (LSig Name -> Bool) -> [LSig RdrName] -> RnM [LSig Name]
 458 -- Renames the signatures and performs error checks
 459 renameSigs ok_sig sigs
 460   = do  { sigs' <- rename_sigs sigs
 461         ; check_sigs ok_sig sigs'
 462         ; return sigs' }
 463
 464 ----------------------
 465 rename_sigs :: [LSig RdrName] -> RnM [LSig Name]
 466 rename_sigs sigs = mappM (wrapLocM renameSig)
 467                          (filter (not . isFixityLSig) sigs)
 468                 -- Remove fixity sigs which have been dealt with already
 469
 470 ----------------------
 471 check_sigs :: (LSig Name -> Bool) -> [LSig Name] -> RnM ()
 472 -- Used for class and instance decls, as well as regular bindings
 473 check_sigs ok_sig sigs
 474         -- Check for (a) duplicate signatures
 475         --           (b) signatures for things not in this group
 476   = do  { mappM_ unknownSigErr (filter bad sigs)
 477         ; mappM_ dupSigDeclErr (findDupsEq eqHsSig sigs) }
 478   where
 479     bad sig = not (ok_sig sig) &&
 480               case sigName sig of
 481                 Just n | isUnboundName n -> False
 482                                 -- Don't complain about an unbound name again
 483                 other                    -> True
 484 -- We use lookupLocatedSigOccRn in the signatures, which is a little bit unsatisfactory
 485 -- because this won't work for:
 486 --      instance Foo T where
 487 --        {-# INLINE op #-}
 488 --        Baz.op = ...
 489 -- We'll just rename the INLINE prag to refer to whatever other 'op'
 490 -- is in scope.  (I'm assuming that Baz.op isn't in scope unqualified.)
 491 -- Doesn't seem worth much trouble to sort this.
 492
 493 renameSig :: Sig RdrName -> RnM (Sig Name)
 494 -- FixitSig is renamed elsewhere.
 495 renameSig (Sig v ty)
 496   = lookupLocatedSigOccRn v                     `thenM` \ new_v ->
 497     rnHsSigType (quotes (ppr v)) ty             `thenM` \ new_ty ->
 498     returnM (Sig new_v new_ty)
 499
 500 renameSig (SpecInstSig ty)
 501   = rnLHsType (text "A SPECIALISE instance pragma") ty `thenM` \ new_ty ->
 502     returnM (SpecInstSig new_ty)
 503
 504 renameSig (SpecSig v ty)
 505   = lookupLocatedSigOccRn v             `thenM` \ new_v ->
 506     rnHsSigType (quotes (ppr v)) ty     `thenM` \ new_ty ->
 507     returnM (SpecSig new_v new_ty)
 508
 509 renameSig (InlineSig b v p)
 510   = lookupLocatedSigOccRn v             `thenM` \ new_v ->
 511     returnM (InlineSig b new_v p)
 512 \end{code}
 513
 514
 515 ************************************************************************
 516 *                                                                       *
 517 \subsection{Match}
 518 *                                                                       *
 519 ************************************************************************
 520
 521 \begin{code}
 522 rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars)
 523 rnMatchGroup ctxt (MatchGroup ms _)
 524   = mapFvRn (rnMatch ctxt) ms   `thenM` \ (new_ms, ms_fvs) ->
 525     returnM (MatchGroup new_ms placeHolderType, ms_fvs)
 526
 527 rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars)
 528 rnMatch ctxt  = wrapLocFstM (rnMatch' ctxt)
 529
 530 rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss)
 531   =
 532         -- Deal with the rhs type signature
 533     bindPatSigTyVarsFV rhs_sig_tys      $
 534     doptM Opt_GlasgowExts               `thenM` \ opt_GlasgowExts ->
 535     (case maybe_rhs_sig of
 536         Nothing -> returnM (Nothing, emptyFVs)
 537         Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty     `thenM` \ (ty', ty_fvs) ->
 538                                      returnM (Just ty', ty_fvs)
 539                 | otherwise       -> addLocErr ty patSigErr     `thenM_`
 540                                      returnM (Nothing, emptyFVs)
 541     )                                   `thenM` \ (maybe_rhs_sig', ty_fvs) ->
 542
 543         -- Now the main event
 544     rnPatsAndThen ctxt pats     $ \ pats' ->
 545     rnGRHSs ctxt grhss          `thenM` \ (grhss', grhss_fvs) ->
 546
 547     returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
 548         -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs
 549   where
 550      rhs_sig_tys =  case maybe_rhs_sig of
 551                         Nothing -> []
 552                         Just ty -> [ty]
 553      doc_sig = text "In a result type-signature"
 554 \end{code}
 555
 556
 557 %************************************************************************
 558 %*                                                                      *
 559 \subsubsection{Guarded right-hand sides (GRHSs)}
 560 %*                                                                      *
 561 %************************************************************************
 562
 563 \begin{code}
 564 rnGRHSs :: HsMatchContext Name -> GRHSs RdrName -> RnM (GRHSs Name, FreeVars)
 565
 566 rnGRHSs ctxt (GRHSs grhss binds)
 567   = rnLocalBindsAndThen binds   $ \ binds' ->
 568     mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) ->
 569     returnM (GRHSs grhss' binds', fvGRHSs)
 570
 571 rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars)
 572 rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt)
 573
 574 rnGRHS' ctxt (GRHS guards rhs)
 575   = do  { opt_GlasgowExts <- doptM Opt_GlasgowExts
 576         ; checkM (opt_GlasgowExts || is_standard_guard guards)
 577                  (addWarn (nonStdGuardErr guards))
 578
 579         ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $
 580                                     rnLExpr rhs
 581         ; return (GRHS guards' rhs', fvs) }
 582   where
 583         -- Standard Haskell 1.4 guards are just a single boolean
 584         -- expression, rather than a list of qualifiers as in the
 585         -- Glasgow extension
 586     is_standard_guard []                     = True
 587     is_standard_guard [L _ (ExprStmt _ _ _)] = True
 588     is_standard_guard other                  = False
 589 \end{code}
 590
 591 %************************************************************************
 592 %*                                                                      *
 593 \subsection{Error messages}
 594 %*                                                                      *
 595 %************************************************************************
 596
 597 \begin{code}
 598 dupSigDeclErr sigs@(L loc sig : _)
 599   = addErrAt loc $
 600         vcat [ptext SLIT("Duplicate") <+> what_it_is <> colon,
 601               nest 2 (vcat (map ppr_sig sigs))]
 602   where
 603     what_it_is = hsSigDoc sig
 604     ppr_sig (L loc sig) = ppr loc <> colon <+> ppr sig
 605
 606 unknownSigErr (L loc sig)
 607   = addErrAt loc $
 608         sep [ptext SLIT("Misplaced") <+> what_it_is <> colon, ppr sig]
 609   where
 610     what_it_is = hsSigDoc sig
 611
 612 missingSigWarn var
 613   = addWarnAt (mkSrcSpan loc loc) $
 614       sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)]
 615   where
 616     loc = nameSrcLoc var  -- TODO: make a proper span
 617
 618 methodBindErr mbind
 619  =  hang (ptext SLIT("Pattern bindings (except simple variables) not allowed in instance declarations"))
 620        2 (ppr mbind)
 621
 622 bindsInHsBootFile mbinds
 623   = hang (ptext SLIT("Bindings in hs-boot files are not allowed"))
 624        2 (ppr mbinds)
 625
 626 nonStdGuardErr guard
 627   = hang (ptext
 628     SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
 629     ) 4 (ppr guard)
 630 \end{code}