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