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