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                           bindLocalsFV, bindPatSigTyVarsFV,
  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(..), TopLevelFlag(..)  )
  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, DefUses)
  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                 -- Rename other declarations
 102         (rn_val_decls, bind_dus) <- rnTopMonoBinds binds sigs ;
 103
 104                 -- You might think that we could build proper def/use information
 105                 -- for type and class declarations, but they can be involved
 106                 -- in mutual recursion across modules, and we only do the SCC
 107                 -- analysis for them in the type checker.
 108                 -- So we content ourselves with gathering uses only; that
 109                 -- means we'll only report a declaration as unused if it isn't
 110                 -- mentioned at all.  Ah well.
 111         (rn_tycl_decls,    src_fvs1) <- mapFvRn rnSrcTyClDecl tycl_decls ;
 112         (rn_inst_decls,    src_fvs2) <- mapFvRn rnSrcInstDecl inst_decls ;
 113         (rn_rule_decls,    src_fvs3) <- mapFvRn rnHsRuleDecl rule_decls ;
 114         (rn_foreign_decls, src_fvs4) <- mapFvRn rnHsForeignDecl foreign_decls ;
 115         (rn_default_decls, src_fvs5) <- mapFvRn rnDefaultDecl default_decls ;
 116         (rn_core_decls,    src_fvs6) <- mapFvRn rnCoreDecl core_decls ;
 117
 118         let {
 119            rn_group = HsGroup { hs_valds  = rn_val_decls,
 120                                 hs_tyclds = rn_tycl_decls,
 121                                 hs_instds = rn_inst_decls,
 122                                 hs_fixds  = [],
 123                                 hs_depds  = [],
 124                                 hs_fords  = rn_foreign_decls,
 125                                 hs_defds  = rn_default_decls,
 126                                 hs_ruleds = rn_rule_decls,
 127                                 hs_coreds = rn_core_decls } ;
 128
 129            other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3,
 130                                 src_fvs4, src_fvs5, src_fvs6] ;
 131            src_dus = bind_dus `plusDU` usesOnly other_fvs
 132         } ;
 133
 134         tcg_env <- getGblEnv ;
 135         return (tcg_env, rn_group, src_dus)
 136     }}}
 137 \end{code}
 138
 139
 140 %*********************************************************
 141 %*                                                       *
 142         Source-code fixity declarations
 143 %*                                                       *
 144 %*********************************************************
 145
 146 \begin{code}
 147 rnSrcFixityDecls :: [RdrNameFixitySig] -> TcRn m FixityEnv
 148 rnSrcFixityDecls fix_decls
 149   = getGblEnv                                   `thenM` \ gbl_env ->
 150     foldlM rnFixityDecl (tcg_fix_env gbl_env)
 151             fix_decls                           `thenM` \ fix_env ->
 152     traceRn (text "fixity env" <+> ppr fix_env) `thenM_`
 153     returnM fix_env
 154
 155 rnFixityDecl :: FixityEnv -> RdrNameFixitySig -> TcRn m FixityEnv
 156 rnFixityDecl fix_env (FixitySig rdr_name fixity loc)
 157   =     -- GHC extension: look up both the tycon and data con
 158         -- for con-like things
 159         -- If neither are in scope, report an error; otherwise
 160         -- add both to the fixity env
 161      mappM lookupTopSrcBndr_maybe (dataTcOccs rdr_name) `thenM` \ maybe_ns ->
 162      case catMaybes maybe_ns of
 163           [] -> addSrcLoc loc                   $
 164                 addErr (unknownNameErr rdr_name)        `thenM_`
 165                 returnM fix_env
 166           ns -> foldlM add fix_env ns
 167   where
 168     add fix_env name
 169       = case lookupNameEnv fix_env name of
 170           Just (FixitySig _ _ loc') -> addErr (dupFixityDecl rdr_name loc loc') `thenM_`
 171                                        returnM fix_env
 172           Nothing -> returnM (extendNameEnv fix_env name (FixitySig name fixity loc))
 173
 174 dupFixityDecl rdr_name loc1 loc2
 175   = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
 176           ptext SLIT("at ") <+> ppr loc1,
 177           ptext SLIT("and") <+> ppr loc2]
 178 \end{code}
 179
 180
 181 %*********************************************************
 182 %*                                                       *
 183         Source-code deprecations declarations
 184 %*                                                       *
 185 %*********************************************************
 186
 187 For deprecations, all we do is check that the names are in scope.
 188 It's only imported deprecations, dealt with in RnIfaces, that we
 189 gather them together.
 190
 191 \begin{code}
 192 rnSrcDeprecDecls :: [RdrNameDeprecation] -> TcRn m Deprecations
 193 rnSrcDeprecDecls []
 194   = returnM NoDeprecs
 195
 196 rnSrcDeprecDecls decls
 197   = mappM rn_deprec decls       `thenM` \ pairs ->
 198     returnM (DeprecSome (mkNameEnv (catMaybes pairs)))
 199  where
 200    rn_deprec (Deprecation rdr_name txt loc)
 201      = addSrcLoc loc                    $
 202        lookupTopSrcBndr rdr_name        `thenM` \ name ->
 203        returnM (Just (name, (name,txt)))
 204
 205 checkModDeprec :: Maybe DeprecTxt -> Deprecations
 206 -- Check for a module deprecation; done once at top level
 207 checkModDeprec Nothing    = NoDeprecs
 208 checkModdeprec (Just txt) = DeprecAll txt
 209
 210 badDeprec d
 211   = sep [ptext SLIT("Illegal deprecation when whole module is deprecated"),
 212          nest 4 (ppr d)]
 213 \end{code}
 214
 215 %*********************************************************
 216 %*                                                      *
 217 \subsection{Source code declarations}
 218 %*                                                      *
 219 %*********************************************************
 220
 221 \begin{code}
 222 rnSrcTyClDecl tycl_decl
 223   = rnTyClDecl tycl_decl                        `thenM` \ new_decl ->
 224     finishSourceTyClDecl tycl_decl new_decl     `thenM` \ (new_decl', fvs) ->
 225     returnM (new_decl', fvs `plusFV` tyClDeclFVs new_decl')
 226
 227 rnSrcInstDecl inst
 228   = rnInstDecl inst                     `thenM` \ new_inst ->
 229     finishSourceInstDecl inst new_inst  `thenM` \ (new_inst', fvs) ->
 230     returnM (new_inst', fvs `plusFV` instDeclFVs new_inst')
 231
 232 rnDefaultDecl (DefaultDecl tys src_loc)
 233   = addSrcLoc src_loc $
 234     mapFvRn (rnHsTypeFVs doc_str) tys           `thenM` \ (tys', fvs) ->
 235     returnM (DefaultDecl tys' src_loc, fvs)
 236   where
 237     doc_str = text "In a `default' declaration"
 238
 239
 240 rnCoreDecl (CoreDecl name ty rhs loc)
 241   = addSrcLoc loc $
 242     lookupTopBndrRn name                `thenM` \ name' ->
 243     rnHsTypeFVs doc_str ty              `thenM` \ (ty', ty_fvs) ->
 244     rnCoreExpr rhs                      `thenM` \ rhs' ->
 245     returnM (CoreDecl name' ty' rhs' loc,
 246              ty_fvs `plusFV` ufExprFVs rhs')
 247   where
 248     doc_str = text "In the Core declaration for" <+> quotes (ppr name)
 249 \end{code}
 250
 251 %*********************************************************
 252 %*                                                      *
 253                 Bindings
 254 %*                                                      *
 255 %*********************************************************
 256
 257 These chaps are here, rather than in TcBinds, so that there
 258 is just one hi-boot file (for RnSource).  rnSrcDecls is part
 259 of the loop too, and it must be defined in this module.
 260
 261 \begin{code}
 262 rnBinds    :: RdrNameHsBinds -> RnM (RenamedHsBinds, DefUses)
 263 -- This version assumes that the binders are already in scope
 264 -- It's used only in 'mdo'
 265 rnBinds EmptyBinds             = returnM (EmptyBinds, emptyDUs)
 266 rnBinds (MonoBind bind sigs _) = rnMonoBinds NotTopLevel bind sigs
 267 rnBinds b@(IPBinds bind _)     = addErr (badIpBinds b)  `thenM_`
 268                                  returnM (EmptyBinds, emptyDUs)
 269
 270 rnBindsAndThen  :: RdrNameHsBinds
 271                 -> (RenamedHsBinds -> RnM (result, FreeVars))
 272                 -> RnM (result, FreeVars)
 273 -- This version (a) assumes that the binding vars are not already in scope
 274 --              (b) removes the binders from the free vars of the thing inside
 275 -- The parser doesn't produce ThenBinds
 276 rnBindsAndThen EmptyBinds              thing_inside = thing_inside EmptyBinds
 277 rnBindsAndThen (MonoBind bind sigs _)  thing_inside = rnMonoBindsAndThen bind sigs thing_inside
 278 rnBindsAndThen (IPBinds binds is_with) thing_inside
 279   = warnIf is_with withWarning                  `thenM_`
 280     rnIPBinds binds                             `thenM` \ (binds',fv_binds) ->
 281     thing_inside (IPBinds binds' is_with)       `thenM` \ (thing, fvs_thing) ->
 282     returnM (thing, fvs_thing `plusFV` fv_binds)
 283 \end{code}
 284
 285
 286 %************************************************************************
 287 %*                                                                      *
 288 \subsubsection{@rnIPBinds@s: in implicit parameter bindings}            *
 289 %*                                                                      *
 290 %************************************************************************
 291
 292 \begin{code}
 293 rnIPBinds [] = returnM ([], emptyFVs)
 294 rnIPBinds ((n, expr) : binds)
 295   = newIPName n                 `thenM` \ name ->
 296     rnExpr expr                 `thenM` \ (expr',fvExpr) ->
 297     rnIPBinds binds             `thenM` \ (binds',fvBinds) ->
 298     returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds)
 299
 300 \end{code}
 301
 302
 303 %*********************************************************
 304 %*                                                      *
 305 \subsection{Foreign declarations}
 306 %*                                                      *
 307 %*********************************************************
 308
 309 \begin{code}
 310 rnHsForeignDecl (ForeignImport name ty spec isDeprec src_loc)
 311   = addSrcLoc src_loc           $
 312     lookupTopBndrRn name                `thenM` \ name' ->
 313     rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
 314     returnM (ForeignImport name' ty' spec isDeprec src_loc,
 315               fvs `plusFV` extras spec)
 316   where
 317     extras (CImport _ _ _ _ CWrapper) = mkFVs [newStablePtrName,
 318                                                bindIOName, returnIOName]
 319     extras _                          = emptyFVs
 320
 321 rnHsForeignDecl (ForeignExport name ty spec isDeprec src_loc)
 322   = addSrcLoc src_loc                   $
 323     lookupOccRn name                            `thenM` \ name' ->
 324     rnHsTypeFVs (fo_decl_msg name) ty           `thenM` \ (ty', fvs) ->
 325     returnM (ForeignExport name' ty' spec isDeprec src_loc,
 326               mkFVs [name', bindIOName, returnIOName] `plusFV` fvs )
 327         -- NB: a foreign export is an *occurrence site* for name, so
 328         --     we add it to the free-variable list.  It might, for example,
 329         --     be imported from another module
 330
 331 fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
 332 \end{code}
 333
 334
 335 %*********************************************************
 336 %*                                                      *
 337 \subsection{Instance declarations}
 338 %*                                                      *
 339 %*********************************************************
 340
 341 \begin{code}
 342 rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc)
 343         -- Used for both source and interface file decls
 344   = addSrcLoc src_loc $
 345     rnHsSigType (text "an instance decl") inst_ty       `thenM` \ inst_ty' ->
 346
 347     (case maybe_dfun_rdr_name of
 348         Nothing            -> returnM Nothing
 349         Just dfun_rdr_name -> lookupGlobalOccRn dfun_rdr_name   `thenM` \ dfun_name ->
 350                               returnM (Just dfun_name)
 351     )                                                   `thenM` \ maybe_dfun_name ->
 352
 353     -- The typechecker checks that all the bindings are for the right class.
 354     returnM (InstDecl inst_ty' EmptyMonoBinds [] maybe_dfun_name src_loc)
 355
 356 -- Compare finishSourceTyClDecl
 357 finishSourceInstDecl (InstDecl _       mbinds uprags _               _      )
 358                      (InstDecl inst_ty _      _      maybe_dfun_name src_loc)
 359         -- Used for both source decls only
 360   = ASSERT( not (maybeToBool maybe_dfun_name) ) -- Source decl!
 361     let
 362         meth_doc    = text "In the bindings in an instance declaration"
 363         meth_names  = collectLocatedMonoBinders mbinds
 364         (inst_tyvars, _, cls,_) = splitHsInstDeclTy inst_ty
 365         -- (Slightly strangely) the forall-d tyvars scope over
 366         -- the method bindings too
 367     in
 368
 369         -- Rename the bindings
 370         -- NB meth_names can be qualified!
 371     checkDupNames meth_doc meth_names           `thenM_`
 372     extendTyVarEnvForMethodBinds inst_tyvars (
 373         rnMethodBinds cls [] mbinds
 374     )                                           `thenM` \ (mbinds', meth_fvs) ->
 375     let
 376         binders = collectMonoBinders mbinds'
 377     in
 378         -- Rename the prags and signatures.
 379         -- Note that the type variables are not in scope here,
 380         -- so that      instance Eq a => Eq (T a) where
 381         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
 382         -- works OK.
 383         --
 384         -- But the (unqualified) method names are in scope
 385     bindLocalNames binders (renameSigs uprags)                  `thenM` \ uprags' ->
 386     checkSigs (okInstDclSig (mkNameSet binders)) uprags'        `thenM_`
 387
 388     returnM (InstDecl inst_ty mbinds' uprags' maybe_dfun_name src_loc,
 389               meth_fvs `plusFV` hsSigsFVs uprags')
 390 \end{code}
 391
 392 %*********************************************************
 393 %*                                                      *
 394 \subsection{Rules}
 395 %*                                                      *
 396 %*********************************************************
 397
 398 \begin{code}
 399 rnIfaceRuleDecl (IfaceRule rule_name act vars fn args rhs src_loc)
 400   = addSrcLoc src_loc   $
 401     lookupOccRn fn              `thenM` \ fn' ->
 402     rnCoreBndrs vars            $ \ vars' ->
 403     mappM rnCoreExpr args       `thenM` \ args' ->
 404     rnCoreExpr rhs              `thenM` \ rhs' ->
 405     returnM (IfaceRule rule_name act vars' fn' args' rhs' src_loc)
 406
 407 rnIfaceRuleDecl (IfaceRuleOut fn rule)          -- Builtin rules come this way
 408   = lookupOccRn fn              `thenM` \ fn' ->
 409     returnM (IfaceRuleOut fn' rule)
 410
 411 rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc)
 412   = addSrcLoc src_loc                                   $
 413     bindPatSigTyVarsFV (collectRuleBndrSigTys vars)     $
 414
 415     bindLocalsFV doc (map get_var vars)         $ \ ids ->
 416     mapFvRn rn_var (vars `zip` ids)             `thenM` \ (vars', fv_vars) ->
 417
 418     rnExpr lhs                                  `thenM` \ (lhs', fv_lhs) ->
 419     rnExpr rhs                                  `thenM` \ (rhs', fv_rhs) ->
 420     let
 421         mb_bad = validRuleLhs ids lhs'
 422     in
 423     checkErr (isNothing mb_bad)
 424              (badRuleLhsErr rule_name lhs' mb_bad)      `thenM_`
 425     let
 426         bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
 427     in
 428     mappM (addErr . badRuleVar rule_name) bad_vars      `thenM_`
 429     returnM (HsRule rule_name act vars' lhs' rhs' src_loc,
 430               fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
 431   where
 432     doc = text "In the transformation rule" <+> ftext rule_name
 433
 434     get_var (RuleBndr v)      = v
 435     get_var (RuleBndrSig v _) = v
 436
 437     rn_var (RuleBndr v, id)      = returnM (RuleBndr id, emptyFVs)
 438     rn_var (RuleBndrSig v t, id) = rnHsTypeFVs doc t    `thenM` \ (t', fvs) ->
 439                                    returnM (RuleBndrSig id t', fvs)
 440 \end{code}
 441
 442 Check the shape of a transformation rule LHS.  Currently
 443 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
 444 not one of the @forall@'d variables.  We also restrict the form of the LHS so
 445 that it may be plausibly matched.  Basically you only get to write ordinary
 446 applications.  (E.g. a case expression is not allowed: too elaborate.)
 447
 448 NB: if you add new cases here, make sure you add new ones to TcRule.ruleLhsTvs
 449
 450 \begin{code}
 451 validRuleLhs :: [Name] -> RenamedHsExpr -> Maybe RenamedHsExpr
 452 -- Nothing => OK
 453 -- Just e  => Not ok, and e is the offending expression
 454 validRuleLhs foralls lhs
 455   = check lhs
 456   where
 457     check (OpApp e1 op _ e2)              = check op `seqMaybe` check_e e1 `seqMaybe` check_e e2
 458     check (HsApp e1 e2)                   = check e1 `seqMaybe` check_e e2
 459     check (HsVar v) | v `notElem` foralls = Nothing
 460     check other                           = Just other  -- Failure
 461
 462     check_e (HsVar v)     = Nothing
 463     check_e (HsPar e)     = check_e e
 464     check_e (HsLit e)     = Nothing
 465     check_e (HsOverLit e) = Nothing
 466
 467     check_e (OpApp e1 op _ e2)   = check_e e1 `seqMaybe` check_e op `seqMaybe` check_e e2
 468     check_e (HsApp e1 e2)        = check_e e1 `seqMaybe` check_e e2
 469     check_e (NegApp e _)         = check_e e
 470     check_e (ExplicitList _ es)  = check_es es
 471     check_e (ExplicitTuple es _) = check_es es
 472     check_e other                = Just other   -- Fails
 473
 474     check_es es = foldr (seqMaybe . check_e) Nothing es
 475 \end{code}
 476
 477
 478 %*********************************************************
 479 %*                                                      *
 480 \subsection{Type, class and iface sig declarations}
 481 %*                                                      *
 482 %*********************************************************
 483
 484 @rnTyDecl@ uses the `global name function' to create a new type
 485 declaration in which local names have been replaced by their original
 486 names, reporting any unknown names.
 487
 488 Renaming type variables is a pain. Because they now contain uniques,
 489 it is necessary to pass in an association list which maps a parsed
 490 tyvar to its @Name@ representation.
 491 In some cases (type signatures of values),
 492 it is even necessary to go over the type first
 493 in order to get the set of tyvars used by it, make an assoc list,
 494 and then go over it again to rename the tyvars!
 495 However, we can also do some scoping checks at the same time.
 496
 497 \begin{code}
 498 rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc = loc})
 499   = addSrcLoc loc $
 500     lookupTopBndrRn name                `thenM` \ name' ->
 501     rnHsType doc_str ty                 `thenM` \ ty' ->
 502     mappM rnIdInfo id_infos             `thenM` \ id_infos' ->
 503     returnM (IfaceSig {tcdName = name', tcdType = ty', tcdIdInfo = id_infos', tcdLoc = loc})
 504   where
 505     doc_str = text "In the interface signature for" <+> quotes (ppr name)
 506
 507 rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
 508   = addSrcLoc loc                       $
 509     lookupTopBndrRn name                `thenM` \ name' ->
 510     returnM (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
 511
 512 rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
 513                     tcdTyVars = tyvars, tcdCons = condecls, tcdGeneric = want_generic,
 514                     tcdDerivs = derivs, tcdLoc = src_loc})
 515   = addSrcLoc src_loc $
 516     lookupTopBndrRn tycon                       `thenM` \ tycon' ->
 517     bindTyVarsRn data_doc tyvars                $ \ tyvars' ->
 518     rnContext data_doc context                  `thenM` \ context' ->
 519     rn_derivs derivs                            `thenM` \ derivs' ->
 520     checkDupOrQualNames data_doc con_names      `thenM_`
 521
 522     rnConDecls tycon' condecls                  `thenM` \ condecls' ->
 523     returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon',
 524                      tcdTyVars = tyvars', tcdCons = condecls', tcdGeneric = want_generic,
 525                      tcdDerivs = derivs', tcdLoc = src_loc})
 526   where
 527     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
 528     con_names = map conDeclName (visibleDataCons condecls)
 529
 530     rn_derivs Nothing   = returnM Nothing
 531     rn_derivs (Just ds) = rnContext data_doc ds `thenM` \ ds' -> returnM (Just ds')
 532
 533 rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc})
 534   = addSrcLoc src_loc $
 535     lookupTopBndrRn name                        `thenM` \ name' ->
 536     bindTyVarsRn syn_doc tyvars                 $ \ tyvars' ->
 537     rnHsType syn_doc ty                         `thenM` \ ty' ->
 538     returnM (TySynonym {tcdName = name', tcdTyVars = tyvars', tcdSynRhs = ty', tcdLoc = src_loc})
 539   where
 540     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 541
 542 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname,
 543                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
 544                        tcdLoc = src_loc})
 545         -- Used for both source and interface file decls
 546   = addSrcLoc src_loc $
 547
 548     lookupTopBndrRn cname                       `thenM` \ cname' ->
 549
 550         -- Tyvars scope over superclass context and method signatures
 551     bindTyVarsRn cls_doc tyvars                 $ \ tyvars' ->
 552
 553         -- Check the superclasses
 554     rnContext cls_doc context                   `thenM` \ context' ->
 555
 556         -- Check the functional dependencies
 557     rnFds cls_doc fds                           `thenM` \ fds' ->
 558
 559         -- Check the signatures
 560         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 561     let
 562         (op_sigs, non_op_sigs) = partition isClassOpSig sigs
 563         sig_rdr_names_w_locs   = [(op,locn) | ClassOpSig op _ _ locn <- sigs]
 564     in
 565     checkDupOrQualNames sig_doc sig_rdr_names_w_locs    `thenM_`
 566     mappM (rnClassOp cname' fds') op_sigs               `thenM` \ sigs' ->
 567     renameSigs non_op_sigs                              `thenM` \ non_ops' ->
 568     checkSigs okClsDclSig  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 rnNote (UfCoreNote s) = returnM (UfCoreNote s)
 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