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