a3e5faf0cc87af6685695805319d6d832686c146
[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 {-# LANGUAGE CPP, ScopedTypeVariables #-}
8
9 module RnSource (
10         rnSrcDecls, addTcgDUs, rnTyClDecls, findSplice
11     ) where
12
13 #include "HsVersions.h"
14
15 import {-# SOURCE #-} RnExpr( rnLExpr )
16 import {-# SOURCE #-} RnSplice ( rnSpliceDecl )
17 import {-# SOURCE #-} TcSplice ( runQuasiQuoteDecl )
18
19 import HsSyn
20 import RdrName
21 import RnTypes
22 import RnBinds
23 import RnEnv
24 import RnNames
25 import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )
26 import TcAnnotations    ( annCtxt )
27 import TcRnMonad
28
29 import ForeignCall      ( CCallTarget(..) )
30 import Module
31 import HscTypes         ( Warnings(..), plusWarns )
32 import Class            ( FunDep )
33 import PrelNames        ( isUnboundName )
34 import Name
35 import NameSet
36 import NameEnv
37 import Avail
38 import Outputable
39 import Bag
40 import BasicTypes       ( RuleName )
41 import FastString
42 import SrcLoc
43 import DynFlags
44 import HscTypes         ( HscEnv, hsc_dflags )
45 import ListSetOps       ( findDupsEq, removeDups )
46 import Digraph          ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
47 import Util             ( mapSnd )
48
49 import Control.Monad
50 import Data.List( partition, sortBy )
51 #if __GLASGOW_HASKELL__ < 709
52 import Data.Traversable (traverse)
53 #endif
54 import Maybes( orElse, mapMaybe )
55 \end{code}
56
57 @rnSourceDecl@ `renames' declarations.
58 It simultaneously performs dependency analysis and precedence parsing.
59 It also does the following error checks:
60 \begin{enumerate}
61 \item
62 Checks that tyvars are used properly. This includes checking
63 for undefined tyvars, and tyvars in contexts that are ambiguous.
64 (Some of this checking has now been moved to module @TcMonoType@,
65 since we don't have functional dependency information at this point.)
66 \item
67 Checks that all variable occurrences are defined.
68 \item
69 Checks the @(..)@ etc constraints in the export list.
70 \end{enumerate}
71
72
73 \begin{code}
74 -- Brings the binders of the group into scope in the appropriate places;
75 -- does NOT assume that anything is in scope already
76 rnSrcDecls :: [Name] -> HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name)
77 -- Rename a HsGroup; used for normal source files *and* hs-boot files
78 rnSrcDecls extra_deps group@(HsGroup { hs_valds   = val_decls,
79                                        hs_splcds  = splice_decls,
80                                        hs_tyclds  = tycl_decls,
81                                        hs_instds  = inst_decls,
82                                        hs_derivds = deriv_decls,
83                                        hs_fixds   = fix_decls,
84                                        hs_warnds  = warn_decls,
85                                        hs_annds   = ann_decls,
86                                        hs_fords   = foreign_decls,
87                                        hs_defds   = default_decls,
88                                        hs_ruleds  = rule_decls,
89                                        hs_vects   = vect_decls,
90                                        hs_docs    = docs })
91  = do {
92    -- (A) Process the fixity declarations, creating a mapping from
93    --     FastStrings to FixItems.
94    --     Also checks for duplcates.
95    local_fix_env <- makeMiniFixityEnv fix_decls ;
96
97    -- (B) Bring top level binders (and their fixities) into scope,
98    --     *except* for the value bindings, which get brought in below.
99    --     However *do* include class ops, data constructors
100    --     And for hs-boot files *do* include the value signatures
101    (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;
102    setEnvs tc_envs $ do {
103
104    failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
105
106    -- (C) Extract the mapping from data constructors to field names and
107    --     extend the record field env.
108    --     This depends on the data constructors and field names being in
109    --     scope from (B) above
110    inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do {
111
112    -- (D) Rename the left-hand sides of the value bindings.
113    --     This depends on everything from (B) being in scope,
114    --     and on (C) for resolving record wild cards.
115    --     It uses the fixity env from (A) to bind fixities for view patterns.
116    new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
117    -- bind the LHSes (and their fixities) in the global rdr environment
118    let { val_binders = collectHsValBinders new_lhs ;
119          all_bndrs   = extendNameSetList tc_bndrs val_binders ;
120          val_avails  = map Avail val_binders  } ;
121    traceRn (text "rnSrcDecls" <+> ppr val_avails) ;
122    (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
123    traceRn (ptext (sLit "Val binders") <+> (ppr val_binders)) ;
124    setEnvs (tcg_env, tcl_env) $ do {
125
126    --  Now everything is in scope, as the remaining renaming assumes.
127
128    -- (E) Rename type and class decls
129    --     (note that value LHSes need to be in scope for default methods)
130    --
131    -- You might think that we could build proper def/use information
132    -- for type and class declarations, but they can be involved
133    -- in mutual recursion across modules, and we only do the SCC
134    -- analysis for them in the type checker.
135    -- So we content ourselves with gathering uses only; that
136    -- means we'll only report a declaration as unused if it isn't
137    -- mentioned at all.  Ah well.
138    traceRn (text "Start rnTyClDecls") ;
139    (rn_tycl_decls, src_fvs1) <- rnTyClDecls extra_deps tycl_decls ;
140
141    -- (F) Rename Value declarations right-hand sides
142    traceRn (text "Start rnmono") ;
143    (rn_val_decls, bind_dus) <- rnTopBindsRHS all_bndrs new_lhs ;
144    traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
145
146    -- (G) Rename Fixity and deprecations
147
148    -- Rename fixity declarations and error if we try to
149    -- fix something from another module (duplicates were checked in (A))
150    rn_fix_decls <- rnSrcFixityDecls all_bndrs fix_decls ;
151
152    -- Rename deprec decls;
153    -- check for duplicates and ensure that deprecated things are defined locally
154    -- at the moment, we don't keep these around past renaming
155    rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ;
156
157    -- (H) Rename Everything else
158
159    (rn_inst_decls,    src_fvs2) <- rnList rnSrcInstDecl   inst_decls ;
160    (rn_rule_decls,    src_fvs3) <- setXOptM Opt_ScopedTypeVariables $
161                                    rnList rnHsRuleDecl    rule_decls ;
162                            -- Inside RULES, scoped type variables are on
163    (rn_vect_decls,    src_fvs4) <- rnList rnHsVectDecl    vect_decls ;
164    (rn_foreign_decls, src_fvs5) <- rnList rnHsForeignDecl foreign_decls ;
165    (rn_ann_decls,     src_fvs6) <- rnList rnAnnDecl       ann_decls ;
166    (rn_default_decls, src_fvs7) <- rnList rnDefaultDecl   default_decls ;
167    (rn_deriv_decls,   src_fvs8) <- rnList rnSrcDerivDecl  deriv_decls ;
168    (rn_splice_decls,  src_fvs9) <- rnList rnSpliceDecl    splice_decls ;
169       -- Haddock docs; no free vars
170    rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
171
172     last_tcg_env <- getGblEnv ;
173    -- (I) Compute the results and return
174    let {rn_group = HsGroup { hs_valds   = rn_val_decls,
175                              hs_splcds  = rn_splice_decls,
176                              hs_tyclds  = rn_tycl_decls,
177                              hs_instds  = rn_inst_decls,
178                              hs_derivds = rn_deriv_decls,
179                              hs_fixds   = rn_fix_decls,
180                              hs_warnds  = [], -- warns are returned in the tcg_env
181                                              -- (see below) not in the HsGroup
182                              hs_fords  = rn_foreign_decls,
183                              hs_annds  = rn_ann_decls,
184                              hs_defds  = rn_default_decls,
185                              hs_ruleds = rn_rule_decls,
186                              hs_vects  = rn_vect_decls,
187                              hs_docs   = rn_docs } ;
188
189         tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ;
190         ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ;
191         other_def  = (Just (mkNameSet tycl_bndrs `unionNameSet` mkNameSet ford_bndrs), emptyNameSet) ;
192         other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
193                               src_fvs5, src_fvs6, src_fvs7, src_fvs8,
194                               src_fvs9] ;
195                 -- It is tiresome to gather the binders from type and class decls
196
197         src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
198                 -- Instance decls may have occurrences of things bound in bind_dus
199                 -- so we must put other_fvs last
200
201         final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus)
202                         in -- we return the deprecs in the env, not in the HsGroup above
203                         tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
204        } ;
205
206    traceRn (text "finish rnSrc" <+> ppr rn_group) ;
207    traceRn (text "finish Dus" <+> ppr src_dus ) ;
208    return (final_tcg_env, rn_group)
209                     }}}}
210
211 -- some utils because we do this a bunch above
212 -- compute and install the new env
213 inNewEnv :: TcM TcGblEnv -> (TcGblEnv -> TcM a) -> TcM a
214 inNewEnv env cont = do e <- env
215                        setGblEnv e $ cont e
216
217 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
218 -- This function could be defined lower down in the module hierarchy,
219 -- but there doesn't seem anywhere very logical to put it.
220 addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
221
222 rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
223 rnList f xs = mapFvRn (wrapLocFstM f) xs
224 \end{code}
225
226
227 %*********************************************************
228 %*                                                       *
229         HsDoc stuff
230 %*                                                       *
231 %*********************************************************
232
233 \begin{code}
234 rnDocDecl :: DocDecl -> RnM DocDecl
235 rnDocDecl (DocCommentNext doc) = do
236   rn_doc <- rnHsDoc doc
237   return (DocCommentNext rn_doc)
238 rnDocDecl (DocCommentPrev doc) = do
239   rn_doc <- rnHsDoc doc
240   return (DocCommentPrev rn_doc)
241 rnDocDecl (DocCommentNamed str doc) = do
242   rn_doc <- rnHsDoc doc
243   return (DocCommentNamed str rn_doc)
244 rnDocDecl (DocGroup lev doc) = do
245   rn_doc <- rnHsDoc doc
246   return (DocGroup lev rn_doc)
247 \end{code}
248
249
250 %*********************************************************
251 %*                                                       *
252         Source-code fixity declarations
253 %*                                                       *
254 %*********************************************************
255
256 \begin{code}
257 rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name]
258 -- Rename the fixity decls, so we can put
259 -- the renamed decls in the renamed syntax tree
260 -- Errors if the thing being fixed is not defined locally.
261 --
262 -- The returned FixitySigs are not actually used for anything,
263 -- except perhaps the GHCi API
264 rnSrcFixityDecls bndr_set fix_decls
265   = do fix_decls <- mapM rn_decl fix_decls
266        return (concat fix_decls)
267   where
268     sig_ctxt = TopSigCtxt bndr_set True
269        -- True <=> can give fixity for class decls and record selectors
270
271     rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
272         -- GHC extension: look up both the tycon and data con
273         -- for con-like things; hence returning a list
274         -- If neither are in scope, report an error; otherwise
275         -- return a fixity sig for each (slightly odd)
276     rn_decl (L loc (FixitySig fnames fixity))
277       = do names <- mapM lookup_one fnames
278            return [ L loc (FixitySig name fixity)
279                   | name <- names ]
280
281     lookup_one :: Located RdrName -> RnM [Located Name]
282     lookup_one (L name_loc rdr_name)
283       = setSrcSpan name_loc $
284                     -- this lookup will fail if the definition isn't local
285         do names <- lookupLocalTcNames sig_ctxt what rdr_name
286            return [ L name_loc name | name <- names ]
287     what = ptext (sLit "fixity signature")
288 \end{code}
289
290
291 %*********************************************************
292 %*                                                       *
293         Source-code deprecations declarations
294 %*                                                       *
295 %*********************************************************
296
297 Check that the deprecated names are defined, are defined locally, and
298 that there are no duplicate deprecations.
299
300 It's only imported deprecations, dealt with in RnIfaces, that we
301 gather them together.
302
303 \begin{code}
304 -- checks that the deprecations are defined locally, and that there are no duplicates
305 rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings
306 rnSrcWarnDecls _ []
307   = return NoWarnings
308
309 rnSrcWarnDecls bndr_set decls
310   = do { -- check for duplicates
311        ; mapM_ (\ dups -> let (L loc rdr:lrdr':_) = dups
312                           in addErrAt loc (dupWarnDecl lrdr' rdr))
313                warn_rdr_dups
314        ; pairs_s <- mapM (addLocM rn_deprec) decls
315        ; return (WarnSome ((concat pairs_s))) }
316  where
317    sig_ctxt = TopSigCtxt bndr_set True
318       -- True <=> Can give deprecations for class ops and record sels
319
320    rn_deprec (Warning rdr_name txt)
321        -- ensures that the names are defined locally
322      = do { names <- lookupLocalTcNames sig_ctxt what rdr_name
323           ; return [(nameOccName name, txt) | name <- names] }
324
325    what = ptext (sLit "deprecation")
326
327    warn_rdr_dups = findDupRdrNames (map (\ (L loc (Warning rdr_name _)) -> L loc rdr_name) decls)
328
329 findDupRdrNames :: [Located RdrName] -> [[Located RdrName]]
330 findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
331
332 -- look for duplicates among the OccNames;
333 -- we check that the names are defined above
334 -- invt: the lists returned by findDupsEq always have at least two elements
335
336 dupWarnDecl :: Located RdrName -> RdrName -> SDoc
337 -- Located RdrName -> DeprecDecl RdrName -> SDoc
338 dupWarnDecl (L loc _) rdr_name
339   = vcat [ptext (sLit "Multiple warning declarations for") <+> quotes (ppr rdr_name),
340           ptext (sLit "also at ") <+> ppr loc]
341
342 \end{code}
343
344 %*********************************************************
345 %*                                                      *
346 \subsection{Annotation declarations}
347 %*                                                      *
348 %*********************************************************
349
350 \begin{code}
351 rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars)
352 rnAnnDecl ann@(HsAnnotation provenance expr)
353   = addErrCtxt (annCtxt ann) $
354     do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
355        ; (expr', expr_fvs) <- setStage (Splice False) $
356                               rnLExpr expr
357        ; return (HsAnnotation provenance' expr', provenance_fvs `plusFV` expr_fvs) }
358
359 rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars)
360 rnAnnProvenance provenance = do
361     provenance' <- traverse lookupTopBndrRn provenance
362     return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))
363 \end{code}
364
365 %*********************************************************
366 %*                                                      *
367 \subsection{Default declarations}
368 %*                                                      *
369 %*********************************************************
370
371 \begin{code}
372 rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars)
373 rnDefaultDecl (DefaultDecl tys)
374   = do { (tys', fvs) <- rnLHsTypes doc_str tys
375        ; return (DefaultDecl tys', fvs) }
376   where
377     doc_str = DefaultDeclCtx
378 \end{code}
379
380 %*********************************************************
381 %*                                                      *
382 \subsection{Foreign declarations}
383 %*                                                      *
384 %*********************************************************
385
386 \begin{code}
387 rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
388 rnHsForeignDecl (ForeignImport name ty _ spec)
389   = do { topEnv :: HscEnv <- getTopEnv
390        ; name' <- lookupLocatedTopBndrRn name
391        ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty
392
393         -- Mark any PackageTarget style imports as coming from the current package
394        ; let packageKey = thisPackage $ hsc_dflags topEnv
395              spec'      = patchForeignImport packageKey spec
396
397        ; return (ForeignImport name' ty' noForeignImportCoercionYet spec', fvs) }
398
399 rnHsForeignDecl (ForeignExport name ty _ spec)
400   = do { name' <- lookupLocatedOccRn name
401        ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty
402        ; return (ForeignExport name' ty' noForeignExportCoercionYet spec, fvs `addOneFV` unLoc name') }
403         -- NB: a foreign export is an *occurrence site* for name, so
404         --     we add it to the free-variable list.  It might, for example,
405         --     be imported from another module
406
407 -- | For Windows DLLs we need to know what packages imported symbols are from
408 --      to generate correct calls. Imported symbols are tagged with the current
409 --      package, so if they get inlined across a package boundry we'll still
410 --      know where they're from.
411 --
412 patchForeignImport :: PackageKey -> ForeignImport -> ForeignImport
413 patchForeignImport packageKey (CImport cconv safety fs spec src)
414         = CImport cconv safety fs (patchCImportSpec packageKey spec) src
415
416 patchCImportSpec :: PackageKey -> CImportSpec -> CImportSpec
417 patchCImportSpec packageKey spec
418  = case spec of
419         CFunction callTarget    -> CFunction $ patchCCallTarget packageKey callTarget
420         _                       -> spec
421
422 patchCCallTarget :: PackageKey -> CCallTarget -> CCallTarget
423 patchCCallTarget packageKey callTarget =
424   case callTarget of
425   StaticTarget label Nothing isFun -> StaticTarget label (Just packageKey) isFun
426   _                                -> callTarget
427
428
429 \end{code}
430
431
432 %*********************************************************
433 %*                                                      *
434 \subsection{Instance declarations}
435 %*                                                      *
436 %*********************************************************
437
438 \begin{code}
439 rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars)
440 rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
441   = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi
442        ; return (TyFamInstD { tfid_inst = tfi' }, fvs) }
443
444 rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
445   = do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi
446        ; return (DataFamInstD { dfid_inst = dfi' }, fvs) }
447
448 rnSrcInstDecl (ClsInstD { cid_inst = cid })
449   = do { (cid', fvs) <- rnClsInstDecl cid
450        ; return (ClsInstD { cid_inst = cid' }, fvs) }
451
452 rnClsInstDecl :: ClsInstDecl RdrName -> RnM (ClsInstDecl Name, FreeVars)
453 rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
454                            , cid_sigs = uprags, cid_tyfam_insts = ats
455                            , cid_overlap_mode = oflag
456                            , cid_datafam_insts = adts })
457         -- Used for both source and interface file decls
458   = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty
459        ; case splitLHsInstDeclTy_maybe inst_ty' of {
460            Nothing -> return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds
461                                           , cid_sigs = [], cid_tyfam_insts = []
462                                           , cid_overlap_mode = oflag
463                                           , cid_datafam_insts = [] }
464                              , inst_fvs) ;
465            Just (inst_tyvars, _, L _ cls,_) ->
466
467     do { let (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags
468              ktv_names = hsLKiTyVarNames inst_tyvars
469
470        -- Rename the associated types, and type signatures
471        -- Both need to have the instance type variables in scope
472        ; traceRn (text "rnSrcInstDecl"  <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names)
473        ; ((ats', adts', other_sigs'), more_fvs)
474              <- extendTyVarEnvFVRn ktv_names $
475                 do { (ats',  at_fvs)  <- rnATInstDecls rnTyFamInstDecl cls inst_tyvars ats
476                    ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls inst_tyvars adts
477                    ; (other_sigs', sig_fvs) <- renameSigs (InstDeclCtxt cls) other_sigs
478                    ; return ( (ats', adts', other_sigs')
479                             , at_fvs `plusFV` adt_fvs `plusFV` sig_fvs) }
480
481         -- Rename the bindings
482         -- The typechecker (not the renamer) checks that all
483         -- the bindings are for the right class
484         -- (Slightly strangely) when scoped type variables are on, the
485         -- forall-d tyvars scope over the method bindings too
486        ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds ktv_names $
487                                 rnMethodBinds cls (mkSigTvFn other_sigs')
488                                                   mbinds
489
490         -- Rename the SPECIALISE instance pramas
491         -- Annoyingly the type variables are not in scope here,
492         -- so that      instance Eq a => Eq (T a) where
493         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
494         -- works OK. That's why we did the partition game above
495         --
496        ; (spec_inst_prags', spec_inst_fvs)
497              <- renameSigs (InstDeclCtxt cls) spec_inst_prags
498
499        ; let uprags' = spec_inst_prags' ++ other_sigs'
500              all_fvs = meth_fvs `plusFV` more_fvs
501                           `plusFV` spec_inst_fvs
502                           `plusFV` inst_fvs
503        ; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds'
504                              , cid_sigs = uprags', cid_tyfam_insts = ats'
505                              , cid_overlap_mode = oflag
506                              , cid_datafam_insts = adts' },
507                  all_fvs) } } }
508              -- We return the renamed associated data type declarations so
509              -- that they can be entered into the list of type declarations
510              -- for the binding group, but we also keep a copy in the instance.
511              -- The latter is needed for well-formedness checks in the type
512              -- checker (eg, to ensure that all ATs of the instance actually
513              -- receive a declaration).
514              -- NB: Even the copies in the instance declaration carry copies of
515              --     the instance context after renaming.  This is a bit
516              --     strange, but should not matter (and it would be more work
517              --     to remove the context).
518
519 rnFamInstDecl :: HsDocContext
520               -> Maybe (Name, [Name])
521               -> Located RdrName
522               -> [LHsType RdrName]
523               -> rhs
524               -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
525               -> RnM (Located Name, HsWithBndrs Name [LHsType Name], rhs',
526                       FreeVars)
527 rnFamInstDecl doc mb_cls tycon pats payload rnPayload
528   = do { tycon'   <- lookupFamInstName (fmap fst mb_cls) tycon
529        ; let loc = case pats of
530                      []             -> pprPanic "rnFamInstDecl" (ppr tycon)
531                      (L loc _ : []) -> loc
532                      (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
533              (kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats
534
535
536        ; rdr_env  <- getLocalRdrEnv
537        ; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names
538        ; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names
539              -- All the free vars of the family patterns
540              -- with a sensible binding location
541        ; ((pats', payload'), fvs)
542               <- bindLocalNamesFV kv_names $
543                  bindLocalNamesFV tv_names $
544                  do { (pats', pat_fvs) <- rnLHsTypes doc pats
545                     ; (payload', rhs_fvs) <- rnPayload doc payload
546
547                          -- See Note [Renaming associated types]
548                     ; let lhs_names = mkNameSet kv_names `unionNameSet` mkNameSet tv_names
549                           bad_tvs = case mb_cls of
550                                       Nothing           -> []
551                                       Just (_,cls_tkvs) -> filter is_bad cls_tkvs
552
553                           is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs
554                                         && not (cls_tkv `elemNameSet` lhs_names)
555
556                     ; unless (null bad_tvs) (badAssocRhs bad_tvs)
557                     ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }
558
559
560        ; let all_fvs = fvs `addOneFV` unLoc tycon'
561        ; return (tycon',
562                  HsWB { hswb_cts = pats', hswb_kvs = kv_names, hswb_tvs = tv_names },
563                  payload',
564                  all_fvs) }
565              -- type instance => use, hence addOneFV
566
567 rnTyFamInstDecl :: Maybe (Name, [Name])
568                 -> TyFamInstDecl RdrName
569                 -> RnM (TyFamInstDecl Name, FreeVars)
570 rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn })
571   = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn
572        ; return (TyFamInstDecl { tfid_eqn = L loc eqn'
573                                , tfid_fvs = fvs }, fvs) }
574
575 rnTyFamInstEqn :: Maybe (Name, [Name])
576                -> TyFamInstEqn RdrName
577                -> RnM (TyFamInstEqn Name, FreeVars)
578 rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon
579                                 , tfe_pats  = HsWB { hswb_cts = pats }
580                                 , tfe_rhs   = rhs })
581   = do { (tycon', pats', rhs', fvs) <-
582            rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn
583        ; return (TyFamEqn { tfe_tycon = tycon'
584                           , tfe_pats  = pats'
585                           , tfe_rhs   = rhs' }, fvs) }
586
587 rnTyFamDefltEqn :: Name
588                 -> TyFamDefltEqn RdrName
589                 -> RnM (TyFamDefltEqn Name, FreeVars)
590 rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon
591                               , tfe_pats  = tyvars
592                               , tfe_rhs   = rhs })
593   = bindHsTyVars ctx (Just cls) [] tyvars $ \ tyvars' ->
594     do { tycon'      <- lookupFamInstName (Just cls) tycon
595        ; (rhs', fvs) <- rnLHsType ctx rhs
596        ; return (TyFamEqn { tfe_tycon = tycon'
597                           , tfe_pats  = tyvars'
598                           , tfe_rhs   = rhs' }, fvs) }
599   where
600     ctx = TyFamilyCtx tycon
601
602 rnDataFamInstDecl :: Maybe (Name, [Name])
603                   -> DataFamInstDecl RdrName
604                   -> RnM (DataFamInstDecl Name, FreeVars)
605 rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon
606                                           , dfid_pats  = HsWB { hswb_cts = pats }
607                                           , dfid_defn  = defn })
608   = do { (tycon', pats', defn', fvs) <-
609            rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn
610        ; return (DataFamInstDecl { dfid_tycon = tycon'
611                                  , dfid_pats  = pats'
612                                  , dfid_defn  = defn'
613                                  , dfid_fvs   = fvs }, fvs) }
614 \end{code}
615
616 Renaming of the associated types in instances.
617
618 \begin{code}
619 -- Rename associated type family decl in class
620 rnATDecls :: Name      -- Class
621           -> [LFamilyDecl RdrName]
622           -> RnM ([LFamilyDecl Name], FreeVars)
623 rnATDecls cls at_decls
624   = rnList (rnFamDecl (Just cls)) at_decls
625
626 rnATInstDecls :: (Maybe (Name, [Name]) ->    -- The function that renames
627                   decl RdrName ->            -- an instance. rnTyFamInstDecl
628                   RnM (decl Name, FreeVars)) -- or rnDataFamInstDecl
629               -> Name      -- Class
630               -> LHsTyVarBndrs Name
631               -> [Located (decl RdrName)]
632               -> RnM ([Located (decl Name)], FreeVars)
633 -- Used for data and type family defaults in a class decl
634 -- and the family instance declarations in an instance
635 --
636 -- NB: We allow duplicate associated-type decls;
637 --     See Note [Associated type instances] in TcInstDcls
638 rnATInstDecls rnFun cls hs_tvs at_insts
639   = rnList (rnFun (Just (cls, tv_ns))) at_insts
640   where
641     tv_ns = hsLKiTyVarNames hs_tvs
642     -- See Note [Renaming associated types]
643 \end{code}
644
645 Note [Renaming associated types]
646 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
647 Check that the RHS of the decl mentions only type variables
648 bound on the LHS.  For example, this is not ok
649    class C a b where
650       type F a x :: *
651    instance C (p,q) r where
652       type F (p,q) x = (x, r)   -- BAD: mentions 'r'
653 c.f. Trac #5515
654
655 The same thing applies to kind variables, of course (Trac #7938, #9574):
656    class Funct f where
657       type Codomain f :: *
658    instance Funct ('KProxy :: KProxy o) where
659       type Codomain 'KProxy = NatTr (Proxy :: o -> *)
660 Here 'o' is mentioned on the RHS of the Codomain function, but
661 not on the LHS.
662
663 All this applies only for *instance* declarations.  In *class*
664 declarations there is no RHS to worry about, and the class variables
665 can all be in scope (Trac #5862):
666     class Category (x :: k -> k -> *) where
667       type Ob x :: k -> Constraint
668       id :: Ob x a => x a a
669       (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c
670 Here 'k' is in scope in the kind signature, just like 'x'.
671
672
673 \begin{code}
674 extendTyVarEnvForMethodBinds :: [Name]
675                              -> RnM (LHsBinds Name, FreeVars)
676                              -> RnM (LHsBinds Name, FreeVars)
677 -- For the method bindings in class and instance decls, we extend
678 -- the type variable environment iff -XScopedTypeVariables
679
680 extendTyVarEnvForMethodBinds ktv_names thing_inside
681   = do  { scoped_tvs <- xoptM Opt_ScopedTypeVariables
682         ; if scoped_tvs then
683                 extendTyVarEnvFVRn ktv_names thing_inside
684           else
685                 thing_inside }
686 \end{code}
687
688 %*********************************************************
689 %*                                                      *
690 \subsection{Stand-alone deriving declarations}
691 %*                                                      *
692 %*********************************************************
693
694 \begin{code}
695 rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
696 rnSrcDerivDecl (DerivDecl ty overlap)
697   = do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving
698        ; unless standalone_deriv_ok (addErr standaloneDerivErr)
699        ; (ty', fvs) <- rnLHsInstType (text "In a deriving declaration") ty
700        ; return (DerivDecl ty' overlap, fvs) }
701
702 standaloneDerivErr :: SDoc
703 standaloneDerivErr
704   = hang (ptext (sLit "Illegal standalone deriving declaration"))
705        2 (ptext (sLit "Use StandaloneDeriving to enable this extension"))
706 \end{code}
707
708 %*********************************************************
709 %*                                                      *
710 \subsection{Rules}
711 %*                                                      *
712 %*********************************************************
713
714 \begin{code}
715 rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
716 rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
717   = do { let rdr_names_w_loc = map get_var vars
718        ; checkDupRdrNames rdr_names_w_loc
719        ; checkShadowedRdrNames rdr_names_w_loc
720        ; names <- newLocalBndrsRn rdr_names_w_loc
721        ; bindHsRuleVars (unLoc rule_name) vars names $ \ vars' ->
722     do { (lhs', fv_lhs') <- rnLExpr lhs
723        ; (rhs', fv_rhs') <- rnLExpr rhs
724        ; checkValidRule (unLoc rule_name) names lhs' fv_lhs'
725        ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
726                  fv_lhs' `plusFV` fv_rhs') } }
727   where
728     get_var (L _ (RuleBndrSig v _)) = v
729     get_var (L _ (RuleBndr v)) = v
730
731 bindHsRuleVars :: RuleName -> [LRuleBndr RdrName] -> [Name]
732                -> ([LRuleBndr Name] -> RnM (a, FreeVars))
733                -> RnM (a, FreeVars)
734 bindHsRuleVars rule_name vars names thing_inside
735   = go vars names $ \ vars' ->
736     bindLocalNamesFV names (thing_inside vars')
737   where
738     doc = RuleCtx rule_name
739
740     go (L l (RuleBndr (L loc _)) : vars) (n : ns) thing_inside
741       = go vars ns $ \ vars' ->
742         thing_inside (L l (RuleBndr (L loc n)) : vars')
743
744     go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside
745       = rnHsBndrSig doc bsig $ \ bsig' ->
746         go vars ns $ \ vars' ->
747         thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars')
748
749     go [] [] thing_inside = thing_inside []
750     go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
751 \end{code}
752
753 Note [Rule LHS validity checking]
754 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
755 Check the shape of a transformation rule LHS.  Currently we only allow
756 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
757 @forall@'d variables.
758
759 We used restrict the form of the 'ei' to prevent you writing rules
760 with LHSs with a complicated desugaring (and hence unlikely to match);
761 (e.g. a case expression is not allowed: too elaborate.)
762
763 But there are legitimate non-trivial args ei, like sections and
764 lambdas.  So it seems simmpler not to check at all, and that is why
765 check_e is commented out.
766
767 \begin{code}
768 checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()
769 checkValidRule rule_name ids lhs' fv_lhs'
770   = do  {       -- Check for the form of the LHS
771           case (validRuleLhs ids lhs') of
772                 Nothing  -> return ()
773                 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
774
775                 -- Check that LHS vars are all bound
776         ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
777         ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
778
779 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
780 -- Nothing => OK
781 -- Just e  => Not ok, and e is the offending expression
782 validRuleLhs foralls lhs
783   = checkl lhs
784   where
785     checkl (L _ e) = check e
786
787     check (OpApp e1 op _ e2)              = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
788     check (HsApp e1 e2)                   = checkl e1 `mplus` checkl_e e2
789     check (HsVar v) | v `notElem` foralls = Nothing
790     check other                           = Just other  -- Failure
791
792         -- Check an argument
793     checkl_e (L _ _e) = Nothing         -- Was (check_e e); see Note [Rule LHS validity checking]
794
795 {-      Commented out; see Note [Rule LHS validity checking] above
796     check_e (HsVar v)     = Nothing
797     check_e (HsPar e)     = checkl_e e
798     check_e (HsLit e)     = Nothing
799     check_e (HsOverLit e) = Nothing
800
801     check_e (OpApp e1 op _ e2)   = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
802     check_e (HsApp e1 e2)        = checkl_e e1 `mplus` checkl_e e2
803     check_e (NegApp e _)         = checkl_e e
804     check_e (ExplicitList _ es)  = checkl_es es
805     check_e other                = Just other   -- Fails
806
807     checkl_es es = foldr (mplus . checkl_e) Nothing es
808 -}
809
810 badRuleVar :: FastString -> Name -> SDoc
811 badRuleVar name var
812   = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
813          ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+>
814                 ptext (sLit "does not appear on left hand side")]
815
816 badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
817 badRuleLhsErr name lhs bad_e
818   = sep [ptext (sLit "Rule") <+> ftext name <> colon,
819          nest 4 (vcat [ptext (sLit "Illegal expression:") <+> ppr bad_e,
820                        ptext (sLit "in left-hand side:") <+> ppr lhs])]
821     $$
822     ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd")
823 \end{code}
824
825
826 %*********************************************************
827 %*                                                      *
828 \subsection{Vectorisation declarations}
829 %*                                                      *
830 %*********************************************************
831
832 \begin{code}
833 rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars)
834 -- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly
835 --        typecheck a complex right-hand side without invoking 'vectType' from the vectoriser.
836 rnHsVectDecl (HsVect var rhs@(L _ (HsVar _)))
837   = do { var' <- lookupLocatedOccRn var
838        ; (rhs', fv_rhs) <- rnLExpr rhs
839        ; return (HsVect var' rhs', fv_rhs `addOneFV` unLoc var')
840        }
841 rnHsVectDecl (HsVect _var _rhs)
842   = failWith $ vcat
843                [ ptext (sLit "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma")
844                , ptext (sLit "must be an identifier")
845                ]
846 rnHsVectDecl (HsNoVect var)
847   = do { var' <- lookupLocatedTopBndrRn var           -- only applies to local (not imported) names
848        ; return (HsNoVect var', unitFV (unLoc var'))
849        }
850 rnHsVectDecl (HsVectTypeIn isScalar tycon Nothing)
851   = do { tycon' <- lookupLocatedOccRn tycon
852        ; return (HsVectTypeIn isScalar tycon' Nothing, unitFV (unLoc tycon'))
853        }
854 rnHsVectDecl (HsVectTypeIn isScalar tycon (Just rhs_tycon))
855   = do { tycon'     <- lookupLocatedOccRn tycon
856        ; rhs_tycon' <- lookupLocatedOccRn rhs_tycon
857        ; return ( HsVectTypeIn isScalar tycon' (Just rhs_tycon')
858                 , mkFVs [unLoc tycon', unLoc rhs_tycon'])
859        }
860 rnHsVectDecl (HsVectTypeOut _ _ _)
861   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"
862 rnHsVectDecl (HsVectClassIn cls)
863   = do { cls' <- lookupLocatedOccRn cls
864        ; return (HsVectClassIn cls', unitFV (unLoc cls'))
865        }
866 rnHsVectDecl (HsVectClassOut _)
867   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
868 rnHsVectDecl (HsVectInstIn instTy)
869   = do { (instTy', fvs) <- rnLHsInstType (text "In a VECTORISE pragma") instTy
870        ; return (HsVectInstIn instTy', fvs)
871        }
872 rnHsVectDecl (HsVectInstOut _)
873   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
874 \end{code}
875
876 %*********************************************************
877 %*                                                      *
878 \subsection{Type, class and iface sig declarations}
879 %*                                                      *
880 %*********************************************************
881
882 @rnTyDecl@ uses the `global name function' to create a new type
883 declaration in which local names have been replaced by their original
884 names, reporting any unknown names.
885
886 Renaming type variables is a pain. Because they now contain uniques,
887 it is necessary to pass in an association list which maps a parsed
888 tyvar to its @Name@ representation.
889 In some cases (type signatures of values),
890 it is even necessary to go over the type first
891 in order to get the set of tyvars used by it, make an assoc list,
892 and then go over it again to rename the tyvars!
893 However, we can also do some scoping checks at the same time.
894
895
896 Note [Extra dependencies from .hs-boot files]
897 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
898 Consider the following case:
899
900   module A where
901     import B
902     data A1 = A1 B1
903
904   module B where
905     import {-# SOURCE #-} A
906     type DisguisedA1 = A1
907     data B1 = B1 DisguisedA1
908
909 We do not follow type synonyms when building the dependencies for each datatype,
910 so we will not find out that B1 really depends on A1 (which means it depends on
911 itself). To handle this problem, at the moment we add dependencies to everything
912 that comes from an .hs-boot file. But we don't add those dependencies to
913 everything. Imagine module B above had another datatype declaration:
914
915   data B2 = B2 Int
916
917 Even though B2 has a dependency (on Int), all its dependencies are from things
918 that live on other packages. Since we don't have mutual dependencies across
919 packages, it is safe not to add the dependencies on the .hs-boot stuff to B2.
920
921 See also Note [Grouping of type and class declarations] in TcTyClsDecls.
922
923 \begin{code}
924 isInPackage :: PackageKey -> Name -> Bool
925 isInPackage pkgId nm = case nameModule_maybe nm of
926                          Nothing -> False
927                          Just m  -> pkgId == modulePackageKey m
928 -- We use nameModule_maybe because we might be in a TH splice, in which case
929 -- there is no module name. In that case we cannot have mutual dependencies,
930 -- so it's fine to return False here.
931
932 rnTyClDecls :: [Name] -> [TyClGroup RdrName]
933             -> RnM ([TyClGroup Name], FreeVars)
934 -- Rename the declarations and do depedency analysis on them
935 rnTyClDecls extra_deps tycl_ds
936   = do { ds_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupConcat tycl_ds)
937        ; role_annot_env <- rnRoleAnnots (concatMap group_roles tycl_ds)
938        ; thisPkg  <- fmap thisPackage getDynFlags
939        ; let add_boot_deps :: FreeVars -> FreeVars
940              -- See Note [Extra dependencies from .hs-boot files]
941              add_boot_deps fvs | any (isInPackage thisPkg) (nameSetElems fvs)
942                                = fvs `plusFV` mkFVs extra_deps
943                                | otherwise
944                                = fvs
945
946              ds_w_fvs' = mapSnd add_boot_deps ds_w_fvs
947
948              sccs :: [SCC (LTyClDecl Name)]
949              sccs = depAnalTyClDecls ds_w_fvs'
950
951              all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs'
952
953              raw_groups = map flattenSCC sccs
954              -- See Note [Role annotations in the renamer]
955              (groups, orphan_roles)
956                = foldr (\group (groups_acc, orphans_acc) ->
957                          let names = map (tcdName . unLoc) group
958                              roles = mapMaybe (lookupNameEnv orphans_acc) names
959                              orphans' = delListFromNameEnv orphans_acc names
960                               -- there doesn't seem to be an interface to
961                               -- do the above more efficiently
962                          in ( TyClGroup { group_tyclds = group
963                                         , group_roles  = roles } : groups_acc
964                             , orphans' )
965                        )
966                        ([], role_annot_env)
967                        raw_groups
968
969        ; mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles)
970        ; traceRn (text "rnTycl"  <+> (ppr ds_w_fvs $$ ppr sccs))
971        ; return (groups, all_fvs) }
972
973 rnTyClDecl :: TyClDecl RdrName
974            -> RnM (TyClDecl Name, FreeVars)
975
976 -- All flavours of type family declarations ("type family", "newtype family",
977 -- and "data family"), both top level and (for an associated type)
978 -- in a class decl
979 rnTyClDecl (FamDecl { tcdFam = decl })
980   = do { (decl', fvs) <- rnFamDecl Nothing decl
981        ; return (FamDecl decl', fvs) }
982
983 rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs })
984   = do { tycon' <- lookupLocatedTopBndrRn tycon
985        ; let kvs = fst (extractHsTyRdrTyVars rhs)
986              doc = TySynCtx tycon
987        ; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
988        ; ((tyvars', rhs'), fvs) <- bindHsTyVars doc Nothing kvs tyvars $
989                                     \ tyvars' ->
990                                     do { (rhs', fvs) <- rnTySyn doc rhs
991                                        ; return ((tyvars', rhs'), fvs) }
992        ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
993                          , tcdRhs = rhs', tcdFVs = fvs }, fvs) }
994
995 -- "data", "newtype" declarations
996 -- both top level and (for an associated type) in an instance decl
997 rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn })
998   = do { tycon' <- lookupLocatedTopBndrRn tycon
999        ; let kvs = extractDataDefnKindVars defn
1000              doc = TyDataCtx tycon
1001        ; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs)
1002        ; ((tyvars', defn'), fvs) <- bindHsTyVars doc Nothing kvs tyvars $ \ tyvars' ->
1003                                     do { (defn', fvs) <- rnDataDefn doc defn
1004                                        ; return ((tyvars', defn'), fvs) }
1005        ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
1006                           , tcdDataDefn = defn', tcdFVs = fvs }, fvs) }
1007
1008 rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls,
1009                               tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
1010                               tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
1011                               tcdDocs = docs})
1012   = do  { lcls' <- lookupLocatedTopBndrRn lcls
1013         ; let cls' = unLoc lcls'
1014               kvs = []  -- No scoped kind vars except those in
1015                         -- kind signatures on the tyvars
1016
1017         -- Tyvars scope over superclass context and method signatures
1018         ; ((tyvars', context', fds', ats', sigs'), stuff_fvs)
1019             <- bindHsTyVars cls_doc Nothing kvs tyvars $ \ tyvars' -> do
1020                   -- Checks for distinct tyvars
1021              { (context', cxt_fvs) <- rnContext cls_doc context
1022              ; fds'  <- rnFds fds
1023                          -- The fundeps have no free variables
1024              ; (ats',   fv_ats) <- rnATDecls cls' ats
1025              ; (sigs', sig_fvs) <- renameSigs (ClsDeclCtxt cls') sigs
1026              ; let fvs = cxt_fvs     `plusFV`
1027                          sig_fvs     `plusFV`
1028                          fv_ats
1029              ; return ((tyvars', context', fds', ats', sigs'), fvs) }
1030
1031         ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs
1032
1033         -- No need to check for duplicate associated type decls
1034         -- since that is done by RnNames.extendGlobalRdrEnvRn
1035
1036         -- Check the signatures
1037         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
1038         ; let sig_rdr_names_w_locs = [op | L _ (TypeSig ops _) <- sigs, op <- ops]
1039         ; checkDupRdrNames sig_rdr_names_w_locs
1040                 -- Typechecker is responsible for checking that we only
1041                 -- give default-method bindings for things in this class.
1042                 -- The renamer *could* check this for class decls, but can't
1043                 -- for instance decls.
1044
1045         -- The newLocals call is tiresome: given a generic class decl
1046         --      class C a where
1047         --        op :: a -> a
1048         --        op {| x+y |} (Inl a) = ...
1049         --        op {| x+y |} (Inr b) = ...
1050         --        op {| a*b |} (a*b)   = ...
1051         -- we want to name both "x" tyvars with the same unique, so that they are
1052         -- easy to group together in the typechecker.
1053         ; (mbinds', meth_fvs)
1054             <- extendTyVarEnvForMethodBinds (hsLKiTyVarNames tyvars') $
1055                 -- No need to check for duplicate method signatures
1056                 -- since that is done by RnNames.extendGlobalRdrEnvRn
1057                 -- and the methods are already in scope
1058                  rnMethodBinds cls' (mkSigTvFn sigs') mbinds
1059
1060   -- Haddock docs
1061         ; docs' <- mapM (wrapLocM rnDocDecl) docs
1062
1063         ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs
1064         ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
1065                               tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
1066                               tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
1067                               tcdDocs = docs', tcdFVs = all_fvs },
1068                   all_fvs ) }
1069   where
1070     cls_doc  = ClassDeclCtx lcls
1071
1072 -- "type" and "type instance" declarations
1073 rnTySyn :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
1074 rnTySyn doc rhs = rnLHsType doc rhs
1075
1076 -- Renames role annotations, returning them as the values in a NameEnv
1077 -- and checks for duplicate role annotations.
1078 -- It is quite convenient to do both of these in the same place.
1079 -- See also Note [Role annotations in the renamer]
1080 rnRoleAnnots :: [LRoleAnnotDecl RdrName]
1081                 -> RnM (NameEnv (LRoleAnnotDecl Name))
1082 rnRoleAnnots role_annots
1083   = do {  -- check for duplicates *before* renaming, to avoid lumping
1084           -- together all the unboundNames
1085          let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots
1086              role_annots_cmp (L _ annot1) (L _ annot2)
1087                = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2
1088        ; mapM_ dupRoleAnnotErr dup_annots
1089        ; role_annots' <- mapM (wrapLocM rn_role_annot1) no_dups
1090           -- some of the role annots will be unbound; we don't wish
1091           -- to include these
1092        ; return $ mkNameEnv [ (name, ra)
1093                             | ra <- role_annots'
1094                             , let name = roleAnnotDeclName (unLoc ra)
1095                             , not (isUnboundName name) ] }
1096   where
1097     rn_role_annot1 (RoleAnnotDecl tycon roles)
1098       = do {  -- the name is an *occurrence*
1099              tycon' <- wrapLocM lookupGlobalOccRn tycon
1100            ; return $ RoleAnnotDecl tycon' roles }
1101
1102 dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM ()
1103 dupRoleAnnotErr [] = panic "dupRoleAnnotErr"
1104 dupRoleAnnotErr list
1105   = addErrAt loc $
1106     hang (text "Duplicate role annotations for" <+>
1107           quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
1108        2 (vcat $ map pp_role_annot sorted_list)
1109     where
1110       sorted_list = sortBy cmp_annot list
1111       (L loc first_decl : _) = sorted_list
1112
1113       pp_role_annot (L loc decl) = hang (ppr decl)
1114                                       4 (text "-- written at" <+> ppr loc)
1115
1116       cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2
1117
1118 orphanRoleAnnotErr :: LRoleAnnotDecl Name -> RnM ()
1119 orphanRoleAnnotErr (L loc decl)
1120   = addErrAt loc $
1121     hang (text "Role annotation for a type previously declared:")
1122        2 (ppr decl) $$
1123     parens (text "The role annotation must be given where" <+>
1124             quotes (ppr $ roleAnnotDeclName decl) <+>
1125             text "is declared.")
1126
1127 rnDataDefn :: HsDocContext -> HsDataDefn RdrName -> RnM (HsDataDefn Name, FreeVars)
1128 rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1129                            , dd_ctxt = context, dd_cons = condecls
1130                            , dd_kindSig = sig, dd_derivs = derivs })
1131   = do  { checkTc (h98_style || null (unLoc context))
1132                   (badGadtStupidTheta doc)
1133
1134         ; (sig', sig_fvs)  <- rnLHsMaybeKind doc sig
1135         ; (context', fvs1) <- rnContext doc context
1136         ; (derivs',  fvs3) <- rn_derivs derivs
1137
1138         -- For the constructor declarations, drop the LocalRdrEnv
1139         -- in the GADT case, where the type variables in the declaration
1140         -- do not scope over the constructor signatures
1141         -- data T a where { T1 :: forall b. b-> b }
1142         ; let { zap_lcl_env | h98_style = \ thing -> thing
1143                             | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
1144         ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls
1145            -- No need to check for duplicate constructor decls
1146            -- since that is done by RnNames.extendGlobalRdrEnvRn
1147
1148         ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
1149                         con_fvs `plusFV` sig_fvs
1150         ; return ( HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1151                               , dd_ctxt = context', dd_kindSig = sig'
1152                               , dd_cons = condecls'
1153                               , dd_derivs = derivs' }
1154                  , all_fvs )
1155         }
1156   where
1157     h98_style = case condecls of  -- Note [Stupid theta]
1158                      L _ (ConDecl { con_res = ResTyGADT {} }) : _  -> False
1159                      _                                             -> True
1160
1161     rn_derivs Nothing   = return (Nothing, emptyFVs)
1162     rn_derivs (Just (L ld ds)) = do { (ds', fvs) <- rnLHsTypes doc ds
1163                                     ; return (Just (L ld ds'), fvs) }
1164
1165 badGadtStupidTheta :: HsDocContext -> SDoc
1166 badGadtStupidTheta _
1167   = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
1168           ptext (sLit "(You can put a context on each contructor, though.)")]
1169
1170 rnFamDecl :: Maybe Name
1171                     -- Just cls => this FamilyDecl is nested
1172                     --             inside an *class decl* for cls
1173                     --             used for associated types
1174           -> FamilyDecl RdrName
1175           -> RnM (FamilyDecl Name, FreeVars)
1176 rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
1177                              , fdInfo = info, fdKindSig = kind })
1178   = do { ((tycon', tyvars', kind'), fv1) <-
1179            bindHsTyVars fmly_doc mb_cls kvs tyvars $ \tyvars' ->
1180            do { tycon' <- lookupLocatedTopBndrRn tycon
1181               ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind
1182               ; return ((tycon', tyvars', kind'), fv_kind) }
1183        ; (info', fv2) <- rn_info info
1184        ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars'
1185                             , fdInfo = info', fdKindSig = kind' }
1186                 , fv1 `plusFV` fv2) }
1187   where
1188      fmly_doc = TyFamilyCtx tycon
1189      kvs = extractRdrKindSigVars kind
1190
1191      rn_info (ClosedTypeFamily eqns)
1192        = do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns
1193                                                     -- no class context,
1194             ; return (ClosedTypeFamily eqns', fvs) }
1195      rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
1196      rn_info DataFamily     = return (DataFamily, emptyFVs)
1197
1198 \end{code}
1199
1200 Note [Stupid theta]
1201 ~~~~~~~~~~~~~~~~~~~
1202 Trac #3850 complains about a regression wrt 6.10 for
1203      data Show a => T a
1204 There is no reason not to allow the stupid theta if there are no data
1205 constructors.  It's still stupid, but does no harm, and I don't want
1206 to cause programs to break unnecessarily (notably HList).  So if there
1207 are no data constructors we allow h98_style = True
1208
1209
1210 \begin{code}
1211 depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)]
1212 -- See Note [Dependency analysis of type and class decls]
1213 depAnalTyClDecls ds_w_fvs
1214   = stronglyConnCompFromEdgedVertices edges
1215   where
1216     edges = [ (d, tcdName (unLoc d), map get_parent (nameSetElems fvs))
1217             | (d, fvs) <- ds_w_fvs ]
1218
1219     -- We also need to consider data constructor names since
1220     -- they may appear in types because of promotion.
1221     get_parent n = lookupNameEnv assoc_env n `orElse` n
1222
1223     assoc_env :: NameEnv Name   -- Maps a data constructor back
1224                                 -- to its parent type constructor
1225     assoc_env = mkNameEnv $ concat assoc_env_list
1226     assoc_env_list = do
1227       (L _ d, _) <- ds_w_fvs
1228       case d of
1229         ClassDecl { tcdLName = L _ cls_name
1230                   , tcdATs = ats }
1231           -> do L _ (FamilyDecl { fdLName = L _ fam_name }) <- ats
1232                 return [(fam_name, cls_name)]
1233         DataDecl { tcdLName = L _ data_name
1234                  , tcdDataDefn = HsDataDefn { dd_cons = cons } }
1235           -> do L _ dc <- cons
1236                 return $ zip (map unLoc $ con_names dc) (repeat data_name)
1237         _ -> []
1238 \end{code}
1239
1240 Note [Dependency analysis of type and class decls]
1241 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1242 We need to do dependency analysis on type and class declarations
1243 else we get bad error messages.  Consider
1244
1245      data T f a = MkT f a
1246      data S f a = MkS f (T f a)
1247
1248 This has a kind error, but the error message is better if you
1249 check T first, (fixing its kind) and *then* S.  If you do kind
1250 inference together, you might get an error reported in S, which
1251 is jolly confusing.  See Trac #4875
1252
1253 Note [Role annotations in the renamer]
1254 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1255 We must ensure that a type's role annotation is put in the same group as the
1256 proper type declaration. This is because role annotations are needed during
1257 type-checking when creating the type's TyCon. So, rnRoleAnnots builds a
1258 NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that
1259 type, if any. Then, this map can be used to add the role annotations to the
1260 groups after dependency analysis.
1261
1262 This process checks for duplicate role annotations, where we must be careful
1263 to do the check *before* renaming to avoid calling all unbound names duplicates
1264 of one another.
1265
1266 The renaming process, as usual, might identify and report errors for unbound
1267 names. We exclude the annotations for unbound names in the annotation
1268 environment to avoid spurious errors for orphaned annotations.
1269
1270 We then (in rnTyClDecls) do a check for orphan role annotations (role
1271 annotations without an accompanying type decl). The check works by folding
1272 over raw_groups (of type [[TyClDecl Name]]), selecting out the relevant
1273 role declarations for each group, as well as diminishing the annotation
1274 environment. After the fold is complete, anything left over in the name
1275 environment must be an orphan, and errors are generated.
1276
1277 An earlier version of this algorithm short-cut the orphan check by renaming
1278 only with names declared in this module. But, this check is insufficient in
1279 the case of staged module compilation (Template Haskell, GHCi).
1280 See #8485. With the new lookup process (which includes types declared in other
1281 modules), we get better error messages, too.
1282
1283 %*********************************************************
1284 %*                                                      *
1285 \subsection{Support code for type/data declarations}
1286 %*                                                      *
1287 %*********************************************************
1288
1289 \begin{code}
1290 ---------------
1291 badAssocRhs :: [Name] -> RnM ()
1292 badAssocRhs ns
1293   = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions")
1294                   <+> pprWithCommas (quotes . ppr) ns)
1295                2 (ptext (sLit "All such variables must be bound on the LHS")))
1296
1297 -----------------
1298 rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
1299 rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
1300
1301 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars)
1302 rnConDecl decl@(ConDecl { con_names = names, con_qvars = tvs
1303                         , con_cxt = lcxt@(L loc cxt), con_details = details
1304                         , con_res = res_ty, con_doc = mb_doc
1305                         , con_old_rec = old_rec, con_explicit = expl })
1306   = do  { mapM_ (addLocM checkConName) names
1307         ; when old_rec (addWarn (deprecRecSyntax decl))
1308         ; new_names <- mapM lookupLocatedTopBndrRn names
1309
1310            -- For H98 syntax, the tvs are the existential ones
1311            -- For GADT syntax, the tvs are all the quantified tyvars
1312            -- Hence the 'filter' in the ResTyH98 case only
1313         ; rdr_env <- getLocalRdrEnv
1314         ; let arg_tys    = hsConDeclArgTys details
1315               (free_kvs, free_tvs) = case res_ty of
1316                                      ResTyH98 -> filterInScope rdr_env (get_rdr_tvs arg_tys)
1317                                      ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
1318
1319          -- With an Explicit forall, check for unused binders
1320          -- With Implicit, find the mentioned ones, and use them as binders
1321          -- With Qualified, do the same as with Implicit, but give a warning
1322          --   See Note [Context quantification]
1323         ; new_tvs <- case expl of
1324                        Implicit -> return (mkHsQTvs (userHsTyVarBndrs loc free_tvs))
1325                        Qualified -> do { warnContextQuantification (docOfHsDocContext doc)
1326                                                                    (userHsTyVarBndrs loc free_tvs)
1327                                        ; return (mkHsQTvs (userHsTyVarBndrs loc free_tvs)) }
1328                        Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs free_tvs
1329                                       ; return tvs }
1330
1331         ; mb_doc' <- rnMbLHsDoc mb_doc
1332
1333         ; bindHsTyVars doc Nothing free_kvs new_tvs $ \new_tyvars -> do
1334         { (new_context, fvs1) <- rnContext doc lcxt
1335         ; (new_details, fvs2) <- rnConDeclDetails doc details
1336         ; (new_details', new_res_ty, fvs3)
1337                      <- rnConResult doc (map unLoc new_names) new_details res_ty
1338         ; return (decl { con_names = new_names, con_qvars = new_tyvars
1339                        , con_cxt = new_context, con_details = new_details'
1340                        , con_res = new_res_ty, con_doc = mb_doc' },
1341                   fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
1342  where
1343     doc = ConDeclCtx names
1344     get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)
1345
1346 rnConResult :: HsDocContext -> [Name]
1347             -> HsConDetails (LHsType Name) [LConDeclField Name]
1348             -> ResType (LHsType RdrName)
1349             -> RnM (HsConDetails (LHsType Name) [LConDeclField Name],
1350                     ResType (LHsType Name), FreeVars)
1351 rnConResult _   _   details ResTyH98 = return (details, ResTyH98, emptyFVs)
1352 rnConResult doc _con details (ResTyGADT ty)
1353   = do { (ty', fvs) <- rnLHsType doc ty
1354        ; let (arg_tys, res_ty) = splitHsFunType ty'
1355                 -- We can finally split it up,
1356                 -- now the renamer has dealt with fixities
1357                 -- See Note [Sorting out the result type] in RdrHsSyn
1358
1359        ; case details of
1360            InfixCon {}  -> pprPanic "rnConResult" (ppr ty)
1361            -- See Note [Sorting out the result type] in RdrHsSyn
1362
1363            RecCon {}    -> do { unless (null arg_tys)
1364                                        (addErr (badRecResTy (docOfHsDocContext doc)))
1365                               ; return (details, ResTyGADT res_ty, fvs) }
1366
1367            PrefixCon {} -> return (PrefixCon arg_tys, ResTyGADT res_ty, fvs) }
1368
1369 rnConDeclDetails
1370     :: HsDocContext
1371     -> HsConDetails (LHsType RdrName) [LConDeclField RdrName]
1372     -> RnM (HsConDetails (LHsType Name) [LConDeclField Name], FreeVars)
1373 rnConDeclDetails doc (PrefixCon tys)
1374   = do { (new_tys, fvs) <- rnLHsTypes doc tys
1375        ; return (PrefixCon new_tys, fvs) }
1376
1377 rnConDeclDetails doc (InfixCon ty1 ty2)
1378   = do { (new_ty1, fvs1) <- rnLHsType doc ty1
1379        ; (new_ty2, fvs2) <- rnLHsType doc ty2
1380        ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
1381
1382 rnConDeclDetails doc (RecCon fields)
1383   = do  { (new_fields, fvs) <- rnConDeclFields doc fields
1384                 -- No need to check for duplicate fields
1385                 -- since that is done by RnNames.extendGlobalRdrEnvRn
1386         ; return (RecCon new_fields, fvs) }
1387
1388 -------------------------------------------------
1389 deprecRecSyntax :: ConDecl RdrName -> SDoc
1390 deprecRecSyntax decl
1391   = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_names decl))
1392                  <+> ptext (sLit "uses deprecated syntax")
1393          , ptext (sLit "Instead, use the form")
1394          , nest 2 (ppr decl) ]   -- Pretty printer uses new form
1395
1396 badRecResTy :: SDoc -> SDoc
1397 badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
1398 \end{code}
1399
1400 %*********************************************************
1401 %*                                                      *
1402 \subsection{Support code for type/data declarations}
1403 %*                                                      *
1404 %*********************************************************
1405
1406 Get the mapping from constructors to fields for this module.
1407 It's convenient to do this after the data type decls have been renamed
1408 \begin{code}
1409 extendRecordFieldEnv :: [TyClGroup RdrName] -> [LInstDecl RdrName] -> TcM TcGblEnv
1410 extendRecordFieldEnv tycl_decls inst_decls
1411   = do  { tcg_env <- getGblEnv
1412         ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
1413         ; return (tcg_env { tcg_field_env = field_env' }) }
1414   where
1415     -- we want to lookup:
1416     --  (a) a datatype constructor
1417     --  (b) a record field
1418     -- knowing that they're from this module.
1419     -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn_maybe,
1420     -- which keeps only the local ones.
1421     lookup x = do { x' <- lookupLocatedTopBndrRn x
1422                     ; return $ unLoc x'}
1423
1424     all_data_cons :: [ConDecl RdrName]
1425     all_data_cons = [con | HsDataDefn { dd_cons = cons } <- all_ty_defs
1426                          , L _ con <- cons ]
1427     all_ty_defs = [ defn | L _ (DataDecl { tcdDataDefn = defn })
1428                                                  <- tyClGroupConcat tycl_decls ]
1429                ++ map dfid_defn (instDeclDataFamInsts inst_decls)
1430                                               -- Do not forget associated types!
1431
1432     get_con (ConDecl { con_names = cons, con_details = RecCon flds })
1433             (RecFields env fld_set)
1434         = do { cons' <- mapM lookup cons
1435              ; flds' <- mapM lookup (concatMap (cd_fld_names . unLoc) flds)
1436              ; let env'    = foldl (\e c -> extendNameEnv e c flds') env cons'
1437
1438                    fld_set' = extendNameSetList fld_set flds'
1439              ; return $ (RecFields env' fld_set') }
1440     get_con _ env = return env
1441 \end{code}
1442
1443 %*********************************************************
1444 %*                                                      *
1445 \subsection{Support code to rename types}
1446 %*                                                      *
1447 %*********************************************************
1448
1449 \begin{code}
1450 rnFds :: [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
1451 rnFds fds
1452   = mapM (wrapLocM rn_fds) fds
1453   where
1454     rn_fds (tys1, tys2)
1455       = do { tys1' <- rnHsTyVars tys1
1456            ; tys2' <- rnHsTyVars tys2
1457            ; return (tys1', tys2') }
1458
1459 rnHsTyVars :: [RdrName] -> RnM [Name]
1460 rnHsTyVars tvs  = mapM rnHsTyVar tvs
1461
1462 rnHsTyVar :: RdrName -> RnM Name
1463 rnHsTyVar tyvar = lookupOccRn tyvar
1464 \end{code}
1465
1466
1467 %*********************************************************
1468 %*                                                      *
1469         findSplice
1470 %*                                                      *
1471 %*********************************************************
1472
1473 This code marches down the declarations, looking for the first
1474 Template Haskell splice.  As it does so it
1475         a) groups the declarations into a HsGroup
1476         b) runs any top-level quasi-quotes
1477
1478 \begin{code}
1479 findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1480 findSplice ds = addl emptyRdrGroup ds
1481
1482 addl :: HsGroup RdrName -> [LHsDecl RdrName]
1483      -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1484 -- This stuff reverses the declarations (again) but it doesn't matter
1485 addl gp []           = return (gp, Nothing)
1486 addl gp (L l d : ds) = add gp l d ds
1487
1488
1489 add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
1490     -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1491
1492 add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
1493   = do { -- We've found a top-level splice.  If it is an *implicit* one
1494          -- (i.e. a naked top level expression)
1495          case flag of
1496            ExplicitSplice -> return ()
1497            ImplicitSplice -> do { th_on <- xoptM Opt_TemplateHaskell
1498                                 ; unless th_on $ setSrcSpan loc $
1499                                   failWith badImplicitSplice }
1500
1501        ; return (gp, Just (splice, ds)) }
1502   where
1503     badImplicitSplice = ptext (sLit "Parse error: naked expression at top level")
1504                      $$ ptext (sLit "Perhaps you intended to use TemplateHaskell")
1505
1506 add gp _ (QuasiQuoteD qq) ds            -- Expand quasiquotes
1507   = do { ds' <- runQuasiQuoteDecl qq
1508        ; addl gp (ds' ++ ds) }
1509
1510 -- Class declarations: pull out the fixity signatures to the top
1511 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
1512   | isClassDecl d
1513   = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
1514     addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
1515   | otherwise
1516   = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
1517
1518 -- Signatures: fixity sigs go a different place than all others
1519 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
1520   = addl (gp {hs_fixds = L l f : ts}) ds
1521 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
1522   = addl (gp {hs_valds = add_sig (L l d) ts}) ds
1523
1524 -- Value declarations: use add_bind
1525 add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
1526   = addl (gp { hs_valds = add_bind (L l d) ts }) ds
1527
1528 -- Role annotations: added to the TyClGroup
1529 add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD d) ds
1530   = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds
1531
1532 -- The rest are routine
1533 add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
1534   = addl (gp { hs_instds = L l d : ts }) ds
1535 add gp@(HsGroup {hs_derivds = ts})  l (DerivD d) ds
1536   = addl (gp { hs_derivds = L l d : ts }) ds
1537 add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
1538   = addl (gp { hs_defds = L l d : ts }) ds
1539 add gp@(HsGroup {hs_fords  = ts}) l (ForD d) ds
1540   = addl (gp { hs_fords = L l d : ts }) ds
1541 add gp@(HsGroup {hs_warnds  = ts})  l (WarningD d) ds
1542   = addl (gp { hs_warnds = L l d : ts }) ds
1543 add gp@(HsGroup {hs_annds  = ts}) l (AnnD d) ds
1544   = addl (gp { hs_annds = L l d : ts }) ds
1545 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
1546   = addl (gp { hs_ruleds = L l d : ts }) ds
1547 add gp@(HsGroup {hs_vects  = ts}) l (VectD d) ds
1548   = addl (gp { hs_vects = L l d : ts }) ds
1549 add gp l (DocD d) ds
1550   = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
1551
1552 add_tycld :: LTyClDecl a -> [TyClGroup a] -> [TyClGroup a]
1553 add_tycld d []       = [TyClGroup { group_tyclds = [d], group_roles = [] }]
1554 add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
1555   = ds { group_tyclds = d : tyclds } : dss
1556
1557 add_role_annot :: LRoleAnnotDecl a -> [TyClGroup a] -> [TyClGroup a]
1558 add_role_annot d [] = [TyClGroup { group_tyclds = [], group_roles = [d] }]
1559 add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
1560   = tycls { group_roles = d : roles } : rest
1561
1562 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
1563 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
1564 add_bind _ (ValBindsOut {})     = panic "RdrHsSyn:add_bind"
1565
1566 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
1567 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
1568 add_sig _ (ValBindsOut {})     = panic "RdrHsSyn:add_sig"
1569 \end{code}