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