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