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