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