Remove fix-submodules.py
[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 nec)) _
141 = noExtCon nec
142 rn_hs_sig_wc_type _ _ (XHsWildCardBndrs nec) _
143 = noExtCon nec
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 nec) = noExtCon nec
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 = noExtField
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 noExtField)]
188 ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
189 ; return (HsQualTy { hst_xqual = noExtField
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 = noExtField
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 nec) = noExtCon nec
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 = noExtField
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 = noExtField, 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 noExtField 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 noExtField 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 noExtField ty', fvs) }
526
527 rnHsTyKi env (HsBangTy _ b ty)
528 = do { (ty', fvs) <- rnLHsTyKi env ty
529 ; return (HsBangTy noExtField 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 noExtField 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 noExtField) 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 noExtField 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 noExtField 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 noExtField 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 noExtField 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 noExtField 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 noExtField 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 noExtField n ty', fvs) }
614
615 rnHsTyKi _ (HsStarTy _ isUni)
616 = return (HsStarTy noExtField 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 noExtField 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 noExtField 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 noExtField tys', fvs) }
644
645 rnHsTyKi env (HsWildCardTy _)
646 = do { checkAnonWildCard env
647 ; return (HsWildCardTy noExtField, 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 RnTopConstraint -> Just constraint_msg
697 RnConstraint -> 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; e.g.
718 -- f :: (Eq _a) => _a -> Int
719 -- g :: (_a, _b) => T _a _b -> Int
720 -- The named tyvars get filled in from elsewhere
721 RnConstraint -> Just constraint_msg
722 constraint_msg = notAllowed (ppr name) <+> text "in a constraint"
723
724 wildCardsAllowed :: RnTyKiEnv -> Bool
725 -- ^ In what contexts are wildcards permitted
726 wildCardsAllowed env
727 = case rtke_ctxt env of
728 TypeSigCtx {} -> True
729 TypBrCtx {} -> True -- Template Haskell quoted type
730 SpliceTypeCtx {} -> True -- Result of a Template Haskell splice
731 ExprWithTySigCtx {} -> True
732 PatCtx {} -> True
733 RuleCtx {} -> True
734 FamPatCtx {} -> True -- Not named wildcards though
735 GHCiCtx {} -> True
736 HsTypeCtx {} -> True
737 _ -> False
738
739
740
741 ---------------
742 -- | Ensures either that we're in a type or that -XPolyKinds is set
743 checkPolyKinds :: Outputable ty
744 => RnTyKiEnv
745 -> ty -- ^ type
746 -> RnM ()
747 checkPolyKinds env ty
748 | isRnKindLevel env
749 = do { polykinds <- xoptM LangExt.PolyKinds
750 ; unless polykinds $
751 addErr (text "Illegal kind:" <+> ppr ty $$
752 text "Did you mean to enable PolyKinds?") }
753 checkPolyKinds _ _ = return ()
754
755 notInKinds :: Outputable ty
756 => RnTyKiEnv
757 -> ty
758 -> RnM ()
759 notInKinds env ty
760 | isRnKindLevel env
761 = addErr (text "Illegal kind:" <+> ppr ty)
762 notInKinds _ _ = return ()
763
764 {- *****************************************************
765 * *
766 Binding type variables
767 * *
768 ***************************************************** -}
769
770 bindSigTyVarsFV :: [Name]
771 -> RnM (a, FreeVars)
772 -> RnM (a, FreeVars)
773 -- Used just before renaming the defn of a function
774 -- with a separate type signature, to bring its tyvars into scope
775 -- With no -XScopedTypeVariables, this is a no-op
776 bindSigTyVarsFV tvs thing_inside
777 = do { scoped_tyvars <- xoptM LangExt.ScopedTypeVariables
778 ; if not scoped_tyvars then
779 thing_inside
780 else
781 bindLocalNamesFV tvs thing_inside }
782
783 -- | Simply bring a bunch of RdrNames into scope. No checking for
784 -- validity, at all. The binding location is taken from the location
785 -- on each name.
786 bindLRdrNames :: [Located RdrName]
787 -> ([Name] -> RnM (a, FreeVars))
788 -> RnM (a, FreeVars)
789 bindLRdrNames rdrs thing_inside
790 = do { var_names <- mapM (newTyVarNameRn Nothing) rdrs
791 ; bindLocalNamesFV var_names $
792 thing_inside var_names }
793
794 ---------------
795 bindHsQTyVars :: forall a b.
796 HsDocContext
797 -> Maybe SDoc -- Just d => check for unused tvs
798 -- d is a phrase like "in the type ..."
799 -> Maybe a -- Just _ => an associated type decl
800 -> [Located RdrName] -- Kind variables from scope, no dups
801 -> (LHsQTyVars GhcPs)
802 -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
803 -- The Bool is True <=> all kind variables used in the
804 -- kind signature are bound on the left. Reason:
805 -- the last clause of Note [CUSKs: Complete user-supplied
806 -- kind signatures] in HsDecls
807 -> RnM (b, FreeVars)
808
809 -- See Note [bindHsQTyVars examples]
810 -- (a) Bring kind variables into scope
811 -- both (i) passed in body_kv_occs
812 -- and (ii) mentioned in the kinds of hsq_bndrs
813 -- (b) Bring type variables into scope
814 --
815 bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside
816 = do { let hs_tv_bndrs = hsQTvExplicit hsq_bndrs
817 bndr_kv_occs = extractHsTyVarBndrsKVs hs_tv_bndrs
818
819 ; let -- See Note [bindHsQTyVars examples] for what
820 -- all these various things are doing
821 bndrs, kv_occs, implicit_kvs :: [Located RdrName]
822 bndrs = map hsLTyVarLocName hs_tv_bndrs
823 kv_occs = nubL (bndr_kv_occs ++ body_kv_occs)
824 -- Make sure to list the binder kvs before the
825 -- body kvs, as mandated by
826 -- Note [Ordering of implicit variables]
827 implicit_kvs = filter_occs bndrs kv_occs
828 del = deleteBys eqLocated
829 all_bound_on_lhs = null ((body_kv_occs `del` bndrs) `del` bndr_kv_occs)
830
831 ; traceRn "checkMixedVars3" $
832 vcat [ text "kv_occs" <+> ppr kv_occs
833 , text "bndrs" <+> ppr hs_tv_bndrs
834 , text "bndr_kv_occs" <+> ppr bndr_kv_occs
835 , text "wubble" <+> ppr ((kv_occs \\ bndrs) \\ bndr_kv_occs)
836 ]
837
838 ; implicit_kv_nms <- mapM (newTyVarNameRn mb_assoc) implicit_kvs
839
840 ; bindLocalNamesFV implicit_kv_nms $
841 bindLHsTyVarBndrs doc mb_in_doc mb_assoc hs_tv_bndrs $ \ rn_bndrs ->
842 do { traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs)
843 ; thing_inside (HsQTvs { hsq_ext = implicit_kv_nms
844 , hsq_explicit = rn_bndrs })
845 all_bound_on_lhs } }
846
847 where
848 filter_occs :: [Located RdrName] -- Bound here
849 -> [Located RdrName] -- Potential implicit binders
850 -> [Located RdrName] -- Final implicit binders
851 -- Filter out any potential implicit binders that are either
852 -- already in scope, or are explicitly bound in the same HsQTyVars
853 filter_occs bndrs occs
854 = filterOut is_in_scope occs
855 where
856 is_in_scope locc = locc `elemRdr` bndrs
857
858 {- Note [bindHsQTyVars examples]
859 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
860 Suppose we have
861 data T k (a::k1) (b::k) :: k2 -> k1 -> *
862
863 Then:
864 hs_tv_bndrs = [k, a::k1, b::k], the explicitly-bound variables
865 bndrs = [k,a,b]
866
867 bndr_kv_occs = [k,k1], kind variables free in kind signatures
868 of hs_tv_bndrs
869
870 body_kv_occs = [k2,k1], kind variables free in the
871 result kind signature
872
873 implicit_kvs = [k1,k2], kind variables free in kind signatures
874 of hs_tv_bndrs, and not bound by bndrs
875
876 * We want to quantify add implicit bindings for implicit_kvs
877
878 * If implicit_body_kvs is non-empty, then there is a kind variable
879 mentioned in the kind signature that is not bound "on the left".
880 That's one of the rules for a CUSK, so we pass that info on
881 as the second argument to thing_inside.
882
883 * Order is not important in these lists. All we are doing is
884 bring Names into scope.
885
886 Finally, you may wonder why filter_occs removes in-scope variables
887 from bndr/body_kv_occs. How can anything be in scope? Answer:
888 HsQTyVars is /also/ used (slightly oddly) for Haskell-98 syntax
889 ConDecls
890 data T a = forall (b::k). MkT a b
891 The ConDecl has a LHsQTyVars in it; but 'a' scopes over the entire
892 ConDecl. Hence the local RdrEnv may be non-empty and we must filter
893 out 'a' from the free vars. (Mind you, in this situation all the
894 implicit kind variables are bound at the data type level, so there
895 are none to bind in the ConDecl, so there are no implicitly bound
896 variables at all.
897
898 Note [Kind variable scoping]
899 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
900 If we have
901 data T (a :: k) k = ...
902 we report "k is out of scope" for (a::k). Reason: k is not brought
903 into scope until the explicit k-binding that follows. It would be
904 terribly confusing to bring into scope an /implicit/ k for a's kind
905 and a distinct, shadowing explicit k that follows, something like
906 data T {k1} (a :: k1) k = ...
907
908 So the rule is:
909
910 the implicit binders never include any
911 of the explicit binders in the group
912
913 Note that in the denerate case
914 data T (a :: a) = blah
915 we get a complaint the second 'a' is not in scope.
916
917 That applies to foralls too: e.g.
918 forall (a :: k) k . blah
919
920 But if the foralls are split, we treat the two groups separately:
921 forall (a :: k). forall k. blah
922 Here we bring into scope an implicit k, which is later shadowed
923 by the explicit k.
924
925 In implementation terms
926
927 * In bindHsQTyVars 'k' is free in bndr_kv_occs; then we delete
928 the binders {a,k}, and so end with no implicit binders. Then we
929 rename the binders left-to-right, and hence see that 'k' is out of
930 scope in the kind of 'a'.
931
932 * Similarly in extract_hs_tv_bndrs
933
934 Note [Variables used as both types and kinds]
935 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
936 We bind the type variables tvs, and kvs is the set of free variables of the
937 kinds in the scope of the binding. Here is one typical example:
938
939 forall a b. a -> (b::k) -> (c::a)
940
941 Here, tvs will be {a,b}, and kvs {k,a}.
942
943 We must make sure that kvs includes all of variables in the kinds of type
944 variable bindings. For instance:
945
946 forall k (a :: k). Proxy a
947
948 If we only look in the body of the `forall` type, we will mistakenly conclude
949 that kvs is {}. But in fact, the type variable `k` is also used as a kind
950 variable in (a :: k), later in the binding. (This mistake lead to #14710.)
951 So tvs is {k,a} and kvs is {k}.
952
953 NB: we do this only at the binding site of 'tvs'.
954 -}
955
956 bindLHsTyVarBndrs :: HsDocContext
957 -> Maybe SDoc -- Just d => check for unused tvs
958 -- d is a phrase like "in the type ..."
959 -> Maybe a -- Just _ => an associated type decl
960 -> [LHsTyVarBndr GhcPs] -- User-written tyvars
961 -> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars))
962 -> RnM (b, FreeVars)
963 bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside
964 = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
965 ; checkDupRdrNames tv_names_w_loc
966 ; go tv_bndrs thing_inside }
967 where
968 tv_names_w_loc = map hsLTyVarLocName tv_bndrs
969
970 go [] thing_inside = thing_inside []
971 go (b:bs) thing_inside = bindLHsTyVarBndr doc mb_assoc b $ \ b' ->
972 do { (res, fvs) <- go bs $ \ bs' ->
973 thing_inside (b' : bs')
974 ; warn_unused b' fvs
975 ; return (res, fvs) }
976
977 warn_unused tv_bndr fvs = case mb_in_doc of
978 Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs
979 Nothing -> return ()
980
981 bindLHsTyVarBndr :: HsDocContext
982 -> Maybe a -- associated class
983 -> LHsTyVarBndr GhcPs
984 -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars))
985 -> RnM (b, FreeVars)
986 bindLHsTyVarBndr _doc mb_assoc (dL->L loc
987 (UserTyVar x
988 lrdr@(dL->L lv _))) thing_inside
989 = do { nm <- newTyVarNameRn mb_assoc lrdr
990 ; bindLocalNamesFV [nm] $
991 thing_inside (cL loc (UserTyVar x (cL lv nm))) }
992
993 bindLHsTyVarBndr doc mb_assoc (dL->L loc (KindedTyVar x lrdr@(dL->L lv _) kind))
994 thing_inside
995 = do { sig_ok <- xoptM LangExt.KindSignatures
996 ; unless sig_ok (badKindSigErr doc kind)
997 ; (kind', fvs1) <- rnLHsKind doc kind
998 ; tv_nm <- newTyVarNameRn mb_assoc lrdr
999 ; (b, fvs2) <- bindLocalNamesFV [tv_nm]
1000 $ thing_inside (cL loc (KindedTyVar x (cL lv tv_nm) kind'))
1001 ; return (b, fvs1 `plusFV` fvs2) }
1002
1003 bindLHsTyVarBndr _ _ (dL->L _ (XTyVarBndr nec)) _ = noExtCon nec
1004 bindLHsTyVarBndr _ _ _ _ = panic "bindLHsTyVarBndr: Impossible Match"
1005 -- due to #15884
1006
1007 newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name
1008 newTyVarNameRn mb_assoc (dL->L loc rdr)
1009 = do { rdr_env <- getLocalRdrEnv
1010 ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of
1011 (Just _, Just n) -> return n
1012 -- Use the same Name as the parent class decl
1013
1014 _ -> newLocalBndrRn (cL loc rdr) }
1015 {-
1016 *********************************************************
1017 * *
1018 ConDeclField
1019 * *
1020 *********************************************************
1021
1022 When renaming a ConDeclField, we have to find the FieldLabel
1023 associated with each field. But we already have all the FieldLabels
1024 available (since they were brought into scope by
1025 RnNames.getLocalNonValBinders), so we just take the list as an
1026 argument, build a map and look them up.
1027 -}
1028
1029 rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs]
1030 -> RnM ([LConDeclField GhcRn], FreeVars)
1031 -- Also called from RnSource
1032 -- No wildcards can appear in record fields
1033 rnConDeclFields ctxt fls fields
1034 = mapFvRn (rnField fl_env env) fields
1035 where
1036 env = mkTyKiEnv ctxt TypeLevel RnTypeBody
1037 fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]
1038
1039 rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs
1040 -> RnM (LConDeclField GhcRn, FreeVars)
1041 rnField fl_env env (dL->L l (ConDeclField _ names ty haddock_doc))
1042 = do { let new_names = map (fmap lookupField) names
1043 ; (new_ty, fvs) <- rnLHsTyKi env ty
1044 ; new_haddock_doc <- rnMbLHsDoc haddock_doc
1045 ; return (cL l (ConDeclField noExtField new_names new_ty new_haddock_doc)
1046 , fvs) }
1047 where
1048 lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn
1049 lookupField (FieldOcc _ (dL->L lr rdr)) =
1050 FieldOcc (flSelector fl) (cL lr rdr)
1051 where
1052 lbl = occNameFS $ rdrNameOcc rdr
1053 fl = expectJust "rnField" $ lookupFsEnv fl_env lbl
1054 lookupField (XFieldOcc nec) = noExtCon nec
1055 rnField _ _ (dL->L _ (XConDeclField nec)) = noExtCon nec
1056 rnField _ _ _ = panic "rnField: Impossible Match"
1057 -- due to #15884
1058
1059 {-
1060 ************************************************************************
1061 * *
1062 Fixities and precedence parsing
1063 * *
1064 ************************************************************************
1065
1066 @mkOpAppRn@ deals with operator fixities. The argument expressions
1067 are assumed to be already correctly arranged. It needs the fixities
1068 recorded in the OpApp nodes, because fixity info applies to the things
1069 the programmer actually wrote, so you can't find it out from the Name.
1070
1071 Furthermore, the second argument is guaranteed not to be another
1072 operator application. Why? Because the parser parses all
1073 operator applications left-associatively, EXCEPT negation, which
1074 we need to handle specially.
1075 Infix types are read in a *right-associative* way, so that
1076 a `op` b `op` c
1077 is always read in as
1078 a `op` (b `op` c)
1079
1080 mkHsOpTyRn rearranges where necessary. The two arguments
1081 have already been renamed and rearranged. It's made rather tiresome
1082 by the presence of ->, which is a separate syntactic construct.
1083 -}
1084
1085 ---------------
1086 -- Building (ty1 `op1` (ty21 `op2` ty22))
1087 mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
1088 -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn
1089 -> RnM (HsType GhcRn)
1090
1091 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsOpTy noExtField ty21 op2 ty22))
1092 = do { fix2 <- lookupTyFixityRn op2
1093 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
1094 (\t1 t2 -> HsOpTy noExtField t1 op2 t2)
1095 (unLoc op2) fix2 ty21 ty22 loc2 }
1096
1097 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsFunTy _ ty21 ty22))
1098 = mk_hs_op_ty mk1 pp_op1 fix1 ty1
1099 (HsFunTy noExtField) funTyConName funTyFixity ty21 ty22 loc2
1100
1101 mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment
1102 = return (mk1 ty1 ty2)
1103
1104 ---------------
1105 mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
1106 -> Name -> Fixity -> LHsType GhcRn
1107 -> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
1108 -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> SrcSpan
1109 -> RnM (HsType GhcRn)
1110 mk_hs_op_ty mk1 op1 fix1 ty1
1111 mk2 op2 fix2 ty21 ty22 loc2
1112 | nofix_error = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2)
1113 ; return (mk1 ty1 (cL loc2 (mk2 ty21 ty22))) }
1114 | associate_right = return (mk1 ty1 (cL loc2 (mk2 ty21 ty22)))
1115 | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
1116 new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
1117 ; return (mk2 (noLoc new_ty) ty22) }
1118 where
1119 (nofix_error, associate_right) = compareFixity fix1 fix2
1120
1121
1122 ---------------------------
1123 mkOpAppRn :: LHsExpr GhcRn -- Left operand; already rearranged
1124 -> LHsExpr GhcRn -> Fixity -- Operator and fixity
1125 -> LHsExpr GhcRn -- Right operand (not an OpApp, but might
1126 -- be a NegApp)
1127 -> RnM (HsExpr GhcRn)
1128
1129 -- (e11 `op1` e12) `op2` e2
1130 mkOpAppRn e1@(dL->L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2
1131 | nofix_error
1132 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
1133 return (OpApp fix2 e1 op2 e2)
1134
1135 | associate_right = do
1136 new_e <- mkOpAppRn e12 op2 fix2 e2
1137 return (OpApp fix1 e11 op1 (cL loc' new_e))
1138 where
1139 loc'= combineLocs e12 e2
1140 (nofix_error, associate_right) = compareFixity fix1 fix2
1141
1142 ---------------------------
1143 -- (- neg_arg) `op` e2
1144 mkOpAppRn e1@(dL->L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2
1145 | nofix_error
1146 = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2)
1147 return (OpApp fix2 e1 op2 e2)
1148
1149 | associate_right
1150 = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
1151 return (NegApp noExtField (cL loc' new_e) neg_name)
1152 where
1153 loc' = combineLocs neg_arg e2
1154 (nofix_error, associate_right) = compareFixity negateFixity fix2
1155
1156 ---------------------------
1157 -- e1 `op` - neg_arg
1158 mkOpAppRn e1 op1 fix1 e2@(dL->L _ (NegApp {})) -- NegApp can occur on the right
1159 | not associate_right -- We *want* right association
1160 = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity)
1161 return (OpApp fix1 e1 op1 e2)
1162 where
1163 (_, associate_right) = compareFixity fix1 negateFixity
1164
1165 ---------------------------
1166 -- Default case
1167 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
1168 = ASSERT2( right_op_ok fix (unLoc e2),
1169 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
1170 )
1171 return (OpApp fix e1 op e2)
1172
1173 ----------------------------
1174
1175 -- | Name of an operator in an operator application or section
1176 data OpName = NormalOp Name -- ^ A normal identifier
1177 | NegateOp -- ^ Prefix negation
1178 | UnboundOp UnboundVar -- ^ An unbound indentifier
1179 | RecFldOp (AmbiguousFieldOcc GhcRn)
1180 -- ^ A (possibly ambiguous) record field occurrence
1181
1182 instance Outputable OpName where
1183 ppr (NormalOp n) = ppr n
1184 ppr NegateOp = ppr negateName
1185 ppr (UnboundOp uv) = ppr uv
1186 ppr (RecFldOp fld) = ppr fld
1187
1188 get_op :: LHsExpr GhcRn -> OpName
1189 -- An unbound name could be either HsVar or HsUnboundVar
1190 -- See RnExpr.rnUnboundVar
1191 get_op (dL->L _ (HsVar _ n)) = NormalOp (unLoc n)
1192 get_op (dL->L _ (HsUnboundVar _ uv)) = UnboundOp uv
1193 get_op (dL->L _ (HsRecFld _ fld)) = RecFldOp fld
1194 get_op other = pprPanic "get_op" (ppr other)
1195
1196 -- Parser left-associates everything, but
1197 -- derived instances may have correctly-associated things to
1198 -- in the right operand. So we just check that the right operand is OK
1199 right_op_ok :: Fixity -> HsExpr GhcRn -> Bool
1200 right_op_ok fix1 (OpApp fix2 _ _ _)
1201 = not error_please && associate_right
1202 where
1203 (error_please, associate_right) = compareFixity fix1 fix2
1204 right_op_ok _ _
1205 = True
1206
1207 -- Parser initially makes negation bind more tightly than any other operator
1208 -- And "deriving" code should respect this (use HsPar if not)
1209 mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id)
1210 -> RnM (HsExpr (GhcPass id))
1211 mkNegAppRn neg_arg neg_name
1212 = ASSERT( not_op_app (unLoc neg_arg) )
1213 return (NegApp noExtField neg_arg neg_name)
1214
1215 not_op_app :: HsExpr id -> Bool
1216 not_op_app (OpApp {}) = False
1217 not_op_app _ = True
1218
1219 ---------------------------
1220 mkOpFormRn :: LHsCmdTop GhcRn -- Left operand; already rearranged
1221 -> LHsExpr GhcRn -> Fixity -- Operator and fixity
1222 -> LHsCmdTop GhcRn -- Right operand (not an infix)
1223 -> RnM (HsCmd GhcRn)
1224
1225 -- (e11 `op1` e12) `op2` e2
1226 mkOpFormRn a1@(dL->L loc
1227 (HsCmdTop _
1228 (dL->L _ (HsCmdArrForm x op1 f (Just fix1)
1229 [a11,a12]))))
1230 op2 fix2 a2
1231 | nofix_error
1232 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
1233 return (HsCmdArrForm x op2 f (Just fix2) [a1, a2])
1234
1235 | associate_right
1236 = do new_c <- mkOpFormRn a12 op2 fix2 a2
1237 return (HsCmdArrForm noExtField op1 f (Just fix1)
1238 [a11, cL loc (HsCmdTop [] (cL loc new_c))])
1239 -- TODO: locs are wrong
1240 where
1241 (nofix_error, associate_right) = compareFixity fix1 fix2
1242
1243 -- Default case
1244 mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
1245 = return (HsCmdArrForm noExtField op Infix (Just fix) [arg1, arg2])
1246
1247
1248 --------------------------------------
1249 mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn
1250 -> RnM (Pat GhcRn)
1251
1252 mkConOpPatRn op2 fix2 p1@(dL->L loc (ConPatIn op1 (InfixCon p11 p12))) p2
1253 = do { fix1 <- lookupFixityRn (unLoc op1)
1254 ; let (nofix_error, associate_right) = compareFixity fix1 fix2
1255
1256 ; if nofix_error then do
1257 { precParseErr (NormalOp (unLoc op1),fix1)
1258 (NormalOp (unLoc op2),fix2)
1259 ; return (ConPatIn op2 (InfixCon p1 p2)) }
1260
1261 else if associate_right then do
1262 { new_p <- mkConOpPatRn op2 fix2 p12 p2
1263 ; return (ConPatIn op1 (InfixCon p11 (cL loc new_p))) }
1264 -- XXX loc right?
1265 else return (ConPatIn op2 (InfixCon p1 p2)) }
1266
1267 mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment
1268 = ASSERT( not_op_pat (unLoc p2) )
1269 return (ConPatIn op (InfixCon p1 p2))
1270
1271 not_op_pat :: Pat GhcRn -> Bool
1272 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
1273 not_op_pat _ = True
1274
1275 --------------------------------------
1276 checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM ()
1277 -- Check precedence of a function binding written infix
1278 -- eg a `op` b `C` c = ...
1279 -- See comments with rnExpr (OpApp ...) about "deriving"
1280
1281 checkPrecMatch op (MG { mg_alts = (dL->L _ ms) })
1282 = mapM_ check ms
1283 where
1284 check (dL->L _ (Match { m_pats = (dL->L l1 p1)
1285 : (dL->L l2 p2)
1286 : _ }))
1287 = setSrcSpan (combineSrcSpans l1 l2) $
1288 do checkPrec op p1 False
1289 checkPrec op p2 True
1290
1291 check _ = return ()
1292 -- This can happen. Consider
1293 -- a `op` True = ...
1294 -- op = ...
1295 -- The infix flag comes from the first binding of the group
1296 -- but the second eqn has no args (an error, but not discovered
1297 -- until the type checker). So we don't want to crash on the
1298 -- second eqn.
1299 checkPrecMatch _ (XMatchGroup nec) = noExtCon nec
1300
1301 checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
1302 checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
1303 op_fix@(Fixity _ op_prec op_dir) <- lookupFixityRn op
1304 op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
1305 let
1306 inf_ok = op1_prec > op_prec ||
1307 (op1_prec == op_prec &&
1308 (op1_dir == InfixR && op_dir == InfixR && right ||
1309 op1_dir == InfixL && op_dir == InfixL && not right))
1310
1311 info = (NormalOp op, op_fix)
1312 info1 = (NormalOp (unLoc op1), op1_fix)
1313 (infol, infor) = if right then (info, info1) else (info1, info)
1314 unless inf_ok (precParseErr infol infor)
1315
1316 checkPrec _ _ _
1317 = return ()
1318
1319 -- Check precedence of (arg op) or (op arg) respectively
1320 -- If arg is itself an operator application, then either
1321 -- (a) its precedence must be higher than that of op
1322 -- (b) its precedency & associativity must be the same as that of op
1323 checkSectionPrec :: FixityDirection -> HsExpr GhcPs
1324 -> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM ()
1325 checkSectionPrec direction section op arg
1326 = case unLoc arg of
1327 OpApp fix _ op' _ -> go_for_it (get_op op') fix
1328 NegApp _ _ _ -> go_for_it NegateOp negateFixity
1329 _ -> return ()
1330 where
1331 op_name = get_op op
1332 go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do
1333 op_fix@(Fixity _ op_prec _) <- lookupFixityOp op_name
1334 unless (op_prec < arg_prec
1335 || (op_prec == arg_prec && direction == assoc))
1336 (sectionPrecErr (get_op op, op_fix)
1337 (arg_op, arg_fix) section)
1338
1339 -- | Look up the fixity for an operator name. Be careful to use
1340 -- 'lookupFieldFixityRn' for (possibly ambiguous) record fields
1341 -- (see #13132).
1342 lookupFixityOp :: OpName -> RnM Fixity
1343 lookupFixityOp (NormalOp n) = lookupFixityRn n
1344 lookupFixityOp NegateOp = lookupFixityRn negateName
1345 lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName (unboundVarOcc u))
1346 lookupFixityOp (RecFldOp f) = lookupFieldFixityRn f
1347
1348
1349 -- Precedence-related error messages
1350
1351 precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM ()
1352 precParseErr op1@(n1,_) op2@(n2,_)
1353 | is_unbound n1 || is_unbound n2
1354 = return () -- Avoid error cascade
1355 | otherwise
1356 = addErr $ hang (text "Precedence parsing error")
1357 4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"),
1358 ppr_opfix op2,
1359 text "in the same infix expression"])
1360
1361 sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr GhcPs -> RnM ()
1362 sectionPrecErr op@(n1,_) arg_op@(n2,_) section
1363 | is_unbound n1 || is_unbound n2
1364 = return () -- Avoid error cascade
1365 | otherwise
1366 = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"),
1367 nest 4 (sep [text "must have lower precedence than that of the operand,",
1368 nest 2 (text "namely" <+> ppr_opfix arg_op)]),
1369 nest 4 (text "in the section:" <+> quotes (ppr section))]
1370
1371 is_unbound :: OpName -> Bool
1372 is_unbound (NormalOp n) = isUnboundName n
1373 is_unbound UnboundOp{} = True
1374 is_unbound _ = False
1375
1376 ppr_opfix :: (OpName, Fixity) -> SDoc
1377 ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
1378 where
1379 pp_op | NegateOp <- op = text "prefix `-'"
1380 | otherwise = quotes (ppr op)
1381
1382
1383 {- *****************************************************
1384 * *
1385 Errors
1386 * *
1387 ***************************************************** -}
1388
1389 unexpectedTypeSigErr :: LHsSigWcType GhcPs -> SDoc
1390 unexpectedTypeSigErr ty
1391 = hang (text "Illegal type signature:" <+> quotes (ppr ty))
1392 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables")
1393
1394 badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM ()
1395 badKindSigErr doc (dL->L loc ty)
1396 = setSrcSpan loc $ addErr $
1397 withHsDocContext doc $
1398 hang (text "Illegal kind signature:" <+> quotes (ppr ty))
1399 2 (text "Perhaps you intended to use KindSignatures")
1400
1401 dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc
1402 dataKindsErr env thing
1403 = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing))
1404 2 (text "Perhaps you intended to use DataKinds")
1405 where
1406 pp_what | isRnKindLevel env = text "kind"
1407 | otherwise = text "type"
1408
1409 inTypeDoc :: HsType GhcPs -> SDoc
1410 inTypeDoc ty = text "In the type" <+> quotes (ppr ty)
1411
1412 warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM ()
1413 warnUnusedForAll in_doc (dL->L loc tv) used_names
1414 = whenWOptM Opt_WarnUnusedForalls $
1415 unless (hsTyVarName tv `elemNameSet` used_names) $
1416 addWarnAt (Reason Opt_WarnUnusedForalls) loc $
1417 vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)
1418 , in_doc ]
1419
1420 opTyErr :: Outputable a => RdrName -> a -> SDoc
1421 opTyErr op overall_ty
1422 = hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty))
1423 2 (text "Use TypeOperators to allow operators in types")
1424
1425 {-
1426 ************************************************************************
1427 * *
1428 Finding the free type variables of a (HsType RdrName)
1429 * *
1430 ************************************************************************
1431
1432
1433 Note [Kind and type-variable binders]
1434 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1435 In a type signature we may implicitly bind type/kind variables. For example:
1436 * f :: a -> a
1437 f = ...
1438 Here we need to find the free type variables of (a -> a),
1439 so that we know what to quantify
1440
1441 * class C (a :: k) where ...
1442 This binds 'k' in ..., as well as 'a'
1443
1444 * f (x :: a -> [a]) = ....
1445 Here we bind 'a' in ....
1446
1447 * f (x :: T a -> T (b :: k)) = ...
1448 Here we bind both 'a' and the kind variable 'k'
1449
1450 * type instance F (T (a :: Maybe k)) = ...a...k...
1451 Here we want to constrain the kind of 'a', and bind 'k'.
1452
1453 To do that, we need to walk over a type and find its free type/kind variables.
1454 We preserve the left-to-right order of each variable occurrence.
1455 See Note [Ordering of implicit variables].
1456
1457 Clients of this code can remove duplicates with nubL.
1458
1459 Note [Ordering of implicit variables]
1460 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1461 Since the advent of -XTypeApplications, GHC makes promises about the ordering
1462 of implicit variable quantification. Specifically, we offer that implicitly
1463 quantified variables (such as those in const :: a -> b -> a, without a `forall`)
1464 will occur in left-to-right order of first occurrence. Here are a few examples:
1465
1466 const :: a -> b -> a -- forall a b. ...
1467 f :: Eq a => b -> a -> a -- forall a b. ... contexts are included
1468
1469 type a <-< b = b -> a
1470 g :: a <-< b -- forall a b. ... type synonyms matter
1471
1472 class Functor f where
1473 fmap :: (a -> b) -> f a -> f b -- forall f a b. ...
1474 -- The f is quantified by the class, so only a and b are considered in fmap
1475
1476 This simple story is complicated by the possibility of dependency: all variables
1477 must come after any variables mentioned in their kinds.
1478
1479 typeRep :: Typeable a => TypeRep (a :: k) -- forall k a. ...
1480
1481 The k comes first because a depends on k, even though the k appears later than
1482 the a in the code. Thus, GHC does ScopedSort on the variables.
1483 See Note [ScopedSort] in Type.
1484
1485 Implicitly bound variables are collected by any function which returns a
1486 FreeKiTyVars, FreeKiTyVarsWithDups, or FreeKiTyVarsNoDups, which notably
1487 includes the `extract-` family of functions (extractHsTysRdrTyVarsDups,
1488 extractHsTyVarBndrsKVs, etc.).
1489 These functions thus promise to keep left-to-right ordering.
1490
1491 Note [Implicit quantification in type synonyms]
1492 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1493 We typically bind type/kind variables implicitly when they are in a kind
1494 annotation on the LHS, for example:
1495
1496 data Proxy (a :: k) = Proxy
1497 type KindOf (a :: k) = k
1498
1499 Here 'k' is in the kind annotation of a type variable binding, KindedTyVar, and
1500 we want to implicitly quantify over it. This is easy: just extract all free
1501 variables from the kind signature. That's what we do in extract_hs_tv_bndrs_kvs
1502
1503 By contrast, on the RHS we can't simply collect *all* free variables. Which of
1504 the following are allowed?
1505
1506 type TySyn1 = a :: Type
1507 type TySyn2 = 'Nothing :: Maybe a
1508 type TySyn3 = 'Just ('Nothing :: Maybe a)
1509 type TySyn4 = 'Left a :: Either Type a
1510
1511 After some design deliberations (see non-taken alternatives below), the answer
1512 is to reject TySyn1 and TySyn3, but allow TySyn2 and TySyn4, at least for now.
1513 We implicitly quantify over free variables of the outermost kind signature, if
1514 one exists:
1515
1516 * In TySyn1, the outermost kind signature is (:: Type), and it does not have
1517 any free variables.
1518 * In TySyn2, the outermost kind signature is (:: Maybe a), it contains a
1519 free variable 'a', which we implicitly quantify over.
1520 * In TySyn3, there is no outermost kind signature. The (:: Maybe a) signature
1521 is hidden inside 'Just.
1522 * In TySyn4, the outermost kind signature is (:: Either Type a), it contains
1523 a free variable 'a', which we implicitly quantify over. That is why we can
1524 also use it to the left of the double colon: 'Left a
1525
1526 The logic resides in extractHsTyRdrTyVarsKindVars. We use it both for type
1527 synonyms and type family instances.
1528
1529 This is something of a stopgap solution until we can explicitly bind invisible
1530 type/kind variables:
1531
1532 type TySyn3 :: forall a. Maybe a
1533 type TySyn3 @a = 'Just ('Nothing :: Maybe a)
1534
1535 Note [Implicit quantification in type synonyms: non-taken alternatives]
1536 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1537
1538 Alternative I: No quantification
1539 --------------------------------
1540 We could offer no implicit quantification on the RHS, accepting none of the
1541 TySyn<N> examples. The user would have to bind the variables explicitly:
1542
1543 type TySyn1 a = a :: Type
1544 type TySyn2 a = 'Nothing :: Maybe a
1545 type TySyn3 a = 'Just ('Nothing :: Maybe a)
1546 type TySyn4 a = 'Left a :: Either Type a
1547
1548 However, this would mean that one would have to specify 'a' at call sites every
1549 time, which could be undesired.
1550
1551 Alternative II: Indiscriminate quantification
1552 ---------------------------------------------
1553 We could implicitly quantify over all free variables on the RHS just like we do
1554 on the LHS. Then we would infer the following kinds:
1555
1556 TySyn1 :: forall {a}. Type
1557 TySyn2 :: forall {a}. Maybe a
1558 TySyn3 :: forall {a}. Maybe (Maybe a)
1559 TySyn4 :: forall {a}. Either Type a
1560
1561 This would work fine for TySyn<2,3,4>, but TySyn1 is clearly bogus: the variable
1562 is free-floating, not fixed by anything.
1563
1564 Alternative III: reportFloatingKvs
1565 ----------------------------------
1566 We could augment Alternative II by hunting down free-floating variables during
1567 type checking. While viable, this would mean we'd end up accepting this:
1568
1569 data Prox k (a :: k)
1570 type T = Prox k
1571
1572 -}
1573
1574 -- See Note [Kind and type-variable binders]
1575 -- These lists are guaranteed to preserve left-to-right ordering of
1576 -- the types the variables were extracted from. See also
1577 -- Note [Ordering of implicit variables].
1578 type FreeKiTyVars = [Located RdrName]
1579
1580 -- | A 'FreeKiTyVars' list that is allowed to have duplicate variables.
1581 type FreeKiTyVarsWithDups = FreeKiTyVars
1582
1583 -- | A 'FreeKiTyVars' list that contains no duplicate variables.
1584 type FreeKiTyVarsNoDups = FreeKiTyVars
1585
1586 filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
1587 filterInScope rdr_env = filterOut (inScope rdr_env . unLoc)
1588
1589 filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars
1590 filterInScopeM vars
1591 = do { rdr_env <- getLocalRdrEnv
1592 ; return (filterInScope rdr_env vars) }
1593
1594 inScope :: LocalRdrEnv -> RdrName -> Bool
1595 inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env
1596
1597 extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
1598 extract_tyarg (HsValArg ty) acc = extract_lty ty acc
1599 extract_tyarg (HsTypeArg _ ki) acc = extract_lty ki acc
1600 extract_tyarg (HsArgPar _) acc = acc
1601
1602 extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
1603 extract_tyargs args acc = foldr extract_tyarg acc args
1604
1605 extractHsTyArgRdrKiTyVarsDup :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups
1606 extractHsTyArgRdrKiTyVarsDup args
1607 = extract_tyargs args []
1608
1609 -- | 'extractHsTyRdrTyVars' finds the type/kind variables
1610 -- of a HsType/HsKind.
1611 -- It's used when making the @forall@s explicit.
1612 -- When the same name occurs multiple times in the types, only the first
1613 -- occurrence is returned.
1614 -- See Note [Kind and type-variable binders]
1615 extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVarsNoDups
1616 extractHsTyRdrTyVars ty
1617 = nubL (extractHsTyRdrTyVarsDups ty)
1618
1619 -- | 'extractHsTyRdrTyVarsDups' finds the type/kind variables
1620 -- of a HsType/HsKind.
1621 -- It's used when making the @forall@s explicit.
1622 -- When the same name occurs multiple times in the types, all occurrences
1623 -- are returned.
1624 extractHsTyRdrTyVarsDups :: LHsType GhcPs -> FreeKiTyVarsWithDups
1625 extractHsTyRdrTyVarsDups ty
1626 = extract_lty ty []
1627
1628 -- | Extracts the free type/kind variables from the kind signature of a HsType.
1629 -- This is used to implicitly quantify over @k@ in @type T = Nothing :: Maybe k@.
1630 -- When the same name occurs multiple times in the type, only the first
1631 -- occurrence is returned, and the left-to-right order of variables is
1632 -- preserved.
1633 -- See Note [Kind and type-variable binders] and
1634 -- Note [Ordering of implicit variables] and
1635 -- Note [Implicit quantification in type synonyms].
1636 extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> FreeKiTyVarsNoDups
1637 extractHsTyRdrTyVarsKindVars (unLoc -> ty) =
1638 case ty of
1639 HsParTy _ ty -> extractHsTyRdrTyVarsKindVars ty
1640 HsKindSig _ _ ki -> extractHsTyRdrTyVars ki
1641 _ -> []
1642
1643 -- | Extracts free type and kind variables from types in a list.
1644 -- When the same name occurs multiple times in the types, all occurrences
1645 -- are returned.
1646 extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> FreeKiTyVarsWithDups
1647 extractHsTysRdrTyVarsDups tys
1648 = extract_ltys tys []
1649
1650 -- Returns the free kind variables of any explictly-kinded binders, returning
1651 -- variable occurrences in left-to-right order.
1652 -- See Note [Ordering of implicit variables].
1653 -- NB: Does /not/ delete the binders themselves.
1654 -- However duplicates are removed
1655 -- E.g. given [k1, a:k1, b:k2]
1656 -- the function returns [k1,k2], even though k1 is bound here
1657 extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVarsNoDups
1658 extractHsTyVarBndrsKVs tv_bndrs
1659 = nubL (extract_hs_tv_bndrs_kvs tv_bndrs)
1660
1661 -- Returns the free kind variables in a type family result signature, returning
1662 -- variable occurrences in left-to-right order.
1663 -- See Note [Ordering of implicit variables].
1664 extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName]
1665 extractRdrKindSigVars (dL->L _ resultSig)
1666 | KindSig _ k <- resultSig = extractHsTyRdrTyVars k
1667 | TyVarSig _ (dL->L _ (KindedTyVar _ _ k)) <- resultSig = extractHsTyRdrTyVars k
1668 | otherwise = []
1669
1670 -- Get type/kind variables mentioned in the kind signature, preserving
1671 -- left-to-right order and without duplicates:
1672 --
1673 -- * data T a (b :: k1) :: k2 -> k1 -> k2 -> Type -- result: [k2,k1]
1674 -- * data T a (b :: k1) -- result: []
1675 --
1676 -- See Note [Ordering of implicit variables].
1677 extractDataDefnKindVars :: HsDataDefn GhcPs -> FreeKiTyVarsNoDups
1678 extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig })
1679 = maybe [] extractHsTyRdrTyVars ksig
1680 extractDataDefnKindVars (XHsDataDefn nec) = noExtCon nec
1681
1682 extract_lctxt :: LHsContext GhcPs
1683 -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
1684 extract_lctxt ctxt = extract_ltys (unLoc ctxt)
1685
1686 extract_ltys :: [LHsType GhcPs]
1687 -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
1688 extract_ltys tys acc = foldr extract_lty acc tys
1689
1690 extract_lty :: LHsType GhcPs
1691 -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
1692 extract_lty (dL->L _ ty) acc
1693 = case ty of
1694 HsTyVar _ _ ltv -> extract_tv ltv acc
1695 HsBangTy _ _ ty -> extract_lty ty acc
1696 HsRecTy _ flds -> foldr (extract_lty
1697 . cd_fld_type . unLoc) acc
1698 flds
1699 HsAppTy _ ty1 ty2 -> extract_lty ty1 $
1700 extract_lty ty2 acc
1701 HsAppKindTy _ ty k -> extract_lty ty $
1702 extract_lty k acc
1703 HsListTy _ ty -> extract_lty ty acc
1704 HsTupleTy _ _ tys -> extract_ltys tys acc
1705 HsSumTy _ tys -> extract_ltys tys acc
1706 HsFunTy _ ty1 ty2 -> extract_lty ty1 $
1707 extract_lty ty2 acc
1708 HsIParamTy _ _ ty -> extract_lty ty acc
1709 HsOpTy _ ty1 tv ty2 -> extract_tv tv $
1710 extract_lty ty1 $
1711 extract_lty ty2 acc
1712 HsParTy _ ty -> extract_lty ty acc
1713 HsSpliceTy {} -> acc -- Type splices mention no tvs
1714 HsDocTy _ ty _ -> extract_lty ty acc
1715 HsExplicitListTy _ _ tys -> extract_ltys tys acc
1716 HsExplicitTupleTy _ tys -> extract_ltys tys acc
1717 HsTyLit _ _ -> acc
1718 HsStarTy _ _ -> acc
1719 HsKindSig _ ty ki -> extract_lty ty $
1720 extract_lty ki acc
1721 HsForAllTy { hst_bndrs = tvs, hst_body = ty }
1722 -> extract_hs_tv_bndrs tvs acc $
1723 extract_lty ty []
1724 HsQualTy { hst_ctxt = ctxt, hst_body = ty }
1725 -> extract_lctxt ctxt $
1726 extract_lty ty acc
1727 XHsType {} -> acc
1728 -- We deal with these separately in rnLHsTypeWithWildCards
1729 HsWildCardTy {} -> acc
1730
1731 extractHsTvBndrs :: [LHsTyVarBndr GhcPs]
1732 -> FreeKiTyVarsWithDups -- Free in body
1733 -> FreeKiTyVarsWithDups -- Free in result
1734 extractHsTvBndrs tv_bndrs body_fvs
1735 = extract_hs_tv_bndrs tv_bndrs [] body_fvs
1736
1737 extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs]
1738 -> FreeKiTyVarsWithDups -- Accumulator
1739 -> FreeKiTyVarsWithDups -- Free in body
1740 -> FreeKiTyVarsWithDups
1741 -- In (forall (a :: Maybe e). a -> b) we have
1742 -- 'a' is bound by the forall
1743 -- 'b' is a free type variable
1744 -- 'e' is a free kind variable
1745 extract_hs_tv_bndrs tv_bndrs acc_vars body_vars
1746 | null tv_bndrs = body_vars ++ acc_vars
1747 | otherwise = filterOut (`elemRdr` tv_bndr_rdrs) (bndr_vars ++ body_vars) ++ acc_vars
1748 -- NB: delete all tv_bndr_rdrs from bndr_vars as well as body_vars.
1749 -- See Note [Kind variable scoping]
1750 where
1751 bndr_vars = extract_hs_tv_bndrs_kvs tv_bndrs
1752 tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs
1753
1754 extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName]
1755 -- Returns the free kind variables of any explictly-kinded binders, returning
1756 -- variable occurrences in left-to-right order.
1757 -- See Note [Ordering of implicit variables].
1758 -- NB: Does /not/ delete the binders themselves.
1759 -- Duplicates are /not/ removed
1760 -- E.g. given [k1, a:k1, b:k2]
1761 -- the function returns [k1,k2], even though k1 is bound here
1762 extract_hs_tv_bndrs_kvs tv_bndrs =
1763 foldr extract_lty []
1764 [k | (dL->L _ (KindedTyVar _ _ k)) <- tv_bndrs]
1765
1766 extract_tv :: Located RdrName
1767 -> [Located RdrName] -> [Located RdrName]
1768 extract_tv tv acc =
1769 if isRdrTyVar (unLoc tv) then tv:acc else acc
1770
1771 -- Deletes duplicates in a list of Located things.
1772 --
1773 -- Importantly, this function is stable with respect to the original ordering
1774 -- of things in the list. This is important, as it is a property that GHC
1775 -- relies on to maintain the left-to-right ordering of implicitly quantified
1776 -- type variables.
1777 -- See Note [Ordering of implicit variables].
1778 nubL :: Eq a => [Located a] -> [Located a]
1779 nubL = nubBy eqLocated
1780
1781 elemRdr :: Located RdrName -> [Located RdrName] -> Bool
1782 elemRdr x = any (eqLocated x)