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