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