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