Add VECTORISE [SCALAR] type pragma
[ghc.git] / compiler / rename / RnSource.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[RnSource]{Main pass of renamer}
5
6 \begin{code}
7 module RnSource ( 
8         rnSrcDecls, addTcgDUs, 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         ( extractHsRhoRdrTyVars )
21 import RnHsSyn
22 import RnTypes
23 import RnBinds          ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn,
24                                 makeMiniFixityEnv)
25 import RnEnv            ( lookupLocalDataTcNames, lookupLocatedOccRn,
26                           lookupTopBndrRn, lookupLocatedTopBndrRn,
27                           lookupOccRn, bindLocalNamesFV,
28                           bindLocatedLocalsFV, bindPatSigTyVarsFV,
29                           bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn,
30                           bindLocalNames, checkDupRdrNames, mapFvRn
31                         )
32 import RnNames          ( getLocalNonValBinders, extendGlobalRdrEnvRn )
33 import HscTypes         ( AvailInfo(..), 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 import Digraph          ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
54
55 import Control.Monad
56 import Maybes( orElse )
57 import Data.Maybe
58 \end{code}
59
60 \begin{code}
61 -- XXX
62 thenM :: Monad a => a b -> (b -> a c) -> a c
63 thenM = (>>=)
64
65 thenM_ :: Monad a => a b -> a c -> a c
66 thenM_ = (>>)
67 \end{code}
68
69 @rnSourceDecl@ `renames' declarations.
70 It simultaneously performs dependency analysis and precedence parsing.
71 It also does the following error checks:
72 \begin{enumerate}
73 \item
74 Checks that tyvars are used properly. This includes checking
75 for undefined tyvars, and tyvars in contexts that are ambiguous.
76 (Some of this checking has now been moved to module @TcMonoType@,
77 since we don't have functional dependency information at this point.)
78 \item
79 Checks that all variable occurences are defined.
80 \item 
81 Checks the @(..)@ etc constraints in the export list.
82 \end{enumerate}
83
84
85 \begin{code}
86 -- Brings the binders of the group into scope in the appropriate places;
87 -- does NOT assume that anything is in scope already
88 rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
89 -- Rename a HsGroup; used for normal source files *and* hs-boot files
90 rnSrcDecls group@(HsGroup { hs_valds   = val_decls,
91                             hs_tyclds  = tycl_decls,
92                             hs_instds  = inst_decls,
93                             hs_derivds = deriv_decls,
94                             hs_fixds   = fix_decls,
95                             hs_warnds  = warn_decls,
96                             hs_annds   = ann_decls,
97                             hs_fords   = foreign_decls,
98                             hs_defds   = default_decls,
99                             hs_ruleds  = rule_decls,
100                             hs_vects   = vect_decls,
101                             hs_docs    = docs })
102  = do {
103    -- (A) Process the fixity declarations, creating a mapping from
104    --     FastStrings to FixItems.
105    --     Also checks for duplcates.
106    local_fix_env <- makeMiniFixityEnv fix_decls;
107
108    -- (B) Bring top level binders (and their fixities) into scope,
109    --     *except* for the value bindings, which get brought in below.
110    --     However *do* include class ops, data constructors
111    --     And for hs-boot files *do* include the value signatures
112    tc_avails <- getLocalNonValBinders group ;
113    tc_envs <- extendGlobalRdrEnvRn tc_avails local_fix_env ;
114    setEnvs tc_envs $ do {
115
116    failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
117
118    -- (C) Extract the mapping from data constructors to field names and
119    --     extend the record field env.
120    --     This depends on the data constructors and field names being in
121    --     scope from (B) above
122    inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do {
123
124    -- (D) Rename the left-hand sides of the value bindings.
125    --     This depends on everything from (B) being in scope,
126    --     and on (C) for resolving record wild cards.
127    --     It uses the fixity env from (A) to bind fixities for view patterns.
128    new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
129    -- bind the LHSes (and their fixities) in the global rdr environment
130    let { val_binders = collectHsValBinders new_lhs ;
131          val_bndr_set = mkNameSet val_binders ;
132          all_bndr_set = val_bndr_set `unionNameSets` availsToNameSet tc_avails ;
133          val_avails = map Avail val_binders 
134        } ;
135    (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
136    traceRn (ptext (sLit "Val binders") <+> (ppr val_binders)) ;
137    setEnvs (tcg_env, tcl_env) $ do {
138
139    --  Now everything is in scope, as the remaining renaming assumes.
140
141    -- (E) Rename type and class decls
142    --     (note that value LHSes need to be in scope for default methods)
143    --
144    -- You might think that we could build proper def/use information
145    -- for type and class declarations, but they can be involved
146    -- in mutual recursion across modules, and we only do the SCC
147    -- analysis for them in the type checker.
148    -- So we content ourselves with gathering uses only; that
149    -- means we'll only report a declaration as unused if it isn't
150    -- mentioned at all.  Ah well.
151    traceRn (text "Start rnTyClDecls") ;
152    (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
153
154    -- (F) Rename Value declarations right-hand sides
155    traceRn (text "Start rnmono") ;
156    (rn_val_decls, bind_dus) <- rnTopBindsRHS new_lhs ;
157    traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
158
159    -- (G) Rename Fixity and deprecations
160    
161    -- Rename fixity declarations and error if we try to
162    -- fix something from another module (duplicates were checked in (A))
163    rn_fix_decls <- rnSrcFixityDecls all_bndr_set fix_decls ;
164
165    -- Rename deprec decls;
166    -- check for duplicates and ensure that deprecated things are defined locally
167    -- at the moment, we don't keep these around past renaming
168    rn_warns <- rnSrcWarnDecls all_bndr_set warn_decls ;
169
170    -- (H) Rename Everything else
171
172    (rn_inst_decls,    src_fvs2) <- rnList rnSrcInstDecl   inst_decls ;
173    (rn_rule_decls,    src_fvs3) <- setXOptM Opt_ScopedTypeVariables $
174                                    rnList rnHsRuleDecl    rule_decls ;
175                            -- Inside RULES, scoped type variables are on
176    (rn_vect_decls,    src_fvs4) <- rnList rnHsVectDecl    vect_decls ;
177    (rn_foreign_decls, src_fvs5) <- rnList rnHsForeignDecl foreign_decls ;
178    (rn_ann_decls,     src_fvs6) <- rnList rnAnnDecl       ann_decls ;
179    (rn_default_decls, src_fvs7) <- rnList rnDefaultDecl   default_decls ;
180    (rn_deriv_decls,   src_fvs8) <- rnList rnSrcDerivDecl  deriv_decls ;
181       -- Haddock docs; no free vars
182    rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
183
184    -- (I) Compute the results and return
185    let {rn_group = HsGroup { hs_valds   = rn_val_decls,
186                              hs_tyclds  = rn_tycl_decls,
187                              hs_instds  = rn_inst_decls,
188                              hs_derivds = rn_deriv_decls,
189                              hs_fixds   = rn_fix_decls,
190                              hs_warnds  = [], -- warns are returned in the tcg_env
191                                              -- (see below) not in the HsGroup
192                              hs_fords  = rn_foreign_decls,
193                              hs_annds  = rn_ann_decls,
194                              hs_defds  = rn_default_decls,
195                              hs_ruleds = rn_rule_decls,
196                              hs_vects  = rn_vect_decls,
197                              hs_docs   = rn_docs } ;
198
199         tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ;
200         ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ;
201         other_def  = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ;
202         other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, 
203                               src_fvs5, src_fvs6, src_fvs7, src_fvs8] ;
204                 -- It is tiresome to gather the binders from type and class decls
205
206         src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
207                 -- Instance decls may have occurrences of things bound in bind_dus
208                 -- so we must put other_fvs last
209
210         final_tcg_env = let tcg_env' = (tcg_env `addTcgDUs` src_dus)
211                         in -- we return the deprecs in the env, not in the HsGroup above
212                         tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
213        } ;
214
215    traceRn (text "finish rnSrc" <+> ppr rn_group) ;
216    traceRn (text "finish Dus" <+> ppr src_dus ) ;
217    return (final_tcg_env, rn_group)
218                     }}}}
219
220 -- some utils because we do this a bunch above
221 -- compute and install the new env
222 inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a
223 inNewEnv env cont = do e <- env
224                        setGblEnv e $ cont e
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         (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty')
448     in
449     extendTyVarEnvForMethodBinds inst_tyvars (          
450         -- (Slightly strangely) the forall-d tyvars scope over
451         -- the method bindings too
452         rnMethodBinds cls (\_ -> [])    -- No scoped tyvars
453                       mbinds
454     )                                           `thenM` \ (mbinds', meth_fvs) ->
455         -- Rename the associated types
456         -- The typechecker (not the renamer) checks that all 
457         -- the declarations are for the right class
458     let
459         at_names = map (tcdLName . unLoc) ats   -- The names of the associated types
460     in
461     checkDupRdrNames at_names           `thenM_`
462         -- See notes with checkDupRdrNames for methods, above
463
464     rnATInsts ats                               `thenM` \ (ats', at_fvs) ->
465
466         -- Rename the prags and signatures.
467         -- Note that the type variables are not in scope here,
468         -- so that      instance Eq a => Eq (T a) where
469         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
470         -- works OK. 
471         --
472         -- But the (unqualified) method names are in scope
473     let 
474         binders = collectHsBindsBinders mbinds'
475         bndr_set = mkNameSet binders
476     in
477     bindLocalNames binders 
478         (renameSigs (Just bndr_set) okInstDclSig uprags)        `thenM` \ uprags' ->
479
480     return (InstDecl inst_ty' mbinds' uprags' ats',
481              meth_fvs `plusFV` at_fvs
482                       `plusFV` hsSigsFVs uprags'
483                       `plusFV` extractHsTyNames inst_ty')
484              -- We return the renamed associated data type declarations so
485              -- that they can be entered into the list of type declarations
486              -- for the binding group, but we also keep a copy in the instance.
487              -- The latter is needed for well-formedness checks in the type
488              -- checker (eg, to ensure that all ATs of the instance actually
489              -- receive a declaration). 
490              -- NB: Even the copies in the instance declaration carry copies of
491              --     the instance context after renaming.  This is a bit
492              --     strange, but should not matter (and it would be more work
493              --     to remove the context).
494 \end{code}
495
496 Renaming of the associated types in instances.  
497
498 \begin{code}
499 rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
500 rnATInsts atDecls = rnList rnATInst atDecls
501   where
502     rnATInst tydecl@TyData     {} = rnTyClDecl tydecl
503     rnATInst tydecl@TySynonym  {} = rnTyClDecl tydecl
504     rnATInst tydecl               =
505       pprPanic "RnSource.rnATInsts: invalid AT instance" 
506                (ppr (tcdName tydecl))
507 \end{code}
508
509 For the method bindings in class and instance decls, we extend the 
510 type variable environment iff -fglasgow-exts
511
512 \begin{code}
513 extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name]
514                              -> RnM (Bag (LHsBind Name), FreeVars)
515                              -> RnM (Bag (LHsBind Name), FreeVars)
516 extendTyVarEnvForMethodBinds tyvars thing_inside
517   = do  { scoped_tvs <- xoptM Opt_ScopedTypeVariables
518         ; if scoped_tvs then
519                 extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
520           else
521                 thing_inside }
522 \end{code}
523
524 %*********************************************************
525 %*                                                      *
526 \subsection{Stand-alone deriving declarations}
527 %*                                                      *
528 %*********************************************************
529
530 \begin{code}
531 rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
532 rnSrcDerivDecl (DerivDecl ty)
533   = do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving
534        ; unless standalone_deriv_ok (addErr standaloneDerivErr)
535        ; ty' <- rnLHsType (text "In a deriving declaration") ty
536        ; let fvs = extractHsTyNames ty'
537        ; return (DerivDecl ty', fvs) }
538
539 standaloneDerivErr :: SDoc
540 standaloneDerivErr 
541   = hang (ptext (sLit "Illegal standalone deriving declaration"))
542        2 (ptext (sLit "Use -XStandaloneDeriving to enable this extension"))
543 \end{code}
544
545 %*********************************************************
546 %*                                                      *
547 \subsection{Rules}
548 %*                                                      *
549 %*********************************************************
550
551 \begin{code}
552 rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
553 rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
554   = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)     $
555     bindLocatedLocalsFV (map get_var vars)              $ \ ids ->
556     do  { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids)
557                 -- NB: The binders in a rule are always Ids
558                 --     We don't (yet) support type variables
559
560         ; (lhs', fv_lhs') <- rnLExpr lhs
561         ; (rhs', fv_rhs') <- rnLExpr rhs
562
563         ; checkValidRule rule_name ids lhs' fv_lhs'
564
565         ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
566                   fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') }
567   where
568     doc = text "In the transformation rule" <+> ftext rule_name
569   
570     get_var (RuleBndr v)      = v
571     get_var (RuleBndrSig v _) = v
572
573     rn_var (RuleBndr (L loc _), id)
574         = return (RuleBndr (L loc id), emptyFVs)
575     rn_var (RuleBndrSig (L loc _) t, id)
576         = rnHsTypeFVs doc t     `thenM` \ (t', fvs) ->
577           return (RuleBndrSig (L loc id) t', fvs)
578
579 badRuleVar :: FastString -> Name -> SDoc
580 badRuleVar name var
581   = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
582          ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+> 
583                 ptext (sLit "does not appear on left hand side")]
584 \end{code}
585
586 Note [Rule LHS validity checking]
587 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
588 Check the shape of a transformation rule LHS.  Currently we only allow
589 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
590 @forall@'d variables.  
591
592 We used restrict the form of the 'ei' to prevent you writing rules
593 with LHSs with a complicated desugaring (and hence unlikely to match);
594 (e.g. a case expression is not allowed: too elaborate.)
595
596 But there are legitimate non-trivial args ei, like sections and
597 lambdas.  So it seems simmpler not to check at all, and that is why
598 check_e is commented out.
599         
600 \begin{code}
601 checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()
602 checkValidRule rule_name ids lhs' fv_lhs'
603   = do  {       -- Check for the form of the LHS
604           case (validRuleLhs ids lhs') of
605                 Nothing  -> return ()
606                 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
607
608                 -- Check that LHS vars are all bound
609         ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
610         ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
611
612 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
613 -- Nothing => OK
614 -- Just e  => Not ok, and e is the offending expression
615 validRuleLhs foralls lhs
616   = checkl lhs
617   where
618     checkl (L _ e) = check e
619
620     check (OpApp e1 op _ e2)              = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
621     check (HsApp e1 e2)                   = checkl e1 `mplus` checkl_e e2
622     check (HsVar v) | v `notElem` foralls = Nothing
623     check other                           = Just other  -- Failure
624
625         -- Check an argument
626     checkl_e (L _ _e) = Nothing         -- Was (check_e e); see Note [Rule LHS validity checking]
627
628 {-      Commented out; see Note [Rule LHS validity checking] above 
629     check_e (HsVar v)     = Nothing
630     check_e (HsPar e)     = checkl_e e
631     check_e (HsLit e)     = Nothing
632     check_e (HsOverLit e) = Nothing
633
634     check_e (OpApp e1 op _ e2)   = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
635     check_e (HsApp e1 e2)        = checkl_e e1 `mplus` checkl_e e2
636     check_e (NegApp e _)         = checkl_e e
637     check_e (ExplicitList _ es)  = checkl_es es
638     check_e other                = Just other   -- Fails
639
640     checkl_es es = foldr (mplus . checkl_e) Nothing es
641 -}
642
643 badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
644 badRuleLhsErr name lhs bad_e
645   = sep [ptext (sLit "Rule") <+> ftext name <> colon,
646          nest 4 (vcat [ptext (sLit "Illegal expression:") <+> ppr bad_e, 
647                        ptext (sLit "in left-hand side:") <+> ppr lhs])]
648     $$
649     ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd")
650 \end{code}
651
652
653 %*********************************************************
654 %*                                                      *
655 \subsection{Vectorisation declarations}
656 %*                                                      *
657 %*********************************************************
658
659 \begin{code}
660 rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars)
661 rnHsVectDecl (HsVect var Nothing)
662   = do { var' <- lookupLocatedTopBndrRn var
663        ; return (HsVect var' Nothing, unitFV (unLoc var'))
664        }
665 rnHsVectDecl (HsVect var (Just rhs))
666   = do { var' <- lookupLocatedTopBndrRn var
667        ; (rhs', fv_rhs) <- rnLExpr rhs
668        ; return (HsVect var' (Just rhs'), fv_rhs `addOneFV` unLoc var')
669        }
670 rnHsVectDecl (HsNoVect var)
671   = do { var' <- lookupLocatedTopBndrRn var
672        ; return (HsNoVect var', unitFV (unLoc var'))
673        }
674 rnHsVectDecl (HsVectTypeIn tycon Nothing)
675   = do { tycon' <- lookupLocatedOccRn tycon
676        ; return (HsVectTypeIn tycon' Nothing, unitFV (unLoc tycon'))
677        }
678 rnHsVectDecl (HsVectTypeIn tycon (Just ty))
679   = do { tycon' <- lookupLocatedOccRn tycon
680        ; (ty', fv_ty) <- rnHsTypeFVs vect_doc ty
681        ; return (HsVectTypeIn tycon' (Just ty'), fv_ty `addOneFV` unLoc tycon')
682        }
683   where
684     vect_doc = text "In the VECTORISE pragma for type constructor" <+> quotes (ppr tycon)
685 rnHsVectDecl (HsVectTypeOut _ _)
686   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"
687 \end{code}
688
689 %*********************************************************
690 %*                                                      *
691 \subsection{Type, class and iface sig declarations}
692 %*                                                      *
693 %*********************************************************
694
695 @rnTyDecl@ uses the `global name function' to create a new type
696 declaration in which local names have been replaced by their original
697 names, reporting any unknown names.
698
699 Renaming type variables is a pain. Because they now contain uniques,
700 it is necessary to pass in an association list which maps a parsed
701 tyvar to its @Name@ representation.
702 In some cases (type signatures of values),
703 it is even necessary to go over the type first
704 in order to get the set of tyvars used by it, make an assoc list,
705 and then go over it again to rename the tyvars!
706 However, we can also do some scoping checks at the same time.
707
708 \begin{code}
709 rnTyClDecls :: [[LTyClDecl RdrName]] -> RnM ([[LTyClDecl Name]], FreeVars)
710 -- Renamed the declarations and do depedency analysis on them
711 rnTyClDecls tycl_ds
712   = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (concat tycl_ds)
713
714        ; let sccs :: [SCC (LTyClDecl Name)]
715              sccs = depAnalTyClDecls ds_w_fvs
716
717              all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs
718
719        ; return (map flattenSCC sccs, all_fvs) }
720
721 rnTyClDecl :: TyClDecl RdrName -> RnM (TyClDecl Name, FreeVars)
722 rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name})
723   = lookupLocatedTopBndrRn name         `thenM` \ name' ->
724     return (ForeignType {tcdLName = name', tcdExtName = ext_name},
725              emptyFVs)
726
727 -- all flavours of type family declarations ("type family", "newtype family",
728 -- and "data family")
729 rnTyClDecl tydecl@TyFamily {} = rnFamily tydecl bindTyVarsFV
730
731 -- "data", "newtype", "data instance, and "newtype instance" declarations
732 rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, 
733                            tcdLName = tycon, tcdTyVars = tyvars, 
734                            tcdTyPats = typats, tcdCons = condecls, 
735                            tcdKindSig = sig, tcdDerivs = derivs}
736   = do  { tycon' <- if isFamInstDecl tydecl
737                     then lookupLocatedOccRn     tycon -- may be imported family
738                     else lookupLocatedTopBndrRn tycon
739         ; checkTc (h98_style || null (unLoc context)) 
740                   (badGadtStupidTheta tycon)
741         ; ((tyvars', context', typats', derivs'), stuff_fvs)
742                 <- bindTyVarsFV tyvars $ \ tyvars' -> do
743                                  -- Checks for distinct tyvars
744                    { context' <- rnContext data_doc context
745                    ; (typats', fvs1) <- rnTyPats data_doc tycon' typats
746                    ; (derivs', fvs2) <- rn_derivs derivs
747                    ; let fvs = fvs1 `plusFV` fvs2 `plusFV` 
748                                extractHsCtxtTyNames context'
749                    ; return ((tyvars', context', typats', derivs'), fvs) }
750
751         -- For the constructor declarations, bring into scope the tyvars 
752         -- bound by the header, but *only* in the H98 case
753         -- Reason: for GADTs, the type variables in the declaration 
754         --   do not scope over the constructor signatures
755         --   data T a where { T1 :: forall b. b-> b }
756         ; let tc_tvs_in_scope | h98_style = hsLTyVarNames tyvars'
757                               | otherwise = []
758         ; (condecls', con_fvs) <- bindLocalNamesFV tc_tvs_in_scope $
759                                   rnConDecls condecls
760                 -- No need to check for duplicate constructor decls
761                 -- since that is done by RnNames.extendGlobalRdrEnvRn
762
763         ; return (TyData {tcdND = new_or_data, tcdCtxt = context', 
764                            tcdLName = tycon', tcdTyVars = tyvars', 
765                            tcdTyPats = typats', tcdKindSig = sig,
766                            tcdCons = condecls', tcdDerivs = derivs'}, 
767                    con_fvs `plusFV` stuff_fvs)
768         }
769   where
770     h98_style = case condecls of         -- Note [Stupid theta]
771                      L _ (ConDecl { con_res = ResTyGADT {} }) : _  -> False
772                      _                                             -> True
773                                                                           
774     data_doc = text "In the data type declaration for" <+> quotes (ppr tycon)
775
776     rn_derivs Nothing   = return (Nothing, emptyFVs)
777     rn_derivs (Just ds) = rnLHsTypes data_doc ds        `thenM` \ ds' -> 
778                           return (Just ds', extractHsTyNames_s ds')
779
780 -- "type" and "type instance" declarations
781 rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars,
782                               tcdTyPats = typats, tcdSynRhs = ty})
783   = bindTyVarsFV tyvars $ \ tyvars' -> do
784     {            -- Checks for distinct tyvars
785       name' <- if isFamInstDecl tydecl
786                   then lookupLocatedOccRn     name -- may be imported family
787                   else lookupLocatedTopBndrRn name
788     ; (typats',fvs1) <- rnTyPats syn_doc name' typats
789     ; (ty', fvs2)    <- rnHsTypeFVs syn_doc ty
790     ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars' 
791                         , tcdTyPats = typats', tcdSynRhs = ty'},
792               fvs1 `plusFV` fvs2) }
793   where
794     syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name)
795
796 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, 
797                        tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
798                        tcdMeths = mbinds, tcdATs = ats, tcdDocs = docs})
799   = do  { cname' <- lookupLocatedTopBndrRn cname
800
801         -- Tyvars scope over superclass context and method signatures
802         ; ((tyvars', context', fds', ats', sigs'), stuff_fvs)
803             <- bindTyVarsFV tyvars $ \ tyvars' -> do
804                  -- Checks for distinct tyvars
805              { context' <- rnContext cls_doc context
806              ; fds' <- rnFds cls_doc fds
807              ; (ats', at_fvs) <- rnATs ats
808              ; sigs' <- renameSigs Nothing okClsDclSig sigs
809              ; let fvs = at_fvs `plusFV` 
810                          extractHsCtxtTyNames context'  `plusFV`
811                          hsSigsFVs sigs'
812                          -- The fundeps have no free variables
813              ; return ((tyvars', context', fds', ats', sigs'), fvs) }
814
815         -- No need to check for duplicate associated type decls
816         -- since that is done by RnNames.extendGlobalRdrEnvRn
817
818         -- Check the signatures
819         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
820         ; let sig_rdr_names_w_locs = [op | L _ (TypeSig ops _) <- sigs, op <- ops]
821         ; checkDupRdrNames sig_rdr_names_w_locs
822                 -- Typechecker is responsible for checking that we only
823                 -- give default-method bindings for things in this class.
824                 -- The renamer *could* check this for class decls, but can't
825                 -- for instance decls.
826
827         -- The newLocals call is tiresome: given a generic class decl
828         --      class C a where
829         --        op :: a -> a
830         --        op {| x+y |} (Inl a) = ...
831         --        op {| x+y |} (Inr b) = ...
832         --        op {| a*b |} (a*b)   = ...
833         -- we want to name both "x" tyvars with the same unique, so that they are
834         -- easy to group together in the typechecker.  
835         ; (mbinds', meth_fvs) 
836             <- extendTyVarEnvForMethodBinds tyvars' $
837                 -- No need to check for duplicate method signatures
838                 -- since that is done by RnNames.extendGlobalRdrEnvRn
839                 -- and the methods are already in scope
840                  rnMethodBinds (unLoc cname') (mkSigTvFn sigs') mbinds
841
842   -- Haddock docs 
843         ; docs' <- mapM (wrapLocM rnDocDecl) docs
844
845         ; return (ClassDecl { tcdCtxt = context', tcdLName = cname', 
846                               tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
847                               tcdMeths = mbinds', tcdATs = ats', tcdDocs = docs'},
848                   meth_fvs `plusFV` stuff_fvs) }
849   where
850     cls_doc  = text "In the declaration for class"      <+> ppr cname
851
852 badGadtStupidTheta :: Located RdrName -> SDoc
853 badGadtStupidTheta _
854   = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
855           ptext (sLit "(You can put a context on each contructor, though.)")]
856 \end{code}
857
858 Note [Stupid theta]
859 ~~~~~~~~~~~~~~~~~~~
860 Trac #3850 complains about a regression wrt 6.10 for 
861      data Show a => T a
862 There is no reason not to allow the stupid theta if there are no data
863 constructors.  It's still stupid, but does no harm, and I don't want
864 to cause programs to break unnecessarily (notably HList).  So if there
865 are no data constructors we allow h98_style = True
866
867
868 \begin{code}
869 depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)]
870 -- See Note [Dependency analysis of type and class decls]
871 depAnalTyClDecls ds_w_fvs
872   = stronglyConnCompFromEdgedVertices edges
873   where
874     edges = [ (d, tcdName (unLoc d), map get_assoc (nameSetToList fvs))
875             | (d, fvs) <- ds_w_fvs ]
876     get_assoc n = lookupNameEnv assoc_env n `orElse` n
877     assoc_env = mkNameEnv [ (tcdName assoc_decl, cls_name) 
878                           | (L _ (ClassDecl { tcdLName = L _ cls_name
879                                             , tcdATs   = ats }) ,_) <- ds_w_fvs
880                           , L _ assoc_decl <- ats ]
881 \end{code}
882
883 Note [Dependency analysis of type and class decls]
884 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
885 We need to do dependency analysis on type and class declarations
886 else we get bad error messages.  Consider
887
888      data T f a = MkT f a
889      data S f a = MkS f (T f a)
890
891 This has a kind error, but the error message is better if you
892 check T first, (fixing its kind) and *then* S.  If you do kind
893 inference together, you might get an error reported in S, which
894 is jolly confusing.  See Trac #4875
895
896
897 %*********************************************************
898 %*                                                      *
899 \subsection{Support code for type/data declarations}
900 %*                                                      *
901 %*********************************************************
902
903 \begin{code}
904 rnTyPats :: SDoc -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars)
905 -- Although, we are processing type patterns here, all type variables will
906 -- already be in scope (they are the same as in the 'tcdTyVars' field of the
907 -- type declaration to which these patterns belong)
908 rnTyPats _   _  Nothing
909   = return (Nothing, emptyFVs)
910 rnTyPats doc tc (Just typats) 
911   = do { typats' <- rnLHsTypes doc typats
912        ; let fvs = addOneFV (extractHsTyNames_s typats') (unLoc tc)
913              -- type instance => use, hence addOneFV
914        ; return (Just typats', fvs) }
915
916 rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
917 rnConDecls condecls
918   = do { condecls' <- mapM (wrapLocM rnConDecl) condecls
919        ; return (condecls', plusFVs (map conDeclFVs condecls')) }
920
921 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
922 rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
923                                , con_cxt = cxt, con_details = details
924                                , con_res = res_ty, con_doc = mb_doc
925                                , con_old_rec = old_rec, con_explicit = expl })
926   = do  { addLocM checkConName name
927         ; when old_rec (addWarn (deprecRecSyntax decl))
928         ; new_name <- lookupLocatedTopBndrRn name
929
930            -- For H98 syntax, the tvs are the existential ones
931            -- For GADT syntax, the tvs are all the quantified tyvars
932            -- Hence the 'filter' in the ResTyH98 case only
933         ; rdr_env <- getLocalRdrEnv
934         ; let in_scope     = (`elemLocalRdrEnv` rdr_env) . unLoc
935               arg_tys      = hsConDeclArgTys details
936               mentioned_tvs = case res_ty of
937                                ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys)
938                                ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
939
940          -- With an Explicit forall, check for unused binders
941          -- With Implicit, find the mentioned ones, and use them as binders
942         ; new_tvs <- case expl of
943                        Implicit -> return (userHsTyVarBndrs mentioned_tvs)
944                        Explicit -> do { warnUnusedForAlls doc tvs mentioned_tvs
945                                       ; return tvs }
946
947         ; mb_doc' <- rnMbLHsDoc mb_doc 
948
949         ; bindTyVarsRn new_tvs $ \new_tyvars -> do
950         { new_context <- rnContext doc cxt
951         ; new_details <- rnConDeclDetails doc details
952         ; (new_details', new_res_ty)  <- rnConResult doc new_details res_ty
953         ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context 
954                        , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }}
955  where
956     doc = text "In the definition of data constructor" <+> quotes (ppr name)
957     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy Boxed tys))
958
959 rnConResult :: SDoc
960             -> HsConDetails (LHsType Name) [ConDeclField Name]
961             -> ResType RdrName
962             -> RnM (HsConDetails (LHsType Name) [ConDeclField Name],
963                     ResType Name)
964 rnConResult _ details ResTyH98 = return (details, ResTyH98)
965 rnConResult doc details (ResTyGADT ty)
966   = do { ty' <- rnLHsType doc ty
967        ; let (arg_tys, res_ty) = splitHsFunType ty'
968                 -- We can finally split it up, 
969                 -- now the renamer has dealt with fixities
970                 -- See Note [Sorting out the result type] in RdrHsSyn
971
972              details' = case details of
973                            RecCon {}    -> details
974                            PrefixCon {} -> PrefixCon arg_tys
975                            InfixCon {}  -> pprPanic "rnConResult" (ppr ty)
976                           -- See Note [Sorting out the result type] in RdrHsSyn
977                 
978        ; when (not (null arg_tys) && case details of { RecCon {} -> True; _ -> False })
979               (addErr (badRecResTy doc))
980        ; return (details', ResTyGADT res_ty) }
981
982 rnConDeclDetails :: SDoc
983                  -> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
984                  -> RnM (HsConDetails (LHsType Name) [ConDeclField Name])
985 rnConDeclDetails doc (PrefixCon tys)
986   = mapM (rnLHsType doc) tys    `thenM` \ new_tys  ->
987     return (PrefixCon new_tys)
988
989 rnConDeclDetails doc (InfixCon ty1 ty2)
990   = rnLHsType doc ty1           `thenM` \ new_ty1 ->
991     rnLHsType doc ty2           `thenM` \ new_ty2 ->
992     return (InfixCon new_ty1 new_ty2)
993
994 rnConDeclDetails doc (RecCon fields)
995   = do  { new_fields <- rnConDeclFields doc fields
996                 -- No need to check for duplicate fields
997                 -- since that is done by RnNames.extendGlobalRdrEnvRn
998         ; return (RecCon new_fields) }
999
1000 -- Rename family declarations
1001 --
1002 -- * This function is parametrised by the routine handling the index
1003 --   variables.  On the toplevel, these are defining occurences, whereas they
1004 --   are usage occurences for associated types.
1005 --
1006 rnFamily :: TyClDecl RdrName 
1007          -> ([LHsTyVarBndr RdrName] -> 
1008              ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) ->
1009              RnM (TyClDecl Name, FreeVars))
1010          -> RnM (TyClDecl Name, FreeVars)
1011
1012 rnFamily (tydecl@TyFamily {tcdFlavour = flavour, 
1013                            tcdLName = tycon, tcdTyVars = tyvars}) 
1014         bindIdxVars =
1015       do { bindIdxVars tyvars $ \tyvars' -> do {
1016          ; tycon' <- lookupLocatedTopBndrRn tycon
1017          ; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon', 
1018                               tcdTyVars = tyvars', tcdKind = tcdKind tydecl}, 
1019                     emptyFVs) 
1020          } }
1021 rnFamily d _ = pprPanic "rnFamily" (ppr d)
1022
1023 -- Rename associated type declarations (in classes)
1024 --
1025 -- * This can be family declarations and (default) type instances
1026 --
1027 rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
1028 rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
1029   where
1030     rn_at (tydecl@TyFamily  {}) = rnFamily tydecl lookupIdxVars
1031     rn_at (tydecl@TySynonym {}) = 
1032       do
1033         unless (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
1034         rnTyClDecl tydecl
1035     rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"
1036
1037     lookupIdxVars tyvars cont = 
1038       do { checkForDups tyvars
1039          ; tyvars' <- mapM lookupIdxVar tyvars
1040          ; cont tyvars'
1041          }
1042     -- Type index variables must be class parameters, which are the only
1043     -- type variables in scope at this point.
1044     lookupIdxVar (L l tyvar) =
1045       do
1046         name' <- lookupOccRn (hsTyVarName tyvar)
1047         return $ L l (replaceTyVarName tyvar name')
1048
1049     -- Type variable may only occur once.
1050     --
1051     checkForDups [] = return ()
1052     checkForDups (L loc tv:ltvs) = 
1053       do { setSrcSpan loc $
1054              when (hsTyVarName tv `ltvElem` ltvs) $
1055                addErr (repeatedTyVar tv)
1056          ; checkForDups ltvs
1057          }
1058
1059     _       `ltvElem` [] = False
1060     rdrName `ltvElem` (L _ tv:ltvs)
1061       | rdrName == hsTyVarName tv = True
1062       | otherwise                 = rdrName `ltvElem` ltvs
1063
1064 deprecRecSyntax :: ConDecl RdrName -> SDoc
1065 deprecRecSyntax decl 
1066   = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl))
1067                  <+> ptext (sLit "uses deprecated syntax")
1068          , ptext (sLit "Instead, use the form")
1069          , nest 2 (ppr decl) ]   -- Pretty printer uses new form
1070
1071 badRecResTy :: SDoc -> SDoc
1072 badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
1073
1074 noPatterns :: SDoc
1075 noPatterns = text "Default definition for an associated synonym cannot have"
1076              <+> text "type pattern"
1077
1078 repeatedTyVar :: HsTyVarBndr RdrName -> SDoc
1079 repeatedTyVar tv = ptext (sLit "Illegal repeated type variable") <+>
1080                    quotes (ppr tv)
1081
1082 -- This data decl will parse OK
1083 --      data T = a Int
1084 -- treating "a" as the constructor.
1085 -- It is really hard to make the parser spot this malformation.
1086 -- So the renamer has to check that the constructor is legal
1087 --
1088 -- We can get an operator as the constructor, even in the prefix form:
1089 --      data T = :% Int Int
1090 -- from interface files, which always print in prefix form
1091
1092 checkConName :: RdrName -> TcRn ()
1093 checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
1094
1095 badDataCon :: RdrName -> SDoc
1096 badDataCon name
1097    = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)]
1098 \end{code}
1099
1100
1101 %*********************************************************
1102 %*                                                      *
1103 \subsection{Support code for type/data declarations}
1104 %*                                                      *
1105 %*********************************************************
1106
1107 Get the mapping from constructors to fields for this module.
1108 It's convenient to do this after the data type decls have been renamed
1109 \begin{code}
1110 extendRecordFieldEnv :: [[LTyClDecl RdrName]] -> [LInstDecl RdrName] -> TcM TcGblEnv
1111 extendRecordFieldEnv tycl_decls inst_decls
1112   = do  { tcg_env <- getGblEnv
1113         ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
1114         ; return (tcg_env { tcg_field_env = field_env' }) }
1115   where
1116     -- we want to lookup:
1117     --  (a) a datatype constructor
1118     --  (b) a record field
1119     -- knowing that they're from this module.
1120     -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn,
1121     -- which keeps only the local ones.
1122     lookup x = do { x' <- lookupLocatedTopBndrRn x
1123                     ; return $ unLoc x'}
1124
1125     all_data_cons :: [ConDecl RdrName]
1126     all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls
1127                          , L _ con <- cons ]
1128     all_tycl_decls = at_tycl_decls ++ concat tycl_decls
1129     at_tycl_decls = instDeclATs inst_decls  -- Do not forget associated types!
1130
1131     get_con (ConDecl { con_name = con, con_details = RecCon flds })
1132             (RecFields env fld_set)
1133         = do { con' <- lookup con
1134              ; flds' <- mapM lookup (map cd_fld_name flds)
1135              ; let env'    = extendNameEnv env con' flds'
1136                    fld_set' = addListToNameSet fld_set flds'
1137              ; return $ (RecFields env' fld_set') }
1138     get_con _ env = return env
1139 \end{code}
1140
1141 %*********************************************************
1142 %*                                                      *
1143 \subsection{Support code to rename types}
1144 %*                                                      *
1145 %*********************************************************
1146
1147 \begin{code}
1148 rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
1149
1150 rnFds doc fds
1151   = mapM (wrapLocM rn_fds) fds
1152   where
1153     rn_fds (tys1, tys2)
1154       = rnHsTyVars doc tys1             `thenM` \ tys1' ->
1155         rnHsTyVars doc tys2             `thenM` \ tys2' ->
1156         return (tys1', tys2')
1157
1158 rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name]
1159 rnHsTyVars doc tvs  = mapM (rnHsTyVar doc) tvs
1160
1161 rnHsTyVar :: SDoc -> RdrName -> RnM Name
1162 rnHsTyVar _doc tyvar = lookupOccRn tyvar
1163 \end{code}
1164
1165
1166 %*********************************************************
1167 %*                                                      *
1168         findSplice
1169 %*                                                      *
1170 %*********************************************************
1171
1172 This code marches down the declarations, looking for the first
1173 Template Haskell splice.  As it does so it
1174         a) groups the declarations into a HsGroup
1175         b) runs any top-level quasi-quotes
1176
1177 \begin{code}
1178 findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1179 findSplice ds = addl emptyRdrGroup ds
1180
1181 addl :: HsGroup RdrName -> [LHsDecl RdrName]
1182      -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1183 -- This stuff reverses the declarations (again) but it doesn't matter
1184 addl gp []           = return (gp, Nothing)
1185 addl gp (L l d : ds) = add gp l d ds
1186
1187
1188 add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
1189     -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1190
1191 add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds 
1192   = do { -- We've found a top-level splice.  If it is an *implicit* one 
1193          -- (i.e. a naked top level expression)
1194          case flag of
1195            Explicit -> return ()
1196            Implicit -> do { th_on <- xoptM Opt_TemplateHaskell
1197                           ; unless th_on $ setSrcSpan loc $
1198                             failWith badImplicitSplice }
1199
1200        ; return (gp, Just (splice, ds)) }
1201   where
1202     badImplicitSplice = ptext (sLit "Parse error: naked expression at top level")
1203
1204 #ifndef GHCI
1205 add _ _ (QuasiQuoteD qq) _
1206   = pprPanic "Can't do QuasiQuote declarations without GHCi" (ppr qq)
1207 #else
1208 add gp _ (QuasiQuoteD qq) ds            -- Expand quasiquotes
1209   = do { ds' <- runQuasiQuoteDecl qq
1210        ; addl gp (ds' ++ ds) }
1211 #endif
1212
1213 -- Class declarations: pull out the fixity signatures to the top
1214 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
1215   | isClassDecl d
1216   = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
1217     addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
1218   | otherwise
1219   = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
1220
1221 -- Signatures: fixity sigs go a different place than all others
1222 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
1223   = addl (gp {hs_fixds = L l f : ts}) ds
1224 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
1225   = addl (gp {hs_valds = add_sig (L l d) ts}) ds
1226
1227 -- Value declarations: use add_bind
1228 add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
1229   = addl (gp { hs_valds = add_bind (L l d) ts }) ds
1230
1231 -- The rest are routine
1232 add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
1233   = addl (gp { hs_instds = L l d : ts }) ds
1234 add gp@(HsGroup {hs_derivds = ts})  l (DerivD d) ds
1235   = addl (gp { hs_derivds = L l d : ts }) ds
1236 add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
1237   = addl (gp { hs_defds = L l d : ts }) ds
1238 add gp@(HsGroup {hs_fords  = ts}) l (ForD d) ds
1239   = addl (gp { hs_fords = L l d : ts }) ds
1240 add gp@(HsGroup {hs_warnds  = ts})  l (WarningD d) ds
1241   = addl (gp { hs_warnds = L l d : ts }) ds
1242 add gp@(HsGroup {hs_annds  = ts}) l (AnnD d) ds
1243   = addl (gp { hs_annds = L l d : ts }) ds
1244 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
1245   = addl (gp { hs_ruleds = L l d : ts }) ds
1246 add gp@(HsGroup {hs_vects  = ts}) l (VectD d) ds
1247   = addl (gp { hs_vects = L l d : ts }) ds
1248 add gp l (DocD d) ds
1249   = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
1250
1251 add_tycld :: LTyClDecl a -> [[LTyClDecl a]] -> [[LTyClDecl a]]
1252 add_tycld d []       = [[d]]
1253 add_tycld d (ds:dss) = (d:ds) : dss
1254
1255 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
1256 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
1257 add_bind _ (ValBindsOut {})     = panic "RdrHsSyn:add_bind"
1258
1259 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
1260 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) 
1261 add_sig _ (ValBindsOut {})     = panic "RdrHsSyn:add_sig"
1262 \end{code}