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