8d3b79704bd9b51e8293589a7738cf90183cb14a
[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 CPP #-}
8
9 module RnTypes (
10 -- Type related stuff
11 rnHsType, rnLHsType, rnLHsTypes, rnContext,
12 rnHsKind, rnLHsKind, rnLHsMaybeKind,
13 rnHsSigType, rnLHsInstType, rnConDeclFields,
14 newTyVarNameRn,
15
16 -- Precence related stuff
17 mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
18 checkPrecMatch, checkSectionPrec,
19
20 -- Binding related stuff
21 warnContextQuantification, warnUnusedForAlls,
22 bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig,
23 extractHsTyRdrTyVars, extractHsTysRdrTyVars,
24 extractRdrKindSigVars, extractDataDefnKindVars,
25 extractWildcards, filterInScope
26 ) where
27
28 import {-# SOURCE #-} TcSplice( runQuasiQuoteType )
29 import {-# SOURCE #-} RnSplice( rnSpliceType )
30
31 import DynFlags
32 import HsSyn
33 import RnHsDoc ( rnLHsDoc, rnMbLHsDoc )
34 import RnEnv
35 import TcRnMonad
36 import RdrName
37 import PrelNames
38 import TysPrim ( funTyConName )
39 import Name
40 import SrcLoc
41 import NameSet
42
43 import Util
44 import BasicTypes ( compareFixity, funTyFixity, negateFixity,
45 Fixity(..), FixityDirection(..) )
46 import Outputable
47 import FastString
48 import Maybes
49 import Data.List ( nub, nubBy )
50 import Control.Monad ( unless, when )
51
52 #include "HsVersions.h"
53
54 {-
55 These type renamers are in a separate module, rather than in (say) RnSource,
56 to break several loop.
57
58 *********************************************************
59 * *
60 \subsection{Renaming types}
61 * *
62 *********************************************************
63 -}
64
65 rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
66 -- rnHsSigType is used for source-language type signatures,
67 -- which use *implicit* universal quantification.
68 rnHsSigType doc_str ty = rnLHsType (TypeSigCtx doc_str) ty
69
70 rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
71 -- Rename the type in an instance or standalone deriving decl
72 rnLHsInstType doc_str ty
73 = do { (ty', fvs) <- rnLHsType (GenericCtx doc_str) ty
74 ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty))
75 ; return (ty', fvs) }
76 where
77 good_inst_ty
78 | Just (_, _, L _ cls, _) <- splitLHsInstDeclTy_maybe ty
79 , isTcOcc (rdrNameOcc cls) = True
80 | otherwise = False
81
82 badInstTy :: LHsType RdrName -> SDoc
83 badInstTy ty = ptext (sLit "Malformed instance:") <+> ppr ty
84
85 {-
86 rnHsType is here because we call it from loadInstDecl, and I didn't
87 want a gratuitous knot.
88
89 Note [Context quantification]
90 -----------------------------
91 Variables in type signatures are implicitly quantified
92 when (1) they are in a type signature not beginning
93 with "forall" or (2) in any qualified type T => R.
94 We are phasing out (2) since it leads to inconsistencies
95 (Trac #4426):
96
97 data A = A (a -> a) is an error
98 data A = A (Eq a => a -> a) binds "a"
99 data A = A (Eq a => a -> b) binds "a" and "b"
100 data A = A (() => a -> b) binds "a" and "b"
101 f :: forall a. a -> b is an error
102 f :: forall a. () => a -> b is an error
103 f :: forall a. a -> (() => b) binds "a" and "b"
104
105 The -fwarn-context-quantification flag warns about
106 this situation. See rnHsTyKi for case HsForAllTy Qualified.
107 -}
108
109 rnLHsTyKi :: Bool -- True <=> renaming a type, False <=> a kind
110 -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
111 rnLHsTyKi isType doc (L loc ty)
112 = setSrcSpan loc $
113 do { (ty', fvs) <- rnHsTyKi isType doc ty
114 ; return (L loc ty', fvs) }
115
116 rnLHsType :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
117 rnLHsType = rnLHsTyKi True
118
119 rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars)
120 rnLHsKind = rnLHsTyKi False
121
122 rnLHsMaybeKind :: HsDocContext -> Maybe (LHsKind RdrName)
123 -> RnM (Maybe (LHsKind Name), FreeVars)
124 rnLHsMaybeKind _ Nothing
125 = return (Nothing, emptyFVs)
126 rnLHsMaybeKind doc (Just kind)
127 = do { (kind', fvs) <- rnLHsKind doc kind
128 ; return (Just kind', fvs) }
129
130 rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
131 rnHsType = rnHsTyKi True
132 rnHsKind :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars)
133 rnHsKind = rnHsTyKi False
134
135 rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
136
137 rnHsTyKi isType doc (HsForAllTy Implicit extra _ lctxt@(L _ ctxt) ty)
138 = ASSERT( isType ) do
139 -- Implicit quantifiction in source code (no kinds on tyvars)
140 -- Given the signature C => T we universally quantify
141 -- over FV(T) \ {in-scope-tyvars}
142 rdr_env <- getLocalRdrEnv
143 loc <- getSrcSpanM
144 let
145 (forall_kvs, forall_tvs) = filterInScope rdr_env $
146 extractHsTysRdrTyVars (ty:ctxt)
147 -- In for-all types we don't bring in scope
148 -- kind variables mentioned in kind signatures
149 -- (Well, not yet anyway....)
150 -- f :: Int -> T (a::k) -- Not allowed
151
152 -- The filterInScope is to ensure that we don't quantify over
153 -- type variables that are in scope; when GlasgowExts is off,
154 -- there usually won't be any, except for class signatures:
155 -- class C a where { op :: a -> a }
156 tyvar_bndrs = userHsTyVarBndrs loc forall_tvs
157
158 rnForAll doc Implicit extra forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty
159
160 rnHsTyKi isType doc fulltype@(HsForAllTy Qualified extra _ lctxt@(L _ ctxt) ty)
161 = ASSERT( isType ) do
162 rdr_env <- getLocalRdrEnv
163 loc <- getSrcSpanM
164 let
165 (forall_kvs, forall_tvs) = filterInScope rdr_env $
166 extractHsTysRdrTyVars (ty:ctxt)
167 tyvar_bndrs = userHsTyVarBndrs loc forall_tvs
168 in_type_doc = ptext (sLit "In the type") <+> quotes (ppr fulltype)
169
170 -- See Note [Context quantification]
171 warnContextQuantification (in_type_doc $$ docOfHsDocContext doc) tyvar_bndrs
172 rnForAll doc Implicit extra forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty
173
174 rnHsTyKi isType doc ty@(HsForAllTy Explicit extra forall_tyvars lctxt@(L _ ctxt) tau)
175 = ASSERT( isType ) do { -- Explicit quantification.
176 -- Check that the forall'd tyvars are actually
177 -- mentioned in the type, and produce a warning if not
178 let (kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt)
179 in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty)
180 ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned
181
182 ; rnForAll doc Explicit extra kvs forall_tyvars lctxt tau }
183
184 rnHsTyKi isType _ (HsTyVar rdr_name)
185 = do { name <- rnTyVar isType rdr_name
186 ; return (HsTyVar name, unitFV name) }
187
188 -- If we see (forall a . ty), without foralls on, the forall will give
189 -- a sensible error message, but we don't want to complain about the dot too
190 -- Hence the jiggery pokery with ty1
191 rnHsTyKi isType doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2)
192 = ASSERT( isType ) setSrcSpan loc $
193 do { ops_ok <- xoptM Opt_TypeOperators
194 ; op' <- if ops_ok
195 then rnTyVar isType op
196 else do { addErr (opTyErr op ty)
197 ; return (mkUnboundName op) } -- Avoid double complaint
198 ; let l_op' = L loc op'
199 ; fix <- lookupTyFixityRn l_op'
200 ; (ty1', fvs1) <- rnLHsType doc ty1
201 ; (ty2', fvs2) <- rnLHsType doc ty2
202 ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2)
203 op' fix ty1' ty2'
204 ; return (res_ty, (fvs1 `plusFV` fvs2) `addOneFV` op') }
205
206 rnHsTyKi isType doc (HsParTy ty)
207 = do { (ty', fvs) <- rnLHsTyKi isType doc ty
208 ; return (HsParTy ty', fvs) }
209
210 rnHsTyKi isType doc (HsBangTy b ty)
211 = ASSERT( isType )
212 do { (ty', fvs) <- rnLHsType doc ty
213 ; return (HsBangTy b ty', fvs) }
214
215 rnHsTyKi _ doc ty@(HsRecTy flds)
216 = do { addErr (hang (ptext (sLit "Record syntax is illegal here:"))
217 2 (ppr ty))
218 ; (flds', fvs) <- rnConDeclFields doc flds
219 ; return (HsRecTy flds', fvs) }
220
221 rnHsTyKi isType doc (HsFunTy ty1 ty2)
222 = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1
223 -- Might find a for-all as the arg of a function type
224 ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2
225 -- Or as the result. This happens when reading Prelude.hi
226 -- when we find return :: forall m. Monad m -> forall a. a -> m a
227
228 -- Check for fixity rearrangements
229 ; res_ty <- if isType
230 then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
231 else return (HsFunTy ty1' ty2')
232 ; return (res_ty, fvs1 `plusFV` fvs2) }
233
234 rnHsTyKi isType doc listTy@(HsListTy ty)
235 = do { data_kinds <- xoptM Opt_DataKinds
236 ; unless (data_kinds || isType) (addErr (dataKindsErr isType listTy))
237 ; (ty', fvs) <- rnLHsTyKi isType doc ty
238 ; return (HsListTy ty', fvs) }
239
240 rnHsTyKi isType doc (HsKindSig ty k)
241 = ASSERT( isType )
242 do { kind_sigs_ok <- xoptM Opt_KindSignatures
243 ; unless kind_sigs_ok (badSigErr False doc ty)
244 ; (ty', fvs1) <- rnLHsType doc ty
245 ; (k', fvs2) <- rnLHsKind doc k
246 ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) }
247
248 rnHsTyKi isType doc (HsPArrTy ty)
249 = ASSERT( isType )
250 do { (ty', fvs) <- rnLHsType doc ty
251 ; return (HsPArrTy ty', fvs) }
252
253 -- Unboxed tuples are allowed to have poly-typed arguments. These
254 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
255 rnHsTyKi isType doc tupleTy@(HsTupleTy tup_con tys)
256 = do { data_kinds <- xoptM Opt_DataKinds
257 ; unless (data_kinds || isType) (addErr (dataKindsErr isType tupleTy))
258 ; (tys', fvs) <- mapFvRn (rnLHsTyKi isType doc) tys
259 ; return (HsTupleTy tup_con tys', fvs) }
260
261 -- Ensure that a type-level integer is nonnegative (#8306, #8412)
262 rnHsTyKi isType _ tyLit@(HsTyLit t)
263 = do { data_kinds <- xoptM Opt_DataKinds
264 ; unless data_kinds (addErr (dataKindsErr isType tyLit))
265 ; when (negLit t) (addErr negLitErr)
266 ; return (HsTyLit t, emptyFVs) }
267 where
268 negLit (HsStrTy _ _) = False
269 negLit (HsNumTy _ i) = i < 0
270 negLitErr = ptext (sLit "Illegal literal in type (type literals must not be negative):") <+> ppr tyLit
271
272 rnHsTyKi isType doc (HsAppTy ty1 ty2)
273 = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1
274 ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2
275 ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) }
276
277 rnHsTyKi isType doc (HsIParamTy n ty)
278 = ASSERT( isType )
279 do { (ty', fvs) <- rnLHsType doc ty
280 ; return (HsIParamTy n ty', fvs) }
281
282 rnHsTyKi isType doc (HsEqTy ty1 ty2)
283 = ASSERT( isType )
284 do { (ty1', fvs1) <- rnLHsType doc ty1
285 ; (ty2', fvs2) <- rnLHsType doc ty2
286 ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) }
287
288 rnHsTyKi isType _ (HsSpliceTy sp k)
289 = ASSERT( isType )
290 rnSpliceType sp k
291
292 rnHsTyKi isType doc (HsDocTy ty haddock_doc)
293 = ASSERT( isType )
294 do { (ty', fvs) <- rnLHsType doc ty
295 ; haddock_doc' <- rnLHsDoc haddock_doc
296 ; return (HsDocTy ty' haddock_doc', fvs) }
297
298 rnHsTyKi isType doc (HsQuasiQuoteTy qq)
299 = ASSERT( isType )
300 do { ty <- runQuasiQuoteType qq
301 -- Wrap the result of the quasi-quoter in parens so that we don't
302 -- lose the outermost location set by runQuasiQuote (#7918)
303 ; rnHsType doc (HsParTy ty) }
304
305 rnHsTyKi isType _ (HsCoreTy ty)
306 = ASSERT( isType )
307 return (HsCoreTy ty, emptyFVs)
308 -- The emptyFVs probably isn't quite right
309 -- but I don't think it matters
310
311 rnHsTyKi _ _ (HsWrapTy {})
312 = panic "rnHsTyKi"
313
314 rnHsTyKi isType doc ty@(HsExplicitListTy k tys)
315 = ASSERT( isType )
316 do { data_kinds <- xoptM Opt_DataKinds
317 ; unless data_kinds (addErr (dataKindsErr isType ty))
318 ; (tys', fvs) <- rnLHsTypes doc tys
319 ; return (HsExplicitListTy k tys', fvs) }
320
321 rnHsTyKi isType doc ty@(HsExplicitTupleTy kis tys)
322 = ASSERT( isType )
323 do { data_kinds <- xoptM Opt_DataKinds
324 ; unless data_kinds (addErr (dataKindsErr isType ty))
325 ; (tys', fvs) <- rnLHsTypes doc tys
326 ; return (HsExplicitTupleTy kis tys', fvs) }
327
328 rnHsTyKi _ _ HsWildcardTy = panic "rnHsTyKi HsWildcardTy"
329 -- Should be replaced by a HsNamedWildcardTy
330
331 rnHsTyKi isType _doc (HsNamedWildcardTy rdr_name)
332 = ASSERT( isType )
333 do { name <- rnTyVar isType rdr_name
334 ; return (HsNamedWildcardTy name, unitFV name) }
335
336 --------------
337 rnTyVar :: Bool -> RdrName -> RnM Name
338 rnTyVar is_type rdr_name
339 | is_type = lookupTypeOccRn rdr_name
340 | otherwise = lookupKindOccRn rdr_name
341
342
343 --------------
344 rnLHsTypes :: HsDocContext -> [LHsType RdrName]
345 -> RnM ([LHsType Name], FreeVars)
346 rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
347
348 rnForAll :: HsDocContext -> HsExplicitFlag
349 -> Maybe SrcSpan -- Location of an extra-constraints wildcard
350 -> [RdrName] -- Kind variables
351 -> LHsTyVarBndrs RdrName -- Type variables
352 -> LHsContext RdrName -> LHsType RdrName
353 -> RnM (HsType Name, FreeVars)
354
355 rnForAll doc exp extra kvs forall_tyvars ctxt ty
356 | null kvs, null (hsQTvBndrs forall_tyvars), null (unLoc ctxt), isNothing extra
357 = rnHsType doc (unLoc ty)
358 -- One reason for this case is that a type like Int#
359 -- starts off as (HsForAllTy Implicit Nothing [] Int), in case
360 -- there is some quantification. Now that we have quantified
361 -- and discovered there are no type variables, it's nicer to turn
362 -- it into plain Int. If it were Int# instead of Int, we'd actually
363 -- get an error, because the body of a genuine for-all is
364 -- of kind *.
365
366 | otherwise
367 = bindHsTyVars doc Nothing kvs forall_tyvars $ \ new_tyvars ->
368 do { (new_ctxt, fvs1) <- rnContext doc ctxt
369 ; (new_ty, fvs2) <- rnLHsType doc ty
370 ; return (HsForAllTy exp extra new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) }
371 -- Retain the same implicit/explicit flag as before
372 -- so that we can later print it correctly
373
374 ---------------
375 bindSigTyVarsFV :: [Name]
376 -> RnM (a, FreeVars)
377 -> RnM (a, FreeVars)
378 -- Used just before renaming the defn of a function
379 -- with a separate type signature, to bring its tyvars into scope
380 -- With no -XScopedTypeVariables, this is a no-op
381 bindSigTyVarsFV tvs thing_inside
382 = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables
383 ; if not scoped_tyvars then
384 thing_inside
385 else
386 bindLocalNamesFV tvs thing_inside }
387
388 ---------------
389 bindHsTyVars :: HsDocContext
390 -> Maybe a -- Just _ => an associated type decl
391 -> [RdrName] -- Kind variables from scope
392 -> LHsTyVarBndrs RdrName -- Type variables
393 -> (LHsTyVarBndrs Name -> RnM (b, FreeVars))
394 -> RnM (b, FreeVars)
395 -- (a) Bring kind variables into scope
396 -- both (i) passed in (kv_bndrs)
397 -- and (ii) mentioned in the kinds of tv_bndrs
398 -- (b) Bring type variables into scope
399 bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
400 = do { rdr_env <- getLocalRdrEnv
401 ; let tvs = hsQTvBndrs tv_bndrs
402 kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs
403 , let (_, kvs) = extractHsTyRdrTyVars kind
404 , kv <- kvs ]
405 all_kvs' = nub (kv_bndrs ++ kvs_from_tv_bndrs)
406 all_kvs = filterOut (`elemLocalRdrEnv` rdr_env) all_kvs'
407
408 overlap_kvs = [ kv | kv <- all_kvs, any ((==) kv . hsLTyVarName) tvs ]
409 -- These variables appear both as kind and type variables
410 -- in the same declaration; eg type family T (x :: *) (y :: x)
411 -- We disallow this: too confusing!
412
413 ; poly_kind <- xoptM Opt_PolyKinds
414 ; unless (poly_kind || null all_kvs)
415 (addErr (badKindBndrs doc all_kvs))
416 ; unless (null overlap_kvs)
417 (addErr (overlappingKindVars doc overlap_kvs))
418
419 ; loc <- getSrcSpanM
420 ; kv_names <- mapM (newLocalBndrRn . L loc) all_kvs
421 ; bindLocalNamesFV kv_names $
422 do { let tv_names_w_loc = hsLTyVarLocNames tv_bndrs
423
424 rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars)
425 rn_tv_bndr (L loc (UserTyVar rdr))
426 = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
427 ; return (L loc (UserTyVar nm), emptyFVs) }
428 rn_tv_bndr (L loc (KindedTyVar (L lv rdr) kind))
429 = do { sig_ok <- xoptM Opt_KindSignatures
430 ; unless sig_ok (badSigErr False doc kind)
431 ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
432 ; (kind', fvs) <- rnLHsKind doc kind
433 ; return (L loc (KindedTyVar (L lv nm) kind'), fvs) }
434
435 -- Check for duplicate or shadowed tyvar bindrs
436 ; checkDupRdrNames tv_names_w_loc
437 ; when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
438
439 ; (tv_bndrs', fvs1) <- mapFvRn rn_tv_bndr tvs
440 ; (res, fvs2) <- bindLocalNamesFV (map hsLTyVarName tv_bndrs') $
441 do { inner_rdr_env <- getLocalRdrEnv
442 ; traceRn (text "bhtv" <+> vcat
443 [ ppr tvs, ppr kv_bndrs, ppr kvs_from_tv_bndrs
444 , ppr $ map (`elemLocalRdrEnv` rdr_env) all_kvs'
445 , ppr $ map (getUnique . rdrNameOcc) all_kvs'
446 , ppr all_kvs, ppr rdr_env, ppr inner_rdr_env ])
447 ; thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) }
448 ; return (res, fvs1 `plusFV` fvs2) } }
449
450 newTyVarNameRn :: Maybe a -> LocalRdrEnv -> SrcSpan -> RdrName -> RnM Name
451 newTyVarNameRn mb_assoc rdr_env loc rdr
452 | Just _ <- mb_assoc -- Use the same Name as the parent class decl
453 , Just n <- lookupLocalRdrEnv rdr_env rdr
454 = return n
455 | otherwise
456 = newLocalBndrRn (L loc rdr)
457
458 --------------------------------
459 rnHsBndrSig :: HsDocContext
460 -> HsWithBndrs RdrName (LHsType RdrName)
461 -> (HsWithBndrs Name (LHsType Name) -> RnM (a, FreeVars))
462 -> RnM (a, FreeVars)
463 rnHsBndrSig doc (HsWB { hswb_cts = ty@(L loc _) }) thing_inside
464 = do { sig_ok <- xoptM Opt_ScopedTypeVariables
465 ; unless sig_ok (badSigErr True doc ty)
466 ; let (kv_bndrs, tv_bndrs) = extractHsTyRdrTyVars ty
467 ; name_env <- getLocalRdrEnv
468 ; tv_names <- newLocalBndrsRn [L loc tv | tv <- tv_bndrs
469 , not (tv `elemLocalRdrEnv` name_env) ]
470 ; kv_names <- newLocalBndrsRn [L loc kv | kv <- kv_bndrs
471 , not (kv `elemLocalRdrEnv` name_env) ]
472 ; (wcs, ty') <- extractWildcards ty
473 ; bindLocalNamesFV kv_names $
474 bindLocalNamesFV tv_names $
475 bindLocatedLocalsFV wcs $ \wcs_new ->
476 do { (ty'', fvs1) <- rnLHsType doc ty'
477 ; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty'', hswb_kvs = kv_names,
478 hswb_tvs = tv_names, hswb_wcs = wcs_new })
479 ; return (res, fvs1 `plusFV` fvs2) } }
480
481 overlappingKindVars :: HsDocContext -> [RdrName] -> SDoc
482 overlappingKindVars doc kvs
483 = vcat [ ptext (sLit "Kind variable") <> plural kvs <+>
484 ptext (sLit "also used as type variable") <> plural kvs
485 <> colon <+> pprQuotedList kvs
486 , docOfHsDocContext doc ]
487
488 badKindBndrs :: HsDocContext -> [RdrName] -> SDoc
489 badKindBndrs doc kvs
490 = vcat [ hang (ptext (sLit "Unexpected kind variable") <> plural kvs
491 <+> pprQuotedList kvs)
492 2 (ptext (sLit "Perhaps you intended to use PolyKinds"))
493 , docOfHsDocContext doc ]
494
495 badSigErr :: Bool -> HsDocContext -> LHsType RdrName -> TcM ()
496 badSigErr is_type doc (L loc ty)
497 = setSrcSpan loc $ addErr $
498 vcat [ hang (ptext (sLit "Illegal") <+> what
499 <+> ptext (sLit "signature:") <+> quotes (ppr ty))
500 2 (ptext (sLit "Perhaps you intended to use") <+> flag)
501 , docOfHsDocContext doc ]
502 where
503 what | is_type = ptext (sLit "type")
504 | otherwise = ptext (sLit "kind")
505 flag | is_type = ptext (sLit "ScopedTypeVariables")
506 | otherwise = ptext (sLit "KindSignatures")
507
508 dataKindsErr :: Bool -> HsType RdrName -> SDoc
509 dataKindsErr is_type thing
510 = hang (ptext (sLit "Illegal") <+> what <> colon <+> quotes (ppr thing))
511 2 (ptext (sLit "Perhaps you intended to use DataKinds"))
512 where
513 what | is_type = ptext (sLit "type")
514 | otherwise = ptext (sLit "kind")
515
516 {-
517 *********************************************************
518 * *
519 \subsection{Contexts and predicates}
520 * *
521 *********************************************************
522 -}
523
524 rnConDeclFields :: HsDocContext -> [LConDeclField RdrName]
525 -> RnM ([LConDeclField Name], FreeVars)
526 rnConDeclFields doc fields = mapFvRn (rnField doc) fields
527
528 rnField :: HsDocContext -> LConDeclField RdrName
529 -> RnM (LConDeclField Name, FreeVars)
530 rnField doc (L l (ConDeclField names ty haddock_doc))
531 = do { new_names <- mapM lookupLocatedTopBndrRn names
532 ; (new_ty, fvs) <- rnLHsType doc ty
533 ; new_haddock_doc <- rnMbLHsDoc haddock_doc
534 ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
535
536 rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
537 rnContext doc (L loc cxt)
538 = do { (cxt', fvs) <- rnLHsTypes doc cxt
539 ; return (L loc cxt', fvs) }
540
541 {-
542 ************************************************************************
543 * *
544 Fixities and precedence parsing
545 * *
546 ************************************************************************
547
548 @mkOpAppRn@ deals with operator fixities. The argument expressions
549 are assumed to be already correctly arranged. It needs the fixities
550 recorded in the OpApp nodes, because fixity info applies to the things
551 the programmer actually wrote, so you can't find it out from the Name.
552
553 Furthermore, the second argument is guaranteed not to be another
554 operator application. Why? Because the parser parses all
555 operator appications left-associatively, EXCEPT negation, which
556 we need to handle specially.
557 Infix types are read in a *right-associative* way, so that
558 a `op` b `op` c
559 is always read in as
560 a `op` (b `op` c)
561
562 mkHsOpTyRn rearranges where necessary. The two arguments
563 have already been renamed and rearranged. It's made rather tiresome
564 by the presence of ->, which is a separate syntactic construct.
565 -}
566
567 ---------------
568 -- Building (ty1 `op1` (ty21 `op2` ty22))
569 mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
570 -> Name -> Fixity -> LHsType Name -> LHsType Name
571 -> RnM (HsType Name)
572
573 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 (w2, op2) ty22))
574 = do { fix2 <- lookupTyFixityRn op2
575 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
576 (\t1 t2 -> HsOpTy t1 (w2, op2) t2)
577 (unLoc op2) fix2 ty21 ty22 loc2 }
578
579 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
580 = mk_hs_op_ty mk1 pp_op1 fix1 ty1
581 HsFunTy funTyConName funTyFixity ty21 ty22 loc2
582
583 mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment
584 = return (mk1 ty1 ty2)
585
586 ---------------
587 mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
588 -> Name -> Fixity -> LHsType Name
589 -> (LHsType Name -> LHsType Name -> HsType Name)
590 -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
591 -> RnM (HsType Name)
592 mk_hs_op_ty mk1 op1 fix1 ty1
593 mk2 op2 fix2 ty21 ty22 loc2
594 | nofix_error = do { precParseErr (op1,fix1) (op2,fix2)
595 ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
596 | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
597 | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
598 new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
599 ; return (mk2 (noLoc new_ty) ty22) }
600 where
601 (nofix_error, associate_right) = compareFixity fix1 fix2
602
603
604 ---------------------------
605 mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged
606 -> LHsExpr Name -> Fixity -- Operator and fixity
607 -> LHsExpr Name -- Right operand (not an OpApp, but might
608 -- be a NegApp)
609 -> RnM (HsExpr Name)
610
611 -- (e11 `op1` e12) `op2` e2
612 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
613 | nofix_error
614 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
615 return (OpApp e1 op2 fix2 e2)
616
617 | associate_right = do
618 new_e <- mkOpAppRn e12 op2 fix2 e2
619 return (OpApp e11 op1 fix1 (L loc' new_e))
620 where
621 loc'= combineLocs e12 e2
622 (nofix_error, associate_right) = compareFixity fix1 fix2
623
624 ---------------------------
625 -- (- neg_arg) `op` e2
626 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
627 | nofix_error
628 = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
629 return (OpApp e1 op2 fix2 e2)
630
631 | associate_right
632 = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
633 return (NegApp (L loc' new_e) neg_name)
634 where
635 loc' = combineLocs neg_arg e2
636 (nofix_error, associate_right) = compareFixity negateFixity fix2
637
638 ---------------------------
639 -- e1 `op` - neg_arg
640 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right
641 | not associate_right -- We *want* right association
642 = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
643 return (OpApp e1 op1 fix1 e2)
644 where
645 (_, associate_right) = compareFixity fix1 negateFixity
646
647 ---------------------------
648 -- Default case
649 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
650 = ASSERT2( right_op_ok fix (unLoc e2),
651 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
652 )
653 return (OpApp e1 op fix e2)
654
655 ----------------------------
656 get_op :: LHsExpr Name -> Name
657 get_op (L _ (HsVar n)) = n
658 get_op other = pprPanic "get_op" (ppr other)
659
660 -- Parser left-associates everything, but
661 -- derived instances may have correctly-associated things to
662 -- in the right operarand. So we just check that the right operand is OK
663 right_op_ok :: Fixity -> HsExpr Name -> Bool
664 right_op_ok fix1 (OpApp _ _ fix2 _)
665 = not error_please && associate_right
666 where
667 (error_please, associate_right) = compareFixity fix1 fix2
668 right_op_ok _ _
669 = True
670
671 -- Parser initially makes negation bind more tightly than any other operator
672 -- And "deriving" code should respect this (use HsPar if not)
673 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
674 mkNegAppRn neg_arg neg_name
675 = ASSERT( not_op_app (unLoc neg_arg) )
676 return (NegApp neg_arg neg_name)
677
678 not_op_app :: HsExpr id -> Bool
679 not_op_app (OpApp _ _ _ _) = False
680 not_op_app _ = True
681
682 ---------------------------
683 mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged
684 -> LHsExpr Name -> Fixity -- Operator and fixity
685 -> LHsCmdTop Name -- Right operand (not an infix)
686 -> RnM (HsCmd Name)
687
688 -- (e11 `op1` e12) `op2` e2
689 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _))
690 op2 fix2 a2
691 | nofix_error
692 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
693 return (HsCmdArrForm op2 (Just fix2) [a1, a2])
694
695 | associate_right
696 = do new_c <- mkOpFormRn a12 op2 fix2 a2
697 return (HsCmdArrForm op1 (Just fix1)
698 [a11, L loc (HsCmdTop (L loc new_c)
699 placeHolderType placeHolderType [])])
700 -- TODO: locs are wrong
701 where
702 (nofix_error, associate_right) = compareFixity fix1 fix2
703
704 -- Default case
705 mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
706 = return (HsCmdArrForm op (Just fix) [arg1, arg2])
707
708
709 --------------------------------------
710 mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
711 -> RnM (Pat Name)
712
713 mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
714 = do { fix1 <- lookupFixityRn (unLoc op1)
715 ; let (nofix_error, associate_right) = compareFixity fix1 fix2
716
717 ; if nofix_error then do
718 { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
719 ; return (ConPatIn op2 (InfixCon p1 p2)) }
720
721 else if associate_right then do
722 { new_p <- mkConOpPatRn op2 fix2 p12 p2
723 ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
724 else return (ConPatIn op2 (InfixCon p1 p2)) }
725
726 mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment
727 = ASSERT( not_op_pat (unLoc p2) )
728 return (ConPatIn op (InfixCon p1 p2))
729
730 not_op_pat :: Pat Name -> Bool
731 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
732 not_op_pat _ = True
733
734 --------------------------------------
735 checkPrecMatch :: Name -> MatchGroup Name body -> RnM ()
736 -- Check precedence of a function binding written infix
737 -- eg a `op` b `C` c = ...
738 -- See comments with rnExpr (OpApp ...) about "deriving"
739
740 checkPrecMatch op (MG { mg_alts = ms })
741 = mapM_ check ms
742 where
743 check (L _ (Match _ (L l1 p1 : L l2 p2 :_) _ _))
744 = setSrcSpan (combineSrcSpans l1 l2) $
745 do checkPrec op p1 False
746 checkPrec op p2 True
747
748 check _ = return ()
749 -- This can happen. Consider
750 -- a `op` True = ...
751 -- op = ...
752 -- The infix flag comes from the first binding of the group
753 -- but the second eqn has no args (an error, but not discovered
754 -- until the type checker). So we don't want to crash on the
755 -- second eqn.
756
757 checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
758 checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
759 op_fix@(Fixity op_prec op_dir) <- lookupFixityRn op
760 op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
761 let
762 inf_ok = op1_prec > op_prec ||
763 (op1_prec == op_prec &&
764 (op1_dir == InfixR && op_dir == InfixR && right ||
765 op1_dir == InfixL && op_dir == InfixL && not right))
766
767 info = (op, op_fix)
768 info1 = (unLoc op1, op1_fix)
769 (infol, infor) = if right then (info, info1) else (info1, info)
770 unless inf_ok (precParseErr infol infor)
771
772 checkPrec _ _ _
773 = return ()
774
775 -- Check precedence of (arg op) or (op arg) respectively
776 -- If arg is itself an operator application, then either
777 -- (a) its precedence must be higher than that of op
778 -- (b) its precedency & associativity must be the same as that of op
779 checkSectionPrec :: FixityDirection -> HsExpr RdrName
780 -> LHsExpr Name -> LHsExpr Name -> RnM ()
781 checkSectionPrec direction section op arg
782 = case unLoc arg of
783 OpApp _ op fix _ -> go_for_it (get_op op) fix
784 NegApp _ _ -> go_for_it negateName negateFixity
785 _ -> return ()
786 where
787 op_name = get_op op
788 go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
789 op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
790 unless (op_prec < arg_prec
791 || (op_prec == arg_prec && direction == assoc))
792 (sectionPrecErr (op_name, op_fix)
793 (arg_op, arg_fix) section)
794
795 -- Precedence-related error messages
796
797 precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
798 precParseErr op1@(n1,_) op2@(n2,_)
799 | isUnboundName n1 || isUnboundName n2
800 = return () -- Avoid error cascade
801 | otherwise
802 = addErr $ hang (ptext (sLit "Precedence parsing error"))
803 4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"),
804 ppr_opfix op2,
805 ptext (sLit "in the same infix expression")])
806
807 sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
808 sectionPrecErr op@(n1,_) arg_op@(n2,_) section
809 | isUnboundName n1 || isUnboundName n2
810 = return () -- Avoid error cascade
811 | otherwise
812 = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
813 nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"),
814 nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]),
815 nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))]
816
817 ppr_opfix :: (Name, Fixity) -> SDoc
818 ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
819 where
820 pp_op | op == negateName = ptext (sLit "prefix `-'")
821 | otherwise = quotes (ppr op)
822
823 {-
824 *********************************************************
825 * *
826 \subsection{Errors}
827 * *
828 *********************************************************
829 -}
830
831 warnUnusedForAlls :: SDoc -> LHsTyVarBndrs RdrName -> [RdrName] -> TcM ()
832 warnUnusedForAlls in_doc bound mentioned_rdrs
833 = whenWOptM Opt_WarnUnusedMatches $
834 mapM_ add_warn bound_but_not_used
835 where
836 bound_names = hsLTyVarLocNames bound
837 bound_but_not_used = filterOut ((`elem` mentioned_rdrs) . unLoc) bound_names
838
839 add_warn (L loc tv)
840 = addWarnAt loc $
841 vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv)
842 , in_doc ]
843
844 warnContextQuantification :: SDoc -> [LHsTyVarBndr RdrName] -> TcM ()
845 warnContextQuantification in_doc tvs
846 = whenWOptM Opt_WarnContextQuantification $
847 mapM_ add_warn tvs
848 where
849 add_warn (L loc tv)
850 = addWarnAt loc $
851 vcat [ ptext (sLit "Variable") <+> quotes (ppr tv) <+>
852 ptext (sLit "is implicitly quantified due to a context") $$
853 ptext (sLit "Use explicit forall syntax instead.") $$
854 ptext (sLit "This will become an error in GHC 7.12.")
855 , in_doc ]
856
857 opTyErr :: RdrName -> HsType RdrName -> SDoc
858 opTyErr op ty@(HsOpTy ty1 _ _)
859 = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty))
860 2 extra
861 where
862 extra | op == dot_tv_RDR && forall_head ty1
863 = perhapsForallMsg
864 | otherwise
865 = ptext (sLit "Use TypeOperators to allow operators in types")
866
867 forall_head (L _ (HsTyVar tv)) = tv == forall_tv_RDR
868 forall_head (L _ (HsAppTy ty _)) = forall_head ty
869 forall_head _other = False
870 opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty)
871
872 {-
873 ************************************************************************
874 * *
875 Finding the free type variables of a (HsType RdrName)
876 * *
877 ************************************************************************
878
879
880 Note [Kind and type-variable binders]
881 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
882 In a type signature we may implicitly bind type varaible and, more
883 recently, kind variables. For example:
884 * f :: a -> a
885 f = ...
886 Here we need to find the free type variables of (a -> a),
887 so that we know what to quantify
888
889 * class C (a :: k) where ...
890 This binds 'k' in ..., as well as 'a'
891
892 * f (x :: a -> [a]) = ....
893 Here we bind 'a' in ....
894
895 * f (x :: T a -> T (b :: k)) = ...
896 Here we bind both 'a' and the kind variable 'k'
897
898 * type instance F (T (a :: Maybe k)) = ...a...k...
899 Here we want to constrain the kind of 'a', and bind 'k'.
900
901 In general we want to walk over a type, and find
902 * Its free type variables
903 * The free kind variables of any kind signatures in the type
904
905 Hence we returns a pair (kind-vars, type vars)
906 See also Note [HsBSig binder lists] in HsTypes
907 -}
908
909 type FreeKiTyVars = ([RdrName], [RdrName])
910
911 filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
912 filterInScope rdr_env (kvs, tvs)
913 = (filterOut in_scope kvs, filterOut in_scope tvs)
914 where
915 in_scope tv = tv `elemLocalRdrEnv` rdr_env
916
917 extractHsTyRdrTyVars :: LHsType RdrName -> FreeKiTyVars
918 -- extractHsTyRdrNames finds the free (kind, type) variables of a HsType
919 -- or the free (sort, kind) variables of a HsKind
920 -- It's used when making the for-alls explicit.
921 -- See Note [Kind and type-variable binders]
922 extractHsTyRdrTyVars ty
923 = case extract_lty ty ([],[]) of
924 (kvs, tvs) -> (nub kvs, nub tvs)
925
926 extractHsTysRdrTyVars :: [LHsType RdrName] -> FreeKiTyVars
927 -- See Note [Kind and type-variable binders]
928 extractHsTysRdrTyVars ty
929 = case extract_ltys ty ([],[]) of
930 (kvs, tvs) -> (nub kvs, nub tvs)
931
932 extractRdrKindSigVars :: Maybe (LHsKind RdrName) -> [RdrName]
933 extractRdrKindSigVars Nothing = []
934 extractRdrKindSigVars (Just k) = nub (fst (extract_lkind k ([],[])))
935
936 extractDataDefnKindVars :: HsDataDefn RdrName -> [RdrName]
937 -- Get the scoped kind variables mentioned free in the constructor decls
938 -- Eg data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
939 -- Here k should scope over the whole definition
940 extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
941 , dd_cons = cons, dd_derivs = derivs })
942 = fst $ extract_lctxt ctxt $
943 extract_mb extract_lkind ksig $
944 extract_mb (extract_ltys . unLoc) derivs $
945 foldr (extract_con . unLoc) ([],[]) cons
946 where
947 extract_con (ConDecl { con_res = ResTyGADT {} }) acc = acc
948 extract_con (ConDecl { con_res = ResTyH98, con_qvars = qvs
949 , con_cxt = ctxt, con_details = details }) acc
950 = extract_hs_tv_bndrs qvs acc $
951 extract_lctxt ctxt $
952 extract_ltys (hsConDeclArgTys details) ([],[])
953
954
955 extract_lctxt :: LHsContext RdrName -> FreeKiTyVars -> FreeKiTyVars
956 extract_lctxt ctxt = extract_ltys (unLoc ctxt)
957
958 extract_ltys :: [LHsType RdrName] -> FreeKiTyVars -> FreeKiTyVars
959 extract_ltys tys acc = foldr extract_lty acc tys
960
961 extract_mb :: (a -> FreeKiTyVars -> FreeKiTyVars) -> Maybe a -> FreeKiTyVars -> FreeKiTyVars
962 extract_mb _ Nothing acc = acc
963 extract_mb f (Just x) acc = f x acc
964
965 extract_lkind :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars
966 extract_lkind kind (acc_kvs, acc_tvs) = case extract_lty kind ([], acc_kvs) of
967 (_, res_kvs) -> (res_kvs, acc_tvs)
968 -- Kinds shouldn't have sort signatures!
969
970 extract_lty :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars
971 extract_lty (L _ ty) acc
972 = case ty of
973 HsTyVar tv -> extract_tv tv acc
974 HsBangTy _ ty -> extract_lty ty acc
975 HsRecTy flds -> foldr (extract_lty . cd_fld_type . unLoc) acc
976 flds
977 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
978 HsListTy ty -> extract_lty ty acc
979 HsPArrTy ty -> extract_lty ty acc
980 HsTupleTy _ tys -> extract_ltys tys acc
981 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
982 HsIParamTy _ ty -> extract_lty ty acc
983 HsEqTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
984 HsOpTy ty1 (_, (L _ tv)) ty2 -> extract_tv tv (extract_lty ty1 (extract_lty ty2 acc))
985 HsParTy ty -> extract_lty ty acc
986 HsCoreTy {} -> acc -- The type is closed
987 HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables
988 HsSpliceTy {} -> acc -- Type splices mention no type variables
989 HsDocTy ty _ -> extract_lty ty acc
990 HsExplicitListTy _ tys -> extract_ltys tys acc
991 HsExplicitTupleTy _ tys -> extract_ltys tys acc
992 HsTyLit _ -> acc
993 HsWrapTy _ _ -> panic "extract_lty"
994 HsKindSig ty ki -> extract_lty ty (extract_lkind ki acc)
995 HsForAllTy _ _ tvs cx ty -> extract_hs_tv_bndrs tvs acc $
996 extract_lctxt cx $
997 extract_lty ty ([],[])
998 -- We deal with these to in a later stage, because they need to be
999 -- replaced by fresh HsTyVars.
1000 HsWildcardTy -> acc
1001 HsNamedWildcardTy _ -> acc
1002
1003 extract_hs_tv_bndrs :: LHsTyVarBndrs RdrName -> FreeKiTyVars
1004 -> FreeKiTyVars -> FreeKiTyVars
1005 extract_hs_tv_bndrs (HsQTvs { hsq_tvs = tvs })
1006 (acc_kvs, acc_tvs) -- Note accumulator comes first
1007 (body_kvs, body_tvs)
1008 | null tvs
1009 = (body_kvs ++ acc_kvs, body_tvs ++ acc_tvs)
1010 | otherwise
1011 = (acc_kvs ++ filterOut (`elem` local_kvs) body_kvs,
1012 acc_tvs ++ filterOut (`elem` local_tvs) body_tvs)
1013 where
1014 local_tvs = map hsLTyVarName tvs
1015 (_, local_kvs) = foldr extract_lty ([], []) [k | L _ (KindedTyVar _ k) <- tvs]
1016 -- These kind variables are bound here if not bound further out
1017
1018 extract_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars
1019 extract_tv tv acc
1020 | isRdrTyVar tv = case acc of (kvs,tvs) -> (kvs, tv : tvs)
1021 | otherwise = acc
1022
1023 -- | Replace all unnamed wildcards in the given type with named wildcards.
1024 -- These names are freshly generated, based on "_". Return a tuple of the
1025 -- named wildcards that weren't already in scope (amongst them the named
1026 -- wildcards the unnamed ones were converted into), and the type in which the
1027 -- unnamed wildcards are replaced by named wildcards.
1028 extractWildcards :: LHsType RdrName -> RnM ([Located RdrName], LHsType RdrName)
1029 extractWildcards ty
1030 = do { (nwcs, awcs, ty') <- go ty
1031 ; rdr_env <- getLocalRdrEnv
1032 -- Filter out named wildcards that are already in scope
1033 ; let nwcs' = nubBy eqLocated $ filterOut (flip (elemLocalRdrEnv . unLoc) rdr_env) nwcs
1034 ; return (nwcs' ++ awcs, ty') }
1035 where
1036 go orig@(L l ty) = case ty of
1037 (HsForAllTy exp extra bndrs (L locCxt cxt) ty) ->
1038 do (nwcs1, awcs1, cxt') <- extList cxt
1039 (nwcs2, awcs2, ty') <- go ty
1040 return (nwcs1 ++ nwcs2, awcs1 ++ awcs2,
1041 L l (HsForAllTy exp extra bndrs (L locCxt cxt') ty'))
1042 (HsAppTy ty1 ty2) -> go2 HsAppTy ty1 ty2
1043 (HsFunTy ty1 ty2) -> go2 HsFunTy ty1 ty2
1044 (HsListTy ty) -> go1 HsListTy ty
1045 (HsPArrTy ty) -> go1 HsPArrTy ty
1046 (HsTupleTy con tys) -> goList (HsTupleTy con) tys
1047 (HsOpTy ty1 op ty2) -> go2 (\t1 t2 -> HsOpTy t1 op t2) ty1 ty2
1048 (HsParTy ty) -> go1 HsParTy ty
1049 (HsIParamTy n ty) -> go1 (HsIParamTy n) ty
1050 (HsEqTy ty1 ty2) -> go2 HsEqTy ty1 ty2
1051 (HsKindSig ty kind) -> go2 HsKindSig ty kind
1052 (HsDocTy ty doc) -> go1 (flip HsDocTy doc) ty
1053 (HsBangTy b ty) -> go1 (HsBangTy b) ty
1054 (HsExplicitListTy ptk tys) -> goList (HsExplicitListTy ptk) tys
1055 (HsExplicitTupleTy ptk tys) -> goList (HsExplicitTupleTy ptk) tys
1056 HsWildcardTy -> do
1057 uniq <- newUnique
1058 let name = mkInternalName uniq (mkTyVarOcc "_") l
1059 rdrName = nameRdrName name
1060 return ([], [L l rdrName], L l $ HsNamedWildcardTy rdrName)
1061 (HsNamedWildcardTy name) -> return ([L l name], [], orig)
1062 -- HsQuasiQuoteTy, HsSpliceTy, HsRecTy, HsCoreTy, HsTyLit, HsWrapTy
1063 _ -> return ([], [], orig)
1064 where
1065 go1 f t = do (nwcs, awcs, t') <- go t
1066 return (nwcs, awcs, L l $ f t')
1067 go2 f t1 t2 =
1068 do (nwcs1, awcs1, t1') <- go t1
1069 (nwcs2, awcs2, t2') <- go t2
1070 return (nwcs1 ++ nwcs2, awcs1 ++ awcs2, L l $ f t1' t2')
1071 extList l = do rec_res <- mapM go l
1072 let (nwcs, awcs, tys') =
1073 foldr (\(nwcs, awcs, ty) (nwcss, awcss, tys) ->
1074 (nwcs ++ nwcss, awcs ++ awcss, ty : tys))
1075 ([], [], []) rec_res
1076 return (nwcs, awcs, tys')
1077 goList f tys = do (nwcs, awcs, tys') <- extList tys
1078 return (nwcs, awcs, L l $ f tys')