Wombling around in Trac #14808
[ghc.git] / compiler / rename / RnSource.hs
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4 \section[RnSource]{Main pass of renamer}
5 -}
6
7 {-# LANGUAGE CPP, ScopedTypeVariables #-}
8 {-# LANGUAGE FlexibleContexts #-}
9 {-# LANGUAGE TypeFamilies #-}
10
11 module RnSource (
12 rnSrcDecls, addTcgDUs, findSplice
13 ) where
14
15 #include "HsVersions.h"
16
17 import GhcPrelude
18
19 import {-# SOURCE #-} RnExpr( rnLExpr )
20 import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls )
21
22 import HsSyn
23 import FieldLabel
24 import RdrName
25 import RnTypes
26 import RnBinds
27 import RnEnv
28 import RnUtils ( HsDocContext(..), mapFvRn, bindLocalNames
29 , checkDupRdrNames, inHsDocContext, bindLocalNamesFV
30 , checkShadowedRdrNames, warnUnusedTypePatterns
31 , extendTyVarEnvFVRn, newLocalBndrsRn )
32 import RnUnbound ( mkUnboundName )
33 import RnNames
34 import RnHsDoc ( rnHsDoc, rnMbLHsDoc )
35 import TcAnnotations ( annCtxt )
36 import TcRnMonad
37
38 import ForeignCall ( CCallTarget(..) )
39 import Module
40 import HscTypes ( Warnings(..), plusWarns )
41 import Class ( FunDep )
42 import PrelNames ( applicativeClassName, pureAName, thenAName
43 , monadClassName, returnMName, thenMName
44 , monadFailClassName, failMName, failMName_preMFP
45 , semigroupClassName, sappendName
46 , monoidClassName, mappendName
47 )
48 import Name
49 import NameSet
50 import NameEnv
51 import Avail
52 import Outputable
53 import Bag
54 import BasicTypes ( DerivStrategy, RuleName, pprRuleName )
55 import FastString
56 import SrcLoc
57 import DynFlags
58 import Util ( debugIsOn, filterOut, lengthExceeds, partitionWith )
59 import HscTypes ( HscEnv, hsc_dflags )
60 import ListSetOps ( findDupsEq, removeDups, equivClasses )
61 import Digraph ( SCC, flattenSCC, flattenSCCs, Node(..)
62 , stronglyConnCompFromEdgedVerticesUniq )
63 import UniqSet
64 import qualified GHC.LanguageExtensions as LangExt
65
66 import Control.Monad
67 import Control.Arrow ( first )
68 import Data.List ( mapAccumL )
69 import qualified Data.List.NonEmpty as NE
70 import Data.List.NonEmpty ( NonEmpty(..) )
71 import Data.Maybe ( isJust )
72 import qualified Data.Set as Set ( difference, fromList, toList, null )
73
74 {- | @rnSourceDecl@ "renames" declarations.
75 It simultaneously performs dependency analysis and precedence parsing.
76 It also does the following error checks:
77
78 * Checks that tyvars are used properly. This includes checking
79 for undefined tyvars, and tyvars in contexts that are ambiguous.
80 (Some of this checking has now been moved to module @TcMonoType@,
81 since we don't have functional dependency information at this point.)
82
83 * Checks that all variable occurrences are defined.
84
85 * Checks the @(..)@ etc constraints in the export list.
86
87 Brings the binders of the group into scope in the appropriate places;
88 does NOT assume that anything is in scope already
89 -}
90 rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn)
91 -- Rename a top-level HsGroup; used for normal source files *and* hs-boot files
92 rnSrcDecls group@(HsGroup { hs_valds = val_decls,
93 hs_splcds = splice_decls,
94 hs_tyclds = tycl_decls,
95 hs_derivds = deriv_decls,
96 hs_fixds = fix_decls,
97 hs_warnds = warn_decls,
98 hs_annds = ann_decls,
99 hs_fords = foreign_decls,
100 hs_defds = default_decls,
101 hs_ruleds = rule_decls,
102 hs_vects = vect_decls,
103 hs_docs = docs })
104 = do {
105 -- (A) Process the fixity declarations, creating a mapping from
106 -- FastStrings to FixItems.
107 -- Also checks for duplicates.
108 local_fix_env <- makeMiniFixityEnv fix_decls ;
109
110 -- (B) Bring top level binders (and their fixities) into scope,
111 -- *except* for the value bindings, which get done in step (D)
112 -- with collectHsIdBinders. However *do* include
113 --
114 -- * Class ops, data constructors, and record fields,
115 -- because they do not have value declarations.
116 -- Aso step (C) depends on datacons and record fields
117 --
118 -- * For hs-boot files, include the value signatures
119 -- Again, they have no value declarations
120 --
121 (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;
122
123
124 setEnvs tc_envs $ do {
125
126 failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
127
128 -- (D1) Bring pattern synonyms into scope.
129 -- Need to do this before (D2) because rnTopBindsLHS
130 -- looks up those pattern synonyms (Trac #9889)
131
132 extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do {
133
134 -- (D2) Rename the left-hand sides of the value bindings.
135 -- This depends on everything from (B) being in scope,
136 -- and on (C) for resolving record wild cards.
137 -- It uses the fixity env from (A) to bind fixities for view patterns.
138 new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
139
140 -- Bind the LHSes (and their fixities) in the global rdr environment
141 let { id_bndrs = collectHsIdBinders new_lhs } ; -- Excludes pattern-synonym binders
142 -- They are already in scope
143 traceRn "rnSrcDecls" (ppr id_bndrs) ;
144 tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;
145 setEnvs tc_envs $ do {
146
147 -- Now everything is in scope, as the remaining renaming assumes.
148
149 -- (E) Rename type and class decls
150 -- (note that value LHSes need to be in scope for default methods)
151 --
152 -- You might think that we could build proper def/use information
153 -- for type and class declarations, but they can be involved
154 -- in mutual recursion across modules, and we only do the SCC
155 -- analysis for them in the type checker.
156 -- So we content ourselves with gathering uses only; that
157 -- means we'll only report a declaration as unused if it isn't
158 -- mentioned at all. Ah well.
159 traceRn "Start rnTyClDecls" (ppr tycl_decls) ;
160 (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;
161
162 -- (F) Rename Value declarations right-hand sides
163 traceRn "Start rnmono" empty ;
164 let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;
165 is_boot <- tcIsHsBootOrSig ;
166 (rn_val_decls, bind_dus) <- if is_boot
167 -- For an hs-boot, use tc_bndrs (which collects how we're renamed
168 -- signatures), since val_bndr_set is empty (there are no x = ...
169 -- bindings in an hs-boot.)
170 then rnTopBindsBoot tc_bndrs new_lhs
171 else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ;
172 traceRn "finish rnmono" (ppr rn_val_decls) ;
173
174 -- (G) Rename Fixity and deprecations
175
176 -- Rename fixity declarations and error if we try to
177 -- fix something from another module (duplicates were checked in (A))
178 let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ;
179 rn_fix_decls <- mapM (mapM (rnSrcFixityDecl (TopSigCtxt all_bndrs)))
180 fix_decls ;
181
182 -- Rename deprec decls;
183 -- check for duplicates and ensure that deprecated things are defined locally
184 -- at the moment, we don't keep these around past renaming
185 rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ;
186
187 -- (H) Rename Everything else
188
189 (rn_rule_decls, src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $
190 rnList rnHsRuleDecls rule_decls ;
191 -- Inside RULES, scoped type variables are on
192 (rn_vect_decls, src_fvs3) <- rnList rnHsVectDecl vect_decls ;
193 (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ;
194 (rn_ann_decls, src_fvs5) <- rnList rnAnnDecl ann_decls ;
195 (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl default_decls ;
196 (rn_deriv_decls, src_fvs7) <- rnList rnSrcDerivDecl deriv_decls ;
197 (rn_splice_decls, src_fvs8) <- rnList rnSpliceDecl splice_decls ;
198 -- Haddock docs; no free vars
199 rn_docs <- mapM (wrapLocM rnDocDecl) docs ;
200
201 last_tcg_env <- getGblEnv ;
202 -- (I) Compute the results and return
203 let {rn_group = HsGroup { hs_valds = rn_val_decls,
204 hs_splcds = rn_splice_decls,
205 hs_tyclds = rn_tycl_decls,
206 hs_derivds = rn_deriv_decls,
207 hs_fixds = rn_fix_decls,
208 hs_warnds = [], -- warns are returned in the tcg_env
209 -- (see below) not in the HsGroup
210 hs_fords = rn_foreign_decls,
211 hs_annds = rn_ann_decls,
212 hs_defds = rn_default_decls,
213 hs_ruleds = rn_rule_decls,
214 hs_vects = rn_vect_decls,
215 hs_docs = rn_docs } ;
216
217 tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ;
218 other_def = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;
219 other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, src_fvs5,
220 src_fvs6, src_fvs7, src_fvs8] ;
221 -- It is tiresome to gather the binders from type and class decls
222
223 src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;
224 -- Instance decls may have occurrences of things bound in bind_dus
225 -- so we must put other_fvs last
226
227 final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus)
228 in -- we return the deprecs in the env, not in the HsGroup above
229 tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };
230 } ;
231 traceRn "finish rnSrc" (ppr rn_group) ;
232 traceRn "finish Dus" (ppr src_dus ) ;
233 return (final_tcg_env, rn_group)
234 }}}}
235
236 addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv
237 -- This function could be defined lower down in the module hierarchy,
238 -- but there doesn't seem anywhere very logical to put it.
239 addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }
240
241 rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)
242 rnList f xs = mapFvRn (wrapLocFstM f) xs
243
244 {-
245 *********************************************************
246 * *
247 HsDoc stuff
248 * *
249 *********************************************************
250 -}
251
252 rnDocDecl :: DocDecl -> RnM DocDecl
253 rnDocDecl (DocCommentNext doc) = do
254 rn_doc <- rnHsDoc doc
255 return (DocCommentNext rn_doc)
256 rnDocDecl (DocCommentPrev doc) = do
257 rn_doc <- rnHsDoc doc
258 return (DocCommentPrev rn_doc)
259 rnDocDecl (DocCommentNamed str doc) = do
260 rn_doc <- rnHsDoc doc
261 return (DocCommentNamed str rn_doc)
262 rnDocDecl (DocGroup lev doc) = do
263 rn_doc <- rnHsDoc doc
264 return (DocGroup lev rn_doc)
265
266 {-
267 *********************************************************
268 * *
269 Source-code deprecations declarations
270 * *
271 *********************************************************
272
273 Check that the deprecated names are defined, are defined locally, and
274 that there are no duplicate deprecations.
275
276 It's only imported deprecations, dealt with in RnIfaces, that we
277 gather them together.
278 -}
279
280 -- checks that the deprecations are defined locally, and that there are no duplicates
281 rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings
282 rnSrcWarnDecls _ []
283 = return NoWarnings
284
285 rnSrcWarnDecls bndr_set decls'
286 = do { -- check for duplicates
287 ; mapM_ (\ dups -> let (L loc rdr :| (lrdr':_)) = dups
288 in addErrAt loc (dupWarnDecl lrdr' rdr))
289 warn_rdr_dups
290 ; pairs_s <- mapM (addLocM rn_deprec) decls
291 ; return (WarnSome ((concat pairs_s))) }
292 where
293 decls = concatMap (\(L _ d) -> wd_warnings d) decls'
294
295 sig_ctxt = TopSigCtxt bndr_set
296
297 rn_deprec (Warning rdr_names txt)
298 -- ensures that the names are defined locally
299 = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)
300 rdr_names
301 ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }
302
303 what = text "deprecation"
304
305 warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning ns _)) -> ns)
306 decls
307
308 findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)]
309 findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))
310
311 -- look for duplicates among the OccNames;
312 -- we check that the names are defined above
313 -- invt: the lists returned by findDupsEq always have at least two elements
314
315 dupWarnDecl :: Located RdrName -> RdrName -> SDoc
316 -- Located RdrName -> DeprecDecl RdrName -> SDoc
317 dupWarnDecl (L loc _) rdr_name
318 = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),
319 text "also at " <+> ppr loc]
320
321 {-
322 *********************************************************
323 * *
324 \subsection{Annotation declarations}
325 * *
326 *********************************************************
327 -}
328
329 rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)
330 rnAnnDecl ann@(HsAnnotation s provenance expr)
331 = addErrCtxt (annCtxt ann) $
332 do { (provenance', provenance_fvs) <- rnAnnProvenance provenance
333 ; (expr', expr_fvs) <- setStage (Splice Untyped) $
334 rnLExpr expr
335 ; return (HsAnnotation s provenance' expr',
336 provenance_fvs `plusFV` expr_fvs) }
337
338 rnAnnProvenance :: AnnProvenance RdrName
339 -> RnM (AnnProvenance Name, FreeVars)
340 rnAnnProvenance provenance = do
341 provenance' <- traverse lookupTopBndrRn provenance
342 return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))
343
344 {-
345 *********************************************************
346 * *
347 \subsection{Default declarations}
348 * *
349 *********************************************************
350 -}
351
352 rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)
353 rnDefaultDecl (DefaultDecl tys)
354 = do { (tys', fvs) <- rnLHsTypes doc_str tys
355 ; return (DefaultDecl tys', fvs) }
356 where
357 doc_str = DefaultDeclCtx
358
359 {-
360 *********************************************************
361 * *
362 \subsection{Foreign declarations}
363 * *
364 *********************************************************
365 -}
366
367 rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)
368 rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
369 = do { topEnv :: HscEnv <- getTopEnv
370 ; name' <- lookupLocatedTopBndrRn name
371 ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
372
373 -- Mark any PackageTarget style imports as coming from the current package
374 ; let unitId = thisPackage $ hsc_dflags topEnv
375 spec' = patchForeignImport unitId spec
376
377 ; return (ForeignImport { fd_name = name', fd_sig_ty = ty'
378 , fd_co = noForeignImportCoercionYet
379 , fd_fi = spec' }, fvs) }
380
381 rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
382 = do { name' <- lookupLocatedOccRn name
383 ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
384 ; return (ForeignExport { fd_name = name', fd_sig_ty = ty'
385 , fd_co = noForeignExportCoercionYet
386 , fd_fe = spec }
387 , 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 :: UnitId -> ForeignImport -> ForeignImport
398 patchForeignImport unitId (CImport cconv safety fs spec src)
399 = CImport cconv safety fs (patchCImportSpec unitId spec) src
400
401 patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec
402 patchCImportSpec unitId spec
403 = case spec of
404 CFunction callTarget -> CFunction $ patchCCallTarget unitId callTarget
405 _ -> spec
406
407 patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget
408 patchCCallTarget unitId callTarget =
409 case callTarget of
410 StaticTarget src label Nothing isFun
411 -> StaticTarget src label (Just unitId) isFun
412 _ -> callTarget
413
414 {-
415 *********************************************************
416 * *
417 \subsection{Instance declarations}
418 * *
419 *********************************************************
420 -}
421
422 rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)
423 rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })
424 = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi
425 ; return (TyFamInstD { tfid_inst = tfi' }, fvs) }
426
427 rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })
428 = do { (dfi', fvs) <- rnDataFamInstDecl Nothing dfi
429 ; return (DataFamInstD { dfid_inst = dfi' }, fvs) }
430
431 rnSrcInstDecl (ClsInstD { cid_inst = cid })
432 = do { traceRn "rnSrcIstDecl {" (ppr cid)
433 ; (cid', fvs) <- rnClsInstDecl cid
434 ; traceRn "rnSrcIstDecl end }" empty
435 ; return (ClsInstD { cid_inst = cid' }, fvs) }
436
437 -- | Warn about non-canonical typeclass instance declarations
438 --
439 -- A "non-canonical" instance definition can occur for instances of a
440 -- class which redundantly defines an operation its superclass
441 -- provides as well (c.f. `return`/`pure`). In such cases, a canonical
442 -- instance is one where the subclass inherits its method
443 -- implementation from its superclass instance (usually the subclass
444 -- has a default method implementation to that effect). Consequently,
445 -- a non-canonical instance occurs when this is not the case.
446 --
447 -- See also descriptions of 'checkCanonicalMonadInstances' and
448 -- 'checkCanonicalMonoidInstances'
449 checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM ()
450 checkCanonicalInstances cls poly_ty mbinds = do
451 whenWOptM Opt_WarnNonCanonicalMonadInstances
452 checkCanonicalMonadInstances
453
454 whenWOptM Opt_WarnNonCanonicalMonadFailInstances
455 checkCanonicalMonadFailInstances
456
457 whenWOptM Opt_WarnNonCanonicalMonoidInstances
458 checkCanonicalMonoidInstances
459
460 where
461 -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance
462 -- declarations. Specifically, the following conditions are verified:
463 --
464 -- In 'Monad' instances declarations:
465 --
466 -- * If 'return' is overridden it must be canonical (i.e. @return = pure@)
467 -- * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@)
468 --
469 -- In 'Applicative' instance declarations:
470 --
471 -- * Warn if 'pure' is defined backwards (i.e. @pure = return@).
472 -- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).
473 --
474 checkCanonicalMonadInstances
475 | cls == applicativeClassName = do
476 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
477 case mbind of
478 FunBind { fun_id = L _ name, fun_matches = mg }
479 | name == pureAName, isAliasMG mg == Just returnMName
480 -> addWarnNonCanonicalMethod1
481 Opt_WarnNonCanonicalMonadInstances "pure" "return"
482
483 | name == thenAName, isAliasMG mg == Just thenMName
484 -> addWarnNonCanonicalMethod1
485 Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)"
486
487 _ -> return ()
488
489 | cls == monadClassName = do
490 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
491 case mbind of
492 FunBind { fun_id = L _ name, fun_matches = mg }
493 | name == returnMName, isAliasMG mg /= Just pureAName
494 -> addWarnNonCanonicalMethod2
495 Opt_WarnNonCanonicalMonadInstances "return" "pure"
496
497 | name == thenMName, isAliasMG mg /= Just thenAName
498 -> addWarnNonCanonicalMethod2
499 Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)"
500
501 _ -> return ()
502
503 | otherwise = return ()
504
505 -- | Warn about unsound/non-canonical 'Monad'/'MonadFail' instance
506 -- declarations. Specifically, the following conditions are verified:
507 --
508 -- In 'Monad' instances declarations:
509 --
510 -- * If 'fail' is overridden it must be canonical
511 -- (i.e. @fail = Control.Monad.Fail.fail@)
512 --
513 -- In 'MonadFail' instance declarations:
514 --
515 -- * Warn if 'fail' is defined backwards
516 -- (i.e. @fail = Control.Monad.fail@).
517 --
518 checkCanonicalMonadFailInstances
519 | cls == monadFailClassName = do
520 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
521 case mbind of
522 FunBind { fun_id = L _ name, fun_matches = mg }
523 | name == failMName, isAliasMG mg == Just failMName_preMFP
524 -> addWarnNonCanonicalMethod1
525 Opt_WarnNonCanonicalMonadFailInstances "fail"
526 "Control.Monad.fail"
527
528 _ -> return ()
529
530 | cls == monadClassName = do
531 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
532 case mbind of
533 FunBind { fun_id = L _ name, fun_matches = mg }
534 | name == failMName_preMFP, isAliasMG mg /= Just failMName
535 -> addWarnNonCanonicalMethod2
536 Opt_WarnNonCanonicalMonadFailInstances "fail"
537 "Control.Monad.Fail.fail"
538 _ -> return ()
539
540 | otherwise = return ()
541
542 -- | Check whether Monoid(mappend) is defined in terms of
543 -- Semigroup((<>)) (and not the other way round). Specifically,
544 -- the following conditions are verified:
545 --
546 -- In 'Monoid' instances declarations:
547 --
548 -- * If 'mappend' is overridden it must be canonical
549 -- (i.e. @mappend = (<>)@)
550 --
551 -- In 'Semigroup' instance declarations:
552 --
553 -- * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@).
554 --
555 checkCanonicalMonoidInstances
556 | cls == semigroupClassName = do
557 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
558 case mbind of
559 FunBind { fun_id = L _ name, fun_matches = mg }
560 | name == sappendName, isAliasMG mg == Just mappendName
561 -> addWarnNonCanonicalMethod1
562 Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend"
563
564 _ -> return ()
565
566 | cls == monoidClassName = do
567 forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
568 case mbind of
569 FunBind { fun_id = L _ name, fun_matches = mg }
570 | name == mappendName, isAliasMG mg /= Just sappendName
571 -> addWarnNonCanonicalMethod2NoDefault
572 Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)"
573
574 _ -> return ()
575
576 | otherwise = return ()
577
578 -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\"
579 -- binding, and return @Just rhsName@ if this is the case
580 isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name
581 isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]}
582 | GRHSs [L _ (GRHS [] body)] lbinds <- grhss
583 , L _ EmptyLocalBinds <- lbinds
584 , L _ (HsVar (L _ rhsName)) <- body = Just rhsName
585 isAliasMG _ = Nothing
586
587 -- got "lhs = rhs" but expected something different
588 addWarnNonCanonicalMethod1 flag lhs rhs = do
589 addWarn (Reason flag) $ vcat
590 [ text "Noncanonical" <+>
591 quotes (text (lhs ++ " = " ++ rhs)) <+>
592 text "definition detected"
593 , instDeclCtxt1 poly_ty
594 , text "Move definition from" <+>
595 quotes (text rhs) <+>
596 text "to" <+> quotes (text lhs)
597 ]
598
599 -- expected "lhs = rhs" but got something else
600 addWarnNonCanonicalMethod2 flag lhs rhs = do
601 addWarn (Reason flag) $ vcat
602 [ text "Noncanonical" <+>
603 quotes (text lhs) <+>
604 text "definition detected"
605 , instDeclCtxt1 poly_ty
606 , text "Either remove definition for" <+>
607 quotes (text lhs) <+> text "or define as" <+>
608 quotes (text (lhs ++ " = " ++ rhs))
609 ]
610
611 -- like above, but method has no default impl
612 addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do
613 addWarn (Reason flag) $ vcat
614 [ text "Noncanonical" <+>
615 quotes (text lhs) <+>
616 text "definition detected"
617 , instDeclCtxt1 poly_ty
618 , text "Define as" <+>
619 quotes (text (lhs ++ " = " ++ rhs))
620 ]
621
622 -- stolen from TcInstDcls
623 instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
624 instDeclCtxt1 hs_inst_ty
625 = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
626
627 inst_decl_ctxt :: SDoc -> SDoc
628 inst_decl_ctxt doc = hang (text "in the instance declaration for")
629 2 (quotes doc <> text ".")
630
631
632 rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)
633 rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
634 , cid_sigs = uprags, cid_tyfam_insts = ats
635 , cid_overlap_mode = oflag
636 , cid_datafam_insts = adts })
637 = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "an instance declaration") inst_ty
638 ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
639 ; let cls = case hsTyGetAppHead_maybe head_ty' of
640 Nothing -> mkUnboundName (mkTcOccFS (fsLit "<class>"))
641 Just (L _ cls, _) -> cls
642 -- rnLHsInstType has added an error message
643 -- if hsTyGetAppHead_maybe fails
644
645 -- Rename the bindings
646 -- The typechecker (not the renamer) checks that all
647 -- the bindings are for the right class
648 -- (Slightly strangely) when scoped type variables are on, the
649 -- forall-d tyvars scope over the method bindings too
650 ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags
651
652 ; checkCanonicalInstances cls inst_ty' mbinds'
653
654 -- Rename the associated types, and type signatures
655 -- Both need to have the instance type variables in scope
656 ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names)
657 ; ((ats', adts'), more_fvs)
658 <- extendTyVarEnvFVRn ktv_names $
659 do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats
660 ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts
661 ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) }
662
663 ; let all_fvs = meth_fvs `plusFV` more_fvs
664 `plusFV` inst_fvs
665 ; return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = mbinds'
666 , cid_sigs = uprags', cid_tyfam_insts = ats'
667 , cid_overlap_mode = oflag
668 , cid_datafam_insts = adts' },
669 all_fvs) }
670 -- We return the renamed associated data type declarations so
671 -- that they can be entered into the list of type declarations
672 -- for the binding group, but we also keep a copy in the instance.
673 -- The latter is needed for well-formedness checks in the type
674 -- checker (eg, to ensure that all ATs of the instance actually
675 -- receive a declaration).
676 -- NB: Even the copies in the instance declaration carry copies of
677 -- the instance context after renaming. This is a bit
678 -- strange, but should not matter (and it would be more work
679 -- to remove the context).
680
681 rnFamInstEqn :: HsDocContext
682 -> Maybe (Name, [Name]) -- Nothing => not associated
683 -- Just (cls,tvs) => associated,
684 -- and gives class and tyvars of the
685 -- parent instance delc
686 -> [Located RdrName] -- Kind variables from the equation's RHS
687 -> FamInstEqn GhcPs rhs
688 -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
689 -> RnM (FamInstEqn GhcRn rhs', FreeVars)
690 rnFamInstEqn doc mb_cls rhs_kvars
691 (HsIB { hsib_body = FamEqn { feqn_tycon = tycon
692 , feqn_pats = pats
693 , feqn_fixity = fixity
694 , feqn_rhs = payload }}) rn_payload
695 = do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon
696 ; let loc = case pats of
697 [] -> pprPanic "rnFamInstEqn" (ppr tycon)
698 (L loc _ : []) -> loc
699 (L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
700
701 ; pat_kity_vars_with_dups <- extractHsTysRdrTyVarsDups pats
702 ; let pat_vars = freeKiTyVarsAllVars $
703 rmDupsInRdrTyVars pat_kity_vars_with_dups
704 -- Use the "...Dups" form because it's needed
705 -- below to report unsed binder on the LHS
706 ; pat_var_names <- mapM (newTyVarNameRn mb_cls . L loc . unLoc) pat_vars
707
708 -- Make sure to filter out the kind variables that were explicitly
709 -- bound in the type patterns.
710 ; let payload_vars = filterOut (`elemRdr` pat_vars) rhs_kvars
711 ; payload_var_names <- mapM (newTyVarNameRn mb_cls) payload_vars
712
713 ; let all_var_names = pat_var_names ++ payload_var_names
714
715 -- All the free vars of the family patterns
716 -- with a sensible binding location
717 ; ((pats', payload'), fvs)
718 <- bindLocalNamesFV all_var_names $
719 do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats
720 ; (payload', rhs_fvs) <- rn_payload doc payload
721
722 -- Report unused binders on the LHS
723 -- See Note [Unused type variables in family instances]
724 ; let groups :: [NonEmpty (Located RdrName)]
725 groups = equivClasses cmpLocated $
726 freeKiTyVarsAllVars pat_kity_vars_with_dups
727 ; tv_nms_dups <- mapM (lookupOccRn . unLoc) $
728 [ tv | (tv :| (_:_)) <- groups ]
729 -- Add to the used variables
730 -- a) any variables that appear *more than once* on the LHS
731 -- e.g. F a Int a = Bool
732 -- b) for associated instances, the variables
733 -- of the instance decl. See
734 -- Note [Unused type variables in family instances]
735 ; let tv_nms_used = extendNameSetList rhs_fvs $
736 inst_tvs ++ tv_nms_dups
737 inst_tvs = case mb_cls of
738 Nothing -> []
739 Just (_, inst_tvs) -> inst_tvs
740 ; warnUnusedTypePatterns pat_var_names tv_nms_used
741
742 -- See Note [Renaming associated types]
743 ; let bad_tvs = case mb_cls of
744 Nothing -> []
745 Just (_,cls_tkvs) -> filter is_bad cls_tkvs
746 var_name_set = mkNameSet all_var_names
747
748 is_bad cls_tkv = cls_tkv `elemNameSet` rhs_fvs
749 && not (cls_tkv `elemNameSet` var_name_set)
750 ; unless (null bad_tvs) (badAssocRhs bad_tvs)
751
752 ; return ((pats', payload'), rhs_fvs `plusFV` pat_fvs) }
753
754 ; let anon_wcs = concatMap collectAnonWildCards pats'
755 all_ibs = anon_wcs ++ all_var_names
756 -- all_ibs: include anonymous wildcards in the implicit
757 -- binders In a type pattern they behave just like any
758 -- other type variable except for being anoymous. See
759 -- Note [Wildcards in family instances]
760 all_fvs = fvs `addOneFV` unLoc tycon'
761 -- type instance => use, hence addOneFV
762
763 ; return (HsIB { hsib_vars = all_ibs
764 , hsib_closed = True
765 , hsib_body
766 = FamEqn { feqn_tycon = tycon'
767 , feqn_pats = pats'
768 , feqn_fixity = fixity
769 , feqn_rhs = payload' } },
770 all_fvs) }
771
772 rnTyFamInstDecl :: Maybe (Name, [Name])
773 -> TyFamInstDecl GhcPs
774 -> RnM (TyFamInstDecl GhcRn, FreeVars)
775 rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = eqn })
776 = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn
777 ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) }
778
779 rnTyFamInstEqn :: Maybe (Name, [Name])
780 -> TyFamInstEqn GhcPs
781 -> RnM (TyFamInstEqn GhcRn, FreeVars)
782 rnTyFamInstEqn mb_cls eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon
783 , feqn_rhs = rhs }})
784 = do { rhs_kvs <- extractHsTyRdrTyVarsKindVars rhs
785 ; rnFamInstEqn (TySynCtx tycon) mb_cls rhs_kvs eqn rnTySyn }
786
787 rnTyFamDefltEqn :: Name
788 -> TyFamDefltEqn GhcPs
789 -> RnM (TyFamDefltEqn GhcRn, FreeVars)
790 rnTyFamDefltEqn cls (FamEqn { feqn_tycon = tycon
791 , feqn_pats = tyvars
792 , feqn_fixity = fixity
793 , feqn_rhs = rhs })
794 = do { kvs <- extractHsTyRdrTyVarsKindVars rhs
795 ; bindHsQTyVars ctx Nothing (Just cls) kvs tyvars $ \ tyvars' _ ->
796 do { tycon' <- lookupFamInstName (Just cls) tycon
797 ; (rhs', fvs) <- rnLHsType ctx rhs
798 ; return (FamEqn { feqn_tycon = tycon'
799 , feqn_pats = tyvars'
800 , feqn_fixity = fixity
801 , feqn_rhs = rhs' }, fvs) } }
802 where
803 ctx = TyFamilyCtx tycon
804
805 rnDataFamInstDecl :: Maybe (Name, [Name])
806 -> DataFamInstDecl GhcPs
807 -> RnM (DataFamInstDecl GhcRn, FreeVars)
808 rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =
809 FamEqn { feqn_tycon = tycon
810 , feqn_rhs = rhs }})})
811 = do { rhs_kvs <- extractDataDefnKindVars rhs
812 ; (eqn', fvs) <-
813 rnFamInstEqn (TyDataCtx tycon) mb_cls rhs_kvs eqn rnDataDefn
814 ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }
815
816 -- Renaming of the associated types in instances.
817
818 -- Rename associated type family decl in class
819 rnATDecls :: Name -- Class
820 -> [LFamilyDecl GhcPs]
821 -> RnM ([LFamilyDecl GhcRn], FreeVars)
822 rnATDecls cls at_decls
823 = rnList (rnFamDecl (Just cls)) at_decls
824
825 rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames
826 decl GhcPs -> -- an instance. rnTyFamInstDecl
827 RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl
828 -> Name -- Class
829 -> [Name]
830 -> [Located (decl GhcPs)]
831 -> RnM ([Located (decl GhcRn)], FreeVars)
832 -- Used for data and type family defaults in a class decl
833 -- and the family instance declarations in an instance
834 --
835 -- NB: We allow duplicate associated-type decls;
836 -- See Note [Associated type instances] in TcInstDcls
837 rnATInstDecls rnFun cls tv_ns at_insts
838 = rnList (rnFun (Just (cls, tv_ns))) at_insts
839 -- See Note [Renaming associated types]
840
841 {- Note [Wildcards in family instances]
842 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
843 Wild cards can be used in type/data family instance declarations to indicate
844 that the name of a type variable doesn't matter. Each wild card will be
845 replaced with a new unique type variable. For instance:
846
847 type family F a b :: *
848 type instance F Int _ = Int
849
850 is the same as
851
852 type family F a b :: *
853 type instance F Int b = Int
854
855 This is implemented as follows: during renaming anonymous wild cards
856 '_' are given freshly generated names. These names are collected after
857 renaming (rnFamInstEqn) and used to make new type variables during
858 type checking (tc_fam_ty_pats). One should not confuse these wild
859 cards with the ones from partial type signatures. The latter generate
860 fresh meta-variables whereas the former generate fresh skolems.
861
862 Note [Unused type variables in family instances]
863 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
864 When the flag -fwarn-unused-type-patterns is on, the compiler reports
865 warnings about unused type variables in type-family instances. A
866 tpye variable is considered used (i.e. cannot be turned into a wildcard)
867 when
868
869 * it occurs on the RHS of the family instance
870 e.g. type instance F a b = a -- a is used on the RHS
871
872 * it occurs multiple times in the patterns on the LHS
873 e.g. type instance F a a = Int -- a appears more than once on LHS
874
875 * it is one of the instance-decl variables, for associated types
876 e.g. instance C (a,b) where
877 type T (a,b) = a
878 Here the type pattern in the type instance must be the same as that
879 for the class instance, so
880 type T (a,_) = a
881 would be rejected. So we should not complain about an unused variable b
882
883 As usual, the warnings are not reported for type variables with names
884 beginning with an underscore.
885
886 Extra-constraints wild cards are not supported in type/data family
887 instance declarations.
888
889 Relevant tickets: #3699, #10586, #10982 and #11451.
890
891 Note [Renaming associated types]
892 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
893 Check that the RHS of the decl mentions only type variables that are explicitly
894 bound on the LHS. For example, this is not ok
895 class C a b where
896 type F a x :: *
897 instance C (p,q) r where
898 type F (p,q) x = (x, r) -- BAD: mentions 'r'
899 c.f. Trac #5515
900
901 Kind variables, on the other hand, are allowed to be implicitly or explicitly
902 bound. As examples, this (#9574) is acceptable:
903 class Funct f where
904 type Codomain f :: *
905 instance Funct ('KProxy :: KProxy o) where
906 -- o is implicitly bound by the kind signature
907 -- of the LHS type pattern ('KProxy)
908 type Codomain 'KProxy = NatTr (Proxy :: o -> *)
909 And this (#14131) is also acceptable:
910 data family Nat :: k -> k -> *
911 -- k is implicitly bound by an invisible kind pattern
912 newtype instance Nat :: (k -> *) -> (k -> *) -> * where
913 Nat :: (forall xx. f xx -> g xx) -> Nat f g
914 We could choose to disallow this, but then associated type families would not
915 be able to be as expressive as top-level type synonyms. For example, this type
916 synonym definition is allowed:
917 type T = (Nothing :: Maybe a)
918 So for parity with type synonyms, we also allow:
919 type family T :: Maybe a
920 type instance T = (Nothing :: Maybe a)
921
922 All this applies only for *instance* declarations. In *class*
923 declarations there is no RHS to worry about, and the class variables
924 can all be in scope (Trac #5862):
925 class Category (x :: k -> k -> *) where
926 type Ob x :: k -> Constraint
927 id :: Ob x a => x a a
928 (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c
929 Here 'k' is in scope in the kind signature, just like 'x'.
930 -}
931
932
933 {-
934 *********************************************************
935 * *
936 \subsection{Stand-alone deriving declarations}
937 * *
938 *********************************************************
939 -}
940
941 rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)
942 rnSrcDerivDecl (DerivDecl ty deriv_strat overlap)
943 = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving
944 ; deriv_strats_ok <- xoptM LangExt.DerivingStrategies
945 ; unless standalone_deriv_ok (addErr standaloneDerivErr)
946 ; failIfTc (isJust deriv_strat && not deriv_strats_ok) $
947 illegalDerivStrategyErr $ fmap unLoc deriv_strat
948 ; (ty', fvs) <- rnLHsInstType (text "a deriving declaration") ty
949 ; return (DerivDecl ty' deriv_strat overlap, fvs) }
950
951 standaloneDerivErr :: SDoc
952 standaloneDerivErr
953 = hang (text "Illegal standalone deriving declaration")
954 2 (text "Use StandaloneDeriving to enable this extension")
955
956 {-
957 *********************************************************
958 * *
959 \subsection{Rules}
960 * *
961 *********************************************************
962 -}
963
964 rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)
965 rnHsRuleDecls (HsRules src rules)
966 = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules
967 ; return (HsRules src rn_rules,fvs) }
968
969 rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)
970 rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs)
971 = do { let rdr_names_w_loc = map get_var vars
972 ; checkDupRdrNames rdr_names_w_loc
973 ; checkShadowedRdrNames rdr_names_w_loc
974 ; names <- newLocalBndrsRn rdr_names_w_loc
975 ; bindHsRuleVars (snd $ unLoc rule_name) vars names $ \ vars' ->
976 do { (lhs', fv_lhs') <- rnLExpr lhs
977 ; (rhs', fv_rhs') <- rnLExpr rhs
978 ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'
979 ; return (HsRule rule_name act vars' lhs' fv_lhs' rhs' fv_rhs',
980 fv_lhs' `plusFV` fv_rhs') } }
981 where
982 get_var (L _ (RuleBndrSig v _)) = v
983 get_var (L _ (RuleBndr v)) = v
984
985 bindHsRuleVars :: RuleName -> [LRuleBndr GhcPs] -> [Name]
986 -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))
987 -> RnM (a, FreeVars)
988 bindHsRuleVars rule_name vars names thing_inside
989 = go vars names $ \ vars' ->
990 bindLocalNamesFV names (thing_inside vars')
991 where
992 doc = RuleCtx rule_name
993
994 go (L l (RuleBndr (L loc _)) : vars) (n : ns) thing_inside
995 = go vars ns $ \ vars' ->
996 thing_inside (L l (RuleBndr (L loc n)) : vars')
997
998 go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside
999 = rnHsSigWcTypeScoped doc bsig $ \ bsig' ->
1000 go vars ns $ \ vars' ->
1001 thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars')
1002
1003 go [] [] thing_inside = thing_inside []
1004 go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)
1005
1006 {-
1007 Note [Rule LHS validity checking]
1008 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1009 Check the shape of a transformation rule LHS. Currently we only allow
1010 LHSs of the form @(f e1 .. en)@, where @f@ is not one of the
1011 @forall@'d variables.
1012
1013 We used restrict the form of the 'ei' to prevent you writing rules
1014 with LHSs with a complicated desugaring (and hence unlikely to match);
1015 (e.g. a case expression is not allowed: too elaborate.)
1016
1017 But there are legitimate non-trivial args ei, like sections and
1018 lambdas. So it seems simmpler not to check at all, and that is why
1019 check_e is commented out.
1020 -}
1021
1022 checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM ()
1023 checkValidRule rule_name ids lhs' fv_lhs'
1024 = do { -- Check for the form of the LHS
1025 case (validRuleLhs ids lhs') of
1026 Nothing -> return ()
1027 Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)
1028
1029 -- Check that LHS vars are all bound
1030 ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]
1031 ; mapM_ (addErr . badRuleVar rule_name) bad_vars }
1032
1033 validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn)
1034 -- Nothing => OK
1035 -- Just e => Not ok, and e is the offending sub-expression
1036 validRuleLhs foralls lhs
1037 = checkl lhs
1038 where
1039 checkl (L _ e) = check e
1040
1041 check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2
1042 check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2
1043 check (HsAppType e _) = checkl e
1044 check (HsVar (L _ v)) | v `notElem` foralls = Nothing
1045 check other = Just other -- Failure
1046
1047 -- Check an argument
1048 checkl_e (L _ _e) = Nothing -- Was (check_e e); see Note [Rule LHS validity checking]
1049
1050 {- Commented out; see Note [Rule LHS validity checking] above
1051 check_e (HsVar v) = Nothing
1052 check_e (HsPar e) = checkl_e e
1053 check_e (HsLit e) = Nothing
1054 check_e (HsOverLit e) = Nothing
1055
1056 check_e (OpApp e1 op _ e2) = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2
1057 check_e (HsApp e1 e2) = checkl_e e1 `mplus` checkl_e e2
1058 check_e (NegApp e _) = checkl_e e
1059 check_e (ExplicitList _ es) = checkl_es es
1060 check_e other = Just other -- Fails
1061
1062 checkl_es es = foldr (mplus . checkl_e) Nothing es
1063 -}
1064
1065 badRuleVar :: FastString -> Name -> SDoc
1066 badRuleVar name var
1067 = sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,
1068 text "Forall'd variable" <+> quotes (ppr var) <+>
1069 text "does not appear on left hand side"]
1070
1071 badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc
1072 badRuleLhsErr name lhs bad_e
1073 = sep [text "Rule" <+> pprRuleName name <> colon,
1074 nest 4 (vcat [err,
1075 text "in left-hand side:" <+> ppr lhs])]
1076 $$
1077 text "LHS must be of form (f e1 .. en) where f is not forall'd"
1078 where
1079 err = case bad_e of
1080 HsUnboundVar uv -> text "Not in scope:" <+> ppr uv
1081 _ -> text "Illegal expression:" <+> ppr bad_e
1082
1083 {-
1084 *********************************************************
1085 * *
1086 \subsection{Vectorisation declarations}
1087 * *
1088 *********************************************************
1089 -}
1090
1091 rnHsVectDecl :: VectDecl GhcPs -> RnM (VectDecl GhcRn, FreeVars)
1092 -- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly
1093 -- typecheck a complex right-hand side without invoking 'vectType' from the vectoriser.
1094 rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _)))
1095 = do { var' <- lookupLocatedOccRn var
1096 ; (rhs', fv_rhs) <- rnLExpr rhs
1097 ; return (HsVect s var' rhs', fv_rhs `addOneFV` unLoc var')
1098 }
1099 rnHsVectDecl (HsVect _ _var _rhs)
1100 = failWith $ vcat
1101 [ text "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma"
1102 , text "must be an identifier"
1103 ]
1104 rnHsVectDecl (HsNoVect s var)
1105 = do { var' <- lookupLocatedTopBndrRn var -- only applies to local (not imported) names
1106 ; return (HsNoVect s var', unitFV (unLoc var'))
1107 }
1108 rnHsVectDecl (HsVectTypeIn s isScalar tycon Nothing)
1109 = do { tycon' <- lookupLocatedOccRn tycon
1110 ; return (HsVectTypeIn s isScalar tycon' Nothing, unitFV (unLoc tycon'))
1111 }
1112 rnHsVectDecl (HsVectTypeIn s isScalar tycon (Just rhs_tycon))
1113 = do { tycon' <- lookupLocatedOccRn tycon
1114 ; rhs_tycon' <- lookupLocatedOccRn rhs_tycon
1115 ; return ( HsVectTypeIn s isScalar tycon' (Just rhs_tycon')
1116 , mkFVs [unLoc tycon', unLoc rhs_tycon'])
1117 }
1118 rnHsVectDecl (HsVectTypeOut _ _ _)
1119 = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"
1120 rnHsVectDecl (HsVectClassIn s cls)
1121 = do { cls' <- lookupLocatedOccRn cls
1122 ; return (HsVectClassIn s cls', unitFV (unLoc cls'))
1123 }
1124 rnHsVectDecl (HsVectClassOut _)
1125 = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
1126 rnHsVectDecl (HsVectInstIn instTy)
1127 = do { (instTy', fvs) <- rnLHsInstType (text "a VECTORISE pragma") instTy
1128 ; return (HsVectInstIn instTy', fvs)
1129 }
1130 rnHsVectDecl (HsVectInstOut _)
1131 = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
1132
1133 {- **************************************************************
1134 * *
1135 Renaming type, class, instance and role declarations
1136 * *
1137 *****************************************************************
1138
1139 @rnTyDecl@ uses the `global name function' to create a new type
1140 declaration in which local names have been replaced by their original
1141 names, reporting any unknown names.
1142
1143 Renaming type variables is a pain. Because they now contain uniques,
1144 it is necessary to pass in an association list which maps a parsed
1145 tyvar to its @Name@ representation.
1146 In some cases (type signatures of values),
1147 it is even necessary to go over the type first
1148 in order to get the set of tyvars used by it, make an assoc list,
1149 and then go over it again to rename the tyvars!
1150 However, we can also do some scoping checks at the same time.
1151
1152 Note [Dependency analysis of type, class, and instance decls]
1153 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1154 A TyClGroup represents a strongly connected components of
1155 type/class/instance decls, together with the role annotations for the
1156 type/class declarations. The renamer uses strongly connected
1157 comoponent analysis to build these groups. We do this for a number of
1158 reasons:
1159
1160 * Improve kind error messages. Consider
1161
1162 data T f a = MkT f a
1163 data S f a = MkS f (T f a)
1164
1165 This has a kind error, but the error message is better if you
1166 check T first, (fixing its kind) and *then* S. If you do kind
1167 inference together, you might get an error reported in S, which
1168 is jolly confusing. See Trac #4875
1169
1170
1171 * Increase kind polymorphism. See TcTyClsDecls
1172 Note [Grouping of type and class declarations]
1173
1174 Why do the instance declarations participate? At least two reasons
1175
1176 * Consider (Trac #11348)
1177
1178 type family F a
1179 type instance F Int = Bool
1180
1181 data R = MkR (F Int)
1182
1183 type Foo = 'MkR 'True
1184
1185 For Foo to kind-check we need to know that (F Int) ~ Bool. But we won't
1186 know that unless we've looked at the type instance declaration for F
1187 before kind-checking Foo.
1188
1189 * Another example is this (Trac #3990).
1190
1191 data family Complex a
1192 data instance Complex Double = CD {-# UNPACK #-} !Double
1193 {-# UNPACK #-} !Double
1194
1195 data T = T {-# UNPACK #-} !(Complex Double)
1196
1197 Here, to generate the right kind of unpacked implementation for T,
1198 we must have access to the 'data instance' declaration.
1199
1200 * Things become more complicated when we introduce transitive
1201 dependencies through imported definitions, like in this scenario:
1202
1203 A.hs
1204 type family Closed (t :: Type) :: Type where
1205 Closed t = Open t
1206
1207 type family Open (t :: Type) :: Type
1208
1209 B.hs
1210 data Q where
1211 Q :: Closed Bool -> Q
1212
1213 type instance Open Int = Bool
1214
1215 type S = 'Q 'True
1216
1217 Somehow, we must ensure that the instance Open Int = Bool is checked before
1218 the type synonym S. While we know that S depends upon 'Q depends upon Closed,
1219 we have no idea that Closed depends upon Open!
1220
1221 To accomodate for these situations, we ensure that an instance is checked
1222 before every @TyClDecl@ on which it does not depend. That's to say, instances
1223 are checked as early as possible in @tcTyAndClassDecls@.
1224
1225 ------------------------------------
1226 So much for WHY. What about HOW? It's pretty easy:
1227
1228 (1) Rename the type/class, instance, and role declarations
1229 individually
1230
1231 (2) Do strongly-connected component analysis of the type/class decls,
1232 We'll make a TyClGroup for each SCC
1233
1234 In this step we treat a reference to a (promoted) data constructor
1235 K as a dependency on its parent type. Thus
1236 data T = K1 | K2
1237 data S = MkS (Proxy 'K1)
1238 Here S depends on 'K1 and hence on its parent T.
1239
1240 In this step we ignore instances; see
1241 Note [No dependencies on data instances]
1242
1243 (3) Attach roles to the appropriate SCC
1244
1245 (4) Attach instances to the appropriate SCC.
1246 We add an instance decl to SCC when:
1247 all its free types/classes are bound in this SCC or earlier ones
1248
1249 (5) We make an initial TyClGroup, with empty group_tyclds, for any
1250 (orphan) instances that affect only imported types/classes
1251
1252 Steps (3) and (4) are done by the (mapAccumL mk_group) call.
1253
1254 Note [No dependencies on data instances]
1255 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1256 Consider this
1257 data family D a
1258 data instance D Int = D1
1259 data S = MkS (Proxy 'D1)
1260
1261 Here the declaration of S depends on the /data instance/ declaration
1262 for 'D Int'. That makes things a lot more complicated, especially
1263 if the data instance is an associated type of an enclosing class instance.
1264 (And the class instance might have several associated type instances
1265 with different dependency structure!)
1266
1267 Ugh. For now we simply don't allow promotion of data constructors for
1268 data instances. See Note [AFamDataCon: not promoting data family
1269 constructors] in TcEnv
1270 -}
1271
1272
1273 rnTyClDecls :: [TyClGroup GhcPs]
1274 -> RnM ([TyClGroup GhcRn], FreeVars)
1275 -- Rename the declarations and do dependency analysis on them
1276 rnTyClDecls tycl_ds
1277 = do { -- Rename the type/class, instance, and role declaraations
1278 tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl)
1279 (tyClGroupTyClDecls tycl_ds)
1280 ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs)
1281
1282 ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)
1283 ; role_annots <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)
1284
1285 -- Do SCC analysis on the type/class decls
1286 ; rdr_env <- getGlobalRdrEnv
1287 ; let tycl_sccs = depAnalTyClDecls rdr_env tycls_w_fvs
1288 role_annot_env = mkRoleAnnotEnv role_annots
1289
1290 inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs
1291 (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map
1292
1293 first_group
1294 | null init_inst_ds = []
1295 | otherwise = [TyClGroup { group_tyclds = []
1296 , group_roles = []
1297 , group_instds = init_inst_ds }]
1298
1299 ((final_inst_ds, orphan_roles), groups)
1300 = mapAccumL mk_group (rest_inst_ds, role_annot_env) tycl_sccs
1301
1302
1303 all_fvs = plusFV (foldr (plusFV . snd) emptyFVs tycls_w_fvs)
1304 (foldr (plusFV . snd) emptyFVs instds_w_fvs)
1305
1306 all_groups = first_group ++ groups
1307
1308 ; ASSERT2( null final_inst_ds, ppr instds_w_fvs $$ ppr inst_ds_map
1309 $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds )
1310 mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles)
1311
1312 ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)
1313 ; return (all_groups, all_fvs) }
1314 where
1315 mk_group :: (InstDeclFreeVarsMap, RoleAnnotEnv)
1316 -> SCC (LTyClDecl GhcRn)
1317 -> ( (InstDeclFreeVarsMap, RoleAnnotEnv)
1318 , TyClGroup GhcRn )
1319 mk_group (inst_map, role_env) scc
1320 = ((inst_map', role_env'), group)
1321 where
1322 tycl_ds = flattenSCC scc
1323 bndrs = map (tcdName . unLoc) tycl_ds
1324 (inst_ds, inst_map') = getInsts bndrs inst_map
1325 (roles, role_env') = getRoleAnnots bndrs role_env
1326 group = TyClGroup { group_tyclds = tycl_ds
1327 , group_roles = roles
1328 , group_instds = inst_ds }
1329
1330
1331 depAnalTyClDecls :: GlobalRdrEnv
1332 -> [(LTyClDecl GhcRn, FreeVars)]
1333 -> [SCC (LTyClDecl GhcRn)]
1334 -- See Note [Dependency analysis of type, class, and instance decls]
1335 depAnalTyClDecls rdr_env ds_w_fvs
1336 = stronglyConnCompFromEdgedVerticesUniq edges
1337 where
1338 edges :: [ Node Name (LTyClDecl GhcRn) ]
1339 edges = [ DigraphNode d (tcdName (unLoc d)) (map (getParent rdr_env) (nonDetEltsUniqSet fvs))
1340 | (d, fvs) <- ds_w_fvs ]
1341 -- It's OK to use nonDetEltsUFM here as
1342 -- stronglyConnCompFromEdgedVertices is still deterministic
1343 -- even if the edges are in nondeterministic order as explained
1344 -- in Note [Deterministic SCC] in Digraph.
1345
1346 toParents :: GlobalRdrEnv -> NameSet -> NameSet
1347 toParents rdr_env ns
1348 = nonDetFoldUniqSet add emptyNameSet ns
1349 -- It's OK to use nonDetFoldUFM because we immediately forget the
1350 -- ordering by creating a set
1351 where
1352 add n s = extendNameSet s (getParent rdr_env n)
1353
1354 getParent :: GlobalRdrEnv -> Name -> Name
1355 getParent rdr_env n
1356 = case lookupGRE_Name rdr_env n of
1357 Just gre -> case gre_par gre of
1358 ParentIs { par_is = p } -> p
1359 FldParent { par_is = p } -> p
1360 _ -> n
1361 Nothing -> n
1362
1363
1364 {- ******************************************************
1365 * *
1366 Role annotations
1367 * *
1368 ****************************************************** -}
1369
1370 -- | Renames role annotations, returning them as the values in a NameEnv
1371 -- and checks for duplicate role annotations.
1372 -- It is quite convenient to do both of these in the same place.
1373 -- See also Note [Role annotations in the renamer]
1374 rnRoleAnnots :: NameSet
1375 -> [LRoleAnnotDecl GhcPs]
1376 -> RnM [LRoleAnnotDecl GhcRn]
1377 rnRoleAnnots tc_names role_annots
1378 = do { -- Check for duplicates *before* renaming, to avoid
1379 -- lumping together all the unboundNames
1380 let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots
1381 role_annots_cmp (L _ annot1) (L _ annot2)
1382 = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2
1383 ; mapM_ dupRoleAnnotErr dup_annots
1384 ; mapM (wrapLocM rn_role_annot1) no_dups }
1385 where
1386 rn_role_annot1 (RoleAnnotDecl tycon roles)
1387 = do { -- the name is an *occurrence*, but look it up only in the
1388 -- decls defined in this group (see #10263)
1389 tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names)
1390 (text "role annotation")
1391 tycon
1392 ; return $ RoleAnnotDecl tycon' roles }
1393
1394 dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()
1395 dupRoleAnnotErr list
1396 = addErrAt loc $
1397 hang (text "Duplicate role annotations for" <+>
1398 quotes (ppr $ roleAnnotDeclName first_decl) <> colon)
1399 2 (vcat $ map pp_role_annot $ NE.toList sorted_list)
1400 where
1401 sorted_list = NE.sortBy cmp_annot list
1402 (L loc first_decl :| _) = sorted_list
1403
1404 pp_role_annot (L loc decl) = hang (ppr decl)
1405 4 (text "-- written at" <+> ppr loc)
1406
1407 cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2
1408
1409 orphanRoleAnnotErr :: LRoleAnnotDecl GhcRn -> RnM ()
1410 orphanRoleAnnotErr (L loc decl)
1411 = addErrAt loc $
1412 hang (text "Role annotation for a type previously declared:")
1413 2 (ppr decl) $$
1414 parens (text "The role annotation must be given where" <+>
1415 quotes (ppr $ roleAnnotDeclName decl) <+>
1416 text "is declared.")
1417
1418
1419 {- Note [Role annotations in the renamer]
1420 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1421 We must ensure that a type's role annotation is put in the same group as the
1422 proper type declaration. This is because role annotations are needed during
1423 type-checking when creating the type's TyCon. So, rnRoleAnnots builds a
1424 NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that
1425 type, if any. Then, this map can be used to add the role annotations to the
1426 groups after dependency analysis.
1427
1428 This process checks for duplicate role annotations, where we must be careful
1429 to do the check *before* renaming to avoid calling all unbound names duplicates
1430 of one another.
1431
1432 The renaming process, as usual, might identify and report errors for unbound
1433 names. We exclude the annotations for unbound names in the annotation
1434 environment to avoid spurious errors for orphaned annotations.
1435
1436 We then (in rnTyClDecls) do a check for orphan role annotations (role
1437 annotations without an accompanying type decl). The check works by folding
1438 over components (of type [[Either (TyClDecl Name) (InstDecl Name)]]), selecting
1439 out the relevant role declarations for each group, as well as diminishing the
1440 annotation environment. After the fold is complete, anything left over in the
1441 name environment must be an orphan, and errors are generated.
1442
1443 An earlier version of this algorithm short-cut the orphan check by renaming
1444 only with names declared in this module. But, this check is insufficient in
1445 the case of staged module compilation (Template Haskell, GHCi).
1446 See #8485. With the new lookup process (which includes types declared in other
1447 modules), we get better error messages, too.
1448 -}
1449
1450
1451 {- ******************************************************
1452 * *
1453 Dependency info for instances
1454 * *
1455 ****************************************************** -}
1456
1457 ----------------------------------------------------------
1458 -- | 'InstDeclFreeVarsMap is an association of an
1459 -- @InstDecl@ with @FreeVars@. The @FreeVars@ are
1460 -- the tycon names that are both
1461 -- a) free in the instance declaration
1462 -- b) bound by this group of type/class/instance decls
1463 type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)]
1464
1465 -- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the
1466 -- @FreeVars@ which are *not* the binders of a @TyClDecl@.
1467 mkInstDeclFreeVarsMap :: GlobalRdrEnv
1468 -> NameSet
1469 -> [(LInstDecl GhcRn, FreeVars)]
1470 -> InstDeclFreeVarsMap
1471 mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs
1472 = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs)
1473 | (inst_decl, fvs) <- inst_ds_fvs ]
1474
1475 -- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the
1476 -- @InstDeclFreeVarsMap@ with these entries removed.
1477 -- We call (getInsts tcs instd_map) when we've completed the declarations
1478 -- for 'tcs'. The call returns (inst_decls, instd_map'), where
1479 -- inst_decls are the instance declarations all of
1480 -- whose free vars are now defined
1481 -- instd_map' is the inst-decl map with 'tcs' removed from
1482 -- the free-var set
1483 getInsts :: [Name] -> InstDeclFreeVarsMap
1484 -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)
1485 getInsts bndrs inst_decl_map
1486 = partitionWith pick_me inst_decl_map
1487 where
1488 pick_me :: (LInstDecl GhcRn, FreeVars)
1489 -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars)
1490 pick_me (decl, fvs)
1491 | isEmptyNameSet depleted_fvs = Left decl
1492 | otherwise = Right (decl, depleted_fvs)
1493 where
1494 depleted_fvs = delFVs bndrs fvs
1495
1496 {- ******************************************************
1497 * *
1498 Renaming a type or class declaration
1499 * *
1500 ****************************************************** -}
1501
1502 rnTyClDecl :: TyClDecl GhcPs
1503 -> RnM (TyClDecl GhcRn, FreeVars)
1504
1505 -- All flavours of type family declarations ("type family", "newtype family",
1506 -- and "data family"), both top level and (for an associated type)
1507 -- in a class decl
1508 rnTyClDecl (FamDecl { tcdFam = decl })
1509 = do { (decl', fvs) <- rnFamDecl Nothing decl
1510 ; return (FamDecl decl', fvs) }
1511
1512 rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,
1513 tcdFixity = fixity, tcdRhs = rhs })
1514 = do { tycon' <- lookupLocatedTopBndrRn tycon
1515 ; kvs <- extractHsTyRdrTyVarsKindVars rhs
1516 ; let doc = TySynCtx tycon
1517 ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)
1518 ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' _ ->
1519 do { (rhs', fvs) <- rnTySyn doc rhs
1520 ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'
1521 , tcdFixity = fixity
1522 , tcdRhs = rhs', tcdFVs = fvs }, fvs) } }
1523
1524 -- "data", "newtype" declarations
1525 -- both top level and (for an associated type) in an instance decl
1526 rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars,
1527 tcdFixity = fixity, tcdDataDefn = defn })
1528 = do { tycon' <- lookupLocatedTopBndrRn tycon
1529 ; kvs <- extractDataDefnKindVars defn
1530 ; let doc = TyDataCtx tycon
1531 ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)
1532 ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->
1533 do { (defn', fvs) <- rnDataDefn doc defn
1534 -- See Note [Complete user-supplied kind signatures] in HsDecls
1535 ; typeintype <- xoptM LangExt.TypeInType
1536 ; let cusk = hsTvbAllKinded tyvars' &&
1537 (not typeintype || no_rhs_kvs)
1538 ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)
1539 ; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
1540 , tcdFixity = fixity
1541 , tcdDataDefn = defn', tcdDataCusk = cusk
1542 , tcdFVs = fvs }, fvs) } }
1543
1544 rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
1545 tcdTyVars = tyvars, tcdFixity = fixity,
1546 tcdFDs = fds, tcdSigs = sigs,
1547 tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
1548 tcdDocs = docs})
1549 = do { lcls' <- lookupLocatedTopBndrRn lcls
1550 ; let cls' = unLoc lcls'
1551 kvs = [] -- No scoped kind vars except those in
1552 -- kind signatures on the tyvars
1553
1554 -- Tyvars scope over superclass context and method signatures
1555 ; ((tyvars', context', fds', ats'), stuff_fvs)
1556 <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do
1557 -- Checks for distinct tyvars
1558 { (context', cxt_fvs) <- rnContext cls_doc context
1559 ; fds' <- rnFds fds
1560 -- The fundeps have no free variables
1561 ; (ats', fv_ats) <- rnATDecls cls' ats
1562 ; let fvs = cxt_fvs `plusFV`
1563 fv_ats
1564 ; return ((tyvars', context', fds', ats'), fvs) }
1565
1566 ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltEqn cls') at_defs
1567
1568 -- No need to check for duplicate associated type decls
1569 -- since that is done by RnNames.extendGlobalRdrEnvRn
1570
1571 -- Check the signatures
1572 -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
1573 ; let sig_rdr_names_w_locs = [op | L _ (ClassOpSig False ops _) <- sigs
1574 , op <- ops]
1575 ; checkDupRdrNames sig_rdr_names_w_locs
1576 -- Typechecker is responsible for checking that we only
1577 -- give default-method bindings for things in this class.
1578 -- The renamer *could* check this for class decls, but can't
1579 -- for instance decls.
1580
1581 -- The newLocals call is tiresome: given a generic class decl
1582 -- class C a where
1583 -- op :: a -> a
1584 -- op {| x+y |} (Inl a) = ...
1585 -- op {| x+y |} (Inr b) = ...
1586 -- op {| a*b |} (a*b) = ...
1587 -- we want to name both "x" tyvars with the same unique, so that they are
1588 -- easy to group together in the typechecker.
1589 ; (mbinds', sigs', meth_fvs)
1590 <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs
1591 -- No need to check for duplicate method signatures
1592 -- since that is done by RnNames.extendGlobalRdrEnvRn
1593 -- and the methods are already in scope
1594
1595 -- Haddock docs
1596 ; docs' <- mapM (wrapLocM rnDocDecl) docs
1597
1598 ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs
1599 ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',
1600 tcdTyVars = tyvars', tcdFixity = fixity,
1601 tcdFDs = fds', tcdSigs = sigs',
1602 tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',
1603 tcdDocs = docs', tcdFVs = all_fvs },
1604 all_fvs ) }
1605 where
1606 cls_doc = ClassDeclCtx lcls
1607
1608 -- "type" and "type instance" declarations
1609 rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
1610 rnTySyn doc rhs = rnLHsType doc rhs
1611
1612 rnDataDefn :: HsDocContext -> HsDataDefn GhcPs
1613 -> RnM (HsDataDefn GhcRn, FreeVars)
1614 rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1615 , dd_ctxt = context, dd_cons = condecls
1616 , dd_kindSig = m_sig, dd_derivs = derivs })
1617 = do { checkTc (h98_style || null (unLoc context))
1618 (badGadtStupidTheta doc)
1619
1620 ; (m_sig', sig_fvs) <- case m_sig of
1621 Just sig -> first Just <$> rnLHsKind doc sig
1622 Nothing -> return (Nothing, emptyFVs)
1623 ; (context', fvs1) <- rnContext doc context
1624 ; (derivs', fvs3) <- rn_derivs derivs
1625
1626 -- For the constructor declarations, drop the LocalRdrEnv
1627 -- in the GADT case, where the type variables in the declaration
1628 -- do not scope over the constructor signatures
1629 -- data T a where { T1 :: forall b. b-> b }
1630 ; let { zap_lcl_env | h98_style = \ thing -> thing
1631 | otherwise = setLocalRdrEnv emptyLocalRdrEnv }
1632 ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls
1633 -- No need to check for duplicate constructor decls
1634 -- since that is done by RnNames.extendGlobalRdrEnvRn
1635
1636 ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`
1637 con_fvs `plusFV` sig_fvs
1638 ; return ( HsDataDefn { dd_ND = new_or_data, dd_cType = cType
1639 , dd_ctxt = context', dd_kindSig = m_sig'
1640 , dd_cons = condecls'
1641 , dd_derivs = derivs' }
1642 , all_fvs )
1643 }
1644 where
1645 h98_style = case condecls of -- Note [Stupid theta]
1646 L _ (ConDeclGADT {}) : _ -> False
1647 _ -> True
1648
1649 rn_derivs (L loc ds)
1650 = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies
1651 ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok)
1652 multipleDerivClausesErr
1653 ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause deriv_strats_ok doc) ds
1654 ; return (L loc ds', fvs) }
1655
1656 rnLHsDerivingClause :: Bool -> HsDocContext -> LHsDerivingClause GhcPs
1657 -> RnM (LHsDerivingClause GhcRn, FreeVars)
1658 rnLHsDerivingClause deriv_strats_ok doc
1659 (L loc (HsDerivingClause { deriv_clause_strategy = dcs
1660 , deriv_clause_tys = L loc' dct }))
1661 = do { failIfTc (isJust dcs && not deriv_strats_ok) $
1662 illegalDerivStrategyErr $ fmap unLoc dcs
1663 ; (dct', fvs) <- mapFvRn (rnHsSigType doc) dct
1664 ; return ( L loc (HsDerivingClause { deriv_clause_strategy = dcs
1665 , deriv_clause_tys = L loc' dct' })
1666 , fvs ) }
1667
1668 badGadtStupidTheta :: HsDocContext -> SDoc
1669 badGadtStupidTheta _
1670 = vcat [text "No context is allowed on a GADT-style data declaration",
1671 text "(You can put a context on each constructor, though.)"]
1672
1673 illegalDerivStrategyErr :: Maybe DerivStrategy -> SDoc
1674 illegalDerivStrategyErr ds
1675 = vcat [ text "Illegal deriving strategy" <> colon <+> maybe empty ppr ds
1676 , text "Use DerivingStrategies to enable this extension" ]
1677
1678 multipleDerivClausesErr :: SDoc
1679 multipleDerivClausesErr
1680 = vcat [ text "Illegal use of multiple, consecutive deriving clauses"
1681 , text "Use DerivingStrategies to allow this" ]
1682
1683 rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested
1684 -- inside an *class decl* for cls
1685 -- used for associated types
1686 -> FamilyDecl GhcPs
1687 -> RnM (FamilyDecl GhcRn, FreeVars)
1688 rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
1689 , fdFixity = fixity
1690 , fdInfo = info, fdResultSig = res_sig
1691 , fdInjectivityAnn = injectivity })
1692 = do { tycon' <- lookupLocatedTopBndrRn tycon
1693 ; kvs <- extractRdrKindSigVars res_sig
1694 ; ((tyvars', res_sig', injectivity'), fv1) <-
1695 bindHsQTyVars doc Nothing mb_cls kvs tyvars $ \ tyvars' _ ->
1696 do { let rn_sig = rnFamResultSig doc
1697 ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig
1698 ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
1699 injectivity
1700 ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }
1701 ; (info', fv2) <- rn_info info
1702 ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars'
1703 , fdFixity = fixity
1704 , fdInfo = info', fdResultSig = res_sig'
1705 , fdInjectivityAnn = injectivity' }
1706 , fv1 `plusFV` fv2) }
1707 where
1708 doc = TyFamilyCtx tycon
1709
1710 ----------------------
1711 rn_info (ClosedTypeFamily (Just eqns))
1712 = do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns
1713 -- no class context,
1714 ; return (ClosedTypeFamily (Just eqns'), fvs) }
1715 rn_info (ClosedTypeFamily Nothing)
1716 = return (ClosedTypeFamily Nothing, emptyFVs)
1717 rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs)
1718 rn_info DataFamily = return (DataFamily, emptyFVs)
1719
1720 rnFamResultSig :: HsDocContext
1721 -> FamilyResultSig GhcPs
1722 -> RnM (FamilyResultSig GhcRn, FreeVars)
1723 rnFamResultSig _ NoSig
1724 = return (NoSig, emptyFVs)
1725 rnFamResultSig doc (KindSig kind)
1726 = do { (rndKind, ftvs) <- rnLHsKind doc kind
1727 ; return (KindSig rndKind, ftvs) }
1728 rnFamResultSig doc (TyVarSig tvbndr)
1729 = do { -- `TyVarSig` tells us that user named the result of a type family by
1730 -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to
1731 -- be sure that the supplied result name is not identical to an
1732 -- already in-scope type variable from an enclosing class.
1733 --
1734 -- Example of disallowed declaration:
1735 -- class C a b where
1736 -- type F b = a | a -> b
1737 rdr_env <- getLocalRdrEnv
1738 ; let resName = hsLTyVarName tvbndr
1739 ; when (resName `elemLocalRdrEnv` rdr_env) $
1740 addErrAt (getLoc tvbndr) $
1741 (hsep [ text "Type variable", quotes (ppr resName) <> comma
1742 , text "naming a type family result,"
1743 ] $$
1744 text "shadows an already bound type variable")
1745
1746 ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for
1747 -- scoping checks that are irrelevant here
1748 tvbndr $ \ tvbndr' ->
1749 return (TyVarSig tvbndr', unitFV (hsLTyVarName tvbndr')) }
1750
1751 -- Note [Renaming injectivity annotation]
1752 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1753 --
1754 -- During renaming of injectivity annotation we have to make several checks to
1755 -- make sure that it is well-formed. At the moment injectivity annotation
1756 -- consists of a single injectivity condition, so the terms "injectivity
1757 -- annotation" and "injectivity condition" might be used interchangeably. See
1758 -- Note [Injectivity annotation] for a detailed discussion of currently allowed
1759 -- injectivity annotations.
1760 --
1761 -- Checking LHS is simple because the only type variable allowed on the LHS of
1762 -- injectivity condition is the variable naming the result in type family head.
1763 -- Example of disallowed annotation:
1764 --
1765 -- type family Foo a b = r | b -> a
1766 --
1767 -- Verifying RHS of injectivity consists of checking that:
1768 --
1769 -- 1. only variables defined in type family head appear on the RHS (kind
1770 -- variables are also allowed). Example of disallowed annotation:
1771 --
1772 -- type family Foo a = r | r -> b
1773 --
1774 -- 2. for associated types the result variable does not shadow any of type
1775 -- class variables. Example of disallowed annotation:
1776 --
1777 -- class Foo a b where
1778 -- type F a = b | b -> a
1779 --
1780 -- Breaking any of these assumptions results in an error.
1781
1782 -- | Rename injectivity annotation. Note that injectivity annotation is just the
1783 -- part after the "|". Everything that appears before it is renamed in
1784 -- rnFamDecl.
1785 rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in
1786 -- type family head
1787 -> LFamilyResultSig GhcRn -- ^ Result signature
1788 -> LInjectivityAnn GhcPs -- ^ Injectivity annotation
1789 -> RnM (LInjectivityAnn GhcRn)
1790 rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv))
1791 (L srcSpan (InjectivityAnn injFrom injTo))
1792 = do
1793 { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors)
1794 <- askNoErrs $
1795 bindLocalNames [hsLTyVarName resTv] $
1796 -- The return type variable scopes over the injectivity annotation
1797 -- e.g. type family F a = (r::*) | r -> a
1798 do { injFrom' <- rnLTyVar injFrom
1799 ; injTo' <- mapM rnLTyVar injTo
1800 ; return $ L srcSpan (InjectivityAnn injFrom' injTo') }
1801
1802 ; let tvNames = Set.fromList $ hsAllLTyVarNames tvBndrs
1803 resName = hsLTyVarName resTv
1804 -- See Note [Renaming injectivity annotation]
1805 lhsValid = EQ == (stableNameCmp resName (unLoc injFrom'))
1806 rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames
1807
1808 -- if renaming of type variables ended with errors (eg. there were
1809 -- not-in-scope variables) don't check the validity of injectivity
1810 -- annotation. This gives better error messages.
1811 ; when (noRnErrors && not lhsValid) $
1812 addErrAt (getLoc injFrom)
1813 ( vcat [ text $ "Incorrect type variable on the LHS of "
1814 ++ "injectivity condition"
1815 , nest 5
1816 ( vcat [ text "Expected :" <+> ppr resName
1817 , text "Actual :" <+> ppr injFrom ])])
1818
1819 ; when (noRnErrors && not (Set.null rhsValid)) $
1820 do { let errorVars = Set.toList rhsValid
1821 ; addErrAt srcSpan $ ( hsep
1822 [ text "Unknown type variable" <> plural errorVars
1823 , text "on the RHS of injectivity condition:"
1824 , interpp'SP errorVars ] ) }
1825
1826 ; return injDecl' }
1827
1828 -- We can only hit this case when the user writes injectivity annotation without
1829 -- naming the result:
1830 --
1831 -- type family F a | result -> a
1832 -- type family F a :: * | result -> a
1833 --
1834 -- So we rename injectivity annotation like we normally would except that
1835 -- this time we expect "result" to be reported not in scope by rnLTyVar.
1836 rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) =
1837 setSrcSpan srcSpan $ do
1838 (injDecl', _) <- askNoErrs $ do
1839 injFrom' <- rnLTyVar injFrom
1840 injTo' <- mapM rnLTyVar injTo
1841 return $ L srcSpan (InjectivityAnn injFrom' injTo')
1842 return $ injDecl'
1843
1844 {-
1845 Note [Stupid theta]
1846 ~~~~~~~~~~~~~~~~~~~
1847 Trac #3850 complains about a regression wrt 6.10 for
1848 data Show a => T a
1849 There is no reason not to allow the stupid theta if there are no data
1850 constructors. It's still stupid, but does no harm, and I don't want
1851 to cause programs to break unnecessarily (notably HList). So if there
1852 are no data constructors we allow h98_style = True
1853 -}
1854
1855
1856 {- *****************************************************
1857 * *
1858 Support code for type/data declarations
1859 * *
1860 ***************************************************** -}
1861
1862 ---------------
1863 badAssocRhs :: [Name] -> RnM ()
1864 badAssocRhs ns
1865 = addErr (hang (text "The RHS of an associated type declaration mentions"
1866 <+> text "out-of-scope variable" <> plural ns
1867 <+> pprWithCommas (quotes . ppr) ns)
1868 2 (text "All such variables must be bound on the LHS"))
1869
1870 -----------------
1871 rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)
1872 rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
1873
1874 rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)
1875 rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
1876 , con_mb_cxt = mcxt, con_args = args
1877 , con_doc = mb_doc })
1878 = do { _ <- addLocM checkConName name
1879 ; new_name <- lookupLocatedTopBndrRn name
1880 ; mb_doc' <- rnMbLHsDoc mb_doc
1881
1882 -- We bind no implicit binders here; this is just like
1883 -- a nested HsForAllTy. E.g. consider
1884 -- data T a = forall (b::k). MkT (...)
1885 -- The 'k' will already be in scope from the bindHsQTyVars
1886 -- for the data decl itself. So we'll get
1887 -- data T {k} a = ...
1888 -- And indeed we may later discover (a::k). But that's the
1889 -- scoping we get. So no implicit binders at the existential forall
1890
1891 ; let ctxt = ConDeclCtx [new_name]
1892 ; bindLHsTyVarBndrs ctxt (Just (inHsDocContext ctxt))
1893 Nothing ex_tvs $ \ new_ex_tvs ->
1894 do { (new_context, fvs1) <- rnMbContext ctxt mcxt
1895 ; (new_args, fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args
1896 ; let all_fvs = fvs1 `plusFV` fvs2
1897 ; traceRn "rnConDecl" (ppr name <+> vcat
1898 [ text "ex_tvs:" <+> ppr ex_tvs
1899 , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ])
1900
1901 ; return (decl { con_name = new_name, con_ex_tvs = new_ex_tvs
1902 , con_mb_cxt = new_context, con_args = new_args
1903 , con_doc = mb_doc' },
1904 all_fvs) }}
1905
1906 rnConDecl decl@(ConDeclGADT { con_names = names
1907 , con_forall = explicit_forall
1908 , con_qvars = qtvs
1909 , con_mb_cxt = mcxt
1910 , con_args = args
1911 , con_res_ty = res_ty
1912 , con_doc = mb_doc })
1913 = do { mapM_ (addLocM checkConName) names
1914 ; new_names <- mapM lookupLocatedTopBndrRn names
1915 ; mb_doc' <- rnMbLHsDoc mb_doc
1916
1917 ; let explicit_tkvs = hsQTvExplicit qtvs
1918 theta = hsConDeclTheta mcxt
1919 arg_tys = hsConDeclArgTys args
1920
1921 -- We must ensure that we extract the free tkvs in left-to-right
1922 -- order of their appearance in the constructor type.
1923 -- That order governs the order the implicitly-quantified type
1924 -- variable, and hence the order needed for visible type application
1925 -- See Trac #14808.
1926 ; free_tkvs <- extractHsTysRdrTyVarsDups (theta ++ arg_tys ++ [res_ty])
1927 ; free_tkvs <- extractHsTvBndrs explicit_tkvs free_tkvs
1928
1929 ; let ctxt = ConDeclCtx new_names
1930 mb_ctxt = Just (inHsDocContext ctxt)
1931
1932 ; traceRn "rnConDecl" (ppr names $$ ppr free_tkvs $$ ppr explicit_forall )
1933 ; rnImplicitBndrs (not explicit_forall) ctxt free_tkvs $ \ implicit_tkvs ->
1934 bindLHsTyVarBndrs ctxt mb_ctxt Nothing explicit_tkvs $ \ explicit_tkvs ->
1935 do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt
1936 ; (new_args, fvs2) <- rnConDeclDetails (unLoc (head new_names)) ctxt args
1937 ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty
1938
1939 ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
1940 (args', res_ty')
1941 = case args of
1942 InfixCon {} -> pprPanic "rnConDecl" (ppr names)
1943 RecCon {} -> (new_args, new_res_ty)
1944 PrefixCon as | (arg_tys, final_res_ty) <- splitHsFunType new_res_ty
1945 -> ASSERT( null as )
1946 -- See Note [GADT abstract syntax] in HsDecls
1947 (PrefixCon arg_tys, final_res_ty)
1948
1949 new_qtvs = HsQTvs { hsq_implicit = implicit_tkvs
1950 , hsq_explicit = explicit_tkvs
1951 , hsq_dependent = emptyNameSet }
1952
1953 ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)
1954 ; return (decl { con_names = new_names
1955 , con_qvars = new_qtvs, con_mb_cxt = new_cxt
1956 , con_args = args', con_res_ty = res_ty'
1957 , con_doc = mb_doc' },
1958 all_fvs) } }
1959
1960 rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)
1961 -> RnM (Maybe (LHsContext GhcRn), FreeVars)
1962 rnMbContext _ Nothing = return (Nothing, emptyFVs)
1963 rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt
1964 ; return (Just ctx',fvs) }
1965
1966 rnConDeclDetails
1967 :: Name
1968 -> HsDocContext
1969 -> HsConDetails (LHsType GhcPs) (Located [LConDeclField GhcPs])
1970 -> RnM (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),
1971 FreeVars)
1972 rnConDeclDetails _ doc (PrefixCon tys)
1973 = do { (new_tys, fvs) <- rnLHsTypes doc tys
1974 ; return (PrefixCon new_tys, fvs) }
1975
1976 rnConDeclDetails _ doc (InfixCon ty1 ty2)
1977 = do { (new_ty1, fvs1) <- rnLHsType doc ty1
1978 ; (new_ty2, fvs2) <- rnLHsType doc ty2
1979 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }
1980
1981 rnConDeclDetails con doc (RecCon (L l fields))
1982 = do { fls <- lookupConstructorFields con
1983 ; (new_fields, fvs) <- rnConDeclFields doc fls fields
1984 -- No need to check for duplicate fields
1985 -- since that is done by RnNames.extendGlobalRdrEnvRn
1986 ; return (RecCon (L l new_fields), fvs) }
1987
1988 -------------------------------------------------
1989
1990 -- | Brings pattern synonym names and also pattern synonym selectors
1991 -- from record pattern synonyms into scope.
1992 extendPatSynEnv :: HsValBinds GhcPs -> MiniFixityEnv
1993 -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a
1994 extendPatSynEnv val_decls local_fix_env thing = do {
1995 names_with_fls <- new_ps val_decls
1996 ; let pat_syn_bndrs = concat [ name: map flSelector fields
1997 | (name, fields) <- names_with_fls ]
1998 ; let avails = map avail pat_syn_bndrs
1999 ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env
2000
2001 ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls
2002 final_gbl_env = gbl_env { tcg_field_env = field_env' }
2003 ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }
2004 where
2005 new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]
2006 new_ps (ValBindsIn binds _) = foldrBagM new_ps' [] binds
2007 new_ps _ = panic "new_ps"
2008
2009 new_ps' :: LHsBindLR GhcPs GhcPs
2010 -> [(Name, [FieldLabel])]
2011 -> TcM [(Name, [FieldLabel])]
2012 new_ps' bind names
2013 | L bind_loc (PatSynBind (PSB { psb_id = L _ n
2014 , psb_args = RecCon as })) <- bind
2015 = do
2016 bnd_name <- newTopSrcBinder (L bind_loc n)
2017 let rnames = map recordPatSynSelectorId as
2018 mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs
2019 mkFieldOcc (L l name) = L l (FieldOcc (L l name) PlaceHolder)
2020 field_occs = map mkFieldOcc rnames
2021 flds <- mapM (newRecordSelector False [bnd_name]) field_occs
2022 return ((bnd_name, flds): names)
2023 | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind
2024 = do
2025 bnd_name <- newTopSrcBinder (L bind_loc n)
2026 return ((bnd_name, []): names)
2027 | otherwise
2028 = return names
2029
2030 {-
2031 *********************************************************
2032 * *
2033 \subsection{Support code to rename types}
2034 * *
2035 *********************************************************
2036 -}
2037
2038 rnFds :: [Located (FunDep (Located RdrName))]
2039 -> RnM [Located (FunDep (Located Name))]
2040 rnFds fds
2041 = mapM (wrapLocM rn_fds) fds
2042 where
2043 rn_fds (tys1, tys2)
2044 = do { tys1' <- rnHsTyVars tys1
2045 ; tys2' <- rnHsTyVars tys2
2046 ; return (tys1', tys2') }
2047
2048 rnHsTyVars :: [Located RdrName] -> RnM [Located Name]
2049 rnHsTyVars tvs = mapM rnHsTyVar tvs
2050
2051 rnHsTyVar :: Located RdrName -> RnM (Located Name)
2052 rnHsTyVar (L l tyvar) = do
2053 tyvar' <- lookupOccRn tyvar
2054 return (L l tyvar')
2055
2056 {-
2057 *********************************************************
2058 * *
2059 findSplice
2060 * *
2061 *********************************************************
2062
2063 This code marches down the declarations, looking for the first
2064 Template Haskell splice. As it does so it
2065 a) groups the declarations into a HsGroup
2066 b) runs any top-level quasi-quotes
2067 -}
2068
2069 findSplice :: [LHsDecl GhcPs]
2070 -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
2071 findSplice ds = addl emptyRdrGroup ds
2072
2073 addl :: HsGroup GhcPs -> [LHsDecl GhcPs]
2074 -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
2075 -- This stuff reverses the declarations (again) but it doesn't matter
2076 addl gp [] = return (gp, Nothing)
2077 addl gp (L l d : ds) = add gp l d ds
2078
2079
2080 add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs]
2081 -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))
2082
2083 -- #10047: Declaration QuasiQuoters are expanded immediately, without
2084 -- causing a group split
2085 add gp _ (SpliceD (SpliceDecl (L _ qq@HsQuasiQuote{}) _)) ds
2086 = do { (ds', _) <- rnTopSpliceDecls qq
2087 ; addl gp (ds' ++ ds)
2088 }
2089
2090 add gp loc (SpliceD splice@(SpliceDecl _ flag)) ds
2091 = do { -- We've found a top-level splice. If it is an *implicit* one
2092 -- (i.e. a naked top level expression)
2093 case flag of
2094 ExplicitSplice -> return ()
2095 ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell
2096 ; unless th_on $ setSrcSpan loc $
2097 failWith badImplicitSplice }
2098
2099 ; return (gp, Just (splice, ds)) }
2100 where
2101 badImplicitSplice = text "Parse error: module header, import declaration"
2102 $$ text "or top-level declaration expected."
2103
2104 -- Class declarations: pull out the fixity signatures to the top
2105 add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds
2106 | isClassDecl d
2107 = let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in
2108 addl (gp { hs_tyclds = add_tycld (L l d) ts, hs_fixds = fsigs ++ fs}) ds
2109 | otherwise
2110 = addl (gp { hs_tyclds = add_tycld (L l d) ts }) ds
2111
2112 -- Signatures: fixity sigs go a different place than all others
2113 add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds
2114 = addl (gp {hs_fixds = L l f : ts}) ds
2115 add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds
2116 = addl (gp {hs_valds = add_sig (L l d) ts}) ds
2117
2118 -- Value declarations: use add_bind
2119 add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds
2120 = addl (gp { hs_valds = add_bind (L l d) ts }) ds
2121
2122 -- Role annotations: added to the TyClGroup
2123 add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD d) ds
2124 = addl (gp { hs_tyclds = add_role_annot (L l d) ts }) ds
2125
2126 -- NB instance declarations go into TyClGroups. We throw them into the first
2127 -- group, just as we do for the TyClD case. The renamer will go on to group
2128 -- and order them later.
2129 add gp@(HsGroup {hs_tyclds = ts}) l (InstD d) ds
2130 = addl (gp { hs_tyclds = add_instd (L l d) ts }) ds
2131
2132 -- The rest are routine
2133 add gp@(HsGroup {hs_derivds = ts}) l (DerivD d) ds
2134 = addl (gp { hs_derivds = L l d : ts }) ds
2135 add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds
2136 = addl (gp { hs_defds = L l d : ts }) ds
2137 add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds
2138 = addl (gp { hs_fords = L l d : ts }) ds
2139 add gp@(HsGroup {hs_warnds = ts}) l (WarningD d) ds
2140 = addl (gp { hs_warnds = L l d : ts }) ds
2141 add gp@(HsGroup {hs_annds = ts}) l (AnnD d) ds
2142 = addl (gp { hs_annds = L l d : ts }) ds
2143 add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds
2144 = addl (gp { hs_ruleds = L l d : ts }) ds
2145 add gp@(HsGroup {hs_vects = ts}) l (VectD d) ds
2146 = addl (gp { hs_vects = L l d : ts }) ds
2147 add gp l (DocD d) ds
2148 = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds
2149
2150 add_tycld :: LTyClDecl a -> [TyClGroup a] -> [TyClGroup a]
2151 add_tycld d [] = [TyClGroup { group_tyclds = [d]
2152 , group_roles = []
2153 , group_instds = []
2154 }
2155 ]
2156 add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)
2157 = ds { group_tyclds = d : tyclds } : dss
2158
2159 add_instd :: LInstDecl a -> [TyClGroup a] -> [TyClGroup a]
2160 add_instd d [] = [TyClGroup { group_tyclds = []
2161 , group_roles = []
2162 , group_instds = [d]
2163 }
2164 ]
2165 add_instd d (ds@(TyClGroup { group_instds = instds }):dss)
2166 = ds { group_instds = d : instds } : dss
2167
2168 add_role_annot :: LRoleAnnotDecl a -> [TyClGroup a] -> [TyClGroup a]
2169 add_role_annot d [] = [TyClGroup { group_tyclds = []
2170 , group_roles = [d]
2171 , group_instds = []
2172 }
2173 ]
2174 add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
2175 = tycls { group_roles = d : roles } : rest
2176
2177 add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
2178 add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
2179 add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
2180
2181 add_sig :: LSig a -> HsValBinds a -> HsValBinds a
2182 add_sig s (ValBindsIn bs sigs) = ValBindsIn bs (s:sigs)
2183 add_sig _ (ValBindsOut {}) = panic "RdrHsSyn:add_sig"