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