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