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