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