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