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, addTcgDUs,
   9         rnTyClDecls, checkModDeprec,
  10         rnSplice, checkTH
  11     ) where
  12
  13 #include "HsVersions.h"
  14
  15 import {-# SOURCE #-} RnExpr( rnLExpr )
  16
  17 import HsSyn
  18 import RdrName          ( RdrName, isRdrDataCon, isRdrTyVar, rdrNameOcc,
  19                           elemLocalRdrEnv, globalRdrEnvElts, GlobalRdrElt(..),
  20                           isLocalGRE )
  21 import RdrHsSyn         ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
  22 import RnHsSyn
  23 import RnTypes          ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
  24 import RnBinds          ( rnTopBinds, rnMethodBinds, renameSigs, mkSigTvFn )
  25 import RnEnv            ( lookupLocalDataTcNames,
  26                           lookupLocatedTopBndrRn, lookupLocatedOccRn,
  27                           lookupOccRn, newLocalsRn,
  28                           bindLocatedLocalsFV, bindPatSigTyVarsFV,
  29                           bindTyVarsRn, extendTyVarEnvFVRn,
  30                           bindLocalNames, checkDupNames, mapFvRn
  31                         )
  32 import TcRnMonad
  33
  34 import HscTypes         ( FixityEnv, FixItem(..),
  35                           Deprecations, Deprecs(..), DeprecTxt, plusDeprecs )
  36 import Class            ( FunDep )
  37 import Name             ( Name, nameOccName )
  38 import NameSet
  39 import NameEnv
  40 import OccName          ( occEnvElts )
  41 import Outputable
  42 import SrcLoc           ( Located(..), unLoc, noLoc )
  43 import DynFlags ( DynFlag(..) )
  44 import Maybes           ( seqMaybe )
  45 import Maybe            ( isNothing, isJust )
  46 import Monad            ( liftM, when )
  47 import BasicTypes       ( Boxity(..) )
  48 \end{code}
  49
  50 @rnSourceDecl@ `renames' declarations.
  51 It simultaneously performs dependency analysis and precedence parsing.
  52 It also does the following error checks:
  53 \begin{enumerate}
  54 \item
  55 Checks that tyvars are used properly. This includes checking
  56 for undefined tyvars, and tyvars in contexts that are ambiguous.
  57 (Some of this checking has now been moved to module @TcMonoType@,
  58 since we don't have functional dependency information at this point.)
  59 \item
  60 Checks that all variable occurences are defined.
  61 \item
  62 Checks the @(..)@ etc constraints in the export list.
  63 \end{enumerate}
  64
  65
  66 \begin{code}
  67 rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
  68
  69 rnSrcDecls (HsGroup { hs_valds  = val_decls,
  70                       hs_tyclds = tycl_decls,
  71                       hs_instds = inst_decls,
  72                       hs_fixds  = fix_decls,
  73                       hs_depds  = deprec_decls,
  74                       hs_fords  = foreign_decls,
  75                       hs_defds  = default_decls,
  76                       hs_ruleds = rule_decls })
  77
  78  = do {         -- Deal with deprecations (returns only the extra deprecations)
  79         deprecs <- rnSrcDeprecDecls deprec_decls ;
  80         updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs })
  81                   $ do {
  82
  83                 -- Deal with top-level fixity decls
  84                 -- (returns the total new fixity env)
  85         rn_fix_decls <- rnSrcFixityDecls fix_decls ;
  86         fix_env <- rnSrcFixityDeclsEnv rn_fix_decls ;
  87         updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
  88                   $ do {
  89
  90                 -- Rename other declarations
  91         traceRn (text "Start rnmono") ;
  92         (rn_val_decls, bind_dus) <- rnTopBinds val_decls ;
  93         traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
  94
  95                 -- You might think that we could build proper def/use information
  96                 -- for type and class declarations, but they can be involved
  97                 -- in mutual recursion across modules, and we only do the SCC
  98                 -- analysis for them in the type checker.
  99                 -- So we content ourselves with gathering uses only; that
 100                 -- means we'll only report a declaration as unused if it isn't
 101                 -- mentioned at all.  Ah well.
 102         (rn_tycl_decls,    src_fvs1)
 103            <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ;
 104         (rn_inst_decls,    src_fvs2)
 105            <- mapFvRn (wrapLocFstM rnSrcInstDecl) inst_decls ;
 106         (rn_rule_decls,    src_fvs3)
 107            <- mapFvRn (wrapLocFstM rnHsRuleDecl) rule_decls ;
 108         (rn_foreign_decls, src_fvs4)
 109            <- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ;
 110         (rn_default_decls, src_fvs5)
 111            <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
 112
 113         let {
 114            rn_group = HsGroup { hs_valds  = rn_val_decls,
 115                                 hs_tyclds = rn_tycl_decls,
 116                                 hs_instds = rn_inst_decls,
 117                                 hs_fixds  = rn_fix_decls,
 118                                 hs_depds  = [],
 119                                 hs_fords  = rn_foreign_decls,
 120                                 hs_defds  = rn_default_decls,
 121                                 hs_ruleds = rn_rule_decls } ;
 122
 123            other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3,
 124                                 src_fvs4, src_fvs5] ;
 125            src_dus = bind_dus `plusDU` usesOnly other_fvs
 126                 -- Note: src_dus will contain *uses* for locally-defined types
 127                 -- and classes, but no *defs* for them.  (Because rnTyClDecl
 128                 -- returns only the uses.)  This is a little
 129                 -- surprising but it doesn't actually matter at all.
 130         } ;
 131
 132         traceRn (text "finish rnSrc" <+> ppr rn_group) ;
 133         traceRn (text "finish Dus" <+> ppr src_dus ) ;
 134         tcg_env <- getGblEnv ;
 135         return (tcg_env `addTcgDUs` src_dus, rn_group)
 136     }}}
 137
 138 rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
 139 rnTyClDecls tycl_decls = do
 140   (decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls
 141   return decls'
 142
 143 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
 144 addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
 145 \end{code}
 146
 147
 148 %*********************************************************
 149 %*                                                       *
 150         Source-code fixity declarations
 151 %*                                                       *
 152 %*********************************************************
 153
 154 \begin{code}
 155 rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM [LFixitySig Name]
 156 rnSrcFixityDecls fix_decls
 157     = do fix_decls <- mapM rnFixityDecl fix_decls
 158          return (concat fix_decls)
 159
 160 rnFixityDecl :: LFixitySig RdrName -> RnM [LFixitySig Name]
 161 rnFixityDecl (L loc (FixitySig (L nameLoc rdr_name) fixity))
 162     = setSrcSpan nameLoc $
 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       do names <- lookupLocalDataTcNames rdr_name
 168          return [ L loc (FixitySig (L nameLoc name) fixity)
 169                       | name <- names ]
 170
 171 rnSrcFixityDeclsEnv :: [LFixitySig Name] -> RnM FixityEnv
 172 rnSrcFixityDeclsEnv fix_decls
 173   = getGblEnv                                   `thenM` \ gbl_env ->
 174     foldlM rnFixityDeclEnv (tcg_fix_env gbl_env)
 175             fix_decls                                   `thenM` \ fix_env ->
 176     traceRn (text "fixity env" <+> pprFixEnv fix_env)   `thenM_`
 177     returnM fix_env
 178
 179 rnFixityDeclEnv :: FixityEnv -> LFixitySig Name -> RnM FixityEnv
 180 rnFixityDeclEnv fix_env (L loc (FixitySig (L nameLoc name) fixity))
 181   = case lookupNameEnv fix_env name of
 182       Just (FixItem _ _ loc')
 183           -> do addLocErr (L nameLoc name) (dupFixityDecl loc')
 184                 return fix_env
 185       Nothing
 186           -> return (extendNameEnv fix_env name fix_item)
 187     where fix_item = FixItem (nameOccName name) fixity nameLoc
 188
 189 pprFixEnv :: FixityEnv -> SDoc
 190 pprFixEnv env
 191   = pprWithCommas (\ (FixItem n f _) -> ppr f <+> ppr n)
 192                   (nameEnvElts env)
 193
 194 dupFixityDecl loc rdr_name
 195   = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
 196           ptext SLIT("also at ") <+> ppr loc
 197         ]
 198 \end{code}
 199
 200
 201 %*********************************************************
 202 %*                                                       *
 203         Source-code deprecations declarations
 204 %*                                                       *
 205 %*********************************************************
 206
 207 For deprecations, all we do is check that the names are in scope.
 208 It's only imported deprecations, dealt with in RnIfaces, that we
 209 gather them together.
 210
 211 \begin{code}
 212 rnSrcDeprecDecls :: [LDeprecDecl RdrName] -> RnM Deprecations
 213 rnSrcDeprecDecls []
 214   = returnM NoDeprecs
 215
 216 rnSrcDeprecDecls decls
 217   = mappM (addLocM rn_deprec) decls     `thenM` \ pairs_s ->
 218     returnM (DeprecSome (mkNameEnv (concat pairs_s)))
 219  where
 220    rn_deprec (Deprecation rdr_name txt)
 221      = lookupLocalDataTcNames rdr_name  `thenM` \ names ->
 222        returnM [(name, (nameOccName name, txt)) | name <- names]
 223
 224 checkModDeprec :: Maybe DeprecTxt -> Deprecations
 225 -- Check for a module deprecation; done once at top level
 226 checkModDeprec Nothing    = NoDeprecs
 227 checkModDeprec (Just txt) = DeprecAll txt
 228 \end{code}
 229
 230 %*********************************************************
 231 %*                                                      *
 232 \subsection{Source code declarations}
 233 %*                                                      *
 234 %*********************************************************
 235
 236 \begin{code}
 237 rnDefaultDecl (DefaultDecl tys)
 238   = mapFvRn (rnHsTypeFVs doc_str) tys   `thenM` \ (tys', fvs) ->
 239     returnM (DefaultDecl tys', fvs)
 240   where
 241     doc_str = text "In a `default' declaration"
 242 \end{code}
 243
 244 %*********************************************************
 245 %*                                                      *
 246 \subsection{Foreign declarations}
 247 %*                                                      *
 248 %*********************************************************
 249
 250 \begin{code}
 251 rnHsForeignDecl (ForeignImport name ty spec)
 252   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
 253     rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
 254     returnM (ForeignImport name' ty' spec, fvs)
 255
 256 rnHsForeignDecl (ForeignExport name ty spec)
 257   = lookupLocatedOccRn name             `thenM` \ name' ->
 258     rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
 259     returnM (ForeignExport name' ty' spec, fvs )
 260         -- NB: a foreign export is an *occurrence site* for name, so
 261         --     we add it to the free-variable list.  It might, for example,
 262         --     be imported from another module
 263
 264 fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
 265 \end{code}
 266
 267
 268 %*********************************************************
 269 %*                                                      *
 270 \subsection{Instance declarations}
 271 %*                                                      *
 272 %*********************************************************
 273
 274 \begin{code}
 275 rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
 276         -- Used for both source and interface file decls
 277   = rnHsSigType (text "an instance decl") inst_ty       `thenM` \ inst_ty' ->
 278
 279         -- Rename the associated types
 280         -- The typechecker (not the renamer) checks that all
 281         -- the declarations are for the right class
 282     let
 283         at_doc   = text "In the associated types of an instance declaration"
 284         at_names = map (head . tyClDeclNames . unLoc) ats
 285     in
 286     checkDupNames at_doc at_names               `thenM_`
 287     rnATInsts ats                               `thenM` \ (ats', at_fvs) ->
 288
 289         -- Rename the bindings
 290         -- The typechecker (not the renamer) checks that all
 291         -- the bindings are for the right class
 292     let
 293         meth_doc    = text "In the bindings in an instance declaration"
 294         meth_names  = collectHsBindLocatedBinders mbinds
 295         (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
 296     in
 297     checkDupNames meth_doc meth_names   `thenM_`
 298     extendTyVarEnvForMethodBinds inst_tyvars (
 299         -- (Slightly strangely) the forall-d tyvars scope over
 300         -- the method bindings too
 301         rnMethodBinds cls (\n->[])      -- No scoped tyvars
 302                       [] mbinds
 303     )                                           `thenM` \ (mbinds', meth_fvs) ->
 304         -- Rename the prags and signatures.
 305         -- Note that the type variables are not in scope here,
 306         -- so that      instance Eq a => Eq (T a) where
 307         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
 308         -- works OK.
 309         --
 310         -- But the (unqualified) method names are in scope
 311     let
 312         binders = collectHsBindBinders mbinds'
 313         ok_sig  = okInstDclSig (mkNameSet binders)
 314     in
 315     bindLocalNames binders (renameSigs ok_sig uprags)   `thenM` \ uprags' ->
 316
 317     returnM (InstDecl inst_ty' mbinds' uprags' ats',
 318              meth_fvs `plusFV` at_fvs
 319                       `plusFV` hsSigsFVs uprags'
 320                       `plusFV` extractHsTyNames inst_ty')
 321              -- We return the renamed associated data type declarations so
 322              -- that they can be entered into the list of type declarations
 323              -- for the binding group, but we also keep a copy in the instance.
 324              -- The latter is needed for well-formedness checks in the type
 325              -- checker (eg, to ensure that all ATs of the instance actually
 326              -- receive a declaration).
 327              -- NB: Even the copies in the instance declaration carry copies of
 328              --     the instance context after renaming.  This is a bit
 329              --     strange, but should not matter (and it would be more work
 330              --     to remove the context).
 331 \end{code}
 332
 333 Renaming of the associated types in instances.
 334
 335 * We raise an error if we encounter a kind signature in an instance.
 336
 337 \begin{code}
 338 rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 339 rnATInsts atDecls =
 340   mapFvRn (wrapLocFstM rnATInst) atDecls
 341   where
 342     rnATInst tydecl@TyFunction {} =
 343       do
 344         addErr noKindSig
 345         rnTyClDecl tydecl
 346     rnATInst tydecl@TySynonym  {} = rnTyClDecl tydecl
 347     rnATInst tydecl@TyData     {} =
 348       do
 349         checkM (not . isKindSigDecl $ tydecl) $ addErr noKindSig
 350         rnTyClDecl tydecl
 351     rnATInst _                    =
 352       panic "RnSource.rnATInsts: not a type declaration"
 353
 354 noKindSig = text "Instances cannot have kind signatures"
 355 \end{code}
 356
 357 For the method bindings in class and instance decls, we extend the
 358 type variable environment iff -fglasgow-exts
 359
 360 \begin{code}
 361 extendTyVarEnvForMethodBinds tyvars thing_inside
 362   = doptM Opt_GlasgowExts                       `thenM` \ opt_GlasgowExts ->
 363     if opt_GlasgowExts then
 364         extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
 365     else
 366         thing_inside
 367 \end{code}
 368
 369
 370 %*********************************************************
 371 %*                                                      *
 372 \subsection{Rules}
 373 %*                                                      *
 374 %*********************************************************
 375
 376 \begin{code}
 377 rnHsRuleDecl (HsRule rule_name act vars lhs fv_lhs rhs fv_rhs)
 378   = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)     $
 379
 380     bindLocatedLocalsFV doc (map get_var vars)          $ \ ids ->
 381     mapFvRn rn_var (vars `zip` ids)             `thenM` \ (vars', fv_vars) ->
 382
 383     rnLExpr lhs                                 `thenM` \ (lhs', fv_lhs') ->
 384     rnLExpr rhs                                 `thenM` \ (rhs', fv_rhs') ->
 385
 386     checkValidRule rule_name ids lhs' fv_lhs'   `thenM_`
 387
 388     returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
 389              fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs')
 390   where
 391     doc = text "In the transformation rule" <+> ftext rule_name
 392
 393     get_var (RuleBndr v)      = v
 394     get_var (RuleBndrSig v _) = v
 395
 396     rn_var (RuleBndr (L loc v), id)
 397         = returnM (RuleBndr (L loc id), emptyFVs)
 398     rn_var (RuleBndrSig (L loc v) t, id)
 399         = rnHsTypeFVs doc t     `thenM` \ (t', fvs) ->
 400           returnM (RuleBndrSig (L loc id) t', fvs)
 401
 402 badRuleVar name var
 403   = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
 404          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 405                 ptext SLIT("does not appear on left hand side")]
 406 \end{code}
 407
 408 Note [Rule LHS validity checking]
 409 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 410 Check the shape of a transformation rule LHS.  Currently we only allow
 411 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
 412 @forall@'d variables.
 413
 414 We used restrict the form of the 'ei' to prevent you writing rules
 415 with LHSs with a complicated desugaring (and hence unlikely to match);
 416 (e.g. a case expression is not allowed: too elaborate.)
 417
 418 But there are legitimate non-trivial args ei, like sections and
 419 lambdas.  So it seems simmpler not to check at all, and that is why
 420 check_e is commented out.
 421
 422 \begin{code}
 423 checkValidRule rule_name ids lhs' fv_lhs'
 424   = do  {       -- Check for the form of the LHS
 425           case (validRuleLhs ids lhs') of
 426                 Nothing  -> return ()
 427                 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
 428
 429                 -- Check that LHS vars are all bound
 430         ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
 431         ; mappM (addErr . badRuleVar rule_name) bad_vars }
 432
 433 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
 434 -- Nothing => OK
 435 -- Just e  => Not ok, and e is the offending expression
 436 validRuleLhs foralls lhs
 437   = checkl lhs
 438   where
 439     checkl (L loc e) = check e
 440
 441     check (OpApp e1 op _ e2)              = checkl op `seqMaybe` checkl_e e1 `seqMaybe` checkl_e e2
 442     check (HsApp e1 e2)                   = checkl e1 `seqMaybe` checkl_e e2
 443     check (HsVar v) | v `notElem` foralls = Nothing
 444     check other                           = Just other  -- Failure
 445
 446         -- Check an argument
 447     checkl_e (L loc e) = Nothing        -- Was (check_e e); see Note [Rule LHS validity checking]
 448
 449 {-      Commented out; see Note [Rule LHS validity checking] above
 450     check_e (HsVar v)     = Nothing
 451     check_e (HsPar e)     = checkl_e e
 452     check_e (HsLit e)     = Nothing
 453     check_e (HsOverLit e) = Nothing
 454
 455     check_e (OpApp e1 op _ e2)   = checkl_e e1 `seqMaybe` checkl_e op `seqMaybe` checkl_e e2
 456     check_e (HsApp e1 e2)        = checkl_e e1 `seqMaybe` checkl_e e2
 457     check_e (NegApp e _)         = checkl_e e
 458     check_e (ExplicitList _ es)  = checkl_es es
 459     check_e (ExplicitTuple es _) = checkl_es es
 460     check_e other                = Just other   -- Fails
 461
 462     checkl_es es = foldr (seqMaybe . checkl_e) Nothing es
 463 -}
 464
 465 badRuleLhsErr name lhs bad_e
 466   = sep [ptext SLIT("Rule") <+> ftext name <> colon,
 467          nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e,
 468                        ptext SLIT("in left-hand side:") <+> ppr lhs])]
 469     $$
 470     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 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 (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
 495   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
 496     returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
 497              emptyFVs)
 498
 499 rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 500                            tcdLName = tycon, tcdTyVars = tyvars,
 501                            tcdTyPats = typatsMaybe, tcdCons = condecls,
 502                            tcdKindSig = sig, tcdDerivs = derivs})
 503   | isKindSigDecl tydecl  -- kind signature of indexed type
 504   = rnTySig tydecl bindTyVarsRn
 505   | is_vanilla            -- Normal Haskell data type decl
 506   = ASSERT( isNothing sig )     -- In normal H98 form, kind signature on the
 507                                 -- data type is syntactically illegal
 508     bindTyVarsRn data_doc tyvars                $ \ tyvars' ->
 509     do  { tycon' <- if isIdxTyDecl tydecl
 510                     then lookupLocatedOccRn     tycon -- may be imported family
 511                     else lookupLocatedTopBndrRn tycon
 512         ; context' <- rnContext data_doc context
 513         ; typats' <- rnTyPats data_doc typatsMaybe
 514         ; (derivs', deriv_fvs) <- rn_derivs derivs
 515         ; checkDupNames data_doc con_names
 516         ; condecls' <- rnConDecls (unLoc tycon') condecls
 517         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context',
 518                            tcdLName = tycon', tcdTyVars = tyvars',
 519                            tcdTyPats = typats', tcdKindSig = Nothing,
 520                            tcdCons = condecls', tcdDerivs = derivs'},
 521                    delFVs (map hsLTyVarName tyvars')    $
 522                    extractHsCtxtTyNames context'        `plusFV`
 523                    plusFVs (map conDeclFVs condecls')   `plusFV`
 524                    deriv_fvs                            `plusFV`
 525                    (if isIdxTyDecl tydecl
 526                    then unitFV (unLoc tycon')   -- type instance => use
 527                    else emptyFVs))
 528         }
 529
 530   | otherwise             -- GADT
 531   = ASSERT( none typatsMaybe )    -- GADTs cannot have type patterns for now
 532     do  { tycon' <- if isIdxTyDecl tydecl
 533                     then lookupLocatedOccRn     tycon -- may be imported family
 534                     else lookupLocatedTopBndrRn tycon
 535         ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
 536         ; tyvars' <- bindTyVarsRn data_doc tyvars
 537                                   (\ tyvars' -> return tyvars')
 538                 -- For GADTs, the type variables in the declaration
 539                 -- do not scope over the constructor signatures
 540                 --      data T a where { T1 :: forall b. b-> b }
 541         ; (derivs', deriv_fvs) <- rn_derivs derivs
 542         ; checkDupNames data_doc con_names
 543         ; condecls' <- rnConDecls (unLoc tycon') condecls
 544         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [],
 545                            tcdLName = tycon', tcdTyVars = tyvars',
 546                            tcdTyPats = Nothing, tcdKindSig = sig,
 547                            tcdCons = condecls', tcdDerivs = derivs'},
 548                    plusFVs (map conDeclFVs condecls') `plusFV`
 549                    deriv_fvs                          `plusFV`
 550                    (if isIdxTyDecl tydecl
 551                    then unitFV (unLoc tycon')   -- type instance => use
 552                    else emptyFVs))
 553         }
 554   where
 555     is_vanilla = case condecls of       -- Yuk
 556                      []                    -> True
 557                      L _ (ConDecl { con_res = ResTyH98 }) : _  -> True
 558                      other                 -> False
 559
 560     none Nothing   = True
 561     none (Just []) = True
 562     none _         = False
 563
 564     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
 565     con_names = map con_names_helper condecls
 566
 567     con_names_helper (L _ c) = con_name c
 568
 569     rn_derivs Nothing   = returnM (Nothing, emptyFVs)
 570     rn_derivs (Just ds) = rnLHsTypes data_doc ds        `thenM` \ ds' ->
 571                           returnM (Just ds', extractHsTyNames_s ds')
 572
 573 rnTyClDecl (tydecl@TyFunction {}) =
 574   rnTySig tydecl bindTyVarsRn
 575
 576 rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
 577                               tcdTyPats = typatsMaybe, tcdSynRhs = ty})
 578   = bindTyVarsRn syn_doc tyvars                 $ \ tyvars' ->
 579     do { name' <- if isIdxTyDecl tydecl
 580                   then lookupLocatedOccRn     name -- may be imported family
 581                   else lookupLocatedTopBndrRn name
 582        ; typats' <- rnTyPats syn_doc typatsMaybe
 583        ; (ty', fvs) <- rnHsTypeFVs syn_doc ty
 584        ; returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars',
 585                              tcdTyPats = typats', tcdSynRhs = ty'},
 586                   delFVs (map hsLTyVarName tyvars') $
 587                   fvs                         `plusFV`
 588                    (if isIdxTyDecl tydecl
 589                    then unitFV (unLoc name')    -- type instance => use
 590                    else emptyFVs))
 591        }
 592   where
 593     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 594
 595 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
 596                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
 597                        tcdMeths = mbinds, tcdATs = ats})
 598   = lookupLocatedTopBndrRn cname                `thenM` \ cname' ->
 599
 600         -- Tyvars scope over superclass context and method signatures
 601     bindTyVarsRn cls_doc tyvars                 ( \ tyvars' ->
 602         rnContext cls_doc context       `thenM` \ context' ->
 603         rnFds cls_doc fds               `thenM` \ fds' ->
 604         rnATs ats                       `thenM` \ (ats', ats_fvs) ->
 605         renameSigs okClsDclSig sigs     `thenM` \ sigs' ->
 606         returnM   (tyvars', context', fds', (ats', ats_fvs), sigs')
 607     )   `thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs') ->
 608
 609         -- Check for duplicates among the associated types
 610     let
 611       at_rdr_names_w_locs      = [tcdLName ty | L _ ty <- ats]
 612     in
 613     checkDupNames at_doc at_rdr_names_w_locs   `thenM_`
 614
 615         -- Check the signatures
 616         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 617     let
 618         sig_rdr_names_w_locs   = [op | L _ (TypeSig op _) <- sigs]
 619     in
 620     checkDupNames sig_doc sig_rdr_names_w_locs  `thenM_`
 621         -- Typechecker is responsible for checking that we only
 622         -- give default-method bindings for things in this class.
 623         -- The renamer *could* check this for class decls, but can't
 624         -- for instance decls.
 625
 626         -- The newLocals call is tiresome: given a generic class decl
 627         --      class C a where
 628         --        op :: a -> a
 629         --        op {| x+y |} (Inl a) = ...
 630         --        op {| x+y |} (Inr b) = ...
 631         --        op {| a*b |} (a*b)   = ...
 632         -- we want to name both "x" tyvars with the same unique, so that they are
 633         -- easy to group together in the typechecker.
 634     extendTyVarEnvForMethodBinds tyvars' (
 635          getLocalRdrEnv                                 `thenM` \ name_env ->
 636          let
 637              meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds
 638              gen_rdr_tyvars_w_locs =
 639                 [ tv | tv <- extractGenericPatTyVars mbinds,
 640                       not (unLoc tv `elemLocalRdrEnv` name_env) ]
 641          in
 642          checkDupNames meth_doc meth_rdr_names_w_locs   `thenM_`
 643          newLocalsRn gen_rdr_tyvars_w_locs      `thenM` \ gen_tyvars ->
 644          rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds
 645     ) `thenM` \ (mbinds', meth_fvs) ->
 646
 647     returnM (ClassDecl { tcdCtxt = context', tcdLName = cname',
 648                          tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
 649                          tcdMeths = mbinds', tcdATs = ats'},
 650              delFVs (map hsLTyVarName tyvars')  $
 651              extractHsCtxtTyNames context'          `plusFV`
 652              plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
 653              hsSigsFVs sigs'                        `plusFV`
 654              meth_fvs                               `plusFV`
 655              ats_fvs)
 656   where
 657     meth_doc = text "In the default-methods for class"  <+> ppr cname
 658     cls_doc  = text "In the declaration for class"      <+> ppr cname
 659     sig_doc  = text "In the signatures for class"       <+> ppr cname
 660     at_doc   = text "In the associated types for class" <+> ppr cname
 661
 662 badGadtStupidTheta tycon
 663   = vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"),
 664           ptext SLIT("(You can put a context on each contructor, though.)")]
 665 \end{code}
 666
 667 %*********************************************************
 668 %*                                                      *
 669 \subsection{Support code for type/data declarations}
 670 %*                                                      *
 671 %*********************************************************
 672
 673 \begin{code}
 674 -- Although, we are processing type patterns here, all type variables will
 675 -- already be in scope (they are the same as in the 'tcdTyVars' field of the
 676 -- type declaration to which these patterns belong)
 677 --
 678 rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name])
 679 rnTyPats _   Nothing       = return Nothing
 680 rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats
 681
 682 rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
 683 rnConDecls tycon condecls
 684   = mappM (wrapLocM rnConDecl) condecls
 685
 686 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
 687 rnConDecl (ConDecl name expl tvs cxt details res_ty)
 688   = do  { addLocM checkConName name
 689
 690         ; new_name <- lookupLocatedTopBndrRn name
 691         ; name_env <- getLocalRdrEnv
 692
 693         -- For H98 syntax, the tvs are the existential ones
 694         -- For GADT syntax, the tvs are all the quantified tyvars
 695         -- Hence the 'filter' in the ResTyH98 case only
 696         ; let not_in_scope  = not . (`elemLocalRdrEnv` name_env) . unLoc
 697               arg_tys       = hsConArgs details
 698               implicit_tvs  = case res_ty of
 699                                 ResTyH98 -> filter not_in_scope $
 700                                                 get_rdr_tvs arg_tys
 701                                 ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
 702               tvs' = case expl of
 703                         Explicit -> tvs
 704                         Implicit -> userHsTyVarBndrs implicit_tvs
 705
 706         ; bindTyVarsRn doc tvs' $ \new_tyvars -> do
 707         { new_context <- rnContext doc cxt
 708         ; new_details <- rnConDetails doc details
 709         ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
 710         ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty) }}
 711   where
 712     doc = text "In the definition of data constructor" <+> quotes (ppr name)
 713     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
 714
 715 rnConResult _ details ResTyH98 = return (details, ResTyH98)
 716
 717 rnConResult doc details (ResTyGADT ty) = do
 718     ty' <- rnHsSigType doc ty
 719     let (arg_tys, res_ty) = splitHsFunType ty'
 720         -- We can split it up, now the renamer has dealt with fixities
 721     case details of
 722         PrefixCon _xs -> ASSERT( null _xs ) return (PrefixCon arg_tys, ResTyGADT res_ty)
 723         RecCon fields -> return (details, ResTyGADT ty')
 724         InfixCon {}   -> panic "rnConResult"
 725
 726 rnConDetails doc (PrefixCon tys)
 727   = mappM (rnLHsType doc) tys   `thenM` \ new_tys  ->
 728     returnM (PrefixCon new_tys)
 729
 730 rnConDetails doc (InfixCon ty1 ty2)
 731   = rnLHsType doc ty1           `thenM` \ new_ty1 ->
 732     rnLHsType doc ty2           `thenM` \ new_ty2 ->
 733     returnM (InfixCon new_ty1 new_ty2)
 734
 735 rnConDetails doc (RecCon fields)
 736   = checkDupNames doc field_names       `thenM_`
 737     mappM (rnField doc) fields          `thenM` \ new_fields ->
 738     returnM (RecCon new_fields)
 739   where
 740     field_names = [fld | (fld, _) <- fields]
 741
 742 rnField doc (name, ty)
 743   = lookupLocatedTopBndrRn name `thenM` \ new_name ->
 744     rnLHsType doc ty            `thenM` \ new_ty ->
 745     returnM (new_name, new_ty)
 746
 747 -- Rename kind signatures (signatures of indexed data types/newtypes and
 748 -- signatures of type functions)
 749 --
 750 -- * This function is parametrised by the routine handling the index
 751 --   variables.  On the toplevel, these are defining occurences, whereas they
 752 --   are usage occurences for associated types.
 753 --
 754 rnTySig :: TyClDecl RdrName
 755         -> (SDoc -> [LHsTyVarBndr RdrName] ->
 756             ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
 757             RnM (TyClDecl Name, FreeVars))
 758         -> RnM (TyClDecl Name, FreeVars)
 759
 760 rnTySig (tydecl@TyData {tcdCtxt = context, tcdLName = tycon,
 761                         tcdTyVars = tyvars, tcdTyPats = mb_typats,
 762                         tcdCons = condecls, tcdKindSig = sig,
 763                         tcdDerivs = derivs})
 764         bindIdxVars =
 765       ASSERT( null condecls )       -- won't have constructors
 766       ASSERT( isNothing mb_typats ) -- won't have type patterns
 767       ASSERT( isNothing derivs )    -- won't have deriving
 768       ASSERT( isJust sig )          -- will have kind signature
 769       do { checkM (not . null $ tyvars) $ addErr needOneIdx   -- #indexes >= 1
 770          ; bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do {
 771          ; tycon' <- lookupLocatedTopBndrRn tycon
 772          ; context' <- rnContext (ksig_doc tycon) context
 773          ; returnM (TyData {tcdND = tcdND tydecl, tcdCtxt = context',
 774                             tcdLName = tycon', tcdTyVars = tyvars',
 775                             tcdTyPats = Nothing, tcdKindSig = sig,
 776                             tcdCons = [], tcdDerivs = Nothing},
 777                     delFVs (map hsLTyVarName tyvars') $
 778                     extractHsCtxtTyNames context')
 779          } }
 780       where
 781
 782 rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars,
 783                             tcdKind = sig})
 784         bindIdxVars =
 785       do { checkM (not . null $ tyvars) $ addErr needOneIdx   -- #indexes >= 1
 786          ; bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do {
 787          ; tycon' <- lookupLocatedTopBndrRn tycon
 788          ; returnM (TyFunction {tcdLName = tycon', tcdTyVars = tyvars',
 789                                 tcdIso = tcdIso tydecl, tcdKind = sig},
 790                     emptyFVs)
 791          } }
 792
 793 ksig_doc tycon = text "In the kind signature for" <+> quotes (ppr tycon)
 794 needOneIdx = text "Kind signature requires at least one type index"
 795
 796 -- Rename associated type declarations (in classes)
 797 --
 798 -- * This can be kind signatures and (default) type function equations.
 799 --
 800 rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 801 rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
 802   where
 803     rn_at (tydecl@TyData     {}) = rnTySig tydecl lookupIdxVars
 804     rn_at (tydecl@TyFunction {}) = rnTySig tydecl lookupIdxVars
 805     rn_at (tydecl@TySynonym  {}) =
 806       do
 807         checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
 808         rnTyClDecl tydecl
 809     rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"
 810
 811     lookupIdxVars _ tyvars cont =
 812       do { checkForDups tyvars;
 813          ; tyvars' <- mappM lookupIdxVar tyvars
 814          ; cont tyvars'
 815          }
 816     -- Type index variables must be class parameters, which are the only
 817     -- type variables in scope at this point.
 818     lookupIdxVar (L l tyvar) =
 819       do
 820         name' <- lookupOccRn (hsTyVarName tyvar)
 821         return $ L l (replaceTyVarName tyvar name')
 822
 823     -- Type variable may only occur once.
 824     --
 825     checkForDups [] = return ()
 826     checkForDups (L loc tv:ltvs) =
 827       do { setSrcSpan loc $
 828              when (hsTyVarName tv `ltvElem` ltvs) $
 829                addErr (repeatedTyVar tv)
 830          ; checkForDups ltvs
 831          }
 832
 833     rdrName `ltvElem` [] = False
 834     rdrName `ltvElem` (L _ tv:ltvs)
 835       | rdrName == hsTyVarName tv = True
 836       | otherwise                 = rdrName `ltvElem` ltvs
 837
 838 noPatterns = text "Default definition for an associated synonym cannot have"
 839              <+> text "type pattern"
 840
 841 repeatedTyVar tv = ptext SLIT("Illegal repeated type variable") <+>
 842                    quotes (ppr tv)
 843
 844 -- This data decl will parse OK
 845 --      data T = a Int
 846 -- treating "a" as the constructor.
 847 -- It is really hard to make the parser spot this malformation.
 848 -- So the renamer has to check that the constructor is legal
 849 --
 850 -- We can get an operator as the constructor, even in the prefix form:
 851 --      data T = :% Int Int
 852 -- from interface files, which always print in prefix form
 853
 854 checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
 855
 856 badDataCon name
 857    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 858 \end{code}
 859
 860
 861 %*********************************************************
 862 %*                                                      *
 863 \subsection{Support code to rename types}
 864 %*                                                      *
 865 %*********************************************************
 866
 867 \begin{code}
 868 rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
 869
 870 rnFds doc fds
 871   = mappM (wrapLocM rn_fds) fds
 872   where
 873     rn_fds (tys1, tys2)
 874       = rnHsTyVars doc tys1             `thenM` \ tys1' ->
 875         rnHsTyVars doc tys2             `thenM` \ tys2' ->
 876         returnM (tys1', tys2')
 877
 878 rnHsTyVars doc tvs  = mappM (rnHsTyvar doc) tvs
 879 rnHsTyvar doc tyvar = lookupOccRn tyvar
 880 \end{code}
 881
 882
 883 %*********************************************************
 884 %*                                                      *
 885                 Splices
 886 %*                                                      *
 887 %*********************************************************
 888
 889 Note [Splices]
 890 ~~~~~~~~~~~~~~
 891 Consider
 892         f = ...
 893         h = ...$(thing "f")...
 894
 895 The splice can expand into literally anything, so when we do dependency
 896 analysis we must assume that it might mention 'f'.  So we simply treat
 897 all locally-defined names as mentioned by any splice.  This is terribly
 898 brutal, but I don't see what else to do.  For example, it'll mean
 899 that every locally-defined thing will appear to be used, so no unused-binding
 900 warnings.  But if we miss the dependency, then we might typecheck 'h' before 'f',
 901 and that will crash the type checker because 'f' isn't in scope.
 902
 903 Currently, I'm not treating a splice as also mentioning every import,
 904 which is a bit inconsistent -- but there are a lot of them.  We might
 905 thereby get some bogus unused-import warnings, but we won't crash the
 906 type checker.  Not very satisfactory really.
 907
 908 \begin{code}
 909 rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
 910 rnSplice (HsSplice n expr)
 911   = do  { checkTH expr "splice"
 912         ; loc  <- getSrcSpanM
 913         ; [n'] <- newLocalsRn [L loc n]
 914         ; (expr', fvs) <- rnLExpr expr
 915
 916         -- Ugh!  See Note [Splices] above
 917         ; lcl_rdr <- getLocalRdrEnv
 918         ; gbl_rdr <- getGlobalRdrEnv
 919         ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr,
 920                                                     isLocalGRE gre]
 921               lcl_names = mkNameSet (occEnvElts lcl_rdr)
 922
 923         ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
 924
 925 #ifdef GHCI
 926 checkTH e what = returnM ()     -- OK
 927 #else
 928 checkTH e what  -- Raise an error in a stage-1 compiler
 929   = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
 930                   ptext SLIT("illegal in a stage-1 compiler"),
 931                   nest 2 (ppr e)])
 932 #endif
 933 \end{code}