ghc/compiler/rename/RnSource.lhs

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