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