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