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 data definitions requires adding the instance
 337 context, as the rhs of an AT declaration may use ATs from classes in the
 338 context.
 339
 340 \begin{code}
 341 rnATDefs :: HsContext RdrName -> [LTyClDecl RdrName]
 342           -> RnM ([LTyClDecl Name], FreeVars)
 343 rnATDefs ctxt atDecls =
 344   mapFvRn (wrapLocFstM addCtxtAndRename) atDecls
 345   where
 346     -- The parser won't accept anything, but a data declaration
 347     addCtxtAndRename ty@TyData {tcdCtxt = L l tyCtxt} =
 348       rnTyClDecl (ty {tcdCtxt = L l (ctxt ++ tyCtxt)})
 349       -- The source loc is somewhat half hearted... -=chak
 350 \end{code}
 351
 352 For the method bindings in class and instance decls, we extend the
 353 type variable environment iff -fglasgow-exts
 354
 355 \begin{code}
 356 extendTyVarEnvForMethodBinds tyvars thing_inside
 357   = doptM Opt_GlasgowExts                       `thenM` \ opt_GlasgowExts ->
 358     if opt_GlasgowExts then
 359         extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
 360     else
 361         thing_inside
 362 \end{code}
 363
 364
 365 %*********************************************************
 366 %*                                                      *
 367 \subsection{Rules}
 368 %*                                                      *
 369 %*********************************************************
 370
 371 \begin{code}
 372 rnHsRuleDecl (HsRule rule_name act vars lhs fv_lhs rhs fv_rhs)
 373   = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)     $
 374
 375     bindLocatedLocalsFV doc (map get_var vars)          $ \ ids ->
 376     mapFvRn rn_var (vars `zip` ids)             `thenM` \ (vars', fv_vars) ->
 377
 378     rnLExpr lhs                                 `thenM` \ (lhs', fv_lhs') ->
 379     rnLExpr rhs                                 `thenM` \ (rhs', fv_rhs') ->
 380
 381     checkValidRule rule_name ids lhs' fv_lhs'   `thenM_`
 382
 383     returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
 384              fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs')
 385   where
 386     doc = text "In the transformation rule" <+> ftext rule_name
 387
 388     get_var (RuleBndr v)      = v
 389     get_var (RuleBndrSig v _) = v
 390
 391     rn_var (RuleBndr (L loc v), id)
 392         = returnM (RuleBndr (L loc id), emptyFVs)
 393     rn_var (RuleBndrSig (L loc v) t, id)
 394         = rnHsTypeFVs doc t     `thenM` \ (t', fvs) ->
 395           returnM (RuleBndrSig (L loc id) t', fvs)
 396
 397 badRuleVar name var
 398   = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
 399          ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+>
 400                 ptext SLIT("does not appear on left hand side")]
 401 \end{code}
 402
 403 Note [Rule LHS validity checking]
 404 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 405 Check the shape of a transformation rule LHS.  Currently we only allow
 406 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
 407 @forall@'d variables.
 408
 409 We used restrict the form of the 'ei' to prevent you writing rules
 410 with LHSs with a complicated desugaring (and hence unlikely to match);
 411 (e.g. a case expression is not allowed: too elaborate.)
 412
 413 But there are legitimate non-trivial args ei, like sections and
 414 lambdas.  So it seems simmpler not to check at all, and that is why
 415 check_e is commented out.
 416
 417 \begin{code}
 418 checkValidRule rule_name ids lhs' fv_lhs'
 419   = do  {       -- Check for the form of the LHS
 420           case (validRuleLhs ids lhs') of
 421                 Nothing  -> return ()
 422                 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
 423
 424                 -- Check that LHS vars are all bound
 425         ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
 426         ; mappM (addErr . badRuleVar rule_name) bad_vars }
 427
 428 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
 429 -- Nothing => OK
 430 -- Just e  => Not ok, and e is the offending expression
 431 validRuleLhs foralls lhs
 432   = checkl lhs
 433   where
 434     checkl (L loc e) = check e
 435
 436     check (OpApp e1 op _ e2)              = checkl op `seqMaybe` checkl_e e1 `seqMaybe` checkl_e e2
 437     check (HsApp e1 e2)                   = checkl e1 `seqMaybe` checkl_e e2
 438     check (HsVar v) | v `notElem` foralls = Nothing
 439     check other                           = Just other  -- Failure
 440
 441         -- Check an argument
 442     checkl_e (L loc e) = Nothing        -- Was (check_e e); see Note [Rule LHS validity checking]
 443
 444 {-      Commented out; see Note [Rule LHS validity checking] above
 445     check_e (HsVar v)     = Nothing
 446     check_e (HsPar e)     = checkl_e e
 447     check_e (HsLit e)     = Nothing
 448     check_e (HsOverLit e) = Nothing
 449
 450     check_e (OpApp e1 op _ e2)   = checkl_e e1 `seqMaybe` checkl_e op `seqMaybe` checkl_e e2
 451     check_e (HsApp e1 e2)        = checkl_e e1 `seqMaybe` checkl_e e2
 452     check_e (NegApp e _)         = checkl_e e
 453     check_e (ExplicitList _ es)  = checkl_es es
 454     check_e (ExplicitTuple es _) = checkl_es es
 455     check_e other                = Just other   -- Fails
 456
 457     checkl_es es = foldr (seqMaybe . checkl_e) Nothing es
 458 -}
 459
 460 badRuleLhsErr name lhs bad_e
 461   = sep [ptext SLIT("Rule") <+> ftext name <> colon,
 462          nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e,
 463                        ptext SLIT("in left-hand side:") <+> ppr lhs])]
 464     $$
 465     ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
 466 \end{code}
 467
 468
 469 %*********************************************************
 470 %*                                                      *
 471 \subsection{Type, class and iface sig declarations}
 472 %*                                                      *
 473 %*********************************************************
 474
 475 @rnTyDecl@ uses the `global name function' to create a new type
 476 declaration in which local names have been replaced by their original
 477 names, reporting any unknown names.
 478
 479 Renaming type variables is a pain. Because they now contain uniques,
 480 it is necessary to pass in an association list which maps a parsed
 481 tyvar to its @Name@ representation.
 482 In some cases (type signatures of values),
 483 it is even necessary to go over the type first
 484 in order to get the set of tyvars used by it, make an assoc list,
 485 and then go over it again to rename the tyvars!
 486 However, we can also do some scoping checks at the same time.
 487
 488 \begin{code}
 489 rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
 490   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
 491     returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
 492              emptyFVs)
 493
 494 rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context,
 495                            tcdLName = tycon, tcdTyVars = tyvars,
 496                            tcdTyPats = typatsMaybe, tcdCons = condecls,
 497                            tcdKindSig = sig, tcdDerivs = derivs})
 498   | isKindSigDecl tydecl  -- kind signature of indexed type
 499   = rnTySig tydecl bindTyVarsRn
 500   | is_vanilla            -- Normal Haskell data type decl
 501   = ASSERT( isNothing sig )     -- In normal H98 form, kind signature on the
 502                                 -- data type is syntactically illegal
 503     bindTyVarsRn data_doc tyvars                $ \ tyvars' ->
 504     do  { tycon' <- lookupLocatedTopBndrRn tycon
 505         ; context' <- rnContext data_doc context
 506         ; typats' <- rnTyPats data_doc typatsMaybe
 507         ; (derivs', deriv_fvs) <- rn_derivs derivs
 508         ; checkDupNames data_doc con_names
 509         ; condecls' <- rnConDecls (unLoc tycon') condecls
 510         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context',
 511                            tcdLName = tycon', tcdTyVars = tyvars',
 512                            tcdTyPats = typats', tcdKindSig = Nothing,
 513                            tcdCons = condecls', tcdDerivs = derivs'},
 514                    delFVs (map hsLTyVarName tyvars')    $
 515                    extractHsCtxtTyNames context'        `plusFV`
 516                    plusFVs (map conDeclFVs condecls')   `plusFV`
 517                    deriv_fvs) }
 518
 519   | otherwise             -- GADT
 520   = ASSERT( none typatsMaybe )    -- GADTs cannot have type patterns for now
 521     do  { tycon' <- lookupLocatedTopBndrRn tycon
 522         ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
 523         ; tyvars' <- bindTyVarsRn data_doc tyvars
 524                                   (\ tyvars' -> return tyvars')
 525                 -- For GADTs, the type variables in the declaration
 526                 -- do not scope over the constructor signatures
 527                 --      data T a where { T1 :: forall b. b-> b }
 528         ; (derivs', deriv_fvs) <- rn_derivs derivs
 529         ; checkDupNames data_doc con_names
 530         ; condecls' <- rnConDecls (unLoc tycon') condecls
 531         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [],
 532                            tcdLName = tycon', tcdTyVars = tyvars',
 533                            tcdTyPats = Nothing, tcdKindSig = sig,
 534                            tcdCons = condecls', tcdDerivs = derivs'},
 535                    plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }
 536
 537   where
 538     is_vanilla = case condecls of       -- Yuk
 539                      []                    -> True
 540                      L _ (ConDecl { con_res = ResTyH98 }) : _  -> True
 541                      other                 -> False
 542
 543     none Nothing   = True
 544     none (Just []) = True
 545     none _         = False
 546
 547     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
 548     con_names = map con_names_helper condecls
 549
 550     con_names_helper (L _ c) = con_name c
 551
 552     rn_derivs Nothing   = returnM (Nothing, emptyFVs)
 553     rn_derivs (Just ds) = rnLHsTypes data_doc ds        `thenM` \ ds' ->
 554                           returnM (Just ds', extractHsTyNames_s ds')
 555
 556 rnTyClDecl (tydecl@TyFunction {}) =
 557   rnTySig tydecl bindTyVarsRn
 558
 559 rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars,
 560                        tcdTyPats = typatsMaybe, tcdSynRhs = ty})
 561   = bindTyVarsRn syn_doc tyvars                 $ \ tyvars' ->
 562     do { name' <- lookupLocatedTopBndrRn name
 563        ; typats' <- rnTyPats syn_doc typatsMaybe
 564        ; (ty', fvs) <- rnHsTypeFVs syn_doc ty
 565        ; returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars',
 566                              tcdTyPats = typats', tcdSynRhs = ty'},
 567                   delFVs (map hsLTyVarName tyvars') fvs) }
 568   where
 569     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 570
 571 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
 572                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
 573                        tcdMeths = mbinds, tcdATs = ats})
 574   = lookupLocatedTopBndrRn cname                `thenM` \ cname' ->
 575
 576         -- Tyvars scope over superclass context and method signatures
 577     bindTyVarsRn cls_doc tyvars                 ( \ tyvars' ->
 578         rnContext cls_doc context       `thenM` \ context' ->
 579         rnFds cls_doc fds               `thenM` \ fds' ->
 580         rnATs ats                       `thenM` \ (ats', ats_fvs) ->
 581         renameSigs okClsDclSig sigs     `thenM` \ sigs' ->
 582         returnM   (tyvars', context', fds', (ats', ats_fvs), sigs')
 583     )   `thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs') ->
 584
 585         -- Check for duplicates among the associated types
 586     let
 587       at_rdr_names_w_locs      = [tcdLName ty | L _ ty <- ats]
 588     in
 589     checkDupNames at_doc at_rdr_names_w_locs   `thenM_`
 590
 591         -- Check the signatures
 592         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 593     let
 594         sig_rdr_names_w_locs   = [op | L _ (TypeSig op _) <- sigs]
 595     in
 596     checkDupNames sig_doc sig_rdr_names_w_locs  `thenM_`
 597         -- Typechecker is responsible for checking that we only
 598         -- give default-method bindings for things in this class.
 599         -- The renamer *could* check this for class decls, but can't
 600         -- for instance decls.
 601
 602         -- The newLocals call is tiresome: given a generic class decl
 603         --      class C a where
 604         --        op :: a -> a
 605         --        op {| x+y |} (Inl a) = ...
 606         --        op {| x+y |} (Inr b) = ...
 607         --        op {| a*b |} (a*b)   = ...
 608         -- we want to name both "x" tyvars with the same unique, so that they are
 609         -- easy to group together in the typechecker.
 610     extendTyVarEnvForMethodBinds tyvars' (
 611          getLocalRdrEnv                                 `thenM` \ name_env ->
 612          let
 613              meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds
 614              gen_rdr_tyvars_w_locs =
 615                 [ tv | tv <- extractGenericPatTyVars mbinds,
 616                       not (unLoc tv `elemLocalRdrEnv` name_env) ]
 617          in
 618          checkDupNames meth_doc meth_rdr_names_w_locs   `thenM_`
 619          newLocalsRn gen_rdr_tyvars_w_locs      `thenM` \ gen_tyvars ->
 620          rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds
 621     ) `thenM` \ (mbinds', meth_fvs) ->
 622
 623     returnM (ClassDecl { tcdCtxt = context', tcdLName = cname',
 624                          tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
 625                          tcdMeths = mbinds', tcdATs = ats'},
 626              delFVs (map hsLTyVarName tyvars')  $
 627              extractHsCtxtTyNames context'          `plusFV`
 628              plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
 629              hsSigsFVs sigs'                        `plusFV`
 630              meth_fvs                               `plusFV`
 631              ats_fvs)
 632   where
 633     meth_doc = text "In the default-methods for class"  <+> ppr cname
 634     cls_doc  = text "In the declaration for class"      <+> ppr cname
 635     sig_doc  = text "In the signatures for class"       <+> ppr cname
 636     at_doc   = text "In the associated types for class" <+> ppr cname
 637
 638 badGadtStupidTheta tycon
 639   = vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"),
 640           ptext SLIT("(You can put a context on each contructor, though.)")]
 641 \end{code}
 642
 643 %*********************************************************
 644 %*                                                      *
 645 \subsection{Support code for type/data declarations}
 646 %*                                                      *
 647 %*********************************************************
 648
 649 \begin{code}
 650 -- Although, we are processing type patterns here, all type variables will
 651 -- already be in scope (they are the same as in the 'tcdTyVars' field of the
 652 -- type declaration to which these patterns belong)
 653 --
 654 rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name])
 655 rnTyPats _   Nothing       = return Nothing
 656 rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats
 657
 658 rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
 659 rnConDecls tycon condecls
 660   = mappM (wrapLocM rnConDecl) condecls
 661
 662 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
 663 rnConDecl (ConDecl name expl tvs cxt details res_ty)
 664   = do  { addLocM checkConName name
 665
 666         ; new_name <- lookupLocatedTopBndrRn name
 667         ; name_env <- getLocalRdrEnv
 668
 669         -- For H98 syntax, the tvs are the existential ones
 670         -- For GADT syntax, the tvs are all the quantified tyvars
 671         -- Hence the 'filter' in the ResTyH98 case only
 672         ; let not_in_scope  = not . (`elemLocalRdrEnv` name_env) . unLoc
 673               arg_tys       = hsConArgs details
 674               implicit_tvs  = case res_ty of
 675                                 ResTyH98 -> filter not_in_scope $
 676                                                 get_rdr_tvs arg_tys
 677                                 ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
 678               tvs' = case expl of
 679                         Explicit -> tvs
 680                         Implicit -> userHsTyVarBndrs implicit_tvs
 681
 682         ; bindTyVarsRn doc tvs' $ \new_tyvars -> do
 683         { new_context <- rnContext doc cxt
 684         ; new_details <- rnConDetails doc details
 685         ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
 686         ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty) }}
 687   where
 688     doc = text "In the definition of data constructor" <+> quotes (ppr name)
 689     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
 690
 691 rnConResult _ details ResTyH98 = return (details, ResTyH98)
 692
 693 rnConResult doc details (ResTyGADT ty) = do
 694     ty' <- rnHsSigType doc ty
 695     let (arg_tys, res_ty) = splitHsFunType ty'
 696         -- We can split it up, now the renamer has dealt with fixities
 697     case details of
 698         PrefixCon _xs -> ASSERT( null _xs ) return (PrefixCon arg_tys, ResTyGADT res_ty)
 699         RecCon fields -> return (details, ResTyGADT ty')
 700         InfixCon {}   -> panic "rnConResult"
 701
 702 rnConDetails doc (PrefixCon tys)
 703   = mappM (rnLHsType doc) tys   `thenM` \ new_tys  ->
 704     returnM (PrefixCon new_tys)
 705
 706 rnConDetails doc (InfixCon ty1 ty2)
 707   = rnLHsType doc ty1           `thenM` \ new_ty1 ->
 708     rnLHsType doc ty2           `thenM` \ new_ty2 ->
 709     returnM (InfixCon new_ty1 new_ty2)
 710
 711 rnConDetails doc (RecCon fields)
 712   = checkDupNames doc field_names       `thenM_`
 713     mappM (rnField doc) fields          `thenM` \ new_fields ->
 714     returnM (RecCon new_fields)
 715   where
 716     field_names = [fld | (fld, _) <- fields]
 717
 718 rnField doc (name, ty)
 719   = lookupLocatedTopBndrRn name `thenM` \ new_name ->
 720     rnLHsType doc ty            `thenM` \ new_ty ->
 721     returnM (new_name, new_ty)
 722
 723 -- Rename kind signatures (signatures of indexed data types/newtypes and
 724 -- signatures of type functions)
 725 --
 726 -- * This function is parametrised by the routine handling the index
 727 --   variables.  On the toplevel, these are defining occurences, whereas they
 728 --   are usage occurences for associated types.
 729 --
 730 rnTySig :: TyClDecl RdrName
 731         -> (SDoc -> [LHsTyVarBndr RdrName] ->
 732             ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
 733             RnM (TyClDecl Name, FreeVars))
 734         -> RnM (TyClDecl Name, FreeVars)
 735
 736 rnTySig (tydecl@TyData {tcdCtxt = context, tcdLName = tycon,
 737                         tcdTyVars = tyvars, tcdTyPats = mb_typats,
 738                         tcdCons = condecls, tcdKindSig = sig,
 739                         tcdDerivs = derivs})
 740         bindIdxVars =
 741       ASSERT( null condecls )       -- won't have constructors
 742       ASSERT( isNothing mb_typats ) -- won't have type patterns
 743       ASSERT( isNothing derivs )    -- won't have deriving
 744       ASSERT( isJust sig )          -- will have kind signature
 745       do { checkM (not . null $ tyvars) $ addErr needOneIdx   -- #indexes >= 1
 746          ; bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do {
 747          ; tycon' <- lookupLocatedTopBndrRn tycon
 748          ; context' <- rnContext (ksig_doc tycon) context
 749          ; returnM (TyData {tcdND = tcdND tydecl, tcdCtxt = context',
 750                             tcdLName = tycon', tcdTyVars = tyvars',
 751                             tcdTyPats = Nothing, tcdKindSig = sig,
 752                             tcdCons = [], tcdDerivs = Nothing},
 753                     delFVs (map hsLTyVarName tyvars') $
 754                     extractHsCtxtTyNames context') } }
 755       where
 756
 757 rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars,
 758                             tcdKind = sig})
 759         bindIdxVars =
 760       do { checkM (not . null $ tyvars) $ addErr needOneIdx   -- #indexes >= 1
 761          ; bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do {
 762          ; tycon' <- lookupLocatedTopBndrRn tycon
 763          ; returnM (TyFunction {tcdLName = tycon', tcdTyVars = tyvars',
 764                                 tcdIso = tcdIso tydecl, tcdKind = sig},
 765                     emptyFVs) } }
 766
 767 ksig_doc tycon = text "In the kind signature for" <+> quotes (ppr tycon)
 768 needOneIdx = text "Kind signature requires at least one type index"
 769
 770 -- Rename associated type declarations (in classes)
 771 --
 772 -- * This can be data declarations, type function signatures, and (default)
 773 --   type function equations.
 774 --
 775 rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 776 rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
 777   where
 778     rn_at (tydecl@TyData     {}) = rnTySig tydecl lookupIdxVars
 779     rn_at (tydecl@TyFunction {}) = rnTySig tydecl lookupIdxVars
 780     rn_at (tydecl@TySynonym  {}) = rnTyClDecl tydecl
 781     rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"
 782
 783     lookupIdxVars _ tyvars cont = mappM lookupIdxVar tyvars >>= cont
 784     --
 785     -- Type index variables must be class parameters, which are the only
 786     -- type variables in scope at this point.
 787     lookupIdxVar (L l tyvar) =
 788       do
 789         name' <- lookupOccRn (hsTyVarName tyvar)
 790         return $ L l (replaceTyVarName tyvar name')
 791
 792 -- This data decl will parse OK
 793 --      data T = a Int
 794 -- treating "a" as the constructor.
 795 -- It is really hard to make the parser spot this malformation.
 796 -- So the renamer has to check that the constructor is legal
 797 --
 798 -- We can get an operator as the constructor, even in the prefix form:
 799 --      data T = :% Int Int
 800 -- from interface files, which always print in prefix form
 801
 802 checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
 803
 804 badDataCon name
 805    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 806 \end{code}
 807
 808
 809 %*********************************************************
 810 %*                                                      *
 811 \subsection{Support code to rename types}
 812 %*                                                      *
 813 %*********************************************************
 814
 815 \begin{code}
 816 rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
 817
 818 rnFds doc fds
 819   = mappM (wrapLocM rn_fds) fds
 820   where
 821     rn_fds (tys1, tys2)
 822       = rnHsTyVars doc tys1             `thenM` \ tys1' ->
 823         rnHsTyVars doc tys2             `thenM` \ tys2' ->
 824         returnM (tys1', tys2')
 825
 826 rnHsTyVars doc tvs  = mappM (rnHsTyvar doc) tvs
 827 rnHsTyvar doc tyvar = lookupOccRn tyvar
 828 \end{code}
 829
 830
 831 %*********************************************************
 832 %*                                                      *
 833                 Splices
 834 %*                                                      *
 835 %*********************************************************
 836
 837 Note [Splices]
 838 ~~~~~~~~~~~~~~
 839 Consider
 840         f = ...
 841         h = ...$(thing "f")...
 842
 843 The splice can expand into literally anything, so when we do dependency
 844 analysis we must assume that it might mention 'f'.  So we simply treat
 845 all locally-defined names as mentioned by any splice.  This is terribly
 846 brutal, but I don't see what else to do.  For example, it'll mean
 847 that every locally-defined thing will appear to be used, so no unused-binding
 848 warnings.  But if we miss the dependency, then we might typecheck 'h' before 'f',
 849 and that will crash the type checker because 'f' isn't in scope.
 850
 851 Currently, I'm not treating a splice as also mentioning every import,
 852 which is a bit inconsistent -- but there are a lot of them.  We might
 853 thereby get some bogus unused-import warnings, but we won't crash the
 854 type checker.  Not very satisfactory really.
 855
 856 \begin{code}
 857 rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
 858 rnSplice (HsSplice n expr)
 859   = do  { checkTH expr "splice"
 860         ; loc  <- getSrcSpanM
 861         ; [n'] <- newLocalsRn [L loc n]
 862         ; (expr', fvs) <- rnLExpr expr
 863
 864         -- Ugh!  See Note [Splices] above
 865         ; lcl_rdr <- getLocalRdrEnv
 866         ; gbl_rdr <- getGlobalRdrEnv
 867         ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr,
 868                                                     isLocalGRE gre]
 869               lcl_names = mkNameSet (occEnvElts lcl_rdr)
 870
 871         ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
 872
 873 #ifdef GHCI
 874 checkTH e what = returnM ()     -- OK
 875 #else
 876 checkTH e what  -- Raise an error in a stage-1 compiler
 877   = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
 878                   ptext SLIT("illegal in a stage-1 compiler"),
 879                   nest 2 (ppr e)])
 880 #endif
 881 \end{code}