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