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