Add -fwarn-context-quantification (#4426)
[ghc.git] / compiler / rename / RnTypes.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[RnSource]{Main pass of renamer}
5
6 \begin{code}
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, filterInScope
25   ) where
26
27 import {-# SOURCE #-} TcSplice( runQuasiQuoteType )
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 )
49 import Control.Monad    ( unless, when )
50
51 #include "HsVersions.h"
52 \end{code}
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 \begin{code}
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 \end{code}
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 \begin{code}
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 _ 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 forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty
158
159 rnHsTyKi isType doc fulltype@(HsForAllTy Qualified _ 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 forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty
172
173 rnHsTyKi isType doc ty@(HsForAllTy Explicit 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 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 -- Perhaps we should use a separate extension here?
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 || isType) (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 --------------
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 \end{code}
340
341
342 \begin{code}
343 rnForAll :: HsDocContext -> HsExplicitFlag
344          -> [RdrName]                -- Kind variables
345          -> LHsTyVarBndrs RdrName   -- Type variables
346          -> LHsContext RdrName -> LHsType RdrName
347          -> RnM (HsType Name, FreeVars)
348
349 rnForAll doc exp kvs forall_tyvars ctxt ty
350   | null kvs, null (hsQTvBndrs forall_tyvars), null (unLoc ctxt)
351   = rnHsType doc (unLoc ty)
352         -- One reason for this case is that a type like Int#
353         -- starts off as (HsForAllTy Nothing [] Int), in case
354         -- there is some quantification.  Now that we have quantified
355         -- and discovered there are no type variables, it's nicer to turn
356         -- it into plain Int.  If it were Int# instead of Int, we'd actually
357         -- get an error, because the body of a genuine for-all is
358         -- of kind *.
359
360   | otherwise
361   = bindHsTyVars doc Nothing kvs forall_tyvars $ \ new_tyvars ->
362     do { (new_ctxt, fvs1) <- rnContext doc ctxt
363        ; (new_ty, fvs2) <- rnLHsType doc ty
364        ; return (HsForAllTy exp new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) }
365         -- Retain the same implicit/explicit flag as before
366         -- so that we can later print it correctly
367
368 ---------------
369 bindSigTyVarsFV :: [Name]
370                 -> RnM (a, FreeVars)
371                 -> RnM (a, FreeVars)
372 -- Used just before renaming the defn of a function
373 -- with a separate type signature, to bring its tyvars into scope
374 -- With no -XScopedTypeVariables, this is a no-op
375 bindSigTyVarsFV tvs thing_inside
376   = do  { scoped_tyvars <- xoptM Opt_ScopedTypeVariables
377         ; if not scoped_tyvars then
378                 thing_inside
379           else
380                 bindLocalNamesFV tvs thing_inside }
381
382 ---------------
383 bindHsTyVars :: HsDocContext
384              -> Maybe a                 -- Just _  => an associated type decl
385              -> [RdrName]               -- Kind variables from scope
386              -> LHsTyVarBndrs RdrName   -- Type variables
387              -> (LHsTyVarBndrs Name -> RnM (b, FreeVars))
388              -> RnM (b, FreeVars)
389 -- (a) Bring kind variables into scope
390 --     both (i)  passed in (kv_bndrs)
391 --     and  (ii) mentioned in the kinds of tv_bndrs
392 -- (b) Bring type variables into scope
393 bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
394   = do { rdr_env <- getLocalRdrEnv
395        ; let tvs = hsQTvBndrs tv_bndrs
396              kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs
397                                  , let (_, kvs) = extractHsTyRdrTyVars kind
398                                  , kv <- kvs ]
399              all_kvs' = nub (kv_bndrs ++ kvs_from_tv_bndrs)
400              all_kvs  = filterOut (`elemLocalRdrEnv` rdr_env) all_kvs'
401
402              overlap_kvs = [ kv | kv <- all_kvs, any ((==) kv . hsLTyVarName) tvs ]
403                 -- These variables appear both as kind and type variables
404                 -- in the same declaration; eg  type family  T (x :: *) (y :: x)
405                 -- We disallow this: too confusing!
406
407        ; poly_kind <- xoptM Opt_PolyKinds
408        ; unless (poly_kind || null all_kvs)
409                 (addErr (badKindBndrs doc all_kvs))
410        ; unless (null overlap_kvs)
411                 (addErr (overlappingKindVars doc overlap_kvs))
412
413        ; loc <- getSrcSpanM
414        ; kv_names <- mapM (newLocalBndrRn . L loc) all_kvs
415        ; bindLocalNamesFV kv_names $
416     do { let tv_names_w_loc = hsLTyVarLocNames tv_bndrs
417
418              rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars)
419              rn_tv_bndr (L loc (UserTyVar rdr))
420                = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
421                     ; return (L loc (UserTyVar nm), emptyFVs) }
422              rn_tv_bndr (L loc (KindedTyVar rdr kind))
423                = do { sig_ok <- xoptM Opt_KindSignatures
424                     ; unless sig_ok (badSigErr False doc kind)
425                     ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
426                     ; (kind', fvs) <- rnLHsKind doc kind
427                     ; return (L loc (KindedTyVar nm kind'), fvs) }
428
429        -- Check for duplicate or shadowed tyvar bindrs
430        ; checkDupRdrNames tv_names_w_loc
431        ; when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
432
433        ; (tv_bndrs', fvs1) <- mapFvRn rn_tv_bndr tvs
434        ; (res, fvs2) <- bindLocalNamesFV (map hsLTyVarName tv_bndrs') $
435                         do { inner_rdr_env <- getLocalRdrEnv
436                            ; traceRn (text "bhtv" <+> vcat
437                                  [ ppr tvs, ppr kv_bndrs, ppr kvs_from_tv_bndrs
438                                  , ppr $ map (`elemLocalRdrEnv` rdr_env) all_kvs'
439                                  , ppr $ map (getUnique . rdrNameOcc) all_kvs'
440                                  , ppr all_kvs, ppr rdr_env, ppr inner_rdr_env ])
441                            ; thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) }
442        ; return (res, fvs1 `plusFV` fvs2) } }
443
444 newTyVarNameRn :: Maybe a -> LocalRdrEnv -> SrcSpan -> RdrName -> RnM Name
445 newTyVarNameRn mb_assoc rdr_env loc rdr
446   | Just _ <- mb_assoc    -- Use the same Name as the parent class decl
447   , Just n <- lookupLocalRdrEnv rdr_env rdr
448   = return n
449   | otherwise
450   = newLocalBndrRn (L loc rdr)
451
452 --------------------------------
453 rnHsBndrSig :: HsDocContext
454             -> HsWithBndrs RdrName (LHsType RdrName)
455             -> (HsWithBndrs Name (LHsType Name) -> RnM (a, FreeVars))
456             -> RnM (a, FreeVars)
457 rnHsBndrSig doc (HsWB { hswb_cts = ty@(L loc _) }) thing_inside
458   = do { sig_ok <- xoptM Opt_ScopedTypeVariables
459        ; unless sig_ok (badSigErr True doc ty)
460        ; let (kv_bndrs, tv_bndrs) = extractHsTyRdrTyVars ty
461        ; name_env <- getLocalRdrEnv
462        ; tv_names <- newLocalBndrsRn [L loc tv | tv <- tv_bndrs
463                                                , not (tv `elemLocalRdrEnv` name_env) ]
464        ; kv_names <- newLocalBndrsRn [L loc kv | kv <- kv_bndrs
465                                                , not (kv `elemLocalRdrEnv` name_env) ]
466        ; bindLocalNamesFV kv_names $
467          bindLocalNamesFV tv_names $
468     do { (ty', fvs1) <- rnLHsType doc ty
469        ; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty', hswb_kvs = kv_names, hswb_tvs = tv_names })
470        ; return (res, fvs1 `plusFV` fvs2) } }
471
472 overlappingKindVars :: HsDocContext -> [RdrName] -> SDoc
473 overlappingKindVars doc kvs
474   = vcat [ ptext (sLit "Kind variable") <> plural kvs <+>
475            ptext (sLit "also used as type variable") <> plural kvs
476            <> colon <+> pprQuotedList kvs
477          , docOfHsDocContext doc ]
478
479 badKindBndrs :: HsDocContext -> [RdrName] -> SDoc
480 badKindBndrs doc kvs
481   = vcat [ hang (ptext (sLit "Unexpected kind variable") <> plural kvs
482                  <+> pprQuotedList kvs)
483               2 (ptext (sLit "Perhaps you intended to use PolyKinds"))
484          , docOfHsDocContext doc ]
485
486 badSigErr :: Bool -> HsDocContext -> LHsType RdrName -> TcM ()
487 badSigErr is_type doc (L loc ty)
488   = setSrcSpan loc $ addErr $
489     vcat [ hang (ptext (sLit "Illegal") <+> what
490                  <+> ptext (sLit "signature:") <+> quotes (ppr ty))
491               2 (ptext (sLit "Perhaps you intended to use") <+> flag)
492          , docOfHsDocContext doc ]
493   where
494     what | is_type   = ptext (sLit "type")
495          | otherwise = ptext (sLit "kind")
496     flag | is_type   = ptext (sLit "ScopedTypeVariables")
497          | otherwise = ptext (sLit "KindSignatures")
498
499 dataKindsErr :: Bool -> HsType RdrName -> SDoc
500 dataKindsErr is_type thing
501   = hang (ptext (sLit "Illegal") <+> what <> colon <+> quotes (ppr thing))
502        2 (ptext (sLit "Perhaps you intended to use DataKinds"))
503   where
504     what | is_type   = ptext (sLit "type")
505          | otherwise = ptext (sLit "kind")
506 \end{code}
507
508 Note [Renaming associated types]
509 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
510 Check that the RHS of the decl mentions only type variables
511 bound on the LHS.  For example, this is not ok
512    class C a b where
513       type F a x :: *
514    instance C (p,q) r where
515       type F (p,q) x = (x, r)   -- BAD: mentions 'r'
516 c.f. Trac #5515
517
518 What makes it tricky is that the *kind* variable from the class *are*
519 in scope (Trac #5862):
520     class Category (x :: k -> k -> *) where
521       type Ob x :: k -> Constraint
522       id :: Ob x a => x a a
523       (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c
524 Here 'k' is in scope in the kind signature even though it's not
525 explicitly mentioned on the LHS of the type Ob declaration.
526
527 We could force you to mention k explicitly, thus
528     class Category (x :: k -> k -> *) where
529       type Ob (x :: k -> k -> *) :: k -> Constraint
530 but it seems tiresome to do so.
531
532
533 %*********************************************************
534 %*                                                      *
535 \subsection{Contexts and predicates}
536 %*                                                      *
537 %*********************************************************
538
539 \begin{code}
540 rnConDeclFields :: HsDocContext -> [ConDeclField RdrName]
541                 -> RnM ([ConDeclField Name], FreeVars)
542 rnConDeclFields doc fields = mapFvRn (rnField doc) fields
543
544 rnField :: HsDocContext -> ConDeclField RdrName -> RnM (ConDeclField Name, FreeVars)
545 rnField doc (ConDeclField name ty haddock_doc)
546   = do { new_name <- lookupLocatedTopBndrRn name
547        ; (new_ty, fvs) <- rnLHsType doc ty
548        ; new_haddock_doc <- rnMbLHsDoc haddock_doc
549        ; return (ConDeclField new_name new_ty new_haddock_doc, fvs) }
550
551 rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
552 rnContext doc (L loc cxt)
553   = do { (cxt', fvs) <- rnLHsTypes doc cxt
554        ; return (L loc cxt', fvs) }
555 \end{code}
556
557
558 %************************************************************************
559 %*                                                                      *
560         Fixities and precedence parsing
561 %*                                                                      *
562 %************************************************************************
563
564 @mkOpAppRn@ deals with operator fixities.  The argument expressions
565 are assumed to be already correctly arranged.  It needs the fixities
566 recorded in the OpApp nodes, because fixity info applies to the things
567 the programmer actually wrote, so you can't find it out from the Name.
568
569 Furthermore, the second argument is guaranteed not to be another
570 operator application.  Why? Because the parser parses all
571 operator appications left-associatively, EXCEPT negation, which
572 we need to handle specially.
573 Infix types are read in a *right-associative* way, so that
574         a `op` b `op` c
575 is always read in as
576         a `op` (b `op` c)
577
578 mkHsOpTyRn rearranges where necessary.  The two arguments
579 have already been renamed and rearranged.  It's made rather tiresome
580 by the presence of ->, which is a separate syntactic construct.
581
582 \begin{code}
583 ---------------
584 -- Building (ty1 `op1` (ty21 `op2` ty22))
585 mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
586            -> Name -> Fixity -> LHsType Name -> LHsType Name
587            -> RnM (HsType Name)
588
589 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 (w2, op2) ty22))
590   = do  { fix2 <- lookupTyFixityRn op2
591         ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
592                       (\t1 t2 -> HsOpTy t1 (w2, op2) t2)
593                       (unLoc op2) fix2 ty21 ty22 loc2 }
594
595 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
596   = mk_hs_op_ty mk1 pp_op1 fix1 ty1
597                 HsFunTy funTyConName funTyFixity ty21 ty22 loc2
598
599 mkHsOpTyRn mk1 _ _ ty1 ty2              -- Default case, no rearrangment
600   = return (mk1 ty1 ty2)
601
602 ---------------
603 mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
604             -> Name -> Fixity -> LHsType Name
605             -> (LHsType Name -> LHsType Name -> HsType Name)
606             -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
607             -> RnM (HsType Name)
608 mk_hs_op_ty mk1 op1 fix1 ty1
609             mk2 op2 fix2 ty21 ty22 loc2
610   | nofix_error     = do { precParseErr (op1,fix1) (op2,fix2)
611                          ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
612   | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
613   | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
614                            new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
615                          ; return (mk2 (noLoc new_ty) ty22) }
616   where
617     (nofix_error, associate_right) = compareFixity fix1 fix2
618
619
620 ---------------------------
621 mkOpAppRn :: LHsExpr Name                       -- Left operand; already rearranged
622           -> LHsExpr Name -> Fixity             -- Operator and fixity
623           -> LHsExpr Name                       -- Right operand (not an OpApp, but might
624                                                 -- be a NegApp)
625           -> RnM (HsExpr Name)
626
627 -- (e11 `op1` e12) `op2` e2
628 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
629   | nofix_error
630   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
631        return (OpApp e1 op2 fix2 e2)
632
633   | associate_right = do
634     new_e <- mkOpAppRn e12 op2 fix2 e2
635     return (OpApp e11 op1 fix1 (L loc' new_e))
636   where
637     loc'= combineLocs e12 e2
638     (nofix_error, associate_right) = compareFixity fix1 fix2
639
640 ---------------------------
641 --      (- neg_arg) `op` e2
642 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
643   | nofix_error
644   = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
645        return (OpApp e1 op2 fix2 e2)
646
647   | associate_right
648   = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
649        return (NegApp (L loc' new_e) neg_name)
650   where
651     loc' = combineLocs neg_arg e2
652     (nofix_error, associate_right) = compareFixity negateFixity fix2
653
654 ---------------------------
655 --      e1 `op` - neg_arg
656 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _))     -- NegApp can occur on the right
657   | not associate_right                 -- We *want* right association
658   = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
659        return (OpApp e1 op1 fix1 e2)
660   where
661     (_, associate_right) = compareFixity fix1 negateFixity
662
663 ---------------------------
664 --      Default case
665 mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
666   = ASSERT2( right_op_ok fix (unLoc e2),
667              ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
668     )
669     return (OpApp e1 op fix e2)
670
671 ----------------------------
672 get_op :: LHsExpr Name -> Name
673 get_op (L _ (HsVar n)) = n
674 get_op other           = pprPanic "get_op" (ppr other)
675
676 -- Parser left-associates everything, but
677 -- derived instances may have correctly-associated things to
678 -- in the right operarand.  So we just check that the right operand is OK
679 right_op_ok :: Fixity -> HsExpr Name -> Bool
680 right_op_ok fix1 (OpApp _ _ fix2 _)
681   = not error_please && associate_right
682   where
683     (error_please, associate_right) = compareFixity fix1 fix2
684 right_op_ok _ _
685   = True
686
687 -- Parser initially makes negation bind more tightly than any other operator
688 -- And "deriving" code should respect this (use HsPar if not)
689 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
690 mkNegAppRn neg_arg neg_name
691   = ASSERT( not_op_app (unLoc neg_arg) )
692     return (NegApp neg_arg neg_name)
693
694 not_op_app :: HsExpr id -> Bool
695 not_op_app (OpApp _ _ _ _) = False
696 not_op_app _               = True
697
698 ---------------------------
699 mkOpFormRn :: LHsCmdTop Name            -- Left operand; already rearranged
700           -> LHsExpr Name -> Fixity     -- Operator and fixity
701           -> LHsCmdTop Name             -- Right operand (not an infix)
702           -> RnM (HsCmd Name)
703
704 -- (e11 `op1` e12) `op2` e2
705 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _))
706         op2 fix2 a2
707   | nofix_error
708   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
709        return (HsCmdArrForm op2 (Just fix2) [a1, a2])
710
711   | associate_right
712   = do new_c <- mkOpFormRn a12 op2 fix2 a2
713        return (HsCmdArrForm op1 (Just fix1)
714                [a11, L loc (HsCmdTop (L loc new_c)
715                placeHolderType placeHolderType [])])
716         -- TODO: locs are wrong
717   where
718     (nofix_error, associate_right) = compareFixity fix1 fix2
719
720 --      Default case
721 mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
722   = return (HsCmdArrForm op (Just fix) [arg1, arg2])
723
724
725 --------------------------------------
726 mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
727              -> RnM (Pat Name)
728
729 mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
730   = do  { fix1 <- lookupFixityRn (unLoc op1)
731         ; let (nofix_error, associate_right) = compareFixity fix1 fix2
732
733         ; if nofix_error then do
734                 { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
735                 ; return (ConPatIn op2 (InfixCon p1 p2)) }
736
737           else if associate_right then do
738                 { new_p <- mkConOpPatRn op2 fix2 p12 p2
739                 ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
740           else return (ConPatIn op2 (InfixCon p1 p2)) }
741
742 mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment
743   = ASSERT( not_op_pat (unLoc p2) )
744     return (ConPatIn op (InfixCon p1 p2))
745
746 not_op_pat :: Pat Name -> Bool
747 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
748 not_op_pat _                           = True
749
750 --------------------------------------
751 checkPrecMatch :: Name -> MatchGroup Name body -> RnM ()
752   -- Check precedence of a function binding written infix
753   --   eg  a `op` b `C` c = ...
754   -- See comments with rnExpr (OpApp ...) about "deriving"
755
756 checkPrecMatch op (MG { mg_alts = ms })
757   = mapM_ check ms
758   where
759     check (L _ (Match (L l1 p1 : L l2 p2 :_) _ _))
760       = setSrcSpan (combineSrcSpans l1 l2) $
761         do checkPrec op p1 False
762            checkPrec op p2 True
763
764     check _ = return ()
765         -- This can happen.  Consider
766         --      a `op` True = ...
767         --      op          = ...
768         -- The infix flag comes from the first binding of the group
769         -- but the second eqn has no args (an error, but not discovered
770         -- until the type checker).  So we don't want to crash on the
771         -- second eqn.
772
773 checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
774 checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
775     op_fix@(Fixity op_prec  op_dir) <- lookupFixityRn op
776     op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
777     let
778         inf_ok = op1_prec > op_prec ||
779                  (op1_prec == op_prec &&
780                   (op1_dir == InfixR && op_dir == InfixR && right ||
781                    op1_dir == InfixL && op_dir == InfixL && not right))
782
783         info  = (op,        op_fix)
784         info1 = (unLoc op1, op1_fix)
785         (infol, infor) = if right then (info, info1) else (info1, info)
786     unless inf_ok (precParseErr infol infor)
787
788 checkPrec _ _ _
789   = return ()
790
791 -- Check precedence of (arg op) or (op arg) respectively
792 -- If arg is itself an operator application, then either
793 --   (a) its precedence must be higher than that of op
794 --   (b) its precedency & associativity must be the same as that of op
795 checkSectionPrec :: FixityDirection -> HsExpr RdrName
796         -> LHsExpr Name -> LHsExpr Name -> RnM ()
797 checkSectionPrec direction section op arg
798   = case unLoc arg of
799         OpApp _ op fix _ -> go_for_it (get_op op) fix
800         NegApp _ _       -> go_for_it negateName  negateFixity
801         _                -> return ()
802   where
803     op_name = get_op op
804     go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
805           op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
806           unless (op_prec < arg_prec
807                   || (op_prec == arg_prec && direction == assoc))
808                  (sectionPrecErr (op_name, op_fix)
809                                  (arg_op, arg_fix) section)
810 \end{code}
811
812 Precedence-related error messages
813
814 \begin{code}
815 precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
816 precParseErr op1@(n1,_) op2@(n2,_)
817   | isUnboundName n1 || isUnboundName n2
818   = return ()     -- Avoid error cascade
819   | otherwise
820   = addErr $ hang (ptext (sLit "Precedence parsing error"))
821       4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"),
822                ppr_opfix op2,
823                ptext (sLit "in the same infix expression")])
824
825 sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
826 sectionPrecErr op@(n1,_) arg_op@(n2,_) section
827   | isUnboundName n1 || isUnboundName n2
828   = return ()     -- Avoid error cascade
829   | otherwise
830   = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
831          nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"),
832                       nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]),
833          nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))]
834
835 ppr_opfix :: (Name, Fixity) -> SDoc
836 ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
837    where
838      pp_op | op == negateName = ptext (sLit "prefix `-'")
839            | otherwise        = quotes (ppr op)
840 \end{code}
841
842 %*********************************************************
843 %*                                                      *
844 \subsection{Errors}
845 %*                                                      *
846 %*********************************************************
847
848 \begin{code}
849 warnUnusedForAlls :: SDoc -> LHsTyVarBndrs RdrName -> [RdrName] -> TcM ()
850 warnUnusedForAlls in_doc bound mentioned_rdrs
851   = whenWOptM Opt_WarnUnusedMatches $
852     mapM_ add_warn bound_but_not_used
853   where
854     bound_names        = hsLTyVarLocNames bound
855     bound_but_not_used = filterOut ((`elem` mentioned_rdrs) . unLoc) bound_names
856
857     add_warn (L loc tv)
858       = addWarnAt loc $
859         vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv)
860              , in_doc ]
861
862 warnContextQuantification :: SDoc -> [LHsTyVarBndr RdrName] -> TcM ()
863 warnContextQuantification in_doc tvs
864   = whenWOptM Opt_WarnContextQuantification $
865     mapM_ add_warn tvs
866   where
867     add_warn (L loc tv)
868       = addWarnAt loc $
869         vcat [ ptext (sLit "Variable") <+> quotes (ppr tv) <+>
870                ptext (sLit "is implicitly quantified due to a context") $$
871                ptext (sLit "Use explicit forall syntax instead.") $$
872                ptext (sLit "This will become an error in GHC 7.12.")
873              , in_doc ]
874
875 opTyErr :: RdrName -> HsType RdrName -> SDoc
876 opTyErr op ty@(HsOpTy ty1 _ _)
877   = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty))
878          2 extra
879   where
880     extra | op == dot_tv_RDR && forall_head ty1
881           = perhapsForallMsg
882           | otherwise
883           = ptext (sLit "Use TypeOperators to allow operators in types")
884
885     forall_head (L _ (HsTyVar tv))   = tv == forall_tv_RDR
886     forall_head (L _ (HsAppTy ty _)) = forall_head ty
887     forall_head _other               = False
888 opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty)
889 \end{code}
890
891 %************************************************************************
892 %*                                                                      *
893       Finding the free type variables of a (HsType RdrName)
894 %*                                                                    *
895 %************************************************************************
896
897
898 Note [Kind and type-variable binders]
899 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
900 In a type signature we may implicitly bind type varaible and, more
901 recently, kind variables.  For example:
902   *   f :: a -> a
903       f = ...
904     Here we need to find the free type variables of (a -> a),
905     so that we know what to quantify
906
907   *   class C (a :: k) where ...
908     This binds 'k' in ..., as well as 'a'
909
910   *   f (x :: a -> [a]) = ....
911     Here we bind 'a' in ....
912
913   *   f (x :: T a -> T (b :: k)) = ...
914     Here we bind both 'a' and the kind variable 'k'
915
916   *   type instance F (T (a :: Maybe k)) = ...a...k...
917     Here we want to constrain the kind of 'a', and bind 'k'.
918
919 In general we want to walk over a type, and find
920   * Its free type variables
921   * The free kind variables of any kind signatures in the type
922
923 Hence we returns a pair (kind-vars, type vars)
924 See also Note [HsBSig binder lists] in HsTypes
925
926 \begin{code}
927 type FreeKiTyVars = ([RdrName], [RdrName])
928
929 filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
930 filterInScope rdr_env (kvs, tvs)
931   = (filterOut in_scope kvs, filterOut in_scope tvs)
932   where
933     in_scope tv = tv `elemLocalRdrEnv` rdr_env
934
935 extractHsTyRdrTyVars :: LHsType RdrName -> FreeKiTyVars
936 -- extractHsTyRdrNames finds the free (kind, type) variables of a HsType
937 --                        or the free (sort, kind) variables of a HsKind
938 -- It's used when making the for-alls explicit.
939 -- See Note [Kind and type-variable binders]
940 extractHsTyRdrTyVars ty
941   = case extract_lty ty ([],[]) of
942      (kvs, tvs) -> (nub kvs, nub tvs)
943
944 extractHsTysRdrTyVars :: [LHsType RdrName] -> FreeKiTyVars
945 -- See Note [Kind and type-variable binders]
946 extractHsTysRdrTyVars ty
947   = case extract_ltys ty ([],[]) of
948      (kvs, tvs) -> (nub kvs, nub tvs)
949
950 extractRdrKindSigVars :: Maybe (LHsKind RdrName) -> [RdrName]
951 extractRdrKindSigVars Nothing = []
952 extractRdrKindSigVars (Just k) = nub (fst (extract_lkind k ([],[])))
953
954 extractDataDefnKindVars :: HsDataDefn RdrName -> [RdrName]
955 -- Get the scoped kind variables mentioned free in the constructor decls
956 -- Eg    data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
957 -- Here k should scope over the whole definition
958 extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
959                                     , dd_cons = cons, dd_derivs = derivs })
960   = fst $ extract_lctxt ctxt $
961           extract_mb extract_lkind ksig $
962           extract_mb extract_ltys derivs $
963           foldr (extract_con . unLoc) ([],[]) cons
964   where
965     extract_con (ConDecl { con_res = ResTyGADT {} }) acc = acc
966     extract_con (ConDecl { con_res = ResTyH98, con_qvars = qvs
967                          , con_cxt = ctxt, con_details = details }) acc
968       = extract_hs_tv_bndrs qvs acc $
969         extract_lctxt ctxt $
970         extract_ltys (hsConDeclArgTys details) ([],[])
971
972
973 extract_lctxt :: LHsContext RdrName -> FreeKiTyVars -> FreeKiTyVars
974 extract_lctxt ctxt = extract_ltys (unLoc ctxt)
975
976 extract_ltys :: [LHsType RdrName] -> FreeKiTyVars -> FreeKiTyVars
977 extract_ltys tys acc = foldr extract_lty acc tys
978
979 extract_mb :: (a -> FreeKiTyVars -> FreeKiTyVars) -> Maybe a -> FreeKiTyVars -> FreeKiTyVars
980 extract_mb _ Nothing  acc = acc
981 extract_mb f (Just x) acc = f x acc
982
983 extract_lkind :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars
984 extract_lkind kind (acc_kvs, acc_tvs) = case extract_lty kind ([], acc_kvs) of
985                                           (_, res_kvs) -> (res_kvs, acc_tvs)
986                                         -- Kinds shouldn't have sort signatures!
987
988 extract_lty :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars
989 extract_lty (L _ ty) acc
990   = case ty of
991       HsTyVar tv                -> extract_tv tv acc
992       HsBangTy _ ty             -> extract_lty ty acc
993       HsRecTy flds              -> foldr (extract_lty . cd_fld_type) acc flds
994       HsAppTy ty1 ty2           -> extract_lty ty1 (extract_lty ty2 acc)
995       HsListTy ty               -> extract_lty ty acc
996       HsPArrTy ty               -> extract_lty ty acc
997       HsTupleTy _ tys           -> extract_ltys tys acc
998       HsFunTy ty1 ty2           -> extract_lty ty1 (extract_lty ty2 acc)
999       HsIParamTy _ ty           -> extract_lty ty acc
1000       HsEqTy ty1 ty2            -> extract_lty ty1 (extract_lty ty2 acc)
1001       HsOpTy ty1 (_, (L _ tv)) ty2 -> extract_tv tv (extract_lty ty1 (extract_lty ty2 acc))
1002       HsParTy ty                -> extract_lty ty acc
1003       HsCoreTy {}               -> acc  -- The type is closed
1004       HsQuasiQuoteTy {}         -> acc  -- Quasi quotes mention no type variables
1005       HsSpliceTy {}             -> acc  -- Type splices mention no type variables
1006       HsDocTy ty _              -> extract_lty ty acc
1007       HsExplicitListTy _ tys    -> extract_ltys tys acc
1008       HsExplicitTupleTy _ tys   -> extract_ltys tys acc
1009       HsTyLit _                 -> acc
1010       HsWrapTy _ _              -> panic "extract_lty"
1011       HsKindSig ty ki           -> extract_lty ty (extract_lkind ki acc)
1012       HsForAllTy _ tvs cx ty    -> extract_hs_tv_bndrs tvs acc $
1013                                    extract_lctxt cx   $
1014                                    extract_lty ty ([],[])
1015
1016 extract_hs_tv_bndrs :: LHsTyVarBndrs RdrName -> FreeKiTyVars
1017                     -> FreeKiTyVars -> FreeKiTyVars
1018 extract_hs_tv_bndrs (HsQTvs { hsq_tvs = tvs })
1019                     (acc_kvs, acc_tvs)   -- Note accumulator comes first
1020                     (body_kvs, body_tvs)
1021   | null tvs
1022   = (body_kvs ++ acc_kvs, body_tvs ++ acc_tvs)
1023   | otherwise
1024   = (acc_kvs ++ filterOut (`elem` local_kvs) body_kvs,
1025      acc_tvs ++ filterOut (`elem` local_tvs) body_tvs)
1026   where
1027     local_tvs = map hsLTyVarName tvs
1028     (_, local_kvs) = foldr extract_lty ([], []) [k | L _ (KindedTyVar _ k) <- tvs]
1029        -- These kind variables are bound here if not bound further out
1030
1031 extract_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars
1032 extract_tv tv acc
1033   | isRdrTyVar tv = case acc of (kvs,tvs) -> (kvs, tv : tvs)
1034   | otherwise     = acc
1035 \end{code}