Refactor wild card renaming
[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), unitFV name) }
289
290 rnHsTyKi isType doc (HsWildCardTy (NamedWildCard rdr_name))
291 = ASSERT( isType )
292 do { not_in_scope <- isNothing `fmap` lookupOccRn_maybe rdr_name
293 ; when not_in_scope $
294 -- When the named wild card is not in scope, it means it shouldn't be
295 -- there in the first place, i.e. rnHsSigTypeWithWildCards wasn't
296 -- used, so fail.
297 failWith $ text "Unexpected wild card:" <+> quotes (ppr rdr_name) $$
298 docOfHsDocContext doc
299 ; name <- rnTyVar isType rdr_name
300 ; return (HsWildCardTy (NamedWildCard name), unitFV name) }
301
302 --------------
303 rnHsTyKiForAll :: Bool -> HsDocContext -> HsType RdrName
304 -> RnM (HsType Name, FreeVars)
305 rnHsTyKiForAll isType doc (HsForAllTy Implicit extra _ lctxt@(L _ ctxt) ty)
306 = ASSERT( isType ) do
307 -- Implicit quantifiction in source code (no kinds on tyvars)
308 -- Given the signature C => T we universally quantify
309 -- over FV(T) \ {in-scope-tyvars}
310 rdr_env <- getLocalRdrEnv
311 loc <- getSrcSpanM
312 let
313 (forall_kvs, forall_tvs) = filterInScope rdr_env $
314 extractHsTysRdrTyVars (ty:ctxt)
315 -- In for-all types we don't bring in scope
316 -- kind variables mentioned in kind signatures
317 -- (Well, not yet anyway....)
318 -- f :: Int -> T (a::k) -- Not allowed
319
320 -- The filterInScope is to ensure that we don't quantify over
321 -- type variables that are in scope; when GlasgowExts is off,
322 -- there usually won't be any, except for class signatures:
323 -- class C a where { op :: a -> a }
324 tyvar_bndrs = userHsTyVarBndrs loc forall_tvs
325
326 rnForAll doc Implicit extra forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty
327
328 rnHsTyKiForAll isType doc
329 fulltype@(HsForAllTy Qualified extra _ lctxt@(L _ ctxt) ty)
330 = ASSERT( isType ) do
331 rdr_env <- getLocalRdrEnv
332 loc <- getSrcSpanM
333 let
334 (forall_kvs, forall_tvs) = filterInScope rdr_env $
335 extractHsTysRdrTyVars (ty:ctxt)
336 tyvar_bndrs = userHsTyVarBndrs loc forall_tvs
337 in_type_doc = ptext (sLit "In the type") <+> quotes (ppr fulltype)
338
339 -- See Note [Context quantification]
340 warnContextQuantification (in_type_doc $$ docOfHsDocContext doc) tyvar_bndrs
341 rnForAll doc Implicit extra forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty
342
343 rnHsTyKiForAll isType doc
344 ty@(HsForAllTy Explicit extra forall_tyvars lctxt@(L _ ctxt) tau)
345 = ASSERT( isType ) do { -- Explicit quantification.
346 -- Check that the forall'd tyvars are actually
347 -- mentioned in the type, and produce a warning if not
348 let (kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt)
349 in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty)
350 ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc)
351 forall_tyvars mentioned
352 ; traceRn (text "rnHsTyKiForAll:Exlicit" <+> vcat
353 [ppr forall_tyvars, ppr lctxt,ppr tau ])
354 ; rnForAll doc Explicit extra kvs forall_tyvars lctxt tau }
355
356 -- The following should never happen but keeps the completeness checker happy
357 rnHsTyKiForAll isType doc ty = rnHsTyKi isType doc ty
358 --------------
359 rnTyVar :: Bool -> RdrName -> RnM Name
360 rnTyVar is_type rdr_name
361 | is_type = lookupTypeOccRn rdr_name
362 | otherwise = lookupKindOccRn rdr_name
363
364
365 --------------
366 rnLHsTypes :: HsDocContext -> [LHsType RdrName]
367 -> RnM ([LHsType Name], FreeVars)
368 rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
369
370 rnForAll :: HsDocContext -> HsExplicitFlag
371 -> Maybe SrcSpan -- Location of an extra-constraints wildcard
372 -> [RdrName] -- Kind variables
373 -> LHsTyVarBndrs RdrName -- Type variables
374 -> LHsContext RdrName -> LHsType RdrName
375 -> RnM (HsType Name, FreeVars)
376
377 rnForAll doc exp extra kvs forall_tyvars ctxt ty
378 | null kvs, null (hsQTvBndrs forall_tyvars), null (unLoc ctxt), isNothing extra
379 = rnHsType doc (unLoc ty)
380 -- One reason for this case is that a type like Int#
381 -- starts off as (HsForAllTy Implicit Nothing [] Int), in case
382 -- there is some quantification. Now that we have quantified
383 -- and discovered there are no type variables, it's nicer to turn
384 -- it into plain Int. If it were Int# instead of Int, we'd actually
385 -- get an error, because the body of a genuine for-all is
386 -- of kind *.
387
388 | otherwise
389 = bindHsTyVars doc Nothing kvs forall_tyvars $ \ new_tyvars ->
390 do { (new_ctxt, fvs1) <- rnContext doc ctxt
391 ; (new_ty, fvs2) <- rnLHsType doc ty
392 ; return (HsForAllTy exp extra new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) }
393 -- Retain the same implicit/explicit flag as before
394 -- so that we can later print it correctly
395
396 ---------------
397 bindSigTyVarsFV :: [Name]
398 -> RnM (a, FreeVars)
399 -> RnM (a, FreeVars)
400 -- Used just before renaming the defn of a function
401 -- with a separate type signature, to bring its tyvars into scope
402 -- With no -XScopedTypeVariables, this is a no-op
403 bindSigTyVarsFV tvs thing_inside
404 = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables
405 ; if not scoped_tyvars then
406 thing_inside
407 else
408 bindLocalNamesFV tvs thing_inside }
409
410 ---------------
411 bindHsTyVars :: HsDocContext
412 -> Maybe a -- Just _ => an associated type decl
413 -> [RdrName] -- Kind variables from scope
414 -> LHsTyVarBndrs RdrName -- Type variables
415 -> (LHsTyVarBndrs Name -> RnM (b, FreeVars))
416 -> RnM (b, FreeVars)
417 -- (a) Bring kind variables into scope
418 -- both (i) passed in (kv_bndrs)
419 -- and (ii) mentioned in the kinds of tv_bndrs
420 -- (b) Bring type variables into scope
421 bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
422 = do { rdr_env <- getLocalRdrEnv
423 ; let tvs = hsQTvBndrs tv_bndrs
424 kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs
425 , let (_, kvs) = extractHsTyRdrTyVars kind
426 , kv <- kvs ]
427 all_kvs' = nub (kv_bndrs ++ kvs_from_tv_bndrs)
428 all_kvs = filterOut (`elemLocalRdrEnv` rdr_env) all_kvs'
429
430 overlap_kvs = [ kv | kv <- all_kvs, any ((==) kv . hsLTyVarName) tvs ]
431 -- These variables appear both as kind and type variables
432 -- in the same declaration; eg type family T (x :: *) (y :: x)
433 -- We disallow this: too confusing!
434
435 ; poly_kind <- xoptM Opt_PolyKinds
436 ; unless (poly_kind || null all_kvs)
437 (addErr (badKindBndrs doc all_kvs))
438 ; unless (null overlap_kvs)
439 (addErr (overlappingKindVars doc overlap_kvs))
440
441 ; loc <- getSrcSpanM
442 ; kv_names <- mapM (newLocalBndrRn . L loc) all_kvs
443 ; bindLocalNamesFV kv_names $
444 do { let tv_names_w_loc = hsLTyVarLocNames tv_bndrs
445
446 rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars)
447 rn_tv_bndr (L loc (UserTyVar rdr))
448 = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
449 ; return (L loc (UserTyVar nm), emptyFVs) }
450 rn_tv_bndr (L loc (KindedTyVar (L lv rdr) kind))
451 = do { sig_ok <- xoptM Opt_KindSignatures
452 ; unless sig_ok (badSigErr False doc kind)
453 ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr
454 ; (kind', fvs) <- rnLHsKind doc kind
455 ; return (L loc (KindedTyVar (L lv nm) kind'), fvs) }
456
457 -- Check for duplicate or shadowed tyvar bindrs
458 ; checkDupRdrNames tv_names_w_loc
459 ; when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
460
461 ; (tv_bndrs', fvs1) <- mapFvRn rn_tv_bndr tvs
462 ; (res, fvs2) <- bindLocalNamesFV (map hsLTyVarName tv_bndrs') $
463 do { inner_rdr_env <- getLocalRdrEnv
464 ; traceRn (text "bhtv" <+> vcat
465 [ ppr tvs, ppr kv_bndrs, ppr kvs_from_tv_bndrs
466 , ppr $ map (`elemLocalRdrEnv` rdr_env) all_kvs'
467 , ppr $ map (getUnique . rdrNameOcc) all_kvs'
468 , ppr all_kvs, ppr rdr_env, ppr inner_rdr_env ])
469 ; thing_inside (HsQTvs { hsq_tvs = tv_bndrs', hsq_kvs = kv_names }) }
470 ; return (res, fvs1 `plusFV` fvs2) } }
471
472 newTyVarNameRn :: Maybe a -> LocalRdrEnv -> SrcSpan -> RdrName -> RnM Name
473 newTyVarNameRn mb_assoc rdr_env loc rdr
474 | Just _ <- mb_assoc -- Use the same Name as the parent class decl
475 , Just n <- lookupLocalRdrEnv rdr_env rdr
476 = return n
477 | otherwise
478 = newLocalBndrRn (L loc rdr)
479
480 --------------------------------
481 rnHsBndrSig :: HsDocContext
482 -> HsWithBndrs RdrName (LHsType RdrName)
483 -> (HsWithBndrs Name (LHsType Name) -> RnM (a, FreeVars))
484 -> RnM (a, FreeVars)
485 rnHsBndrSig doc (HsWB { hswb_cts = ty@(L loc _) }) thing_inside
486 = do { sig_ok <- xoptM Opt_ScopedTypeVariables
487 ; unless sig_ok (badSigErr True doc ty)
488 ; let (kv_bndrs, tv_bndrs) = extractHsTyRdrTyVars ty
489 ; name_env <- getLocalRdrEnv
490 ; tv_names <- newLocalBndrsRn [L loc tv | tv <- tv_bndrs
491 , not (tv `elemLocalRdrEnv` name_env) ]
492 ; kv_names <- newLocalBndrsRn [L loc kv | kv <- kv_bndrs
493 , not (kv `elemLocalRdrEnv` name_env) ]
494 ; bindLocalNamesFV kv_names $
495 bindLocalNamesFV tv_names $
496 do { (ty', fvs1, wcs) <- rnLHsTypeWithWildCards doc ty
497 ; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty', hswb_kvs = kv_names,
498 hswb_tvs = tv_names, hswb_wcs = wcs })
499 ; return (res, fvs1 `plusFV` fvs2) } }
500
501 overlappingKindVars :: HsDocContext -> [RdrName] -> SDoc
502 overlappingKindVars doc kvs
503 = vcat [ ptext (sLit "Kind variable") <> plural kvs <+>
504 ptext (sLit "also used as type variable") <> plural kvs
505 <> colon <+> pprQuotedList kvs
506 , docOfHsDocContext doc ]
507
508 badKindBndrs :: HsDocContext -> [RdrName] -> SDoc
509 badKindBndrs doc kvs
510 = vcat [ hang (ptext (sLit "Unexpected kind variable") <> plural kvs
511 <+> pprQuotedList kvs)
512 2 (ptext (sLit "Perhaps you intended to use PolyKinds"))
513 , docOfHsDocContext doc ]
514
515 badSigErr :: Bool -> HsDocContext -> LHsType RdrName -> TcM ()
516 badSigErr is_type doc (L loc ty)
517 = setSrcSpan loc $ addErr $
518 vcat [ hang (ptext (sLit "Illegal") <+> what
519 <+> ptext (sLit "signature:") <+> quotes (ppr ty))
520 2 (ptext (sLit "Perhaps you intended to use") <+> flag)
521 , docOfHsDocContext doc ]
522 where
523 what | is_type = ptext (sLit "type")
524 | otherwise = ptext (sLit "kind")
525 flag | is_type = ptext (sLit "ScopedTypeVariables")
526 | otherwise = ptext (sLit "KindSignatures")
527
528 dataKindsErr :: Bool -> HsType RdrName -> SDoc
529 dataKindsErr is_type thing
530 = hang (ptext (sLit "Illegal") <+> what <> colon <+> quotes (ppr thing))
531 2 (ptext (sLit "Perhaps you intended to use DataKinds"))
532 where
533 what | is_type = ptext (sLit "type")
534 | otherwise = ptext (sLit "kind")
535
536 --------------------------------
537 -- | Variant of @rnHsSigType@ that supports wild cards. Also returns the wild
538 -- cards to bind.
539 rnHsSigTypeWithWildCards :: SDoc -> LHsType RdrName
540 -> RnM (LHsType Name, FreeVars, [Name])
541 rnHsSigTypeWithWildCards doc_str = rnLHsTypeWithWildCards (TypeSigCtx doc_str)
542
543 -- | Variant of @rnLHsType@ that supports wild cards. The third element of the
544 -- tuple consists of the freshly generated names of the anonymous wild cards
545 -- occurring in the type, as well as the names of the named wild cards in the
546 -- type that are not yet in scope.
547 rnLHsTypeWithWildCards :: HsDocContext -> LHsType RdrName
548 -> RnM (LHsType Name, FreeVars, [Name])
549 rnLHsTypeWithWildCards doc ty
550 = do { -- When there is a wild card at the end of the context, remove it and
551 -- add its location as the extra-constraints wild card in the
552 -- HsForAllTy.
553 let ty' = extractExtraCtsWc `fmap` ty
554
555 ; checkValidPartialType doc ty'
556
557 ; rdr_env <- getLocalRdrEnv
558 -- Filter out named wildcards that are already in scope
559 ; let (_, wcs) = collectWildCards ty'
560 nwcs = [L loc n | L loc (NamedWildCard n) <- wcs
561 , not (elemLocalRdrEnv n rdr_env) ]
562 ; bindLocatedLocalsRn nwcs $ \nwcs' -> do {
563 (ty'', fvs) <- rnLHsType doc ty'
564 -- Add the anonymous wildcards that have been given names during
565 -- renaming
566 ; let (_, wcs') = collectWildCards ty''
567 awcs = filter (isAnonWildCard . unLoc) wcs'
568 ; return (ty'', fvs, nwcs' ++ map (HsSyn.wildCardName . unLoc) awcs) } }
569 where
570 extractExtraCtsWc (HsForAllTy flag _ bndrs (L l ctxt) ty)
571 | Just (ctxt', ct) <- snocView ctxt
572 , L lx (HsWildCardTy (AnonWildCard _)) <- ignoreParens ct
573 = HsForAllTy flag (Just lx) bndrs (L l ctxt') ty
574 extractExtraCtsWc ty = ty
575
576 -- | Extract all wild cards from a type. The named and anonymous
577 -- extra-constraints wild cards are returned separately to be able to give
578 -- more accurate error messages.
579 collectWildCards
580 :: Eq name => LHsType name
581 -> ([Located (HsWildCardInfo name)], -- extra-constraints wild cards
582 [Located (HsWildCardInfo name)]) -- wild cards
583 collectWildCards lty = (nubBy sameWildCard extra, nubBy sameWildCard wcs)
584 where
585 (extra, wcs) = go lty
586 go (L loc ty) = case ty of
587 HsAppTy ty1 ty2 -> go ty1 `mappend` go ty2
588 HsFunTy ty1 ty2 -> go ty1 `mappend` go ty2
589 HsListTy ty -> go ty
590 HsPArrTy ty -> go ty
591 HsTupleTy _ tys -> gos tys
592 HsOpTy ty1 _ ty2 -> go ty1 `mappend` go ty2
593 HsParTy ty -> go ty
594 HsIParamTy _ ty -> go ty
595 HsEqTy ty1 ty2 -> go ty1 `mappend` go ty2
596 HsKindSig ty kind -> go ty `mappend` go kind
597 HsDocTy ty _ -> go ty
598 HsBangTy _ ty -> go ty
599 HsRecTy flds -> gos $ map (cd_fld_type . unLoc) flds
600 HsExplicitListTy _ tys -> gos tys
601 HsExplicitTupleTy _ tys -> gos tys
602 HsWrapTy _ ty -> go (L loc ty)
603 -- Interesting cases
604 HsWildCardTy wc -> ([], [L loc wc])
605 HsForAllTy _ _ _ (L _ ctxt) ty -> ctxtWcs `mappend` go ty
606 where
607 ctxt' = map ignoreParens ctxt
608 extraWcs = [L l wc | L l (HsWildCardTy wc) <- ctxt']
609 (_, wcs) = gos ctxt'
610 -- Remove extra-constraints wild cards from wcs
611 ctxtWcs = (extraWcs, deleteFirstsBy sameWildCard
612 (nubBy sameWildCard wcs) extraWcs)
613 -- HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit
614 _ -> mempty
615 gos = mconcat . map go
616
617 -- | Check the validity of a partial type signature. The following things are
618 -- checked:
619 --
620 -- * Named extra-constraints wild cards aren't allowed,
621 -- e.g. invalid: @(Show a, _x) => a -> String@.
622 --
623 -- * There is only one extra-constraints wild card in the context and it must
624 -- come last, e.g. invalid: @(_, Show a) => a -> String@
625 -- or @(_, Show a, _) => a -> String@.
626 --
627 -- * There should be no unnamed wild cards in the context.
628 --
629 -- * An extra-constraints wild card can only occur in the top-level context.
630 -- This would be invalid: @(Eq a, _) => a -> (Num a, _) => a -> Bool@.
631 --
632 -- * Named wild cards occurring in the context must also occur in the monotype.
633 --
634 -- When an invalid wild card is found, we fail with an error.
635 checkValidPartialType :: HsDocContext -> LHsType RdrName -> RnM ()
636 checkValidPartialType doc lty
637 = do { whenNonEmpty isNamedWildCard inExtra $ \(L loc _) ->
638 failAt loc $ typeDoc $$
639 text "An extra-constraints wild card cannot be named" $$
640 docOfHsDocContext doc
641
642 ; whenNonEmpty isAnonWildCard extraTopLevel $ \(L loc _) ->
643 failAt loc $ typeDoc $$
644 -- If there was a valid extra-constraints wild card, it should have
645 -- already been removed and its location should be stored in the
646 -- HsForAllTy
647 (if isJust extra
648 then text "Only a single extra-constraints wild card is allowed"
649 else fcat [ text "An extra-constraints wild card must occur"
650 , text "at the end of the constraints" ]) $$
651 docOfHsDocContext doc
652
653 ; whenNonEmpty isAnonWildCard inCtxt $ \(L loc _) ->
654 failAt loc $ typeDoc $$
655 text "Anonymous wild cards are not allowed in constraints" $$
656 docOfHsDocContext doc
657
658 ; whenNonEmpty isAnonWildCard nestedExtra $ \(L loc _) ->
659 failAt loc $ typeDoc $$
660 fcat [ text "An extra-constraints wild card is only allowed"
661 , text "in the top-level context" ] $$
662 docOfHsDocContext doc
663
664 ; whenNonEmpty isNamedWildCard inCtxtNotInTau $ \(L loc name) ->
665 failAt loc $ typeDoc $$
666 fcat [ text "The named wild card" <+> quotes (ppr name) <> space
667 , text "is only allowed in the constraints"
668 , text "when it also occurs in the rest of the type" ] $$
669 docOfHsDocContext doc }
670 where
671 typeDoc = hang (text "Invalid partial type:") 2 (ppr lty)
672 (extra, ctxt, tau) = splitPartialType lty
673 (inExtra, _) = collectWildCards lty
674 (nestedExtra, inTau) = collectWildCards tau
675 (_, inCtxt) = mconcat $ map collectWildCards ctxt
676 inCtxtNotInTau = deleteFirstsBy sameWildCard inCtxt inTau
677 extraTopLevel = deleteFirstsBy sameWildCard inExtra nestedExtra
678
679 splitPartialType (L _ (HsForAllTy _ extra _ (L _ ctxt) ty))
680 = (extra, map ignoreParens ctxt, ty)
681 splitPartialType ty = (Nothing, [], ty)
682
683 whenNonEmpty test wcs f
684 = whenIsJust (listToMaybe $ filter (test . unLoc) wcs) f
685
686
687 {-
688 *********************************************************
689 * *
690 \subsection{Contexts and predicates}
691 * *
692 *********************************************************
693 -}
694
695 rnConDeclFields :: HsDocContext -> [LConDeclField RdrName]
696 -> RnM ([LConDeclField Name], FreeVars)
697 rnConDeclFields doc fields = mapFvRn (rnField doc) fields
698
699 rnField :: HsDocContext -> LConDeclField RdrName
700 -> RnM (LConDeclField Name, FreeVars)
701 rnField doc (L l (ConDeclField names ty haddock_doc))
702 = do { new_names <- mapM lookupLocatedTopBndrRn names
703 ; (new_ty, fvs) <- rnLHsType doc ty
704 ; new_haddock_doc <- rnMbLHsDoc haddock_doc
705 ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
706
707 rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
708 rnContext doc (L loc cxt)
709 = do { (cxt', fvs) <- rnLHsTypes doc cxt
710 ; return (L loc cxt', fvs) }
711
712 {-
713 ************************************************************************
714 * *
715 Fixities and precedence parsing
716 * *
717 ************************************************************************
718
719 @mkOpAppRn@ deals with operator fixities. The argument expressions
720 are assumed to be already correctly arranged. It needs the fixities
721 recorded in the OpApp nodes, because fixity info applies to the things
722 the programmer actually wrote, so you can't find it out from the Name.
723
724 Furthermore, the second argument is guaranteed not to be another
725 operator application. Why? Because the parser parses all
726 operator appications left-associatively, EXCEPT negation, which
727 we need to handle specially.
728 Infix types are read in a *right-associative* way, so that
729 a `op` b `op` c
730 is always read in as
731 a `op` (b `op` c)
732
733 mkHsOpTyRn rearranges where necessary. The two arguments
734 have already been renamed and rearranged. It's made rather tiresome
735 by the presence of ->, which is a separate syntactic construct.
736 -}
737
738 ---------------
739 -- Building (ty1 `op1` (ty21 `op2` ty22))
740 mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
741 -> Name -> Fixity -> LHsType Name -> LHsType Name
742 -> RnM (HsType Name)
743
744 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 (w2, op2) ty22))
745 = do { fix2 <- lookupTyFixityRn op2
746 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
747 (\t1 t2 -> HsOpTy t1 (w2, op2) t2)
748 (unLoc op2) fix2 ty21 ty22 loc2 }
749
750 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
751 = mk_hs_op_ty mk1 pp_op1 fix1 ty1
752 HsFunTy funTyConName funTyFixity ty21 ty22 loc2
753
754 mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment
755 = return (mk1 ty1 ty2)
756
757 ---------------
758 mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
759 -> Name -> Fixity -> LHsType Name
760 -> (LHsType Name -> LHsType Name -> HsType Name)
761 -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
762 -> RnM (HsType Name)
763 mk_hs_op_ty mk1 op1 fix1 ty1
764 mk2 op2 fix2 ty21 ty22 loc2
765 | nofix_error = do { precParseErr (op1,fix1) (op2,fix2)
766 ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
767 | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
768 | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
769 new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
770 ; return (mk2 (noLoc new_ty) ty22) }
771 where
772 (nofix_error, associate_right) = compareFixity fix1 fix2
773
774
775 ---------------------------
776 mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged
777 -> LHsExpr Name -> Fixity -- Operator and fixity
778 -> LHsExpr Name -- Right operand (not an OpApp, but might
779 -- be a NegApp)
780 -> RnM (HsExpr Name)
781
782 -- (e11 `op1` e12) `op2` e2
783 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
784 | nofix_error
785 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
786 return (OpApp e1 op2 fix2 e2)
787
788 | associate_right = do
789 new_e <- mkOpAppRn e12 op2 fix2 e2
790 return (OpApp e11 op1 fix1 (L loc' new_e))
791 where
792 loc'= combineLocs e12 e2
793 (nofix_error, associate_right) = compareFixity fix1 fix2
794
795 ---------------------------
796 -- (- neg_arg) `op` e2
797 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
798 | nofix_error
799 = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
800 return (OpApp e1 op2 fix2 e2)
801
802 | associate_right
803 = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
804 return (NegApp (L loc' new_e) neg_name)
805 where
806 loc' = combineLocs neg_arg e2
807 (nofix_error, associate_right) = compareFixity negateFixity fix2
808
809 ---------------------------
810 -- e1 `op` - neg_arg
811 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right
812 | not associate_right -- We *want* right association
813 = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
814 return (OpApp e1 op1 fix1 e2)
815 where
816 (_, associate_right) = compareFixity fix1 negateFixity
817
818 ---------------------------
819 -- Default case
820 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
821 = ASSERT2( right_op_ok fix (unLoc e2),
822 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
823 )
824 return (OpApp e1 op fix e2)
825
826 ----------------------------
827 get_op :: LHsExpr Name -> Name
828 get_op (L _ (HsVar n)) = n
829 get_op other = pprPanic "get_op" (ppr other)
830
831 -- Parser left-associates everything, but
832 -- derived instances may have correctly-associated things to
833 -- in the right operarand. So we just check that the right operand is OK
834 right_op_ok :: Fixity -> HsExpr Name -> Bool
835 right_op_ok fix1 (OpApp _ _ fix2 _)
836 = not error_please && associate_right
837 where
838 (error_please, associate_right) = compareFixity fix1 fix2
839 right_op_ok _ _
840 = True
841
842 -- Parser initially makes negation bind more tightly than any other operator
843 -- And "deriving" code should respect this (use HsPar if not)
844 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
845 mkNegAppRn neg_arg neg_name
846 = ASSERT( not_op_app (unLoc neg_arg) )
847 return (NegApp neg_arg neg_name)
848
849 not_op_app :: HsExpr id -> Bool
850 not_op_app (OpApp _ _ _ _) = False
851 not_op_app _ = True
852
853 ---------------------------
854 mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged
855 -> LHsExpr Name -> Fixity -- Operator and fixity
856 -> LHsCmdTop Name -- Right operand (not an infix)
857 -> RnM (HsCmd Name)
858
859 -- (e11 `op1` e12) `op2` e2
860 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _))
861 op2 fix2 a2
862 | nofix_error
863 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
864 return (HsCmdArrForm op2 (Just fix2) [a1, a2])
865
866 | associate_right
867 = do new_c <- mkOpFormRn a12 op2 fix2 a2
868 return (HsCmdArrForm op1 (Just fix1)
869 [a11, L loc (HsCmdTop (L loc new_c)
870 placeHolderType placeHolderType [])])
871 -- TODO: locs are wrong
872 where
873 (nofix_error, associate_right) = compareFixity fix1 fix2
874
875 -- Default case
876 mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
877 = return (HsCmdArrForm op (Just fix) [arg1, arg2])
878
879
880 --------------------------------------
881 mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
882 -> RnM (Pat Name)
883
884 mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
885 = do { fix1 <- lookupFixityRn (unLoc op1)
886 ; let (nofix_error, associate_right) = compareFixity fix1 fix2
887
888 ; if nofix_error then do
889 { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
890 ; return (ConPatIn op2 (InfixCon p1 p2)) }
891
892 else if associate_right then do
893 { new_p <- mkConOpPatRn op2 fix2 p12 p2
894 ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
895 else return (ConPatIn op2 (InfixCon p1 p2)) }
896
897 mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment
898 = ASSERT( not_op_pat (unLoc p2) )
899 return (ConPatIn op (InfixCon p1 p2))
900
901 not_op_pat :: Pat Name -> Bool
902 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
903 not_op_pat _ = True
904
905 --------------------------------------
906 checkPrecMatch :: Name -> MatchGroup Name body -> RnM ()
907 -- Check precedence of a function binding written infix
908 -- eg a `op` b `C` c = ...
909 -- See comments with rnExpr (OpApp ...) about "deriving"
910
911 checkPrecMatch op (MG { mg_alts = ms })
912 = mapM_ check ms
913 where
914 check (L _ (Match _ (L l1 p1 : L l2 p2 :_) _ _))
915 = setSrcSpan (combineSrcSpans l1 l2) $
916 do checkPrec op p1 False
917 checkPrec op p2 True
918
919 check _ = return ()
920 -- This can happen. Consider
921 -- a `op` True = ...
922 -- op = ...
923 -- The infix flag comes from the first binding of the group
924 -- but the second eqn has no args (an error, but not discovered
925 -- until the type checker). So we don't want to crash on the
926 -- second eqn.
927
928 checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
929 checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
930 op_fix@(Fixity op_prec op_dir) <- lookupFixityRn op
931 op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
932 let
933 inf_ok = op1_prec > op_prec ||
934 (op1_prec == op_prec &&
935 (op1_dir == InfixR && op_dir == InfixR && right ||
936 op1_dir == InfixL && op_dir == InfixL && not right))
937
938 info = (op, op_fix)
939 info1 = (unLoc op1, op1_fix)
940 (infol, infor) = if right then (info, info1) else (info1, info)
941 unless inf_ok (precParseErr infol infor)
942
943 checkPrec _ _ _
944 = return ()
945
946 -- Check precedence of (arg op) or (op arg) respectively
947 -- If arg is itself an operator application, then either
948 -- (a) its precedence must be higher than that of op
949 -- (b) its precedency & associativity must be the same as that of op
950 checkSectionPrec :: FixityDirection -> HsExpr RdrName
951 -> LHsExpr Name -> LHsExpr Name -> RnM ()
952 checkSectionPrec direction section op arg
953 = case unLoc arg of
954 OpApp _ op fix _ -> go_for_it (get_op op) fix
955 NegApp _ _ -> go_for_it negateName negateFixity
956 _ -> return ()
957 where
958 op_name = get_op op
959 go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
960 op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
961 unless (op_prec < arg_prec
962 || (op_prec == arg_prec && direction == assoc))
963 (sectionPrecErr (op_name, op_fix)
964 (arg_op, arg_fix) section)
965
966 -- Precedence-related error messages
967
968 precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
969 precParseErr op1@(n1,_) op2@(n2,_)
970 | isUnboundName n1 || isUnboundName n2
971 = return () -- Avoid error cascade
972 | otherwise
973 = addErr $ hang (ptext (sLit "Precedence parsing error"))
974 4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"),
975 ppr_opfix op2,
976 ptext (sLit "in the same infix expression")])
977
978 sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
979 sectionPrecErr op@(n1,_) arg_op@(n2,_) section
980 | isUnboundName n1 || isUnboundName n2
981 = return () -- Avoid error cascade
982 | otherwise
983 = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
984 nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"),
985 nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]),
986 nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))]
987
988 ppr_opfix :: (Name, Fixity) -> SDoc
989 ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
990 where
991 pp_op | op == negateName = ptext (sLit "prefix `-'")
992 | otherwise = quotes (ppr op)
993
994 {-
995 *********************************************************
996 * *
997 \subsection{Errors}
998 * *
999 *********************************************************
1000 -}
1001
1002 warnUnusedForAlls :: SDoc -> LHsTyVarBndrs RdrName -> [RdrName] -> TcM ()
1003 warnUnusedForAlls in_doc bound mentioned_rdrs
1004 = whenWOptM Opt_WarnUnusedMatches $
1005 mapM_ add_warn bound_but_not_used
1006 where
1007 bound_names = hsLTyVarLocNames bound
1008 bound_but_not_used = filterOut ((`elem` mentioned_rdrs) . unLoc) bound_names
1009
1010 add_warn (L loc tv)
1011 = addWarnAt loc $
1012 vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv)
1013 , in_doc ]
1014
1015 warnContextQuantification :: SDoc -> [LHsTyVarBndr RdrName] -> TcM ()
1016 warnContextQuantification in_doc tvs
1017 = whenWOptM Opt_WarnContextQuantification $
1018 mapM_ add_warn tvs
1019 where
1020 add_warn (L loc tv)
1021 = addWarnAt loc $
1022 vcat [ ptext (sLit "Variable") <+> quotes (ppr tv) <+>
1023 ptext (sLit "is implicitly quantified due to a context") $$
1024 ptext (sLit "Use explicit forall syntax instead.") $$
1025 ptext (sLit "This will become an error in GHC 7.12.")
1026 , in_doc ]
1027
1028 opTyErr :: RdrName -> HsType RdrName -> SDoc
1029 opTyErr op ty@(HsOpTy ty1 _ _)
1030 = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty))
1031 2 extra
1032 where
1033 extra | op == dot_tv_RDR && forall_head ty1
1034 = perhapsForallMsg
1035 | otherwise
1036 = ptext (sLit "Use TypeOperators to allow operators in types")
1037
1038 forall_head (L _ (HsTyVar tv)) = tv == forall_tv_RDR
1039 forall_head (L _ (HsAppTy ty _)) = forall_head ty
1040 forall_head _other = False
1041 opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty)
1042
1043 {-
1044 ************************************************************************
1045 * *
1046 Finding the free type variables of a (HsType RdrName)
1047 * *
1048 ************************************************************************
1049
1050
1051 Note [Kind and type-variable binders]
1052 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1053 In a type signature we may implicitly bind type variable and, more
1054 recently, kind variables. For example:
1055 * f :: a -> a
1056 f = ...
1057 Here we need to find the free type variables of (a -> a),
1058 so that we know what to quantify
1059
1060 * class C (a :: k) where ...
1061 This binds 'k' in ..., as well as 'a'
1062
1063 * f (x :: a -> [a]) = ....
1064 Here we bind 'a' in ....
1065
1066 * f (x :: T a -> T (b :: k)) = ...
1067 Here we bind both 'a' and the kind variable 'k'
1068
1069 * type instance F (T (a :: Maybe k)) = ...a...k...
1070 Here we want to constrain the kind of 'a', and bind 'k'.
1071
1072 In general we want to walk over a type, and find
1073 * Its free type variables
1074 * The free kind variables of any kind signatures in the type
1075
1076 Hence we returns a pair (kind-vars, type vars)
1077 See also Note [HsBSig binder lists] in HsTypes
1078 -}
1079
1080 type FreeKiTyVars = ([RdrName], [RdrName])
1081
1082 filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
1083 filterInScope rdr_env (kvs, tvs)
1084 = (filterOut in_scope kvs, filterOut in_scope tvs)
1085 where
1086 in_scope tv = tv `elemLocalRdrEnv` rdr_env
1087
1088 extractHsTyRdrTyVars :: LHsType RdrName -> FreeKiTyVars
1089 -- extractHsTyRdrNames finds the free (kind, type) variables of a HsType
1090 -- or the free (sort, kind) variables of a HsKind
1091 -- It's used when making the for-alls explicit.
1092 -- See Note [Kind and type-variable binders]
1093 extractHsTyRdrTyVars ty
1094 = case extract_lty ty ([],[]) of
1095 (kvs, tvs) -> (nub kvs, nub tvs)
1096
1097 extractHsTysRdrTyVars :: [LHsType RdrName] -> FreeKiTyVars
1098 -- See Note [Kind and type-variable binders]
1099 extractHsTysRdrTyVars ty
1100 = case extract_ltys ty ([],[]) of
1101 (kvs, tvs) -> (nub kvs, nub tvs)
1102
1103 extractRdrKindSigVars :: Maybe (LHsKind RdrName) -> [RdrName]
1104 extractRdrKindSigVars Nothing = []
1105 extractRdrKindSigVars (Just k) = nub (fst (extract_lkind k ([],[])))
1106
1107 extractDataDefnKindVars :: HsDataDefn RdrName -> [RdrName]
1108 -- Get the scoped kind variables mentioned free in the constructor decls
1109 -- Eg data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
1110 -- Here k should scope over the whole definition
1111 extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
1112 , dd_cons = cons, dd_derivs = derivs })
1113 = fst $ extract_lctxt ctxt $
1114 extract_mb extract_lkind ksig $
1115 extract_mb (extract_ltys . unLoc) derivs $
1116 foldr (extract_con . unLoc) ([],[]) cons
1117 where
1118 extract_con (ConDecl { con_res = ResTyGADT {} }) acc = acc
1119 extract_con (ConDecl { con_res = ResTyH98, con_qvars = qvs
1120 , con_cxt = ctxt, con_details = details }) acc
1121 = extract_hs_tv_bndrs qvs acc $
1122 extract_lctxt ctxt $
1123 extract_ltys (hsConDeclArgTys details) ([],[])
1124
1125
1126 extract_lctxt :: LHsContext RdrName -> FreeKiTyVars -> FreeKiTyVars
1127 extract_lctxt ctxt = extract_ltys (unLoc ctxt)
1128
1129 extract_ltys :: [LHsType RdrName] -> FreeKiTyVars -> FreeKiTyVars
1130 extract_ltys tys acc = foldr extract_lty acc tys
1131
1132 extract_mb :: (a -> FreeKiTyVars -> FreeKiTyVars) -> Maybe a -> FreeKiTyVars -> FreeKiTyVars
1133 extract_mb _ Nothing acc = acc
1134 extract_mb f (Just x) acc = f x acc
1135
1136 extract_lkind :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars
1137 extract_lkind kind (acc_kvs, acc_tvs) = case extract_lty kind ([], acc_kvs) of
1138 (_, res_kvs) -> (res_kvs, acc_tvs)
1139 -- Kinds shouldn't have sort signatures!
1140
1141 extract_lty :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars
1142 extract_lty (L _ ty) acc
1143 = case ty of
1144 HsTyVar tv -> extract_tv tv acc
1145 HsBangTy _ ty -> extract_lty ty acc
1146 HsRecTy flds -> foldr (extract_lty . cd_fld_type . unLoc) acc
1147 flds
1148 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
1149 HsListTy ty -> extract_lty ty acc
1150 HsPArrTy ty -> extract_lty ty acc
1151 HsTupleTy _ tys -> extract_ltys tys acc
1152 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
1153 HsIParamTy _ ty -> extract_lty ty acc
1154 HsEqTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
1155 HsOpTy ty1 (_, (L _ tv)) ty2 -> extract_tv tv (extract_lty ty1 (extract_lty ty2 acc))
1156 HsParTy ty -> extract_lty ty acc
1157 HsCoreTy {} -> acc -- The type is closed
1158 HsSpliceTy {} -> acc -- Type splices mention no type variables
1159 HsDocTy ty _ -> extract_lty ty acc
1160 HsExplicitListTy _ tys -> extract_ltys tys acc
1161 HsExplicitTupleTy _ tys -> extract_ltys tys acc
1162 HsTyLit _ -> acc
1163 HsWrapTy _ _ -> panic "extract_lty"
1164 HsKindSig ty ki -> extract_lty ty (extract_lkind ki acc)
1165 HsForAllTy _ _ tvs cx ty -> extract_hs_tv_bndrs tvs acc $
1166 extract_lctxt cx $
1167 extract_lty ty ([],[])
1168 -- We deal with these separately in rnLHsTypeWithWildCards
1169 HsWildCardTy _ -> acc
1170
1171 extract_hs_tv_bndrs :: LHsTyVarBndrs RdrName -> FreeKiTyVars
1172 -> FreeKiTyVars -> FreeKiTyVars
1173 extract_hs_tv_bndrs (HsQTvs { hsq_tvs = tvs })
1174 (acc_kvs, acc_tvs) -- Note accumulator comes first
1175 (body_kvs, body_tvs)
1176 | null tvs
1177 = (body_kvs ++ acc_kvs, body_tvs ++ acc_tvs)
1178 | otherwise
1179 = (acc_kvs ++ filterOut (`elem` local_kvs) body_kvs,
1180 acc_tvs ++ filterOut (`elem` local_tvs) body_tvs)
1181 where
1182 local_tvs = map hsLTyVarName tvs
1183 (_, local_kvs) = foldr extract_lty ([], []) [k | L _ (KindedTyVar _ k) <- tvs]
1184 -- These kind variables are bound here if not bound further out
1185
1186 extract_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars
1187 extract_tv tv acc
1188 | isRdrTyVar tv = case acc of (kvs,tvs) -> (kvs, tv : tvs)
1189 | otherwise = acc