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