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