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