Fix #11648.
[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 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 --------------
430 rnTyKiContext :: RnTyKiEnv -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
431 rnTyKiContext env (L loc cxt)
432 = do { traceRn (text "rncontext" <+> ppr cxt)
433 ; let env' = env { rtke_what = RnConstraint }
434 ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt
435 ; return (L loc cxt', fvs) }
436 where
437
438 rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
439 rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta
440
441 --------------
442 rnLHsTyKi :: RnTyKiEnv -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
443 rnLHsTyKi env (L loc ty)
444 = setSrcSpan loc $
445 do { (ty', fvs) <- rnHsTyKi env ty
446 ; return (L loc ty', fvs) }
447
448 rnHsTyKi :: RnTyKiEnv -> HsType RdrName -> RnM (HsType Name, FreeVars)
449
450 rnHsTyKi env ty@(HsForAllTy { hst_bndrs = tyvars, hst_body = tau })
451 = do { checkTypeInType env ty
452 ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty)
453 Nothing [] tyvars $ \ _ tyvars' _ ->
454 do { (tau', fvs) <- rnLHsTyKi env tau
455 ; return ( HsForAllTy { hst_bndrs = tyvars', hst_body = tau' }
456 , fvs) } }
457
458 rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })
459 = do { checkTypeInType env ty -- See Note [QualTy in kinds]
460 ; (ctxt', fvs1) <- rnTyKiContext env lctxt
461 ; (tau', fvs2) <- rnLHsTyKi env tau
462 ; return (HsQualTy { hst_ctxt = ctxt', hst_body = tau' }
463 , fvs1 `plusFV` fvs2) }
464
465 rnHsTyKi env (HsTyVar (L loc rdr_name))
466 = do { name <- rnTyVar env rdr_name
467 ; return (HsTyVar (L loc name), unitFV name) }
468
469 rnHsTyKi env ty@(HsOpTy ty1 l_op ty2)
470 = setSrcSpan (getLoc l_op) $
471 do { (l_op', fvs1) <- rnHsTyOp env ty l_op
472 ; fix <- lookupTyFixityRn l_op'
473 ; (ty1', fvs2) <- rnLHsTyKi env ty1
474 ; (ty2', fvs3) <- rnLHsTyKi env ty2
475 ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2)
476 (unLoc l_op') fix ty1' ty2'
477 ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }
478
479 rnHsTyKi env (HsParTy ty)
480 = do { (ty', fvs) <- rnLHsTyKi env ty
481 ; return (HsParTy ty', fvs) }
482
483 rnHsTyKi env (HsBangTy b ty)
484 = do { (ty', fvs) <- rnLHsTyKi env ty
485 ; return (HsBangTy b ty', fvs) }
486
487 rnHsTyKi env ty@(HsRecTy flds)
488 = do { let ctxt = rtke_ctxt env
489 ; fls <- get_fields ctxt
490 ; (flds', fvs) <- rnConDeclFields ctxt fls flds
491 ; return (HsRecTy flds', fvs) }
492 where
493 get_fields (ConDeclCtx names)
494 = concatMapM (lookupConstructorFields . unLoc) names
495 get_fields _
496 = do { addErr (hang (text "Record syntax is illegal here:")
497 2 (ppr ty))
498 ; return [] }
499
500 rnHsTyKi env (HsFunTy ty1 ty2)
501 = do { (ty1', fvs1) <- rnLHsTyKi env ty1
502 -- Might find a for-all as the arg of a function type
503 ; (ty2', fvs2) <- rnLHsTyKi env ty2
504 -- Or as the result. This happens when reading Prelude.hi
505 -- when we find return :: forall m. Monad m -> forall a. a -> m a
506
507 -- Check for fixity rearrangements
508 ; res_ty <- mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
509 ; return (res_ty, fvs1 `plusFV` fvs2) }
510
511 rnHsTyKi env listTy@(HsListTy ty)
512 = do { data_kinds <- xoptM LangExt.DataKinds
513 ; when (not data_kinds && isRnKindLevel env)
514 (addErr (dataKindsErr env listTy))
515 ; (ty', fvs) <- rnLHsTyKi env ty
516 ; return (HsListTy ty', fvs) }
517
518 rnHsTyKi env t@(HsKindSig ty k)
519 = do { checkTypeInType env t
520 ; kind_sigs_ok <- xoptM LangExt.KindSignatures
521 ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty)
522 ; (ty', fvs1) <- rnLHsTyKi env ty
523 ; (k', fvs2) <- rnLHsTyKi (env { rtke_level = KindLevel }) k
524 ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) }
525
526 rnHsTyKi env t@(HsPArrTy ty)
527 = do { notInKinds env t
528 ; (ty', fvs) <- rnLHsTyKi env ty
529 ; return (HsPArrTy ty', fvs) }
530
531 -- Unboxed tuples are allowed to have poly-typed arguments. These
532 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
533 rnHsTyKi env tupleTy@(HsTupleTy tup_con tys)
534 = do { data_kinds <- xoptM LangExt.DataKinds
535 ; when (not data_kinds && isRnKindLevel env)
536 (addErr (dataKindsErr env tupleTy))
537 ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
538 ; return (HsTupleTy tup_con tys', fvs) }
539
540 -- Ensure that a type-level integer is nonnegative (#8306, #8412)
541 rnHsTyKi env tyLit@(HsTyLit t)
542 = do { data_kinds <- xoptM LangExt.DataKinds
543 ; unless data_kinds (addErr (dataKindsErr env tyLit))
544 ; when (negLit t) (addErr negLitErr)
545 ; checkTypeInType env tyLit
546 ; return (HsTyLit t, emptyFVs) }
547 where
548 negLit (HsStrTy _ _) = False
549 negLit (HsNumTy _ i) = i < 0
550 negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit
551
552 rnHsTyKi env overall_ty@(HsAppsTy tys)
553 = do { -- Step 1: Break up the HsAppsTy into symbols and non-symbol regions
554 let (non_syms, syms) = splitHsAppsTy tys
555
556 -- Step 2: rename the pieces
557 ; (syms1, fvs1) <- mapFvRn (rnHsTyOp env overall_ty) syms
558 ; (non_syms1, fvs2) <- (mapFvRn . mapFvRn) (rnLHsTyKi env) non_syms
559
560 -- Step 3: deal with *. See Note [Dealing with *]
561 ; let (non_syms2, syms2) = deal_with_star [] [] non_syms1 syms1
562
563 -- Step 4: collapse the non-symbol regions with HsAppTy
564 ; non_syms3 <- mapM deal_with_non_syms non_syms2
565
566 -- Step 5: assemble the pieces, using mkHsOpTyRn
567 ; L _ res_ty <- build_res_ty non_syms3 syms2
568
569 -- all done. Phew.
570 ; return (res_ty, fvs1 `plusFV` fvs2) }
571 where
572 -- See Note [Dealing with *]
573 deal_with_star :: [[LHsType Name]] -> [Located Name]
574 -> [[LHsType Name]] -> [Located Name]
575 -> ([[LHsType Name]], [Located Name])
576 deal_with_star acc1 acc2
577 (non_syms1 : non_syms2 : non_syms) (L loc star : ops)
578 | star `hasKey` starKindTyConKey || star `hasKey` unicodeStarKindTyConKey
579 = deal_with_star acc1 acc2
580 ((non_syms1 ++ L loc (HsTyVar (L loc star)) : non_syms2) : non_syms)
581 ops
582 deal_with_star acc1 acc2 (non_syms1 : non_syms) (op1 : ops)
583 = deal_with_star (non_syms1 : acc1) (op1 : acc2) non_syms ops
584 deal_with_star acc1 acc2 [non_syms] []
585 = (reverse (non_syms : acc1), reverse acc2)
586 deal_with_star _ _ _ _
587 = pprPanic "deal_with_star" (ppr overall_ty)
588
589 -- collapse [LHsType Name] to LHsType Name by making applications
590 -- monadic only for failure
591 deal_with_non_syms :: [LHsType Name] -> RnM (LHsType Name)
592 deal_with_non_syms (non_sym : non_syms) = return $ mkHsAppTys non_sym non_syms
593 deal_with_non_syms [] = failWith (emptyNonSymsErr overall_ty)
594
595 -- assemble a right-biased OpTy for use in mkHsOpTyRn
596 build_res_ty :: [LHsType Name] -> [Located Name] -> RnM (LHsType Name)
597 build_res_ty (arg1 : args) (op1 : ops)
598 = do { rhs <- build_res_ty args ops
599 ; fix <- lookupTyFixityRn op1
600 ; res <-
601 mkHsOpTyRn (\t1 t2 -> HsOpTy t1 op1 t2) (unLoc op1) fix arg1 rhs
602 ; let loc = combineSrcSpans (getLoc arg1) (getLoc rhs)
603 ; return (L loc res)
604 }
605 build_res_ty [arg] [] = return arg
606 build_res_ty _ _ = pprPanic "build_op_ty" (ppr overall_ty)
607
608 rnHsTyKi env (HsAppTy ty1 ty2)
609 = do { (ty1', fvs1) <- rnLHsTyKi env ty1
610 ; (ty2', fvs2) <- rnLHsTyKi env ty2
611 ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) }
612
613 rnHsTyKi env t@(HsIParamTy n ty)
614 = do { notInKinds env t
615 ; (ty', fvs) <- rnLHsTyKi env ty
616 ; return (HsIParamTy n ty', fvs) }
617
618 rnHsTyKi env t@(HsEqTy ty1 ty2)
619 = do { checkTypeInType env t
620 ; (ty1', fvs1) <- rnLHsTyKi env ty1
621 ; (ty2', fvs2) <- rnLHsTyKi env ty2
622 ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) }
623
624 rnHsTyKi _ (HsSpliceTy sp k)
625 = rnSpliceType sp k
626
627 rnHsTyKi env (HsDocTy ty haddock_doc)
628 = do { (ty', fvs) <- rnLHsTyKi env ty
629 ; haddock_doc' <- rnLHsDoc haddock_doc
630 ; return (HsDocTy ty' haddock_doc', fvs) }
631
632 rnHsTyKi _ (HsCoreTy ty)
633 = return (HsCoreTy ty, emptyFVs)
634 -- The emptyFVs probably isn't quite right
635 -- but I don't think it matters
636
637 rnHsTyKi env ty@(HsExplicitListTy k tys)
638 = do { checkTypeInType env ty
639 ; data_kinds <- xoptM LangExt.DataKinds
640 ; unless data_kinds (addErr (dataKindsErr env ty))
641 ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
642 ; return (HsExplicitListTy k tys', fvs) }
643
644 rnHsTyKi env ty@(HsExplicitTupleTy kis tys)
645 = do { checkTypeInType env ty
646 ; data_kinds <- xoptM LangExt.DataKinds
647 ; unless data_kinds (addErr (dataKindsErr env ty))
648 ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
649 ; return (HsExplicitTupleTy kis tys', fvs) }
650
651 rnHsTyKi env (HsWildCardTy wc)
652 = do { checkAnonWildCard env wc
653 ; wc' <- rnAnonWildCard wc
654 ; return (HsWildCardTy wc', emptyFVs) }
655 -- emptyFVs: this occurrence does not refer to a
656 -- user-written binding site, so don't treat
657 -- it as a free variable
658
659 --------------
660 rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name
661 rnTyVar env rdr_name
662 = do { name <- if isRnKindLevel env
663 then lookupKindOccRn rdr_name
664 else lookupTypeOccRn rdr_name
665 ; checkNamedWildCard env name
666 ; return name }
667
668 rnLTyVar :: Located RdrName -> RnM (Located Name)
669 -- Called externally; does not deal with wildards
670 rnLTyVar (L loc rdr_name)
671 = do { tyvar <- lookupTypeOccRn rdr_name
672 ; return (L loc tyvar) }
673
674 --------------
675 rnHsTyOp :: Outputable a
676 => RnTyKiEnv -> a -> Located RdrName -> RnM (Located Name, FreeVars)
677 rnHsTyOp env overall_ty (L loc op)
678 = do { ops_ok <- xoptM LangExt.TypeOperators
679 ; op' <- rnTyVar env op
680 ; unless (ops_ok
681 || op' == starKindTyConName
682 || op' == unicodeStarKindTyConName
683 || op' `hasKey` eqTyConKey) $
684 addErr (opTyErr op overall_ty)
685 ; let l_op' = L loc op'
686 ; return (l_op', unitFV op') }
687
688 --------------
689 notAllowed :: SDoc -> SDoc
690 notAllowed doc
691 = text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed")
692
693 checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM ()
694 checkWildCard env (Just doc)
695 = addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))]
696 checkWildCard _ Nothing
697 = return ()
698
699 checkAnonWildCard :: RnTyKiEnv -> HsWildCardInfo RdrName -> RnM ()
700 -- Report an error if an anonymoous wildcard is illegal here
701 checkAnonWildCard env wc
702 = checkWildCard env mb_bad
703 where
704 mb_bad :: Maybe SDoc
705 mb_bad | not (wildCardsAllowed env)
706 = Just (notAllowed (ppr wc))
707 | otherwise
708 = case rtke_what env of
709 RnTypeBody -> Nothing
710 RnConstraint -> Just constraint_msg
711 RnTopConstraint -> Just constraint_msg
712
713 constraint_msg = hang (notAllowed (ppr wc) <+> text "in a constraint")
714 2 hint_msg
715 hint_msg = vcat [ text "except as the last top-level constraint of a type signature"
716 , nest 2 (text "e.g f :: (Eq a, _) => blah") ]
717
718 checkNamedWildCard :: RnTyKiEnv -> Name -> RnM ()
719 -- Report an error if a named wildcard is illegal here
720 checkNamedWildCard env name
721 = checkWildCard env mb_bad
722 where
723 mb_bad | not (name `elemNameSet` rtke_nwcs env)
724 = Nothing -- Not a wildcard
725 | not (wildCardsAllowed env)
726 = Just (notAllowed (ppr name))
727 | otherwise
728 = case rtke_what env of
729 RnTypeBody -> Nothing -- Allowed
730 RnTopConstraint -> Nothing -- Allowed
731 RnConstraint -> Just constraint_msg
732 constraint_msg = notAllowed (ppr name) <+> text "in a constraint"
733
734 checkExtraConstraintWildCard :: RnTyKiEnv -> HsWildCardInfo RdrName
735 -> RnM ()
736 -- Rename the extra-constraint spot in a type signature
737 -- (blah, _) => type
738 -- Check that extra-constraints are allowed at all, and
739 -- if so that it's an anonymous wildcard
740 checkExtraConstraintWildCard env wc
741 = checkWildCard env mb_bad
742 where
743 mb_bad | not (extraConstraintWildCardsAllowed env)
744 = Just (text "Extra-constraint wildcard" <+> quotes (ppr wc)
745 <+> text "not allowed")
746 | otherwise
747 = Nothing
748
749 extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
750 extraConstraintWildCardsAllowed env
751 = case rtke_ctxt env of
752 TypeSigCtx {} -> True
753 _ -> False
754
755 wildCardsAllowed :: RnTyKiEnv -> Bool
756 -- ^ In what contexts are wildcards permitted
757 wildCardsAllowed env
758 = case rtke_ctxt env of
759 TypeSigCtx {} -> True
760 TypBrCtx {} -> True -- Template Haskell quoted type
761 SpliceTypeCtx {} -> True -- Result of a Template Haskell splice
762 ExprWithTySigCtx {} -> True
763 PatCtx {} -> True
764 RuleCtx {} -> True
765 FamPatCtx {} -> True -- Not named wildcards though
766 GHCiCtx {} -> True
767 HsTypeCtx {} -> True
768 _ -> False
769
770 rnAnonWildCard :: HsWildCardInfo RdrName -> RnM (HsWildCardInfo Name)
771 rnAnonWildCard (AnonWildCard _)
772 = do { loc <- getSrcSpanM
773 ; uniq <- newUnique
774 ; let name = mkInternalName uniq (mkTyVarOcc "_") loc
775 ; return (AnonWildCard (L loc name)) }
776
777 ---------------
778 -- | Ensures either that we're in a type or that -XTypeInType is set
779 checkTypeInType :: Outputable ty
780 => RnTyKiEnv
781 -> ty -- ^ type
782 -> RnM ()
783 checkTypeInType env ty
784 | isRnKindLevel env
785 = do { type_in_type <- xoptM LangExt.TypeInType
786 ; unless type_in_type $
787 addErr (text "Illegal kind:" <+> ppr ty $$
788 text "Did you mean to enable TypeInType?") }
789 checkTypeInType _ _ = return ()
790
791 notInKinds :: Outputable ty
792 => RnTyKiEnv
793 -> ty
794 -> RnM ()
795 notInKinds env ty
796 | isRnKindLevel env
797 = addErr (text "Illegal kind (even with TypeInType enabled):" <+> ppr ty)
798 notInKinds _ _ = return ()
799
800 {- *****************************************************
801 * *
802 Binding type variables
803 * *
804 ***************************************************** -}
805
806 bindSigTyVarsFV :: [Name]
807 -> RnM (a, FreeVars)
808 -> RnM (a, FreeVars)
809 -- Used just before renaming the defn of a function
810 -- with a separate type signature, to bring its tyvars into scope
811 -- With no -XScopedTypeVariables, this is a no-op
812 bindSigTyVarsFV tvs thing_inside
813 = do { scoped_tyvars <- xoptM LangExt.ScopedTypeVariables
814 ; if not scoped_tyvars then
815 thing_inside
816 else
817 bindLocalNamesFV tvs thing_inside }
818
819 -- | Simply bring a bunch of RdrNames into scope. No checking for
820 -- validity, at all. The binding location is taken from the location
821 -- on each name.
822 bindLRdrNames :: [Located RdrName]
823 -> ([Name] -> RnM (a, FreeVars))
824 -> RnM (a, FreeVars)
825 bindLRdrNames rdrs thing_inside
826 = do { var_names <- mapM (newTyVarNameRn Nothing) rdrs
827 ; bindLocalNamesFV var_names $
828 thing_inside var_names }
829
830 ---------------
831 bindHsQTyVars :: forall a b.
832 HsDocContext
833 -> Maybe SDoc -- if we are to check for unused tvs,
834 -- a phrase like "in the type ..."
835 -> Maybe a -- Just _ => an associated type decl
836 -> [Located RdrName] -- Kind variables from scope, in l-to-r
837 -- order, but not from ...
838 -> (LHsQTyVars RdrName) -- ... these user-written tyvars
839 -> (LHsQTyVars Name -> RnM (b, FreeVars))
840 -> RnM (b, FreeVars)
841 -- (a) Bring kind variables into scope
842 -- both (i) passed in (kv_bndrs)
843 -- and (ii) mentioned in the kinds of tv_bndrs
844 -- (b) Bring type variables into scope
845 bindHsQTyVars doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
846 = do { bindLHsTyVarBndrs doc mb_in_doc
847 mb_assoc kv_bndrs (hsQTvExplicit tv_bndrs) $
848 \ rn_kvs rn_bndrs dep_var_set ->
849 thing_inside (HsQTvs { hsq_implicit = rn_kvs
850 , hsq_explicit = rn_bndrs
851 , hsq_dependent = dep_var_set }) }
852
853 bindLHsTyVarBndrs :: forall a b.
854 HsDocContext
855 -> Maybe SDoc -- if we are to check for unused tvs,
856 -- a phrase like "in the type ..."
857 -> Maybe a -- Just _ => an associated type decl
858 -> [Located RdrName] -- Unbound kind variables from scope,
859 -- in l-to-r order, but not from ...
860 -> [LHsTyVarBndr RdrName] -- ... these user-written tyvars
861 -> ( [Name] -- all kv names
862 -> [LHsTyVarBndr Name]
863 -> NameSet -- which names, from the preceding list,
864 -- are used dependently within that list
865 -- See Note [Dependent LHsQTyVars] in TcHsType
866 -> RnM (b, FreeVars))
867 -> RnM (b, FreeVars)
868 bindLHsTyVarBndrs doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside
869 = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
870 ; go [] [] emptyNameSet emptyNameSet emptyNameSet tv_bndrs }
871 where
872 tv_names_w_loc = map hsLTyVarLocName tv_bndrs
873
874 go :: [Name] -- kind-vars found (in reverse order)
875 -> [LHsTyVarBndr Name] -- already renamed (in reverse order)
876 -> NameSet -- kind vars already in scope (for dup checking)
877 -> NameSet -- type vars already in scope (for dup checking)
878 -> NameSet -- (all) variables used dependently
879 -> [LHsTyVarBndr RdrName] -- still to be renamed, scoped
880 -> RnM (b, FreeVars)
881 go rn_kvs rn_tvs kv_names tv_names dep_vars (tv_bndr : tv_bndrs)
882 = bindLHsTyVarBndr doc mb_assoc kv_names tv_names tv_bndr $
883 \ kv_nms used_dependently tv_bndr' ->
884 do { (b, fvs) <- go (reverse kv_nms ++ rn_kvs)
885 (tv_bndr' : rn_tvs)
886 (kv_names `extendNameSetList` kv_nms)
887 (tv_names `extendNameSet` hsLTyVarName tv_bndr')
888 (dep_vars `unionNameSet` used_dependently)
889 tv_bndrs
890 ; warn_unused tv_bndr' fvs
891 ; return (b, fvs) }
892
893 go rn_kvs rn_tvs _kv_names tv_names dep_vars []
894 = -- still need to deal with the kv_bndrs passed in originally
895 bindImplicitKvs doc mb_assoc kv_bndrs tv_names $ \ kv_nms others ->
896 do { let all_rn_kvs = reverse (reverse kv_nms ++ rn_kvs)
897 all_rn_tvs = reverse rn_tvs
898 ; env <- getLocalRdrEnv
899 ; let all_dep_vars = dep_vars `unionNameSet` others
900 exp_dep_vars -- variables in all_rn_tvs that are in dep_vars
901 = mkNameSet [ name
902 | v <- all_rn_tvs
903 , let name = hsLTyVarName v
904 , name `elemNameSet` all_dep_vars ]
905 ; traceRn (text "bindHsTyVars" <+> (ppr env $$
906 ppr all_rn_kvs $$
907 ppr all_rn_tvs $$
908 ppr exp_dep_vars))
909 ; thing_inside all_rn_kvs all_rn_tvs exp_dep_vars }
910
911 warn_unused tv_bndr fvs = case mb_in_doc of
912 Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs
913 Nothing -> return ()
914
915 bindLHsTyVarBndr :: HsDocContext
916 -> Maybe a -- associated class
917 -> NameSet -- kind vars already in scope
918 -> NameSet -- type vars already in scope
919 -> LHsTyVarBndr RdrName
920 -> ([Name] -> NameSet -> LHsTyVarBndr Name -> RnM (b, FreeVars))
921 -- passed the newly-bound implicitly-declared kind vars,
922 -- any other names used in a kind
923 -- and the renamed LHsTyVarBndr
924 -> RnM (b, FreeVars)
925 bindLHsTyVarBndr doc mb_assoc kv_names tv_names hs_tv_bndr thing_inside
926 = case hs_tv_bndr of
927 L loc (UserTyVar lrdr@(L lv rdr)) ->
928 do { check_dup loc rdr
929 ; nm <- newTyVarNameRn mb_assoc lrdr
930 ; bindLocalNamesFV [nm] $
931 thing_inside [] emptyNameSet (L loc (UserTyVar (L lv nm))) }
932 L loc (KindedTyVar lrdr@(L lv rdr) kind) ->
933 do { check_dup lv rdr
934
935 -- check for -XKindSignatures
936 ; sig_ok <- xoptM LangExt.KindSignatures
937 ; unless sig_ok (badKindSigErr doc kind)
938
939 -- deal with kind vars in the user-written kind
940 ; free_kvs <- freeKiTyVarsAllVars <$> extractHsTyRdrTyVars kind
941 ; bindImplicitKvs doc mb_assoc free_kvs tv_names $
942 \ new_kv_nms other_kv_nms ->
943 do { (kind', fvs1) <- rnLHsKind doc kind
944 ; tv_nm <- newTyVarNameRn mb_assoc lrdr
945 ; (b, fvs2) <- bindLocalNamesFV [tv_nm] $
946 thing_inside new_kv_nms other_kv_nms
947 (L loc (KindedTyVar (L lv tv_nm) kind'))
948 ; return (b, fvs1 `plusFV` fvs2) }}
949 where
950 -- make sure that the RdrName isn't in the sets of
951 -- names. We can't just check that it's not in scope at all
952 -- because we might be inside an associated class.
953 check_dup :: SrcSpan -> RdrName -> RnM ()
954 check_dup loc rdr
955 = do { m_name <- lookupLocalOccRn_maybe rdr
956 ; whenIsJust m_name $ \name ->
957 do { when (name `elemNameSet` kv_names) $
958 addErrAt loc (vcat [ ki_ty_err_msg name
959 , pprHsDocContext doc ])
960 ; when (name `elemNameSet` tv_names) $
961 dupNamesErr getLoc [L loc name, L (nameSrcSpan name) name] }}
962
963 ki_ty_err_msg n = text "Variable" <+> quotes (ppr n) <+>
964 text "used as a kind variable before being bound" $$
965 text "as a type variable. Perhaps reorder your variables?"
966
967
968 bindImplicitKvs :: HsDocContext
969 -> Maybe a
970 -> [Located RdrName] -- ^ kind var *occurrences*, from which
971 -- intent to bind is inferred
972 -> NameSet -- ^ *type* variables, for type/kind
973 -- misuse check for -XNoTypeInType
974 -> ([Name] -> NameSet -> RnM (b, FreeVars))
975 -- ^ passed new kv_names, and any other names used in a kind
976 -> RnM (b, FreeVars)
977 bindImplicitKvs _ _ [] _ thing_inside
978 = thing_inside [] emptyNameSet
979 bindImplicitKvs doc mb_assoc free_kvs tv_names thing_inside
980 = do { rdr_env <- getLocalRdrEnv
981 ; let part_kvs lrdr@(L loc kv_rdr)
982 = case lookupLocalRdrEnv rdr_env kv_rdr of
983 Just kv_name -> Left (L loc kv_name)
984 _ -> Right lrdr
985 (bound_kvs, new_kvs) = partitionWith part_kvs free_kvs
986
987 -- check whether we're mixing types & kinds illegally
988 ; type_in_type <- xoptM LangExt.TypeInType
989 ; unless type_in_type $
990 mapM_ (check_tv_used_in_kind tv_names) bound_kvs
991
992 ; poly_kinds <- xoptM LangExt.PolyKinds
993 ; unless poly_kinds $
994 addErr (badKindBndrs doc new_kvs)
995
996 -- bind the vars and move on
997 ; kv_nms <- mapM (newTyVarNameRn mb_assoc) new_kvs
998 ; bindLocalNamesFV kv_nms $
999 thing_inside kv_nms (mkNameSet (map unLoc bound_kvs)) }
1000 where
1001 -- check to see if the variables free in a kind are bound as type
1002 -- variables. Assume -XNoTypeInType.
1003 check_tv_used_in_kind :: NameSet -- ^ *type* variables
1004 -> Located Name -- ^ renamed var used in kind
1005 -> RnM ()
1006 check_tv_used_in_kind tv_names (L loc kv_name)
1007 = when (kv_name `elemNameSet` tv_names) $
1008 addErrAt loc (vcat [ text "Type variable" <+> quotes (ppr kv_name) <+>
1009 text "used in a kind." $$
1010 text "Did you mean to use TypeInType?"
1011 , pprHsDocContext doc ])
1012
1013
1014 newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name
1015 newTyVarNameRn mb_assoc (L loc rdr)
1016 = do { rdr_env <- getLocalRdrEnv
1017 ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of
1018 (Just _, Just n) -> return n
1019 -- Use the same Name as the parent class decl
1020
1021 _ -> newLocalBndrRn (L loc rdr) }
1022
1023 ---------------------
1024 collectAnonWildCards :: LHsType Name -> [Name]
1025 -- | Extract all wild cards from a type.
1026 collectAnonWildCards lty = go lty
1027 where
1028 go (L _ ty) = case ty of
1029 HsWildCardTy (AnonWildCard (L _ wc)) -> [wc]
1030 HsAppsTy tys -> gos (mapMaybe (prefix_types_only . unLoc) tys)
1031 HsAppTy ty1 ty2 -> go ty1 `mappend` go ty2
1032 HsFunTy ty1 ty2 -> go ty1 `mappend` go ty2
1033 HsListTy ty -> go ty
1034 HsPArrTy ty -> go ty
1035 HsTupleTy _ tys -> gos tys
1036 HsOpTy ty1 _ ty2 -> go ty1 `mappend` go ty2
1037 HsParTy ty -> go ty
1038 HsIParamTy _ ty -> go ty
1039 HsEqTy ty1 ty2 -> go ty1 `mappend` go ty2
1040 HsKindSig ty kind -> go ty `mappend` go kind
1041 HsDocTy ty _ -> go ty
1042 HsBangTy _ ty -> go ty
1043 HsRecTy flds -> gos $ map (cd_fld_type . unLoc) flds
1044 HsExplicitListTy _ tys -> gos tys
1045 HsExplicitTupleTy _ tys -> gos tys
1046 HsForAllTy { hst_body = ty } -> go ty
1047 HsQualTy { hst_ctxt = L _ ctxt
1048 , hst_body = ty } -> gos ctxt `mappend` go ty
1049 -- HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit
1050 _ -> mempty
1051
1052 gos = mconcat . map go
1053
1054 prefix_types_only (HsAppPrefix ty) = Just ty
1055 prefix_types_only (HsAppInfix _) = Nothing
1056
1057 collectAnonWildCardsBndrs :: [LHsTyVarBndr Name] -> [Name]
1058 collectAnonWildCardsBndrs ltvs = concatMap (go . unLoc) ltvs
1059 where
1060 go (UserTyVar _) = []
1061 go (KindedTyVar _ ki) = collectAnonWildCards ki
1062
1063 {-
1064 *********************************************************
1065 * *
1066 ConDeclField
1067 * *
1068 *********************************************************
1069
1070 When renaming a ConDeclField, we have to find the FieldLabel
1071 associated with each field. But we already have all the FieldLabels
1072 available (since they were brought into scope by
1073 RnNames.getLocalNonValBinders), so we just take the list as an
1074 argument, build a map and look them up.
1075 -}
1076
1077 rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField RdrName]
1078 -> RnM ([LConDeclField Name], FreeVars)
1079 -- Also called from RnSource
1080 -- No wildcards can appear in record fields
1081 rnConDeclFields ctxt fls fields
1082 = mapFvRn (rnField fl_env env) fields
1083 where
1084 env = mkTyKiEnv ctxt TypeLevel RnTypeBody
1085 fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]
1086
1087 rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField RdrName
1088 -> RnM (LConDeclField Name, FreeVars)
1089 rnField fl_env env (L l (ConDeclField names ty haddock_doc))
1090 = do { let new_names = map (fmap lookupField) names
1091 ; (new_ty, fvs) <- rnLHsTyKi env ty
1092 ; new_haddock_doc <- rnMbLHsDoc haddock_doc
1093 ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
1094 where
1095 lookupField :: FieldOcc RdrName -> FieldOcc Name
1096 lookupField (FieldOcc (L lr rdr) _) = FieldOcc (L lr rdr) (flSelector fl)
1097 where
1098 lbl = occNameFS $ rdrNameOcc rdr
1099 fl = expectJust "rnField" $ lookupFsEnv fl_env lbl
1100
1101 {-
1102 ************************************************************************
1103 * *
1104 Fixities and precedence parsing
1105 * *
1106 ************************************************************************
1107
1108 @mkOpAppRn@ deals with operator fixities. The argument expressions
1109 are assumed to be already correctly arranged. It needs the fixities
1110 recorded in the OpApp nodes, because fixity info applies to the things
1111 the programmer actually wrote, so you can't find it out from the Name.
1112
1113 Furthermore, the second argument is guaranteed not to be another
1114 operator application. Why? Because the parser parses all
1115 operator appications left-associatively, EXCEPT negation, which
1116 we need to handle specially.
1117 Infix types are read in a *right-associative* way, so that
1118 a `op` b `op` c
1119 is always read in as
1120 a `op` (b `op` c)
1121
1122 mkHsOpTyRn rearranges where necessary. The two arguments
1123 have already been renamed and rearranged. It's made rather tiresome
1124 by the presence of ->, which is a separate syntactic construct.
1125 -}
1126
1127 ---------------
1128 -- Building (ty1 `op1` (ty21 `op2` ty22))
1129 mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
1130 -> Name -> Fixity -> LHsType Name -> LHsType Name
1131 -> RnM (HsType Name)
1132
1133 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
1134 = do { fix2 <- lookupTyFixityRn op2
1135 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
1136 (\t1 t2 -> HsOpTy t1 op2 t2)
1137 (unLoc op2) fix2 ty21 ty22 loc2 }
1138
1139 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
1140 = mk_hs_op_ty mk1 pp_op1 fix1 ty1
1141 HsFunTy funTyConName funTyFixity ty21 ty22 loc2
1142
1143 mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment
1144 = return (mk1 ty1 ty2)
1145
1146 ---------------
1147 mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
1148 -> Name -> Fixity -> LHsType Name
1149 -> (LHsType Name -> LHsType Name -> HsType Name)
1150 -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
1151 -> RnM (HsType Name)
1152 mk_hs_op_ty mk1 op1 fix1 ty1
1153 mk2 op2 fix2 ty21 ty22 loc2
1154 | nofix_error = do { precParseErr (op1,fix1) (op2,fix2)
1155 ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
1156 | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
1157 | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
1158 new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
1159 ; return (mk2 (noLoc new_ty) ty22) }
1160 where
1161 (nofix_error, associate_right) = compareFixity fix1 fix2
1162
1163
1164 ---------------------------
1165 mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged
1166 -> LHsExpr Name -> Fixity -- Operator and fixity
1167 -> LHsExpr Name -- Right operand (not an OpApp, but might
1168 -- be a NegApp)
1169 -> RnM (HsExpr Name)
1170
1171 -- (e11 `op1` e12) `op2` e2
1172 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
1173 | nofix_error
1174 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
1175 return (OpApp e1 op2 fix2 e2)
1176
1177 | associate_right = do
1178 new_e <- mkOpAppRn e12 op2 fix2 e2
1179 return (OpApp e11 op1 fix1 (L loc' new_e))
1180 where
1181 loc'= combineLocs e12 e2
1182 (nofix_error, associate_right) = compareFixity fix1 fix2
1183
1184 ---------------------------
1185 -- (- neg_arg) `op` e2
1186 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
1187 | nofix_error
1188 = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
1189 return (OpApp e1 op2 fix2 e2)
1190
1191 | associate_right
1192 = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
1193 return (NegApp (L loc' new_e) neg_name)
1194 where
1195 loc' = combineLocs neg_arg e2
1196 (nofix_error, associate_right) = compareFixity negateFixity fix2
1197
1198 ---------------------------
1199 -- e1 `op` - neg_arg
1200 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right
1201 | not associate_right -- We *want* right association
1202 = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
1203 return (OpApp e1 op1 fix1 e2)
1204 where
1205 (_, associate_right) = compareFixity fix1 negateFixity
1206
1207 ---------------------------
1208 -- Default case
1209 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
1210 = ASSERT2( right_op_ok fix (unLoc e2),
1211 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
1212 )
1213 return (OpApp e1 op fix e2)
1214
1215 ----------------------------
1216 get_op :: LHsExpr Name -> Name
1217 -- An unbound name could be either HsVar or HsUnboundVar
1218 -- See RnExpr.rnUnboundVar
1219 get_op (L _ (HsVar (L _ n))) = n
1220 get_op (L _ (HsUnboundVar occ)) = mkUnboundName occ
1221 get_op other = pprPanic "get_op" (ppr other)
1222
1223 -- Parser left-associates everything, but
1224 -- derived instances may have correctly-associated things to
1225 -- in the right operarand. So we just check that the right operand is OK
1226 right_op_ok :: Fixity -> HsExpr Name -> Bool
1227 right_op_ok fix1 (OpApp _ _ fix2 _)
1228 = not error_please && associate_right
1229 where
1230 (error_please, associate_right) = compareFixity fix1 fix2
1231 right_op_ok _ _
1232 = True
1233
1234 -- Parser initially makes negation bind more tightly than any other operator
1235 -- And "deriving" code should respect this (use HsPar if not)
1236 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
1237 mkNegAppRn neg_arg neg_name
1238 = ASSERT( not_op_app (unLoc neg_arg) )
1239 return (NegApp neg_arg neg_name)
1240
1241 not_op_app :: HsExpr id -> Bool
1242 not_op_app (OpApp _ _ _ _) = False
1243 not_op_app _ = True
1244
1245 ---------------------------
1246 mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged
1247 -> LHsExpr Name -> Fixity -- Operator and fixity
1248 -> LHsCmdTop Name -- Right operand (not an infix)
1249 -> RnM (HsCmd Name)
1250
1251 -- (e11 `op1` e12) `op2` e2
1252 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _))
1253 op2 fix2 a2
1254 | nofix_error
1255 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
1256 return (HsCmdArrForm op2 (Just fix2) [a1, a2])
1257
1258 | associate_right
1259 = do new_c <- mkOpFormRn a12 op2 fix2 a2
1260 return (HsCmdArrForm op1 (Just fix1)
1261 [a11, L loc (HsCmdTop (L loc new_c)
1262 placeHolderType placeHolderType [])])
1263 -- TODO: locs are wrong
1264 where
1265 (nofix_error, associate_right) = compareFixity fix1 fix2
1266
1267 -- Default case
1268 mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
1269 = return (HsCmdArrForm op (Just fix) [arg1, arg2])
1270
1271
1272 --------------------------------------
1273 mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
1274 -> RnM (Pat Name)
1275
1276 mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
1277 = do { fix1 <- lookupFixityRn (unLoc op1)
1278 ; let (nofix_error, associate_right) = compareFixity fix1 fix2
1279
1280 ; if nofix_error then do
1281 { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
1282 ; return (ConPatIn op2 (InfixCon p1 p2)) }
1283
1284 else if associate_right then do
1285 { new_p <- mkConOpPatRn op2 fix2 p12 p2
1286 ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
1287 else return (ConPatIn op2 (InfixCon p1 p2)) }
1288
1289 mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment
1290 = ASSERT( not_op_pat (unLoc p2) )
1291 return (ConPatIn op (InfixCon p1 p2))
1292
1293 not_op_pat :: Pat Name -> Bool
1294 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
1295 not_op_pat _ = True
1296
1297 --------------------------------------
1298 checkPrecMatch :: Name -> MatchGroup Name body -> RnM ()
1299 -- Check precedence of a function binding written infix
1300 -- eg a `op` b `C` c = ...
1301 -- See comments with rnExpr (OpApp ...) about "deriving"
1302
1303 checkPrecMatch op (MG { mg_alts = L _ ms })
1304 = mapM_ check ms
1305 where
1306 check (L _ (Match _ (L l1 p1 : L l2 p2 :_) _ _))
1307 = setSrcSpan (combineSrcSpans l1 l2) $
1308 do checkPrec op p1 False
1309 checkPrec op p2 True
1310
1311 check _ = return ()
1312 -- This can happen. Consider
1313 -- a `op` True = ...
1314 -- op = ...
1315 -- The infix flag comes from the first binding of the group
1316 -- but the second eqn has no args (an error, but not discovered
1317 -- until the type checker). So we don't want to crash on the
1318 -- second eqn.
1319
1320 checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
1321 checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
1322 op_fix@(Fixity _ op_prec op_dir) <- lookupFixityRn op
1323 op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
1324 let
1325 inf_ok = op1_prec > op_prec ||
1326 (op1_prec == op_prec &&
1327 (op1_dir == InfixR && op_dir == InfixR && right ||
1328 op1_dir == InfixL && op_dir == InfixL && not right))
1329
1330 info = (op, op_fix)
1331 info1 = (unLoc op1, op1_fix)
1332 (infol, infor) = if right then (info, info1) else (info1, info)
1333 unless inf_ok (precParseErr infol infor)
1334
1335 checkPrec _ _ _
1336 = return ()
1337
1338 -- Check precedence of (arg op) or (op arg) respectively
1339 -- If arg is itself an operator application, then either
1340 -- (a) its precedence must be higher than that of op
1341 -- (b) its precedency & associativity must be the same as that of op
1342 checkSectionPrec :: FixityDirection -> HsExpr RdrName
1343 -> LHsExpr Name -> LHsExpr Name -> RnM ()
1344 checkSectionPrec direction section op arg
1345 = case unLoc arg of
1346 OpApp _ op fix _ -> go_for_it (get_op op) fix
1347 NegApp _ _ -> go_for_it negateName negateFixity
1348 _ -> return ()
1349 where
1350 op_name = get_op op
1351 go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do
1352 op_fix@(Fixity _ op_prec _) <- lookupFixityRn op_name
1353 unless (op_prec < arg_prec
1354 || (op_prec == arg_prec && direction == assoc))
1355 (sectionPrecErr (op_name, op_fix)
1356 (arg_op, arg_fix) section)
1357
1358 -- Precedence-related error messages
1359
1360 precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
1361 precParseErr op1@(n1,_) op2@(n2,_)
1362 | isUnboundName n1 || isUnboundName n2
1363 = return () -- Avoid error cascade
1364 | otherwise
1365 = addErr $ hang (text "Precedence parsing error")
1366 4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"),
1367 ppr_opfix op2,
1368 text "in the same infix expression"])
1369
1370 sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
1371 sectionPrecErr op@(n1,_) arg_op@(n2,_) section
1372 | isUnboundName n1 || isUnboundName n2
1373 = return () -- Avoid error cascade
1374 | otherwise
1375 = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"),
1376 nest 4 (sep [text "must have lower precedence than that of the operand,",
1377 nest 2 (text "namely" <+> ppr_opfix arg_op)]),
1378 nest 4 (text "in the section:" <+> quotes (ppr section))]
1379
1380 ppr_opfix :: (Name, Fixity) -> SDoc
1381 ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
1382 where
1383 pp_op | op == negateName = text "prefix `-'"
1384 | otherwise = quotes (ppr op)
1385
1386 {- *****************************************************
1387 * *
1388 Errors
1389 * *
1390 ***************************************************** -}
1391
1392 badKindBndrs :: HsDocContext -> [Located RdrName] -> SDoc
1393 badKindBndrs doc kvs
1394 = withHsDocContext doc $
1395 hang (text "Unexpected kind variable" <> plural kvs
1396 <+> pprQuotedList kvs)
1397 2 (text "Perhaps you intended to use PolyKinds")
1398
1399 badKindSigErr :: HsDocContext -> LHsType RdrName -> TcM ()
1400 badKindSigErr doc (L loc ty)
1401 = setSrcSpan loc $ addErr $
1402 withHsDocContext doc $
1403 hang (text "Illegal kind signature:" <+> quotes (ppr ty))
1404 2 (text "Perhaps you intended to use KindSignatures")
1405
1406 dataKindsErr :: RnTyKiEnv -> HsType RdrName -> SDoc
1407 dataKindsErr env thing
1408 = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing))
1409 2 (text "Perhaps you intended to use DataKinds")
1410 where
1411 pp_what | isRnKindLevel env = text "kind"
1412 | otherwise = text "type"
1413
1414 inTypeDoc :: HsType RdrName -> SDoc
1415 inTypeDoc ty = text "In the type" <+> quotes (ppr ty)
1416
1417 warnUnusedForAll :: SDoc -> LHsTyVarBndr Name -> FreeVars -> TcM ()
1418 warnUnusedForAll in_doc (L loc tv) used_names
1419 = whenWOptM Opt_WarnUnusedForalls $
1420 unless (hsTyVarName tv `elemNameSet` used_names) $
1421 addWarnAt (Reason Opt_WarnUnusedForalls) loc $
1422 vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)
1423 , in_doc ]
1424
1425 opTyErr :: Outputable a => RdrName -> a -> SDoc
1426 opTyErr op overall_ty
1427 = hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty))
1428 2 extra
1429 where
1430 extra | op == dot_tv_RDR
1431 = perhapsForallMsg
1432 | otherwise
1433 = text "Use TypeOperators to allow operators in types"
1434
1435 emptyNonSymsErr :: HsType RdrName -> SDoc
1436 emptyNonSymsErr overall_ty
1437 = text "Operator applied to too few arguments:" <+> ppr overall_ty
1438
1439 {-
1440 ************************************************************************
1441 * *
1442 Finding the free type variables of a (HsType RdrName)
1443 * *
1444 ************************************************************************
1445
1446
1447 Note [Kind and type-variable binders]
1448 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1449 In a type signature we may implicitly bind type variable and, more
1450 recently, kind variables. For example:
1451 * f :: a -> a
1452 f = ...
1453 Here we need to find the free type variables of (a -> a),
1454 so that we know what to quantify
1455
1456 * class C (a :: k) where ...
1457 This binds 'k' in ..., as well as 'a'
1458
1459 * f (x :: a -> [a]) = ....
1460 Here we bind 'a' in ....
1461
1462 * f (x :: T a -> T (b :: k)) = ...
1463 Here we bind both 'a' and the kind variable 'k'
1464
1465 * type instance F (T (a :: Maybe k)) = ...a...k...
1466 Here we want to constrain the kind of 'a', and bind 'k'.
1467
1468 In general we want to walk over a type, and find
1469 * Its free type variables
1470 * The free kind variables of any kind signatures in the type
1471
1472 Hence we returns a pair (kind-vars, type vars)
1473 See also Note [HsBSig binder lists] in HsTypes
1474 -}
1475
1476 data FreeKiTyVars = FKTV { fktv_kis :: [Located RdrName]
1477 , _fktv_k_set :: OccSet -- for efficiency,
1478 -- only used internally
1479 , fktv_tys :: [Located RdrName]
1480 , _fktv_t_set :: OccSet
1481 , fktv_all :: [Located RdrName] }
1482
1483 instance Outputable FreeKiTyVars where
1484 ppr (FKTV kis _ tys _ _) = ppr (kis, tys)
1485
1486 emptyFKTV :: FreeKiTyVars
1487 emptyFKTV = FKTV [] emptyOccSet [] emptyOccSet []
1488
1489 freeKiTyVarsAllVars :: FreeKiTyVars -> [Located RdrName]
1490 freeKiTyVarsAllVars = fktv_all
1491
1492 freeKiTyVarsKindVars :: FreeKiTyVars -> [Located RdrName]
1493 freeKiTyVarsKindVars = fktv_kis
1494
1495 freeKiTyVarsTypeVars :: FreeKiTyVars -> [Located RdrName]
1496 freeKiTyVarsTypeVars = fktv_tys
1497
1498 filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
1499 filterInScope rdr_env (FKTV kis k_set tys t_set all)
1500 = FKTV (filterOut in_scope kis)
1501 (filterOccSet (not . in_scope_occ) k_set)
1502 (filterOut in_scope tys)
1503 (filterOccSet (not . in_scope_occ) t_set)
1504 (filterOut in_scope all)
1505 where
1506 in_scope = inScope rdr_env . unLoc
1507 in_scope_occ occ = isJust $ lookupLocalRdrOcc rdr_env occ
1508
1509 inScope :: LocalRdrEnv -> RdrName -> Bool
1510 inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env
1511
1512 extractHsTyRdrTyVars :: LHsType RdrName -> RnM FreeKiTyVars
1513 -- extractHsTyRdrNames finds the free (kind, type) variables of a HsType
1514 -- or the free (sort, kind) variables of a HsKind
1515 -- It's used when making the for-alls explicit.
1516 -- Does not return any wildcards
1517 -- When the same name occurs multiple times in the types, only the first
1518 -- occurence is returned.
1519 -- See Note [Kind and type-variable binders]
1520 extractHsTyRdrTyVars ty
1521 = do { FKTV kis k_set tys t_set all <- extract_lty TypeLevel ty emptyFKTV
1522 ; return (FKTV (nubL kis) k_set
1523 (nubL tys) t_set
1524 (nubL all)) }
1525
1526 -- | Extracts free type and kind variables from types in a list.
1527 -- When the same name occurs multiple times in the types, only the first
1528 -- occurence is returned and the rest is filtered out.
1529 -- See Note [Kind and type-variable binders]
1530 extractHsTysRdrTyVars :: [LHsType RdrName] -> RnM FreeKiTyVars
1531 extractHsTysRdrTyVars tys
1532 = rmDupsInRdrTyVars <$> extractHsTysRdrTyVarsDups tys
1533
1534 -- | Extracts free type and kind variables from types in a list.
1535 -- When the same name occurs multiple times in the types, all occurences
1536 -- are returned.
1537 extractHsTysRdrTyVarsDups :: [LHsType RdrName] -> RnM FreeKiTyVars
1538 extractHsTysRdrTyVarsDups tys
1539 = extract_ltys TypeLevel tys emptyFKTV
1540
1541 -- | Removes multiple occurences of the same name from FreeKiTyVars.
1542 rmDupsInRdrTyVars :: FreeKiTyVars -> FreeKiTyVars
1543 rmDupsInRdrTyVars (FKTV kis k_set tys t_set all)
1544 = FKTV (nubL kis) k_set (nubL tys) t_set (nubL all)
1545
1546 extractRdrKindSigVars :: LFamilyResultSig RdrName -> RnM [Located RdrName]
1547 extractRdrKindSigVars (L _ resultSig)
1548 | KindSig k <- resultSig = kindRdrNameFromSig k
1549 | TyVarSig (L _ (KindedTyVar _ k)) <- resultSig = kindRdrNameFromSig k
1550 | otherwise = return []
1551 where kindRdrNameFromSig k = freeKiTyVarsAllVars <$> extractHsTyRdrTyVars k
1552
1553 extractDataDefnKindVars :: HsDataDefn RdrName -> RnM [Located RdrName]
1554 -- Get the scoped kind variables mentioned free in the constructor decls
1555 -- Eg data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
1556 -- Here k should scope over the whole definition
1557 extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
1558 , dd_cons = cons, dd_derivs = derivs })
1559 = (nubL . freeKiTyVarsKindVars) <$>
1560 (extract_lctxt TypeLevel ctxt =<<
1561 extract_mb extract_lkind ksig =<<
1562 extract_mb (extract_sig_tys . unLoc) derivs =<<
1563 foldrM (extract_con . unLoc) emptyFKTV cons)
1564 where
1565 extract_con (ConDeclGADT { }) acc = return acc
1566 extract_con (ConDeclH98 { con_qvars = qvs
1567 , con_cxt = ctxt, con_details = details }) acc
1568 = extract_hs_tv_bndrs (maybe [] hsQTvExplicit qvs) acc =<<
1569 extract_mlctxt ctxt =<<
1570 extract_ltys TypeLevel (hsConDeclArgTys details) emptyFKTV
1571
1572 extract_mlctxt :: Maybe (LHsContext RdrName) -> FreeKiTyVars -> RnM FreeKiTyVars
1573 extract_mlctxt Nothing acc = return acc
1574 extract_mlctxt (Just ctxt) acc = extract_lctxt TypeLevel ctxt acc
1575
1576 extract_lctxt :: TypeOrKind
1577 -> LHsContext RdrName -> FreeKiTyVars -> RnM FreeKiTyVars
1578 extract_lctxt t_or_k ctxt = extract_ltys t_or_k (unLoc ctxt)
1579
1580 extract_sig_tys :: [LHsSigType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars
1581 extract_sig_tys sig_tys acc
1582 = foldrM (\sig_ty acc -> extract_lty TypeLevel (hsSigType sig_ty) acc)
1583 acc sig_tys
1584
1585 extract_ltys :: TypeOrKind
1586 -> [LHsType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars
1587 extract_ltys t_or_k tys acc = foldrM (extract_lty t_or_k) acc tys
1588
1589 extract_mb :: (a -> FreeKiTyVars -> RnM FreeKiTyVars)
1590 -> Maybe a -> FreeKiTyVars -> RnM FreeKiTyVars
1591 extract_mb _ Nothing acc = return acc
1592 extract_mb f (Just x) acc = f x acc
1593
1594 extract_lkind :: LHsType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars
1595 extract_lkind = extract_lty KindLevel
1596
1597 extract_lty :: TypeOrKind -> LHsType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars
1598 extract_lty t_or_k (L _ ty) acc
1599 = case ty of
1600 HsTyVar ltv -> extract_tv t_or_k ltv acc
1601 HsBangTy _ ty -> extract_lty t_or_k ty acc
1602 HsRecTy flds -> foldrM (extract_lty t_or_k
1603 . cd_fld_type . unLoc) acc
1604 flds
1605 HsAppsTy tys -> extract_apps t_or_k tys acc
1606 HsAppTy ty1 ty2 -> extract_lty t_or_k ty1 =<<
1607 extract_lty t_or_k ty2 acc
1608 HsListTy ty -> extract_lty t_or_k ty acc
1609 HsPArrTy ty -> extract_lty t_or_k ty acc
1610 HsTupleTy _ tys -> extract_ltys t_or_k tys acc
1611 HsFunTy ty1 ty2 -> extract_lty t_or_k ty1 =<<
1612 extract_lty t_or_k ty2 acc
1613 HsIParamTy _ ty -> extract_lty t_or_k ty acc
1614 HsEqTy ty1 ty2 -> extract_lty t_or_k ty1 =<<
1615 extract_lty t_or_k ty2 acc
1616 HsOpTy ty1 tv ty2 -> extract_tv t_or_k tv =<<
1617 extract_lty t_or_k ty1 =<<
1618 extract_lty t_or_k ty2 acc
1619 HsParTy ty -> extract_lty t_or_k ty acc
1620 HsCoreTy {} -> return acc -- The type is closed
1621 HsSpliceTy {} -> return acc -- Type splices mention no tvs
1622 HsDocTy ty _ -> extract_lty t_or_k ty acc
1623 HsExplicitListTy _ tys -> extract_ltys t_or_k tys acc
1624 HsExplicitTupleTy _ tys -> extract_ltys t_or_k tys acc
1625 HsTyLit _ -> return acc
1626 HsKindSig ty ki -> extract_lty t_or_k ty =<<
1627 extract_lkind ki acc
1628 HsForAllTy { hst_bndrs = tvs, hst_body = ty }
1629 -> extract_hs_tv_bndrs tvs acc =<<
1630 extract_lty t_or_k ty emptyFKTV
1631 HsQualTy { hst_ctxt = ctxt, hst_body = ty }
1632 -> extract_lctxt t_or_k ctxt =<<
1633 extract_lty t_or_k ty acc
1634 -- We deal with these separately in rnLHsTypeWithWildCards
1635 HsWildCardTy {} -> return acc
1636
1637 extract_apps :: TypeOrKind
1638 -> [LHsAppType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars
1639 extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys
1640
1641 extract_app :: TypeOrKind -> LHsAppType RdrName -> FreeKiTyVars
1642 -> RnM FreeKiTyVars
1643 extract_app t_or_k (L _ (HsAppInfix tv)) acc = extract_tv t_or_k tv acc
1644 extract_app t_or_k (L _ (HsAppPrefix ty)) acc = extract_lty t_or_k ty acc
1645
1646 extract_hs_tv_bndrs :: [LHsTyVarBndr RdrName] -> FreeKiTyVars
1647 -> FreeKiTyVars -> RnM FreeKiTyVars
1648 -- In (forall (a :: Maybe e). a -> b) we have
1649 -- 'a' is bound by the forall
1650 -- 'b' is a free type variable
1651 -- 'e' is a free kind variable
1652 extract_hs_tv_bndrs tvs
1653 (FKTV acc_kvs acc_k_set acc_tvs acc_t_set acc_all)
1654 -- Note accumulator comes first
1655 (FKTV body_kvs body_k_set body_tvs body_t_set body_all)
1656 | null tvs
1657 = return $
1658 FKTV (body_kvs ++ acc_kvs) (body_k_set `unionOccSets` acc_k_set)
1659 (body_tvs ++ acc_tvs) (body_t_set `unionOccSets` acc_t_set)
1660 (body_all ++ acc_all)
1661 | otherwise
1662 = do { FKTV bndr_kvs bndr_k_set _ _ _
1663 <- foldrM extract_lkind emptyFKTV [k | L _ (KindedTyVar _ k) <- tvs]
1664
1665 ; let locals = mkOccSet $ map (rdrNameOcc . hsLTyVarName) tvs
1666 ; return $
1667 FKTV (filterOut ((`elemOccSet` locals) . rdrNameOcc . unLoc) (bndr_kvs ++ body_kvs) ++ acc_kvs)
1668 ((body_k_set `minusOccSet` locals) `unionOccSets` acc_k_set `unionOccSets` bndr_k_set)
1669 (filterOut ((`elemOccSet` locals) . rdrNameOcc . unLoc) body_tvs ++ acc_tvs)
1670 ((body_t_set `minusOccSet` locals) `unionOccSets` acc_t_set)
1671 (filterOut ((`elemOccSet` locals) . rdrNameOcc . unLoc) (bndr_kvs ++ body_all) ++ acc_all) }
1672
1673 extract_tv :: TypeOrKind -> Located RdrName -> FreeKiTyVars -> RnM FreeKiTyVars
1674 extract_tv t_or_k ltv@(L _ tv) acc
1675 | isRdrTyVar tv = case acc of
1676 FKTV kvs k_set tvs t_set all
1677 | isTypeLevel t_or_k
1678 -> do { when (occ `elemOccSet` k_set) $
1679 mixedVarsErr ltv
1680 ; return (FKTV kvs k_set (ltv : tvs) (t_set `extendOccSet` occ)
1681 (ltv : all)) }
1682 | otherwise
1683 -> do { when (occ `elemOccSet` t_set) $
1684 mixedVarsErr ltv
1685 ; return (FKTV (ltv : kvs) (k_set `extendOccSet` occ) tvs t_set
1686 (ltv : all)) }
1687 | otherwise = return acc
1688 where
1689 occ = rdrNameOcc tv
1690
1691 mixedVarsErr :: Located RdrName -> RnM ()
1692 mixedVarsErr (L loc tv)
1693 = do { typeintype <- xoptM LangExt.TypeInType
1694 ; unless typeintype $
1695 addErrAt loc $ text "Variable" <+> quotes (ppr tv) <+>
1696 text "used as both a kind and a type" $$
1697 text "Did you intend to use TypeInType?" }
1698
1699 -- just used in this module; seemed convenient here
1700 nubL :: Eq a => [Located a] -> [Located a]
1701 nubL = nubBy eqLocated