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