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