ghc/compiler/rename/RnSource.lhs

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