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