RnSource.lhs 40.8 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
	rnSrcDecls, addTcgDUs, rnTyClDecls 
9
    ) where
10

11
#include "HsVersions.h"
sof's avatar
sof committed
12

13 14
import {-# SOURCE #-} RnExpr( rnLExpr )

15
import HsSyn
16
import RdrName		( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
17
import RdrHsSyn		( extractGenericPatTyVars, extractHsRhoRdrTyVars )
18
import RnHsSyn
19
import RnTypes		( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext, rnConDeclFields )
20 21
import RnBinds		( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
                                makeMiniFixityEnv)
22 23
import RnEnv		( lookupLocalDataTcNames, lookupLocatedOccRn,
			  lookupTopBndrRn, lookupLocatedTopBndrRn,
24
			  lookupOccRn, newLocalsRn, 
25
			  bindLocatedLocalsFV, bindPatSigTyVarsFV,
26
			  bindTyVarsRn, extendTyVarEnvFVRn,
Ian Lynagh's avatar
Ian Lynagh committed
27
			  bindLocalNames, checkDupRdrNames, mapFvRn,
28
			  checkM
29
			)
30
import RnNames       	( getLocalNonValBinders, extendGlobalRdrEnvRn )
31
import HscTypes      	( GenAvailInfo(..), availsToNameSet )
32
import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
33
import TcRnMonad
34

Ian Lynagh's avatar
Ian Lynagh committed
35
import HscTypes		( Warnings(..), plusWarns )
36
import Class		( FunDep )
37
import Name		( Name, nameOccName )
38
import NameSet
39
import NameEnv
40
import Outputable
Ian Lynagh's avatar
Ian Lynagh committed
41
import Bag
42
import FastString
43
import SrcLoc
44
import DynFlags	( DynFlag(..) )
45
import Maybe            ( isNothing )
46
import BasicTypes       ( Boxity(..) )
47

Ian Lynagh's avatar
Ian Lynagh committed
48
import ListSetOps    (findDupsEq)
49 50

import Control.Monad
51 52
\end{code}

Ian Lynagh's avatar
Ian Lynagh committed
53 54 55 56 57 58 59 60 61
\begin{code}
-- XXX
thenM :: Monad a => a b -> (b -> a c) -> a c
thenM = (>>=)

thenM_ :: Monad a => a b -> a c -> a c
thenM_ = (>>)
\end{code}

62
@rnSourceDecl@ `renames' declarations.
63 64 65 66 67 68
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.
69 70
(Some of this checking has now been moved to module @TcMonoType@,
since we don't have functional dependency information at this point.)
71 72 73
\item
Checks that all variable occurences are defined.
\item 
74
Checks the @(..)@ etc constraints in the export list.
75 76 77
\end{enumerate}


78
\begin{code}
79
-- Brings the binders of the group into scope in the appropriate places;
80
-- does NOT assume that anything is in scope already
81
rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
82
-- Rename a HsGroup; used for normal source files *and* hs-boot files
83
rnSrcDecls group@(HsGroup {hs_valds  = val_decls,
84 85 86 87
                                   hs_tyclds = tycl_decls,
                                   hs_instds = inst_decls,
                                   hs_derivds = deriv_decls,
                                   hs_fixds  = fix_decls,
Ian Lynagh's avatar
Ian Lynagh committed
88
                                   hs_warnds  = warn_decls,
89
                                   hs_annds  = ann_decls,
90 91 92 93 94 95 96 97 98 99 100
                                   hs_fords  = foreign_decls,
                                   hs_defds  = default_decls,
                                   hs_ruleds = rule_decls,
                                   hs_docs   = docs })
 = do {
   -- (A) Process the fixity declarations, creating a mapping from
   --     FastStrings to FixItems.
   --     Also checks for duplcates.
   local_fix_env <- makeMiniFixityEnv fix_decls;

   -- (B) Bring top level binders (and their fixities) into scope,
101
   --     *except* for the value bindings, which get brought in below.
102 103 104 105
   --     However *do* include class ops, data constructors
   --     And for hs-boot files *do* include the value signatures
   tc_avails <- getLocalNonValBinders group ;
   tc_envs <- extendGlobalRdrEnvRn tc_avails local_fix_env ;
106
   setEnvs tc_envs $ do {
107 108 109 110 111 112 113

   failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations

   -- (C) Extract the mapping from data constructors to field names and
   --     extend the record field env.
   --     This depends on the data constructors and field names being in
   --     scope from (B) above
114
   inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do {
115 116 117 118 119 120 121

   -- (D) Rename the left-hand sides of the value bindings.
   --     This depends on everything from (B) being in scope,
   --     and on (C) for resolving record wild cards.
   --     It uses the fixity env from (A) to bind fixities for view patterns.
   new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
   -- bind the LHSes (and their fixities) in the global rdr environment
122 123 124 125
   let { val_binders = map unLoc $ collectHsValBinders new_lhs ;
	 val_bndr_set = mkNameSet val_binders ;
	 all_bndr_set = val_bndr_set `unionNameSets` availsToNameSet tc_avails ;
         val_avails = map Avail val_binders 
126
       } ;
127
   (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
128
   setEnvs (tcg_env, tcl_env) $ do {
129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146

   --  Now everything is in scope, as the remaining renaming assumes.

   -- (E) Rename type and class decls
   --     (note that value LHSes need to be in scope for default methods)
   --
   -- 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.
   traceRn (text "Start rnTyClDecls") ;
   (rn_tycl_decls, src_fvs1) <- rnList rnTyClDecl tycl_decls ;

   -- (F) Rename Value declarations right-hand sides
   traceRn (text "Start rnmono") ;
147
   (rn_val_decls, bind_dus) <- rnTopBindsRHS val_bndr_set new_lhs ;
148 149 150 151
   traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;

   -- (G) Rename Fixity and deprecations
   
152
   -- Rename fixity declarations and error if we try to
153
   -- fix something from another module (duplicates were checked in (A))
154 155 156
   rn_fix_decls <- rnSrcFixityDecls all_bndr_set fix_decls ;

   -- Rename deprec decls;
157 158
   -- check for duplicates and ensure that deprecated things are defined locally
   -- at the moment, we don't keep these around past renaming
159
   rn_warns <- rnSrcWarnDecls all_bndr_set warn_decls ;
160 161 162 163

   -- (H) Rename Everything else

   (rn_inst_decls,    src_fvs2) <- rnList rnSrcInstDecl   inst_decls ;
164 165 166
   (rn_rule_decls,    src_fvs3) <- setOptM Opt_ScopedTypeVariables $
   		      		   rnList rnHsRuleDecl    rule_decls ;
			   -- Inside RULES, scoped type variables are on
167
   (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
168 169 170
   (rn_ann_decls,     src_fvs5) <- rnList rnAnnDecl       ann_decls ;
   (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl   default_decls ;
   (rn_deriv_decls,   src_fvs7) <- rnList rnSrcDerivDecl  deriv_decls ;
171 172 173 174 175
      -- Haddock docs; no free vars
   rn_docs <- mapM (wrapLocM rnDocDecl) docs ;

   -- (I) Compute the results and return
   let {rn_group = HsGroup { hs_valds  = rn_val_decls,
176 177
			     hs_tyclds = rn_tycl_decls,
			     hs_instds = rn_inst_decls,
178
                             hs_derivds = rn_deriv_decls,
179
			     hs_fixds  = rn_fix_decls,
Ian Lynagh's avatar
Ian Lynagh committed
180
			     hs_warnds = [], -- warns are returned in the tcg_env
181 182
	                                     -- (see below) not in the HsGroup
			     hs_fords  = rn_foreign_decls,
183
			     hs_annds   = rn_ann_decls,
184 185
			     hs_defds  = rn_default_decls,
			     hs_ruleds = rn_rule_decls,
186
                             hs_docs   = rn_docs } ;
187

188 189
	other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, 
			     src_fvs5, src_fvs6, src_fvs7] ;
190
	src_dus = bind_dus `plusDU` usesOnly other_fvs;
191 192 193 194
		-- 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.
195

196 197
       final_tcg_env = let tcg_env' = (tcg_env `addTcgDUs` src_dus)
                       in -- we return the deprecs in the env, not in the HsGroup above
Ian Lynagh's avatar
Ian Lynagh committed
198
                         tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
199 200 201 202 203 204 205 206 207 208 209 210
       } ;

   traceRn (text "finish rnSrc" <+> ppr rn_group) ;
   traceRn (text "finish Dus" <+> ppr src_dus ) ;
   return (final_tcg_env , rn_group)
                    }}}}

-- some utils because we do this a bunch above
-- compute and install the new env
inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a
inNewEnv env cont = do e <- env
                       setGblEnv e $ cont e
211

212
rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
213
-- Used for external core
Ian Lynagh's avatar
Ian Lynagh committed
214
rnTyClDecls tycl_decls = do  (decls', _fvs) <- rnList rnTyClDecl tycl_decls
215
			     return decls'
216 217

addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv 
218 219
-- This function could be defined lower down in the module hierarchy, 
-- but there doesn't seem anywhere very logical to put it.
220
addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
221 222 223

rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
rnList f xs = mapFvRn (wrapLocFstM f) xs
224 225 226 227 228 229 230 231 232 233
\end{code}


%*********************************************************
%*						 	 *
	HsDoc stuff
%*							 *
%*********************************************************

\begin{code}
234 235 236 237 238 239 240 241 242 243 244 245 246
rnDocDecl :: DocDecl RdrName -> RnM (DocDecl Name)
rnDocDecl (DocCommentNext doc) = do 
  rn_doc <- rnHsDoc doc
  return (DocCommentNext rn_doc)
rnDocDecl (DocCommentPrev doc) = do 
  rn_doc <- rnHsDoc doc
  return (DocCommentPrev rn_doc)
rnDocDecl (DocCommentNamed str doc) = do
  rn_doc <- rnHsDoc doc
  return (DocCommentNamed str rn_doc)
rnDocDecl (DocGroup lev doc) = do
  rn_doc <- rnHsDoc doc
  return (DocGroup lev rn_doc)
247 248 249 250 251 252 253 254 255 256
\end{code}


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

\begin{code}
257
rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name]
258 259 260
-- Rename the fixity decls, so we can put
-- the renamed decls in the renamed syntax tree
-- Errors if the thing being fixed is not defined locally.
261 262 263
--
-- The returned FixitySigs are not actually used for anything,
-- except perhaps the GHCi API
264
rnSrcFixityDecls bound_names fix_decls
265 266 267 268
  = do fix_decls <- mapM rn_decl fix_decls
       return (concat fix_decls)
  where
    rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
269
        -- GHC extension: look up both the tycon and data con 
270
	-- for con-like things; hence returning a list
271
	-- If neither are in scope, report an error; otherwise
272
	-- return a fixity sig for each (slightly odd)
273 274
    rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity))
      = setSrcSpan name_loc $
275
                    -- this lookup will fail if the definition isn't local
276
        do names <- lookupLocalDataTcNames bound_names what rdr_name
277
           return [ L loc (FixitySig (L name_loc name) fixity)
278 279
                  | name <- names ]
    what = ptext (sLit "fixity signature")
280 281 282 283 284 285 286 287 288
\end{code}


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

289 290 291
Check that the deprecated names are defined, are defined locally, and
that there are no duplicate deprecations.

292 293 294 295
It's only imported deprecations, dealt with in RnIfaces, that we
gather them together.

\begin{code}
296
-- checks that the deprecations are defined locally, and that there are no duplicates
297 298
rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings
rnSrcWarnDecls _bound_names [] 
299
  = return NoWarnings
300

301
rnSrcWarnDecls bound_names decls 
302
  = do { -- check for duplicates
303 304 305
       ; mapM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupWarnDecl lrdr')) warn_rdr_dups
       ; mapM (addLocM rn_deprec) decls	`thenM` \ pairs_s ->
         return (WarnSome ((concat pairs_s))) }
306
 where
Ian Lynagh's avatar
Ian Lynagh committed
307
   rn_deprec (Warning rdr_name txt)
308
       -- ensures that the names are defined locally
309
     = lookupLocalDataTcNames bound_names what rdr_name	`thenM` \ names ->
310
       return [(nameOccName name, txt) | name <- names]
311
   
312 313
   what = ptext (sLit "deprecation")

314 315 316
   -- look for duplicates among the OccNames;
   -- we check that the names are defined above
   -- invt: the lists returned by findDupsEq always have at least two elements
Ian Lynagh's avatar
Ian Lynagh committed
317 318
   warn_rdr_dups = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
                     (map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls)
319
               
Ian Lynagh's avatar
Ian Lynagh committed
320
dupWarnDecl :: Located RdrName -> RdrName -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
321
-- Located RdrName -> DeprecDecl RdrName -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
322 323
dupWarnDecl (L loc _) rdr_name
  = vcat [ptext (sLit "Multiple warning declarations for") <+> quotes (ppr rdr_name),
Ian Lynagh's avatar
Ian Lynagh committed
324
          ptext (sLit "also at ") <+> ppr loc]
325

326
\end{code}
327

328 329
%*********************************************************
%*							*
330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349
\subsection{Annotation declarations}
%*							*
%*********************************************************

\begin{code}
rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars)
rnAnnDecl (HsAnnotation provenance expr) = do
    (provenance', provenance_fvs) <- rnAnnProvenance provenance
    (expr', expr_fvs) <- rnLExpr expr
    return (HsAnnotation provenance' expr', provenance_fvs `plusFV` expr_fvs)

rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars)
rnAnnProvenance provenance = do
    provenance' <- modifyAnnProvenanceNameM lookupTopBndrRn provenance
    return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))
\end{code}

%*********************************************************
%*							*
\subsection{Default declarations}
350 351
%*							*
%*********************************************************
352

353
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
354
rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars)
355 356
rnDefaultDecl (DefaultDecl tys)
  = mapFvRn (rnHsTypeFVs doc_str) tys	`thenM` \ (tys', fvs) ->
357
    return (DefaultDecl tys', fvs)
358
  where
359
    doc_str = text "In a `default' declaration"
360 361
\end{code}

362 363 364 365 366 367 368
%*********************************************************
%*							*
\subsection{Foreign declarations}
%*							*
%*********************************************************

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
369
rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
Simon Marlow's avatar
Simon Marlow committed
370
rnHsForeignDecl (ForeignImport name ty spec)
371
  = lookupLocatedTopBndrRn name	        `thenM` \ name' ->
372
    rnHsTypeFVs (fo_decl_msg name) ty	`thenM` \ (ty', fvs) ->
373
    return (ForeignImport name' ty' spec, fvs)
374

Simon Marlow's avatar
Simon Marlow committed
375
rnHsForeignDecl (ForeignExport name ty spec)
376
  = lookupLocatedOccRn name	        `thenM` \ name' ->
377
    rnHsTypeFVs (fo_decl_msg name) ty  	`thenM` \ (ty', fvs) ->
378
    return (ForeignExport name' ty' spec, fvs `addOneFV` unLoc name')
379 380 381
	-- 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
382

Ian Lynagh's avatar
Ian Lynagh committed
383
fo_decl_msg :: Located RdrName -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
384
fo_decl_msg name = ptext (sLit "In the foreign declaration for") <+> ppr name
385 386 387 388 389 390 391 392 393 394
\end{code}


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

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
395
rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
396
rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
397
	-- Used for both source and interface file decls
398
  = rnHsSigType (text "an instance decl") inst_ty	`thenM` \ inst_ty' ->
399

400 401 402
	-- Rename the bindings
	-- The typechecker (not the renamer) checks that all 
	-- the bindings are for the right class
403
    let
404
	meth_doc    = text "In the bindings in an instance declaration"
405 406
	meth_names  = collectHsBindLocatedBinders mbinds
	(inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
407
    in
408 409 410 411 412 413 414 415 416 417
    checkDupRdrNames meth_doc meth_names 	`thenM_`
	-- Check that the same method is not given twice in the
	-- same instance decl	instance C T where
	--			      f x = ...
	--			      g y = ...
	--			      f x = ...
	-- We must use checkDupRdrNames because the Name of the
	-- method is the Name of the class selector, whose SrcSpan
	-- points to the class declaration

418
    extendTyVarEnvForMethodBinds inst_tyvars (		
419 420
	-- (Slightly strangely) the forall-d tyvars scope over
	-- the method bindings too
Ian Lynagh's avatar
Ian Lynagh committed
421
	rnMethodBinds cls (\_ -> []) 	-- No scoped tyvars
422
		      [] mbinds
423
    )						`thenM` \ (mbinds', meth_fvs) ->
424 425 426 427 428 429 430 431 432 433 434 435
	-- 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 of an instance declaration"
	at_names = map (head . tyClDeclNames . unLoc) ats
    in
    checkDupRdrNames at_doc at_names		`thenM_`
	-- See notes with checkDupRdrNames for methods, above

    rnATInsts ats				`thenM` \ (ats', at_fvs) ->

436 437 438 439 440 441 442
	-- 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
443
    let 
444
	binders = collectHsBindBinders mbinds'
445
	bndr_set = mkNameSet binders
446
    in
447 448
    bindLocalNames binders 
	(renameSigs (Just bndr_set) okInstDclSig uprags)	`thenM` \ uprags' ->
449

450
    return (InstDecl inst_ty' mbinds' uprags' ats',
451 452
	     meth_fvs `plusFV` at_fvs
		      `plusFV` hsSigsFVs uprags'
453
		      `plusFV` extractHsTyNames inst_ty')
454 455 456 457 458 459 460 461 462 463 464 465
             -- 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}

466
Renaming of the associated types in instances.  
467

468
\begin{code}
469
rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
470
rnATInsts atDecls = rnList rnATInst atDecls
471
  where
472
    rnATInst tydecl@TyData     {} = rnTyClDecl tydecl
473
    rnATInst tydecl@TySynonym  {} = rnTyClDecl tydecl
474 475 476
    rnATInst tydecl               =
      pprPanic "RnSource.rnATInsts: invalid AT instance" 
	       (ppr (tcdName tydecl))
477 478
\end{code}

479 480 481 482
For the method bindings in class and instance decls, we extend the 
type variable environment iff -fglasgow-exts

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
483 484 485
extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name]
                             -> RnM (Bag (LHsBind Name), FreeVars)
                             -> RnM (Bag (LHsBind Name), FreeVars)
486
extendTyVarEnvForMethodBinds tyvars thing_inside
487 488 489 490 491
  = do	{ scoped_tvs <- doptM Opt_ScopedTypeVariables
	; if scoped_tvs then
		extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
	  else
		thing_inside }
492 493
\end{code}

494 495 496 497 498 499 500 501
%*********************************************************
%*							*
\subsection{Stand-alone deriving declarations}
%*							*
%*********************************************************

\begin{code}
rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
502
rnSrcDerivDecl (DerivDecl ty)
503
  = do ty' <- rnLHsType (text "a deriving decl") ty
504 505
       let fvs = extractHsTyNames ty'
       return (DerivDecl ty', fvs)
506
\end{code}
507

508 509 510 511 512 513 514
%*********************************************************
%*							*
\subsection{Rules}
%*							*
%*********************************************************

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
515 516
rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
517 518
  = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)	$
    bindLocatedLocalsFV doc (map get_var vars)		$ \ ids ->
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
519 520 521
    do	{ (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids)
		-- NB: The binders in a rule are always Ids
		--     We don't (yet) support type variables
522

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
523 524
	; (lhs', fv_lhs') <- rnLExpr lhs
	; (rhs', fv_rhs') <- rnLExpr rhs
525

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
526
	; checkValidRule rule_name ids lhs' fv_lhs'
527

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
528 529
	; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
		  fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') }
530
  where
531
    doc = text "In the transformation rule" <+> ftext rule_name
532 533 534 535
  
    get_var (RuleBndr v)      = v
    get_var (RuleBndrSig v _) = v

Ian Lynagh's avatar
Ian Lynagh committed
536
    rn_var (RuleBndr (L loc _), id)
537
	= return (RuleBndr (L loc id), emptyFVs)
Ian Lynagh's avatar
Ian Lynagh committed
538
    rn_var (RuleBndrSig (L loc _) t, id)
539
	= rnHsTypeFVs doc t	`thenM` \ (t', fvs) ->
540
	  return (RuleBndrSig (L loc id) t', fvs)
541

Ian Lynagh's avatar
Ian Lynagh committed
542
badRuleVar :: FastString -> Name -> SDoc
543
badRuleVar name var
Ian Lynagh's avatar
Ian Lynagh committed
544 545 546
  = 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")]
547 548
\end{code}

549 550 551 552 553
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.  
554

555 556 557
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.)
558

559 560 561 562
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.
	
563
\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
564
checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()
565 566 567 568 569 570 571 572
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')]
Ian Lynagh's avatar
Ian Lynagh committed
573
	; mapM_ (addErr . badRuleVar rule_name) bad_vars }
574

575
validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
576 577
-- Nothing => OK
-- Just e  => Not ok, and e is the offending expression
578
validRuleLhs foralls lhs
579
  = checkl lhs
580
  where
Ian Lynagh's avatar
Ian Lynagh committed
581
    checkl (L _ e) = check e
582

583 584
    check (OpApp e1 op _ e2)		  = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
    check (HsApp e1 e2) 		  = checkl e1 `mplus` checkl_e e2
585 586 587
    check (HsVar v) | v `notElem` foralls = Nothing
    check other				  = Just other 	-- Failure

588
	-- Check an argument
Ian Lynagh's avatar
Ian Lynagh committed
589
    checkl_e (L _ _e) = Nothing 	-- Was (check_e e); see Note [Rule LHS validity checking]
590

591
{-	Commented out; see Note [Rule LHS validity checking] above 
592
    check_e (HsVar v)     = Nothing
593
    check_e (HsPar e) 	  = checkl_e e
594 595 596
    check_e (HsLit e) 	  = Nothing
    check_e (HsOverLit e) = Nothing

597 598
    check_e (OpApp e1 op _ e2) 	 = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
    check_e (HsApp e1 e2)      	 = checkl_e e1 `mplus` checkl_e e2
599 600
    check_e (NegApp e _)       	 = checkl_e e
    check_e (ExplicitList _ es)	 = checkl_es es
601 602
    check_e other		 = Just other	-- Fails

603
    checkl_es es = foldr (mplus . checkl_e) Nothing es
604
-}
605

Ian Lynagh's avatar
Ian Lynagh committed
606
badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
607
badRuleLhsErr name lhs bad_e
Ian Lynagh's avatar
Ian Lynagh committed
608 609 610
  = 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])]
611
    $$
Ian Lynagh's avatar
Ian Lynagh committed
612
    ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd")
613 614
\end{code}

615

616 617
%*********************************************************
%*							*
618
\subsection{Type, class and iface sig declarations}
619 620 621 622 623 624 625 626 627
%*							*
%*********************************************************

@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
628 629 630 631 632 633
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.
634 635

\begin{code}
Ian Lynagh's avatar
Ian Lynagh committed
636
rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars)
637 638
rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name})
  = lookupLocatedTopBndrRn name		`thenM` \ name' ->
639
    return (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name},
640
	     emptyFVs)
641

642 643 644 645 646 647
-- all flavours of type family declarations ("type family", "newtype fanily",
-- and "data family")
rnTyClDecl (tydecl@TyFamily {}) =
  rnFamily tydecl bindTyVarsRn

-- "data", "newtype", "data instance, and "newtype instance" declarations
648
rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, 
649 650
			   tcdLName = tycon, tcdTyVars = tyvars, 
			   tcdTyPats = typatsMaybe, tcdCons = condecls, 
651
			   tcdKindSig = sig, tcdDerivs = derivs}
652
  | is_vanilla	          -- Normal Haskell data type decl
653
  = ASSERT( isNothing sig )	-- In normal H98 form, kind signature on the 
654 655 656
				-- data type is syntactically illegal 
    ASSERT( distinctTyVarBndrs tyvars )   -- Tyvars should be distinct	
    do  { bindTyVarsRn data_doc tyvars                  $ \ tyvars' -> do
657
    	{ tycon' <- if isFamInstDecl tydecl
658 659
		    then lookupLocatedOccRn     tycon -- may be imported family
		    else lookupLocatedTopBndrRn tycon
660
	; context' <- rnContext data_doc context
661
	; typats' <- rnTyPats data_doc typatsMaybe
662
	; condecls' <- rnConDecls (unLoc tycon') condecls
663
		-- No need to check for duplicate constructor decls
664
		-- since that is done by RnNames.extendGlobalRdrEnvRn
665
	; (derivs', deriv_fvs) <- rn_derivs derivs
666
	; return (TyData {tcdND = new_or_data, tcdCtxt = context', 
667 668 669
			   tcdLName = tycon', tcdTyVars = tyvars', 
			   tcdTyPats = typats', tcdKindSig = Nothing, 
			   tcdCons = condecls', tcdDerivs = derivs'}, 
670 671
		   delFVs (map hsLTyVarName tyvars')	$
	     	   extractHsCtxtTyNames context'	`plusFV`
672
	     	   plusFVs (map conDeclFVs condecls')   `plusFV`
673
	     	   deriv_fvs				`plusFV`
674
		   (if isFamInstDecl tydecl
675 676
		   then unitFV (unLoc tycon')	-- type instance => use
		   else emptyFVs)) 
677
        } }
678

679
  | otherwise	          -- GADT
680
  = do	{ tycon' <- if isFamInstDecl tydecl
681 682
		    then lookupLocatedOccRn     tycon -- may be imported family
		    else lookupLocatedTopBndrRn tycon
683
	; checkTc (null (unLoc context)) (badGadtStupidTheta tycon)
684 685 686 687
    	; (tyvars', typats')
		<- bindTyVarsRn data_doc tyvars $ \ tyvars' -> do
		   { typats' <- rnTyPats data_doc typatsMaybe
		   ; return (tyvars', typats') }
688 689 690
		-- For GADTs, the type variables in the declaration 
		-- do not scope over the constructor signatures
		-- 	data T a where { T1 :: forall b. b-> b }
691

692
	; condecls' <- rnConDecls (unLoc tycon') condecls
693
		-- No need to check for duplicate constructor decls
694
		-- since that is done by RnNames.extendGlobalRdrEnvRn
695

696
	; (derivs', deriv_fvs) <- rn_derivs derivs
697
	; return (TyData {tcdND = new_or_data, tcdCtxt = noLoc [], 
698
			   tcdLName = tycon', tcdTyVars = tyvars', 
699
			   tcdTyPats = typats', tcdKindSig = sig,
700
			   tcdCons = condecls', tcdDerivs = derivs'}, 
701 702
	     	   plusFVs (map conDeclFVs condecls') `plusFV` 
		   deriv_fvs			      `plusFV`
703
		   (if isFamInstDecl tydecl
704 705 706
		   then unitFV (unLoc tycon')	-- type instance => use
		   else emptyFVs))
        }
sof's avatar
sof committed
707
  where
708 709
    is_vanilla = case condecls of	-- Yuk
		     [] 		   -> True
710
		     L _ (ConDecl { con_res = ResTyH98 }) : _  -> True
Ian Lynagh's avatar
Ian Lynagh committed
711
		     _    		   -> False
712

713
    data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
714

715
    rn_derivs Nothing   = return (Nothing, emptyFVs)
716
    rn_derivs (Just ds) = rnLHsTypes data_doc ds	`thenM` \ ds' -> 
717
			  return (Just ds', extractHsTyNames_s ds')
718

719
-- "type" and "type instance" declarations
720
rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
721
			      tcdTyPats = typatsMaybe, tcdSynRhs = ty})
722 723
  = ASSERT( distinctTyVarBndrs tyvars )   -- Tyvars should be distinct	
    do { bindTyVarsRn syn_doc tyvars                    $ \ tyvars' -> do
724
       { name' <- if isFamInstDecl tydecl
725 726
		  then lookupLocatedOccRn     name -- may be imported family
		  else lookupLocatedTopBndrRn name
727 728
       ; typats' <- rnTyPats syn_doc typatsMaybe
       ; (ty', fvs) <- rnHsTypeFVs syn_doc ty
729
       ; return (TySynonym {tcdLName = name', tcdTyVars = tyvars', 
730
			     tcdTyPats = typats', tcdSynRhs = ty'},
731 732
	          delFVs (map hsLTyVarName tyvars') $
		  fvs			      `plusFV`
733
		   (if isFamInstDecl tydecl
734 735
		   then unitFV (unLoc name')	-- type instance => use
		   else emptyFVs))
736
       } }
sof's avatar
sof committed
737
  where
738
    syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
739

740
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, 
741
		       tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
742
		       tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
743
  = do	{ cname' <- lookupLocatedTopBndrRn cname
sof's avatar
sof committed
744

745
	-- Tyvars scope over superclass context and method signatures
746 747 748 749 750
	; (tyvars', context', fds', ats', ats_fvs, sigs')
	    <- bindTyVarsRn cls_doc tyvars $ \ tyvars' -> do
	     { context' <- rnContext cls_doc context
	     ; fds' <- rnFds cls_doc fds
	     ; (ats', ats_fvs) <- rnATs ats
751
	     ; sigs' <- renameSigs Nothing okClsDclSig sigs
752
	     ; return   (tyvars', context', fds', ats', ats_fvs, sigs') }
753

754
	-- No need to check for duplicate associated type decls
755
	-- since that is done by RnNames.extendGlobalRdrEnvRn
756

757
	-- Check the signatures
758
	-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
759
	; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
760
	; checkDupRdrNames sig_doc sig_rdr_names_w_locs
761 762 763 764
		-- 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.
765

766
   	-- The newLocals call is tiresome: given a generic class decl
767 768 769 770 771 772 773
	--	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.  
774 775 776
	; (mbinds', meth_fvs) 
	    <- extendTyVarEnvForMethodBinds tyvars' $ do
	    { name_env <- getLocalRdrEnv
Ian Lynagh's avatar
Ian Lynagh committed
777
	    ; let gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
778
	    		 		         not (unLoc tv `elemLocalRdrEnv` name_env) ]
779
		-- No need to check for duplicate method signatures
780
		-- since that is done by RnNames.extendGlobalRdrEnvRn
781
		-- and the methods are already in scope
782 783 784
	    ; gen_tyvars <- newLocalsRn gen_rdr_tyvars_w_locs
	    ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }

785 786
  -- Haddock docs 
	; docs' <- mapM (wrapLocM rnDocDecl) docs
787 788 789 790 791 792 793 794 795 796 797

	; return (ClassDecl { tcdCtxt = context', tcdLName = cname', 
			      tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
			      tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},

	     	  delFVs (map hsLTyVarName tyvars')	$
	     	  extractHsCtxtTyNames context'	    	`plusFV`
	     	  plusFVs (map extractFunDepNames (map unLoc fds'))  `plusFV`
	     	  hsSigsFVs sigs'		  	`plusFV`
	     	  meth_fvs				`plusFV`
	     	  ats_fvs) }
798 799 800
  where
    cls_doc  = text "In the declaration for class" 	<+> ppr cname
    sig_doc  = text "In the signatures for class"  	<+> ppr cname
801

802 803 804 805 806 807 808
distinctTyVarBndrs :: [LHsTyVarBndr RdrName] -> Bool
-- The tyvar binders should have distinct names
distinctTyVarBndrs tvs 
  = null (findDupsEq eq tvs)
  where
    eq (L _ v1) (L _ v2) = hsTyVarName v1 == hsTyVarName v2

Ian Lynagh's avatar
Ian Lynagh committed
809 810
badGadtStupidTheta :: Located RdrName -> SDoc
badGadtStupidTheta _
Ian Lynagh's avatar
Ian Lynagh committed
811 812
  = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
	  ptext (sLit "(You can put a context on each contructor, though.)")]
813 814
\end{code}

815

816 817
%*********************************************************
%*							*
818
\subsection{Support code for type/data declarations}
819 820 821 822
%*							*
%*********************************************************

\begin{code}
823
-- Although, we are processing type patterns here, all type variables will
824 825 826 827 828 829 830
-- 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

831
rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name]
Ian Lynagh's avatar
Ian Lynagh committed
832
rnConDecls _tycon condecls
833
  = mapM (wrapLocM rnConDecl) condecls
834

835
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
836 837 838 839
rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
                   	, con_cxt = cxt, con_details = details
                   	, con_res = res_ty, con_doc = mb_doc
                   	, con_old_rec = old_rec, con_explicit = expl })
840
  = do	{ addLocM checkConName name
841
    	; when old_rec (addWarn (deprecRecSyntax decl))
sof's avatar
sof committed
842

843 844 845 846 847 848 849
	; 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
850
	      arg_tys       = hsConDeclArgTys details
851
	      implicit_tvs  = case res_ty of
852
	      	    		ResTyH98     -> filter not_in_scope $
853 854
						get_rdr_tvs arg_tys
	      	    		ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
855 856 857
	      new_tvs = case expl of
	        	  Explicit -> tvs
		    	  Implicit -> userHsTyVarBndrs implicit_tvs
858

859
        ; mb_doc' <- rnMbLHsDoc mb_doc 
860

861
        ; bindTyVarsRn doc new_tvs $ \new_tyvars -> do
862