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