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, elemLocalRdrEnv, globalRdrEnvElts,
  19                           GlobalRdrElt(..), isLocalGRE )
  20 import RdrHsSyn         ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
  21 import RnHsSyn
  22 import RnTypes          ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext )
  23 import RnBinds          ( rnTopBinds, rnMethodBinds, renameSigs )
  24 import RnEnv            ( lookupLocalDataTcNames,
  25                           lookupLocatedTopBndrRn, lookupLocatedOccRn,
  26                           lookupOccRn, newLocalsRn,
  27                           bindLocatedLocalsFV, bindPatSigTyVarsFV,
  28                           bindTyVarsRn, extendTyVarEnvFVRn,
  29                           bindLocalNames, checkDupNames, mapFvRn
  30                         )
  31 import TcRnMonad
  32
  33 import HscTypes         ( FixityEnv, FixItem(..),
  34                           Deprecations, Deprecs(..), DeprecTxt, plusDeprecs )
  35 import Class            ( FunDep )
  36 import Name             ( Name, nameOccName )
  37 import NameSet
  38 import NameEnv
  39 import OccName          ( occEnvElts )
  40 import Outputable
  41 import SrcLoc           ( Located(..), unLoc, getLoc, noLoc )
  42 import DynFlags ( DynFlag(..) )
  43 import Maybes           ( seqMaybe )
  44 import Maybe            ( isNothing )
  45 import BasicTypes       ( Boxity(..) )
  46 \end{code}
  47
  48 @rnSourceDecl@ `renames' declarations.
  49 It simultaneously performs dependency analysis and precedence parsing.
  50 It also does the following error checks:
  51 \begin{enumerate}
  52 \item
  53 Checks that tyvars are used properly. This includes checking
  54 for undefined tyvars, and tyvars in contexts that are ambiguous.
  55 (Some of this checking has now been moved to module @TcMonoType@,
  56 since we don't have functional dependency information at this point.)
  57 \item
  58 Checks that all variable occurences are defined.
  59 \item
  60 Checks the @(..)@ etc constraints in the export list.
  61 \end{enumerate}
  62
  63
  64 \begin{code}
  65 rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
  66
  67 rnSrcDecls (HsGroup { hs_valds  = val_decls,
  68                       hs_tyclds = tycl_decls,
  69                       hs_instds = inst_decls,
  70                       hs_fixds  = fix_decls,
  71                       hs_depds  = deprec_decls,
  72                       hs_fords  = foreign_decls,
  73                       hs_defds  = default_decls,
  74                       hs_ruleds = rule_decls })
  75
  76  = do {         -- Deal with deprecations (returns only the extra deprecations)
  77         deprecs <- rnSrcDeprecDecls deprec_decls ;
  78         updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs })
  79                   $ do {
  80
  81                 -- Deal with top-level fixity decls
  82                 -- (returns the total new fixity env)
  83         rn_fix_decls <- rnSrcFixityDecls fix_decls ;
  84         fix_env <- rnSrcFixityDeclsEnv rn_fix_decls ;
  85         updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
  86                   $ do {
  87
  88                 -- Rename other declarations
  89         traceRn (text "Start rnmono") ;
  90         (rn_val_decls, bind_dus) <- rnTopBinds val_decls ;
  91         traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
  92
  93                 -- You might think that we could build proper def/use information
  94                 -- for type and class declarations, but they can be involved
  95                 -- in mutual recursion across modules, and we only do the SCC
  96                 -- analysis for them in the type checker.
  97                 -- So we content ourselves with gathering uses only; that
  98                 -- means we'll only report a declaration as unused if it isn't
  99                 -- mentioned at all.  Ah well.
 100         (rn_tycl_decls,    src_fvs1)
 101            <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ;
 102         (rn_inst_decls,    src_fvs2)
 103            <- mapFvRn (wrapLocFstM rnSrcInstDecl) inst_decls ;
 104         (rn_rule_decls,    src_fvs3)
 105            <- mapFvRn (wrapLocFstM rnHsRuleDecl) rule_decls ;
 106         (rn_foreign_decls, src_fvs4)
 107            <- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ;
 108         (rn_default_decls, src_fvs5)
 109            <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
 110
 111         let {
 112            rn_group = HsGroup { hs_valds  = rn_val_decls,
 113                                 hs_tyclds = rn_tycl_decls,
 114                                 hs_instds = rn_inst_decls,
 115                                 hs_fixds  = rn_fix_decls,
 116                                 hs_depds  = [],
 117                                 hs_fords  = rn_foreign_decls,
 118                                 hs_defds  = rn_default_decls,
 119                                 hs_ruleds = rn_rule_decls } ;
 120
 121            other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3,
 122                                 src_fvs4, src_fvs5] ;
 123            src_dus = bind_dus `plusDU` usesOnly other_fvs
 124                 -- Note: src_dus will contain *uses* for locally-defined types
 125                 -- and classes, but no *defs* for them.  (Because rnTyClDecl
 126                 -- returns only the uses.)  This is a little
 127                 -- surprising but it doesn't actually matter at all.
 128         } ;
 129
 130         traceRn (text "finish rnSrc" <+> ppr rn_group) ;
 131         traceRn (text "finish Dus" <+> ppr src_dus ) ;
 132         tcg_env <- getGblEnv ;
 133         return (tcg_env `addTcgDUs` src_dus, rn_group)
 134     }}}
 135
 136 rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
 137 rnTyClDecls tycl_decls = do
 138   (decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls
 139   return decls'
 140
 141 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
 142 addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
 143 \end{code}
 144
 145
 146 %*********************************************************
 147 %*                                                       *
 148         Source-code fixity declarations
 149 %*                                                       *
 150 %*********************************************************
 151
 152 \begin{code}
 153 rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM [LFixitySig Name]
 154 rnSrcFixityDecls fix_decls
 155     = do fix_decls <- mapM rnFixityDecl fix_decls
 156          return (concat fix_decls)
 157
 158 rnFixityDecl :: LFixitySig RdrName -> RnM [LFixitySig Name]
 159 rnFixityDecl (L loc (FixitySig (L nameLoc rdr_name) fixity))
 160     = setSrcSpan nameLoc $
 161         -- GHC extension: look up both the tycon and data con
 162         -- for con-like things
 163         -- If neither are in scope, report an error; otherwise
 164         -- add both to the fixity env
 165       do names <- lookupLocalDataTcNames rdr_name
 166          return [ L loc (FixitySig (L nameLoc name) fixity)
 167                       | name <- names ]
 168
 169 rnSrcFixityDeclsEnv :: [LFixitySig Name] -> RnM FixityEnv
 170 rnSrcFixityDeclsEnv fix_decls
 171   = getGblEnv                                   `thenM` \ gbl_env ->
 172     foldlM rnFixityDeclEnv (tcg_fix_env gbl_env)
 173             fix_decls                                   `thenM` \ fix_env ->
 174     traceRn (text "fixity env" <+> pprFixEnv fix_env)   `thenM_`
 175     returnM fix_env
 176
 177 rnFixityDeclEnv :: FixityEnv -> LFixitySig Name -> RnM FixityEnv
 178 rnFixityDeclEnv fix_env (L loc (FixitySig (L nameLoc name) fixity))
 179   = case lookupNameEnv fix_env name of
 180       Just (FixItem _ _ loc')
 181           -> do addLocErr (L nameLoc name) (dupFixityDecl loc')
 182                 return fix_env
 183       Nothing
 184           -> return (extendNameEnv fix_env name fix_item)
 185     where fix_item = FixItem (nameOccName name) fixity nameLoc
 186
 187 pprFixEnv :: FixityEnv -> SDoc
 188 pprFixEnv env
 189   = pprWithCommas (\ (FixItem n f _) -> ppr f <+> ppr n)
 190                   (nameEnvElts env)
 191
 192 dupFixityDecl loc rdr_name
 193   = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
 194           ptext SLIT("also at ") <+> ppr loc
 195         ]
 196 \end{code}
 197
 198
 199 %*********************************************************
 200 %*                                                       *
 201         Source-code deprecations declarations
 202 %*                                                       *
 203 %*********************************************************
 204
 205 For deprecations, all we do is check that the names are in scope.
 206 It's only imported deprecations, dealt with in RnIfaces, that we
 207 gather them together.
 208
 209 \begin{code}
 210 rnSrcDeprecDecls :: [LDeprecDecl RdrName] -> RnM Deprecations
 211 rnSrcDeprecDecls []
 212   = returnM NoDeprecs
 213
 214 rnSrcDeprecDecls decls
 215   = mappM (addLocM rn_deprec) decls     `thenM` \ pairs_s ->
 216     returnM (DeprecSome (mkNameEnv (concat pairs_s)))
 217  where
 218    rn_deprec (Deprecation rdr_name txt)
 219      = lookupLocalDataTcNames rdr_name  `thenM` \ names ->
 220        returnM [(name, (nameOccName name, txt)) | name <- names]
 221
 222 checkModDeprec :: Maybe DeprecTxt -> Deprecations
 223 -- Check for a module deprecation; done once at top level
 224 checkModDeprec Nothing    = NoDeprecs
 225 checkModDeprec (Just txt) = DeprecAll txt
 226 \end{code}
 227
 228 %*********************************************************
 229 %*                                                      *
 230 \subsection{Source code declarations}
 231 %*                                                      *
 232 %*********************************************************
 233
 234 \begin{code}
 235 rnDefaultDecl (DefaultDecl tys)
 236   = mapFvRn (rnHsTypeFVs doc_str) tys   `thenM` \ (tys', fvs) ->
 237     returnM (DefaultDecl tys', fvs)
 238   where
 239     doc_str = text "In a `default' declaration"
 240 \end{code}
 241
 242 %*********************************************************
 243 %*                                                      *
 244 \subsection{Foreign declarations}
 245 %*                                                      *
 246 %*********************************************************
 247
 248 \begin{code}
 249 rnHsForeignDecl (ForeignImport name ty spec isDeprec)
 250   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
 251     rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
 252     returnM (ForeignImport name' ty' spec isDeprec, fvs)
 253
 254 rnHsForeignDecl (ForeignExport name ty spec isDeprec)
 255   = lookupLocatedOccRn name             `thenM` \ name' ->
 256     rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
 257     returnM (ForeignExport name' ty' spec isDeprec, fvs )
 258         -- NB: a foreign export is an *occurrence site* for name, so
 259         --     we add it to the free-variable list.  It might, for example,
 260         --     be imported from another module
 261
 262 fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
 263 \end{code}
 264
 265
 266 %*********************************************************
 267 %*                                                      *
 268 \subsection{Instance declarations}
 269 %*                                                      *
 270 %*********************************************************
 271
 272 \begin{code}
 273 rnSrcInstDecl (InstDecl inst_ty mbinds uprags)
 274         -- Used for both source and interface file decls
 275   = rnHsSigType (text "an instance decl") inst_ty       `thenM` \ inst_ty' ->
 276
 277         -- Rename the bindings
 278         -- The typechecker (not the renamer) checks that all
 279         -- the bindings are for the right class
 280     let
 281         meth_doc    = text "In the bindings in an instance declaration"
 282         meth_names  = collectHsBindLocatedBinders mbinds
 283         (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
 284     in
 285     checkDupNames meth_doc meth_names   `thenM_`
 286     extendTyVarEnvForMethodBinds inst_tyvars (
 287         -- (Slightly strangely) the forall-d tyvars scope over
 288         -- the method bindings too
 289         rnMethodBinds cls [] mbinds
 290     )                                           `thenM` \ (mbinds', meth_fvs) ->
 291         -- Rename the prags and signatures.
 292         -- Note that the type variables are not in scope here,
 293         -- so that      instance Eq a => Eq (T a) where
 294         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
 295         -- works OK.
 296         --
 297         -- But the (unqualified) method names are in scope
 298     let
 299         binders = collectHsBindBinders mbinds'
 300         ok_sig  = okInstDclSig (mkNameSet binders)
 301     in
 302     bindLocalNames binders (renameSigs ok_sig uprags)   `thenM` \ uprags' ->
 303
 304     returnM (InstDecl inst_ty' mbinds' uprags',
 305              meth_fvs `plusFV` hsSigsFVs uprags'
 306                       `plusFV` extractHsTyNames inst_ty')
 307 \end{code}
 308
 309 For the method bindings in class and instance decls, we extend the
 310 type variable environment iff -fglasgow-exts
 311
 312 \begin{code}
 313 extendTyVarEnvForMethodBinds tyvars thing_inside
 314   = doptM Opt_GlasgowExts                       `thenM` \ opt_GlasgowExts ->
 315     if opt_GlasgowExts then
 316         extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
 317     else
 318         thing_inside
 319 \end{code}
 320
 321
 322 %*********************************************************
 323 %*                                                      *
 324 \subsection{Rules}
 325 %*                                                      *
 326 %*********************************************************
 327
 328 \begin{code}
 329 rnHsRuleDecl (HsRule rule_name act vars lhs fv_lhs rhs fv_rhs)
 330   = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)     $
 331
 332     bindLocatedLocalsFV doc (map get_var vars)          $ \ ids ->
 333     mapFvRn rn_var (vars `zip` ids)             `thenM` \ (vars', fv_vars) ->
 334
 335     rnLExpr lhs                                 `thenM` \ (lhs', fv_lhs') ->
 336     rnLExpr rhs                                 `thenM` \ (rhs', fv_rhs') ->
 337     let
 338         mb_bad = validRuleLhs ids lhs'
 339     in
 340     checkErr (isNothing mb_bad)
 341              (badRuleLhsErr rule_name lhs' mb_bad)      `thenM_`
 342     let
 343         bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
 344     in
 345     mappM (addErr . badRuleVar rule_name) bad_vars      `thenM_`
 346     returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
 347              fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs')
 348   where
 349     doc = text "In the transformation rule" <+> ftext rule_name
 350
 351     get_var (RuleBndr v)      = v
 352     get_var (RuleBndrSig v _) = v
 353
 354     rn_var (RuleBndr (L loc v), id)
 355         = returnM (RuleBndr (L loc id), emptyFVs)
 356     rn_var (RuleBndrSig (L loc v) t, id)
 357         = rnHsTypeFVs doc t     `thenM` \ (t', fvs) ->
 358           returnM (RuleBndrSig (L loc id) t', fvs)
 359 \end{code}
 360
 361 Check the shape of a transformation rule LHS.  Currently
 362 we only allow LHSs of the form @(f e1 .. en)@, where @f@ is
 363 not one of the @forall@'d variables.  We also restrict the form of the LHS so
 364 that it may be plausibly matched.  Basically you only get to write ordinary
 365 applications.  (E.g. a case expression is not allowed: too elaborate.)
 366
 367 NB: if you add new cases here, make sure you add new ones to TcRule.ruleLhsTvs
 368
 369 \begin{code}
 370 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
 371 -- Nothing => OK
 372 -- Just e  => Not ok, and e is the offending expression
 373 validRuleLhs foralls lhs
 374   = checkl lhs
 375   where
 376     checkl (L loc e) = check e
 377
 378     check (OpApp e1 op _ e2)              = checkl op `seqMaybe` checkl_e e1 `seqMaybe` checkl_e e2
 379     check (HsApp e1 e2)                   = checkl e1 `seqMaybe` checkl_e e2
 380     check (HsVar v) | v `notElem` foralls = Nothing
 381     check other                           = Just other  -- Failure
 382
 383     checkl_e (L loc e) = check_e e
 384
 385     check_e (HsVar v)     = Nothing
 386     check_e (HsPar e)     = checkl_e e
 387     check_e (HsLit e)     = Nothing
 388     check_e (HsOverLit e) = Nothing
 389
 390     check_e (OpApp e1 op _ e2)   = checkl_e e1 `seqMaybe` checkl_e op `seqMaybe` checkl_e e2
 391     check_e (HsApp e1 e2)        = checkl_e e1 `seqMaybe` checkl_e e2
 392     check_e (NegApp e _)         = checkl_e e
 393     check_e (ExplicitList _ es)  = checkl_es es
 394     check_e (ExplicitTuple es _) = checkl_es es
 395     check_e other                = Just other   -- Fails
 396
 397     checkl_es es = foldr (seqMaybe . checkl_e) Nothing es
 398
 399 badRuleLhsErr name lhs (Just bad_e)
 400   = sep [ptext SLIT("Rule") <+> ftext name <> colon,
 401          nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e,
 402                        ptext SLIT("in left-hand side:") <+> ppr lhs])]
 403     $$
 404     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 405
 406 badRuleVar name var
 407   = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
 408          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 409                 ptext SLIT("does not appear on left hand side")]
 410 \end{code}
 411
 412
 413 %*********************************************************
 414 %*                                                      *
 415 \subsection{Type, class and iface sig declarations}
 416 %*                                                      *
 417 %*********************************************************
 418
 419 @rnTyDecl@ uses the `global name function' to create a new type
 420 declaration in which local names have been replaced by their original
 421 names, reporting any unknown names.
 422
 423 Renaming type variables is a pain. Because they now contain uniques,
 424 it is necessary to pass in an association list which maps a parsed
 425 tyvar to its @Name@ representation.
 426 In some cases (type signatures of values),
 427 it is even necessary to go over the type first
 428 in order to get the set of tyvars used by it, make an assoc list,
 429 and then go over it again to rename the tyvars!
 430 However, we can also do some scoping checks at the same time.
 431
 432 \begin{code}
 433 rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
 434   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
 435     returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
 436              emptyFVs)
 437
 438 rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
 439                     tcdTyVars = tyvars, tcdCons = condecls,
 440                     tcdKindSig = sig, tcdDerivs = derivs})
 441   | is_vanilla  -- Normal Haskell data type decl
 442   = ASSERT( isNothing sig )     -- In normal H98 form, kind signature on the
 443                                 -- data type is syntactically illegal
 444     bindTyVarsRn data_doc tyvars                $ \ tyvars' ->
 445     do  { tycon' <- lookupLocatedTopBndrRn tycon
 446         ; context' <- rnContext data_doc context
 447         ; (derivs', deriv_fvs) <- rn_derivs derivs
 448         ; checkDupNames data_doc con_names
 449         ; condecls' <- rnConDecls (unLoc tycon') condecls
 450         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon',
 451                            tcdTyVars = tyvars', tcdKindSig = Nothing, tcdCons = condecls',
 452                            tcdDerivs = derivs'},
 453                    delFVs (map hsLTyVarName tyvars')    $
 454                    extractHsCtxtTyNames context'        `plusFV`
 455                    plusFVs (map conDeclFVs condecls') `plusFV`
 456                    deriv_fvs) }
 457
 458   | otherwise   -- GADT
 459   = do  { tycon' <- lookupLocatedTopBndrRn tycon
 460         ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
 461         ; tyvars' <- bindTyVarsRn data_doc tyvars
 462                                   (\ tyvars' -> return tyvars')
 463                 -- For GADTs, the type variables in the declaration
 464                 -- do not scope over the constructor signatures
 465                 --      data T a where { T1 :: forall b. b-> b }
 466         ; (derivs', deriv_fvs) <- rn_derivs derivs
 467         ; checkDupNames data_doc con_names
 468         ; condecls' <- rnConDecls (unLoc tycon') condecls
 469         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], tcdLName = tycon',
 470                            tcdTyVars = tyvars', tcdCons = condecls', tcdKindSig = sig,
 471                            tcdDerivs = derivs'},
 472                    plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }
 473
 474   where
 475     is_vanilla = case condecls of       -- Yuk
 476                      []                    -> True
 477                      L _ (ConDecl { con_res = ResTyH98 }) : _  -> True
 478                      other                 -> False
 479
 480     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
 481     con_names = map con_names_helper condecls
 482
 483     con_names_helper (L _ c) = con_name c
 484
 485     rn_derivs Nothing   = returnM (Nothing, emptyFVs)
 486     rn_derivs (Just ds) = rnLHsTypes data_doc ds        `thenM` \ ds' ->
 487                           returnM (Just ds', extractHsTyNames_s ds')
 488
 489 rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty})
 490   = lookupLocatedTopBndrRn name                 `thenM` \ name' ->
 491     bindTyVarsRn syn_doc tyvars                 $ \ tyvars' ->
 492     rnHsTypeFVs syn_doc ty                      `thenM` \ (ty', fvs) ->
 493     returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars',
 494                         tcdSynRhs = ty'},
 495              delFVs (map hsLTyVarName tyvars') fvs)
 496   where
 497     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 498
 499 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
 500                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
 501                        tcdMeths = mbinds})
 502   = lookupLocatedTopBndrRn cname                `thenM` \ cname' ->
 503
 504         -- Tyvars scope over superclass context and method signatures
 505     bindTyVarsRn cls_doc tyvars                 ( \ tyvars' ->
 506         rnContext cls_doc context       `thenM` \ context' ->
 507         rnFds cls_doc fds               `thenM` \ fds' ->
 508         renameSigs okClsDclSig sigs     `thenM` \ sigs' ->
 509         returnM   (tyvars', context', fds', sigs')
 510     )   `thenM` \ (tyvars', context', fds', sigs') ->
 511
 512         -- Check the signatures
 513         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 514     let
 515         sig_rdr_names_w_locs   = [op | L _ (TypeSig op _) <- sigs]
 516     in
 517     checkDupNames sig_doc sig_rdr_names_w_locs  `thenM_`
 518         -- Typechecker is responsible for checking that we only
 519         -- give default-method bindings for things in this class.
 520         -- The renamer *could* check this for class decls, but can't
 521         -- for instance decls.
 522
 523         -- The newLocals call is tiresome: given a generic class decl
 524         --      class C a where
 525         --        op :: a -> a
 526         --        op {| x+y |} (Inl a) = ...
 527         --        op {| x+y |} (Inr b) = ...
 528         --        op {| a*b |} (a*b)   = ...
 529         -- we want to name both "x" tyvars with the same unique, so that they are
 530         -- easy to group together in the typechecker.
 531     extendTyVarEnvForMethodBinds tyvars' (
 532          getLocalRdrEnv                                 `thenM` \ name_env ->
 533          let
 534              meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds
 535              gen_rdr_tyvars_w_locs =
 536                 [ tv | tv <- extractGenericPatTyVars mbinds,
 537                       not (unLoc tv `elemLocalRdrEnv` name_env) ]
 538          in
 539          checkDupNames meth_doc meth_rdr_names_w_locs   `thenM_`
 540          newLocalsRn gen_rdr_tyvars_w_locs      `thenM` \ gen_tyvars ->
 541          rnMethodBinds (unLoc cname') gen_tyvars mbinds
 542     ) `thenM` \ (mbinds', meth_fvs) ->
 543
 544     returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars',
 545                          tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds'},
 546              delFVs (map hsLTyVarName tyvars')  $
 547              extractHsCtxtTyNames context'          `plusFV`
 548              plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
 549              hsSigsFVs sigs'                        `plusFV`
 550              meth_fvs)
 551   where
 552     meth_doc = text "In the default-methods for class"  <+> ppr cname
 553     cls_doc  = text "In the declaration for class"      <+> ppr cname
 554     sig_doc  = text "In the signatures for class"       <+> ppr cname
 555
 556 badGadtStupidTheta tycon
 557   = vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"),
 558           ptext SLIT("(You can put a context on each contructor, though.)")]
 559 \end{code}
 560
 561 %*********************************************************
 562 %*                                                      *
 563 \subsection{Support code for type/data declarations}
 564 %*                                                      *
 565 %*********************************************************
 566
 567 \begin{code}
 568 rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
 569 rnConDecls tycon condecls
 570   = mappM (wrapLocM rnConDecl) condecls
 571
 572 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
 573 rnConDecl (ConDecl name expl tvs cxt details res_ty)
 574   = do  { addLocM checkConName name
 575
 576         ; new_name <- lookupLocatedTopBndrRn name
 577         ; name_env <- getLocalRdrEnv
 578
 579         -- For H98 syntax, the tvs are the existential ones
 580         -- For GADT syntax, the tvs are all the quantified tyvars
 581         -- Hence the 'filter' in the ResTyH98 case only
 582         ; let not_in_scope  = not . (`elemLocalRdrEnv` name_env) . unLoc
 583               arg_tys       = hsConArgs details
 584               implicit_tvs  = case res_ty of
 585                                 ResTyH98 -> filter not_in_scope $
 586                                                 get_rdr_tvs arg_tys
 587                                 ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
 588               tvs' = case expl of
 589                         Explicit -> tvs
 590                         Implicit -> userHsTyVarBndrs implicit_tvs
 591
 592         ; bindTyVarsRn doc tvs' $ \new_tyvars -> do
 593         { new_context <- rnContext doc cxt
 594         ; new_details <- rnConDetails doc details
 595         ; new_res_ty  <- rnConResult doc res_ty
 596         ; let rv = ConDecl new_name expl new_tyvars new_context new_details new_res_ty
 597         ; traceRn (text "****** - autrijus" <> ppr rv)
 598         ; return rv } }
 599   where
 600     doc = text "In the definition of data constructor" <+> quotes (ppr name)
 601     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
 602
 603 rnConResult _ ResTyH98 = return ResTyH98
 604 rnConResult doc (ResTyGADT ty) = do
 605     ty' <- rnHsSigType doc ty
 606     return $ ResTyGADT ty'
 607
 608 rnConDetails doc (PrefixCon tys)
 609   = mappM (rnLHsType doc) tys   `thenM` \ new_tys  ->
 610     returnM (PrefixCon new_tys)
 611
 612 rnConDetails doc (InfixCon ty1 ty2)
 613   = rnLHsType doc ty1           `thenM` \ new_ty1 ->
 614     rnLHsType doc ty2           `thenM` \ new_ty2 ->
 615     returnM (InfixCon new_ty1 new_ty2)
 616
 617 rnConDetails doc (RecCon fields)
 618   = checkDupNames doc field_names       `thenM_`
 619     mappM (rnField doc) fields          `thenM` \ new_fields ->
 620     returnM (RecCon new_fields)
 621   where
 622     field_names = [fld | (fld, _) <- fields]
 623
 624 rnField doc (name, ty)
 625   = lookupLocatedTopBndrRn name `thenM` \ new_name ->
 626     rnLHsType doc ty            `thenM` \ new_ty ->
 627     returnM (new_name, new_ty)
 628
 629 -- This data decl will parse OK
 630 --      data T = a Int
 631 -- treating "a" as the constructor.
 632 -- It is really hard to make the parser spot this malformation.
 633 -- So the renamer has to check that the constructor is legal
 634 --
 635 -- We can get an operator as the constructor, even in the prefix form:
 636 --      data T = :% Int Int
 637 -- from interface files, which always print in prefix form
 638
 639 checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
 640
 641 badDataCon name
 642    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 643 \end{code}
 644
 645
 646 %*********************************************************
 647 %*                                                      *
 648 \subsection{Support code to rename types}
 649 %*                                                      *
 650 %*********************************************************
 651
 652 \begin{code}
 653 rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
 654
 655 rnFds doc fds
 656   = mappM (wrapLocM rn_fds) fds
 657   where
 658     rn_fds (tys1, tys2)
 659       = rnHsTyVars doc tys1             `thenM` \ tys1' ->
 660         rnHsTyVars doc tys2             `thenM` \ tys2' ->
 661         returnM (tys1', tys2')
 662
 663 rnHsTyVars doc tvs  = mappM (rnHsTyvar doc) tvs
 664 rnHsTyvar doc tyvar = lookupOccRn tyvar
 665 \end{code}
 666
 667
 668 %*********************************************************
 669 %*                                                      *
 670                 Splices
 671 %*                                                      *
 672 %*********************************************************
 673
 674 Note [Splices]
 675 ~~~~~~~~~~~~~~
 676 Consider
 677         f = ...
 678         h = ...$(thing "f")...
 679
 680 The splice can expand into literally anything, so when we do dependency
 681 analysis we must assume that it might mention 'f'.  So we simply treat
 682 all locally-defined names as mentioned by any splice.  This is terribly
 683 brutal, but I don't see what else to do.  For example, it'll mean
 684 that every locally-defined thing will appear to be used, so no unused-binding
 685 warnings.  But if we miss the dependency, then we might typecheck 'h' before 'f',
 686 and that will crash the type checker because 'f' isn't in scope.
 687
 688 Currently, I'm not treating a splice as also mentioning every import,
 689 which is a bit inconsistent -- but there are a lot of them.  We might
 690 thereby get some bogus unused-import warnings, but we won't crash the
 691 type checker.  Not very satisfactory really.
 692
 693 \begin{code}
 694 rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
 695 rnSplice (HsSplice n expr)
 696   = do  { checkTH expr "splice"
 697         ; loc  <- getSrcSpanM
 698         ; [n'] <- newLocalsRn [L loc n]
 699         ; (expr', fvs) <- rnLExpr expr
 700
 701         -- Ugh!  See Note [Splices] above
 702         ; lcl_rdr <- getLocalRdrEnv
 703         ; gbl_rdr <- getGlobalRdrEnv
 704         ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr,
 705                                                     isLocalGRE gre]
 706               lcl_names = mkNameSet (occEnvElts lcl_rdr)
 707
 708         ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
 709
 710 #ifdef GHCI
 711 checkTH e what = returnM ()     -- OK
 712 #else
 713 checkTH e what  -- Raise an error in a stage-1 compiler
 714   = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
 715                   ptext SLIT("illegal in a stage-1 compiler"),
 716                   nest 2 (ppr e)])
 717 #endif
 718 \end{code}