RnSource.lhs 32.4 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 4 5 6
%
\section[RnSource]{Main pass of renamer}

\begin{code}
7
module RnSource ( 
8 9
	rnSrcDecls, addTcgDUs, 
	rnTyClDecls, checkModDeprec,
10
	rnSplice, checkTH
11
    ) where
12

13
#include "HsVersions.h"
sof's avatar
sof committed
14

15 16
import {-# SOURCE #-} RnExpr( rnLExpr )

17
import HsSyn
18 19 20
import RdrName		( RdrName, isRdrDataCon, isRdrTyVar, rdrNameOcc, 
			  elemLocalRdrEnv, globalRdrEnvElts, GlobalRdrElt(..),
			  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 35 36
import HscTypes		( FixityEnv, FixItem(..),
			  Deprecations, Deprecs(..), DeprecTxt, plusDeprecs )
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 49
\end{code}

50
@rnSourceDecl@ `renames' declarations.
51 52 53 54 55 56
It simultaneously performs dependency analysis and precedence parsing.
It also does the following error checks:
\begin{enumerate}
\item
Checks that tyvars are used properly. This includes checking
for undefined tyvars, and tyvars in contexts that are ambiguous.
57 58
(Some of this checking has now been moved to module @TcMonoType@,
since we don't have functional dependency information at this point.)
59 60 61
\item
Checks that all variable occurences are defined.
\item 
62
Checks the @(..)@ etc constraints in the export list.
63 64 65
\end{enumerate}


66
\begin{code}
67
rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
68

69
rnSrcDecls (HsGroup { hs_valds  = val_decls,
70 71 72 73 74 75
		      hs_tyclds = tycl_decls,
		      hs_instds = inst_decls,
		      hs_fixds  = fix_decls,
		      hs_depds  = deprec_decls,
		      hs_fords  = foreign_decls,
		      hs_defds  = default_decls,
76
		      hs_ruleds = rule_decls })
77 78 79

 = do {		-- Deal with deprecations (returns only the extra deprecations)
	deprecs <- rnSrcDeprecDecls deprec_decls ;
80 81 82 83 84
	updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` deprecs })
		  $ do {

		-- Deal with top-level fixity decls 
		-- (returns the total new fixity env)
85
        rn_fix_decls <- rnSrcFixityDecls fix_decls ;
86
	fix_env <- rnSrcFixityDeclsEnv rn_fix_decls ;
87 88 89
	updGblEnv (\gbl -> gbl { tcg_fix_env = fix_env })
		  $ do {

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 96 97 98 99 100 101

		-- You might think that we could build proper def/use information
		-- for type and class declarations, but they can be involved
		-- in mutual recursion across modules, and we only do the SCC
		-- analysis for them in the type checker.
		-- So we content ourselves with gathering uses only; that
		-- means we'll only report a declaration as unused if it isn't
		-- mentioned at all.  Ah well.
102 103 104 105 106 107 108 109 110 111
	(rn_tycl_decls,    src_fvs1)
	   <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ;
	(rn_inst_decls,    src_fvs2)
	   <- mapFvRn (wrapLocFstM rnSrcInstDecl) inst_decls ;
	(rn_rule_decls,    src_fvs3)
	   <- mapFvRn (wrapLocFstM rnHsRuleDecl) rule_decls ;
	(rn_foreign_decls, src_fvs4)
	   <- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ;
	(rn_default_decls, src_fvs5)
	   <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ;
112 113
	
	let {
114 115
           rn_at_decls = concat 
			   [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 121 122
			    	hs_depds  = [],
			    	hs_fords  = rn_foreign_decls,
			    	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 129 130 131
		-- Note: src_dus will contain *uses* for locally-defined types
		-- and classes, but no *defs* for them.  (Because rnTyClDecl 
		-- returns only the uses.)  This is a little 
		-- 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 141 142 143

rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
rnTyClDecls tycl_decls = do 
  (decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls
  return decls'
144 145 146

addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv 
addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
147 148 149 150 151 152 153 154 155 156
\end{code}


%*********************************************************
%*						 	 *
	Source-code fixity declarations
%*							 *
%*********************************************************

\begin{code}
157
rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM [LFixitySig Name]
158
rnSrcFixityDecls fix_decls
159 160 161 162 163
    = do fix_decls <- mapM rnFixityDecl fix_decls
         return (concat fix_decls)

rnFixityDecl :: LFixitySig RdrName -> RnM [LFixitySig Name]
rnFixityDecl (L loc (FixitySig (L nameLoc rdr_name) fixity))
164 165 166 167 168 169
    = setSrcSpan nameLoc $
        -- GHC extension: look up both the tycon and data con 
	-- for con-like things
	-- If neither are in scope, report an error; otherwise
	-- add both to the fixity env
      do names <- lookupLocalDataTcNames rdr_name
170 171 172
         return [ L loc (FixitySig (L nameLoc name) fixity)
                      | name <- names ]

173
rnSrcFixityDeclsEnv :: [LFixitySig Name] -> RnM FixityEnv
174
rnSrcFixityDeclsEnv fix_decls
175
  = getGblEnv					`thenM` \ gbl_env ->
176
    foldlM rnFixityDeclEnv (tcg_fix_env gbl_env) 
177 178
	    fix_decls				 	`thenM` \ fix_env ->
    traceRn (text "fixity env" <+> pprFixEnv fix_env)	`thenM_`
179 180
    returnM fix_env

181 182 183 184 185 186 187 188 189
rnFixityDeclEnv :: FixityEnv -> LFixitySig Name -> RnM FixityEnv
rnFixityDeclEnv fix_env (L loc (FixitySig (L nameLoc name) fixity))
  = case lookupNameEnv fix_env name of
      Just (FixItem _ _ loc') 
	  -> do addLocErr (L nameLoc name) (dupFixityDecl loc')
    	        return fix_env
      Nothing
          -> return (extendNameEnv fix_env name fix_item)
    where fix_item = FixItem (nameOccName name) fixity nameLoc
190 191 192 193 194

pprFixEnv :: FixityEnv -> SDoc
pprFixEnv env 
  = pprWithCommas (\ (FixItem n f _) -> ppr f <+> ppr n)
		  (nameEnvElts env)
195

196
dupFixityDecl loc rdr_name
197
  = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
198 199
	  ptext SLIT("also at ") <+> ppr loc
	]
200 201 202 203 204 205 206 207 208 209 210 211 212 213
\end{code}


%*********************************************************
%*						 	 *
	Source-code deprecations declarations
%*							 *
%*********************************************************

For deprecations, all we do is check that the names are in scope.
It's only imported deprecations, dealt with in RnIfaces, that we
gather them together.

\begin{code}
214
rnSrcDeprecDecls :: [LDeprecDecl RdrName] -> RnM Deprecations
215 216 217 218
rnSrcDeprecDecls [] 
  = returnM NoDeprecs

rnSrcDeprecDecls decls
219 220
  = mappM (addLocM rn_deprec) decls	`thenM` \ pairs_s ->
    returnM (DeprecSome (mkNameEnv (concat pairs_s)))
221
 where
222
   rn_deprec (Deprecation rdr_name txt)
223 224
     = lookupLocalDataTcNames rdr_name	`thenM` \ names ->
       returnM [(name, (nameOccName name, txt)) | name <- names]
225 226 227 228

checkModDeprec :: Maybe DeprecTxt -> Deprecations
-- Check for a module deprecation; done once at top level
checkModDeprec Nothing    = NoDeprecs
229
checkModDeprec (Just txt) = DeprecAll txt
230
\end{code}
231

232 233 234 235 236
%*********************************************************
%*							*
\subsection{Source code declarations}
%*							*
%*********************************************************
237

238
\begin{code}
239 240 241
rnDefaultDecl (DefaultDecl tys)
  = mapFvRn (rnHsTypeFVs doc_str) tys	`thenM` \ (tys', fvs) ->
    returnM (DefaultDecl tys', fvs)
242
  where
243
    doc_str = text "In a `default' declaration"
244 245
\end{code}

246 247 248 249 250 251 252
%*********************************************************
%*							*
\subsection{Foreign declarations}
%*							*
%*********************************************************

\begin{code}
Simon Marlow's avatar
Simon Marlow committed
253
rnHsForeignDecl (ForeignImport name ty spec)
254
  = lookupLocatedTopBndrRn name	        `thenM` \ name' ->
255
    rnHsTypeFVs (fo_decl_msg name) ty	`thenM` \ (ty', fvs) ->
Simon Marlow's avatar
Simon Marlow committed
256
    returnM (ForeignImport name' ty' spec, fvs)
257

Simon Marlow's avatar
Simon Marlow committed
258
rnHsForeignDecl (ForeignExport name ty spec)
259
  = lookupLocatedOccRn name	        `thenM` \ name' ->
260
    rnHsTypeFVs (fo_decl_msg name) ty  	`thenM` \ (ty', fvs) ->
Simon Marlow's avatar
Simon Marlow committed
261
    returnM (ForeignExport name' ty' spec, fvs )
262 263 264
	-- NB: a foreign export is an *occurrence site* for name, so 
	--     we add it to the free-variable list.  It might, for example,
	--     be imported from another module
265

266
fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name
267 268 269 270 271 272 273 274 275 276
\end{code}


%*********************************************************
%*							*
\subsection{Instance declarations}
%*							*
%*********************************************************

\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 282 283 284 285 286 287 288 289 290 291
	-- Rename the associated types
	-- The typechecker (not the renamer) checks that all 
	-- the declarations are for the right class
    let
	at_doc   = text "In the associated types in an instance declaration"
	at_names = map (head . tyClDeclNames . unLoc) ats
	(_, rdrCtxt, _, _) = splitHsInstDeclTy (unLoc inst_ty)
    in
    checkDupNames at_doc at_names		`thenM_`
    rnATDefs rdrCtxt ats			`thenM` \ (ats', at_fvs) ->

292 293 294
	-- Rename the bindings
	-- The typechecker (not the renamer) checks that all 
	-- the bindings are for the right class
295
    let
296
	meth_doc    = text "In the bindings in an instance declaration"
297 298
	meth_names  = collectHsBindLocatedBinders mbinds
	(inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
299
    in
300
    checkDupNames meth_doc meth_names 	`thenM_`
301
    extendTyVarEnvForMethodBinds inst_tyvars (		
302 303
	-- (Slightly strangely) the forall-d tyvars scope over
	-- the method bindings too
304 305
	rnMethodBinds cls (\n->[]) 	-- No scoped tyvars
		      [] mbinds
306
    )						`thenM` \ (mbinds', meth_fvs) ->
307 308 309 310 311 312 313
	-- Rename the prags and signatures.
	-- Note that the type variables are not in scope here,
	-- so that	instance Eq a => Eq (T a) where
	--			{-# SPECIALISE instance Eq a => Eq (T [a]) #-}
	-- works OK. 
	--
	-- 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 321 322
    returnM (InstDecl inst_ty' mbinds' uprags' ats',
	     meth_fvs `plusFV` at_fvs
		      `plusFV` hsSigsFVs uprags'
323
		      `plusFV` extractHsTyNames inst_ty')
324 325 326 327 328 329 330 331 332 333 334 335
             -- We return the renamed associated data type declarations so
             -- that they can be entered into the list of type declarations
             -- for the binding group, but we also keep a copy in the instance.
             -- The latter is needed for well-formedness checks in the type
             -- checker (eg, to ensure that all ATs of the instance actually
             -- receive a declaration). 
	     -- NB: Even the copies in the instance declaration carry copies of
	     --     the instance context after renaming.  This is a bit
	     --     strange, but should not matter (and it would be more work
	     --     to remove the context).
\end{code}

336 337 338 339 340
Renaming of the associated type definitions in instances.  

* In the case of associated data and newtype definitions we add the instance
  context.
* We raise an error if we encounter a kind signature in an instance.
341 342 343 344 345

\begin{code}
rnATDefs :: HsContext RdrName -> [LTyClDecl RdrName] 
	  -> RnM ([LTyClDecl Name], FreeVars)
rnATDefs ctxt atDecls = 
346
  mapFvRn (wrapLocFstM rnAtDef) atDecls
347
  where
348 349 350 351 352 353 354 355 356 357 358 359 360 361
    rnAtDef tydecl@TyFunction {}                 = 
      do
        addErr noKindSig
	rnTyClDecl tydecl
    rnAtDef tydecl@TySynonym  {}                 = rnTyClDecl tydecl
    rnAtDef tydecl@TyData {tcdCtxt = L l tyCtxt} = 
      do
        checkM (not . isKindSigDecl $ tydecl) $ addErr noKindSig
        rnTyClDecl (tydecl {tcdCtxt = L l (ctxt ++ tyCtxt)})
          -- The source loc is somewhat half hearted... -=chak
    rnAtDef _ =
      panic "RnSource.rnATDefs: not a type declaration"

noKindSig = text "Instances cannot have kind signatures"
362 363
\end{code}

364 365 366 367 368 369 370
For the method bindings in class and instance decls, we extend the 
type variable environment iff -fglasgow-exts

\begin{code}
extendTyVarEnvForMethodBinds tyvars thing_inside
  = doptM Opt_GlasgowExts			`thenM` \ opt_GlasgowExts ->
    if opt_GlasgowExts then
371
	extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
372 373 374 375 376
    else
	thing_inside
\end{code}


377 378 379 380 381 382 383
%*********************************************************
%*							*
\subsection{Rules}
%*							*
%*********************************************************

\begin{code}
384
rnHsRuleDecl (HsRule rule_name act vars lhs fv_lhs rhs fv_rhs)
385
  = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)	$
386

387
    bindLocatedLocalsFV doc (map get_var vars)		$ \ ids ->
388
    mapFvRn rn_var (vars `zip` ids)		`thenM` \ (vars', fv_vars) ->
389

390 391
    rnLExpr lhs					`thenM` \ (lhs', fv_lhs') ->
    rnLExpr rhs					`thenM` \ (rhs', fv_rhs') ->
392 393 394

    checkValidRule rule_name ids lhs' fv_lhs'	`thenM_`

395 396
    returnM (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
	     fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs')
397
  where
398
    doc = text "In the transformation rule" <+> ftext rule_name
399 400 401 402
  
    get_var (RuleBndr v)      = v
    get_var (RuleBndrSig v _) = v

403 404 405 406 407
    rn_var (RuleBndr (L loc v), id)
	= returnM (RuleBndr (L loc id), emptyFVs)
    rn_var (RuleBndrSig (L loc v) t, id)
	= rnHsTypeFVs doc t	`thenM` \ (t', fvs) ->
	  returnM (RuleBndrSig (L loc id) t', fvs)
408 409 410 411 412

badRuleVar name var
  = sep [ptext SLIT("Rule") <+> doubleQuotes (ftext name) <> colon,
	 ptext SLIT("Forall'd variable") <+> quotes (ppr var) <+> 
		ptext SLIT("does not appear on left hand side")]
413 414
\end{code}

415 416 417 418 419
Note [Rule LHS validity checking]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Check the shape of a transformation rule LHS.  Currently we only allow
LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
@forall@'d variables.  
420

421 422 423
We used restrict the form of the 'ei' to prevent you writing rules
with LHSs with a complicated desugaring (and hence unlikely to match);
(e.g. a case expression is not allowed: too elaborate.)
424

425 426 427 428
But there are legitimate non-trivial args ei, like sections and
lambdas.  So it seems simmpler not to check at all, and that is why
check_e is commented out.
	
429
\begin{code}
430 431 432 433 434 435 436 437 438 439
checkValidRule rule_name ids lhs' fv_lhs'
  = do 	{ 	-- Check for the form of the LHS
	  case (validRuleLhs ids lhs') of
		Nothing  -> return ()
		Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)

		-- Check that LHS vars are all bound
	; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
	; mappM (addErr . badRuleVar rule_name) bad_vars }

440
validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
441 442
-- Nothing => OK
-- Just e  => Not ok, and e is the offending expression
443
validRuleLhs foralls lhs
444
  = checkl lhs
445
  where
446 447 448 449
    checkl (L loc e) = check e

    check (OpApp e1 op _ e2)		  = checkl op `seqMaybe` checkl_e e1 `seqMaybe` checkl_e e2
    check (HsApp e1 e2) 		  = checkl e1 `seqMaybe` checkl_e e2
450 451 452
    check (HsVar v) | v `notElem` foralls = Nothing
    check other				  = Just other 	-- Failure

453 454
	-- Check an argument
    checkl_e (L loc e) = Nothing 	-- Was (check_e e); see Note [Rule LHS validity checking]
455

456
{-	Commented out; see Note [Rule LHS validity checking] above 
457
    check_e (HsVar v)     = Nothing
458
    check_e (HsPar e) 	  = checkl_e e
459 460 461
    check_e (HsLit e) 	  = Nothing
    check_e (HsOverLit e) = Nothing

462 463 464 465 466
    check_e (OpApp e1 op _ e2) 	 = checkl_e e1 `seqMaybe` checkl_e op `seqMaybe` checkl_e e2
    check_e (HsApp e1 e2)      	 = checkl_e e1 `seqMaybe` checkl_e e2
    check_e (NegApp e _)       	 = checkl_e e
    check_e (ExplicitList _ es)	 = checkl_es es
    check_e (ExplicitTuple es _) = checkl_es es
467 468
    check_e other		 = Just other	-- Fails

469
    checkl_es es = foldr (seqMaybe . checkl_e) Nothing es
470
-}
471

472
badRuleLhsErr name lhs bad_e
473 474 475 476 477
  = sep [ptext SLIT("Rule") <+> ftext name <> colon,
	 nest 4 (vcat [ptext SLIT("Illegal expression:") <+> ppr bad_e, 
		       ptext SLIT("in left-hand side:") <+> ppr lhs])]
    $$
    ptext SLIT("LHS must be of form (f e1 .. en) where f is not forall'd")
478 479
\end{code}

480

481 482
%*********************************************************
%*							*
483
\subsection{Type, class and iface sig declarations}
484 485 486 487 488 489 490 491 492
%*							*
%*********************************************************

@rnTyDecl@ uses the `global name function' to create a new type
declaration in which local names have been replaced by their original
names, reporting any unknown names.

Renaming type variables is a pain. Because they now contain uniques,
it is necessary to pass in an association list which maps a parsed
493 494 495 496 497 498
tyvar to its @Name@ representation.
In some cases (type signatures of values),
it is even necessary to go over the type first
in order to get the set of tyvars used by it, make an assoc list,
and then go over it again to rename the tyvars!
However, we can also do some scoping checks at the same time.
499 500

\begin{code}
501 502 503
rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
  = lookupLocatedTopBndrRn name		`thenM` \ name' ->
    returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
504
	     emptyFVs)
505

506 507 508 509 510 511 512
rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, 
			   tcdLName = tycon, tcdTyVars = tyvars, 
			   tcdTyPats = typatsMaybe, tcdCons = condecls, 
			   tcdKindSig = sig, tcdDerivs = derivs})
  | isKindSigDecl tydecl  -- kind signature of indexed type
  = rnTySig tydecl bindTyVarsRn
  | is_vanilla	          -- Normal Haskell data type decl
513 514 515
  = ASSERT( isNothing sig )	-- In normal H98 form, kind signature on the 
				-- data type is syntactically illegal
    bindTyVarsRn data_doc tyvars		$ \ tyvars' ->
516 517
    do	{ tycon' <- lookupLocatedTopBndrRn tycon
	; context' <- rnContext data_doc context
518
	; typats' <- rnTyPats data_doc typatsMaybe
519 520 521
	; (derivs', deriv_fvs) <- rn_derivs derivs
	; checkDupNames data_doc con_names
	; condecls' <- rnConDecls (unLoc tycon') condecls
522 523 524 525
	; returnM (TyData {tcdND = new_or_data, tcdCtxt = context', 
			   tcdLName = tycon', tcdTyVars = tyvars', 
			   tcdTyPats = typats', tcdKindSig = Nothing, 
			   tcdCons = condecls', tcdDerivs = derivs'}, 
526 527
		   delFVs (map hsLTyVarName tyvars')	$
	     	   extractHsCtxtTyNames context'	`plusFV`
528
	     	   plusFVs (map conDeclFVs condecls')   `plusFV`
529 530
	     	   deriv_fvs) }

531
  | otherwise	          -- GADT
532
  = ASSERT( none typatsMaybe )    -- GADTs cannot have type patterns for now
533
    do	{ tycon' <- lookupLocatedTopBndrRn tycon
534 535
	; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
    	; tyvars' <- bindTyVarsRn data_doc tyvars 
536 537 538 539 540 541 542
				  (\ tyvars' -> return tyvars')
		-- For GADTs, the type variables in the declaration 
		-- do not scope over the constructor signatures
		-- 	data T a where { T1 :: forall b. b-> b }
	; (derivs', deriv_fvs) <- rn_derivs derivs
	; checkDupNames data_doc con_names
	; condecls' <- rnConDecls (unLoc tycon') condecls
543 544 545 546
	; returnM (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], 
			   tcdLName = tycon', tcdTyVars = tyvars', 
			   tcdTyPats = Nothing, tcdKindSig = sig,
			   tcdCons = condecls', tcdDerivs = derivs'}, 
547 548
	     	   plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) }

sof's avatar
sof committed
549
  where
550 551
    is_vanilla = case condecls of	-- Yuk
		     [] 		   -> True
552
		     L _ (ConDecl { con_res = ResTyH98 }) : _  -> True
553 554
		     other		   -> False

555 556 557 558
    none Nothing   = True
    none (Just []) = True
    none _         = False

559
    data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
560 561
    con_names = map con_names_helper condecls

562
    con_names_helper (L _ c) = con_name c
563

564
    rn_derivs Nothing   = returnM (Nothing, emptyFVs)
565 566
    rn_derivs (Just ds) = rnLHsTypes data_doc ds	`thenM` \ ds' -> 
			  returnM (Just ds', extractHsTyNames_s ds')
567 568 569 570 571 572 573 574 575 576 577 578 579

rnTyClDecl (tydecl@TyFunction {}) =
  rnTySig tydecl bindTyVarsRn

rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars,
		       tcdTyPats = typatsMaybe, tcdSynRhs = ty})
  = bindTyVarsRn syn_doc tyvars		        $ \ tyvars' ->
    do { name' <- lookupLocatedTopBndrRn name
       ; typats' <- rnTyPats syn_doc typatsMaybe
       ; (ty', fvs) <- rnHsTypeFVs syn_doc ty
       ; returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars', 
			     tcdTyPats = typats', tcdSynRhs = ty'},
	          delFVs (map hsLTyVarName tyvars') fvs) }
sof's avatar
sof committed
580
  where
581
    syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
582

583
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, 
584
		       tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
585
		       tcdMeths = mbinds, tcdATs = ats})
586
  = lookupLocatedTopBndrRn cname		`thenM` \ cname' ->
sof's avatar
sof committed
587

588
	-- Tyvars scope over superclass context and method signatures
589 590 591
    bindTyVarsRn cls_doc tyvars			( \ tyvars' ->
	rnContext cls_doc context	`thenM` \ context' ->
	rnFds cls_doc fds		`thenM` \ fds' ->
592
	rnATs ats			`thenM` \ (ats', ats_fvs) ->
593
	renameSigs okClsDclSig sigs	`thenM` \ sigs' ->
594 595 596 597 598 599 600 601
	returnM   (tyvars', context', fds', (ats', ats_fvs), sigs')
    )	`thenM` \ (tyvars', context', fds', (ats', ats_fvs), sigs') ->

	-- Check for duplicates among the associated types
    let
      at_rdr_names_w_locs      = [tcdLName ty | L _ ty <- ats]
    in
    checkDupNames at_doc at_rdr_names_w_locs   `thenM_`
602

603
	-- Check the signatures
604
	-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
605
    let
606
	sig_rdr_names_w_locs   = [op | L _ (TypeSig op _) <- sigs]
607
    in
608
    checkDupNames sig_doc sig_rdr_names_w_locs	`thenM_` 
609 610 611 612 613
	-- Typechecker is responsible for checking that we only
	-- give default-method bindings for things in this class.
	-- The renamer *could* check this for class decls, but can't
	-- for instance decls.

614
   	-- The newLocals call is tiresome: given a generic class decl
615 616 617 618 619 620 621
	--	class C a where
	--	  op :: a -> a
	--	  op {| x+y |} (Inl a) = ...
	--	  op {| x+y |} (Inr b) = ...
	--	  op {| a*b |} (a*b)   = ...
	-- we want to name both "x" tyvars with the same unique, so that they are
	-- easy to group together in the typechecker.  
622 623 624
    extendTyVarEnvForMethodBinds tyvars' (
   	 getLocalRdrEnv					`thenM` \ name_env ->
   	 let
625 626 627 628
 	     meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds
 	     gen_rdr_tyvars_w_locs = 
		[ tv | tv <- extractGenericPatTyVars mbinds,
 		      not (unLoc tv `elemLocalRdrEnv` name_env) ]
629 630
   	 in
   	 checkDupNames meth_doc meth_rdr_names_w_locs	`thenM_`
631
   	 newLocalsRn gen_rdr_tyvars_w_locs	`thenM` \ gen_tyvars ->
632
   	 rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds
633 634
    ) `thenM` \ (mbinds', meth_fvs) ->

635 636 637
    returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', 
			 tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
			 tcdMeths = mbinds', tcdATs = ats'},
638
	     delFVs (map hsLTyVarName tyvars')	$
639
	     extractHsCtxtTyNames context'	    `plusFV`
640
	     plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
641
	     hsSigsFVs sigs'		  	    `plusFV`
642 643
	     meth_fvs				    `plusFV`
	     ats_fvs)
644 645 646 647
  where
    meth_doc = text "In the default-methods for class"	<+> ppr cname
    cls_doc  = text "In the declaration for class" 	<+> ppr cname
    sig_doc  = text "In the signatures for class"  	<+> ppr cname
648
    at_doc   = text "In the associated types for class"	<+> ppr cname
649 650 651 652

badGadtStupidTheta tycon
  = vcat [ptext SLIT("No context is allowed on a GADT-style data declaration"),
	  ptext SLIT("(You can put a context on each contructor, though.)")]
653 654
\end{code}

655 656
%*********************************************************
%*							*
657
\subsection{Support code for type/data declarations}
658 659 660 661
%*							*
%*********************************************************

\begin{code}
662
-- Although, we are processing type patterns here, all type variables will
663 664 665 666 667 668 669
-- already be in scope (they are the same as in the 'tcdTyVars' field of the
-- type declaration to which these patterns belong)
--
rnTyPats :: SDoc -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name])
rnTyPats _   Nothing       = return Nothing
rnTyPats doc (Just typats) = liftM Just $ rnLHsTypes doc typats

670
rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
671
rnConDecls tycon condecls
672
  = mappM (wrapLocM rnConDecl) condecls
673

674
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
675 676
rnConDecl (ConDecl name expl tvs cxt details res_ty)
  = do	{ addLocM checkConName name
sof's avatar
sof committed
677

678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696
	; new_name <- lookupLocatedTopBndrRn name
	; name_env <- getLocalRdrEnv
	
	-- For H98 syntax, the tvs are the existential ones
	-- For GADT syntax, the tvs are all the quantified tyvars
	-- Hence the 'filter' in the ResTyH98 case only
	; let not_in_scope  = not . (`elemLocalRdrEnv` name_env) . unLoc
	      arg_tys       = hsConArgs details
	      implicit_tvs  = case res_ty of
	      	    		ResTyH98 -> filter not_in_scope $
						get_rdr_tvs arg_tys
	      	    		ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
	      tvs' = case expl of
	        	Explicit -> tvs
		    	Implicit -> userHsTyVarBndrs implicit_tvs

	; bindTyVarsRn doc tvs' $ \new_tyvars -> do
	{ new_context <- rnContext doc cxt
        ; new_details <- rnConDetails doc details
697 698
        ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
        ; return (ConDecl new_name expl new_tyvars new_context new_details' new_res_ty) }}
699 700
  where
    doc = text "In the definition of data constructor" <+> quotes (ppr name)
701 702
    get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))

703 704 705
rnConResult _ details ResTyH98 = return (details, ResTyH98)

rnConResult doc details (ResTyGADT ty) = do
706
    ty' <- rnHsSigType doc ty
707 708 709 710 711 712
    let (arg_tys, res_ty) = splitHsFunType ty'
	-- We can split it up, now the renamer has dealt with fixities
    case details of
	PrefixCon _xs -> ASSERT( null _xs ) return (PrefixCon arg_tys, ResTyGADT res_ty)
	RecCon fields -> return (details, ResTyGADT ty')
	InfixCon {}   -> panic "rnConResult"
713

714
rnConDetails doc (PrefixCon tys)
715
  = mappM (rnLHsType doc) tys	`thenM` \ new_tys  ->
716
    returnM (PrefixCon new_tys)
sof's avatar
sof committed
717

718
rnConDetails doc (InfixCon ty1 ty2)
719 720
  = rnLHsType doc ty1  		`thenM` \ new_ty1 ->
    rnLHsType doc ty2  		`thenM` \ new_ty2 ->
721
    returnM (InfixCon new_ty1 new_ty2)
722

723
rnConDetails doc (RecCon fields)
724
  = checkDupNames doc field_names	`thenM_`
725 726
    mappM (rnField doc) fields		`thenM` \ new_fields ->
    returnM (RecCon new_fields)
sof's avatar
sof committed
727
  where
728
    field_names = [fld | (fld, _) <- fields]
729

730
rnField doc (name, ty)
731
  = lookupLocatedTopBndrRn name	`thenM` \ new_name ->
732
    rnLHsType doc ty		`thenM` \ new_ty ->
733
    returnM (new_name, new_ty) 
734

735 736
-- Rename kind signatures (signatures of indexed data types/newtypes and
-- signatures of type functions)
737
--
738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758
-- * This function is parametrised by the routine handling the index
--   variables.  On the toplevel, these are defining occurences, whereas they
--   are usage occurences for associated types.
--
rnTySig :: TyClDecl RdrName 
        -> (SDoc -> [LHsTyVarBndr RdrName] -> 
	    ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
	    RnM (TyClDecl Name, FreeVars))
        -> RnM (TyClDecl Name, FreeVars)

rnTySig (tydecl@TyData {tcdCtxt = context, tcdLName = tycon, 
			tcdTyVars = tyvars, tcdTyPats = mb_typats,
			tcdCons = condecls, tcdKindSig = sig, 
			tcdDerivs = derivs}) 
        bindIdxVars =
      ASSERT( null condecls )	    -- won't have constructors
      ASSERT( isNothing mb_typats ) -- won't have type patterns
      ASSERT( isNothing derivs )    -- won't have deriving
      ASSERT( isJust sig )          -- will have kind signature
      do { checkM (not . null $ tyvars) $ addErr needOneIdx   -- #indexes >= 1
	 ; bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do {
759
	 ; tycon' <- lookupLocatedTopBndrRn tycon
760 761 762 763 764 765 766
	 ; context' <- rnContext (ksig_doc tycon) context
	 ; returnM (TyData {tcdND = tcdND tydecl, tcdCtxt = context', 
			    tcdLName = tycon', tcdTyVars = tyvars',
			    tcdTyPats = Nothing, tcdKindSig = sig, 
			    tcdCons = [], tcdDerivs = Nothing}, 
		    delFVs (map hsLTyVarName tyvars') $
	     	    extractHsCtxtTyNames context') } }
767
      where
768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783

rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars, 
			    tcdKind = sig}) 
        bindIdxVars =
      do { checkM (not . null $ tyvars) $ addErr needOneIdx   -- #indexes >= 1
	 ; bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do {
	 ; tycon' <- lookupLocatedTopBndrRn tycon
	 ; returnM (TyFunction {tcdLName = tycon', tcdTyVars = tyvars',
			        tcdIso = tcdIso tydecl, tcdKind = sig}, 
		    emptyFVs) } }

ksig_doc tycon = text "In the kind signature for" <+> quotes (ppr tycon)
needOneIdx = text "Kind signature requires at least one type index"

-- Rename associated type declarations (in classes)
--
784
-- * This can be kind signatures and (default) type function equations.
785 786 787 788 789 790
--
rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
  where
    rn_at (tydecl@TyData     {}) = rnTySig tydecl lookupIdxVars
    rn_at (tydecl@TyFunction {}) = rnTySig tydecl lookupIdxVars
791 792 793 794
    rn_at (tydecl@TySynonym  {}) = 
      do
        checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
        rnTyClDecl tydecl
795 796 797 798 799 800 801 802 803 804
    rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"

    lookupIdxVars _ tyvars cont = mappM lookupIdxVar tyvars >>= cont
    --
    -- Type index variables must be class parameters, which are the only
    -- type variables in scope at this point.
    lookupIdxVar (L l tyvar) =
      do
	name' <- lookupOccRn (hsTyVarName tyvar)
	return $ L l (replaceTyVarName tyvar name')
805

806 807 808
noPatterns = text "Default definition for an associated synonym cannot have"
	     <+> text "type pattern"

809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844
-- This data decl will parse OK
--	data T = a Int
-- treating "a" as the constructor.
-- It is really hard to make the parser spot this malformation.
-- So the renamer has to check that the constructor is legal
--
-- We can get an operator as the constructor, even in the prefix form:
--	data T = :% Int Int
-- from interface files, which always print in prefix form

checkConName name = checkErr (isRdrDataCon name) (badDataCon name)

badDataCon name
   = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)]
\end{code}


%*********************************************************
%*							*
\subsection{Support code to rename types}
%*							*
%*********************************************************

\begin{code}
rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]

rnFds doc fds
  = mappM (wrapLocM rn_fds) fds
  where
    rn_fds (tys1, tys2)
      =	rnHsTyVars doc tys1		`thenM` \ tys1' ->
	rnHsTyVars doc tys2		`thenM` \ tys2' ->
	returnM (tys1', tys2')

rnHsTyVars doc tvs  = mappM (rnHsTyvar doc) tvs
rnHsTyvar doc tyvar = lookupOccRn tyvar
845
\end{code}
846

847 848 849 850 851 852 853

%*********************************************************
%*							*
		Splices
%*							*
%*********************************************************

854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872
Note [Splices]
~~~~~~~~~~~~~~
Consider
	f = ...
	h = ...$(thing "f")...

The splice can expand into literally anything, so when we do dependency
analysis we must assume that it might mention 'f'.  So we simply treat
all locally-defined names as mentioned by any splice.  This is terribly
brutal, but I don't see what else to do.  For example, it'll mean
that every locally-defined thing will appear to be used, so no unused-binding
warnings.  But if we miss the dependency, then we might typecheck 'h' before 'f',
and that will crash the type checker because 'f' isn't in scope.

Currently, I'm not treating a splice as also mentioning every import,
which is a bit inconsistent -- but there are a lot of them.  We might
thereby get some bogus unused-import warnings, but we won't crash the
type checker.  Not very satisfactory really.

873 874 875
\begin{code}
rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars)
rnSplice (HsSplice n expr)
876 877 878 879 880 881 882 883 884 885 886 887 888
  = do	{ checkTH expr "splice"
	; loc  <- getSrcSpanM
	; [n'] <- newLocalsRn [L loc n]
	; (expr', fvs) <- rnLExpr expr

	-- Ugh!  See Note [Splices] above
	; lcl_rdr <- getLocalRdrEnv
	; gbl_rdr <- getGlobalRdrEnv
	; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, 
						    isLocalGRE gre]
	      lcl_names = mkNameSet (occEnvElts lcl_rdr)

	; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) }
889 890 891 892 893 894 895 896 897

#ifdef GHCI 
checkTH e what = returnM ()	-- OK
#else
checkTH e what 	-- Raise an error in a stage-1 compiler
  = addErr (vcat [ptext SLIT("Template Haskell") <+> text what <+>  
	          ptext SLIT("illegal in a stage-1 compiler"),
	          nest 2 (ppr e)])
#endif   
898
\end{code}