Visible type application
[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-constraint 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 HsTypeCtx {} -> True
778 _ -> False
779
780 rnAnonWildCard :: HsWildCardInfo RdrName -> RnM (HsWildCardInfo Name)
781 rnAnonWildCard (AnonWildCard _)
782 = do { loc <- getSrcSpanM
783 ; uniq <- newUnique
784 ; let name = mkInternalName uniq (mkTyVarOcc "_") loc
785 ; return (AnonWildCard (L loc name)) }
786
787 ---------------
788 -- | Ensures either that we're in a type or that -XTypeInType is set
789 checkTypeInType :: Outputable ty
790 => RnTyKiEnv
791 -> ty -- ^ type
792 -> RnM ()
793 checkTypeInType env ty
794 | isRnKindLevel env
795 = do { type_in_type <- xoptM LangExt.TypeInType
796 ; unless type_in_type $
797 addErr (text "Illegal kind:" <+> ppr ty $$
798 text "Did you mean to enable TypeInType?") }
799 checkTypeInType _ _ = return ()
800
801 notInKinds :: Outputable ty
802 => RnTyKiEnv
803 -> ty
804 -> RnM ()
805 notInKinds env ty
806 | isRnKindLevel env
807 = addErr (text "Illegal kind (even with TypeInType enabled):" <+> ppr ty)
808 notInKinds _ _ = return ()
809
810 {- *****************************************************
811 * *
812 Binding type variables
813 * *
814 ***************************************************** -}
815
816 bindSigTyVarsFV :: [Name]
817 -> RnM (a, FreeVars)
818 -> RnM (a, FreeVars)
819 -- Used just before renaming the defn of a function
820 -- with a separate type signature, to bring its tyvars into scope
821 -- With no -XScopedTypeVariables, this is a no-op
822 bindSigTyVarsFV tvs thing_inside
823 = do { scoped_tyvars <- xoptM LangExt.ScopedTypeVariables
824 ; if not scoped_tyvars then
825 thing_inside
826 else
827 bindLocalNamesFV tvs thing_inside }
828
829 -- | Simply bring a bunch of RdrNames into scope. No checking for
830 -- validity, at all. The binding location is taken from the location
831 -- on each name.
832 bindLRdrNames :: [Located RdrName]
833 -> ([Name] -> RnM (a, FreeVars))
834 -> RnM (a, FreeVars)
835 bindLRdrNames rdrs thing_inside
836 = do { var_names <- mapM (newTyVarNameRn Nothing) rdrs
837 ; bindLocalNamesFV var_names $
838 thing_inside var_names }
839
840 ---------------
841 bindHsQTyVars :: forall a b.
842 HsDocContext
843 -> Maybe a -- Just _ => an associated type decl
844 -> [Located RdrName] -- Kind variables from scope, in l-to-r
845 -- order, but not from ...
846 -> (LHsQTyVars RdrName) -- ... these user-written tyvars
847 -> (LHsQTyVars Name -> RnM (b, FreeVars))
848 -> RnM (b, FreeVars)
849 -- (a) Bring kind variables into scope
850 -- both (i) passed in (kv_bndrs)
851 -- and (ii) mentioned in the kinds of tv_bndrs
852 -- (b) Bring type variables into scope
853 bindHsQTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
854 = do { bindLHsTyVarBndrs doc mb_assoc kv_bndrs (hsQTvExplicit tv_bndrs) $
855 \ rn_kvs rn_bndrs ->
856 thing_inside (HsQTvs { hsq_implicit = rn_kvs
857 , hsq_explicit = rn_bndrs }) }
858
859 bindLHsTyVarBndrs :: forall a b.
860 HsDocContext
861 -> Maybe a -- Just _ => an associated type decl
862 -> [Located RdrName] -- Unbound kind variables from scope,
863 -- in l-to-r order, but not from ...
864 -> [LHsTyVarBndr RdrName] -- ... these user-written tyvars
865 -> ( [Name] -- all kv names
866 -> [LHsTyVarBndr Name]
867 -> RnM (b, FreeVars))
868 -> RnM (b, FreeVars)
869 bindLHsTyVarBndrs doc mb_assoc kv_bndrs tv_bndrs thing_inside
870 = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
871 ; go [] [] emptyNameSet emptyNameSet tv_bndrs }
872 where
873 tv_names_w_loc = map hsLTyVarLocName tv_bndrs
874
875 go :: [Name] -- kind-vars found (in reverse order)
876 -> [LHsTyVarBndr Name] -- already renamed (in reverse order)
877 -> NameSet -- kind vars already in scope (for dup checking)
878 -> NameSet -- type vars already in scope (for dup checking)
879 -> [LHsTyVarBndr RdrName] -- still to be renamed, scoped
880 -> RnM (b, FreeVars)
881 go rn_kvs rn_tvs kv_names tv_names (tv_bndr : tv_bndrs)
882 = bindLHsTyVarBndr doc mb_assoc kv_names tv_names tv_bndr $
883 \ kv_nms tv_bndr' -> go (reverse kv_nms ++ rn_kvs)
884 (tv_bndr' : rn_tvs)
885 (kv_names `extendNameSetList` kv_nms)
886 (tv_names `extendNameSet` hsLTyVarName tv_bndr')
887 tv_bndrs
888
889 go rn_kvs rn_tvs _kv_names tv_names []
890 = -- still need to deal with the kv_bndrs passed in originally
891 bindImplicitKvs doc mb_assoc kv_bndrs tv_names $ \ kv_nms ->
892 do { let all_rn_kvs = reverse (reverse kv_nms ++ rn_kvs)
893 all_rn_tvs = reverse rn_tvs
894 ; env <- getLocalRdrEnv
895 ; traceRn (text "bindHsTyVars" <+> (ppr env $$
896 ppr all_rn_kvs $$
897 ppr all_rn_tvs))
898 ; thing_inside all_rn_kvs all_rn_tvs }
899
900 bindLHsTyVarBndr :: HsDocContext
901 -> Maybe a -- associated class
902 -> NameSet -- kind vars already in scope
903 -> NameSet -- type vars already in scope
904 -> LHsTyVarBndr RdrName
905 -> ([Name] -> LHsTyVarBndr Name -> RnM (b, FreeVars))
906 -- passed the newly-bound implicitly-declared kind vars,
907 -- and the renamed LHsTyVarBndr
908 -> RnM (b, FreeVars)
909 bindLHsTyVarBndr doc mb_assoc kv_names tv_names hs_tv_bndr thing_inside
910 = case hs_tv_bndr of
911 L loc (UserTyVar lrdr@(L lv rdr)) ->
912 do { check_dup loc rdr
913 ; nm <- newTyVarNameRn mb_assoc lrdr
914 ; bindLocalNamesFV [nm] $
915 thing_inside [] (L loc (UserTyVar (L lv nm))) }
916 L loc (KindedTyVar lrdr@(L lv rdr) kind) ->
917 do { check_dup lv rdr
918
919 -- check for -XKindSignatures
920 ; sig_ok <- xoptM LangExt.KindSignatures
921 ; unless sig_ok (badKindSigErr doc kind)
922
923 -- deal with kind vars in the user-written kind
924 ; free_kvs <- freeKiTyVarsAllVars <$> extractHsTyRdrTyVars kind
925 ; bindImplicitKvs doc mb_assoc free_kvs tv_names $ \ kv_nms ->
926 do { (kind', fvs1) <- rnLHsKind doc kind
927 ; tv_nm <- newTyVarNameRn mb_assoc lrdr
928 ; (b, fvs2) <- bindLocalNamesFV [tv_nm] $
929 thing_inside kv_nms
930 (L loc (KindedTyVar (L lv tv_nm) kind'))
931 ; return (b, fvs1 `plusFV` fvs2) }}
932 where
933 -- make sure that the RdrName isn't in the sets of
934 -- names. We can't just check that it's not in scope at all
935 -- because we might be inside an associated class.
936 check_dup :: SrcSpan -> RdrName -> RnM ()
937 check_dup loc rdr
938 = do { m_name <- lookupLocalOccRn_maybe rdr
939 ; whenIsJust m_name $ \name ->
940 do { when (name `elemNameSet` kv_names) $
941 addErrAt loc (vcat [ ki_ty_err_msg name
942 , pprHsDocContext doc ])
943 ; when (name `elemNameSet` tv_names) $
944 dupNamesErr getLoc [L loc name, L (nameSrcSpan name) name] }}
945
946 ki_ty_err_msg n = text "Variable" <+> quotes (ppr n) <+>
947 text "used as a kind variable before being bound" $$
948 text "as a type variable. Perhaps reorder your variables?"
949
950
951 bindImplicitKvs :: HsDocContext
952 -> Maybe a
953 -> [Located RdrName] -- ^ kind var *occurrences*, from which
954 -- intent to bind is inferred
955 -> NameSet -- ^ *type* variables, for type/kind
956 -- misuse check for -XNoTypeInType
957 -> ([Name] -> RnM (b, FreeVars)) -- ^ passed new kv_names
958 -> RnM (b, FreeVars)
959 bindImplicitKvs _ _ [] _ thing_inside = thing_inside []
960 bindImplicitKvs doc mb_assoc free_kvs tv_names thing_inside
961 = do { rdr_env <- getLocalRdrEnv
962 ; let part_kvs lrdr@(L loc kv_rdr)
963 = case lookupLocalRdrEnv rdr_env kv_rdr of
964 Just kv_name -> Left (L loc kv_name)
965 _ -> Right lrdr
966 (bound_kvs, new_kvs) = partitionWith part_kvs free_kvs
967
968 -- check whether we're mixing types & kinds illegally
969 ; type_in_type <- xoptM LangExt.TypeInType
970 ; unless type_in_type $
971 mapM_ (check_tv_used_in_kind tv_names) bound_kvs
972
973 ; poly_kinds <- xoptM LangExt.PolyKinds
974 ; unless poly_kinds $
975 addErr (badKindBndrs doc new_kvs)
976
977 -- bind the vars and move on
978 ; kv_nms <- mapM (newTyVarNameRn mb_assoc) new_kvs
979 ; bindLocalNamesFV kv_nms $
980 thing_inside kv_nms }
981 where
982 -- check to see if the variables free in a kind are bound as type
983 -- variables. Assume -XNoTypeInType.
984 check_tv_used_in_kind :: NameSet -- ^ *type* variables
985 -> Located Name -- ^ renamed var used in kind
986 -> RnM ()
987 check_tv_used_in_kind tv_names (L loc kv_name)
988 = when (kv_name `elemNameSet` tv_names) $
989 addErrAt loc (vcat [ text "Type variable" <+> quotes (ppr kv_name) <+>
990 text "used in a kind." $$
991 text "Did you mean to use TypeInType?"
992 , pprHsDocContext doc ])
993
994
995 newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name
996 newTyVarNameRn mb_assoc (L loc rdr)
997 = do { rdr_env <- getLocalRdrEnv
998 ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of
999 (Just _, Just n) -> return n
1000 -- Use the same Name as the parent class decl
1001
1002 _ -> newLocalBndrRn (L loc rdr) }
1003
1004 ---------------------
1005 collectAnonWildCards :: LHsType Name -> [Name]
1006 -- | Extract all wild cards from a type.
1007 collectAnonWildCards lty = go lty
1008 where
1009 go (L _ ty) = case ty of
1010 HsWildCardTy (AnonWildCard (L _ wc)) -> [wc]
1011 HsAppsTy tys -> gos (mapMaybe (prefix_types_only . unLoc) tys)
1012 HsAppTy ty1 ty2 -> go ty1 `mappend` go ty2
1013 HsFunTy ty1 ty2 -> go ty1 `mappend` go ty2
1014 HsListTy ty -> go ty
1015 HsPArrTy ty -> go ty
1016 HsTupleTy _ tys -> gos tys
1017 HsOpTy ty1 _ ty2 -> go ty1 `mappend` go ty2
1018 HsParTy ty -> go ty
1019 HsIParamTy _ ty -> go ty
1020 HsEqTy ty1 ty2 -> go ty1 `mappend` go ty2
1021 HsKindSig ty kind -> go ty `mappend` go kind
1022 HsDocTy ty _ -> go ty
1023 HsBangTy _ ty -> go ty
1024 HsRecTy flds -> gos $ map (cd_fld_type . unLoc) flds
1025 HsExplicitListTy _ tys -> gos tys
1026 HsExplicitTupleTy _ tys -> gos tys
1027 HsForAllTy { hst_body = ty } -> go ty
1028 HsQualTy { hst_ctxt = L _ ctxt
1029 , hst_body = ty } -> gos ctxt `mappend` go ty
1030 -- HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit
1031 _ -> mempty
1032
1033 gos = mconcat . map go
1034
1035 prefix_types_only (HsAppPrefix ty) = Just ty
1036 prefix_types_only (HsAppInfix _) = Nothing
1037
1038
1039 {-
1040 *********************************************************
1041 * *
1042 ConDeclField
1043 * *
1044 *********************************************************
1045
1046 When renaming a ConDeclField, we have to find the FieldLabel
1047 associated with each field. But we already have all the FieldLabels
1048 available (since they were brought into scope by
1049 RnNames.getLocalNonValBinders), so we just take the list as an
1050 argument, build a map and look them up.
1051 -}
1052
1053 rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField RdrName]
1054 -> RnM ([LConDeclField Name], FreeVars)
1055 -- Also called from RnSource
1056 -- No wildcards can appear in record fields
1057 rnConDeclFields ctxt fls fields
1058 = mapFvRn (rnField fl_env env) fields
1059 where
1060 env = mkTyKiEnv ctxt TypeLevel RnTypeBody
1061 fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]
1062
1063 rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField RdrName
1064 -> RnM (LConDeclField Name, FreeVars)
1065 rnField fl_env env (L l (ConDeclField names ty haddock_doc))
1066 = do { let new_names = map (fmap lookupField) names
1067 ; (new_ty, fvs) <- rnLHsTyKi env ty
1068 ; new_haddock_doc <- rnMbLHsDoc haddock_doc
1069 ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
1070 where
1071 lookupField :: FieldOcc RdrName -> FieldOcc Name
1072 lookupField (FieldOcc (L lr rdr) _) = FieldOcc (L lr rdr) (flSelector fl)
1073 where
1074 lbl = occNameFS $ rdrNameOcc rdr
1075 fl = expectJust "rnField" $ lookupFsEnv fl_env lbl
1076
1077 {-
1078 ************************************************************************
1079 * *
1080 Fixities and precedence parsing
1081 * *
1082 ************************************************************************
1083
1084 @mkOpAppRn@ deals with operator fixities. The argument expressions
1085 are assumed to be already correctly arranged. It needs the fixities
1086 recorded in the OpApp nodes, because fixity info applies to the things
1087 the programmer actually wrote, so you can't find it out from the Name.
1088
1089 Furthermore, the second argument is guaranteed not to be another
1090 operator application. Why? Because the parser parses all
1091 operator appications left-associatively, EXCEPT negation, which
1092 we need to handle specially.
1093 Infix types are read in a *right-associative* way, so that
1094 a `op` b `op` c
1095 is always read in as
1096 a `op` (b `op` c)
1097
1098 mkHsOpTyRn rearranges where necessary. The two arguments
1099 have already been renamed and rearranged. It's made rather tiresome
1100 by the presence of ->, which is a separate syntactic construct.
1101 -}
1102
1103 ---------------
1104 -- Building (ty1 `op1` (ty21 `op2` ty22))
1105 mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
1106 -> Name -> Fixity -> LHsType Name -> LHsType Name
1107 -> RnM (HsType Name)
1108
1109 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
1110 = do { fix2 <- lookupTyFixityRn op2
1111 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
1112 (\t1 t2 -> HsOpTy t1 op2 t2)
1113 (unLoc op2) fix2 ty21 ty22 loc2 }
1114
1115 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
1116 = mk_hs_op_ty mk1 pp_op1 fix1 ty1
1117 HsFunTy funTyConName funTyFixity ty21 ty22 loc2
1118
1119 mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment
1120 = return (mk1 ty1 ty2)
1121
1122 ---------------
1123 mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
1124 -> Name -> Fixity -> LHsType Name
1125 -> (LHsType Name -> LHsType Name -> HsType Name)
1126 -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
1127 -> RnM (HsType Name)
1128 mk_hs_op_ty mk1 op1 fix1 ty1
1129 mk2 op2 fix2 ty21 ty22 loc2
1130 | nofix_error = do { precParseErr (op1,fix1) (op2,fix2)
1131 ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
1132 | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
1133 | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
1134 new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
1135 ; return (mk2 (noLoc new_ty) ty22) }
1136 where
1137 (nofix_error, associate_right) = compareFixity fix1 fix2
1138
1139
1140 ---------------------------
1141 mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged
1142 -> LHsExpr Name -> Fixity -- Operator and fixity
1143 -> LHsExpr Name -- Right operand (not an OpApp, but might
1144 -- be a NegApp)
1145 -> RnM (HsExpr Name)
1146
1147 -- (e11 `op1` e12) `op2` e2
1148 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
1149 | nofix_error
1150 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
1151 return (OpApp e1 op2 fix2 e2)
1152
1153 | associate_right = do
1154 new_e <- mkOpAppRn e12 op2 fix2 e2
1155 return (OpApp e11 op1 fix1 (L loc' new_e))
1156 where
1157 loc'= combineLocs e12 e2
1158 (nofix_error, associate_right) = compareFixity fix1 fix2
1159
1160 ---------------------------
1161 -- (- neg_arg) `op` e2
1162 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
1163 | nofix_error
1164 = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
1165 return (OpApp e1 op2 fix2 e2)
1166
1167 | associate_right
1168 = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
1169 return (NegApp (L loc' new_e) neg_name)
1170 where
1171 loc' = combineLocs neg_arg e2
1172 (nofix_error, associate_right) = compareFixity negateFixity fix2
1173
1174 ---------------------------
1175 -- e1 `op` - neg_arg
1176 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right
1177 | not associate_right -- We *want* right association
1178 = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
1179 return (OpApp e1 op1 fix1 e2)
1180 where
1181 (_, associate_right) = compareFixity fix1 negateFixity
1182
1183 ---------------------------
1184 -- Default case
1185 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
1186 = ASSERT2( right_op_ok fix (unLoc e2),
1187 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
1188 )
1189 return (OpApp e1 op fix e2)
1190
1191 ----------------------------
1192 get_op :: LHsExpr Name -> Name
1193 -- An unbound name could be either HsVar or HsUnboundVar
1194 -- See RnExpr.rnUnboundVar
1195 get_op (L _ (HsVar (L _ n))) = n
1196 get_op (L _ (HsUnboundVar occ)) = mkUnboundName occ
1197 get_op other = pprPanic "get_op" (ppr other)
1198
1199 -- Parser left-associates everything, but
1200 -- derived instances may have correctly-associated things to
1201 -- in the right operarand. So we just check that the right operand is OK
1202 right_op_ok :: Fixity -> HsExpr Name -> Bool
1203 right_op_ok fix1 (OpApp _ _ fix2 _)
1204 = not error_please && associate_right
1205 where
1206 (error_please, associate_right) = compareFixity fix1 fix2
1207 right_op_ok _ _
1208 = True
1209
1210 -- Parser initially makes negation bind more tightly than any other operator
1211 -- And "deriving" code should respect this (use HsPar if not)
1212 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
1213 mkNegAppRn neg_arg neg_name
1214 = ASSERT( not_op_app (unLoc neg_arg) )
1215 return (NegApp neg_arg neg_name)
1216
1217 not_op_app :: HsExpr id -> Bool
1218 not_op_app (OpApp _ _ _ _) = False
1219 not_op_app _ = True
1220
1221 ---------------------------
1222 mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged
1223 -> LHsExpr Name -> Fixity -- Operator and fixity
1224 -> LHsCmdTop Name -- Right operand (not an infix)
1225 -> RnM (HsCmd Name)
1226
1227 -- (e11 `op1` e12) `op2` e2
1228 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _))
1229 op2 fix2 a2
1230 | nofix_error
1231 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
1232 return (HsCmdArrForm op2 (Just fix2) [a1, a2])
1233
1234 | associate_right
1235 = do new_c <- mkOpFormRn a12 op2 fix2 a2
1236 return (HsCmdArrForm op1 (Just fix1)
1237 [a11, L loc (HsCmdTop (L loc new_c)
1238 placeHolderType placeHolderType [])])
1239 -- TODO: locs are wrong
1240 where
1241 (nofix_error, associate_right) = compareFixity fix1 fix2
1242
1243 -- Default case
1244 mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
1245 = return (HsCmdArrForm op (Just fix) [arg1, arg2])
1246
1247
1248 --------------------------------------
1249 mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
1250 -> RnM (Pat Name)
1251
1252 mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
1253 = do { fix1 <- lookupFixityRn (unLoc op1)
1254 ; let (nofix_error, associate_right) = compareFixity fix1 fix2
1255
1256 ; if nofix_error then do
1257 { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
1258 ; return (ConPatIn op2 (InfixCon p1 p2)) }
1259
1260 else if associate_right then do
1261 { new_p <- mkConOpPatRn op2 fix2 p12 p2
1262 ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
1263 else return (ConPatIn op2 (InfixCon p1 p2)) }
1264
1265 mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment
1266 = ASSERT( not_op_pat (unLoc p2) )
1267 return (ConPatIn op (InfixCon p1 p2))
1268
1269 not_op_pat :: Pat Name -> Bool
1270 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
1271 not_op_pat _ = True
1272
1273 --------------------------------------
1274 checkPrecMatch :: Name -> MatchGroup Name body -> RnM ()
1275 -- Check precedence of a function binding written infix
1276 -- eg a `op` b `C` c = ...
1277 -- See comments with rnExpr (OpApp ...) about "deriving"
1278
1279 checkPrecMatch op (MG { mg_alts = L _ ms })
1280 = mapM_ check ms
1281 where
1282 check (L _ (Match _ (L l1 p1 : L l2 p2 :_) _ _))
1283 = setSrcSpan (combineSrcSpans l1 l2) $
1284 do checkPrec op p1 False
1285 checkPrec op p2 True
1286
1287 check _ = return ()
1288 -- This can happen. Consider
1289 -- a `op` True = ...
1290 -- op = ...
1291 -- The infix flag comes from the first binding of the group
1292 -- but the second eqn has no args (an error, but not discovered
1293 -- until the type checker). So we don't want to crash on the
1294 -- second eqn.
1295
1296 checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
1297 checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
1298 op_fix@(Fixity op_prec op_dir) <- lookupFixityRn op
1299 op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
1300 let
1301 inf_ok = op1_prec > op_prec ||
1302 (op1_prec == op_prec &&
1303 (op1_dir == InfixR && op_dir == InfixR && right ||
1304 op1_dir == InfixL && op_dir == InfixL && not right))
1305
1306 info = (op, op_fix)
1307 info1 = (unLoc op1, op1_fix)
1308 (infol, infor) = if right then (info, info1) else (info1, info)
1309 unless inf_ok (precParseErr infol infor)
1310
1311 checkPrec _ _ _
1312 = return ()
1313
1314 -- Check precedence of (arg op) or (op arg) respectively
1315 -- If arg is itself an operator application, then either
1316 -- (a) its precedence must be higher than that of op
1317 -- (b) its precedency & associativity must be the same as that of op
1318 checkSectionPrec :: FixityDirection -> HsExpr RdrName
1319 -> LHsExpr Name -> LHsExpr Name -> RnM ()
1320 checkSectionPrec direction section op arg
1321 = case unLoc arg of
1322 OpApp _ op fix _ -> go_for_it (get_op op) fix
1323 NegApp _ _ -> go_for_it negateName negateFixity
1324 _ -> return ()
1325 where
1326 op_name = get_op op
1327 go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
1328 op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
1329 unless (op_prec < arg_prec
1330 || (op_prec == arg_prec && direction == assoc))
1331 (sectionPrecErr (op_name, op_fix)
1332 (arg_op, arg_fix) section)
1333
1334 -- Precedence-related error messages
1335
1336 precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
1337 precParseErr op1@(n1,_) op2@(n2,_)
1338 | isUnboundName n1 || isUnboundName n2
1339 = return () -- Avoid error cascade
1340 | otherwise
1341 = addErr $ hang (ptext (sLit "Precedence parsing error"))
1342 4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"),
1343 ppr_opfix op2,
1344 ptext (sLit "in the same infix expression")])
1345
1346 sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
1347 sectionPrecErr op@(n1,_) arg_op@(n2,_) section
1348 | isUnboundName n1 || isUnboundName n2
1349 = return () -- Avoid error cascade
1350 | otherwise
1351 = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
1352 nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"),
1353 nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]),
1354 nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))]
1355
1356 ppr_opfix :: (Name, Fixity) -> SDoc
1357 ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
1358 where
1359 pp_op | op == negateName = ptext (sLit "prefix `-'")
1360 | otherwise = quotes (ppr op)
1361
1362 {- *****************************************************
1363 * *
1364 Errors
1365 * *
1366 ***************************************************** -}
1367
1368 badKindBndrs :: HsDocContext -> [Located RdrName] -> SDoc
1369 badKindBndrs doc kvs
1370 = withHsDocContext doc $
1371 hang (ptext (sLit "Unexpected kind variable") <> plural kvs
1372 <+> pprQuotedList kvs)
1373 2 (ptext (sLit "Perhaps you intended to use PolyKinds"))
1374
1375 badKindSigErr :: HsDocContext -> LHsType RdrName -> TcM ()
1376 badKindSigErr doc (L loc ty)
1377 = setSrcSpan loc $ addErr $
1378 withHsDocContext doc $
1379 hang (ptext (sLit "Illegal kind signature:") <+> quotes (ppr ty))
1380 2 (ptext (sLit "Perhaps you intended to use KindSignatures"))
1381
1382 dataKindsErr :: RnTyKiEnv -> HsType RdrName -> SDoc
1383 dataKindsErr env thing
1384 = hang (ptext (sLit "Illegal") <+> pp_what <> colon <+> quotes (ppr thing))
1385 2 (ptext (sLit "Perhaps you intended to use DataKinds"))
1386 where
1387 pp_what | isRnKindLevel env = ptext (sLit "kind")
1388 | otherwise = ptext (sLit "type")
1389
1390 inTypeDoc :: HsType RdrName -> SDoc
1391 inTypeDoc ty = ptext (sLit "In the type") <+> quotes (ppr ty)
1392
1393 warnUnusedForAlls :: SDoc -> [LHsTyVarBndr Name] -> FreeVars -> TcM ()
1394 warnUnusedForAlls in_doc bound_names used_names
1395 = whenWOptM Opt_WarnUnusedMatches $
1396 mapM_ add_warn bound_names
1397 where
1398 add_warn (L loc tv)
1399 = unless (hsTyVarName tv `elemNameSet` used_names) $
1400 addWarnAt loc $
1401 vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv)
1402 , in_doc ]
1403
1404 opTyErr :: Outputable a => RdrName -> a -> SDoc
1405 opTyErr op overall_ty
1406 = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty))
1407 2 extra
1408 where
1409 extra | op == dot_tv_RDR
1410 = perhapsForallMsg
1411 | otherwise
1412 = ptext (sLit "Use TypeOperators to allow operators in types")
1413
1414 emptyNonSymsErr :: HsType RdrName -> SDoc
1415 emptyNonSymsErr overall_ty
1416 = text "Operator applied to too few arguments:" <+> ppr overall_ty
1417
1418 {-
1419 ************************************************************************
1420 * *
1421 Finding the free type variables of a (HsType RdrName)
1422 * *
1423 ************************************************************************
1424
1425
1426 Note [Kind and type-variable binders]
1427 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1428 In a type signature we may implicitly bind type variable and, more
1429 recently, kind variables. For example:
1430 * f :: a -> a
1431 f = ...
1432 Here we need to find the free type variables of (a -> a),
1433 so that we know what to quantify
1434
1435 * class C (a :: k) where ...
1436 This binds 'k' in ..., as well as 'a'
1437
1438 * f (x :: a -> [a]) = ....
1439 Here we bind 'a' in ....
1440
1441 * f (x :: T a -> T (b :: k)) = ...
1442 Here we bind both 'a' and the kind variable 'k'
1443
1444 * type instance F (T (a :: Maybe k)) = ...a...k...
1445 Here we want to constrain the kind of 'a', and bind 'k'.
1446
1447 In general we want to walk over a type, and find
1448 * Its free type variables
1449 * The free kind variables of any kind signatures in the type
1450
1451 Hence we returns a pair (kind-vars, type vars)
1452 See also Note [HsBSig binder lists] in HsTypes
1453 -}
1454
1455 data FreeKiTyVars = FKTV { fktv_kis :: [Located RdrName]
1456 , _fktv_k_set :: OccSet -- for efficiency,
1457 -- only used internally
1458 , fktv_tys :: [Located RdrName]
1459 , _fktv_t_set :: OccSet
1460 , fktv_all :: [Located RdrName] }
1461
1462 instance Outputable FreeKiTyVars where
1463 ppr (FKTV kis _ tys _ _) = ppr (kis, tys)
1464
1465 emptyFKTV :: FreeKiTyVars
1466 emptyFKTV = FKTV [] emptyOccSet [] emptyOccSet []
1467
1468 freeKiTyVarsAllVars :: FreeKiTyVars -> [Located RdrName]
1469 freeKiTyVarsAllVars = fktv_all
1470
1471 freeKiTyVarsKindVars :: FreeKiTyVars -> [Located RdrName]
1472 freeKiTyVarsKindVars = fktv_kis
1473
1474 freeKiTyVarsTypeVars :: FreeKiTyVars -> [Located RdrName]
1475 freeKiTyVarsTypeVars = fktv_tys
1476
1477 filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
1478 filterInScope rdr_env (FKTV kis k_set tys t_set all)
1479 = FKTV (filterOut in_scope kis)
1480 (filterOccSet (not . in_scope_occ) k_set)
1481 (filterOut in_scope tys)
1482 (filterOccSet (not . in_scope_occ) t_set)
1483 (filterOut in_scope all)
1484 where
1485 in_scope = inScope rdr_env . unLoc
1486 in_scope_occ occ = isJust $ lookupLocalRdrOcc rdr_env occ
1487
1488 inScope :: LocalRdrEnv -> RdrName -> Bool
1489 inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env
1490
1491 extractHsTyRdrTyVars :: LHsType RdrName -> RnM FreeKiTyVars
1492 -- extractHsTyRdrNames finds the free (kind, type) variables of a HsType
1493 -- or the free (sort, kind) variables of a HsKind
1494 -- It's used when making the for-alls explicit.
1495 -- Does not return any wildcards
1496 -- When the same name occurs multiple times in the types, only the first
1497 -- occurence is returned.
1498 -- See Note [Kind and type-variable binders]
1499 extractHsTyRdrTyVars ty
1500 = do { FKTV kis k_set tys t_set all <- extract_lty TypeLevel ty emptyFKTV
1501 ; return (FKTV (nubL kis) k_set
1502 (nubL tys) t_set
1503 (nubL all)) }
1504
1505 -- | Extracts free type and kind variables from types in a list.
1506 -- When the same name occurs multiple times in the types, only the first
1507 -- occurence is returned and the rest is filtered out.
1508 -- See Note [Kind and type-variable binders]
1509 extractHsTysRdrTyVars :: [LHsType RdrName] -> RnM FreeKiTyVars
1510 extractHsTysRdrTyVars tys
1511 = rmDupsInRdrTyVars <$> extractHsTysRdrTyVarsDups tys
1512
1513 -- | Extracts free type and kind variables from types in a list.
1514 -- When the same name occurs multiple times in the types, all occurences
1515 -- are returned.
1516 extractHsTysRdrTyVarsDups :: [LHsType RdrName] -> RnM FreeKiTyVars
1517 extractHsTysRdrTyVarsDups tys
1518 = extract_ltys TypeLevel tys emptyFKTV
1519
1520 -- | Removes multiple occurences of the same name from FreeKiTyVars.
1521 rmDupsInRdrTyVars :: FreeKiTyVars -> FreeKiTyVars
1522 rmDupsInRdrTyVars (FKTV kis k_set tys t_set all)
1523 = FKTV (nubL kis) k_set (nubL tys) t_set (nubL all)
1524
1525 extractRdrKindSigVars :: LFamilyResultSig RdrName -> RnM [Located RdrName]
1526 extractRdrKindSigVars (L _ resultSig)
1527 | KindSig k <- resultSig = kindRdrNameFromSig k
1528 | TyVarSig (L _ (KindedTyVar _ k)) <- resultSig = kindRdrNameFromSig k
1529 | otherwise = return []
1530 where kindRdrNameFromSig k = freeKiTyVarsAllVars <$> extractHsTyRdrTyVars k
1531
1532 extractDataDefnKindVars :: HsDataDefn RdrName -> RnM [Located RdrName]
1533 -- Get the scoped kind variables mentioned free in the constructor decls
1534 -- Eg data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
1535 -- Here k should scope over the whole definition
1536 extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
1537 , dd_cons = cons, dd_derivs = derivs })
1538 = (nubL . freeKiTyVarsKindVars) <$>
1539 (extract_lctxt TypeLevel ctxt =<<
1540 extract_mb extract_lkind ksig =<<
1541 extract_mb (extract_sig_tys . unLoc) derivs =<<
1542 foldrM (extract_con . unLoc) emptyFKTV cons)
1543 where
1544 extract_con (ConDeclGADT { }) acc = return acc
1545 extract_con (ConDeclH98 { con_qvars = qvs
1546 , con_cxt = ctxt, con_details = details }) acc
1547 = extract_hs_tv_bndrs (maybe [] hsQTvExplicit qvs) acc =<<
1548 extract_mlctxt ctxt =<<
1549 extract_ltys TypeLevel (hsConDeclArgTys details) emptyFKTV
1550
1551 extract_mlctxt :: Maybe (LHsContext RdrName) -> FreeKiTyVars -> RnM FreeKiTyVars
1552 extract_mlctxt Nothing acc = return acc
1553 extract_mlctxt (Just ctxt) acc = extract_lctxt TypeLevel ctxt acc
1554
1555 extract_lctxt :: TypeOrKind
1556 -> LHsContext RdrName -> FreeKiTyVars -> RnM FreeKiTyVars
1557 extract_lctxt t_or_k ctxt = extract_ltys t_or_k (unLoc ctxt)
1558
1559 extract_sig_tys :: [LHsSigType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars
1560 extract_sig_tys sig_tys acc
1561 = foldrM (\sig_ty acc -> extract_lty TypeLevel (hsSigType sig_ty) acc)
1562 acc sig_tys
1563
1564 extract_ltys :: TypeOrKind
1565 -> [LHsType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars
1566 extract_ltys t_or_k tys acc = foldrM (extract_lty t_or_k) acc tys
1567
1568 extract_mb :: (a -> FreeKiTyVars -> RnM FreeKiTyVars)
1569 -> Maybe a -> FreeKiTyVars -> RnM FreeKiTyVars
1570 extract_mb _ Nothing acc = return acc
1571 extract_mb f (Just x) acc = f x acc
1572
1573 extract_lkind :: LHsType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars
1574 extract_lkind = extract_lty KindLevel
1575
1576 extract_lty :: TypeOrKind -> LHsType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars
1577 extract_lty t_or_k (L _ ty) acc
1578 = case ty of
1579 HsTyVar ltv -> extract_tv t_or_k ltv acc
1580 HsBangTy _ ty -> extract_lty t_or_k ty acc
1581 HsRecTy flds -> foldrM (extract_lty t_or_k
1582 . cd_fld_type . unLoc) acc
1583 flds
1584 HsAppsTy tys -> extract_apps t_or_k tys acc
1585 HsAppTy ty1 ty2 -> extract_lty t_or_k ty1 =<<
1586 extract_lty t_or_k ty2 acc
1587 HsListTy ty -> extract_lty t_or_k ty acc
1588 HsPArrTy ty -> extract_lty t_or_k ty acc
1589 HsTupleTy _ tys -> extract_ltys t_or_k tys acc
1590 HsFunTy ty1 ty2 -> extract_lty t_or_k ty1 =<<
1591 extract_lty t_or_k ty2 acc
1592 HsIParamTy _ ty -> extract_lty t_or_k ty acc
1593 HsEqTy ty1 ty2 -> extract_lty t_or_k ty1 =<<
1594 extract_lty t_or_k ty2 acc
1595 HsOpTy ty1 tv ty2 -> extract_tv t_or_k tv =<<
1596 extract_lty t_or_k ty1 =<<
1597 extract_lty t_or_k ty2 acc
1598 HsParTy ty -> extract_lty t_or_k ty acc
1599 HsCoreTy {} -> return acc -- The type is closed
1600 HsSpliceTy {} -> return acc -- Type splices mention no tvs
1601 HsDocTy ty _ -> extract_lty t_or_k ty acc
1602 HsExplicitListTy _ tys -> extract_ltys t_or_k tys acc
1603 HsExplicitTupleTy _ tys -> extract_ltys t_or_k tys acc
1604 HsTyLit _ -> return acc
1605 HsKindSig ty ki -> extract_lty t_or_k ty =<<
1606 extract_lkind ki acc
1607 HsForAllTy { hst_bndrs = tvs, hst_body = ty }
1608 -> extract_hs_tv_bndrs tvs acc =<<
1609 extract_lty t_or_k ty emptyFKTV
1610 HsQualTy { hst_ctxt = ctxt, hst_body = ty }
1611 -> extract_lctxt t_or_k ctxt =<<
1612 extract_lty t_or_k ty acc
1613 -- We deal with these separately in rnLHsTypeWithWildCards
1614 HsWildCardTy {} -> return acc
1615
1616 extract_apps :: TypeOrKind
1617 -> [LHsAppType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars
1618 extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys
1619
1620 extract_app :: TypeOrKind -> LHsAppType RdrName -> FreeKiTyVars
1621 -> RnM FreeKiTyVars
1622 extract_app t_or_k (L _ (HsAppInfix tv)) acc = extract_tv t_or_k tv acc
1623 extract_app t_or_k (L _ (HsAppPrefix ty)) acc = extract_lty t_or_k ty acc
1624
1625 extract_hs_tv_bndrs :: [LHsTyVarBndr RdrName] -> FreeKiTyVars
1626 -> FreeKiTyVars -> RnM FreeKiTyVars
1627 -- In (forall (a :: Maybe e). a -> b) we have
1628 -- 'a' is bound by the forall
1629 -- 'b' is a free type variable
1630 -- 'e' is a free kind variable
1631 extract_hs_tv_bndrs tvs
1632 (FKTV acc_kvs acc_k_set acc_tvs acc_t_set acc_all)
1633 -- Note accumulator comes first
1634 (FKTV body_kvs body_k_set body_tvs body_t_set body_all)
1635 | null tvs
1636 = return $
1637 FKTV (body_kvs ++ acc_kvs) (body_k_set `unionOccSets` acc_k_set)
1638 (body_tvs ++ acc_tvs) (body_t_set `unionOccSets` acc_t_set)
1639 (body_all ++ acc_all)
1640 | otherwise
1641 = do { FKTV bndr_kvs bndr_k_set _ _ _
1642 <- foldrM extract_lkind emptyFKTV [k | L _ (KindedTyVar _ k) <- tvs]
1643
1644 ; let locals = mkOccSet $ map (rdrNameOcc . hsLTyVarName) tvs
1645 ; return $
1646 FKTV (filterOut ((`elemOccSet` locals) . rdrNameOcc . unLoc) (bndr_kvs ++ body_kvs) ++ acc_kvs)
1647 ((body_k_set `minusOccSet` locals) `unionOccSets` acc_k_set `unionOccSets` bndr_k_set)
1648 (filterOut ((`elemOccSet` locals) . rdrNameOcc . unLoc) body_tvs ++ acc_tvs)
1649 ((body_t_set `minusOccSet` locals) `unionOccSets` acc_t_set)
1650 (filterOut ((`elemOccSet` locals) . rdrNameOcc . unLoc) (bndr_kvs ++ body_all) ++ acc_all) }
1651
1652 extract_tv :: TypeOrKind -> Located RdrName -> FreeKiTyVars -> RnM FreeKiTyVars
1653 extract_tv t_or_k ltv@(L _ tv) acc
1654 | isRdrTyVar tv = case acc of
1655 FKTV kvs k_set tvs t_set all
1656 | isTypeLevel t_or_k
1657 -> do { when (occ `elemOccSet` k_set) $
1658 mixedVarsErr ltv
1659 ; return (FKTV kvs k_set (ltv : tvs) (t_set `extendOccSet` occ)
1660 (ltv : all)) }
1661 | otherwise
1662 -> do { when (occ `elemOccSet` t_set) $
1663 mixedVarsErr ltv
1664 ; return (FKTV (ltv : kvs) (k_set `extendOccSet` occ) tvs t_set
1665 (ltv : all)) }
1666 | otherwise = return acc
1667 where
1668 occ = rdrNameOcc tv
1669
1670 mixedVarsErr :: Located RdrName -> RnM ()
1671 mixedVarsErr (L loc tv)
1672 = do { typeintype <- xoptM LangExt.TypeInType
1673 ; unless typeintype $
1674 addErrAt loc $ text "Variable" <+> quotes (ppr tv) <+>
1675 text "used as both a kind and a type" $$
1676 text "Did you intend to use TypeInType?" }
1677
1678 -- just used in this module; seemed convenient here
1679 nubL :: Eq a => [Located a] -> [Located a]
1680 nubL = nubBy eqLocated