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