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