ghc/compiler/rename/RnSource.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[RnSource]{Main pass of renamer}
   5
   6 \begin{code}
   7 module RnSource (
   8         rnSrcDecls, checkModDeprec,
   9         rnTyClDecl, rnIfaceRuleDecl, rnInstDecl,
  10         rnBinds, rnBindsAndThen, rnStats,
  11     ) where
  12
  13 #include "HsVersions.h"
  14
  15 import HsSyn
  16 import RdrName          ( RdrName, isRdrDataCon, elemRdrEnv )
  17 import RdrHsSyn         ( RdrNameConDecl, RdrNameTyClDecl,
  18                           RdrNameDeprecation, RdrNameFixitySig,
  19                           RdrNameHsBinds,
  20                           extractGenericPatTyVars
  21                         )
  22 import RnHsSyn
  23 import HsCore
  24 import RnExpr           ( rnExpr )
  25 import RnTypes          ( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext )
  26
  27 import RnBinds          ( rnTopMonoBinds, rnMonoBinds, rnMethodBinds,
  28                           rnMonoBindsAndThen, renameSigs, checkSigs )
  29 import RnEnv            ( lookupTopBndrRn, lookupOccRn, lookupSysBndr,
  30                           newLocalsRn, lookupGlobalOccRn,
  31                           bindLocalsFVRn, bindPatSigTyVars,
  32                           bindTyVarsRn, extendTyVarEnvFVRn,
  33                           bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
  34                           checkDupOrQualNames, checkDupNames, mapFvRn,
  35                           lookupTopSrcBndr_maybe, lookupTopSrcBndr,
  36                           dataTcOccs, newIPName, unknownNameErr
  37                         )
  38 import TcRnMonad
  39
  40 import BasicTypes       ( FixitySig(..) )
  41 import HscTypes         ( ExternalPackageState(..), FixityEnv,
  42                           Deprecations(..), plusDeprecs )
  43 import Module           ( moduleEnvElts )
  44 import Class            ( FunDep, DefMeth (..) )
  45 import TyCon            ( DataConDetails(..), visibleDataCons )
  46 import Name             ( Name )
  47 import NameSet
  48 import NameEnv
  49 import ErrUtils         ( dumpIfSet )
  50 import PrelNames        ( newStablePtrName, bindIOName, returnIOName )
  51 import List             ( partition )
  52 import Bag              ( bagToList )
  53 import Outputable
  54 import SrcLoc           ( SrcLoc )
  55 import CmdLineOpts      ( DynFlag(..) )
  56                                 -- Warn of unused for-all'd tyvars
  57 import Maybes           ( maybeToBool, seqMaybe )
  58 import Maybe            ( maybe, catMaybes, isNothing )
  59 \end{code}
  60
  61 @rnSourceDecl@ `renames' declarations.
  62 It simultaneously performs dependency analysis and precedence parsing.
  63 It also does the following error checks:
  64 \begin{enumerate}
  65 \item
  66 Checks that tyvars are used properly. This includes checking
  67 for undefined tyvars, and tyvars in contexts that are ambiguous.
  68 (Some of this checking has now been moved to module @TcMonoType@,
  69 since we don't have functional dependency information at this point.)
  70 \item
  71 Checks that all variable occurences are defined.
  72 \item
  73 Checks the @(..)@ etc constraints in the export list.
  74 \end{enumerate}
  75
  76
  77 \begin{code}
  78 rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name, FreeVars)
  79
  80 rnSrcDecls (HsGroup { hs_valds  = MonoBind binds sigs _,
  81                       hs_tyclds = tycl_decls,
  82                       hs_instds = inst_decls,
  83                       hs_fixds  = fix_decls,
  84                       hs_depds  = deprec_decls,
  85                       hs_fords  = foreign_decls,
  86                       hs_defds  = default_decls,
  87                       hs_ruleds = rule_decls,
  88                       hs_coreds = core_decls })
  89
  90  = do {         -- Deal with deprecations (returns only the extra deprecations)
  91         deprecs <- rnSrcDeprecDecls deprec_decls ;
  92         updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs })
  93                   $ do {
  94
  95                 -- Deal with top-level fixity decls
  96                 -- (returns the total new fixity env)
  97         fix_env <- rnSrcFixityDecls fix_decls ;
  98         updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
  99                   $ do {
 100
 101                 -- Rename other declarations
 102         (rn_val_decls, src_fvs1)     <- rnTopMonoBinds binds sigs ;
 103         (rn_inst_decls, src_fvs2)    <- mapFvRn rnSrcInstDecl inst_decls ;
 104         (rn_tycl_decls, src_fvs3)    <- mapFvRn rnSrcTyClDecl tycl_decls ;
 105         (rn_rule_decls, src_fvs4)    <- mapFvRn rnHsRuleDecl rule_decls ;
 106         (rn_foreign_decls, src_fvs5) <- mapFvRn rnHsForeignDecl foreign_decls ;
 107         (rn_default_decls, src_fvs6) <- mapFvRn rnDefaultDecl default_decls ;
 108         (rn_core_decls,    src_fvs7) <- mapFvRn rnCoreDecl core_decls ;
 109
 110         let {
 111            rn_group = HsGroup { hs_valds  = rn_val_decls,
 112                                 hs_tyclds = rn_tycl_decls,
 113                                 hs_instds = rn_inst_decls,
 114                                 hs_fixds  = [],
 115                                 hs_depds  = [],
 116                                 hs_fords  = rn_foreign_decls,
 117                                 hs_defds  = rn_default_decls,
 118                                 hs_ruleds = rn_rule_decls,
 119                                 hs_coreds = rn_core_decls } ;
 120            src_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
 121                               src_fvs5, src_fvs6, src_fvs7] } ;
 122
 123         traceRn (text "rnSrcDecls" <+> ppr (nameSetToList src_fvs)) ;
 124         tcg_env <- getGblEnv ;
 125         return (tcg_env, rn_group, src_fvs)
 126     }}}
 127 \end{code}
 128
 129
 130 %*********************************************************
 131 %*                                                       *
 132         Source-code fixity declarations
 133 %*                                                       *
 134 %*********************************************************
 135
 136 \begin{code}
 137 rnSrcFixityDecls :: [RdrNameFixitySig] -> TcRn m FixityEnv
 138 rnSrcFixityDecls fix_decls
 139   = getGblEnv                                   `thenM` \ gbl_env ->
 140     foldlM rnFixityDecl (tcg_fix_env gbl_env)
 141             fix_decls                           `thenM` \ fix_env ->
 142     traceRn (text "fixity env" <+> ppr fix_env) `thenM_`
 143     returnM fix_env
 144
 145 rnFixityDecl :: FixityEnv -> RdrNameFixitySig -> TcRn m FixityEnv
 146 rnFixityDecl fix_env (FixitySig rdr_name fixity loc)
 147   =     -- GHC extension: look up both the tycon and data con
 148         -- for con-like things
 149         -- If neither are in scope, report an error; otherwise
 150         -- add both to the fixity env
 151      mappM lookupTopSrcBndr_maybe (dataTcOccs rdr_name) `thenM` \ maybe_ns ->
 152      case catMaybes maybe_ns of
 153           [] -> addSrcLoc loc                   $
 154                 addErr (unknownNameErr rdr_name)        `thenM_`
 155                 returnM fix_env
 156           ns -> foldlM add fix_env ns
 157   where
 158     add fix_env name
 159       = case lookupNameEnv fix_env name of
 160           Just (FixitySig _ _ loc') -> addErr (dupFixityDecl rdr_name loc loc') `thenM_`
 161                                        returnM fix_env
 162           Nothing -> returnM (extendNameEnv fix_env name (FixitySig name fixity loc))
 163
 164 dupFixityDecl rdr_name loc1 loc2
 165   = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
 166           ptext SLIT("at ") <+> ppr loc1,
 167           ptext SLIT("and") <+> ppr loc2]
 168 \end{code}
 169
 170
 171 %*********************************************************
 172 %*                                                       *
 173         Source-code deprecations declarations
 174 %*                                                       *
 175 %*********************************************************
 176
 177 For deprecations, all we do is check that the names are in scope.
 178 It's only imported deprecations, dealt with in RnIfaces, that we
 179 gather them together.
 180
 181 \begin{code}
 182 rnSrcDeprecDecls :: [RdrNameDeprecation] -> TcRn m Deprecations
 183 rnSrcDeprecDecls []
 184   = returnM NoDeprecs
 185
 186 rnSrcDeprecDecls decls
 187   = mappM rn_deprec decls       `thenM` \ pairs ->
 188     returnM (DeprecSome (mkNameEnv (catMaybes pairs)))
 189  where
 190    rn_deprec (Deprecation rdr_name txt loc)
 191      = addSrcLoc loc                    $
 192        lookupTopSrcBndr rdr_name        `thenM` \ name ->
 193        returnM (Just (name, (name,txt)))
 194
 195 checkModDeprec :: Maybe DeprecTxt -> Deprecations
 196 -- Check for a module deprecation; done once at top level
 197 checkModDeprec Nothing    = NoDeprecs
 198 checkModdeprec (Just txt) = DeprecAll txt
 199
 200 badDeprec d
 201   = sep [ptext SLIT("Illegal deprecation when whole module is deprecated"),
 202          nest 4 (ppr d)]
 203 \end{code}
 204
 205 %*********************************************************
 206 %*                                                      *
 207 \subsection{Source code declarations}
 208 %*                                                      *
 209 %*********************************************************
 210
 211 \begin{code}
 212 rnSrcTyClDecl tycl_decl
 213   = rnTyClDecl tycl_decl                        `thenM` \ new_decl ->
 214     finishSourceTyClDecl tycl_decl new_decl     `thenM` \ (new_decl', fvs) ->
 215     returnM (new_decl', fvs `plusFV` tyClDeclFVs new_decl')
 216
 217 rnSrcInstDecl inst
 218   = rnInstDecl inst                     `thenM` \ new_inst ->
 219     finishSourceInstDecl inst new_inst  `thenM` \ (new_inst', fvs) ->
 220     returnM (new_inst', fvs `plusFV` instDeclFVs new_inst')
 221
 222 rnDefaultDecl (DefaultDecl tys src_loc)
 223   = addSrcLoc src_loc $
 224     mapFvRn (rnHsTypeFVs doc_str) tys           `thenM` \ (tys', fvs) ->
 225     returnM (DefaultDecl tys' src_loc, fvs)
 226   where
 227     doc_str = text "In a `default' declaration"
 228
 229
 230 rnCoreDecl (CoreDecl name ty rhs loc)
 231   = addSrcLoc loc $
 232     lookupTopBndrRn name                `thenM` \ name' ->
 233     rnHsTypeFVs doc_str ty              `thenM` \ (ty', ty_fvs) ->
 234     rnCoreExpr rhs                      `thenM` \ rhs' ->
 235     returnM (CoreDecl name' ty' rhs' loc,
 236              ty_fvs `plusFV` ufExprFVs rhs')
 237   where
 238     doc_str = text "In the Core declaration for" <+> quotes (ppr name)
 239 \end{code}
 240
 241 %*********************************************************
 242 %*                                                      *
 243                 Bindings
 244 %*                                                      *
 245 %*********************************************************
 246
 247 These chaps are here, rather than in TcBinds, so that there
 248 is just one hi-boot file (for RnSource).  rnSrcDecls is part
 249 of the loop too, and it must be defined in this module.
 250
 251 \begin{code}
 252 rnTopBinds    :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars)
 253 rnTopBinds EmptyBinds             = returnM (EmptyBinds, emptyFVs)
 254 rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs
 255   -- The parser doesn't produce other forms
 256
 257 rnBinds    :: RdrNameHsBinds -> RnM (RenamedHsBinds, FreeVars)
 258 -- This version assumes that the binders are already in scope
 259 -- It's used only in 'mdo'
 260 rnBinds EmptyBinds             = returnM (EmptyBinds, emptyFVs)
 261 rnBinds (MonoBind bind sigs _) = rnMonoBinds bind sigs
 262 rnBinds b@(IPBinds bind _)     = addErr (badIpBinds b)  `thenM_`
 263                                  returnM (EmptyBinds, emptyFVs)
 264
 265 rnBindsAndThen  :: RdrNameHsBinds
 266                 -> (RenamedHsBinds -> RnM (result, FreeVars))
 267                 -> RnM (result, FreeVars)
 268 -- This version (a) assumes that the binding vars are not already in scope
 269 --              (b) removes the binders from the free vars of the thing inside
 270 -- The parser doesn't produce ThenBinds
 271 rnBindsAndThen EmptyBinds              thing_inside = thing_inside EmptyBinds
 272 rnBindsAndThen (MonoBind bind sigs _)  thing_inside = rnMonoBindsAndThen bind sigs thing_inside
 273 rnBindsAndThen (IPBinds binds is_with) thing_inside
 274   = warnIf is_with withWarning                  `thenM_`
 275     rnIPBinds binds                             `thenM` \ (binds',fv_binds) ->
 276     thing_inside (IPBinds binds' is_with)       `thenM` \ (thing, fvs_thing) ->
 277     returnM (thing, fvs_thing `plusFV` fv_binds)
 278 \end{code}
 279
 280
 281 %************************************************************************
 282 %*                                                                      *
 283 \subsubsection{@rnIPBinds@s: in implicit parameter bindings}            *
 284 %*                                                                      *
 285 %************************************************************************
 286
 287 \begin{code}
 288 rnIPBinds [] = returnM ([], emptyFVs)
 289 rnIPBinds ((n, expr) : binds)
 290   = newIPName n                 `thenM` \ name ->
 291     rnExpr expr                 `thenM` \ (expr',fvExpr) ->
 292     rnIPBinds binds             `thenM` \ (binds',fvBinds) ->
 293     returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds)
 294
 295 \end{code}
 296
 297
 298 %*********************************************************
 299 %*                                                      *
 300 \subsection{Foreign declarations}
 301 %*                                                      *
 302 %*********************************************************
 303
 304 \begin{code}
 305 rnHsForeignDecl (ForeignImport name ty spec isDeprec src_loc)
 306   = addSrcLoc src_loc           $
 307     lookupTopBndrRn name                `thenM` \ name' ->
 308     rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
 309     returnM (ForeignImport name' ty' spec isDeprec src_loc,
 310               fvs `plusFV` extras spec)
 311   where
 312     extras (CImport _ _ _ _ CWrapper) = mkFVs [newStablePtrName,
 313                                                bindIOName, returnIOName]
 314     extras _                          = emptyFVs
 315
 316 rnHsForeignDecl (ForeignExport name ty spec isDeprec src_loc)
 317   = addSrcLoc src_loc                   $
 318     lookupOccRn name                            `thenM` \ name' ->
 319     rnHsTypeFVs (fo_decl_msg name) ty           `thenM` \ (ty', fvs) ->
 320     returnM (ForeignExport name' ty' spec isDeprec src_loc,
 321               mkFVs [name', bindIOName, returnIOName] `plusFV` fvs )
 322         -- NB: a foreign export is an *occurrence site* for name, so
 323         --     we add it to the free-variable list.  It might, for example,
 324         --     be imported from another module
 325
 326 fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
 327 \end{code}
 328
 329
 330 %*********************************************************
 331 %*                                                      *
 332 \subsection{Instance declarations}
 333 %*                                                      *
 334 %*********************************************************
 335
 336 \begin{code}
 337 rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)
 338         -- Used for both source and interface file decls
 339   = addSrcLoc src_loc $
 340     rnHsSigType (text "an instance decl") inst_ty       `thenM` \ inst_ty' ->
 341
 342     (case maybe_dfun_rdr_name of
 343         Nothing            -> returnM Nothing
 344         Just dfun_rdr_name -> lookupGlobalOccRn dfun_rdr_name   `thenM` \ dfun_name ->
 345                               returnM (Just dfun_name)
 346     )                                                   `thenM` \ maybe_dfun_name ->
 347
 348     -- The typechecker checks that all the bindings are for the right class.
 349     returnM (InstDecl inst_ty' EmptyMonoBinds [] maybe_dfun_name src_loc)
 350
 351 -- Compare finishSourceTyClDecl
 352 finishSourceInstDecl (InstDecl _       mbinds uprags _               _      )
 353                      (InstDecl inst_ty _      _      maybe_dfun_name src_loc)
 354         -- Used for both source decls only
 355   = ASSERT( not (maybeToBool maybe_dfun_name) ) -- Source decl!
 356     let
 357         meth_doc    = text "In the bindings in an instance declaration"
 358         meth_names  = collectLocatedMonoBinders mbinds
 359         (inst_tyvars, _, cls,_) = splitHsInstDeclTy inst_ty
 360         -- (Slightly strangely) the forall-d tyvars scope over
 361         -- the method bindings too
 362     in
 363
 364         -- Rename the bindings
 365         -- NB meth_names can be qualified!
 366     checkDupNames meth_doc meth_names           `thenM_`
 367     extendTyVarEnvForMethodBinds inst_tyvars (
 368         rnMethodBinds cls [] mbinds
 369     )                                           `thenM` \ (mbinds', meth_fvs) ->
 370     let
 371         binders = collectMonoBinders mbinds'
 372     in
 373         -- Rename the prags and signatures.
 374         -- Note that the type variables are not in scope here,
 375         -- so that      instance Eq a => Eq (T a) where
 376         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
 377         -- works OK.
 378         --
 379         -- But the (unqualified) method names are in scope
 380     bindLocalNames binders (renameSigs uprags)                  `thenM` \ uprags' ->
 381     checkSigs okInstDclSig (mkNameSet binders) uprags'          `thenM_`
 382
 383     returnM (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc,
 384               meth_fvs `plusFV` hsSigsFVs uprags')
 385 \end{code}
 386
 387 %*********************************************************
 388 %*                                                      *
 389 \subsection{Rules}
 390 %*                                                      *
 391 %*********************************************************
 392
 393 \begin{code}
 394 rnIfaceRuleDecl (IfaceRule rule_name act vars fn args rhs src_loc)
 395   = addSrcLoc src_loc   $
 396     lookupOccRn fn              `thenM` \ fn' ->
 397     rnCoreBndrs vars            $ \ vars' ->
 398     mappM rnCoreExpr args       `thenM` \ args' ->
 399     rnCoreExpr rhs              `thenM` \ rhs' ->
 400     returnM (IfaceRule rule_name act vars' fn' args' rhs' src_loc)
 401
 402 rnIfaceRuleDecl (IfaceRuleOut fn rule)          -- Builtin rules come this way
 403   = lookupOccRn fn              `thenM` \ fn' ->
 404     returnM (IfaceRuleOut fn' rule)
 405
 406 rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc)
 407   = addSrcLoc src_loc                           $
 408     bindPatSigTyVars (collectRuleBndrSigTys vars)       $
 409
 410     bindLocalsFVRn doc (map get_var vars)       $ \ ids ->
 411     mapFvRn rn_var (vars `zip` ids)             `thenM` \ (vars', fv_vars) ->
 412
 413     rnExpr lhs                                  `thenM` \ (lhs', fv_lhs) ->
 414     rnExpr rhs                                  `thenM` \ (rhs', fv_rhs) ->
 415     let
 416         mb_bad = validRuleLhs ids lhs'
 417     in
 418     checkErr (isNothing mb_bad)
 419              (badRuleLhsErr rule_name lhs' mb_bad)      `thenM_`
 420     let
 421         bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
 422     in
 423     mappM (addErr . badRuleVar rule_name) bad_vars      `thenM_`
 424     returnM (HsRule rule_name act vars' lhs' rhs' src_loc,
 425               fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
 426   where
 427     doc = text "In the transformation rule" <+> ftext rule_name
 428
 429     get_var (RuleBndr v)      = v
 430     get_var (RuleBndrSig v _) = v
 431
 432     rn_var (RuleBndr v, id)      = returnM (RuleBndr id, emptyFVs)
 433     rn_var (RuleBndrSig v t, id) = rnHsTypeFVs doc t    `thenM` \ (t', fvs) ->
 434                                    returnM (RuleBndrSig id t', fvs)
 435 \end{code}
 436
 437 Check the shape of a transformation rule LHS.  Currently
 438 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
 439 not one of the @forall@'d variables.  We also restrict the form of the LHS so
 440 that it may be plausibly matched.  Basically you only get to write ordinary
 441 applications.  (E.g. a case expression is not allowed: too elaborate.)
 442
 443 NB: if you add new cases here, make sure you add new ones to TcRule.ruleLhsTvs
 444
 445 \begin{code}
 446 validRuleLhs :: [Name] -> RenamedHsExpr -> Maybe RenamedHsExpr
 447 -- Nothing => OK
 448 -- Just e  => Not ok, and e is the offending expression
 449 validRuleLhs foralls lhs
 450   = check lhs
 451   where
 452     check (OpApp e1 op _ e2)              = check op `seqMaybe` check_e e1 `seqMaybe` check_e e2
 453     check (HsApp e1 e2)                   = check e1 `seqMaybe` check_e e2
 454     check (HsVar v) | v `notElem` foralls = Nothing
 455     check other                           = Just other  -- Failure
 456
 457     check_e (HsVar v)     = Nothing
 458     check_e (HsPar e)     = check_e e
 459     check_e (HsLit e)     = Nothing
 460     check_e (HsOverLit e) = Nothing
 461
 462     check_e (OpApp e1 op _ e2)   = check_e e1 `seqMaybe` check_e op `seqMaybe` check_e e2
 463     check_e (HsApp e1 e2)        = check_e e1 `seqMaybe` check_e e2
 464     check_e (NegApp e _)         = check_e e
 465     check_e (ExplicitList _ es)  = check_es es
 466     check_e (ExplicitTuple es _) = check_es es
 467     check_e other                = Just other   -- Fails
 468
 469     check_es es = foldr (seqMaybe . check_e) Nothing es
 470 \end{code}
 471
 472
 473 %*********************************************************
 474 %*                                                      *
 475 \subsection{Type, class and iface sig declarations}
 476 %*                                                      *
 477 %*********************************************************
 478
 479 @rnTyDecl@ uses the `global name function' to create a new type
 480 declaration in which local names have been replaced by their original
 481 names, reporting any unknown names.
 482
 483 Renaming type variables is a pain. Because they now contain uniques,
 484 it is necessary to pass in an association list which maps a parsed
 485 tyvar to its @Name@ representation.
 486 In some cases (type signatures of values),
 487 it is even necessary to go over the type first
 488 in order to get the set of tyvars used by it, make an assoc list,
 489 and then go over it again to rename the tyvars!
 490 However, we can also do some scoping checks at the same time.
 491
 492 \begin{code}
 493 rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc = loc})
 494   = addSrcLoc loc $
 495     lookupTopBndrRn name                `thenM` \ name' ->
 496     rnHsType doc_str ty                 `thenM` \ ty' ->
 497     mappM rnIdInfo id_infos             `thenM` \ id_infos' ->
 498     returnM (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc})
 499   where
 500     doc_str = text "In the interface signature for" <+> quotes (ppr name)
 501
 502 rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
 503   = addSrcLoc loc                       $
 504     lookupTopBndrRn name                `thenM` \ name' ->
 505     returnM (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
 506
 507 rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
 508                     tcdTyVars = tyvars, tcdCons = condecls, tcdGeneric = want_generic,
 509                     tcdDerivs = derivs, tcdLoc = src_loc})
 510   = addSrcLoc src_loc $
 511     lookupTopBndrRn tycon                       `thenM` \ tycon' ->
 512     bindTyVarsRn data_doc tyvars                $ \ tyvars' ->
 513     rnContext data_doc context                  `thenM` \ context' ->
 514     rn_derivs derivs                            `thenM` \ derivs' ->
 515     checkDupOrQualNames data_doc con_names      `thenM_`
 516
 517     rnConDecls tycon' condecls                  `thenM` \ condecls' ->
 518     returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
 519                      tcdTyVars = tyvars', tcdCons = condecls', tcdGeneric = want_generic,
 520                      tcdDerivs = derivs', tcdLoc = src_loc})
 521   where
 522     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
 523     con_names = map conDeclName (visibleDataCons condecls)
 524
 525     rn_derivs Nothing   = returnM Nothing
 526     rn_derivs (Just ds) = rnContext data_doc ds `thenM` \ ds' -> returnM (Just ds')
 527
 528 rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
 529   = addSrcLoc src_loc $
 530     lookupTopBndrRn name                        `thenM` \ name' ->
 531     bindTyVarsRn syn_doc tyvars                 $ \ tyvars' ->
 532     rnHsType syn_doc ty                         `thenM` \ ty' ->
 533     returnM (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
 534   where
 535     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 536
 537 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname,
 538                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
 539                        tcdLoc = src_loc})
 540         -- Used for both source and interface file decls
 541   = addSrcLoc src_loc $
 542
 543     lookupTopBndrRn cname                       `thenM` \ cname' ->
 544
 545         -- Tyvars scope over superclass context and method signatures
 546     bindTyVarsRn cls_doc tyvars                 $ \ tyvars' ->
 547
 548         -- Check the superclasses
 549     rnContext cls_doc context                   `thenM` \ context' ->
 550
 551         -- Check the functional dependencies
 552     rnFds cls_doc fds                           `thenM` \ fds' ->
 553
 554         -- Check the signatures
 555         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 556     let
 557         (op_sigs, non_op_sigs) = partition isClassOpSig sigs
 558         sig_rdr_names_w_locs   = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
 559     in
 560     checkDupOrQualNames sig_doc sig_rdr_names_w_locs    `thenM_`
 561     mappM (rnClassOp cname' fds') op_sigs               `thenM` \ sigs' ->
 562     let
 563         binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ]
 564     in
 565     renameSigs non_op_sigs                      `thenM` \ non_ops' ->
 566     checkSigs okClsDclSig binders non_ops'      `thenM_`
 567         -- Typechecker is responsible for checking that we only
 568         -- give default-method bindings for things in this class.
 569         -- The renamer *could* check this for class decls, but can't
 570         -- for instance decls.
 571
 572     returnM (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars',
 573                          tcdFDs = fds', tcdSigs = non_ops' ++ sigs', tcdMeths = Nothing,
 574                          tcdLoc = src_loc})
 575   where
 576     cls_doc  = text "In the declaration for class"      <+> ppr cname
 577     sig_doc  = text "In the signatures for class"       <+> ppr cname
 578
 579 rnClassOp clas clas_fds sig@(ClassOpSig op dm_stuff ty locn)
 580   = addSrcLoc locn $
 581     lookupTopBndrRn op                  `thenM` \ op_name ->
 582
 583         -- Check the signature
 584     rnHsSigType (quotes (ppr op)) ty    `thenM` \ new_ty ->
 585
 586         -- Make the default-method name
 587     (case dm_stuff of
 588         DefMeth dm_rdr_name
 589             ->  -- Imported class that has a default method decl
 590                 lookupSysBndr dm_rdr_name       `thenM` \ dm_name ->
 591                 returnM (DefMeth dm_name)
 592                         -- An imported class decl for a class decl that had an explicit default
 593                         -- method, mentions, rather than defines,
 594                         -- the default method, so we must arrange to pull it in
 595
 596         GenDefMeth -> returnM GenDefMeth
 597         NoDefMeth  -> returnM NoDefMeth
 598     )                                           `thenM` \ dm_stuff' ->
 599
 600     returnM (ClassOpSig op_name dm_stuff' new_ty locn)
 601
 602 finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnM (RenamedTyClDecl, FreeVars)
 603         -- Used for source file decls only
 604         -- Renames the default-bindings of a class decl
 605 finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc})     -- Get mbinds from here
 606          rn_cls_decl@(ClassDecl {tcdName = cls, tcdTyVars = tyvars})            -- Everything else is here
 607   -- There are some default-method bindings (abeit possibly empty) so
 608   -- this is a source-code class declaration
 609   =     -- The newLocals call is tiresome: given a generic class decl
 610         --      class C a where
 611         --        op :: a -> a
 612         --        op {| x+y |} (Inl a) = ...
 613         --        op {| x+y |} (Inr b) = ...
 614         --        op {| a*b |} (a*b)   = ...
 615         -- we want to name both "x" tyvars with the same unique, so that they are
 616         -- easy to group together in the typechecker.
 617         -- Hence the
 618     addSrcLoc src_loc                           $
 619     extendTyVarEnvForMethodBinds tyvars                 $
 620     getLocalRdrEnv                                      `thenM` \ name_env ->
 621     let
 622         meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds
 623         gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds,
 624                                                 not (tv `elemRdrEnv` name_env)]
 625     in
 626     checkDupOrQualNames meth_doc meth_rdr_names_w_locs  `thenM_`
 627     newLocalsRn gen_rdr_tyvars_w_locs                   `thenM` \ gen_tyvars ->
 628     rnMethodBinds cls gen_tyvars mbinds                 `thenM` \ (mbinds', meth_fvs) ->
 629     returnM (rn_cls_decl {tcdMeths = Just mbinds'}, meth_fvs)
 630   where
 631     meth_doc = text "In the default-methods for class"  <+> ppr (tcdName rn_cls_decl)
 632
 633 finishSourceTyClDecl _ tycl_decl@(TyData {tcdDerivs = derivings})
 634   -- Derivings are returned here so that they don't form part of the tyClDeclFVs.
 635   -- This is important, because tyClDeclFVs should contain only the
 636   -- FVs that are `needed' by the interface file declaration, and
 637   -- derivings do not appear in this.  It also means that the tcGroups
 638   -- are smaller, which turned out to be important for the usage inference. KSW 2002-02.
 639   = returnM (tycl_decl,
 640               maybe emptyFVs extractHsCtxtTyNames derivings)
 641
 642 finishSourceTyClDecl _ tycl_decl = returnM (tycl_decl, emptyFVs)
 643         -- Not a class declaration
 644 \end{code}
 645
 646 For the method bindings in class and instance decls, we extend the
 647 type variable environment iff -fglasgow-exts
 648
 649 \begin{code}
 650 extendTyVarEnvForMethodBinds tyvars thing_inside
 651   = doptM Opt_GlasgowExts                       `thenM` \ opt_GlasgowExts ->
 652     if opt_GlasgowExts then
 653         extendTyVarEnvFVRn (map hsTyVarName tyvars) thing_inside
 654     else
 655         thing_inside
 656 \end{code}
 657
 658
 659 %*********************************************************
 660 %*                                                      *
 661 \subsection{Support code for type/data declarations}
 662 %*                                                      *
 663 %*********************************************************
 664
 665 \begin{code}
 666 conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc)
 667 conDeclName (ConDecl n _ _ _ l) = (n,l)
 668
 669 rnConDecls :: Name -> DataConDetails RdrNameConDecl -> RnM (DataConDetails RenamedConDecl)
 670 rnConDecls tycon Unknown     = returnM Unknown
 671 rnConDecls tycon (HasCons n) = returnM (HasCons n)
 672 rnConDecls tycon (DataCons condecls)
 673   =     -- Check that there's at least one condecl,
 674         -- or else we're reading an interface file, or -fglasgow-exts
 675     (if null condecls then
 676         doptM Opt_GlasgowExts   `thenM` \ glaExts ->
 677         getModeRn               `thenM` \ mode ->
 678         checkErr (glaExts || isInterfaceMode mode)
 679                 (emptyConDeclsErr tycon)
 680      else returnM ()
 681     )                                           `thenM_`
 682
 683     mappM rnConDecl condecls                    `thenM` \ condecls' ->
 684     returnM (DataCons condecls')
 685
 686 rnConDecl :: RdrNameConDecl -> RnM RenamedConDecl
 687 rnConDecl (ConDecl name tvs cxt details locn)
 688   = addSrcLoc locn $
 689     checkConName name           `thenM_`
 690     lookupTopBndrRn name        `thenM` \ new_name ->
 691
 692     bindTyVarsRn doc tvs                $ \ new_tyvars ->
 693     rnContext doc cxt                   `thenM` \ new_context ->
 694     rnConDetails doc locn details       `thenM` \ new_details ->
 695     returnM (ConDecl new_name new_tyvars new_context new_details locn)
 696   where
 697     doc = text "In the definition of data constructor" <+> quotes (ppr name)
 698
 699 rnConDetails doc locn (PrefixCon tys)
 700   = mappM (rnBangTy doc) tys    `thenM` \ new_tys  ->
 701     returnM (PrefixCon new_tys)
 702
 703 rnConDetails doc locn (InfixCon ty1 ty2)
 704   = rnBangTy doc ty1            `thenM` \ new_ty1 ->
 705     rnBangTy doc ty2            `thenM` \ new_ty2 ->
 706     returnM (InfixCon new_ty1 new_ty2)
 707
 708 rnConDetails doc locn (RecCon fields)
 709   = checkDupOrQualNames doc field_names `thenM_`
 710     mappM (rnField doc) fields          `thenM` \ new_fields ->
 711     returnM (RecCon new_fields)
 712   where
 713     field_names = [(fld, locn) | (fld, _) <- fields]
 714
 715 rnField doc (name, ty)
 716   = lookupTopBndrRn name        `thenM` \ new_name ->
 717     rnBangTy doc ty             `thenM` \ new_ty ->
 718     returnM (new_name, new_ty)
 719
 720 rnBangTy doc (BangType s ty)
 721   = rnHsType doc ty             `thenM` \ new_ty ->
 722     returnM (BangType s new_ty)
 723
 724 -- This data decl will parse OK
 725 --      data T = a Int
 726 -- treating "a" as the constructor.
 727 -- It is really hard to make the parser spot this malformation.
 728 -- So the renamer has to check that the constructor is legal
 729 --
 730 -- We can get an operator as the constructor, even in the prefix form:
 731 --      data T = :% Int Int
 732 -- from interface files, which always print in prefix form
 733
 734 checkConName name
 735   = checkErr (isRdrDataCon name) (badDataCon name)
 736 \end{code}
 737
 738
 739 %*********************************************************
 740 %*                                                      *
 741 \subsection{Support code to rename types}
 742 %*                                                      *
 743 %*********************************************************
 744
 745 \begin{code}
 746 rnFds :: SDoc -> [FunDep RdrName] -> RnM [FunDep Name]
 747
 748 rnFds doc fds
 749   = mappM rn_fds fds
 750   where
 751     rn_fds (tys1, tys2)
 752       = rnHsTyVars doc tys1             `thenM` \ tys1' ->
 753         rnHsTyVars doc tys2             `thenM` \ tys2' ->
 754         returnM (tys1', tys2')
 755
 756 rnHsTyVars doc tvs  = mappM (rnHsTyvar doc) tvs
 757 rnHsTyvar doc tyvar = lookupOccRn tyvar
 758 \end{code}
 759
 760 %*********************************************************
 761 %*                                                       *
 762 \subsection{IdInfo}
 763 %*                                                       *
 764 %*********************************************************
 765
 766 \begin{code}
 767 rnIdInfo (HsWorker worker arity)
 768   = lookupOccRn worker                  `thenM` \ worker' ->
 769     returnM (HsWorker worker' arity)
 770
 771 rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenM` \ expr' ->
 772                                   returnM (HsUnfold inline expr')
 773 rnIdInfo (HsStrictness str)     = returnM (HsStrictness str)
 774 rnIdInfo (HsArity arity)        = returnM (HsArity arity)
 775 rnIdInfo HsNoCafRefs            = returnM HsNoCafRefs
 776 \end{code}
 777
 778 @UfCore@ expressions.
 779
 780 \begin{code}
 781 rnCoreExpr (UfType ty)
 782   = rnHsType (text "unfolding type") ty `thenM` \ ty' ->
 783     returnM (UfType ty')
 784
 785 rnCoreExpr (UfVar v)
 786   = lookupOccRn v       `thenM` \ v' ->
 787     returnM (UfVar v')
 788
 789 rnCoreExpr (UfLit l)
 790   = returnM (UfLit l)
 791
 792 rnCoreExpr (UfLitLit l ty)
 793   = rnHsType (text "litlit") ty `thenM` \ ty' ->
 794     returnM (UfLitLit l ty')
 795
 796 rnCoreExpr (UfFCall cc ty)
 797   = rnHsType (text "ccall") ty  `thenM` \ ty' ->
 798     returnM (UfFCall cc ty')
 799
 800 rnCoreExpr (UfTuple (HsTupCon boxity arity) args)
 801   = mappM rnCoreExpr args               `thenM` \ args' ->
 802     returnM (UfTuple (HsTupCon boxity arity) args')
 803
 804 rnCoreExpr (UfApp fun arg)
 805   = rnCoreExpr fun              `thenM` \ fun' ->
 806     rnCoreExpr arg              `thenM` \ arg' ->
 807     returnM (UfApp fun' arg')
 808
 809 rnCoreExpr (UfCase scrut bndr alts)
 810   = rnCoreExpr scrut                    `thenM` \ scrut' ->
 811     bindCoreLocalRn bndr                $ \ bndr' ->
 812     mappM rnCoreAlt alts                `thenM` \ alts' ->
 813     returnM (UfCase scrut' bndr' alts')
 814
 815 rnCoreExpr (UfNote note expr)
 816   = rnNote note                 `thenM` \ note' ->
 817     rnCoreExpr expr             `thenM` \ expr' ->
 818     returnM  (UfNote note' expr')
 819
 820 rnCoreExpr (UfLam bndr body)
 821   = rnCoreBndr bndr             $ \ bndr' ->
 822     rnCoreExpr body             `thenM` \ body' ->
 823     returnM (UfLam bndr' body')
 824
 825 rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
 826   = rnCoreExpr rhs              `thenM` \ rhs' ->
 827     rnCoreBndr bndr             $ \ bndr' ->
 828     rnCoreExpr body             `thenM` \ body' ->
 829     returnM (UfLet (UfNonRec bndr' rhs') body')
 830
 831 rnCoreExpr (UfLet (UfRec pairs) body)
 832   = rnCoreBndrs bndrs           $ \ bndrs' ->
 833     mappM rnCoreExpr rhss       `thenM` \ rhss' ->
 834     rnCoreExpr body             `thenM` \ body' ->
 835     returnM (UfLet (UfRec (bndrs' `zip` rhss')) body')
 836   where
 837     (bndrs, rhss) = unzip pairs
 838 \end{code}
 839
 840 \begin{code}
 841 rnCoreBndr (UfValBinder name ty) thing_inside
 842   = rnHsType doc ty             `thenM` \ ty' ->
 843     bindCoreLocalRn name        $ \ name' ->
 844     thing_inside (UfValBinder name' ty')
 845   where
 846     doc = text "unfolding id"
 847
 848 rnCoreBndr (UfTyBinder name kind) thing_inside
 849   = bindCoreLocalRn name                $ \ name' ->
 850     thing_inside (UfTyBinder name' kind)
 851
 852 rnCoreBndrs []     thing_inside = thing_inside []
 853 rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b          $ \ name' ->
 854                                   rnCoreBndrs bs        $ \ names' ->
 855                                   thing_inside (name':names')
 856 \end{code}
 857
 858 \begin{code}
 859 rnCoreAlt (con, bndrs, rhs)
 860   = rnUfCon con                         `thenM` \ con' ->
 861     bindCoreLocalsRn bndrs              $ \ bndrs' ->
 862     rnCoreExpr rhs                      `thenM` \ rhs' ->
 863     returnM (con', bndrs', rhs')
 864
 865 rnNote (UfCoerce ty)
 866   = rnHsType (text "unfolding coerce") ty       `thenM` \ ty' ->
 867     returnM (UfCoerce ty')
 868
 869 rnNote (UfSCC cc)   = returnM (UfSCC cc)
 870 rnNote UfInlineCall = returnM UfInlineCall
 871 rnNote UfInlineMe   = returnM UfInlineMe
 872 rnNote (UfCoreNote s) = returnM (UfCoreNote s)
 873
 874 rnUfCon UfDefault
 875   = returnM UfDefault
 876
 877 rnUfCon (UfTupleAlt tup_con)
 878   = returnM (UfTupleAlt tup_con)
 879
 880 rnUfCon (UfDataAlt con)
 881   = lookupOccRn con             `thenM` \ con' ->
 882     returnM (UfDataAlt con')
 883
 884 rnUfCon (UfLitAlt lit)
 885   = returnM (UfLitAlt lit)
 886
 887 rnUfCon (UfLitLitAlt lit ty)
 888   = rnHsType (text "litlit") ty         `thenM` \ ty' ->
 889     returnM (UfLitLitAlt lit ty')
 890 \end{code}
 891
 892 %*********************************************************
 893 %*                                                      *
 894 \subsection{Statistics}
 895 %*                                                      *
 896 %*********************************************************
 897
 898 \begin{code}
 899 rnStats :: [RenamedHsDecl]      -- Imported decls
 900         -> TcRn m ()
 901 rnStats imp_decls
 902   = doptM Opt_D_dump_rn_trace   `thenM` \ dump_rn_trace ->
 903     doptM Opt_D_dump_rn_stats   `thenM` \ dump_rn_stats ->
 904     doptM Opt_D_dump_rn         `thenM` \ dump_rn ->
 905     getEps                      `thenM` \ eps ->
 906
 907     ioToTcRn (dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn)
 908                         "Renamer statistics"
 909                         (getRnStats eps imp_decls))     `thenM_`
 910     returnM ()
 911
 912 getRnStats :: ExternalPackageState -> [RenamedHsDecl] -> SDoc
 913 getRnStats eps imported_decls
 914   = hcat [text "Renamer stats: ", stats]
 915   where
 916     n_mods = length [() | _ <- moduleEnvElts (eps_PIT eps)]
 917         -- This is really only right for a one-shot compile
 918
 919     (decls_map, n_decls_slurped) = eps_decls eps
 920
 921     n_decls_left   = length [decl | (avail, True, (_,decl)) <- nameEnvElts decls_map
 922                         -- Data, newtype, and class decls are in the decls_fm
 923                         -- under multiple names; the tycon/class, and each
 924                         -- constructor/class op too.
 925                         -- The 'True' selects just the 'main' decl
 926                      ]
 927
 928     (insts_left, n_insts_slurped) = eps_insts eps
 929     n_insts_left  = length (bagToList insts_left)
 930
 931     (rules_left, n_rules_slurped) = eps_rules eps
 932     n_rules_left  = length (bagToList rules_left)
 933
 934     stats = vcat
 935         [int n_mods <+> text "interfaces read",
 936          hsep [ int n_decls_slurped, text "type/class/variable imported, out of",
 937                 int (n_decls_slurped + n_decls_left), text "read"],
 938          hsep [ int n_insts_slurped, text "instance decls imported, out of",
 939                 int (n_insts_slurped + n_insts_left), text "read"],
 940          hsep [ int n_rules_slurped, text "rule decls imported, out of",
 941                 int (n_rules_slurped + n_rules_left), text "read"]
 942         ]
 943 \end{code}
 944
 945 %*********************************************************
 946 %*                                                       *
 947 \subsection{Errors}
 948 %*                                                       *
 949 %*********************************************************
 950
 951 \begin{code}
 952 badDataCon name
 953    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 954
 955 badRuleLhsErr name lhs (Just bad_e)
 956   = sep [ptext SLIT("Rule") <+> ftext name <> colon,
 957          nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e,
 958                        ptext SLIT("in left-hand side:") <+> ppr lhs])]
 959     $$
 960     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 961
 962 badRuleVar name var
 963   = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
 964          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 965                 ptext SLIT("does not appear on left hand side")]
 966
 967 emptyConDeclsErr tycon
 968   = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
 969          nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
 970
 971 withWarning
 972   = sep [quotes (ptext SLIT("with")),
 973          ptext SLIT("is deprecated, use"),
 974          quotes (ptext SLIT("let")),
 975          ptext SLIT("instead")]
 976
 977 badIpBinds binds
 978   = hang (ptext SLIT("Implicit-parameter bindings illegal in 'mdo':")) 4
 979          (ppr binds)
 980 \end{code}
 981