ghc/compiler/rename/RnSource.lhs

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