~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to compiler/rename/RnSource.lhs

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
ImportĀ upstreamĀ versionĀ 7.0.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
 
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, rnTyClDecls, findSplice
 
9
    ) where
 
10
 
 
11
#include "HsVersions.h"
 
12
 
 
13
import {-# SOURCE #-} RnExpr( rnLExpr )
 
14
#ifdef GHCI
 
15
import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl )
 
16
#endif  /* GHCI */
 
17
 
 
18
import HsSyn
 
19
import RdrName          ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc )
 
20
import RdrHsSyn         ( extractGenericPatTyVars, extractHsRhoRdrTyVars )
 
21
import RnHsSyn
 
22
import RnTypes          ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext, rnConDeclFields )
 
23
import RnBinds          ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
 
24
                                makeMiniFixityEnv)
 
25
import RnEnv            ( lookupLocalDataTcNames, lookupLocatedOccRn,
 
26
                          lookupTopBndrRn, lookupLocatedTopBndrRn,
 
27
                          lookupOccRn, newLocalBndrsRn, bindLocalNamesFV,
 
28
                          bindLocatedLocalsFV, bindPatSigTyVarsFV,
 
29
                          bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn,
 
30
                          bindLocalNames, checkDupRdrNames, mapFvRn
 
31
                        )
 
32
import RnNames          ( getLocalNonValBinders, extendGlobalRdrEnvRn )
 
33
import HscTypes         ( GenAvailInfo(..), availsToNameSet )
 
34
import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
 
35
import TcRnMonad
 
36
 
 
37
import ForeignCall      ( CCallTarget(..) )
 
38
import Module
 
39
import HscTypes         ( Warnings(..), plusWarns )
 
40
import Class            ( FunDep )
 
41
import Name             ( Name, nameOccName )
 
42
import NameSet
 
43
import NameEnv
 
44
import Outputable
 
45
import Bag
 
46
import FastString
 
47
import Util             ( filterOut )
 
48
import SrcLoc
 
49
import DynFlags
 
50
import HscTypes         ( HscEnv, hsc_dflags )
 
51
import BasicTypes       ( Boxity(..) )
 
52
import ListSetOps       ( findDupsEq )
 
53
 
 
54
 
 
55
import Control.Monad
 
56
import Data.Maybe
 
57
\end{code}
 
58
 
 
59
\begin{code}
 
60
-- XXX
 
61
thenM :: Monad a => a b -> (b -> a c) -> a c
 
62
thenM = (>>=)
 
63
 
 
64
thenM_ :: Monad a => a b -> a c -> a c
 
65
thenM_ = (>>)
 
66
\end{code}
 
67
 
 
68
@rnSourceDecl@ `renames' declarations.
 
69
It simultaneously performs dependency analysis and precedence parsing.
 
70
It also does the following error checks:
 
71
\begin{enumerate}
 
72
\item
 
73
Checks that tyvars are used properly. This includes checking
 
74
for undefined tyvars, and tyvars in contexts that are ambiguous.
 
75
(Some of this checking has now been moved to module @TcMonoType@,
 
76
since we don't have functional dependency information at this point.)
 
77
\item
 
78
Checks that all variable occurences are defined.
 
79
\item 
 
80
Checks the @(..)@ etc constraints in the export list.
 
81
\end{enumerate}
 
82
 
 
83
 
 
84
\begin{code}
 
85
-- Brings the binders of the group into scope in the appropriate places;
 
86
-- does NOT assume that anything is in scope already
 
87
rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
 
88
-- Rename a HsGroup; used for normal source files *and* hs-boot files
 
89
rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
 
90
                            hs_tyclds  = tycl_decls,
 
91
                            hs_instds  = inst_decls,
 
92
                            hs_derivds = deriv_decls,
 
93
                            hs_fixds   = fix_decls,
 
94
                            hs_warnds  = warn_decls,
 
95
                            hs_annds   = ann_decls,
 
96
                            hs_fords   = foreign_decls,
 
97
                            hs_defds   = default_decls,
 
98
                            hs_ruleds  = rule_decls,
 
99
                            hs_docs    = docs })
 
100
 = do {
 
101
   -- (A) Process the fixity declarations, creating a mapping from
 
102
   --     FastStrings to FixItems.
 
103
   --     Also checks for duplcates.
 
104
   local_fix_env <- makeMiniFixityEnv fix_decls;
 
105
 
 
106
   -- (B) Bring top level binders (and their fixities) into scope,
 
107
   --     *except* for the value bindings, which get brought in below.
 
108
   --     However *do* include class ops, data constructors
 
109
   --     And for hs-boot files *do* include the value signatures
 
110
   tc_avails <- getLocalNonValBinders group ;
 
111
   tc_envs <- extendGlobalRdrEnvRn tc_avails local_fix_env ;
 
112
   setEnvs tc_envs $ do {
 
113
 
 
114
   failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
 
115
 
 
116
   -- (C) Extract the mapping from data constructors to field names and
 
117
   --     extend the record field env.
 
118
   --     This depends on the data constructors and field names being in
 
119
   --     scope from (B) above
 
120
   inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do {
 
121
 
 
122
   -- (D) Rename the left-hand sides of the value bindings.
 
123
   --     This depends on everything from (B) being in scope,
 
124
   --     and on (C) for resolving record wild cards.
 
125
   --     It uses the fixity env from (A) to bind fixities for view patterns.
 
126
   new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
 
127
   -- bind the LHSes (and their fixities) in the global rdr environment
 
128
   let { val_binders = collectHsValBinders new_lhs ;
 
129
         val_bndr_set = mkNameSet val_binders ;
 
130
         all_bndr_set = val_bndr_set `unionNameSets` availsToNameSet tc_avails ;
 
131
         val_avails = map Avail val_binders 
 
132
       } ;
 
133
   (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
 
134
   setEnvs (tcg_env, tcl_env) $ do {
 
135
 
 
136
   --  Now everything is in scope, as the remaining renaming assumes.
 
137
 
 
138
   -- (E) Rename type and class decls
 
139
   --     (note that value LHSes need to be in scope for default methods)
 
140
   --
 
141
   -- You might think that we could build proper def/use information
 
142
   -- for type and class declarations, but they can be involved
 
143
   -- in mutual recursion across modules, and we only do the SCC
 
144
   -- analysis for them in the type checker.
 
145
   -- So we content ourselves with gathering uses only; that
 
146
   -- means we'll only report a declaration as unused if it isn't
 
147
   -- mentioned at all.  Ah well.
 
148
   traceRn (text "Start rnTyClDecls") ;
 
149
   (rn_tycl_decls, src_fvs1) <- rnList rnTyClDecl tycl_decls ;
 
150
 
 
151
   -- (F) Rename Value declarations right-hand sides
 
152
   traceRn (text "Start rnmono") ;
 
153
   (rn_val_decls, bind_dus) <- rnTopBindsRHS new_lhs ;
 
154
   traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
 
155
 
 
156
   -- (G) Rename Fixity and deprecations
 
157
   
 
158
   -- Rename fixity declarations and error if we try to
 
159
   -- fix something from another module (duplicates were checked in (A))
 
160
   rn_fix_decls <- rnSrcFixityDecls all_bndr_set fix_decls ;
 
161
 
 
162
   -- Rename deprec decls;
 
163
   -- check for duplicates and ensure that deprecated things are defined locally
 
164
   -- at the moment, we don't keep these around past renaming
 
165
   rn_warns <- rnSrcWarnDecls all_bndr_set warn_decls ;
 
166
 
 
167
   -- (H) Rename Everything else
 
168
 
 
169
   (rn_inst_decls,    src_fvs2) <- rnList rnSrcInstDecl   inst_decls ;
 
170
   (rn_rule_decls,    src_fvs3) <- setOptM Opt_ScopedTypeVariables $
 
171
                                   rnList rnHsRuleDecl    rule_decls ;
 
172
                           -- Inside RULES, scoped type variables are on
 
173
   (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
 
174
   (rn_ann_decls,     src_fvs5) <- rnList rnAnnDecl       ann_decls ;
 
175
   (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl   default_decls ;
 
176
   (rn_deriv_decls,   src_fvs7) <- rnList rnSrcDerivDecl  deriv_decls ;
 
177
      -- Haddock docs; no free vars
 
178
   rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
 
179
 
 
180
   -- (I) Compute the results and return
 
181
   let {rn_group = HsGroup { hs_valds   = rn_val_decls,
 
182
                             hs_tyclds  = rn_tycl_decls,
 
183
                             hs_instds  = rn_inst_decls,
 
184
                             hs_derivds = rn_deriv_decls,
 
185
                             hs_fixds   = rn_fix_decls,
 
186
                             hs_warnds  = [], -- warns are returned in the tcg_env
 
187
                                             -- (see below) not in the HsGroup
 
188
                             hs_fords  = rn_foreign_decls,
 
189
                             hs_annds  = rn_ann_decls,
 
190
                             hs_defds  = rn_default_decls,
 
191
                             hs_ruleds = rn_rule_decls,
 
192
                             hs_docs   = rn_docs } ;
 
193
 
 
194
        tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ;
 
195
        ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ;
 
196
        other_def  = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ;
 
197
        other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, 
 
198
                              src_fvs5, src_fvs6, src_fvs7] ;
 
199
                -- It is tiresome to gather the binders from type and class decls
 
200
 
 
201
        src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
 
202
                -- Instance decls may have occurrences of things bound in bind_dus
 
203
                -- so we must put other_fvs last
 
204
 
 
205
        final_tcg_env = let tcg_env' = (tcg_env `addTcgDUs` src_dus)
 
206
                        in -- we return the deprecs in the env, not in the HsGroup above
 
207
                        tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
 
208
       } ;
 
209
 
 
210
   traceRn (text "finish rnSrc" <+> ppr rn_group) ;
 
211
   traceRn (text "finish Dus" <+> ppr src_dus ) ;
 
212
   return (final_tcg_env, rn_group)
 
213
                    }}}}
 
214
 
 
215
-- some utils because we do this a bunch above
 
216
-- compute and install the new env
 
217
inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a
 
218
inNewEnv env cont = do e <- env
 
219
                       setGblEnv e $ cont e
 
220
 
 
221
rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name]
 
222
-- Used for external core
 
223
rnTyClDecls tycl_decls = do  (decls', _fvs) <- rnList rnTyClDecl tycl_decls
 
224
                             return decls'
 
225
 
 
226
addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv 
 
227
-- This function could be defined lower down in the module hierarchy, 
 
228
-- but there doesn't seem anywhere very logical to put it.
 
229
addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
 
230
 
 
231
rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
 
232
rnList f xs = mapFvRn (wrapLocFstM f) xs
 
233
\end{code}
 
234
 
 
235
 
 
236
%*********************************************************
 
237
%*                                                       *
 
238
        HsDoc stuff
 
239
%*                                                       *
 
240
%*********************************************************
 
241
 
 
242
\begin{code}
 
243
rnDocDecl :: DocDecl -> RnM DocDecl
 
244
rnDocDecl (DocCommentNext doc) = do 
 
245
  rn_doc <- rnHsDoc doc
 
246
  return (DocCommentNext rn_doc)
 
247
rnDocDecl (DocCommentPrev doc) = do 
 
248
  rn_doc <- rnHsDoc doc
 
249
  return (DocCommentPrev rn_doc)
 
250
rnDocDecl (DocCommentNamed str doc) = do
 
251
  rn_doc <- rnHsDoc doc
 
252
  return (DocCommentNamed str rn_doc)
 
253
rnDocDecl (DocGroup lev doc) = do
 
254
  rn_doc <- rnHsDoc doc
 
255
  return (DocGroup lev rn_doc)
 
256
\end{code}
 
257
 
 
258
 
 
259
%*********************************************************
 
260
%*                                                       *
 
261
        Source-code fixity declarations
 
262
%*                                                       *
 
263
%*********************************************************
 
264
 
 
265
\begin{code}
 
266
rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name]
 
267
-- Rename the fixity decls, so we can put
 
268
-- the renamed decls in the renamed syntax tree
 
269
-- Errors if the thing being fixed is not defined locally.
 
270
--
 
271
-- The returned FixitySigs are not actually used for anything,
 
272
-- except perhaps the GHCi API
 
273
rnSrcFixityDecls bound_names fix_decls
 
274
  = do fix_decls <- mapM rn_decl fix_decls
 
275
       return (concat fix_decls)
 
276
  where
 
277
    rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
 
278
        -- GHC extension: look up both the tycon and data con 
 
279
        -- for con-like things; hence returning a list
 
280
        -- If neither are in scope, report an error; otherwise
 
281
        -- return a fixity sig for each (slightly odd)
 
282
    rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity))
 
283
      = setSrcSpan name_loc $
 
284
                    -- this lookup will fail if the definition isn't local
 
285
        do names <- lookupLocalDataTcNames bound_names what rdr_name
 
286
           return [ L loc (FixitySig (L name_loc name) fixity)
 
287
                  | name <- names ]
 
288
    what = ptext (sLit "fixity signature")
 
289
\end{code}
 
290
 
 
291
 
 
292
%*********************************************************
 
293
%*                                                       *
 
294
        Source-code deprecations declarations
 
295
%*                                                       *
 
296
%*********************************************************
 
297
 
 
298
Check that the deprecated names are defined, are defined locally, and
 
299
that there are no duplicate deprecations.
 
300
 
 
301
It's only imported deprecations, dealt with in RnIfaces, that we
 
302
gather them together.
 
303
 
 
304
\begin{code}
 
305
-- checks that the deprecations are defined locally, and that there are no duplicates
 
306
rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings
 
307
rnSrcWarnDecls _bound_names [] 
 
308
  = return NoWarnings
 
309
 
 
310
rnSrcWarnDecls bound_names decls 
 
311
  = do { -- check for duplicates
 
312
       ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups
 
313
                          in addErrAt loc (dupWarnDecl lrdr' rdr)) 
 
314
               warn_rdr_dups
 
315
       ; pairs_s <- mapM (addLocM rn_deprec) decls
 
316
       ; return (WarnSome ((concat pairs_s))) }
 
317
 where
 
318
   rn_deprec (Warning rdr_name txt)
 
319
       -- ensures that the names are defined locally
 
320
     = lookupLocalDataTcNames bound_names what rdr_name `thenM` \ names ->
 
321
       return [(nameOccName name, txt) | name <- names]
 
322
   
 
323
   what = ptext (sLit "deprecation")
 
324
 
 
325
   -- look for duplicates among the OccNames;
 
326
   -- we check that the names are defined above
 
327
   -- invt: the lists returned by findDupsEq always have at least two elements
 
328
   warn_rdr_dups = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
 
329
                     (map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls)
 
330
               
 
331
dupWarnDecl :: Located RdrName -> RdrName -> SDoc
 
332
-- Located RdrName -> DeprecDecl RdrName -> SDoc
 
333
dupWarnDecl (L loc _) rdr_name
 
334
  = vcat [ptext (sLit "Multiple warning declarations for") <+> quotes (ppr rdr_name),
 
335
          ptext (sLit "also at ") <+> ppr loc]
 
336
 
 
337
\end{code}
 
338
 
 
339
%*********************************************************
 
340
%*                                                      *
 
341
\subsection{Annotation declarations}
 
342
%*                                                      *
 
343
%*********************************************************
 
344
 
 
345
\begin{code}
 
346
rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars)
 
347
rnAnnDecl (HsAnnotation provenance expr) = do
 
348
    (provenance', provenance_fvs) <- rnAnnProvenance provenance
 
349
    (expr', expr_fvs) <- rnLExpr expr
 
350
    return (HsAnnotation provenance' expr', provenance_fvs `plusFV` expr_fvs)
 
351
 
 
352
rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars)
 
353
rnAnnProvenance provenance = do
 
354
    provenance' <- modifyAnnProvenanceNameM lookupTopBndrRn provenance
 
355
    return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))
 
356
\end{code}
 
357
 
 
358
%*********************************************************
 
359
%*                                                      *
 
360
\subsection{Default declarations}
 
361
%*                                                      *
 
362
%*********************************************************
 
363
 
 
364
\begin{code}
 
365
rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars)
 
366
rnDefaultDecl (DefaultDecl tys)
 
367
  = mapFvRn (rnHsTypeFVs doc_str) tys   `thenM` \ (tys', fvs) ->
 
368
    return (DefaultDecl tys', fvs)
 
369
  where
 
370
    doc_str = text "In a `default' declaration"
 
371
\end{code}
 
372
 
 
373
%*********************************************************
 
374
%*                                                      *
 
375
\subsection{Foreign declarations}
 
376
%*                                                      *
 
377
%*********************************************************
 
378
 
 
379
\begin{code}
 
380
rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
 
381
rnHsForeignDecl (ForeignImport name ty spec)
 
382
  = getTopEnv                           `thenM` \ (topEnv :: HscEnv) ->
 
383
    lookupLocatedTopBndrRn name         `thenM` \ name' ->
 
384
    rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
 
385
 
 
386
    -- Mark any PackageTarget style imports as coming from the current package
 
387
    let packageId       = thisPackage $ hsc_dflags topEnv
 
388
        spec'           = patchForeignImport packageId spec
 
389
 
 
390
    in  return (ForeignImport name' ty' spec', fvs)
 
391
 
 
392
rnHsForeignDecl (ForeignExport name ty spec)
 
393
  = lookupLocatedOccRn name             `thenM` \ name' ->
 
394
    rnHsTypeFVs (fo_decl_msg name) ty   `thenM` \ (ty', fvs) ->
 
395
    return (ForeignExport name' ty' spec, fvs `addOneFV` unLoc name')
 
396
        -- NB: a foreign export is an *occurrence site* for name, so 
 
397
        --     we add it to the free-variable list.  It might, for example,
 
398
        --     be imported from another module
 
399
 
 
400
fo_decl_msg :: Located RdrName -> SDoc
 
401
fo_decl_msg name = ptext (sLit "In the foreign declaration for") <+> ppr name
 
402
 
 
403
 
 
404
-- | For Windows DLLs we need to know what packages imported symbols are from
 
405
--      to generate correct calls. Imported symbols are tagged with the current
 
406
--      package, so if they get inlined across a package boundry we'll still
 
407
--      know where they're from.
 
408
--
 
409
patchForeignImport :: PackageId -> ForeignImport -> ForeignImport
 
410
patchForeignImport packageId (CImport cconv safety fs spec)
 
411
        = CImport cconv safety fs (patchCImportSpec packageId spec) 
 
412
 
 
413
patchCImportSpec :: PackageId -> CImportSpec -> CImportSpec
 
414
patchCImportSpec packageId spec
 
415
 = case spec of
 
416
        CFunction callTarget    -> CFunction $ patchCCallTarget packageId callTarget
 
417
        _                       -> spec
 
418
 
 
419
patchCCallTarget :: PackageId -> CCallTarget -> CCallTarget
 
420
patchCCallTarget packageId callTarget
 
421
 = case callTarget of
 
422
        StaticTarget label Nothing
 
423
         -> StaticTarget label (Just packageId)
 
424
 
 
425
        _                       -> callTarget   
 
426
 
 
427
 
 
428
\end{code}
 
429
 
 
430
 
 
431
%*********************************************************
 
432
%*                                                      *
 
433
\subsection{Instance declarations}
 
434
%*                                                      *
 
435
%*********************************************************
 
436
 
 
437
\begin{code}
 
438
rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
 
439
rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
 
440
        -- Used for both source and interface file decls
 
441
  = rnHsSigType (text "an instance decl") inst_ty       `thenM` \ inst_ty' ->
 
442
 
 
443
        -- Rename the bindings
 
444
        -- The typechecker (not the renamer) checks that all 
 
445
        -- the bindings are for the right class
 
446
    let
 
447
        meth_names  = collectMethodBinders mbinds
 
448
        (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
 
449
    in
 
450
    checkDupRdrNames meth_names         `thenM_`
 
451
        -- Check that the same method is not given twice in the
 
452
        -- same instance decl   instance C T where
 
453
        --                            f x = ...
 
454
        --                            g y = ...
 
455
        --                            f x = ...
 
456
        -- We must use checkDupRdrNames because the Name of the
 
457
        -- method is the Name of the class selector, whose SrcSpan
 
458
        -- points to the class declaration
 
459
 
 
460
    extendTyVarEnvForMethodBinds inst_tyvars (          
 
461
        -- (Slightly strangely) the forall-d tyvars scope over
 
462
        -- the method bindings too
 
463
        rnMethodBinds cls (\_ -> [])    -- No scoped tyvars
 
464
                      [] mbinds
 
465
    )                                           `thenM` \ (mbinds', meth_fvs) ->
 
466
        -- Rename the associated types
 
467
        -- The typechecker (not the renamer) checks that all 
 
468
        -- the declarations are for the right class
 
469
    let
 
470
        at_names = map (head . hsTyClDeclBinders) ats
 
471
    in
 
472
    checkDupRdrNames at_names           `thenM_`
 
473
        -- See notes with checkDupRdrNames for methods, above
 
474
 
 
475
    rnATInsts ats                               `thenM` \ (ats', at_fvs) ->
 
476
 
 
477
        -- Rename the prags and signatures.
 
478
        -- Note that the type variables are not in scope here,
 
479
        -- so that      instance Eq a => Eq (T a) where
 
480
        --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
 
481
        -- works OK. 
 
482
        --
 
483
        -- But the (unqualified) method names are in scope
 
484
    let 
 
485
        binders = collectHsBindsBinders mbinds'
 
486
        bndr_set = mkNameSet binders
 
487
    in
 
488
    bindLocalNames binders 
 
489
        (renameSigs (Just bndr_set) okInstDclSig uprags)        `thenM` \ uprags' ->
 
490
 
 
491
    return (InstDecl inst_ty' mbinds' uprags' ats',
 
492
             meth_fvs `plusFV` at_fvs
 
493
                      `plusFV` hsSigsFVs uprags'
 
494
                      `plusFV` extractHsTyNames inst_ty')
 
495
             -- We return the renamed associated data type declarations so
 
496
             -- that they can be entered into the list of type declarations
 
497
             -- for the binding group, but we also keep a copy in the instance.
 
498
             -- The latter is needed for well-formedness checks in the type
 
499
             -- checker (eg, to ensure that all ATs of the instance actually
 
500
             -- receive a declaration). 
 
501
             -- NB: Even the copies in the instance declaration carry copies of
 
502
             --     the instance context after renaming.  This is a bit
 
503
             --     strange, but should not matter (and it would be more work
 
504
             --     to remove the context).
 
505
\end{code}
 
506
 
 
507
Renaming of the associated types in instances.  
 
508
 
 
509
\begin{code}
 
510
rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 
511
rnATInsts atDecls = rnList rnATInst atDecls
 
512
  where
 
513
    rnATInst tydecl@TyData     {} = rnTyClDecl tydecl
 
514
    rnATInst tydecl@TySynonym  {} = rnTyClDecl tydecl
 
515
    rnATInst tydecl               =
 
516
      pprPanic "RnSource.rnATInsts: invalid AT instance" 
 
517
               (ppr (tcdName tydecl))
 
518
\end{code}
 
519
 
 
520
For the method bindings in class and instance decls, we extend the 
 
521
type variable environment iff -fglasgow-exts
 
522
 
 
523
\begin{code}
 
524
extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name]
 
525
                             -> RnM (Bag (LHsBind Name), FreeVars)
 
526
                             -> RnM (Bag (LHsBind Name), FreeVars)
 
527
extendTyVarEnvForMethodBinds tyvars thing_inside
 
528
  = do  { scoped_tvs <- xoptM Opt_ScopedTypeVariables
 
529
        ; if scoped_tvs then
 
530
                extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
 
531
          else
 
532
                thing_inside }
 
533
\end{code}
 
534
 
 
535
%*********************************************************
 
536
%*                                                      *
 
537
\subsection{Stand-alone deriving declarations}
 
538
%*                                                      *
 
539
%*********************************************************
 
540
 
 
541
\begin{code}
 
542
rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
 
543
rnSrcDerivDecl (DerivDecl ty)
 
544
  = do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving
 
545
       ; unless standalone_deriv_ok (addErr standaloneDerivErr)
 
546
       ; ty' <- rnLHsType (text "a deriving decl") ty
 
547
       ; let fvs = extractHsTyNames ty'
 
548
       ; return (DerivDecl ty', fvs) }
 
549
 
 
550
standaloneDerivErr :: SDoc
 
551
standaloneDerivErr 
 
552
  = hang (ptext (sLit "Illegal standalone deriving declaration"))
 
553
       2 (ptext (sLit "Use -XStandaloneDeriving to enable this extension"))
 
554
\end{code}
 
555
 
 
556
%*********************************************************
 
557
%*                                                      *
 
558
\subsection{Rules}
 
559
%*                                                      *
 
560
%*********************************************************
 
561
 
 
562
\begin{code}
 
563
rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
 
564
rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
 
565
  = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)     $
 
566
    bindLocatedLocalsFV (map get_var vars)              $ \ ids ->
 
567
    do  { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids)
 
568
                -- NB: The binders in a rule are always Ids
 
569
                --     We don't (yet) support type variables
 
570
 
 
571
        ; (lhs', fv_lhs') <- rnLExpr lhs
 
572
        ; (rhs', fv_rhs') <- rnLExpr rhs
 
573
 
 
574
        ; checkValidRule rule_name ids lhs' fv_lhs'
 
575
 
 
576
        ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
 
577
                  fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') }
 
578
  where
 
579
    doc = text "In the transformation rule" <+> ftext rule_name
 
580
  
 
581
    get_var (RuleBndr v)      = v
 
582
    get_var (RuleBndrSig v _) = v
 
583
 
 
584
    rn_var (RuleBndr (L loc _), id)
 
585
        = return (RuleBndr (L loc id), emptyFVs)
 
586
    rn_var (RuleBndrSig (L loc _) t, id)
 
587
        = rnHsTypeFVs doc t     `thenM` \ (t', fvs) ->
 
588
          return (RuleBndrSig (L loc id) t', fvs)
 
589
 
 
590
badRuleVar :: FastString -> Name -> SDoc
 
591
badRuleVar name var
 
592
  = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
 
593
         ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+> 
 
594
                ptext (sLit "does not appear on left hand side")]
 
595
\end{code}
 
596
 
 
597
Note [Rule LHS validity checking]
 
598
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
599
Check the shape of a transformation rule LHS.  Currently we only allow
 
600
LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
 
601
@forall@'d variables.  
 
602
 
 
603
We used restrict the form of the 'ei' to prevent you writing rules
 
604
with LHSs with a complicated desugaring (and hence unlikely to match);
 
605
(e.g. a case expression is not allowed: too elaborate.)
 
606
 
 
607
But there are legitimate non-trivial args ei, like sections and
 
608
lambdas.  So it seems simmpler not to check at all, and that is why
 
609
check_e is commented out.
 
610
        
 
611
\begin{code}
 
612
checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()
 
613
checkValidRule rule_name ids lhs' fv_lhs'
 
614
  = do  {       -- Check for the form of the LHS
 
615
          case (validRuleLhs ids lhs') of
 
616
                Nothing  -> return ()
 
617
                Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
 
618
 
 
619
                -- Check that LHS vars are all bound
 
620
        ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
 
621
        ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
 
622
 
 
623
validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
 
624
-- Nothing => OK
 
625
-- Just e  => Not ok, and e is the offending expression
 
626
validRuleLhs foralls lhs
 
627
  = checkl lhs
 
628
  where
 
629
    checkl (L _ e) = check e
 
630
 
 
631
    check (OpApp e1 op _ e2)              = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
 
632
    check (HsApp e1 e2)                   = checkl e1 `mplus` checkl_e e2
 
633
    check (HsVar v) | v `notElem` foralls = Nothing
 
634
    check other                           = Just other  -- Failure
 
635
 
 
636
        -- Check an argument
 
637
    checkl_e (L _ _e) = Nothing         -- Was (check_e e); see Note [Rule LHS validity checking]
 
638
 
 
639
{-      Commented out; see Note [Rule LHS validity checking] above 
 
640
    check_e (HsVar v)     = Nothing
 
641
    check_e (HsPar e)     = checkl_e e
 
642
    check_e (HsLit e)     = Nothing
 
643
    check_e (HsOverLit e) = Nothing
 
644
 
 
645
    check_e (OpApp e1 op _ e2)   = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
 
646
    check_e (HsApp e1 e2)        = checkl_e e1 `mplus` checkl_e e2
 
647
    check_e (NegApp e _)         = checkl_e e
 
648
    check_e (ExplicitList _ es)  = checkl_es es
 
649
    check_e other                = Just other   -- Fails
 
650
 
 
651
    checkl_es es = foldr (mplus . checkl_e) Nothing es
 
652
-}
 
653
 
 
654
badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
 
655
badRuleLhsErr name lhs bad_e
 
656
  = sep [ptext (sLit "Rule") <+> ftext name <> colon,
 
657
         nest 4 (vcat [ptext (sLit "Illegal expression:") <+> ppr bad_e, 
 
658
                       ptext (sLit "in left-hand side:") <+> ppr lhs])]
 
659
    $$
 
660
    ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd")
 
661
\end{code}
 
662
 
 
663
 
 
664
%*********************************************************
 
665
%*                                                      *
 
666
\subsection{Type, class and iface sig declarations}
 
667
%*                                                      *
 
668
%*********************************************************
 
669
 
 
670
@rnTyDecl@ uses the `global name function' to create a new type
 
671
declaration in which local names have been replaced by their original
 
672
names, reporting any unknown names.
 
673
 
 
674
Renaming type variables is a pain. Because they now contain uniques,
 
675
it is necessary to pass in an association list which maps a parsed
 
676
tyvar to its @Name@ representation.
 
677
In some cases (type signatures of values),
 
678
it is even necessary to go over the type first
 
679
in order to get the set of tyvars used by it, make an assoc list,
 
680
and then go over it again to rename the tyvars!
 
681
However, we can also do some scoping checks at the same time.
 
682
 
 
683
\begin{code}
 
684
rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars)
 
685
rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name})
 
686
  = lookupLocatedTopBndrRn name         `thenM` \ name' ->
 
687
    return (ForeignType {tcdLName = name', tcdExtName = ext_name},
 
688
             emptyFVs)
 
689
 
 
690
-- all flavours of type family declarations ("type family", "newtype fanily",
 
691
-- and "data family")
 
692
rnTyClDecl tydecl@TyFamily {} = rnFamily tydecl bindTyVarsFV
 
693
 
 
694
-- "data", "newtype", "data instance, and "newtype instance" declarations
 
695
rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, 
 
696
                           tcdLName = tycon, tcdTyVars = tyvars, 
 
697
                           tcdTyPats = typats, tcdCons = condecls, 
 
698
                           tcdKindSig = sig, tcdDerivs = derivs}
 
699
  = do  { tycon' <- if isFamInstDecl tydecl
 
700
                    then lookupLocatedOccRn     tycon -- may be imported family
 
701
                    else lookupLocatedTopBndrRn tycon
 
702
        ; checkTc (h98_style || null (unLoc context)) 
 
703
                  (badGadtStupidTheta tycon)
 
704
        ; ((tyvars', context', typats', derivs'), stuff_fvs)
 
705
                <- bindTyVarsFV tyvars $ \ tyvars' -> do
 
706
                                 -- Checks for distinct tyvars
 
707
                   { context' <- rnContext data_doc context
 
708
                   ; (typats', fvs1) <- rnTyPats data_doc tycon' typats
 
709
                   ; (derivs', fvs2) <- rn_derivs derivs
 
710
                   ; let fvs = fvs1 `plusFV` fvs2 `plusFV` 
 
711
                               extractHsCtxtTyNames context'
 
712
                   ; return ((tyvars', context', typats', derivs'), fvs) }
 
713
 
 
714
        -- For the constructor declarations, bring into scope the tyvars 
 
715
        -- bound by the header, but *only* in the H98 case
 
716
        -- Reason: for GADTs, the type variables in the declaration 
 
717
        --   do not scope over the constructor signatures
 
718
        --   data T a where { T1 :: forall b. b-> b }
 
719
        ; let tc_tvs_in_scope | h98_style = hsLTyVarNames tyvars'
 
720
                              | otherwise = []
 
721
        ; (condecls', con_fvs) <- bindLocalNamesFV tc_tvs_in_scope $
 
722
                                  rnConDecls condecls
 
723
                -- No need to check for duplicate constructor decls
 
724
                -- since that is done by RnNames.extendGlobalRdrEnvRn
 
725
 
 
726
        ; return (TyData {tcdND = new_or_data, tcdCtxt = context', 
 
727
                           tcdLName = tycon', tcdTyVars = tyvars', 
 
728
                           tcdTyPats = typats', tcdKindSig = sig,
 
729
                           tcdCons = condecls', tcdDerivs = derivs'}, 
 
730
                   con_fvs `plusFV` stuff_fvs)
 
731
        }
 
732
  where
 
733
    h98_style = case condecls of         -- Note [Stupid theta]
 
734
                     L _ (ConDecl { con_res = ResTyGADT {} }) : _  -> False
 
735
                     _                                             -> True
 
736
                                                                          
 
737
    data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
 
738
 
 
739
    rn_derivs Nothing   = return (Nothing, emptyFVs)
 
740
    rn_derivs (Just ds) = rnLHsTypes data_doc ds        `thenM` \ ds' -> 
 
741
                          return (Just ds', extractHsTyNames_s ds')
 
742
 
 
743
-- "type" and "type instance" declarations
 
744
rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
 
745
                              tcdTyPats = typats, tcdSynRhs = ty})
 
746
  = bindTyVarsFV tyvars $ \ tyvars' -> do
 
747
    {            -- Checks for distinct tyvars
 
748
      name' <- if isFamInstDecl tydecl
 
749
                  then lookupLocatedOccRn     name -- may be imported family
 
750
                  else lookupLocatedTopBndrRn name
 
751
    ; (typats',fvs1) <- rnTyPats syn_doc name' typats
 
752
    ; (ty', fvs2)    <- rnHsTypeFVs syn_doc ty
 
753
    ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars' 
 
754
                        , tcdTyPats = typats', tcdSynRhs = ty'},
 
755
              fvs1 `plusFV` fvs2) }
 
756
  where
 
757
    syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
 
758
 
 
759
rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, 
 
760
                       tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
 
761
                       tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
 
762
  = do  { cname' <- lookupLocatedTopBndrRn cname
 
763
 
 
764
        -- Tyvars scope over superclass context and method signatures
 
765
        ; ((tyvars', context', fds', ats', sigs'), stuff_fvs)
 
766
            <- bindTyVarsFV tyvars $ \ tyvars' -> do
 
767
                 -- Checks for distinct tyvars
 
768
             { context' <- rnContext cls_doc context
 
769
             ; fds' <- rnFds cls_doc fds
 
770
             ; (ats', at_fvs) <- rnATs ats
 
771
             ; sigs' <- renameSigs Nothing okClsDclSig sigs
 
772
             ; let fvs = at_fvs `plusFV` 
 
773
                         extractHsCtxtTyNames context'  `plusFV`
 
774
                         hsSigsFVs sigs'
 
775
                         -- The fundeps have no free variables
 
776
             ; return ((tyvars', context', fds', ats', sigs'), fvs) }
 
777
 
 
778
        -- No need to check for duplicate associated type decls
 
779
        -- since that is done by RnNames.extendGlobalRdrEnvRn
 
780
 
 
781
        -- Check the signatures
 
782
        -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
 
783
        ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs]
 
784
        ; checkDupRdrNames sig_rdr_names_w_locs
 
785
                -- Typechecker is responsible for checking that we only
 
786
                -- give default-method bindings for things in this class.
 
787
                -- The renamer *could* check this for class decls, but can't
 
788
                -- for instance decls.
 
789
 
 
790
        -- The newLocals call is tiresome: given a generic class decl
 
791
        --      class C a where
 
792
        --        op :: a -> a
 
793
        --        op {| x+y |} (Inl a) = ...
 
794
        --        op {| x+y |} (Inr b) = ...
 
795
        --        op {| a*b |} (a*b)   = ...
 
796
        -- we want to name both "x" tyvars with the same unique, so that they are
 
797
        -- easy to group together in the typechecker.  
 
798
        ; (mbinds', meth_fvs) 
 
799
            <- extendTyVarEnvForMethodBinds tyvars' $ do
 
800
            { name_env <- getLocalRdrEnv
 
801
            ; let gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds,
 
802
                                                 not (unLoc tv `elemLocalRdrEnv` name_env) ]
 
803
                -- No need to check for duplicate method signatures
 
804
                -- since that is done by RnNames.extendGlobalRdrEnvRn
 
805
                -- and the methods are already in scope
 
806
            ; gen_tyvars <- newLocalBndrsRn gen_rdr_tyvars_w_locs
 
807
            ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds }
 
808
 
 
809
  -- Haddock docs 
 
810
        ; docs' <- mapM (wrapLocM rnDocDecl) docs
 
811
 
 
812
        ; return (ClassDecl { tcdCtxt = context', tcdLName = cname', 
 
813
                              tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
 
814
                              tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
 
815
                  meth_fvs `plusFV` stuff_fvs) }
 
816
  where
 
817
    cls_doc  = text "In the declaration for class"      <+> ppr cname
 
818
 
 
819
badGadtStupidTheta :: Located RdrName -> SDoc
 
820
badGadtStupidTheta _
 
821
  = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
 
822
          ptext (sLit "(You can put a context on each contructor, though.)")]
 
823
\end{code}
 
824
 
 
825
Note [Stupid theta]
 
826
~~~~~~~~~~~~~~~~~~~
 
827
Trac #3850 complains about a regression wrt 6.10 for 
 
828
     data Show a => T a
 
829
There is no reason not to allow the stupid theta if there are no data
 
830
constructors.  It's still stupid, but does no harm, and I don't want
 
831
to cause programs to break unnecessarily (notably HList).  So if there
 
832
are no data constructors we allow h98_style = True
 
833
 
 
834
 
 
835
%*********************************************************
 
836
%*                                                      *
 
837
\subsection{Support code for type/data declarations}
 
838
%*                                                      *
 
839
%*********************************************************
 
840
 
 
841
\begin{code}
 
842
rnTyPats :: SDoc -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars)
 
843
-- Although, we are processing type patterns here, all type variables will
 
844
-- already be in scope (they are the same as in the 'tcdTyVars' field of the
 
845
-- type declaration to which these patterns belong)
 
846
rnTyPats _   _  Nothing
 
847
  = return (Nothing, emptyFVs)
 
848
rnTyPats doc tc (Just typats) 
 
849
  = do { typats' <- rnLHsTypes doc typats
 
850
       ; let fvs = addOneFV (extractHsTyNames_s typats') (unLoc tc)
 
851
             -- type instance => use, hence addOneFV
 
852
       ; return (Just typats', fvs) }
 
853
 
 
854
rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
 
855
rnConDecls condecls
 
856
  = do { condecls' <- mapM (wrapLocM rnConDecl) condecls
 
857
       ; return (condecls', plusFVs (map conDeclFVs condecls')) }
 
858
 
 
859
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
 
860
rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
 
861
                               , con_cxt = cxt, con_details = details
 
862
                               , con_res = res_ty, con_doc = mb_doc
 
863
                               , con_old_rec = old_rec, con_explicit = expl })
 
864
  = do  { addLocM checkConName name
 
865
        ; when old_rec (addWarn (deprecRecSyntax decl))
 
866
        ; new_name <- lookupLocatedTopBndrRn name
 
867
 
 
868
           -- For H98 syntax, the tvs are the existential ones
 
869
           -- For GADT syntax, the tvs are all the quantified tyvars
 
870
           -- Hence the 'filter' in the ResTyH98 case only
 
871
        ; rdr_env <- getLocalRdrEnv
 
872
        ; let in_scope     = (`elemLocalRdrEnv` rdr_env) . unLoc
 
873
              arg_tys      = hsConDeclArgTys details
 
874
              implicit_tvs = case res_ty of
 
875
                               ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys)
 
876
                               ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
 
877
              new_tvs = case expl of
 
878
                          Explicit -> tvs
 
879
                          Implicit -> userHsTyVarBndrs implicit_tvs
 
880
 
 
881
        ; mb_doc' <- rnMbLHsDoc mb_doc 
 
882
 
 
883
        ; bindTyVarsRn new_tvs $ \new_tyvars -> do
 
884
        { new_context <- rnContext doc cxt
 
885
        ; new_details <- rnConDeclDetails doc details
 
886
        ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
 
887
        ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context 
 
888
                       , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }}
 
889
 where
 
890
    doc = text "In the definition of data constructor" <+> quotes (ppr name)
 
891
    get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
 
892
 
 
893
rnConResult :: SDoc
 
894
            -> HsConDetails (LHsType Name) [ConDeclField Name]
 
895
            -> ResType RdrName
 
896
            -> RnM (HsConDetails (LHsType Name) [ConDeclField Name],
 
897
                    ResType Name)
 
898
rnConResult _ details ResTyH98 = return (details, ResTyH98)
 
899
rnConResult doc details (ResTyGADT ty)
 
900
  = do { ty' <- rnLHsType doc ty
 
901
       ; let (arg_tys, res_ty) = splitHsFunType ty'
 
902
                -- We can finally split it up, 
 
903
                -- now the renamer has dealt with fixities
 
904
                -- See Note [Sorting out the result type] in RdrHsSyn
 
905
 
 
906
             details' = case details of
 
907
                           RecCon {}    -> details
 
908
                           PrefixCon {} -> PrefixCon arg_tys
 
909
                           InfixCon {}  -> pprPanic "rnConResult" (ppr ty)
 
910
                          -- See Note [Sorting out the result type] in RdrHsSyn
 
911
                
 
912
       ; when (not (null arg_tys) && case details of { RecCon {} -> True; _ -> False })
 
913
              (addErr (badRecResTy doc))
 
914
       ; return (details', ResTyGADT res_ty) }
 
915
 
 
916
rnConDeclDetails :: SDoc
 
917
                 -> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
 
918
                 -> RnM (HsConDetails (LHsType Name) [ConDeclField Name])
 
919
rnConDeclDetails doc (PrefixCon tys)
 
920
  = mapM (rnLHsType doc) tys    `thenM` \ new_tys  ->
 
921
    return (PrefixCon new_tys)
 
922
 
 
923
rnConDeclDetails doc (InfixCon ty1 ty2)
 
924
  = rnLHsType doc ty1           `thenM` \ new_ty1 ->
 
925
    rnLHsType doc ty2           `thenM` \ new_ty2 ->
 
926
    return (InfixCon new_ty1 new_ty2)
 
927
 
 
928
rnConDeclDetails doc (RecCon fields)
 
929
  = do  { new_fields <- rnConDeclFields doc fields
 
930
                -- No need to check for duplicate fields
 
931
                -- since that is done by RnNames.extendGlobalRdrEnvRn
 
932
        ; return (RecCon new_fields) }
 
933
 
 
934
-- Rename family declarations
 
935
--
 
936
-- * This function is parametrised by the routine handling the index
 
937
--   variables.  On the toplevel, these are defining occurences, whereas they
 
938
--   are usage occurences for associated types.
 
939
--
 
940
rnFamily :: TyClDecl RdrName 
 
941
         -> ([LHsTyVarBndr RdrName] -> 
 
942
             ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
 
943
             RnM (TyClDecl Name, FreeVars))
 
944
         -> RnM (TyClDecl Name, FreeVars)
 
945
 
 
946
rnFamily (tydecl@TyFamily {tcdFlavour = flavour, 
 
947
                           tcdLName = tycon, tcdTyVars = tyvars}) 
 
948
        bindIdxVars =
 
949
      do { bindIdxVars tyvars $ \tyvars' -> do {
 
950
         ; tycon' <- lookupLocatedTopBndrRn tycon
 
951
         ; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon', 
 
952
                              tcdTyVars = tyvars', tcdKind = tcdKind tydecl}, 
 
953
                    emptyFVs) 
 
954
         } }
 
955
rnFamily d _ = pprPanic "rnFamily" (ppr d)
 
956
 
 
957
-- Rename associated type declarations (in classes)
 
958
--
 
959
-- * This can be family declarations and (default) type instances
 
960
--
 
961
rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 
962
rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
 
963
  where
 
964
    rn_at (tydecl@TyFamily  {}) = rnFamily tydecl lookupIdxVars
 
965
    rn_at (tydecl@TySynonym {}) = 
 
966
      do
 
967
        unless (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
 
968
        rnTyClDecl tydecl
 
969
    rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"
 
970
 
 
971
    lookupIdxVars tyvars cont = 
 
972
      do { checkForDups tyvars
 
973
         ; tyvars' <- mapM lookupIdxVar tyvars
 
974
         ; cont tyvars'
 
975
         }
 
976
    -- Type index variables must be class parameters, which are the only
 
977
    -- type variables in scope at this point.
 
978
    lookupIdxVar (L l tyvar) =
 
979
      do
 
980
        name' <- lookupOccRn (hsTyVarName tyvar)
 
981
        return $ L l (replaceTyVarName tyvar name')
 
982
 
 
983
    -- Type variable may only occur once.
 
984
    --
 
985
    checkForDups [] = return ()
 
986
    checkForDups (L loc tv:ltvs) = 
 
987
      do { setSrcSpan loc $
 
988
             when (hsTyVarName tv `ltvElem` ltvs) $
 
989
               addErr (repeatedTyVar tv)
 
990
         ; checkForDups ltvs
 
991
         }
 
992
 
 
993
    _       `ltvElem` [] = False
 
994
    rdrName `ltvElem` (L _ tv:ltvs)
 
995
      | rdrName == hsTyVarName tv = True
 
996
      | otherwise                 = rdrName `ltvElem` ltvs
 
997
 
 
998
deprecRecSyntax :: ConDecl RdrName -> SDoc
 
999
deprecRecSyntax decl 
 
1000
  = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl))
 
1001
                 <+> ptext (sLit "uses deprecated syntax")
 
1002
         , ptext (sLit "Instead, use the form")
 
1003
         , nest 2 (ppr decl) ]   -- Pretty printer uses new form
 
1004
 
 
1005
badRecResTy :: SDoc -> SDoc
 
1006
badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
 
1007
 
 
1008
noPatterns :: SDoc
 
1009
noPatterns = text "Default definition for an associated synonym cannot have"
 
1010
             <+> text "type pattern"
 
1011
 
 
1012
repeatedTyVar :: HsTyVarBndr RdrName -> SDoc
 
1013
repeatedTyVar tv = ptext (sLit "Illegal repeated type variable") <+>
 
1014
                   quotes (ppr tv)
 
1015
 
 
1016
-- This data decl will parse OK
 
1017
--      data T = a Int
 
1018
-- treating "a" as the constructor.
 
1019
-- It is really hard to make the parser spot this malformation.
 
1020
-- So the renamer has to check that the constructor is legal
 
1021
--
 
1022
-- We can get an operator as the constructor, even in the prefix form:
 
1023
--      data T = :% Int Int
 
1024
-- from interface files, which always print in prefix form
 
1025
 
 
1026
checkConName :: RdrName -> TcRn ()
 
1027
checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
 
1028
 
 
1029
badDataCon :: RdrName -> SDoc
 
1030
badDataCon name
 
1031
   = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)]
 
1032
\end{code}
 
1033
 
 
1034
 
 
1035
%*********************************************************
 
1036
%*                                                      *
 
1037
\subsection{Support code for type/data declarations}
 
1038
%*                                                      *
 
1039
%*********************************************************
 
1040
 
 
1041
Get the mapping from constructors to fields for this module.
 
1042
It's convenient to do this after the data type decls have been renamed
 
1043
\begin{code}
 
1044
extendRecordFieldEnv :: [LTyClDecl RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv
 
1045
extendRecordFieldEnv tycl_decls inst_decls
 
1046
  = do  { tcg_env <- getGblEnv
 
1047
        ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
 
1048
        ; return (tcg_env { tcg_field_env = field_env' }) }
 
1049
  where
 
1050
    -- we want to lookup:
 
1051
    --  (a) a datatype constructor
 
1052
    --  (b) a record field
 
1053
    -- knowing that they're from this module.
 
1054
    -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn,
 
1055
    -- which keeps only the local ones.
 
1056
    lookup x = do { x' <- lookupLocatedTopBndrRn x
 
1057
                    ; return $ unLoc x'}
 
1058
 
 
1059
    all_data_cons :: [ConDecl RdrName]
 
1060
    all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls
 
1061
                         , L _ con <- cons ]
 
1062
    all_tycl_decls = at_tycl_decls ++ tycl_decls
 
1063
    at_tycl_decls = instDeclATs inst_decls  -- Do not forget associated types!
 
1064
 
 
1065
    get_con (ConDecl { con_name = con, con_details = RecCon flds })
 
1066
            (RecFields env fld_set)
 
1067
        = do { con' <- lookup con
 
1068
             ; flds' <- mapM lookup (map cd_fld_name flds)
 
1069
             ; let env'    = extendNameEnv env con' flds'
 
1070
                   fld_set' = addListToNameSet fld_set flds'
 
1071
             ; return $ (RecFields env' fld_set') }
 
1072
    get_con _ env = return env
 
1073
\end{code}
 
1074
 
 
1075
%*********************************************************
 
1076
%*                                                      *
 
1077
\subsection{Support code to rename types}
 
1078
%*                                                      *
 
1079
%*********************************************************
 
1080
 
 
1081
\begin{code}
 
1082
rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
 
1083
 
 
1084
rnFds doc fds
 
1085
  = mapM (wrapLocM rn_fds) fds
 
1086
  where
 
1087
    rn_fds (tys1, tys2)
 
1088
      = rnHsTyVars doc tys1             `thenM` \ tys1' ->
 
1089
        rnHsTyVars doc tys2             `thenM` \ tys2' ->
 
1090
        return (tys1', tys2')
 
1091
 
 
1092
rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name]
 
1093
rnHsTyVars doc tvs  = mapM (rnHsTyVar doc) tvs
 
1094
 
 
1095
rnHsTyVar :: SDoc -> RdrName -> RnM Name
 
1096
rnHsTyVar _doc tyvar = lookupOccRn tyvar
 
1097
\end{code}
 
1098
 
 
1099
 
 
1100
%*********************************************************
 
1101
%*                                                      *
 
1102
        findSplice
 
1103
%*                                                      *
 
1104
%*********************************************************
 
1105
 
 
1106
This code marches down the declarations, looking for the first
 
1107
Template Haskell splice.  As it does so it
 
1108
        a) groups the declarations into a HsGroup
 
1109
        b) runs any top-level quasi-quotes
 
1110
 
 
1111
\begin{code}
 
1112
findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
 
1113
findSplice ds = addl emptyRdrGroup ds
 
1114
 
 
1115
addl :: HsGroup RdrName -> [LHsDecl RdrName]
 
1116
     -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
 
1117
-- This stuff reverses the declarations (again) but it doesn't matter
 
1118
addl gp []           = return (gp, Nothing)
 
1119
addl gp (L l d : ds) = add gp l d ds
 
1120
 
 
1121
 
 
1122
add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
 
1123
    -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
 
1124
 
 
1125
add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds 
 
1126
  = do { -- We've found a top-level splice.  If it is an *implicit* one 
 
1127
         -- (i.e. a naked top level expression)
 
1128
         case flag of
 
1129
           Explicit -> return ()
 
1130
           Implicit -> do { th_on <- xoptM Opt_TemplateHaskell
 
1131
                          ; unless th_on $ setSrcSpan loc $
 
1132
                            failWith badImplicitSplice }
 
1133
 
 
1134
       ; return (gp, Just (splice, ds)) }
 
1135
  where
 
1136
    badImplicitSplice = ptext (sLit "Parse error: naked expression at top level")
 
1137
 
 
1138
#ifndef GHCI
 
1139
add _ _ (QuasiQuoteD qq) _
 
1140
  = pprPanic "Can't do QuasiQuote declarations without GHCi" (ppr qq)
 
1141
#else
 
1142
add gp _ (QuasiQuoteD qq) ds            -- Expand quasiquotes
 
1143
  = do { ds' <- runQuasiQuoteDecl qq
 
1144
       ; addl gp (ds' ++ ds) }
 
1145
#endif
 
1146
 
 
1147
-- Class declarations: pull out the fixity signatures to the top
 
1148
add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
 
1149
  | isClassDecl d
 
1150
  = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
 
1151
    addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs}) ds
 
1152
  | otherwise
 
1153
  = addl (gp { hs_tyclds = L l d : ts }) ds
 
1154
 
 
1155
-- Signatures: fixity sigs go a different place than all others
 
1156
add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
 
1157
  = addl (gp {hs_fixds = L l f : ts}) ds
 
1158
add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
 
1159
  = addl (gp {hs_valds = add_sig (L l d) ts}) ds
 
1160
 
 
1161
-- Value declarations: use add_bind
 
1162
add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
 
1163
  = addl (gp { hs_valds = add_bind (L l d) ts }) ds
 
1164
 
 
1165
-- The rest are routine
 
1166
add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
 
1167
  = addl (gp { hs_instds = L l d : ts }) ds
 
1168
add gp@(HsGroup {hs_derivds = ts})  l (DerivD d) ds
 
1169
  = addl (gp { hs_derivds = L l d : ts }) ds
 
1170
add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
 
1171
  = addl (gp { hs_defds = L l d : ts }) ds
 
1172
add gp@(HsGroup {hs_fords  = ts}) l (ForD d) ds
 
1173
  = addl (gp { hs_fords = L l d : ts }) ds
 
1174
add gp@(HsGroup {hs_warnds  = ts})  l (WarningD d) ds
 
1175
  = addl (gp { hs_warnds = L l d : ts }) ds
 
1176
add gp@(HsGroup {hs_annds  = ts}) l (AnnD d) ds
 
1177
  = addl (gp { hs_annds = L l d : ts }) ds
 
1178
add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
 
1179
  = addl (gp { hs_ruleds = L l d : ts }) ds
 
1180
add gp l (DocD d) ds
 
1181
  = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
 
1182
 
 
1183
add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
 
1184
add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
 
1185
add_bind _ (ValBindsOut {})     = panic "RdrHsSyn:add_bind"
 
1186
 
 
1187
add_sig :: LSig a -> HsValBinds a -> HsValBinds a
 
1188
add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) 
 
1189
add_sig _ (ValBindsOut {})     = panic "RdrHsSyn:add_sig"
 
1190
\end{code}
 
 
b'\\ No newline at end of file'