1f08856142d6cc5403a1f06540b57fe3dc346783
[ghc.git] / compiler / rename / RnTypes.hs
1 {-
2 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4 \section[RnSource]{Main pass of renamer}
5 -}
6
7 {-# LANGUAGE ScopedTypeVariables #-}
8 {-# LANGUAGE CPP #-}
9
10 module RnTypes (
11 -- Type related stuff
12 rnHsType, rnLHsType, rnLHsTypes, rnContext,
13 rnHsKind, rnLHsKind,
14 rnHsSigType, rnHsWcType,
15 rnHsSigWcType, rnHsSigWcTypeScoped,
16 rnLHsInstType,
17 newTyVarNameRn, collectAnonWildCards,
18 rnConDeclFields,
19 rnLTyVar,
20
21 -- Precence related stuff
22 mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
23 checkPrecMatch, checkSectionPrec,
24
25 -- Binding related stuff
26 bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs,
27 bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,
28 extractFilteredRdrTyVars, extractFilteredRdrTyVarsDups,
29 extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
30 extractHsTyRdrTyVarsDups, extractHsTysRdrTyVars,
31 extractHsTysRdrTyVarsDups, rmDupsInRdrTyVars,
32 extractRdrKindSigVars, extractDataDefnKindVars,
33 extractHsTvBndrs,
34 freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars,
35 elemRdr
36 ) where
37
38 import GhcPrelude
39
40 import {-# SOURCE #-} RnSplice( rnSpliceType )
41
42 import DynFlags
43 import HsSyn
44 import RnHsDoc ( rnLHsDoc, rnMbLHsDoc )
45 import RnEnv
46 import RnUnbound ( perhapsForallMsg )
47 import RnUtils ( HsDocContext(..), withHsDocContext, mapFvRn
48 , pprHsDocContext, bindLocalNamesFV
49 , newLocalBndrRn, checkDupRdrNames, checkShadowedRdrNames )
50 import RnFixity ( lookupFieldFixityRn, lookupFixityRn
51 , lookupTyFixityRn )
52 import TcRnMonad
53 import RdrName
54 import PrelNames
55 import TysPrim ( funTyConName )
56 import TysWiredIn ( starKindTyConName, unicodeStarKindTyConName )
57 import Name
58 import SrcLoc
59 import NameSet
60 import FieldLabel
61
62 import Util
63 import ListSetOps ( deleteBys )
64 import BasicTypes ( compareFixity, funTyFixity, negateFixity,
65 Fixity(..), FixityDirection(..), LexicalFixity(..) )
66 import Outputable
67 import FastString
68 import Maybes
69 import qualified GHC.LanguageExtensions as LangExt
70
71 import Data.List ( nubBy, partition, (\\) )
72 import Control.Monad ( unless, when )
73
74 #include "HsVersions.h"
75
76 {-
77 These type renamers are in a separate module, rather than in (say) RnSource,
78 to break several loop.
79
80 *********************************************************
81 * *
82 HsSigWcType (i.e with wildcards)
83 * *
84 *********************************************************
85 -}
86
87 rnHsSigWcType :: HsDocContext -> LHsSigWcType GhcPs
88 -> RnM (LHsSigWcType GhcRn, FreeVars)
89 rnHsSigWcType doc sig_ty
90 = rn_hs_sig_wc_type False doc sig_ty $ \sig_ty' ->
91 return (sig_ty', emptyFVs)
92
93 rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs
94 -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
95 -> RnM (a, FreeVars)
96 -- Used for
97 -- - Signatures on binders in a RULE
98 -- - Pattern type signatures
99 -- Wildcards are allowed
100 -- type signatures on binders only allowed with ScopedTypeVariables
101 rnHsSigWcTypeScoped ctx sig_ty thing_inside
102 = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables
103 ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty)
104 ; rn_hs_sig_wc_type True ctx sig_ty thing_inside
105 }
106 -- True: for pattern type sigs and rules we /do/ want
107 -- to bring those type variables into scope, even
108 -- if there's a forall at the top which usually
109 -- stops that happening
110 -- e.g \ (x :: forall a. a-> b) -> e
111 -- Here we do bring 'b' into scope
112
113 rn_hs_sig_wc_type :: Bool -- True <=> always bind any free tyvars of the
114 -- type, regardless of whether it has
115 -- a forall at the top
116 -> HsDocContext
117 -> LHsSigWcType GhcPs
118 -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
119 -> RnM (a, FreeVars)
120 -- rn_hs_sig_wc_type is used for source-language type signatures
121 rn_hs_sig_wc_type always_bind_free_tvs ctxt
122 (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})
123 thing_inside
124 = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty
125 ; (tv_rdrs, nwc_rdrs') <- partition_nwcs free_vars
126 ; let nwc_rdrs = nubL nwc_rdrs'
127 bind_free_tvs = always_bind_free_tvs || not (isLHsForAllTy hs_ty)
128 ; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars ->
129 do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty
130 ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' }
131 ib_ty' = mk_implicit_bndrs vars hs_ty' fvs1
132 ; (res, fvs2) <- thing_inside sig_ty'
133 ; return (res, fvs1 `plusFV` fvs2) } }
134 rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs _)) _
135 = panic "rn_hs_sig_wc_type"
136 rn_hs_sig_wc_type _ _ (XHsWildCardBndrs _) _
137 = panic "rn_hs_sig_wc_type"
138
139 rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
140 rnHsWcType ctxt (HsWC { hswc_body = hs_ty })
141 = do { free_vars <- extractFilteredRdrTyVars hs_ty
142 ; (_, nwc_rdrs) <- partition_nwcs free_vars
143 ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty
144 ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' }
145 ; return (sig_ty', fvs) }
146 rnHsWcType _ (XHsWildCardBndrs _) = panic "rnHsWcType"
147
148 rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs
149 -> RnM ([Name], LHsType GhcRn, FreeVars)
150 rnWcBody ctxt nwc_rdrs hs_ty
151 = do { nwcs <- mapM newLocalBndrRn nwc_rdrs
152 ; let env = RTKE { rtke_level = TypeLevel
153 , rtke_what = RnTypeBody
154 , rtke_nwcs = mkNameSet nwcs
155 , rtke_ctxt = ctxt }
156 ; (hs_ty', fvs) <- bindLocalNamesFV nwcs $
157 rn_lty env hs_ty
158 ; let awcs = collectAnonWildCards hs_ty'
159 ; return (nwcs ++ awcs, hs_ty', fvs) }
160 where
161 rn_lty env (L loc hs_ty)
162 = setSrcSpan loc $
163 do { (hs_ty', fvs) <- rn_ty env hs_ty
164 ; return (L loc hs_ty', fvs) }
165
166 rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
167 -- A lot of faff just to allow the extra-constraints wildcard to appear
168 rn_ty env hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_body })
169 = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) Nothing tvs $ \ tvs' ->
170 do { (hs_body', fvs) <- rn_lty env hs_body
171 ; return (HsForAllTy { hst_xforall = noExt, hst_bndrs = tvs'
172 , hst_body = hs_body' }, fvs) }
173
174 rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt, hst_body = hs_ty })
175 | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt
176 , L lx (HsWildCardTy _) <- ignoreParens hs_ctxt_last
177 = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1
178 ; wc' <- setSrcSpan lx $
179 do { checkExtraConstraintWildCard env hs_ctxt1
180 ; rnAnonWildCard }
181 ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')]
182 ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
183 ; return (HsQualTy { hst_xqual = noExt
184 , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }
185 , fvs1 `plusFV` fvs2) }
186
187 | otherwise
188 = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt
189 ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
190 ; return (HsQualTy { hst_xqual = noExt
191 , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }
192 , fvs1 `plusFV` fvs2) }
193
194 rn_ty env hs_ty = rnHsTyKi env hs_ty
195
196 rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint })
197
198
199 checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM ()
200 -- Rename the extra-constraint spot in a type signature
201 -- (blah, _) => type
202 -- Check that extra-constraints are allowed at all, and
203 -- if so that it's an anonymous wildcard
204 checkExtraConstraintWildCard env hs_ctxt
205 = checkWildCard env mb_bad
206 where
207 mb_bad | not (extraConstraintWildCardsAllowed env)
208 = Just base_msg
209 -- Currently, we do not allow wildcards in their full glory in
210 -- standalone deriving declarations. We only allow a single
211 -- extra-constraints wildcard à la:
212 --
213 -- deriving instance _ => Eq (Foo a)
214 --
215 -- i.e., we don't support things like
216 --
217 -- deriving instance (Eq a, _) => Eq (Foo a)
218 | DerivDeclCtx {} <- rtke_ctxt env
219 , not (null hs_ctxt)
220 = Just deriv_decl_msg
221 | otherwise
222 = Nothing
223
224 base_msg = text "Extra-constraint wildcard" <+> quotes pprAnonWildCard
225 <+> text "not allowed"
226
227 deriv_decl_msg
228 = hang base_msg
229 2 (vcat [ text "except as the sole constraint"
230 , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ])
231
232 extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
233 extraConstraintWildCardsAllowed env
234 = case rtke_ctxt env of
235 TypeSigCtx {} -> True
236 ExprWithTySigCtx {} -> True
237 DerivDeclCtx {} -> True
238 _ -> False
239
240 -- | Finds free type and kind variables in a type,
241 -- without duplicates, and
242 -- without variables that are already in scope in LocalRdrEnv
243 -- NB: this includes named wildcards, which look like perfectly
244 -- ordinary type variables at this point
245 extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups
246 extractFilteredRdrTyVars hs_ty
247 = do { rdr_env <- getLocalRdrEnv
248 ; filterInScope rdr_env <$> extractHsTyRdrTyVars hs_ty }
249
250 -- | Finds free type and kind variables in a type,
251 -- with duplicates, but
252 -- without variables that are already in scope in LocalRdrEnv
253 -- NB: this includes named wildcards, which look like perfectly
254 -- ordinary type variables at this point
255 extractFilteredRdrTyVarsDups :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups
256 extractFilteredRdrTyVarsDups hs_ty
257 = do { rdr_env <- getLocalRdrEnv
258 ; filterInScope rdr_env <$> extractHsTyRdrTyVarsDups hs_ty }
259
260 -- | When the NamedWildCards extension is enabled, partition_nwcs
261 -- removes type variables that start with an underscore from the
262 -- FreeKiTyVars in the argument and returns them in a separate list.
263 -- When the extension is disabled, the function returns the argument
264 -- and empty list. See Note [Renaming named wild cards]
265 partition_nwcs :: FreeKiTyVars -> RnM (FreeKiTyVars, [Located RdrName])
266 partition_nwcs free_vars@(FKTV { fktv_tys = tys })
267 = do { wildcards_enabled <- fmap (xopt LangExt.NamedWildCards) getDynFlags
268 ; let (nwcs, no_nwcs) | wildcards_enabled = partition is_wildcard tys
269 | otherwise = ([], tys)
270 free_vars' = free_vars { fktv_tys = no_nwcs }
271 ; return (free_vars', nwcs) }
272 where
273 is_wildcard :: Located RdrName -> Bool
274 is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr))
275
276 {- Note [Renaming named wild cards]
277 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
278 Identifiers starting with an underscore are always parsed as type variables.
279 It is only here in the renamer that we give the special treatment.
280 See Note [The wildcard story for types] in HsTypes.
281
282 It's easy! When we collect the implicitly bound type variables, ready
283 to bring them into scope, and NamedWildCards is on, we partition the
284 variables into the ones that start with an underscore (the named
285 wildcards) and the rest. Then we just add them to the hswc_wcs field
286 of the HsWildCardBndrs structure, and we are done.
287
288
289 *********************************************************
290 * *
291 HsSigtype (i.e. no wildcards)
292 * *
293 ****************************************************** -}
294
295 rnHsSigType :: HsDocContext -> LHsSigType GhcPs
296 -> RnM (LHsSigType GhcRn, FreeVars)
297 -- Used for source-language type signatures
298 -- that cannot have wildcards
299 rnHsSigType ctx (HsIB { hsib_body = hs_ty })
300 = do { traceRn "rnHsSigType" (ppr hs_ty)
301 ; vars <- extractFilteredRdrTyVarsDups hs_ty
302 ; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) vars $ \ vars ->
303 do { (body', fvs) <- rnLHsType ctx hs_ty
304 ; return ( mk_implicit_bndrs vars body' fvs, fvs ) } }
305 rnHsSigType _ (XHsImplicitBndrs _) = panic "rnHsSigType"
306
307 rnImplicitBndrs :: Bool -- True <=> bring into scope any free type variables
308 -- E.g. f :: forall a. a->b
309 -- we do not want to bring 'b' into scope, hence False
310 -- But f :: a -> b
311 -- we want to bring both 'a' and 'b' into scope
312 -> FreeKiTyVarsWithDups
313 -- Free vars of hs_ty (excluding wildcards)
314 -- May have duplicates, which is
315 -- checked here
316 -> ([Name] -> RnM (a, FreeVars))
317 -> RnM (a, FreeVars)
318 rnImplicitBndrs bind_free_tvs
319 fvs_with_dups@(FKTV { fktv_kis = kvs_with_dups
320 , fktv_tys = tvs_with_dups })
321 thing_inside
322 = do { let FKTV kvs tvs = rmDupsInRdrTyVars fvs_with_dups
323 real_tvs | bind_free_tvs = tvs
324 | otherwise = []
325 -- We always bind over free /kind/ variables.
326 -- Bind free /type/ variables only if there is no
327 -- explicit forall. E.g.
328 -- f :: Proxy (a :: k) -> b
329 -- Quantify over {k} and {a,b}
330 -- g :: forall a. Proxy (a :: k) -> b
331 -- Quantify over {k} and {}
332 -- Note that we always do the implicit kind-quantification
333 -- but, rather arbitrarily, we switch off the type-quantification
334 -- if there is an explicit forall
335
336 ; traceRn "rnImplicitBndrs" (vcat [ ppr kvs, ppr tvs, ppr real_tvs ])
337
338 ; loc <- getSrcSpanM
339 ; vars <- mapM (newLocalBndrRn . L loc . unLoc) (kvs ++ real_tvs)
340
341 ; traceRn "checkMixedVars2" $
342 vcat [ text "kvs_with_dups" <+> ppr kvs_with_dups
343 , text "tvs_with_dups" <+> ppr tvs_with_dups ]
344 ; checkMixedVars kvs_with_dups tvs_with_dups
345 -- E.g. Either (Proxy (a :: k)) k
346 -- Here 'k' is used at kind level and type level
347
348 ; bindLocalNamesFV vars $
349 thing_inside vars }
350
351 rnLHsInstType :: SDoc -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
352 -- Rename the type in an instance.
353 -- The 'doc_str' is "an instance declaration".
354 -- Do not try to decompose the inst_ty in case it is malformed
355 rnLHsInstType doc inst_ty = rnHsSigType (GenericCtx doc) inst_ty
356
357 mk_implicit_bndrs :: [Name] -- implicitly bound
358 -> a -- payload
359 -> FreeVars -- FreeVars of payload
360 -> HsImplicitBndrs GhcRn a
361 mk_implicit_bndrs vars body fvs
362 = HsIB { hsib_ext = HsIBRn
363 { hsib_vars = vars
364 , hsib_closed = nameSetAll (not . isTyVarName) (vars `delFVs` fvs) }
365 , hsib_body = body }
366
367
368
369 {- ******************************************************
370 * *
371 LHsType and HsType
372 * *
373 ****************************************************** -}
374
375 {-
376 rnHsType is here because we call it from loadInstDecl, and I didn't
377 want a gratuitous knot.
378
379 Note [Context quantification]
380 -----------------------------
381 Variables in type signatures are implicitly quantified
382 when (1) they are in a type signature not beginning
383 with "forall" or (2) in any qualified type T => R.
384 We are phasing out (2) since it leads to inconsistencies
385 (Trac #4426):
386
387 data A = A (a -> a) is an error
388 data A = A (Eq a => a -> a) binds "a"
389 data A = A (Eq a => a -> b) binds "a" and "b"
390 data A = A (() => a -> b) binds "a" and "b"
391 f :: forall a. a -> b is an error
392 f :: forall a. () => a -> b is an error
393 f :: forall a. a -> (() => b) binds "a" and "b"
394
395 This situation is now considered to be an error. See rnHsTyKi for case
396 HsForAllTy Qualified.
397
398 Note [Dealing with *]
399 ~~~~~~~~~~~~~~~~~~~~~
400 As a legacy from the days when types and kinds were different, we use
401 the type * to mean what we now call GHC.Types.Type. The problem is that
402 * should associate just like an identifier, *not* a symbol.
403 Running example: the user has written
404
405 T (Int, Bool) b + c * d
406
407 At this point, we have a bunch of stretches of types
408
409 [[T, (Int, Bool), b], [c], [d]]
410
411 these are the [[LHsType Name]] and a bunch of operators
412
413 [GHC.TypeLits.+, GHC.Types.*]
414
415 Note that the * is GHC.Types.*. So, we want to rearrange to have
416
417 [[T, (Int, Bool), b], [c, *, d]]
418
419 and
420
421 [GHC.TypeLits.+]
422
423 as our lists. We can then do normal fixity resolution on these. The fixities
424 must come along for the ride just so that the list stays in sync with the
425 operators.
426
427 Note [QualTy in kinds]
428 ~~~~~~~~~~~~~~~~~~~~~~
429 I was wondering whether QualTy could occur only at TypeLevel. But no,
430 we can have a qualified type in a kind too. Here is an example:
431
432 type family F a where
433 F Bool = Nat
434 F Nat = Type
435
436 type family G a where
437 G Type = Type -> Type
438 G () = Nat
439
440 data X :: forall k1 k2. (F k1 ~ G k2) => k1 -> k2 -> Type where
441 MkX :: X 'True '()
442
443 See that k1 becomes Bool and k2 becomes (), so the equality is
444 satisfied. If I write MkX :: X 'True 'False, compilation fails with a
445 suitable message:
446
447 MkX :: X 'True '()
448 • Couldn't match kind ‘G Bool’ with ‘Nat’
449 Expected kind: G Bool
450 Actual kind: F Bool
451
452 However: in a kind, the constraints in the QualTy must all be
453 equalities; or at least, any kinds with a class constraint are
454 uninhabited.
455 -}
456
457 data RnTyKiEnv
458 = RTKE { rtke_ctxt :: HsDocContext
459 , rtke_level :: TypeOrKind -- Am I renaming a type or a kind?
460 , rtke_what :: RnTyKiWhat -- And within that what am I renaming?
461 , rtke_nwcs :: NameSet -- These are the in-scope named wildcards
462 }
463
464 data RnTyKiWhat = RnTypeBody
465 | RnTopConstraint -- Top-level context of HsSigWcTypes
466 | RnConstraint -- All other constraints
467
468 instance Outputable RnTyKiEnv where
469 ppr (RTKE { rtke_level = lev, rtke_what = what
470 , rtke_nwcs = wcs, rtke_ctxt = ctxt })
471 = text "RTKE"
472 <+> braces (sep [ ppr lev, ppr what, ppr wcs
473 , pprHsDocContext ctxt ])
474
475 instance Outputable RnTyKiWhat where
476 ppr RnTypeBody = text "RnTypeBody"
477 ppr RnTopConstraint = text "RnTopConstraint"
478 ppr RnConstraint = text "RnConstraint"
479
480 mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
481 mkTyKiEnv cxt level what
482 = RTKE { rtke_level = level, rtke_nwcs = emptyNameSet
483 , rtke_what = what, rtke_ctxt = cxt }
484
485 isRnKindLevel :: RnTyKiEnv -> Bool
486 isRnKindLevel (RTKE { rtke_level = KindLevel }) = True
487 isRnKindLevel _ = False
488
489 --------------
490 rnLHsType :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
491 rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty
492
493 rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
494 rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
495
496 rnHsType :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
497 rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty
498
499 rnLHsKind :: HsDocContext -> LHsKind GhcPs -> RnM (LHsKind GhcRn, FreeVars)
500 rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
501
502 rnHsKind :: HsDocContext -> HsKind GhcPs -> RnM (HsKind GhcRn, FreeVars)
503 rnHsKind ctxt kind = rnHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
504
505 --------------
506 rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs
507 -> RnM (LHsContext GhcRn, FreeVars)
508 rnTyKiContext env (L loc cxt)
509 = do { traceRn "rncontext" (ppr cxt)
510 ; let env' = env { rtke_what = RnConstraint }
511 ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt
512 ; return (L loc cxt', fvs) }
513
514 rnContext :: HsDocContext -> LHsContext GhcPs
515 -> RnM (LHsContext GhcRn, FreeVars)
516 rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta
517
518 --------------
519 rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
520 rnLHsTyKi env (L loc ty)
521 = setSrcSpan loc $
522 do { (ty', fvs) <- rnHsTyKi env ty
523 ; return (L loc ty', fvs) }
524
525 rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
526
527 rnHsTyKi env ty@(HsForAllTy { hst_bndrs = tyvars, hst_body = tau })
528 = do { checkTypeInType env ty
529 ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty)
530 Nothing tyvars $ \ tyvars' ->
531 do { (tau', fvs) <- rnLHsTyKi env tau
532 ; return ( HsForAllTy { hst_xforall = noExt, hst_bndrs = tyvars'
533 , hst_body = tau' }
534 , fvs) } }
535
536 rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })
537 = do { checkTypeInType env ty -- See Note [QualTy in kinds]
538 ; (ctxt', fvs1) <- rnTyKiContext env lctxt
539 ; (tau', fvs2) <- rnLHsTyKi env tau
540 ; return (HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt'
541 , hst_body = tau' }
542 , fvs1 `plusFV` fvs2) }
543
544 rnHsTyKi env (HsTyVar _ ip (L loc rdr_name))
545 = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $
546 unlessXOptM LangExt.PolyKinds $ addErr $
547 withHsDocContext (rtke_ctxt env) $
548 vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name)
549 , text "Perhaps you intended to use PolyKinds" ]
550 -- Any type variable at the kind level is illegal without the use
551 -- of PolyKinds (see #14710)
552 ; name <- rnTyVar env rdr_name
553 ; return (HsTyVar noExt ip (L loc name), unitFV name) }
554
555 rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2)
556 = setSrcSpan (getLoc l_op) $
557 do { (l_op', fvs1) <- rnHsTyOp env ty l_op
558 ; fix <- lookupTyFixityRn l_op'
559 ; (ty1', fvs2) <- rnLHsTyKi env ty1
560 ; (ty2', fvs3) <- rnLHsTyKi env ty2
561 ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExt t1 l_op' t2)
562 (unLoc l_op') fix ty1' ty2'
563 ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }
564
565 rnHsTyKi env (HsParTy _ ty)
566 = do { (ty', fvs) <- rnLHsTyKi env ty
567 ; return (HsParTy noExt ty', fvs) }
568
569 rnHsTyKi env (HsBangTy _ b ty)
570 = do { (ty', fvs) <- rnLHsTyKi env ty
571 ; return (HsBangTy noExt b ty', fvs) }
572 rnHsTyKi env ty@(HsRecTy _ flds)
573 = do { let ctxt = rtke_ctxt env
574 ; fls <- get_fields ctxt
575 ; (flds', fvs) <- rnConDeclFields ctxt fls flds
576 ; return (HsRecTy noExt flds', fvs) }
577 where
578 get_fields (ConDeclCtx names)
579 = concatMapM (lookupConstructorFields . unLoc) names
580 get_fields _
581 = do { addErr (hang (text "Record syntax is illegal here:")
582 2 (ppr ty))
583 ; return [] }
584
585 rnHsTyKi env (HsFunTy _ ty1 ty2)
586 = do { (ty1', fvs1) <- rnLHsTyKi env ty1
587 -- Might find a for-all as the arg of a function type
588 ; (ty2', fvs2) <- rnLHsTyKi env ty2
589 -- Or as the result. This happens when reading Prelude.hi
590 -- when we find return :: forall m. Monad m -> forall a. a -> m a
591
592 -- Check for fixity rearrangements
593 ; res_ty <- mkHsOpTyRn (HsFunTy noExt) funTyConName funTyFixity ty1' ty2'
594 ; return (res_ty, fvs1 `plusFV` fvs2) }
595
596 rnHsTyKi env listTy@(HsListTy _ ty)
597 = do { data_kinds <- xoptM LangExt.DataKinds
598 ; when (not data_kinds && isRnKindLevel env)
599 (addErr (dataKindsErr env listTy))
600 ; (ty', fvs) <- rnLHsTyKi env ty
601 ; return (HsListTy noExt ty', fvs) }
602
603 rnHsTyKi env t@(HsKindSig _ ty k)
604 = do { checkTypeInType env t
605 ; kind_sigs_ok <- xoptM LangExt.KindSignatures
606 ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty)
607 ; (ty', fvs1) <- rnLHsTyKi env ty
608 ; (k', fvs2) <- rnLHsTyKi (env { rtke_level = KindLevel }) k
609 ; return (HsKindSig noExt ty' k', fvs1 `plusFV` fvs2) }
610
611 -- Unboxed tuples are allowed to have poly-typed arguments. These
612 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
613 rnHsTyKi env tupleTy@(HsTupleTy _ tup_con tys)
614 = do { data_kinds <- xoptM LangExt.DataKinds
615 ; when (not data_kinds && isRnKindLevel env)
616 (addErr (dataKindsErr env tupleTy))
617 ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
618 ; return (HsTupleTy noExt tup_con tys', fvs) }
619
620 rnHsTyKi env sumTy@(HsSumTy _ tys)
621 = do { data_kinds <- xoptM LangExt.DataKinds
622 ; when (not data_kinds && isRnKindLevel env)
623 (addErr (dataKindsErr env sumTy))
624 ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
625 ; return (HsSumTy noExt tys', fvs) }
626
627 -- Ensure that a type-level integer is nonnegative (#8306, #8412)
628 rnHsTyKi env tyLit@(HsTyLit _ t)
629 = do { data_kinds <- xoptM LangExt.DataKinds
630 ; unless data_kinds (addErr (dataKindsErr env tyLit))
631 ; when (negLit t) (addErr negLitErr)
632 ; checkTypeInType env tyLit
633 ; return (HsTyLit noExt t, emptyFVs) }
634 where
635 negLit (HsStrTy _ _) = False
636 negLit (HsNumTy _ i) = i < 0
637 negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit
638
639 rnHsTyKi env overall_ty@(HsAppsTy _ tys)
640 = do { -- Step 1: Break up the HsAppsTy into symbols and non-symbol regions
641 let (non_syms, syms) = splitHsAppsTy tys
642
643 -- Step 2: rename the pieces
644 ; (syms1, fvs1) <- mapFvRn (rnHsTyOp env overall_ty) syms
645 ; (non_syms1, fvs2) <- (mapFvRn . mapFvRn) (rnLHsTyKi env) non_syms
646
647 -- Step 3: deal with *. See Note [Dealing with *]
648 ; let (non_syms2, syms2) = deal_with_star [] [] non_syms1 syms1
649
650 -- Step 4: collapse the non-symbol regions with HsAppTy
651 ; non_syms3 <- mapM deal_with_non_syms non_syms2
652
653 -- Step 5: assemble the pieces, using mkHsOpTyRn
654 ; L _ res_ty <- build_res_ty non_syms3 syms2
655
656 -- all done. Phew.
657 ; return (res_ty, fvs1 `plusFV` fvs2) }
658 where
659 -- See Note [Dealing with *]
660 deal_with_star :: [[LHsType GhcRn]] -> [Located Name]
661 -> [[LHsType GhcRn]] -> [Located Name]
662 -> ([[LHsType GhcRn]], [Located Name])
663 deal_with_star acc1 acc2
664 (non_syms1 : non_syms2 : non_syms) (L loc star : ops)
665 | star `hasKey` starKindTyConKey || star `hasKey` unicodeStarKindTyConKey
666 = deal_with_star acc1 acc2
667 ((non_syms1 ++ L loc (HsTyVar noExt NotPromoted (L loc star))
668 : non_syms2) : non_syms)
669 ops
670 deal_with_star acc1 acc2 (non_syms1 : non_syms) (op1 : ops)
671 = deal_with_star (non_syms1 : acc1) (op1 : acc2) non_syms ops
672 deal_with_star acc1 acc2 [non_syms] []
673 = (reverse (non_syms : acc1), reverse acc2)
674 deal_with_star _ _ _ _
675 = pprPanic "deal_with_star" (ppr overall_ty)
676
677 -- collapse [LHsType GhcRn] to LHsType GhcRn by making applications
678 -- monadic only for failure
679 deal_with_non_syms :: [LHsType GhcRn] -> RnM (LHsType GhcRn)
680 deal_with_non_syms (non_sym : non_syms) = return $ mkHsAppTys non_sym non_syms
681 deal_with_non_syms [] = failWith (emptyNonSymsErr overall_ty)
682
683 -- assemble a right-biased OpTy for use in mkHsOpTyRn
684 build_res_ty :: [LHsType GhcRn] -> [Located Name] -> RnM (LHsType GhcRn)
685 build_res_ty (arg1 : args) (op1 : ops)
686 = do { rhs <- build_res_ty args ops
687 ; fix <- lookupTyFixityRn op1
688 ; res <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExt t1 op1 t2) (unLoc op1)
689 fix arg1 rhs
690 ; let loc = combineSrcSpans (getLoc arg1) (getLoc rhs)
691 ; return (L loc res)
692 }
693 build_res_ty [arg] [] = return arg
694 build_res_ty _ _ = pprPanic "build_op_ty" (ppr overall_ty)
695
696 rnHsTyKi env (HsAppTy _ ty1 ty2)
697 = do { (ty1', fvs1) <- rnLHsTyKi env ty1
698 ; (ty2', fvs2) <- rnLHsTyKi env ty2
699 ; return (HsAppTy noExt ty1' ty2', fvs1 `plusFV` fvs2) }
700
701 rnHsTyKi env t@(HsIParamTy _ n ty)
702 = do { notInKinds env t
703 ; (ty', fvs) <- rnLHsTyKi env ty
704 ; return (HsIParamTy noExt n ty', fvs) }
705
706 rnHsTyKi env t@(HsEqTy _ ty1 ty2)
707 = do { checkTypeInType env t
708 ; (ty1', fvs1) <- rnLHsTyKi env ty1
709 ; (ty2', fvs2) <- rnLHsTyKi env ty2
710 ; return (HsEqTy noExt ty1' ty2', fvs1 `plusFV` fvs2) }
711
712 rnHsTyKi _ (HsSpliceTy _ sp)
713 = rnSpliceType sp
714
715 rnHsTyKi env (HsDocTy _ ty haddock_doc)
716 = do { (ty', fvs) <- rnLHsTyKi env ty
717 ; haddock_doc' <- rnLHsDoc haddock_doc
718 ; return (HsDocTy noExt ty' haddock_doc', fvs) }
719
720 rnHsTyKi _ (XHsType (NHsCoreTy ty))
721 = return (XHsType (NHsCoreTy ty), emptyFVs)
722 -- The emptyFVs probably isn't quite right
723 -- but I don't think it matters
724
725 rnHsTyKi env ty@(HsExplicitListTy _ ip tys)
726 = do { checkTypeInType env ty
727 ; data_kinds <- xoptM LangExt.DataKinds
728 ; unless data_kinds (addErr (dataKindsErr env ty))
729 ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
730 ; return (HsExplicitListTy noExt ip tys', fvs) }
731
732 rnHsTyKi env ty@(HsExplicitTupleTy _ tys)
733 = do { checkTypeInType env ty
734 ; data_kinds <- xoptM LangExt.DataKinds
735 ; unless data_kinds (addErr (dataKindsErr env ty))
736 ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
737 ; return (HsExplicitTupleTy noExt tys', fvs) }
738
739 rnHsTyKi env (HsWildCardTy _)
740 = do { checkAnonWildCard env
741 ; wc' <- rnAnonWildCard
742 ; return (HsWildCardTy wc', emptyFVs) }
743 -- emptyFVs: this occurrence does not refer to a
744 -- user-written binding site, so don't treat
745 -- it as a free variable
746
747 --------------
748 rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name
749 rnTyVar env rdr_name
750 = do { name <- if isRnKindLevel env
751 then lookupKindOccRn rdr_name
752 else lookupTypeOccRn rdr_name
753 ; checkNamedWildCard env name
754 ; return name }
755
756 rnLTyVar :: Located RdrName -> RnM (Located Name)
757 -- Called externally; does not deal with wildards
758 rnLTyVar (L loc rdr_name)
759 = do { tyvar <- lookupTypeOccRn rdr_name
760 ; return (L loc tyvar) }
761
762 --------------
763 rnHsTyOp :: Outputable a
764 => RnTyKiEnv -> a -> Located RdrName
765 -> RnM (Located Name, FreeVars)
766 rnHsTyOp env overall_ty (L loc op)
767 = do { ops_ok <- xoptM LangExt.TypeOperators
768 ; op' <- rnTyVar env op
769 ; unless (ops_ok
770 || op' == starKindTyConName
771 || op' == unicodeStarKindTyConName
772 || op' `hasKey` eqTyConKey) $
773 addErr (opTyErr op overall_ty)
774 ; let l_op' = L loc op'
775 ; return (l_op', unitFV op') }
776
777 --------------
778 notAllowed :: SDoc -> SDoc
779 notAllowed doc
780 = text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed")
781
782 checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM ()
783 checkWildCard env (Just doc)
784 = addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))]
785 checkWildCard _ Nothing
786 = return ()
787
788 checkAnonWildCard :: RnTyKiEnv -> RnM ()
789 -- Report an error if an anonymous wildcard is illegal here
790 checkAnonWildCard env
791 = checkWildCard env mb_bad
792 where
793 mb_bad :: Maybe SDoc
794 mb_bad | not (wildCardsAllowed env)
795 = Just (notAllowed pprAnonWildCard)
796 | otherwise
797 = case rtke_what env of
798 RnTypeBody -> Nothing
799 RnConstraint -> Just constraint_msg
800 RnTopConstraint -> Just constraint_msg
801
802 constraint_msg = hang
803 (notAllowed pprAnonWildCard <+> text "in a constraint")
804 2 hint_msg
805 hint_msg = vcat [ text "except as the last top-level constraint of a type signature"
806 , nest 2 (text "e.g f :: (Eq a, _) => blah") ]
807
808 checkNamedWildCard :: RnTyKiEnv -> Name -> RnM ()
809 -- Report an error if a named wildcard is illegal here
810 checkNamedWildCard env name
811 = checkWildCard env mb_bad
812 where
813 mb_bad | not (name `elemNameSet` rtke_nwcs env)
814 = Nothing -- Not a wildcard
815 | not (wildCardsAllowed env)
816 = Just (notAllowed (ppr name))
817 | otherwise
818 = case rtke_what env of
819 RnTypeBody -> Nothing -- Allowed
820 RnTopConstraint -> Nothing -- Allowed
821 RnConstraint -> Just constraint_msg
822 constraint_msg = notAllowed (ppr name) <+> text "in a constraint"
823
824 wildCardsAllowed :: RnTyKiEnv -> Bool
825 -- ^ In what contexts are wildcards permitted
826 wildCardsAllowed env
827 = case rtke_ctxt env of
828 TypeSigCtx {} -> True
829 TypBrCtx {} -> True -- Template Haskell quoted type
830 SpliceTypeCtx {} -> True -- Result of a Template Haskell splice
831 ExprWithTySigCtx {} -> True
832 PatCtx {} -> True
833 RuleCtx {} -> True
834 FamPatCtx {} -> True -- Not named wildcards though
835 GHCiCtx {} -> True
836 HsTypeCtx {} -> True
837 _ -> False
838
839 rnAnonWildCard :: RnM HsWildCardInfo
840 rnAnonWildCard
841 = do { loc <- getSrcSpanM
842 ; uniq <- newUnique
843 ; let name = mkInternalName uniq (mkTyVarOcc "_") loc
844 ; return (AnonWildCard (L loc name)) }
845
846 ---------------
847 -- | Ensures either that we're in a type or that -XTypeInType is set
848 checkTypeInType :: Outputable ty
849 => RnTyKiEnv
850 -> ty -- ^ type
851 -> RnM ()
852 checkTypeInType env ty
853 | isRnKindLevel env
854 = do { type_in_type <- xoptM LangExt.TypeInType
855 ; unless type_in_type $
856 addErr (text "Illegal kind:" <+> ppr ty $$
857 text "Did you mean to enable TypeInType?") }
858 checkTypeInType _ _ = return ()
859
860 notInKinds :: Outputable ty
861 => RnTyKiEnv
862 -> ty
863 -> RnM ()
864 notInKinds env ty
865 | isRnKindLevel env
866 = addErr (text "Illegal kind (even with TypeInType enabled):" <+> ppr ty)
867 notInKinds _ _ = return ()
868
869 {- *****************************************************
870 * *
871 Binding type variables
872 * *
873 ***************************************************** -}
874
875 bindSigTyVarsFV :: [Name]
876 -> RnM (a, FreeVars)
877 -> RnM (a, FreeVars)
878 -- Used just before renaming the defn of a function
879 -- with a separate type signature, to bring its tyvars into scope
880 -- With no -XScopedTypeVariables, this is a no-op
881 bindSigTyVarsFV tvs thing_inside
882 = do { scoped_tyvars <- xoptM LangExt.ScopedTypeVariables
883 ; if not scoped_tyvars then
884 thing_inside
885 else
886 bindLocalNamesFV tvs thing_inside }
887
888 -- | Simply bring a bunch of RdrNames into scope. No checking for
889 -- validity, at all. The binding location is taken from the location
890 -- on each name.
891 bindLRdrNames :: [Located RdrName]
892 -> ([Name] -> RnM (a, FreeVars))
893 -> RnM (a, FreeVars)
894 bindLRdrNames rdrs thing_inside
895 = do { var_names <- mapM (newTyVarNameRn Nothing) rdrs
896 ; bindLocalNamesFV var_names $
897 thing_inside var_names }
898
899 ---------------
900 bindHsQTyVars :: forall a b.
901 HsDocContext
902 -> Maybe SDoc -- Just d => check for unused tvs
903 -- d is a phrase like "in the type ..."
904 -> Maybe a -- Just _ => an associated type decl
905 -> [Located RdrName] -- Kind variables from scope, no dups
906 -> (LHsQTyVars GhcPs)
907 -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
908 -- The Bool is True <=> all kind variables used in the
909 -- kind signature are bound on the left. Reason:
910 -- the TypeInType clause of Note [Complete user-supplied
911 -- kind signatures] in HsDecls
912 -> RnM (b, FreeVars)
913
914 -- See Note [bindHsQTyVars examples]
915 -- (a) Bring kind variables into scope
916 -- both (i) passed in body_kv_occs
917 -- and (ii) mentioned in the kinds of hsq_bndrs
918 -- (b) Bring type variables into scope
919 --
920 bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside
921 = do { let hs_tv_bndrs = hsQTvExplicit hsq_bndrs
922 ; bndr_kv_occs <- extractHsTyVarBndrsKVs hs_tv_bndrs
923 ; rdr_env <- getLocalRdrEnv
924
925 ; let -- See Note [bindHsQTyVars examples] for what
926 -- all these various things are doing
927 bndrs, kv_occs, implicit_kvs :: [Located RdrName]
928 bndrs = map hsLTyVarLocName hs_tv_bndrs
929 kv_occs = nubL (body_kv_occs ++ bndr_kv_occs)
930 implicit_kvs = filter_occs rdr_env bndrs kv_occs
931 -- Deleting bndrs: See Note [Kind-variable ordering]
932 -- dep_bndrs is the subset of bndrs that are dependent
933 -- i.e. appear in bndr/body_kv_occs
934 -- Can't use implicit_kvs because we've deleted bndrs from that!
935 dep_bndrs = filter (`elemRdr` kv_occs) bndrs
936 del = deleteBys eqLocated
937 all_bound_on_lhs = null ((body_kv_occs `del` bndrs) `del` bndr_kv_occs)
938
939 ; traceRn "checkMixedVars3" $
940 vcat [ text "kv_occs" <+> ppr kv_occs
941 , text "bndrs" <+> ppr hs_tv_bndrs
942 , text "bndr_kv_occs" <+> ppr bndr_kv_occs
943 , text "wubble" <+> ppr ((kv_occs \\ bndrs) \\ bndr_kv_occs)
944 ]
945 ; checkMixedVars kv_occs bndrs
946
947 ; implicit_kv_nms <- mapM (newTyVarNameRn mb_assoc) implicit_kvs
948
949 ; bindLocalNamesFV implicit_kv_nms $
950 bindLHsTyVarBndrs doc mb_in_doc mb_assoc hs_tv_bndrs $ \ rn_bndrs ->
951 do { traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs)
952 ; dep_bndr_nms <- mapM (lookupLocalOccRn . unLoc) dep_bndrs
953 ; thing_inside (HsQTvs { hsq_ext = HsQTvsRn
954 { hsq_implicit = implicit_kv_nms
955 , hsq_dependent = mkNameSet dep_bndr_nms }
956 , hsq_explicit = rn_bndrs })
957 all_bound_on_lhs } }
958
959 where
960 filter_occs :: LocalRdrEnv -- In scope
961 -> [Located RdrName] -- Bound here
962 -> [Located RdrName] -- Potential implicit binders
963 -> [Located RdrName] -- Final implicit binders
964 -- Filter out any potential implicit binders that are either
965 -- already in scope, or are explicitly bound here
966 filter_occs rdr_env bndrs occs
967 = filterOut is_in_scope occs
968 where
969 is_in_scope locc@(L _ occ) = isJust (lookupLocalRdrEnv rdr_env occ)
970 || locc `elemRdr` bndrs
971
972 {- Note [bindHsQTyVars examples]
973 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
974 Suppose we have
975 data T k (a::k1) (b::k) :: k2 -> k1 -> *
976
977 Then:
978 hs_tv_bndrs = [k, a::k1, b::k], the explicitly-bound variables
979 bndrs = [k,a,b]
980
981 bndr_kv_occs = [k,k1], kind variables free in kind signatures
982 of hs_tv_bndrs
983
984 body_kv_occs = [k2,k1], kind variables free in the
985 result kind signature
986
987 implicit_kvs = [k1,k2], kind variables free in kind signatures
988 of hs_tv_bndrs, and not bound by bndrs
989
990 * We want to quantify add implicit bindings for implicit_kvs
991
992 * The "dependent" bndrs (hsq_dependent) are the subset of
993 bndrs that are free in bndr_kv_occs or body_kv_occs
994
995 * If implicit_body_kvs is non-empty, then there is a kind variable
996 mentioned in the kind signature that is not bound "on the left".
997 That's one of the rules for a CUSK, so we pass that info on
998 as the second argument to thing_inside.
999
1000 * Order is not important in these lists. All we are doing is
1001 bring Names into scope.
1002
1003 Finally, you may wonder why filter_occs removes in-scope variables
1004 from bndr/body_kv_occs. How can anything be in scope? Answer:
1005 HsQTyVars is /also/ used (slightly oddly) for Haskell-98 syntax
1006 ConDecls
1007 data T a = forall (b::k). MkT a b
1008 The ConDecl has a LHsQTyVars in it; but 'a' scopes over the entire
1009 ConDecl. Hence the local RdrEnv may be non-empty and we must filter
1010 out 'a' from the free vars. (Mind you, in this situation all the
1011 implicit kind variables are bound at the data type level, so there
1012 are none to bind in the ConDecl, so there are no implicitly bound
1013 variables at all.
1014
1015 Note [Kind variable scoping]
1016 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1017 If we have
1018 data T (a :: k) k = ...
1019 we report "k is out of scope" for (a::k). Reason: k is not brought
1020 into scope until the explicit k-binding that follows. It would be
1021 terribly confusing to bring into scope an /implicit/ k for a's kind
1022 and a distinct, shadowing explicit k that follows, something like
1023 data T {k1} (a :: k1) k = ...
1024
1025 So the rule is:
1026
1027 the implicit binders never include any
1028 of the explicit binders in the group
1029
1030 Note that in the denerate case
1031 data T (a :: a) = blah
1032 we get a complaint the second 'a' is not in scope.
1033
1034 That applies to foralls too: e.g.
1035 forall (a :: k) k . blah
1036
1037 But if the foralls are split, we treat the two groups separately:
1038 forall (a :: k). forall k. blah
1039 Here we bring into scope an implicit k, which is later shadowed
1040 by the explicit k.
1041
1042 In implementation terms
1043
1044 * In bindHsQTyVars 'k' is free in bndr_kv_occs; then we delete
1045 the binders {a,k}, and so end with no implicit binders. Then we
1046 rename the binders left-to-right, and hence see that 'k' is out of
1047 scope in the kind of 'a'.
1048
1049 * Similarly in extract_hs_tv_bndrs
1050
1051 Note [Variables used as both types and kinds]
1052 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1053 In (checkMixedVars kvs tvs), we bind the type variables tvs, and kvs is the
1054 set of free variables of the kinds in the scope of the binding. Here is one
1055 typical example:
1056
1057 forall a b. a -> (b::k) -> (c::a)
1058
1059 Here, tvs will be {a,b}, and kvs {k,a}.
1060 Without -XTypeInType we want to complain that `a` is used both
1061 as a type and a kind.
1062
1063 Specifically, check that there is no overlap between kvs and tvs
1064 See typecheck/should_fail/T11963 for examples.
1065
1066 We must also make sure that kvs includes all of variables in the kinds of type
1067 variable bindings. For instance:
1068
1069 forall k (a :: k). Proxy a
1070
1071 If we only look in the body of the `forall` type, we will mistakenly conclude
1072 that kvs is {}. But in fact, the type variable `k` is also used as a kind
1073 variable in (a :: k), later in the binding. (This mistake lead to #14710.)
1074 So tvs is {k,a} and kvs is {k}, so we must also reject this without the use
1075 of -XTypeInType.
1076
1077 NB: we do this only at the binding site of 'tvs'.
1078 -}
1079
1080 bindLHsTyVarBndrs :: HsDocContext
1081 -> Maybe SDoc -- Just d => check for unused tvs
1082 -- d is a phrase like "in the type ..."
1083 -> Maybe a -- Just _ => an associated type decl
1084 -> [LHsTyVarBndr GhcPs] -- User-written tyvars
1085 -> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars))
1086 -> RnM (b, FreeVars)
1087 bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside
1088 = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
1089 ; checkDupRdrNames tv_names_w_loc
1090 ; go tv_bndrs thing_inside }
1091 where
1092 tv_names_w_loc = map hsLTyVarLocName tv_bndrs
1093
1094 go [] thing_inside = thing_inside []
1095 go (b:bs) thing_inside = bindLHsTyVarBndr doc mb_assoc b $ \ b' ->
1096 do { (res, fvs) <- go bs $ \ bs' ->
1097 thing_inside (b' : bs')
1098 ; warn_unused b' fvs
1099 ; return (res, fvs) }
1100
1101 warn_unused tv_bndr fvs = case mb_in_doc of
1102 Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs
1103 Nothing -> return ()
1104
1105 bindLHsTyVarBndr :: HsDocContext
1106 -> Maybe a -- associated class
1107 -> LHsTyVarBndr GhcPs
1108 -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars))
1109 -> RnM (b, FreeVars)
1110 bindLHsTyVarBndr _doc mb_assoc (L loc (UserTyVar x lrdr@(L lv _))) thing_inside
1111 = do { nm <- newTyVarNameRn mb_assoc lrdr
1112 ; bindLocalNamesFV [nm] $
1113 thing_inside (L loc (UserTyVar x (L lv nm))) }
1114
1115 bindLHsTyVarBndr doc mb_assoc (L loc (KindedTyVar x lrdr@(L lv _) kind))
1116 thing_inside
1117 = do { sig_ok <- xoptM LangExt.KindSignatures
1118 ; unless sig_ok (badKindSigErr doc kind)
1119 ; (kind', fvs1) <- rnLHsKind doc kind
1120 ; tv_nm <- newTyVarNameRn mb_assoc lrdr
1121 ; (b, fvs2) <- bindLocalNamesFV [tv_nm] $
1122 thing_inside (L loc (KindedTyVar x (L lv tv_nm) kind'))
1123 ; return (b, fvs1 `plusFV` fvs2) }
1124
1125 bindLHsTyVarBndr _ _ (L _ (XTyVarBndr{})) _ = panic "bindLHsTyVarBndr"
1126
1127 newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name
1128 newTyVarNameRn mb_assoc (L loc rdr)
1129 = do { rdr_env <- getLocalRdrEnv
1130 ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of
1131 (Just _, Just n) -> return n
1132 -- Use the same Name as the parent class decl
1133
1134 _ -> newLocalBndrRn (L loc rdr) }
1135
1136 ---------------------
1137 collectAnonWildCards :: LHsType GhcRn -> [Name]
1138 -- | Extract all wild cards from a type.
1139 collectAnonWildCards lty = go lty
1140 where
1141 go (L _ ty) = case ty of
1142 HsWildCardTy (AnonWildCard (L _ wc)) -> [wc]
1143 HsAppsTy _ tys -> gos (mapMaybe (prefix_types_only . unLoc) tys)
1144 HsAppTy _ ty1 ty2 -> go ty1 `mappend` go ty2
1145 HsFunTy _ ty1 ty2 -> go ty1 `mappend` go ty2
1146 HsListTy _ ty -> go ty
1147 HsTupleTy _ _ tys -> gos tys
1148 HsSumTy _ tys -> gos tys
1149 HsOpTy _ ty1 _ ty2 -> go ty1 `mappend` go ty2
1150 HsParTy _ ty -> go ty
1151 HsIParamTy _ _ ty -> go ty
1152 HsEqTy _ ty1 ty2 -> go ty1 `mappend` go ty2
1153 HsKindSig _ ty kind -> go ty `mappend` go kind
1154 HsDocTy _ ty _ -> go ty
1155 HsBangTy _ _ ty -> go ty
1156 HsRecTy _ flds -> gos $ map (cd_fld_type . unLoc) flds
1157 HsExplicitListTy _ _ tys -> gos tys
1158 HsExplicitTupleTy _ tys -> gos tys
1159 HsForAllTy { hst_bndrs = bndrs
1160 , hst_body = ty } -> collectAnonWildCardsBndrs bndrs
1161 `mappend` go ty
1162 HsQualTy { hst_ctxt = L _ ctxt
1163 , hst_body = ty } -> gos ctxt `mappend` go ty
1164 HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty
1165 HsSpliceTy{} -> mempty
1166 HsTyLit{} -> mempty
1167 HsTyVar{} -> mempty
1168 XHsType{} -> mempty
1169
1170 gos = mconcat . map go
1171
1172 prefix_types_only (HsAppPrefix _ ty) = Just ty
1173 prefix_types_only (HsAppInfix _ _) = Nothing
1174 prefix_types_only (XAppType _) = Nothing
1175
1176 collectAnonWildCardsBndrs :: [LHsTyVarBndr GhcRn] -> [Name]
1177 collectAnonWildCardsBndrs ltvs = concatMap (go . unLoc) ltvs
1178 where
1179 go (UserTyVar _ _) = []
1180 go (KindedTyVar _ _ ki) = collectAnonWildCards ki
1181 go (XTyVarBndr{}) = []
1182
1183 {-
1184 *********************************************************
1185 * *
1186 ConDeclField
1187 * *
1188 *********************************************************
1189
1190 When renaming a ConDeclField, we have to find the FieldLabel
1191 associated with each field. But we already have all the FieldLabels
1192 available (since they were brought into scope by
1193 RnNames.getLocalNonValBinders), so we just take the list as an
1194 argument, build a map and look them up.
1195 -}
1196
1197 rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs]
1198 -> RnM ([LConDeclField GhcRn], FreeVars)
1199 -- Also called from RnSource
1200 -- No wildcards can appear in record fields
1201 rnConDeclFields ctxt fls fields
1202 = mapFvRn (rnField fl_env env) fields
1203 where
1204 env = mkTyKiEnv ctxt TypeLevel RnTypeBody
1205 fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]
1206
1207 rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs
1208 -> RnM (LConDeclField GhcRn, FreeVars)
1209 rnField fl_env env (L l (ConDeclField _ names ty haddock_doc))
1210 = do { let new_names = map (fmap lookupField) names
1211 ; (new_ty, fvs) <- rnLHsTyKi env ty
1212 ; new_haddock_doc <- rnMbLHsDoc haddock_doc
1213 ; return (L l (ConDeclField noExt new_names new_ty new_haddock_doc)
1214 , fvs) }
1215 where
1216 lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn
1217 lookupField (FieldOcc _ (L lr rdr)) = FieldOcc (flSelector fl) (L lr rdr)
1218 where
1219 lbl = occNameFS $ rdrNameOcc rdr
1220 fl = expectJust "rnField" $ lookupFsEnv fl_env lbl
1221 lookupField (XFieldOcc{}) = panic "rnField"
1222 rnField _ _ (L _ (XConDeclField _)) = panic "rnField"
1223
1224 {-
1225 ************************************************************************
1226 * *
1227 Fixities and precedence parsing
1228 * *
1229 ************************************************************************
1230
1231 @mkOpAppRn@ deals with operator fixities. The argument expressions
1232 are assumed to be already correctly arranged. It needs the fixities
1233 recorded in the OpApp nodes, because fixity info applies to the things
1234 the programmer actually wrote, so you can't find it out from the Name.
1235
1236 Furthermore, the second argument is guaranteed not to be another
1237 operator application. Why? Because the parser parses all
1238 operator applications left-associatively, EXCEPT negation, which
1239 we need to handle specially.
1240 Infix types are read in a *right-associative* way, so that
1241 a `op` b `op` c
1242 is always read in as
1243 a `op` (b `op` c)
1244
1245 mkHsOpTyRn rearranges where necessary. The two arguments
1246 have already been renamed and rearranged. It's made rather tiresome
1247 by the presence of ->, which is a separate syntactic construct.
1248 -}
1249
1250 ---------------
1251 -- Building (ty1 `op1` (ty21 `op2` ty22))
1252 mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
1253 -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn
1254 -> RnM (HsType GhcRn)
1255
1256 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy noExt ty21 op2 ty22))
1257 = do { fix2 <- lookupTyFixityRn op2
1258 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
1259 (\t1 t2 -> HsOpTy noExt t1 op2 t2)
1260 (unLoc op2) fix2 ty21 ty22 loc2 }
1261
1262 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy _ ty21 ty22))
1263 = mk_hs_op_ty mk1 pp_op1 fix1 ty1
1264 (HsFunTy noExt) funTyConName funTyFixity ty21 ty22 loc2
1265
1266 mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment
1267 = return (mk1 ty1 ty2)
1268
1269 ---------------
1270 mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
1271 -> Name -> Fixity -> LHsType GhcRn
1272 -> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
1273 -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> SrcSpan
1274 -> RnM (HsType GhcRn)
1275 mk_hs_op_ty mk1 op1 fix1 ty1
1276 mk2 op2 fix2 ty21 ty22 loc2
1277 | nofix_error = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2)
1278 ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
1279 | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
1280 | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
1281 new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
1282 ; return (mk2 (noLoc new_ty) ty22) }
1283 where
1284 (nofix_error, associate_right) = compareFixity fix1 fix2
1285
1286
1287 ---------------------------
1288 mkOpAppRn :: LHsExpr GhcRn -- Left operand; already rearranged
1289 -> LHsExpr GhcRn -> Fixity -- Operator and fixity
1290 -> LHsExpr GhcRn -- Right operand (not an OpApp, but might
1291 -- be a NegApp)
1292 -> RnM (HsExpr GhcRn)
1293
1294 -- (e11 `op1` e12) `op2` e2
1295 mkOpAppRn e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2
1296 | nofix_error
1297 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
1298 return (OpApp fix2 e1 op2 e2)
1299
1300 | associate_right = do
1301 new_e <- mkOpAppRn e12 op2 fix2 e2
1302 return (OpApp fix1 e11 op1 (L loc' new_e))
1303 where
1304 loc'= combineLocs e12 e2
1305 (nofix_error, associate_right) = compareFixity fix1 fix2
1306
1307 ---------------------------
1308 -- (- neg_arg) `op` e2
1309 mkOpAppRn e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2
1310 | nofix_error
1311 = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2)
1312 return (OpApp fix2 e1 op2 e2)
1313
1314 | associate_right
1315 = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
1316 return (NegApp noExt (L loc' new_e) neg_name)
1317 where
1318 loc' = combineLocs neg_arg e2
1319 (nofix_error, associate_right) = compareFixity negateFixity fix2
1320
1321 ---------------------------
1322 -- e1 `op` - neg_arg
1323 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right
1324 | not associate_right -- We *want* right association
1325 = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity)
1326 return (OpApp fix1 e1 op1 e2)
1327 where
1328 (_, associate_right) = compareFixity fix1 negateFixity
1329
1330 ---------------------------
1331 -- Default case
1332 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
1333 = ASSERT2( right_op_ok fix (unLoc e2),
1334 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
1335 )
1336 return (OpApp fix e1 op e2)
1337
1338 ----------------------------
1339
1340 -- | Name of an operator in an operator application or section
1341 data OpName = NormalOp Name -- ^ A normal identifier
1342 | NegateOp -- ^ Prefix negation
1343 | UnboundOp UnboundVar -- ^ An unbound indentifier
1344 | RecFldOp (AmbiguousFieldOcc GhcRn)
1345 -- ^ A (possibly ambiguous) record field occurrence
1346
1347 instance Outputable OpName where
1348 ppr (NormalOp n) = ppr n
1349 ppr NegateOp = ppr negateName
1350 ppr (UnboundOp uv) = ppr uv
1351 ppr (RecFldOp fld) = ppr fld
1352
1353 get_op :: LHsExpr GhcRn -> OpName
1354 -- An unbound name could be either HsVar or HsUnboundVar
1355 -- See RnExpr.rnUnboundVar
1356 get_op (L _ (HsVar _ (L _ n))) = NormalOp n
1357 get_op (L _ (HsUnboundVar _ uv)) = UnboundOp uv
1358 get_op (L _ (HsRecFld _ fld)) = RecFldOp fld
1359 get_op other = pprPanic "get_op" (ppr other)
1360
1361 -- Parser left-associates everything, but
1362 -- derived instances may have correctly-associated things to
1363 -- in the right operand. So we just check that the right operand is OK
1364 right_op_ok :: Fixity -> HsExpr GhcRn -> Bool
1365 right_op_ok fix1 (OpApp fix2 _ _ _)
1366 = not error_please && associate_right
1367 where
1368 (error_please, associate_right) = compareFixity fix1 fix2
1369 right_op_ok _ _
1370 = True
1371
1372 -- Parser initially makes negation bind more tightly than any other operator
1373 -- And "deriving" code should respect this (use HsPar if not)
1374 mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id)
1375 -> RnM (HsExpr (GhcPass id))
1376 mkNegAppRn neg_arg neg_name
1377 = ASSERT( not_op_app (unLoc neg_arg) )
1378 return (NegApp noExt neg_arg neg_name)
1379
1380 not_op_app :: HsExpr id -> Bool
1381 not_op_app (OpApp {}) = False
1382 not_op_app _ = True
1383
1384 ---------------------------
1385 mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged
1386 -> LHsExpr GhcRn -> Fixity -- Operator and fixity
1387 -> LHsCmdTop GhcRn -- Right operand (not an infix)
1388 -> RnM (HsCmd GhcRn)
1389
1390 -- (e11 `op1` e12) `op2` e2
1391 mkOpFormRn a1@(L loc (HsCmdTop _ (L _ (HsCmdArrForm x op1 f (Just fix1)
1392 [a11,a12]))))
1393 op2 fix2 a2
1394 | nofix_error
1395 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
1396 return (HsCmdArrForm x op2 f (Just fix2) [a1, a2])
1397
1398 | associate_right
1399 = do new_c <- mkOpFormRn a12 op2 fix2 a2
1400 return (HsCmdArrForm noExt op1 f (Just fix1)
1401 [a11, L loc (HsCmdTop [] (L loc new_c))])
1402 -- TODO: locs are wrong
1403 where
1404 (nofix_error, associate_right) = compareFixity fix1 fix2
1405
1406 -- Default case
1407 mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
1408 = return (HsCmdArrForm noExt op Infix (Just fix) [arg1, arg2])
1409
1410
1411 --------------------------------------
1412 mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn
1413 -> RnM (Pat GhcRn)
1414
1415 mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
1416 = do { fix1 <- lookupFixityRn (unLoc op1)
1417 ; let (nofix_error, associate_right) = compareFixity fix1 fix2
1418
1419 ; if nofix_error then do
1420 { precParseErr (NormalOp (unLoc op1),fix1)
1421 (NormalOp (unLoc op2),fix2)
1422 ; return (ConPatIn op2 (InfixCon p1 p2)) }
1423
1424 else if associate_right then do
1425 { new_p <- mkConOpPatRn op2 fix2 p12 p2
1426 ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
1427 else return (ConPatIn op2 (InfixCon p1 p2)) }
1428
1429 mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment
1430 = ASSERT( not_op_pat (unLoc p2) )
1431 return (ConPatIn op (InfixCon p1 p2))
1432
1433 not_op_pat :: Pat GhcRn -> Bool
1434 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
1435 not_op_pat _ = True
1436
1437 --------------------------------------
1438 checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM ()
1439 -- Check precedence of a function binding written infix
1440 -- eg a `op` b `C` c = ...
1441 -- See comments with rnExpr (OpApp ...) about "deriving"
1442
1443 checkPrecMatch op (MG { mg_alts = L _ ms })
1444 = mapM_ check ms
1445 where
1446 check (L _ (Match { m_pats = L l1 p1 : L l2 p2 :_ }))
1447 = setSrcSpan (combineSrcSpans l1 l2) $
1448 do checkPrec op p1 False
1449 checkPrec op p2 True
1450
1451 check _ = return ()
1452 -- This can happen. Consider
1453 -- a `op` True = ...
1454 -- op = ...
1455 -- The infix flag comes from the first binding of the group
1456 -- but the second eqn has no args (an error, but not discovered
1457 -- until the type checker). So we don't want to crash on the
1458 -- second eqn.
1459 checkPrecMatch _ (XMatchGroup {}) = panic "checkPrecMatch"
1460
1461 checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
1462 checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
1463 op_fix@(Fixity _ op_prec op_dir) <- lookupFixityRn op
1464 op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
1465 let
1466 inf_ok = op1_prec > op_prec ||
1467 (op1_prec == op_prec &&
1468 (op1_dir == InfixR && op_dir == InfixR && right ||
1469 op1_dir == InfixL && op_dir == InfixL && not right))
1470
1471 info = (NormalOp op, op_fix)
1472 info1 = (NormalOp (unLoc op1), op1_fix)
1473 (infol, infor) = if right then (info, info1) else (info1, info)
1474 unless inf_ok (precParseErr infol infor)
1475
1476 checkPrec _ _ _
1477 = return ()
1478
1479 -- Check precedence of (arg op) or (op arg) respectively
1480 -- If arg is itself an operator application, then either
1481 -- (a) its precedence must be higher than that of op
1482 -- (b) its precedency & associativity must be the same as that of op
1483 checkSectionPrec :: FixityDirection -> HsExpr GhcPs
1484 -> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM ()
1485 checkSectionPrec direction section op arg
1486 = case unLoc arg of
1487 OpApp fix _ op' _ -> go_for_it (get_op op') fix
1488 NegApp _ _ _ -> go_for_it NegateOp negateFixity
1489 _ -> return ()
1490 where
1491 op_name = get_op op
1492 go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do
1493 op_fix@(Fixity _ op_prec _) <- lookupFixityOp op_name
1494 unless (op_prec < arg_prec
1495 || (op_prec == arg_prec && direction == assoc))
1496 (sectionPrecErr (get_op op, op_fix)
1497 (arg_op, arg_fix) section)
1498
1499 -- | Look up the fixity for an operator name. Be careful to use
1500 -- 'lookupFieldFixityRn' for (possibly ambiguous) record fields
1501 -- (see Trac #13132).
1502 lookupFixityOp :: OpName -> RnM Fixity
1503 lookupFixityOp (NormalOp n) = lookupFixityRn n
1504 lookupFixityOp NegateOp = lookupFixityRn negateName
1505 lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName (unboundVarOcc u))
1506 lookupFixityOp (RecFldOp f) = lookupFieldFixityRn f
1507
1508
1509 -- Precedence-related error messages
1510
1511 precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM ()
1512 precParseErr op1@(n1,_) op2@(n2,_)
1513 | is_unbound n1 || is_unbound n2
1514 = return () -- Avoid error cascade
1515 | otherwise
1516 = addErr $ hang (text "Precedence parsing error")
1517 4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"),
1518 ppr_opfix op2,
1519 text "in the same infix expression"])
1520
1521 sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr GhcPs -> RnM ()
1522 sectionPrecErr op@(n1,_) arg_op@(n2,_) section
1523 | is_unbound n1 || is_unbound n2
1524 = return () -- Avoid error cascade
1525 | otherwise
1526 = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"),
1527 nest 4 (sep [text "must have lower precedence than that of the operand,",
1528 nest 2 (text "namely" <+> ppr_opfix arg_op)]),
1529 nest 4 (text "in the section:" <+> quotes (ppr section))]
1530
1531 is_unbound :: OpName -> Bool
1532 is_unbound (NormalOp n) = isUnboundName n
1533 is_unbound UnboundOp{} = True
1534 is_unbound _ = False
1535
1536 ppr_opfix :: (OpName, Fixity) -> SDoc
1537 ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
1538 where
1539 pp_op | NegateOp <- op = text "prefix `-'"
1540 | otherwise = quotes (ppr op)
1541
1542
1543 {- *****************************************************
1544 * *
1545 Errors
1546 * *
1547 ***************************************************** -}
1548
1549 unexpectedTypeSigErr :: LHsSigWcType GhcPs -> SDoc
1550 unexpectedTypeSigErr ty
1551 = hang (text "Illegal type signature:" <+> quotes (ppr ty))
1552 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables")
1553
1554 badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM ()
1555 badKindSigErr doc (L loc ty)
1556 = setSrcSpan loc $ addErr $
1557 withHsDocContext doc $
1558 hang (text "Illegal kind signature:" <+> quotes (ppr ty))
1559 2 (text "Perhaps you intended to use KindSignatures")
1560
1561 dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc
1562 dataKindsErr env thing
1563 = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing))
1564 2 (text "Perhaps you intended to use DataKinds")
1565 where
1566 pp_what | isRnKindLevel env = text "kind"
1567 | otherwise = text "type"
1568
1569 inTypeDoc :: HsType GhcPs -> SDoc
1570 inTypeDoc ty = text "In the type" <+> quotes (ppr ty)
1571
1572 warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM ()
1573 warnUnusedForAll in_doc (L loc tv) used_names
1574 = whenWOptM Opt_WarnUnusedForalls $
1575 unless (hsTyVarName tv `elemNameSet` used_names) $
1576 addWarnAt (Reason Opt_WarnUnusedForalls) loc $
1577 vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)
1578 , in_doc ]
1579
1580 opTyErr :: Outputable a => RdrName -> a -> SDoc
1581 opTyErr op overall_ty
1582 = hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty))
1583 2 extra
1584 where
1585 extra | op == dot_tv_RDR
1586 = perhapsForallMsg
1587 | otherwise
1588 = text "Use TypeOperators to allow operators in types"
1589
1590 emptyNonSymsErr :: HsType GhcPs -> SDoc
1591 emptyNonSymsErr overall_ty
1592 = text "Operator applied to too few arguments:" <+> ppr overall_ty
1593
1594 {-
1595 ************************************************************************
1596 * *
1597 Finding the free type variables of a (HsType RdrName)
1598 * *
1599 ************************************************************************
1600
1601
1602 Note [Kind and type-variable binders]
1603 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1604 In a type signature we may implicitly bind type variable and, more
1605 recently, kind variables. For example:
1606 * f :: a -> a
1607 f = ...
1608 Here we need to find the free type variables of (a -> a),
1609 so that we know what to quantify
1610
1611 * class C (a :: k) where ...
1612 This binds 'k' in ..., as well as 'a'
1613
1614 * f (x :: a -> [a]) = ....
1615 Here we bind 'a' in ....
1616
1617 * f (x :: T a -> T (b :: k)) = ...
1618 Here we bind both 'a' and the kind variable 'k'
1619
1620 * type instance F (T (a :: Maybe k)) = ...a...k...
1621 Here we want to constrain the kind of 'a', and bind 'k'.
1622
1623 In general we want to walk over a type, and find
1624 * Its free type variables
1625 * The free kind variables of any kind signatures in the type
1626
1627 Hence we return a pair (kind-vars, type vars)
1628 See also Note [HsBSig binder lists] in HsTypes
1629
1630 Most clients of this code just want to know the kind/type vars, without
1631 duplicates. The function rmDupsInRdrTyVars removes duplicates. That function
1632 also makes sure that no variable is reported as both a kind var and
1633 a type var, preferring kind vars. Why kind vars? Consider this:
1634
1635 foo :: forall (a :: k). Proxy k -> Proxy a -> ...
1636
1637 Should that be accepted?
1638
1639 Normally, if a type signature has an explicit forall, it must list *all*
1640 tyvars mentioned in the type. But there's an exception for tyvars mentioned in
1641 a kind, as k is above. Note that k is also used "as a type variable", as the
1642 argument to the first Proxy. So, do we consider k to be type-variable-like and
1643 require it in the forall? Or do we consider k to be kind-variable-like and not
1644 require it?
1645
1646 It's not just in type signatures: kind variables are implicitly brought into
1647 scope in a variety of places. Should vars used at both the type level and kind
1648 level be treated this way?
1649
1650 GHC indeed allows kind variables to be brought into scope implicitly even when
1651 the kind variable is also used as a type variable. Thus, we must prefer to keep
1652 a variable listed as a kind var in rmDupsInRdrTyVars. If we kept it as a type
1653 var, then this would prevent it from being implicitly quantified (see
1654 rnImplicitBndrs). In the `foo` example above, that would have the consequence
1655 of the k in Proxy k being reported as out of scope.
1656
1657 -}
1658
1659 -- See Note [Kind and type-variable binders]
1660 data FreeKiTyVars = FKTV { fktv_kis :: [Located RdrName]
1661 , fktv_tys :: [Located RdrName] }
1662
1663 -- | A 'FreeKiTyVars' list that is allowed to have duplicate variables.
1664 type FreeKiTyVarsWithDups = FreeKiTyVars
1665
1666 -- | A 'FreeKiTyVars' list that contains no duplicate variables.
1667 type FreeKiTyVarsNoDups = FreeKiTyVars
1668
1669 instance Outputable FreeKiTyVars where
1670 ppr (FKTV kis tys) = ppr (kis, tys)
1671
1672 emptyFKTV :: FreeKiTyVarsNoDups
1673 emptyFKTV = FKTV [] []
1674
1675 freeKiTyVarsAllVars :: FreeKiTyVars -> [Located RdrName]
1676 freeKiTyVarsAllVars (FKTV tys kvs) = tys ++ kvs
1677
1678 freeKiTyVarsKindVars :: FreeKiTyVars -> [Located RdrName]
1679 freeKiTyVarsKindVars = fktv_kis
1680
1681 freeKiTyVarsTypeVars :: FreeKiTyVars -> [Located RdrName]
1682 freeKiTyVarsTypeVars = fktv_tys
1683
1684 filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
1685 filterInScope rdr_env (FKTV kis tys)
1686 = FKTV (filterOut in_scope kis)
1687 (filterOut in_scope tys)
1688 where
1689 in_scope = inScope rdr_env . unLoc
1690
1691 inScope :: LocalRdrEnv -> RdrName -> Bool
1692 inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env
1693
1694 -- | 'extractHsTyRdrTyVars' finds the
1695 -- free (kind, type) variables of an 'HsType'
1696 -- or the free (sort, kind) variables of an 'HsKind'.
1697 -- It's used when making the @forall@s explicit.
1698 -- Does not return any wildcards.
1699 -- When the same name occurs multiple times in the types, only the first
1700 -- occurrence is returned.
1701 -- See Note [Kind and type-variable binders]
1702 extractHsTyRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups
1703 extractHsTyRdrTyVars ty
1704 = rmDupsInRdrTyVars <$> extractHsTyRdrTyVarsDups ty
1705
1706 -- | 'extractHsTyRdrTyVarsDups' find the
1707 -- free (kind, type) variables of an 'HsType'
1708 -- or the free (sort, kind) variables of an 'HsKind'.
1709 -- It's used when making the @forall@s explicit.
1710 -- Does not return any wildcards.
1711 -- When the same name occurs multiple times in the types, all occurrences
1712 -- are returned.
1713 extractHsTyRdrTyVarsDups :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups
1714 extractHsTyRdrTyVarsDups ty
1715 = extract_lty TypeLevel ty emptyFKTV
1716
1717 -- | Extracts the free kind variables (but not the type variables) of an
1718 -- 'HsType'. Does not return any wildcards.
1719 -- When the same name occurs multiple times in the type, only the first
1720 -- occurrence is returned.
1721 -- See Note [Kind and type-variable binders]
1722 extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> RnM [Located RdrName]
1723 extractHsTyRdrTyVarsKindVars ty
1724 = freeKiTyVarsKindVars <$> extractHsTyRdrTyVars ty
1725
1726 -- | Extracts free type and kind variables from types in a list.
1727 -- When the same name occurs multiple times in the types, only the first
1728 -- occurrence is returned and the rest is filtered out.
1729 -- See Note [Kind and type-variable binders]
1730 extractHsTysRdrTyVars :: [LHsType GhcPs] -> RnM FreeKiTyVarsNoDups
1731 extractHsTysRdrTyVars tys
1732 = rmDupsInRdrTyVars <$> extractHsTysRdrTyVarsDups tys
1733
1734 -- | Extracts free type and kind variables from types in a list.
1735 -- When the same name occurs multiple times in the types, all occurrences
1736 -- are returned.
1737 extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> RnM FreeKiTyVarsWithDups
1738 extractHsTysRdrTyVarsDups tys
1739 = extract_ltys TypeLevel tys emptyFKTV
1740
1741 extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> RnM [Located RdrName]
1742 -- Returns the free kind variables of any explictly-kinded binders
1743 -- NB: Does /not/ delete the binders themselves.
1744 -- However duplicates are removed
1745 -- E.g. given [k1, a:k1, b:k2]
1746 -- the function returns [k1,k2], even though k1 is bound here
1747 extractHsTyVarBndrsKVs tv_bndrs
1748 = do { kvs <- extract_hs_tv_bndrs_kvs tv_bndrs
1749 ; return (nubL kvs) }
1750
1751 -- | Removes multiple occurrences of the same name from FreeKiTyVars. If a
1752 -- variable occurs as both a kind and a type variable, only keep the occurrence
1753 -- as a kind variable.
1754 -- See also Note [Kind and type-variable binders]
1755 rmDupsInRdrTyVars :: FreeKiTyVarsWithDups -> FreeKiTyVarsNoDups
1756 rmDupsInRdrTyVars (FKTV kis tys)
1757 = FKTV kis' tys'
1758 where
1759 kis' = nubL kis
1760 tys' = nubL (filterOut (`elemRdr` kis') tys)
1761
1762 extractRdrKindSigVars :: LFamilyResultSig GhcPs -> RnM [Located RdrName]
1763 extractRdrKindSigVars (L _ resultSig)
1764 | KindSig _ k <- resultSig = kindRdrNameFromSig k
1765 | TyVarSig _ (L _ (KindedTyVar _ _ k)) <- resultSig = kindRdrNameFromSig k
1766 | otherwise = return []
1767 where kindRdrNameFromSig k = freeKiTyVarsAllVars <$> extractHsTyRdrTyVars k
1768
1769 extractDataDefnKindVars :: HsDataDefn GhcPs -> RnM [Located RdrName]
1770 -- Get the scoped kind variables mentioned free in the constructor decls
1771 -- Eg: data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
1772 -- Here k should scope over the whole definition
1773 --
1774 -- However, do NOT collect free kind vars from the deriving clauses:
1775 -- Eg: (Trac #14331) class C p q
1776 -- data D = D deriving ( C (a :: k) )
1777 -- Here k should /not/ scope over the whole definition. We intend
1778 -- this to elaborate to:
1779 -- class C @k1 @k2 (p::k1) (q::k2)
1780 -- data D = D
1781 -- instance forall k (a::k). C @k @* a D where ...
1782 --
1783 extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
1784 , dd_cons = cons })
1785 = (nubL . freeKiTyVarsKindVars) <$>
1786 (extract_lctxt TypeLevel ctxt =<<
1787 extract_mb extract_lkind ksig =<<
1788 foldrM (extract_con . unLoc) emptyFKTV cons)
1789 where
1790 extract_con (ConDeclGADT { }) acc = return acc
1791 extract_con (ConDeclH98 { con_ex_tvs = ex_tvs
1792 , con_mb_cxt = ctxt, con_args = args }) acc
1793 = extract_hs_tv_bndrs ex_tvs acc =<<
1794 extract_mlctxt ctxt =<<
1795 extract_ltys TypeLevel (hsConDeclArgTys args) emptyFKTV
1796 extract_con (XConDecl { }) _ = panic "extractDataDefnKindVars"
1797 extractDataDefnKindVars (XHsDataDefn _) = panic "extractDataDefnKindVars"
1798
1799 extract_mlctxt :: Maybe (LHsContext GhcPs)
1800 -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
1801 extract_mlctxt Nothing acc = return acc
1802 extract_mlctxt (Just ctxt) acc = extract_lctxt TypeLevel ctxt acc
1803
1804 extract_lctxt :: TypeOrKind
1805 -> LHsContext GhcPs
1806 -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
1807 extract_lctxt t_or_k ctxt = extract_ltys t_or_k (unLoc ctxt)
1808
1809 extract_ltys :: TypeOrKind
1810 -> [LHsType GhcPs]
1811 -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
1812 extract_ltys t_or_k tys acc = foldrM (extract_lty t_or_k) acc tys
1813
1814 extract_mb :: (a -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups)
1815 -> Maybe a
1816 -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
1817 extract_mb _ Nothing acc = return acc
1818 extract_mb f (Just x) acc = f x acc
1819
1820 extract_lkind :: LHsType GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars
1821 extract_lkind = extract_lty KindLevel
1822
1823 extract_lty :: TypeOrKind -> LHsType GhcPs
1824 -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
1825 extract_lty t_or_k (L _ ty) acc
1826 = case ty of
1827 HsTyVar _ _ ltv -> extract_tv t_or_k ltv acc
1828 HsBangTy _ _ ty -> extract_lty t_or_k ty acc
1829 HsRecTy _ flds -> foldrM (extract_lty t_or_k
1830 . cd_fld_type . unLoc) acc
1831 flds
1832 HsAppsTy _ tys -> extract_apps t_or_k tys acc
1833 HsAppTy _ ty1 ty2 -> extract_lty t_or_k ty1 =<<
1834 extract_lty t_or_k ty2 acc
1835 HsListTy _ ty -> extract_lty t_or_k ty acc
1836 HsTupleTy _ _ tys -> extract_ltys t_or_k tys acc
1837 HsSumTy _ tys -> extract_ltys t_or_k tys acc
1838 HsFunTy _ ty1 ty2 -> extract_lty t_or_k ty1 =<<
1839 extract_lty t_or_k ty2 acc
1840 HsIParamTy _ _ ty -> extract_lty t_or_k ty acc
1841 HsEqTy _ ty1 ty2 -> extract_lty t_or_k ty1 =<<
1842 extract_lty t_or_k ty2 acc
1843 HsOpTy _ ty1 tv ty2 -> extract_tv t_or_k tv =<<
1844 extract_lty t_or_k ty1 =<<
1845 extract_lty t_or_k ty2 acc
1846 HsParTy _ ty -> extract_lty t_or_k ty acc
1847 HsSpliceTy {} -> return acc -- Type splices mention no tvs
1848 HsDocTy _ ty _ -> extract_lty t_or_k ty acc
1849 HsExplicitListTy _ _ tys -> extract_ltys t_or_k tys acc
1850 HsExplicitTupleTy _ tys -> extract_ltys t_or_k tys acc
1851 HsTyLit _ _ -> return acc
1852 HsKindSig _ ty ki -> extract_lty t_or_k ty =<<
1853 extract_lkind ki acc
1854 HsForAllTy { hst_bndrs = tvs, hst_body = ty }
1855 -> extract_hs_tv_bndrs tvs acc =<<
1856 extract_lty t_or_k ty emptyFKTV
1857 HsQualTy { hst_ctxt = ctxt, hst_body = ty }
1858 -> extract_lctxt t_or_k ctxt =<<
1859 extract_lty t_or_k ty acc
1860 XHsType {} -> return acc
1861 -- We deal with these separately in rnLHsTypeWithWildCards
1862 HsWildCardTy {} -> return acc
1863
1864 extract_apps :: TypeOrKind
1865 -> [LHsAppType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars
1866 extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys
1867
1868 extract_app :: TypeOrKind -> LHsAppType GhcPs
1869 -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
1870 extract_app t_or_k (L _ (HsAppInfix _ tv)) acc = extract_tv t_or_k tv acc
1871 extract_app t_or_k (L _ (HsAppPrefix _ ty)) acc = extract_lty t_or_k ty acc
1872 extract_app _ (L _ (XAppType _ )) _ = panic "extract_app"
1873
1874 extractHsTvBndrs :: [LHsTyVarBndr GhcPs]
1875 -> FreeKiTyVarsWithDups -- Free in body
1876 -> RnM FreeKiTyVarsWithDups -- Free in result
1877 extractHsTvBndrs tv_bndrs body_fvs
1878 = extract_hs_tv_bndrs tv_bndrs emptyFKTV body_fvs
1879
1880 extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs]
1881 -> FreeKiTyVarsWithDups -- Accumulator
1882 -> FreeKiTyVarsWithDups -- Free in body
1883 -> RnM FreeKiTyVarsWithDups
1884 -- In (forall (a :: Maybe e). a -> b) we have
1885 -- 'a' is bound by the forall
1886 -- 'b' is a free type variable
1887 -- 'e' is a free kind variable
1888 extract_hs_tv_bndrs tv_bndrs
1889 (FKTV acc_kvs acc_tvs) -- Accumulator
1890 (FKTV body_kvs body_tvs) -- Free in the body
1891 | null tv_bndrs
1892 = return $
1893 FKTV (body_kvs ++ acc_kvs) (body_tvs ++ acc_tvs)
1894 | otherwise
1895 = do { bndr_kvs <- extract_hs_tv_bndrs_kvs tv_bndrs
1896
1897 ; let tv_bndr_rdrs, all_kv_occs :: [Located RdrName]
1898 tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs
1899 -- We must include both kind variables from the binding as well
1900 -- as the body of the `forall` type.
1901 -- See Note [Variables used as both types and kinds].
1902 all_kv_occs = bndr_kvs ++ body_kvs
1903
1904 ; traceRn "checkMixedVars1" $
1905 vcat [ text "bndr_kvs" <+> ppr bndr_kvs
1906 , text "body_kvs" <+> ppr body_kvs
1907 , text "all_kv_occs" <+> ppr all_kv_occs
1908 , text "tv_bndr_rdrs" <+> ppr tv_bndr_rdrs ]
1909 ; checkMixedVars all_kv_occs tv_bndr_rdrs
1910
1911 ; return $
1912 FKTV (filterOut (`elemRdr` tv_bndr_rdrs) all_kv_occs
1913 -- NB: delete all tv_bndr_rdrs from bndr_kvs as well
1914 -- as body_kvs; see Note [Kind variable scoping]
1915 ++ acc_kvs)
1916 (filterOut (`elemRdr` tv_bndr_rdrs) body_tvs ++ acc_tvs) }
1917
1918 extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> RnM [Located RdrName]
1919 -- Returns the free kind variables of any explictly-kinded binders
1920 -- NB: Does /not/ delete the binders themselves.
1921 -- Duplicates are /not/ removed
1922 -- E.g. given [k1, a:k1, b:k2]
1923 -- the function returns [k1,k2], even though k1 is bound here
1924 extract_hs_tv_bndrs_kvs tv_bndrs
1925 = do { fktvs <- foldrM extract_lkind emptyFKTV
1926 [k | L _ (KindedTyVar _ _ k) <- tv_bndrs]
1927 ; return (freeKiTyVarsKindVars fktvs) }
1928 -- There will /be/ no free tyvars!
1929
1930 extract_tv :: TypeOrKind -> Located RdrName
1931 -> FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
1932 extract_tv t_or_k ltv@(L _ tv) acc@(FKTV kvs tvs)
1933 | not (isRdrTyVar tv) = return acc
1934 | isTypeLevel t_or_k = return (FKTV kvs (ltv : tvs))
1935 | otherwise = return (FKTV (ltv : kvs) tvs)
1936
1937 -- just used in this module; seemed convenient here
1938 nubL :: Eq a => [Located a] -> [Located a]
1939 nubL = nubBy eqLocated
1940
1941 elemRdr :: Located RdrName -> [Located RdrName] -> Bool
1942 elemRdr x = any (eqLocated x)
1943
1944 -- Check for type variables that are also used as kinds without the use of
1945 -- -XTypeInType. See Note [Variables used as both types and kinds].
1946 checkMixedVars :: [Located RdrName] -> [Located RdrName] -> RnM ()
1947 checkMixedVars kvs tvs
1948 = do { type_in_type <- xoptM LangExt.TypeInType
1949 ; unless type_in_type $
1950 mapM_ check kvs }
1951 where
1952 check kv = when (kv `elemRdr` tvs) $
1953 addErrAt (getLoc kv) $
1954 vcat [ text "Variable" <+> quotes (ppr kv)
1955 <+> text "used as both a kind and a type"
1956 , text "Did you intend to use TypeInType?" ]