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