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