Refactor HsDecls again, to put family instances in InstDecl
[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 (FamInstDecl ty_decl)
428   = do { (ty_decl', fvs) <- rnTyClDecl Nothing ty_decl
429        ; return (FamInstDecl ty_decl', fvs) }
430
431 rnSrcInstDecl (ClsInstDecl inst_ty mbinds uprags ats)
432         -- Used for both source and interface file decls
433   = do { inst_ty' <- rnLHsInstType (text "In an instance declaration") inst_ty
434        ; let Just (inst_tyvars, _, L _ cls,_) = splitLHsInstDeclTy_maybe inst_ty'
435              (spec_inst_prags, other_sigs) = partition isSpecInstLSig uprags
436
437        -- Rename the associated types, and type signatures
438        -- Both need to have the instance type variables in scope
439        ; ((ats', other_sigs'), more_fvs) 
440              <- extendTyVarEnvFVRn (map hsLTyVarName inst_tyvars) $
441                 do { (ats', at_fvs) <- rnATInsts cls ats
442                    ; other_sigs'    <- renameSigs (InstDeclCtxt cls) other_sigs
443                    ; return ( (ats', other_sigs')
444                             , at_fvs `plusFV` hsSigsFVs other_sigs') }
445
446         -- Rename the bindings
447         -- The typechecker (not the renamer) checks that all 
448         -- the bindings are for the right class
449         -- (Slightly strangely) when scoped type variables are on, the 
450         -- forall-d tyvars scope over the method bindings too
451        ; (mbinds', meth_fvs) <- extendTyVarEnvForMethodBinds inst_tyvars $
452                                 rnMethodBinds cls (mkSigTvFn other_sigs')
453                                                   mbinds    
454
455         -- Rename the SPECIALISE instance pramas
456         -- Annoyingly the type variables are not in scope here,
457         -- so that      instance Eq a => Eq (T a) where
458         --                      {-# SPECIALISE instance Eq a => Eq (T [a]) #-}
459         -- works OK. That's why we did the partition game above
460         --
461         -- But the (unqualified) method names are in scope
462 --       ; let binders = collectHsBindsBinders mbinds'
463        ; spec_inst_prags' <- -- bindLocalNames binders $
464                              renameSigs (InstDeclCtxt cls) spec_inst_prags
465
466        ; let uprags' = spec_inst_prags' ++ other_sigs'
467        ; return (ClsInstDecl inst_ty' mbinds' uprags' ats',
468                  meth_fvs `plusFV` more_fvs
469                           `plusFV` hsSigsFVs spec_inst_prags'
470                           `plusFV` extractHsTyNames inst_ty') }
471              -- We return the renamed associated data type declarations so
472              -- that they can be entered into the list of type declarations
473              -- for the binding group, but we also keep a copy in the instance.
474              -- The latter is needed for well-formedness checks in the type
475              -- checker (eg, to ensure that all ATs of the instance actually
476              -- receive a declaration). 
477              -- NB: Even the copies in the instance declaration carry copies of
478              --     the instance context after renaming.  This is a bit
479              --     strange, but should not matter (and it would be more work
480              --     to remove the context).
481 \end{code}
482
483 Renaming of the associated types in instances.  
484
485 \begin{code}
486 rnATInsts :: Name -> [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
487        -- NB: We allow duplicate associated-type decls; 
488        --     See Note [Associated type instances] in TcInstDcls
489 rnATInsts cls atDecls = rnList rnATInst atDecls
490   where
491     rnATInst tydecl@TyData     {} = rnTyClDecl (Just cls) tydecl
492     rnATInst tydecl@TySynonym  {} = rnTyClDecl (Just cls) tydecl
493     rnATInst tydecl               = pprPanic "RnSource.rnATInsts: invalid AT instance" 
494                                              (ppr (tcdName tydecl))
495 \end{code}
496
497 For the method bindings in class and instance decls, we extend the 
498 type variable environment iff -fglasgow-exts
499
500 \begin{code}
501 extendTyVarEnvForMethodBinds :: [LHsTyVarBndr Name]
502                              -> RnM (Bag (LHsBind Name), FreeVars)
503                              -> RnM (Bag (LHsBind Name), FreeVars)
504 extendTyVarEnvForMethodBinds tyvars thing_inside
505   = do  { scoped_tvs <- xoptM Opt_ScopedTypeVariables
506         ; if scoped_tvs then
507                 extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside
508           else
509                 thing_inside }
510 \end{code}
511
512 %*********************************************************
513 %*                                                      *
514 \subsection{Stand-alone deriving declarations}
515 %*                                                      *
516 %*********************************************************
517
518 \begin{code}
519 rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars)
520 rnSrcDerivDecl (DerivDecl ty)
521   = do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving
522        ; unless standalone_deriv_ok (addErr standaloneDerivErr)
523        ; ty' <- rnLHsInstType (text "In a deriving declaration") ty
524        ; let fvs = extractHsTyNames ty'
525        ; return (DerivDecl ty', fvs) }
526
527 standaloneDerivErr :: SDoc
528 standaloneDerivErr 
529   = hang (ptext (sLit "Illegal standalone deriving declaration"))
530        2 (ptext (sLit "Use -XStandaloneDeriving to enable this extension"))
531 \end{code}
532
533 %*********************************************************
534 %*                                                      *
535 \subsection{Rules}
536 %*                                                      *
537 %*********************************************************
538
539 \begin{code}
540 rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars)
541 rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
542   = bindPatSigTyVarsFV (collectRuleBndrSigTys vars)     $
543     bindLocatedLocalsFV (map get_var vars)              $ \ ids ->
544     do  { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids)
545                 -- NB: The binders in a rule are always Ids
546                 --     We don't (yet) support type variables
547
548         ; (lhs', fv_lhs') <- rnLExpr lhs
549         ; (rhs', fv_rhs') <- rnLExpr rhs
550
551         ; checkValidRule rule_name ids lhs' fv_lhs'
552
553         ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
554                   fv_vars `plusFV` fv_lhs' `plusFV` fv_rhs') }
555   where
556     doc = RuleCtx rule_name
557   
558     get_var (RuleBndr v)      = v
559     get_var (RuleBndrSig v _) = v
560
561     rn_var (RuleBndr (L loc _), id)
562         = return (RuleBndr (L loc id), emptyFVs)
563     rn_var (RuleBndrSig (L loc _) t, id)
564         = do { (t', fvs) <- rnHsTypeFVs doc t
565              ; return (RuleBndrSig (L loc id) t', fvs) }
566
567 badRuleVar :: FastString -> Name -> SDoc
568 badRuleVar name var
569   = sep [ptext (sLit "Rule") <+> doubleQuotes (ftext name) <> colon,
570          ptext (sLit "Forall'd variable") <+> quotes (ppr var) <+> 
571                 ptext (sLit "does not appear on left hand side")]
572 \end{code}
573
574 Note [Rule LHS validity checking]
575 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
576 Check the shape of a transformation rule LHS.  Currently we only allow
577 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
578 @forall@'d variables.  
579
580 We used restrict the form of the 'ei' to prevent you writing rules
581 with LHSs with a complicated desugaring (and hence unlikely to match);
582 (e.g. a case expression is not allowed: too elaborate.)
583
584 But there are legitimate non-trivial args ei, like sections and
585 lambdas.  So it seems simmpler not to check at all, and that is why
586 check_e is commented out.
587         
588 \begin{code}
589 checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM ()
590 checkValidRule rule_name ids lhs' fv_lhs'
591   = do  {       -- Check for the form of the LHS
592           case (validRuleLhs ids lhs') of
593                 Nothing  -> return ()
594                 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
595
596                 -- Check that LHS vars are all bound
597         ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
598         ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
599
600 validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name)
601 -- Nothing => OK
602 -- Just e  => Not ok, and e is the offending expression
603 validRuleLhs foralls lhs
604   = checkl lhs
605   where
606     checkl (L _ e) = check e
607
608     check (OpApp e1 op _ e2)              = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
609     check (HsApp e1 e2)                   = checkl e1 `mplus` checkl_e e2
610     check (HsVar v) | v `notElem` foralls = Nothing
611     check other                           = Just other  -- Failure
612
613         -- Check an argument
614     checkl_e (L _ _e) = Nothing         -- Was (check_e e); see Note [Rule LHS validity checking]
615
616 {-      Commented out; see Note [Rule LHS validity checking] above 
617     check_e (HsVar v)     = Nothing
618     check_e (HsPar e)     = checkl_e e
619     check_e (HsLit e)     = Nothing
620     check_e (HsOverLit e) = Nothing
621
622     check_e (OpApp e1 op _ e2)   = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
623     check_e (HsApp e1 e2)        = checkl_e e1 `mplus` checkl_e e2
624     check_e (NegApp e _)         = checkl_e e
625     check_e (ExplicitList _ es)  = checkl_es es
626     check_e other                = Just other   -- Fails
627
628     checkl_es es = foldr (mplus . checkl_e) Nothing es
629 -}
630
631 badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc
632 badRuleLhsErr name lhs bad_e
633   = sep [ptext (sLit "Rule") <+> ftext name <> colon,
634          nest 4 (vcat [ptext (sLit "Illegal expression:") <+> ppr bad_e, 
635                        ptext (sLit "in left-hand side:") <+> ppr lhs])]
636     $$
637     ptext (sLit "LHS must be of form (f e1 .. en) where f is not forall'd")
638 \end{code}
639
640
641 %*********************************************************
642 %*                                                      *
643 \subsection{Vectorisation declarations}
644 %*                                                      *
645 %*********************************************************
646
647 \begin{code}
648 rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars)
649 rnHsVectDecl (HsVect var Nothing)
650   = do { var' <- lookupLocatedOccRn var
651        ; return (HsVect var' Nothing, unitFV (unLoc var'))
652        }
653 -- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly
654 --        typecheck a complex right-hand side without invoking 'vectType' from the vectoriser.
655 rnHsVectDecl (HsVect var (Just rhs@(L _ (HsVar _))))
656   = do { var' <- lookupLocatedOccRn var
657        ; (rhs', fv_rhs) <- rnLExpr rhs
658        ; return (HsVect var' (Just rhs'), fv_rhs `addOneFV` unLoc var')
659        }
660 rnHsVectDecl (HsVect _var (Just _rhs))
661   = failWith $ vcat 
662                [ ptext (sLit "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma")
663                , ptext (sLit "must be an identifier")
664                ]
665 rnHsVectDecl (HsNoVect var)
666   = do { var' <- lookupLocatedTopBndrRn var           -- only applies to local (not imported) names
667        ; return (HsNoVect var', unitFV (unLoc var'))
668        }
669 rnHsVectDecl (HsVectTypeIn isScalar tycon Nothing)
670   = do { tycon' <- lookupLocatedOccRn tycon
671        ; return (HsVectTypeIn isScalar tycon' Nothing, unitFV (unLoc tycon'))
672        }
673 rnHsVectDecl (HsVectTypeIn isScalar tycon (Just rhs_tycon))
674   = do { tycon'     <- lookupLocatedOccRn tycon
675        ; rhs_tycon' <- lookupLocatedOccRn rhs_tycon
676        ; return ( HsVectTypeIn isScalar tycon' (Just rhs_tycon')
677                 , mkFVs [unLoc tycon', unLoc rhs_tycon'])
678        }
679 rnHsVectDecl (HsVectTypeOut _ _ _)
680   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"
681 rnHsVectDecl (HsVectClassIn cls)
682   = do { cls' <- lookupLocatedOccRn cls
683        ; return (HsVectClassIn cls', unitFV (unLoc cls'))
684        }
685 rnHsVectDecl (HsVectClassOut _)
686   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
687 rnHsVectDecl (HsVectInstIn instTy)
688   = do { instTy' <- rnLHsInstType (text "In a VECTORISE pragma") instTy
689        ; return (HsVectInstIn instTy', extractHsTyNames instTy')
690        }
691 rnHsVectDecl (HsVectInstOut _)
692   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
693 \end{code}
694
695 %*********************************************************
696 %*                                                      *
697 \subsection{Type, class and iface sig declarations}
698 %*                                                      *
699 %*********************************************************
700
701 @rnTyDecl@ uses the `global name function' to create a new type
702 declaration in which local names have been replaced by their original
703 names, reporting any unknown names.
704
705 Renaming type variables is a pain. Because they now contain uniques,
706 it is necessary to pass in an association list which maps a parsed
707 tyvar to its @Name@ representation.
708 In some cases (type signatures of values),
709 it is even necessary to go over the type first
710 in order to get the set of tyvars used by it, make an assoc list,
711 and then go over it again to rename the tyvars!
712 However, we can also do some scoping checks at the same time.
713
714
715 Note [Extra dependencies from .hs-boot files]
716 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
717 Consider the following case:
718
719   module A where
720     import B
721     data A1 = A1 B1
722   
723   module B where
724     import {-# SOURCE #-} A
725     type DisguisedA1 = A1
726     data B1 = B1 DisguisedA1
727
728 We do not follow type synonyms when building the dependencies for each datatype,
729 so we will not find out that B1 really depends on A1 (which means it depends on
730 itself). To handle this problem, at the moment we add dependencies to everything
731 that comes from an .hs-boot file. But we don't add those dependencies to
732 everything. Imagine module B above had another datatype declaration:
733
734   data B2 = B2 Int
735
736 Even though B2 has a dependency (on Int), all its dependencies are from things
737 that live on other packages. Since we don't have mutual dependencies across
738 packages, it is safe not to add the dependencies on the .hs-boot stuff to B2.
739
740 See also Note [Grouping of type and class declarations] in TcTyClsDecls.
741
742 \begin{code}
743 isInPackage :: PackageId -> Name -> Bool
744 isInPackage pkgId nm = case nameModule_maybe nm of
745                          Nothing -> False
746                          Just m  -> pkgId == modulePackageId m
747 -- We use nameModule_maybe because we might be in a TH splice, in which case
748 -- there is no module name. In that case we cannot have mutual dependencies,
749 -- so it's fine to return False here.
750
751 rnTyClDecls :: [Name] -> [[LTyClDecl RdrName]]
752             -> RnM ([[LTyClDecl Name]], FreeVars)
753 -- Rename the declarations and do depedency analysis on them
754 rnTyClDecls extra_deps tycl_ds
755   = do { ds_w_fvs <- mapM (wrapLocFstM (rnTyClDecl Nothing)) (concat tycl_ds)
756        ; thisPkg  <- fmap thisPackage getDynFlags
757        ; let add_boot_deps :: FreeVars -> FreeVars
758              -- See Note [Extra dependencies from .hs-boot files]
759              add_boot_deps fvs | any (isInPackage thisPkg) (nameSetToList fvs)
760                                = fvs `plusFV` mkFVs extra_deps
761                                | otherwise
762                                = fvs
763
764              ds_w_fvs' = map (\(ds, fvs) -> (ds, add_boot_deps fvs)) ds_w_fvs
765
766              sccs :: [SCC (LTyClDecl Name)]
767              sccs = depAnalTyClDecls ds_w_fvs'
768
769              all_fvs = foldr (plusFV . snd) emptyFVs ds_w_fvs'
770
771        ; traceRn (text "rnTycl"  <+> (ppr ds_w_fvs $$ ppr sccs))
772        ; return (map flattenSCC sccs, all_fvs) }
773
774
775 rnTyClDecl :: Maybe Name  -- Just cls => this TyClDecl is nested 
776                           --             inside an *instance decl* for cls
777                           --             used for associated types
778            -> TyClDecl RdrName 
779            -> RnM (TyClDecl Name, FreeVars)
780 rnTyClDecl _ (ForeignType {tcdLName = name, tcdExtName = ext_name})
781   = do { name' <- lookupLocatedTopBndrRn name
782        ; return (ForeignType {tcdLName = name', tcdExtName = ext_name},
783                  emptyFVs) }
784
785 -- All flavours of type family declarations ("type family", "newtype family",
786 -- and "data family"), both top level and (for an associated type) 
787 -- in a class decl
788 rnTyClDecl mb_cls (TyFamily { tcdLName = tycon, tcdTyVars = tyvars
789                             , tcdFlavour = flav, tcdKind = kind })
790   = bindQTvs fmly_doc mb_cls tyvars $ \tyvars' ->
791     do { tycon' <- lookupLocatedTopBndrRn tycon
792        ; kind' <- rnLHsMaybeKind fmly_doc kind
793        ; let fv_kind = maybe emptyFVs extractHsTyNames kind'
794              fvs = extractHsTyVarBndrNames_s tyvars' fv_kind
795        ; return ( TyFamily { tcdLName = tycon', tcdTyVars = tyvars'
796                            , tcdFlavour = flav, tcdKind = kind' }
797                 , fvs) }
798   where fmly_doc = TyFamilyCtx tycon
799
800 -- "data", "newtype", "data instance, and "newtype instance" declarations
801 -- both top level and (for an associated type) in an instance decl
802 rnTyClDecl mb_cls tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, 
803                                  tcdLName = tycon, tcdTyVars = tyvars, 
804                                  tcdTyPats = typats, tcdCons = condecls, 
805                                  tcdKindSig = sig, tcdDerivs = derivs}
806   = do  { tycon' <- lookupTcdName mb_cls tydecl
807         ; sig' <- rnLHsMaybeKind data_doc sig
808         ; checkTc (h98_style || null (unLoc context)) 
809                   (badGadtStupidTheta tycon)
810
811         ; ((tyvars', context', typats', derivs'), stuff_fvs)
812                 <- bindQTvs data_doc mb_cls tyvars $ \ tyvars' -> do
813                                  -- Checks for distinct tyvars
814                    { context' <- rnContext data_doc context
815                    ; (typats', fvs1) <- rnTyPats data_doc tycon' typats
816                    ; (derivs', fvs2) <- rn_derivs derivs
817                    ; let fvs = fvs1 `plusFV` fvs2 `plusFV` 
818                                extractHsCtxtTyNames context'
819                                `plusFV` maybe emptyFVs extractHsTyNames sig'
820                    ; return ((tyvars', context', typats', derivs'), fvs) }
821
822         -- For the constructor declarations, bring into scope the tyvars 
823         -- bound by the header, but *only* in the H98 case
824         -- Reason: for GADTs, the type variables in the declaration 
825         --   do not scope over the constructor signatures
826         --   data T a where { T1 :: forall b. b-> b }
827         ; let tc_tvs_in_scope | h98_style = hsLTyVarNames tyvars'
828                               | otherwise = []
829         ; (condecls', con_fvs) <- bindLocalNamesFV tc_tvs_in_scope $
830                                   rnConDecls condecls
831                 -- No need to check for duplicate constructor decls
832                 -- since that is done by RnNames.extendGlobalRdrEnvRn
833
834         ; return (TyData {tcdND = new_or_data, tcdCtxt = context', 
835                            tcdLName = tycon', tcdTyVars = tyvars', 
836                            tcdTyPats = typats', tcdKindSig = sig',
837                            tcdCons = condecls', tcdDerivs = derivs'}, 
838                    con_fvs `plusFV` stuff_fvs)
839         }
840   where
841     h98_style = case condecls of         -- Note [Stupid theta]
842                      L _ (ConDecl { con_res = ResTyGADT {} }) : _  -> False
843                      _                                             -> True
844
845     data_doc = TyDataCtx tycon
846
847     rn_derivs Nothing   = return (Nothing, emptyFVs)
848     rn_derivs (Just ds) = do { ds' <- rnLHsTypes data_doc ds
849                              ; return (Just ds', extractHsTyNames_s ds') }
850
851 -- "type" and "type instance" declarations
852 rnTyClDecl mb_cls tydecl@(TySynonym { tcdTyVars = tyvars, tcdLName = name,
853                                       tcdTyPats = typats, tcdSynRhs = ty})
854   = bindQTvs syn_doc mb_cls tyvars $ \ tyvars' -> do
855     {            -- Checks for distinct tyvars
856       name' <- lookupTcdName mb_cls tydecl
857     ; (typats',fvs1) <- rnTyPats syn_doc name' typats
858     ; (ty', fvs2)    <- rnHsTypeFVs syn_doc ty
859     ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars'
860                         , tcdTyPats = typats', tcdSynRhs = ty'}
861              , extractHsTyVarBndrNames_s tyvars' (fvs1 `plusFV` fvs2)) }
862   where
863     syn_doc = TySynCtx name
864
865 rnTyClDecl _ (ClassDecl {tcdCtxt = context, tcdLName = lcls, 
866                          tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, 
867                          tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
868                          tcdDocs = docs})
869   = do  { lcls' <- lookupLocatedTopBndrRn lcls
870         ; let cls' = unLoc lcls'
871
872         -- Tyvars scope over superclass context and method signatures
873         ; ((tyvars', context', fds', ats', at_defs', sigs'), stuff_fvs)
874             <- bindTyVarsFV cls_doc tyvars $ \ tyvars' -> do
875                  -- Checks for distinct tyvars
876              { context' <- rnContext cls_doc context
877              ; fds'  <- rnFds (docOfHsDocContext cls_doc) fds
878              ; let rn_at = rnTyClDecl (Just cls')
879              ; (ats', fv_ats) <- mapAndUnzipM (wrapLocFstM rn_at) ats
880              ; sigs' <- renameSigs (ClsDeclCtxt cls') sigs
881              ; (at_defs', fv_at_defs) <- mapAndUnzipM (wrapLocFstM rn_at) at_defs
882              ; let fvs = extractHsCtxtTyNames context'  `plusFV`
883                          hsSigsFVs sigs'                `plusFV`
884                          plusFVs fv_ats                 `plusFV`
885                          plusFVs fv_at_defs
886                          -- The fundeps have no free variables
887              ; return ((tyvars', context', fds', ats', at_defs', sigs'), fvs) }
888
889         -- No need to check for duplicate associated type decls
890         -- since that is done by RnNames.extendGlobalRdrEnvRn
891
892         -- Check the signatures
893         -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
894         ; let sig_rdr_names_w_locs = [op | L _ (TypeSig ops _) <- sigs, op <- ops]
895         ; checkDupRdrNames sig_rdr_names_w_locs
896                 -- Typechecker is responsible for checking that we only
897                 -- give default-method bindings for things in this class.
898                 -- The renamer *could* check this for class decls, but can't
899                 -- for instance decls.
900
901         -- The newLocals call is tiresome: given a generic class decl
902         --      class C a where
903         --        op :: a -> a
904         --        op {| x+y |} (Inl a) = ...
905         --        op {| x+y |} (Inr b) = ...
906         --        op {| a*b |} (a*b)   = ...
907         -- we want to name both "x" tyvars with the same unique, so that they are
908         -- easy to group together in the typechecker.  
909         ; (mbinds', meth_fvs) 
910             <- extendTyVarEnvForMethodBinds tyvars' $
911                 -- No need to check for duplicate method signatures
912                 -- since that is done by RnNames.extendGlobalRdrEnvRn
913                 -- and the methods are already in scope
914                  rnMethodBinds cls' (mkSigTvFn sigs') mbinds
915
916   -- Haddock docs 
917         ; docs' <- mapM (wrapLocM rnDocDecl) docs
918
919         ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', 
920                               tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs',
921                               tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
922                               tcdDocs = docs'},
923                   extractHsTyVarBndrNames_s tyvars' (meth_fvs `plusFV` stuff_fvs)) }
924   where
925     cls_doc  = ClassDeclCtx lcls
926
927
928 bindQTvs :: HsDocContext -> Maybe Name -> [LHsTyVarBndr RdrName]
929          -> ([LHsTyVarBndr Name] -> RnM (a, FreeVars))
930          -> RnM (a, FreeVars)
931 bindQTvs doc mb_cls tyvars thing_inside
932   | isNothing mb_cls    -- Not associated
933   = bindTyVarsFV doc tyvars thing_inside
934   | otherwise           -- Associated
935   = do { let tv_rdr_names = map hsLTyVarLocName tyvars
936              -- *All* the free vars of the family patterns
937
938        -- Check for duplicated bindings
939        -- This test is irrelevant for data/type *instances*, where the tyvars
940        -- are the free tyvars of the patterns, and hence have no duplicates
941        -- But it's needed for data/type *family* decls
942        ; mapM_ dupBoundTyVar (findDupRdrNames tv_rdr_names)
943
944        ; rdr_env <- getLocalRdrEnv
945
946        ; tv_ns <- mapM (mk_tv_name rdr_env) tv_rdr_names
947        ; tyvars' <- zipWithM (\old new -> replaceLTyVarName old new (rnLHsKind doc)) tyvars tv_ns
948        ; (thing, fvs) <- bindLocalNamesFV tv_ns $ thing_inside tyvars'
949
950         -- Check that the RHS of the decl mentions only type variables
951         -- bound on the LHS.  For example, this is not ok
952         --       class C a b where
953         --         type F a x :: *
954         --       instance C (p,q) r where
955         --         type F (p,q) x = (x, r)      -- BAD: mentions 'r'
956         -- c.f. Trac #5515
957        ; let bad_tvs = filterNameSet (isTvOcc . nameOccName) fvs
958        ; unless (isEmptyNameSet bad_tvs) (badAssocRhs (nameSetToList bad_tvs))
959
960        ; return (thing, fvs) }
961   where
962     mk_tv_name :: LocalRdrEnv -> Located RdrName -> RnM Name
963     mk_tv_name rdr_env (L l tv_rdr)
964       = case lookupLocalRdrEnv rdr_env tv_rdr of 
965           Just n  -> return n
966           Nothing -> newLocalBndrRn (L l tv_rdr)
967
968 badAssocRhs :: [Name] -> RnM ()
969 badAssocRhs ns
970   = addErr (hang (ptext (sLit "The RHS of an associated type declaration mentions type variable") 
971                   <> plural ns 
972                   <+> pprWithCommas (quotes . ppr) ns)
973                2 (ptext (sLit "All such variables must be bound on the LHS")))
974
975 dupBoundTyVar :: [Located RdrName] -> RnM ()
976 dupBoundTyVar (L loc tv : _) 
977   = setSrcSpan loc $
978     addErr (ptext (sLit "Illegal repeated type variable") <+> quotes (ppr tv))
979 dupBoundTyVar [] = panic "dupBoundTyVar"
980
981 badGadtStupidTheta :: Located RdrName -> SDoc
982 badGadtStupidTheta _
983   = vcat [ptext (sLit "No context is allowed on a GADT-style data declaration"),
984           ptext (sLit "(You can put a context on each contructor, though.)")]
985 \end{code}
986
987 Note [Stupid theta]
988 ~~~~~~~~~~~~~~~~~~~
989 Trac #3850 complains about a regression wrt 6.10 for 
990      data Show a => T a
991 There is no reason not to allow the stupid theta if there are no data
992 constructors.  It's still stupid, but does no harm, and I don't want
993 to cause programs to break unnecessarily (notably HList).  So if there
994 are no data constructors we allow h98_style = True
995
996
997 \begin{code}
998 depAnalTyClDecls :: [(LTyClDecl Name, FreeVars)] -> [SCC (LTyClDecl Name)]
999 -- See Note [Dependency analysis of type and class decls]
1000 depAnalTyClDecls ds_w_fvs
1001   = stronglyConnCompFromEdgedVertices edges
1002   where
1003     edges = [ (d, tcdName (unLoc d), map get_parent (nameSetToList fvs))
1004             | (d, fvs) <- ds_w_fvs ]
1005
1006     -- We also need to consider data constructor names since 
1007     -- they may appear in types because of promotion.
1008     get_parent n = lookupNameEnv assoc_env n `orElse` n
1009
1010     assoc_env :: NameEnv Name   -- Maps a data constructor back 
1011                                 -- to its parent type constructor
1012     assoc_env = mkNameEnv assoc_env_list
1013     assoc_env_list = do
1014       (L _ d, _) <- ds_w_fvs
1015       case d of
1016         ClassDecl { tcdLName = L _ cls_name
1017                   , tcdATs = ats } -> do
1018                        L _ assoc_decl <- ats
1019                        return (tcdName assoc_decl, cls_name)
1020         TyData { tcdLName = L _ data_name
1021                , tcdCons = cons } -> do
1022                        L _ dc <- cons
1023                        return (unLoc (con_name dc), data_name)
1024         _ -> []
1025 \end{code}
1026
1027 Note [Dependency analysis of type and class decls]
1028 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1029 We need to do dependency analysis on type and class declarations
1030 else we get bad error messages.  Consider
1031
1032      data T f a = MkT f a
1033      data S f a = MkS f (T f a)
1034
1035 This has a kind error, but the error message is better if you
1036 check T first, (fixing its kind) and *then* S.  If you do kind
1037 inference together, you might get an error reported in S, which
1038 is jolly confusing.  See Trac #4875
1039
1040
1041 %*********************************************************
1042 %*                                                      *
1043 \subsection{Support code for type/data declarations}
1044 %*                                                      *
1045 %*********************************************************
1046
1047 \begin{code}
1048 rnTyPats :: HsDocContext -> Located Name -> Maybe [LHsType RdrName] -> RnM (Maybe [LHsType Name], FreeVars)
1049 -- Although, we are processing type patterns here, all type variables will
1050 -- already be in scope (they are the same as in the 'tcdTyVars' field of the
1051 -- type declaration to which these patterns belong)
1052 rnTyPats _   _  Nothing
1053   = return (Nothing, emptyFVs)
1054 rnTyPats doc tc (Just typats) 
1055   = do { typats' <- rnLHsTypes doc typats
1056        ; let fvs = addOneFV (extractHsTyNames_s typats') (unLoc tc)
1057              -- type instance => use, hence addOneFV
1058        ; return (Just typats', fvs) }
1059
1060 rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
1061 rnConDecls condecls
1062   = do { condecls' <- mapM (wrapLocM rnConDecl) condecls
1063        ; return (condecls', plusFVs (map conDeclFVs condecls')) }
1064
1065 rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name)
1066 rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs
1067                         , con_cxt = cxt, con_details = details
1068                         , con_res = res_ty, con_doc = mb_doc
1069                         , con_old_rec = old_rec, con_explicit = expl })
1070   = do  { addLocM checkConName name
1071         ; when old_rec (addWarn (deprecRecSyntax decl))
1072         ; new_name <- lookupLocatedTopBndrRn name
1073
1074            -- For H98 syntax, the tvs are the existential ones
1075            -- For GADT syntax, the tvs are all the quantified tyvars
1076            -- Hence the 'filter' in the ResTyH98 case only
1077         ; rdr_env <- getLocalRdrEnv
1078         ; let in_scope     = (`elemLocalRdrEnv` rdr_env) . unLoc
1079               arg_tys      = hsConDeclArgTys details
1080               mentioned_tvs = case res_ty of
1081                                ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys)
1082                                ResTyGADT ty -> get_rdr_tvs (ty : arg_tys)
1083
1084          -- With an Explicit forall, check for unused binders
1085          -- With Implicit, find the mentioned ones, and use them as binders
1086         ; new_tvs <- case expl of
1087                        Implicit -> return (userHsTyVarBndrs mentioned_tvs)
1088                        Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs mentioned_tvs
1089                                       ; return tvs }
1090
1091         ; mb_doc' <- rnMbLHsDoc mb_doc 
1092
1093         ; bindTyVarsRn doc new_tvs $ \new_tyvars -> do
1094         { new_context <- rnContext doc cxt
1095         ; new_details <- rnConDeclDetails doc details
1096         ; (new_details', new_res_ty)  <- rnConResult doc (unLoc new_name) new_details res_ty
1097         ; return (decl { con_name = new_name, con_qvars = new_tyvars, con_cxt = new_context 
1098                        , con_details = new_details', con_res = new_res_ty, con_doc = mb_doc' }) }}
1099  where
1100     doc = ConDeclCtx name
1101     get_rdr_tvs tys  = extractHsRhoRdrTyVars cxt (noLoc (HsTupleTy HsBoxedTuple tys))
1102
1103 rnConResult :: HsDocContext -> Name
1104             -> HsConDetails (LHsType Name) [ConDeclField Name]
1105             -> ResType RdrName
1106             -> RnM (HsConDetails (LHsType Name) [ConDeclField Name],
1107                     ResType Name)
1108 rnConResult _   _   details ResTyH98 = return (details, ResTyH98)
1109 rnConResult doc con details (ResTyGADT ty)
1110   = do { ty' <- rnLHsType doc ty
1111        ; let (arg_tys, res_ty) = splitHsFunType ty'
1112                 -- We can finally split it up, 
1113                 -- now the renamer has dealt with fixities
1114                 -- See Note [Sorting out the result type] in RdrHsSyn
1115
1116        ; case details of
1117            InfixCon {}  -> pprPanic "rnConResult" (ppr ty)
1118            -- See Note [Sorting out the result type] in RdrHsSyn
1119
1120            RecCon {}    -> do { unless (null arg_tys) 
1121                                        (addErr (badRecResTy (docOfHsDocContext doc)))
1122                               ; return (details, ResTyGADT res_ty) }
1123
1124            PrefixCon {} | isSymOcc (getOccName con)  -- See Note [Infix GADT cons]
1125                         , [ty1,ty2] <- arg_tys
1126                         -> do { fix_env <- getFixityEnv
1127                               ; return (if   con `elemNameEnv` fix_env 
1128                                         then InfixCon ty1 ty2
1129                                         else PrefixCon arg_tys
1130                                        , ResTyGADT res_ty) }
1131                         | otherwise
1132                         -> return (PrefixCon arg_tys, ResTyGADT res_ty) }
1133
1134 rnConDeclDetails :: HsDocContext
1135                  -> HsConDetails (LHsType RdrName) [ConDeclField RdrName]
1136                  -> RnM (HsConDetails (LHsType Name) [ConDeclField Name])
1137 rnConDeclDetails doc (PrefixCon tys)
1138   = do { new_tys <- mapM (rnLHsType doc) tys
1139        ; return (PrefixCon new_tys) }
1140
1141 rnConDeclDetails doc (InfixCon ty1 ty2)
1142   = do { new_ty1 <- rnLHsType doc ty1
1143        ; new_ty2 <- rnLHsType doc ty2
1144        ; return (InfixCon new_ty1 new_ty2) }
1145
1146 rnConDeclDetails doc (RecCon fields)
1147   = do  { new_fields <- rnConDeclFields doc fields
1148                 -- No need to check for duplicate fields
1149                 -- since that is done by RnNames.extendGlobalRdrEnvRn
1150         ; return (RecCon new_fields) }
1151
1152 -------------------------------------------------
1153 deprecRecSyntax :: ConDecl RdrName -> SDoc
1154 deprecRecSyntax decl 
1155   = vcat [ ptext (sLit "Declaration of") <+> quotes (ppr (con_name decl))
1156                  <+> ptext (sLit "uses deprecated syntax")
1157          , ptext (sLit "Instead, use the form")
1158          , nest 2 (ppr decl) ]   -- Pretty printer uses new form
1159
1160 badRecResTy :: SDoc -> SDoc
1161 badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
1162
1163 -- This data decl will parse OK
1164 --      data T = a Int
1165 -- treating "a" as the constructor.
1166 -- It is really hard to make the parser spot this malformation.
1167 -- So the renamer has to check that the constructor is legal
1168 --
1169 -- We can get an operator as the constructor, even in the prefix form:
1170 --      data T = :% Int Int
1171 -- from interface files, which always print in prefix form
1172
1173 checkConName :: RdrName -> TcRn ()
1174 checkConName name = checkErr (isRdrDataCon name) (badDataCon name)
1175
1176 badDataCon :: RdrName -> SDoc
1177 badDataCon name
1178    = hsep [ptext (sLit "Illegal data constructor name"), quotes (ppr name)]
1179 \end{code}
1180
1181 Note [Infix GADT constructors]
1182 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1183 We do not currently have syntax to declare an infix constructor in GADT syntax,
1184 but it makes a (small) difference to the Show instance.  So as a slightly
1185 ad-hoc solution, we regard a GADT data constructor as infix if
1186   a) it is an operator symbol
1187   b) it has two arguments
1188   c) there is a fixity declaration for it
1189 For example:
1190    infix 6 (:--:) 
1191    data T a where
1192      (:--:) :: t1 -> t2 -> T Int
1193
1194 %*********************************************************
1195 %*                                                      *
1196 \subsection{Support code for type/data declarations}
1197 %*                                                      *
1198 %*********************************************************
1199
1200 Get the mapping from constructors to fields for this module.
1201 It's convenient to do this after the data type decls have been renamed
1202 \begin{code}
1203 extendRecordFieldEnv :: [[LTyClDecl RdrName]] -> [LInstDecl RdrName] -> TcM TcGblEnv
1204 extendRecordFieldEnv tycl_decls inst_decls
1205   = do  { tcg_env <- getGblEnv
1206         ; field_env' <- foldrM get_con (tcg_field_env tcg_env) all_data_cons
1207         ; return (tcg_env { tcg_field_env = field_env' }) }
1208   where
1209     -- we want to lookup:
1210     --  (a) a datatype constructor
1211     --  (b) a record field
1212     -- knowing that they're from this module.
1213     -- lookupLocatedTopBndrRn does this, because it does a lookupGreLocalRn,
1214     -- which keeps only the local ones.
1215     lookup x = do { x' <- lookupLocatedTopBndrRn x
1216                     ; return $ unLoc x'}
1217
1218     all_data_cons :: [ConDecl RdrName]
1219     all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls
1220                          , L _ con <- cons ]
1221     all_tycl_decls = at_tycl_decls ++ concat tycl_decls
1222     at_tycl_decls = instDeclFamInsts inst_decls  -- Do not forget associated types!
1223
1224     get_con (ConDecl { con_name = con, con_details = RecCon flds })
1225             (RecFields env fld_set)
1226         = do { con' <- lookup con
1227              ; flds' <- mapM lookup (map cd_fld_name flds)
1228              ; let env'    = extendNameEnv env con' flds'
1229                    fld_set' = addListToNameSet fld_set flds'
1230              ; return $ (RecFields env' fld_set') }
1231     get_con _ env = return env
1232 \end{code}
1233
1234 %*********************************************************
1235 %*                                                      *
1236 \subsection{Support code to rename types}
1237 %*                                                      *
1238 %*********************************************************
1239
1240 \begin{code}
1241 rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)]
1242
1243 rnFds doc fds
1244   = mapM (wrapLocM rn_fds) fds
1245   where
1246     rn_fds (tys1, tys2)
1247       = do { tys1' <- rnHsTyVars doc tys1
1248            ; tys2' <- rnHsTyVars doc tys2
1249            ; return (tys1', tys2') }
1250
1251 rnHsTyVars :: SDoc -> [RdrName] -> RnM [Name]
1252 rnHsTyVars doc tvs  = mapM (rnHsTyVar doc) tvs
1253
1254 rnHsTyVar :: SDoc -> RdrName -> RnM Name
1255 rnHsTyVar _doc tyvar = lookupOccRn tyvar
1256 \end{code}
1257
1258
1259 %*********************************************************
1260 %*                                                      *
1261         findSplice
1262 %*                                                      *
1263 %*********************************************************
1264
1265 This code marches down the declarations, looking for the first
1266 Template Haskell splice.  As it does so it
1267         a) groups the declarations into a HsGroup
1268         b) runs any top-level quasi-quotes
1269
1270 \begin{code}
1271 findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1272 findSplice ds = addl emptyRdrGroup ds
1273
1274 addl :: HsGroup RdrName -> [LHsDecl RdrName]
1275      -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1276 -- This stuff reverses the declarations (again) but it doesn't matter
1277 addl gp []           = return (gp, Nothing)
1278 addl gp (L l d : ds) = add gp l d ds
1279
1280
1281 add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName]
1282     -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName]))
1283
1284 add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds 
1285   = do { -- We've found a top-level splice.  If it is an *implicit* one 
1286          -- (i.e. a naked top level expression)
1287          case flag of
1288            Explicit -> return ()
1289            Implicit -> do { th_on <- xoptM Opt_TemplateHaskell
1290                           ; unless th_on $ setSrcSpan loc $
1291                             failWith badImplicitSplice }
1292
1293        ; return (gp, Just (splice, ds)) }
1294   where
1295     badImplicitSplice = ptext (sLit "Parse error: naked expression at top level")
1296
1297 #ifndef GHCI
1298 add _ _ (QuasiQuoteD qq) _
1299   = pprPanic "Can't do QuasiQuote declarations without GHCi" (ppr qq)
1300 #else
1301 add gp _ (QuasiQuoteD qq) ds            -- Expand quasiquotes
1302   = do { ds' <- runQuasiQuoteDecl qq
1303        ; addl gp (ds' ++ ds) }
1304 #endif
1305
1306 -- Class declarations: pull out the fixity signatures to the top
1307 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
1308   | isClassDecl d
1309   = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
1310     addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
1311   | otherwise
1312   = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
1313
1314 -- Signatures: fixity sigs go a different place than all others
1315 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
1316   = addl (gp {hs_fixds = L l f : ts}) ds
1317 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
1318   = addl (gp {hs_valds = add_sig (L l d) ts}) ds
1319
1320 -- Value declarations: use add_bind
1321 add gp@(HsGroup {hs_valds  = ts}) l (ValD d) ds
1322   = addl (gp { hs_valds = add_bind (L l d) ts }) ds
1323
1324 -- The rest are routine
1325 add gp@(HsGroup {hs_instds = ts})  l (InstD d) ds
1326   = addl (gp { hs_instds = L l d : ts }) ds
1327 add gp@(HsGroup {hs_derivds = ts})  l (DerivD d) ds
1328   = addl (gp { hs_derivds = L l d : ts }) ds
1329 add gp@(HsGroup {hs_defds  = ts})  l (DefD d) ds
1330   = addl (gp { hs_defds = L l d : ts }) ds
1331 add gp@(HsGroup {hs_fords  = ts}) l (ForD d) ds
1332   = addl (gp { hs_fords = L l d : ts }) ds
1333 add gp@(HsGroup {hs_warnds  = ts})  l (WarningD d) ds
1334   = addl (gp { hs_warnds = L l d : ts }) ds
1335 add gp@(HsGroup {hs_annds  = ts}) l (AnnD d) ds
1336   = addl (gp { hs_annds = L l d : ts }) ds
1337 add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD d) ds
1338   = addl (gp { hs_ruleds = L l d : ts }) ds
1339 add gp@(HsGroup {hs_vects  = ts}) l (VectD d) ds
1340   = addl (gp { hs_vects = L l d : ts }) ds
1341 add gp l (DocD d) ds
1342   = addl (gp { hs_docs = (L l d) : (hs_docs gp) })  ds
1343
1344 add_tycld :: LTyClDecl a -> [[LTyClDecl a]] -> [[LTyClDecl a]]
1345 add_tycld d []       = [[d]]
1346 add_tycld d (ds:dss) = (d:ds) : dss
1347
1348 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
1349 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
1350 add_bind _ (ValBindsOut {})     = panic "RdrHsSyn:add_bind"
1351
1352 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
1353 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs) 
1354 add_sig _ (ValBindsOut {})     = panic "RdrHsSyn:add_sig"
1355 \end{code}