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