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 (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon,
 495                     tcdTyVars = tyvars, tcdTyPats = typatsMaybe,
 496                     tcdCons = condecls, tcdKindSig = sig, tcdDerivs = derivs})
 497   | is_vanilla  -- Normal Haskell data type decl
 498   = ASSERT( isNothing sig )     -- In normal H98 form, kind signature on the
 499                                 -- data type is syntactically illegal
 500     bindTyVarsRn data_doc tyvars                $ \ tyvars' ->
 501     do  { tycon' <- lookupLocatedTopBndrRn tycon
 502         ; context' <- rnContext data_doc context
 503         ; typats' <- rnTyPats data_doc typatsMaybe
 504         ; (derivs', deriv_fvs) <- rn_derivs derivs
 505         ; checkDupNames data_doc con_names
 506         ; condecls' <- rnConDecls (unLoc tycon') condecls
 507         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = context',
 508                            tcdLName = tycon', tcdTyVars = tyvars',
 509                            tcdTyPats = typats', tcdKindSig = Nothing,
 510                            tcdCons = condecls', tcdDerivs = derivs'},
 511                    delFVs (map hsLTyVarName tyvars')    $
 512                    extractHsCtxtTyNames context'        `plusFV`
 513                    plusFVs (map conDeclFVs condecls')   `plusFV`
 514                    deriv_fvs) }
 515
 516   | otherwise   -- GADT
 517   = ASSERT( none typatsMaybe )    -- GADTs cannot have type patterns for now
 518     do  { tycon' <- lookupLocatedTopBndrRn tycon
 519         ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
 520         ; tyvars' <- bindTyVarsRn data_doc tyvars
 521                                   (\ tyvars' -> return tyvars')
 522                 -- For GADTs, the type variables in the declaration
 523                 -- do not scope over the constructor signatures
 524                 --      data T a where { T1 :: forall b. b-> b }
 525         ; (derivs', deriv_fvs) <- rn_derivs derivs
 526         ; checkDupNames data_doc con_names
 527         ; condecls' <- rnConDecls (unLoc tycon') condecls
 528         ; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [],
 529                            tcdLName = tycon', tcdTyVars = tyvars',
 530                            tcdTyPats = Nothing, tcdKindSig = sig,
 531                            tcdCons = condecls', tcdDerivs = derivs'},
 532                    plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }
 533
 534   where
 535     is_vanilla = case condecls of       -- Yuk
 536                      []                    -> True
 537                      L _ (ConDecl { con_res = ResTyH98 }) : _  -> True
 538                      other                 -> False
 539
 540     none Nothing   = True
 541     none (Just []) = True
 542     none _         = False
 543
 544     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
 545     con_names = map con_names_helper condecls
 546
 547     con_names_helper (L _ c) = con_name c
 548
 549     rn_derivs Nothing   = returnM (Nothing, emptyFVs)
 550     rn_derivs (Just ds) = rnLHsTypes data_doc ds        `thenM` \ ds' ->
 551                           returnM (Just ds', extractHsTyNames_s ds')
 552
 553 rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty})
 554   = lookupLocatedTopBndrRn name                 `thenM` \ name' ->
 555     bindTyVarsRn syn_doc tyvars                 $ \ tyvars' ->
 556     rnHsTypeFVs syn_doc ty                      `thenM` \ (ty', fvs) ->
 557     returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars',
 558                         tcdSynRhs = ty'},
 559              delFVs (map hsLTyVarName tyvars') fvs)
 560   where
 561     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 562
 563 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname,
 564                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
 565                        tcdMeths = mbinds, tcdATs = ats})
 566   = lookupLocatedTopBndrRn cname                `thenM` \ cname' ->
 567
 568         -- Tyvars scope over superclass context and method signatures
 569     bindTyVarsRn cls_doc tyvars                 ( \ tyvars' ->
 570         rnContext cls_doc context       `thenM` \ context' ->
 571         rnFds cls_doc fds               `thenM` \ fds' ->
 572         rnATs ats                       `thenM` \ (ats', ats_fvs) ->
 573         renameSigs okClsDclSig sigs     `thenM` \ sigs' ->
 574         returnM   (tyvars', context', fds', (ats', ats_fvs), sigs')
 575     )   `thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs') ->
 576
 577         -- Check for duplicates among the associated types
 578     let
 579       at_rdr_names_w_locs      = [tcdLName ty | L _ ty <- ats]
 580     in
 581     checkDupNames at_doc at_rdr_names_w_locs   `thenM_`
 582
 583         -- Check the signatures
 584         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 585     let
 586         sig_rdr_names_w_locs   = [op | L _ (TypeSig op _) <- sigs]
 587     in
 588     checkDupNames sig_doc sig_rdr_names_w_locs  `thenM_`
 589         -- Typechecker is responsible for checking that we only
 590         -- give default-method bindings for things in this class.
 591         -- The renamer *could* check this for class decls, but can't
 592         -- for instance decls.
 593
 594         -- The newLocals call is tiresome: given a generic class decl
 595         --      class C a where
 596         --        op :: a -> a
 597         --        op {| x+y |} (Inl a) = ...
 598         --        op {| x+y |} (Inr b) = ...
 599         --        op {| a*b |} (a*b)   = ...
 600         -- we want to name both "x" tyvars with the same unique, so that they are
 601         -- easy to group together in the typechecker.
 602     extendTyVarEnvForMethodBinds tyvars' (
 603          getLocalRdrEnv                                 `thenM` \ name_env ->
 604          let
 605              meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds
 606              gen_rdr_tyvars_w_locs =
 607                 [ tv | tv <- extractGenericPatTyVars mbinds,
 608                       not (unLoc tv `elemLocalRdrEnv` name_env) ]
 609          in
 610          checkDupNames meth_doc meth_rdr_names_w_locs   `thenM_`
 611          newLocalsRn gen_rdr_tyvars_w_locs      `thenM` \ gen_tyvars ->
 612          rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds
 613     ) `thenM` \ (mbinds', meth_fvs) ->
 614
 615     returnM (ClassDecl { tcdCtxt = context', tcdLName = cname',
 616                          tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
 617                          tcdMeths = mbinds', tcdATs = ats'},
 618              delFVs (map hsLTyVarName tyvars')  $
 619              extractHsCtxtTyNames context'          `plusFV`
 620              plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
 621              hsSigsFVs sigs'                        `plusFV`
 622              meth_fvs                               `plusFV`
 623              ats_fvs)
 624   where
 625     meth_doc = text "In the default-methods for class"  <+> ppr cname
 626     cls_doc  = text "In the declaration for class"      <+> ppr cname
 627     sig_doc  = text "In the signatures for class"       <+> ppr cname
 628     at_doc   = text "In the associated types for class" <+> ppr cname
 629
 630 badGadtStupidTheta tycon
 631   = vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"),
 632           ptext SLIT("(You can put a context on each contructor, though.)")]
 633 \end{code}
 634
 635 %*********************************************************
 636 %*                                                      *
 637 \subsection{Support code for type/data declarations}
 638 %*                                                      *
 639 %*********************************************************
 640
 641 \begin{code}
 642 -- Although, we are processing type patterns here, all type variables will
 643 -- already be in scope (they are the same as in the 'tcdTyVars' field of the
 644 -- type declaration to which these patterns belong)
 645 --
 646 rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name])
 647 rnTyPats _   Nothing       = return Nothing
 648 rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats
 649
 650 rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
 651 rnConDecls tycon condecls
 652   = mappM (wrapLocM rnConDecl) condecls
 653
 654 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
 655 rnConDecl (ConDecl name expl tvs cxt details res_ty)
 656   = do  { addLocM checkConName name
 657
 658         ; new_name <- lookupLocatedTopBndrRn name
 659         ; name_env <- getLocalRdrEnv
 660
 661         -- For H98 syntax, the tvs are the existential ones
 662         -- For GADT syntax, the tvs are all the quantified tyvars
 663         -- Hence the 'filter' in the ResTyH98 case only
 664         ; let not_in_scope  = not . (`elemLocalRdrEnv` name_env) . unLoc
 665               arg_tys       = hsConArgs details
 666               implicit_tvs  = case res_ty of
 667                                 ResTyH98 -> filter not_in_scope $
 668                                                 get_rdr_tvs arg_tys
 669                                 ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
 670               tvs' = case expl of
 671                         Explicit -> tvs
 672                         Implicit -> userHsTyVarBndrs implicit_tvs
 673
 674         ; bindTyVarsRn doc tvs' $ \new_tyvars -> do
 675         { new_context <- rnContext doc cxt
 676         ; new_details <- rnConDetails doc details
 677         ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
 678         ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty) }}
 679   where
 680     doc = text "In the definition of data constructor" <+> quotes (ppr name)
 681     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
 682
 683 rnConResult _ details ResTyH98 = return (details, ResTyH98)
 684
 685 rnConResult doc details (ResTyGADT ty) = do
 686     ty' <- rnHsSigType doc ty
 687     let (arg_tys, res_ty) = splitHsFunType ty'
 688         -- We can split it up, now the renamer has dealt with fixities
 689     case details of
 690         PrefixCon _xs -> ASSERT( null _xs ) return (PrefixCon arg_tys, ResTyGADT res_ty)
 691         RecCon fields -> return (details, ResTyGADT ty')
 692         InfixCon {}   -> panic "rnConResult"
 693
 694 rnConDetails doc (PrefixCon tys)
 695   = mappM (rnLHsType doc) tys   `thenM` \ new_tys  ->
 696     returnM (PrefixCon new_tys)
 697
 698 rnConDetails doc (InfixCon ty1 ty2)
 699   = rnLHsType doc ty1           `thenM` \ new_ty1 ->
 700     rnLHsType doc ty2           `thenM` \ new_ty2 ->
 701     returnM (InfixCon new_ty1 new_ty2)
 702
 703 rnConDetails doc (RecCon fields)
 704   = checkDupNames doc field_names       `thenM_`
 705     mappM (rnField doc) fields          `thenM` \ new_fields ->
 706     returnM (RecCon new_fields)
 707   where
 708     field_names = [fld | (fld, _) <- fields]
 709
 710 rnField doc (name, ty)
 711   = lookupLocatedTopBndrRn name `thenM` \ new_name ->
 712     rnLHsType doc ty            `thenM` \ new_ty ->
 713     returnM (new_name, new_ty)
 714
 715 -- This data decl will parse OK
 716 --      data T = a Int
 717 -- treating "a" as the constructor.
 718 -- It is really hard to make the parser spot this malformation.
 719 -- So the renamer has to check that the constructor is legal
 720 --
 721 -- We can get an operator as the constructor, even in the prefix form:
 722 --      data T = :% Int Int
 723 -- from interface files, which always print in prefix form
 724
 725 checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
 726
 727 badDataCon name
 728    = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
 729 \end{code}
 730
 731
 732 %*********************************************************
 733 %*                                                      *
 734 \subsection{Support code to rename types}
 735 %*                                                      *
 736 %*********************************************************
 737
 738 \begin{code}
 739 rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
 740
 741 rnFds doc fds
 742   = mappM (wrapLocM rn_fds) fds
 743   where
 744     rn_fds (tys1, tys2)
 745       = rnHsTyVars doc tys1             `thenM` \ tys1' ->
 746         rnHsTyVars doc tys2             `thenM` \ tys2' ->
 747         returnM (tys1', tys2')
 748
 749 rnHsTyVars doc tvs  = mappM (rnHsTyvar doc) tvs
 750 rnHsTyvar doc tyvar = lookupOccRn tyvar
 751
 752 -- Rename kind signatures (signatures of indexed data types/newtypes and
 753 -- signatures of type functions)
 754 --
 755 -- * This function is parametrised by the routine handling the index
 756 --   variables.  On the toplevel, these are defining occurences, whereas they
 757 --   are usage occurences for associated types.
 758 --
 759 rnTySig :: TyClDecl RdrName
 760         -> (SDoc -> [LHsTyVarBndr RdrName] ->
 761             ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
 762             RnM (TyClDecl Name, FreeVars))
 763         -> RnM (TyClDecl Name, FreeVars)
 764
 765 rnTySig (tydecl@TyData {tcdCtxt = context, tcdLName = tycon,
 766                         tcdTyVars = tyvars, tcdTyPats = mb_typats,
 767                         tcdCons = condecls, tcdKindSig = sig,
 768                         tcdDerivs = derivs})
 769         bindIdxVars =
 770       ASSERT( null condecls )       -- won't have constructors
 771       ASSERT( isNothing mb_typats ) -- won't have type patterns
 772       ASSERT( isNothing derivs )    -- won't have deriving
 773       ASSERT( isJust sig )          -- will have kind signature
 774       do { checkM (not . null $ tyvars) $ addErr needOneIdx   -- #indexes >= 1
 775          ; bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do {
 776          ; tycon' <- lookupLocatedTopBndrRn tycon
 777          ; context' <- rnContext (ksig_doc tycon) context
 778          ; returnM (TyData {tcdND = tcdND tydecl, tcdCtxt = context',
 779                             tcdLName = tycon', tcdTyVars = tyvars',
 780                             tcdTyPats = Nothing, tcdKindSig = sig,
 781                             tcdCons = [], tcdDerivs = Nothing},
 782                     delFVs (map hsLTyVarName tyvars') $
 783                     extractHsCtxtTyNames context') } }
 784       where
 785
 786 rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars,
 787                             tcdKind = sig})
 788         bindIdxVars =
 789       do { checkM (not . null $ tyvars) $ addErr needOneIdx   -- #indexes >= 1
 790          ; bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do {
 791          ; tycon' <- lookupLocatedTopBndrRn tycon
 792          ; returnM (TyFunction {tcdLName = tycon', tcdTyVars = tyvars',
 793                                 tcdIso = tcdIso tydecl, tcdKind = sig},
 794                     emptyFVs) } }
 795
 796 ksig_doc tycon = text "In the kind signature for" <+> quotes (ppr tycon)
 797 needOneIdx = text "Kind signature requires at least one type index"
 798
 799 -- Rename associated type declarations (in classes)
 800 --
 801 -- * This can be data declarations, type function signatures, and (default)
 802 --   type function equations.
 803 --
 804 rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 805 rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
 806   where
 807     rn_at (tydecl@TyData     {}) = rnTySig tydecl lookupIdxVars
 808     rn_at (tydecl@TyFunction {}) = rnTySig tydecl lookupIdxVars
 809     rn_at (tydelc@TySynonym  {}) = panic "!!!TODO: case not impl yet"
 810     rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"
 811
 812     lookupIdxVars _ tyvars cont = mappM lookupIdxVar tyvars >>= cont
 813     --
 814     -- Type index variables must be class parameters, which are the only
 815     -- type variables in scope at this point.
 816     lookupIdxVar (L l tyvar) =
 817       do
 818         name' <- lookupOccRn (hsTyVarName tyvar)
 819         return $ L l (replaceTyVarName tyvar name')
 820 \end{code}
 821
 822
 823 %*********************************************************
 824 %*                                                      *
 825                 Splices
 826 %*                                                      *
 827 %*********************************************************
 828
 829 Note [Splices]
 830 ~~~~~~~~~~~~~~
 831 Consider
 832         f = ...
 833         h = ...$(thing "f")...
 834
 835 The splice can expand into literally anything, so when we do dependency
 836 analysis we must assume that it might mention 'f'.  So we simply treat
 837 all locally-defined names as mentioned by any splice.  This is terribly
 838 brutal, but I don't see what else to do.  For example, it'll mean
 839 that every locally-defined thing will appear to be used, so no unused-binding
 840 warnings.  But if we miss the dependency, then we might typecheck 'h' before 'f',
 841 and that will crash the type checker because 'f' isn't in scope.
 842
 843 Currently, I'm not treating a splice as also mentioning every import,
 844 which is a bit inconsistent -- but there are a lot of them.  We might
 845 thereby get some bogus unused-import warnings, but we won't crash the
 846 type checker.  Not very satisfactory really.
 847
 848 \begin{code}
 849 rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
 850 rnSplice (HsSplice n expr)
 851   = do  { checkTH expr "splice"
 852         ; loc  <- getSrcSpanM
 853         ; [n'] <- newLocalsRn [L loc n]
 854         ; (expr', fvs) <- rnLExpr expr
 855
 856         -- Ugh!  See Note [Splices] above
 857         ; lcl_rdr <- getLocalRdrEnv
 858         ; gbl_rdr <- getGlobalRdrEnv
 859         ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr,
 860                                                     isLocalGRE gre]
 861               lcl_names = mkNameSet (occEnvElts lcl_rdr)
 862
 863         ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
 864
 865 #ifdef GHCI
 866 checkTH e what = returnM ()     -- OK
 867 #else
 868 checkTH e what  -- Raise an error in a stage-1 compiler
 869   = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>
 870                   ptext SLIT("illegal in a stage-1 compiler"),
 871                   nest 2 (ppr e)])
 872 #endif
 873 \end{code}