Minor refactor to use filterInScope
[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, collectWildCards,
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 ; rdr_env <- getLocalRdrEnv
493 ; let (kv_bndrs, tv_bndrs) = filterInScope rdr_env $
494 extractHsTyRdrTyVars ty
495 ; kv_names <- newLocalBndrsRn (map (L loc) kv_bndrs)
496 ; tv_names <- newLocalBndrsRn (map (L loc) tv_bndrs)
497 ; bindLocalNamesFV kv_names $
498 bindLocalNamesFV tv_names $
499 do { (ty', fvs1, wcs) <- rnLHsTypeWithWildCards doc ty
500 ; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty'
501 , hswb_kvs = kv_names
502 , hswb_tvs = tv_names
503 , hswb_wcs = wcs })
504 ; return (res, fvs1 `plusFV` fvs2) } }
505
506 overlappingKindVars :: HsDocContext -> [RdrName] -> SDoc
507 overlappingKindVars doc kvs
508 = vcat [ ptext (sLit "Kind variable") <> plural kvs <+>
509 ptext (sLit "also used as type variable") <> plural kvs
510 <> colon <+> pprQuotedList kvs
511 , docOfHsDocContext doc ]
512
513 badKindBndrs :: HsDocContext -> [RdrName] -> SDoc
514 badKindBndrs doc kvs
515 = vcat [ hang (ptext (sLit "Unexpected kind variable") <> plural kvs
516 <+> pprQuotedList kvs)
517 2 (ptext (sLit "Perhaps you intended to use PolyKinds"))
518 , docOfHsDocContext doc ]
519
520 badSigErr :: Bool -> HsDocContext -> LHsType RdrName -> TcM ()
521 badSigErr is_type doc (L loc ty)
522 = setSrcSpan loc $ addErr $
523 vcat [ hang (ptext (sLit "Illegal") <+> what
524 <+> ptext (sLit "signature:") <+> quotes (ppr ty))
525 2 (ptext (sLit "Perhaps you intended to use") <+> flag)
526 , docOfHsDocContext doc ]
527 where
528 what | is_type = ptext (sLit "type")
529 | otherwise = ptext (sLit "kind")
530 flag | is_type = ptext (sLit "ScopedTypeVariables")
531 | otherwise = ptext (sLit "KindSignatures")
532
533 dataKindsErr :: Bool -> HsType RdrName -> SDoc
534 dataKindsErr is_type thing
535 = hang (ptext (sLit "Illegal") <+> what <> colon <+> quotes (ppr thing))
536 2 (ptext (sLit "Perhaps you intended to use DataKinds"))
537 where
538 what | is_type = ptext (sLit "type")
539 | otherwise = ptext (sLit "kind")
540
541 --------------------------------
542 -- | Variant of @rnHsSigType@ that supports wild cards. Also returns the wild
543 -- cards to bind.
544 rnHsSigTypeWithWildCards :: SDoc -> LHsType RdrName
545 -> RnM (LHsType Name, FreeVars, [Name])
546 rnHsSigTypeWithWildCards doc_str ty
547 = rnLHsTypeWithWildCards (TypeSigCtx doc_str) ty'
548 where
549 ty' = extractExtraCtsWc `fmap` flattenTopLevelLHsForAllTy ty
550 -- When there is a wild card at the end of the context, remove it and add
551 -- its location as the extra-constraints wild card in the HsForAllTy.
552 extractExtraCtsWc (HsForAllTy flag _ bndrs (L l ctxt) ty)
553 | Just (ctxt', ct) <- snocView ctxt
554 , L lx (HsWildCardTy (AnonWildCard _)) <- ignoreParens ct
555 = HsForAllTy flag (Just lx) bndrs (L l ctxt') ty
556 extractExtraCtsWc ty = ty
557
558 -- | Variant of @rnLHsType@ that supports wild cards. The third element of the
559 -- tuple consists of the freshly generated names of the anonymous wild cards
560 -- occurring in the type, as well as the names of the named wild cards in the
561 -- type that are not yet in scope.
562 rnLHsTypeWithWildCards :: HsDocContext -> LHsType RdrName
563 -> RnM (LHsType Name, FreeVars, [Name])
564 rnLHsTypeWithWildCards doc ty
565 = do { checkValidPartialType doc ty
566 ; rdr_env <- getLocalRdrEnv
567 -- Filter out named wildcards that are already in scope
568 ; let (_, wcs) = collectWildCards ty
569 nwcs = [L loc n | L loc (NamedWildCard n) <- wcs
570 , not (elemLocalRdrEnv n rdr_env) ]
571 ; bindLocatedLocalsRn nwcs $ \nwcs' -> do {
572 (ty', fvs) <- rnLHsType doc ty
573 -- Add the anonymous wildcards that have been given names during
574 -- renaming
575 ; let (_, wcs') = collectWildCards ty'
576 awcs = filter (isAnonWildCard . unLoc) wcs'
577 ; return (ty', fvs, nwcs' ++ map (HsSyn.wildCardName . unLoc) awcs) } }
578
579 -- | Extract all wild cards from a type. The named and anonymous
580 -- extra-constraints wild cards are returned separately to be able to give
581 -- more accurate error messages.
582 collectWildCards
583 :: Eq name => LHsType name
584 -> ([Located (HsWildCardInfo name)], -- extra-constraints wild cards
585 [Located (HsWildCardInfo name)]) -- wild cards
586 collectWildCards lty = (extra, nubBy sameNamedWildCard wcs)
587 where
588 (extra, wcs) = go lty
589 go (L loc ty) = case ty of
590 HsAppTy ty1 ty2 -> go ty1 `mappend` go ty2
591 HsFunTy ty1 ty2 -> go ty1 `mappend` go ty2
592 HsListTy ty -> go ty
593 HsPArrTy ty -> go ty
594 HsTupleTy _ tys -> gos tys
595 HsOpTy ty1 _ ty2 -> go ty1 `mappend` go ty2
596 HsParTy ty -> go ty
597 HsIParamTy _ ty -> go ty
598 HsEqTy ty1 ty2 -> go ty1 `mappend` go ty2
599 HsKindSig ty kind -> go ty `mappend` go kind
600 HsDocTy ty _ -> go ty
601 HsBangTy _ ty -> go ty
602 HsRecTy flds -> gos $ map (cd_fld_type . unLoc) flds
603 HsExplicitListTy _ tys -> gos tys
604 HsExplicitTupleTy _ tys -> gos tys
605 HsWrapTy _ ty -> go (L loc ty)
606 -- Interesting cases
607 HsWildCardTy wc -> ([], [L loc wc])
608 HsForAllTy _ _ _ (L _ ctxt) ty -> ctxtWcs `mappend` go ty
609 where
610 ctxt' = map ignoreParens ctxt
611 extraWcs = [L l wc | L l (HsWildCardTy wc) <- ctxt']
612 (_, wcs) = gos ctxt'
613 -- Remove extra-constraints wild cards from wcs
614 ctxtWcs = (extraWcs, deleteFirstsBy sameWildCard
615 (nubBy sameWildCard wcs) extraWcs)
616 -- HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit
617 _ -> mempty
618 gos = mconcat . map go
619
620 -- | Check the validity of a partial type signature. The following things are
621 -- checked:
622 --
623 -- * Named extra-constraints wild cards aren't allowed,
624 -- e.g. invalid: @(Show a, _x) => a -> String@.
625 --
626 -- * There is only one extra-constraints wild card in the context and it must
627 -- come last, e.g. invalid: @(_, Show a) => a -> String@
628 -- or @(_, Show a, _) => a -> String@.
629 --
630 -- * There should be no unnamed wild cards in the context.
631 --
632 -- * An extra-constraints wild card can only occur in the top-level context.
633 -- This would be invalid: @(Eq a, _) => a -> (Num a, _) => a -> Bool@.
634 --
635 -- * Named wild cards occurring in the context must also occur in the monotype.
636 --
637 -- When an invalid wild card is found, we fail with an error.
638 checkValidPartialType :: HsDocContext -> LHsType RdrName -> RnM ()
639 checkValidPartialType doc lty
640 = do { whenNonEmpty isNamedWildCard inExtra $ \(L loc _) ->
641 failAt loc $ typeDoc $$
642 text "An extra-constraints wild card cannot be named" $$
643 docOfHsDocContext doc
644
645 ; whenNonEmpty isAnonWildCard extraTopLevel $ \(L loc _) ->
646 failAt loc $ typeDoc $$
647 -- If there was a valid extra-constraints wild card, it should have
648 -- already been removed and its location should be stored in the
649 -- HsForAllTy
650 (case extra of
651 Just _ ->
652 -- We're in a top-level context with an extracted
653 -- extra-constraints wild card.
654 text "Only a single extra-constraints wild card is allowed"
655 _ | TypeSigCtx _ <- doc ->
656 -- We're in a top-level context, but the extra-constraints wild
657 -- card didn't occur at the end.
658 fcat [ text "An extra-constraints wild card must occur"
659 , text "at the end of the constraints" ]
660 _ ->
661 -- We're not in a top-level context, so no extra-constraints
662 -- wild cards are supported.
663 fcat [ text "An extra-constraints wild card is only allowed"
664 , text "in the top-level context" ]) $$
665 docOfHsDocContext doc
666
667 ; whenNonEmpty isAnonWildCard inCtxt $ \(L loc _) ->
668 failAt loc $ typeDoc $$
669 text "Anonymous wild cards are not allowed in constraints" $$
670 docOfHsDocContext doc
671
672 ; whenNonEmpty isAnonWildCard nestedExtra $ \(L loc _) ->
673 failAt loc $ typeDoc $$
674 fcat [ text "An extra-constraints wild card is only allowed"
675 , text "in the top-level context" ] $$
676 docOfHsDocContext doc
677
678 ; whenNonEmpty isNamedWildCard inCtxtNotInTau $ \(L loc name) ->
679 failAt loc $ typeDoc $$
680 fcat [ text "The named wild card" <+> quotes (ppr name) <> space
681 , text "is only allowed in the constraints"
682 , text "when it also occurs in the rest of the type" ] $$
683 docOfHsDocContext doc }
684 where
685 typeDoc = hang (text "Invalid partial type:") 2 (ppr lty)
686 (extra, ctxt, tau) = splitPartialType lty
687 (inExtra, _) = collectWildCards lty
688 (nestedExtra, inTau) = collectWildCards tau
689 (_, inCtxt) = mconcat $ map collectWildCards ctxt
690 inCtxtNotInTau = deleteFirstsBy sameWildCard inCtxt inTau
691 extraTopLevel = deleteFirstsBy sameWildCard inExtra nestedExtra
692
693 splitPartialType (L _ (HsForAllTy _ extra _ (L _ ctxt) ty))
694 = (extra, map ignoreParens ctxt, ty)
695 splitPartialType ty = (Nothing, [], ty)
696
697 whenNonEmpty test wcs f
698 = whenIsJust (listToMaybe $ filter (test . unLoc) wcs) f
699
700
701 {-
702 *********************************************************
703 * *
704 \subsection{Contexts and predicates}
705 * *
706 *********************************************************
707 -}
708
709 rnConDeclFields :: HsDocContext -> [LConDeclField RdrName]
710 -> RnM ([LConDeclField Name], FreeVars)
711 rnConDeclFields doc fields = mapFvRn (rnField doc) fields
712
713 rnField :: HsDocContext -> LConDeclField RdrName
714 -> RnM (LConDeclField Name, FreeVars)
715 rnField doc (L l (ConDeclField names ty haddock_doc))
716 = do { new_names <- mapM lookupLocatedTopBndrRn names
717 ; (new_ty, fvs) <- rnLHsType doc ty
718 ; new_haddock_doc <- rnMbLHsDoc haddock_doc
719 ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
720
721 rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
722 rnContext doc (L loc cxt)
723 = do { (cxt', fvs) <- rnLHsTypes doc cxt
724 ; return (L loc cxt', fvs) }
725
726 {-
727 ************************************************************************
728 * *
729 Fixities and precedence parsing
730 * *
731 ************************************************************************
732
733 @mkOpAppRn@ deals with operator fixities. The argument expressions
734 are assumed to be already correctly arranged. It needs the fixities
735 recorded in the OpApp nodes, because fixity info applies to the things
736 the programmer actually wrote, so you can't find it out from the Name.
737
738 Furthermore, the second argument is guaranteed not to be another
739 operator application. Why? Because the parser parses all
740 operator appications left-associatively, EXCEPT negation, which
741 we need to handle specially.
742 Infix types are read in a *right-associative* way, so that
743 a `op` b `op` c
744 is always read in as
745 a `op` (b `op` c)
746
747 mkHsOpTyRn rearranges where necessary. The two arguments
748 have already been renamed and rearranged. It's made rather tiresome
749 by the presence of ->, which is a separate syntactic construct.
750 -}
751
752 ---------------
753 -- Building (ty1 `op1` (ty21 `op2` ty22))
754 mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
755 -> Name -> Fixity -> LHsType Name -> LHsType Name
756 -> RnM (HsType Name)
757
758 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 (w2, op2) ty22))
759 = do { fix2 <- lookupTyFixityRn op2
760 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
761 (\t1 t2 -> HsOpTy t1 (w2, op2) t2)
762 (unLoc op2) fix2 ty21 ty22 loc2 }
763
764 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
765 = mk_hs_op_ty mk1 pp_op1 fix1 ty1
766 HsFunTy funTyConName funTyFixity ty21 ty22 loc2
767
768 mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment
769 = return (mk1 ty1 ty2)
770
771 ---------------
772 mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
773 -> Name -> Fixity -> LHsType Name
774 -> (LHsType Name -> LHsType Name -> HsType Name)
775 -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
776 -> RnM (HsType Name)
777 mk_hs_op_ty mk1 op1 fix1 ty1
778 mk2 op2 fix2 ty21 ty22 loc2
779 | nofix_error = do { precParseErr (op1,fix1) (op2,fix2)
780 ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
781 | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
782 | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
783 new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
784 ; return (mk2 (noLoc new_ty) ty22) }
785 where
786 (nofix_error, associate_right) = compareFixity fix1 fix2
787
788
789 ---------------------------
790 mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged
791 -> LHsExpr Name -> Fixity -- Operator and fixity
792 -> LHsExpr Name -- Right operand (not an OpApp, but might
793 -- be a NegApp)
794 -> RnM (HsExpr Name)
795
796 -- (e11 `op1` e12) `op2` e2
797 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
798 | nofix_error
799 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
800 return (OpApp e1 op2 fix2 e2)
801
802 | associate_right = do
803 new_e <- mkOpAppRn e12 op2 fix2 e2
804 return (OpApp e11 op1 fix1 (L loc' new_e))
805 where
806 loc'= combineLocs e12 e2
807 (nofix_error, associate_right) = compareFixity fix1 fix2
808
809 ---------------------------
810 -- (- neg_arg) `op` e2
811 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
812 | nofix_error
813 = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
814 return (OpApp e1 op2 fix2 e2)
815
816 | associate_right
817 = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
818 return (NegApp (L loc' new_e) neg_name)
819 where
820 loc' = combineLocs neg_arg e2
821 (nofix_error, associate_right) = compareFixity negateFixity fix2
822
823 ---------------------------
824 -- e1 `op` - neg_arg
825 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right
826 | not associate_right -- We *want* right association
827 = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
828 return (OpApp e1 op1 fix1 e2)
829 where
830 (_, associate_right) = compareFixity fix1 negateFixity
831
832 ---------------------------
833 -- Default case
834 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
835 = ASSERT2( right_op_ok fix (unLoc e2),
836 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
837 )
838 return (OpApp e1 op fix e2)
839
840 ----------------------------
841 get_op :: LHsExpr Name -> Name
842 -- An unbound name could be either HsVar or HsUnboundVra
843 -- See RnExpr.rnUnboundVar
844 get_op (L _ (HsVar n)) = n
845 get_op (L _ (HsUnboundVar occ)) = mkUnboundName (mkRdrUnqual occ)
846 get_op other = pprPanic "get_op" (ppr other)
847
848 -- Parser left-associates everything, but
849 -- derived instances may have correctly-associated things to
850 -- in the right operarand. So we just check that the right operand is OK
851 right_op_ok :: Fixity -> HsExpr Name -> Bool
852 right_op_ok fix1 (OpApp _ _ fix2 _)
853 = not error_please && associate_right
854 where
855 (error_please, associate_right) = compareFixity fix1 fix2
856 right_op_ok _ _
857 = True
858
859 -- Parser initially makes negation bind more tightly than any other operator
860 -- And "deriving" code should respect this (use HsPar if not)
861 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
862 mkNegAppRn neg_arg neg_name
863 = ASSERT( not_op_app (unLoc neg_arg) )
864 return (NegApp neg_arg neg_name)
865
866 not_op_app :: HsExpr id -> Bool
867 not_op_app (OpApp _ _ _ _) = False
868 not_op_app _ = True
869
870 ---------------------------
871 mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged
872 -> LHsExpr Name -> Fixity -- Operator and fixity
873 -> LHsCmdTop Name -- Right operand (not an infix)
874 -> RnM (HsCmd Name)
875
876 -- (e11 `op1` e12) `op2` e2
877 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _))
878 op2 fix2 a2
879 | nofix_error
880 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
881 return (HsCmdArrForm op2 (Just fix2) [a1, a2])
882
883 | associate_right
884 = do new_c <- mkOpFormRn a12 op2 fix2 a2
885 return (HsCmdArrForm op1 (Just fix1)
886 [a11, L loc (HsCmdTop (L loc new_c)
887 placeHolderType placeHolderType [])])
888 -- TODO: locs are wrong
889 where
890 (nofix_error, associate_right) = compareFixity fix1 fix2
891
892 -- Default case
893 mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
894 = return (HsCmdArrForm op (Just fix) [arg1, arg2])
895
896
897 --------------------------------------
898 mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
899 -> RnM (Pat Name)
900
901 mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
902 = do { fix1 <- lookupFixityRn (unLoc op1)
903 ; let (nofix_error, associate_right) = compareFixity fix1 fix2
904
905 ; if nofix_error then do
906 { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
907 ; return (ConPatIn op2 (InfixCon p1 p2)) }
908
909 else if associate_right then do
910 { new_p <- mkConOpPatRn op2 fix2 p12 p2
911 ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
912 else return (ConPatIn op2 (InfixCon p1 p2)) }
913
914 mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment
915 = ASSERT( not_op_pat (unLoc p2) )
916 return (ConPatIn op (InfixCon p1 p2))
917
918 not_op_pat :: Pat Name -> Bool
919 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
920 not_op_pat _ = True
921
922 --------------------------------------
923 checkPrecMatch :: Name -> MatchGroup Name body -> RnM ()
924 -- Check precedence of a function binding written infix
925 -- eg a `op` b `C` c = ...
926 -- See comments with rnExpr (OpApp ...) about "deriving"
927
928 checkPrecMatch op (MG { mg_alts = ms })
929 = mapM_ check ms
930 where
931 check (L _ (Match _ (L l1 p1 : L l2 p2 :_) _ _))
932 = setSrcSpan (combineSrcSpans l1 l2) $
933 do checkPrec op p1 False
934 checkPrec op p2 True
935
936 check _ = return ()
937 -- This can happen. Consider
938 -- a `op` True = ...
939 -- op = ...
940 -- The infix flag comes from the first binding of the group
941 -- but the second eqn has no args (an error, but not discovered
942 -- until the type checker). So we don't want to crash on the
943 -- second eqn.
944
945 checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
946 checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
947 op_fix@(Fixity op_prec op_dir) <- lookupFixityRn op
948 op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
949 let
950 inf_ok = op1_prec > op_prec ||
951 (op1_prec == op_prec &&
952 (op1_dir == InfixR && op_dir == InfixR && right ||
953 op1_dir == InfixL && op_dir == InfixL && not right))
954
955 info = (op, op_fix)
956 info1 = (unLoc op1, op1_fix)
957 (infol, infor) = if right then (info, info1) else (info1, info)
958 unless inf_ok (precParseErr infol infor)
959
960 checkPrec _ _ _
961 = return ()
962
963 -- Check precedence of (arg op) or (op arg) respectively
964 -- If arg is itself an operator application, then either
965 -- (a) its precedence must be higher than that of op
966 -- (b) its precedency & associativity must be the same as that of op
967 checkSectionPrec :: FixityDirection -> HsExpr RdrName
968 -> LHsExpr Name -> LHsExpr Name -> RnM ()
969 checkSectionPrec direction section op arg
970 = case unLoc arg of
971 OpApp _ op fix _ -> go_for_it (get_op op) fix
972 NegApp _ _ -> go_for_it negateName negateFixity
973 _ -> return ()
974 where
975 op_name = get_op op
976 go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
977 op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
978 unless (op_prec < arg_prec
979 || (op_prec == arg_prec && direction == assoc))
980 (sectionPrecErr (op_name, op_fix)
981 (arg_op, arg_fix) section)
982
983 -- Precedence-related error messages
984
985 precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
986 precParseErr op1@(n1,_) op2@(n2,_)
987 | isUnboundName n1 || isUnboundName n2
988 = return () -- Avoid error cascade
989 | otherwise
990 = addErr $ hang (ptext (sLit "Precedence parsing error"))
991 4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"),
992 ppr_opfix op2,
993 ptext (sLit "in the same infix expression")])
994
995 sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
996 sectionPrecErr op@(n1,_) arg_op@(n2,_) section
997 | isUnboundName n1 || isUnboundName n2
998 = return () -- Avoid error cascade
999 | otherwise
1000 = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
1001 nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"),
1002 nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]),
1003 nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))]
1004
1005 ppr_opfix :: (Name, Fixity) -> SDoc
1006 ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
1007 where
1008 pp_op | op == negateName = ptext (sLit "prefix `-'")
1009 | otherwise = quotes (ppr op)
1010
1011 {-
1012 *********************************************************
1013 * *
1014 \subsection{Errors}
1015 * *
1016 *********************************************************
1017 -}
1018
1019 warnUnusedForAlls :: SDoc -> LHsTyVarBndrs RdrName -> [RdrName] -> TcM ()
1020 warnUnusedForAlls in_doc bound mentioned_rdrs
1021 = whenWOptM Opt_WarnUnusedMatches $
1022 mapM_ add_warn bound_but_not_used
1023 where
1024 bound_names = hsLTyVarLocNames bound
1025 bound_but_not_used = filterOut ((`elem` mentioned_rdrs) . unLoc) bound_names
1026
1027 add_warn (L loc tv)
1028 = addWarnAt loc $
1029 vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv)
1030 , in_doc ]
1031
1032 warnContextQuantification :: SDoc -> [LHsTyVarBndr RdrName] -> TcM ()
1033 warnContextQuantification in_doc tvs
1034 = whenWOptM Opt_WarnContextQuantification $
1035 mapM_ add_warn tvs
1036 where
1037 add_warn (L loc tv)
1038 = addWarnAt loc $
1039 vcat [ ptext (sLit "Variable") <+> quotes (ppr tv) <+>
1040 ptext (sLit "is implicitly quantified due to a context") $$
1041 ptext (sLit "Use explicit forall syntax instead.") $$
1042 ptext (sLit "This will become an error in GHC 7.12.")
1043 , in_doc ]
1044
1045 opTyErr :: RdrName -> HsType RdrName -> SDoc
1046 opTyErr op ty@(HsOpTy ty1 _ _)
1047 = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty))
1048 2 extra
1049 where
1050 extra | op == dot_tv_RDR && forall_head ty1
1051 = perhapsForallMsg
1052 | otherwise
1053 = ptext (sLit "Use TypeOperators to allow operators in types")
1054
1055 forall_head (L _ (HsTyVar tv)) = tv == forall_tv_RDR
1056 forall_head (L _ (HsAppTy ty _)) = forall_head ty
1057 forall_head _other = False
1058 opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty)
1059
1060 {-
1061 ************************************************************************
1062 * *
1063 Finding the free type variables of a (HsType RdrName)
1064 * *
1065 ************************************************************************
1066
1067
1068 Note [Kind and type-variable binders]
1069 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1070 In a type signature we may implicitly bind type variable and, more
1071 recently, kind variables. For example:
1072 * f :: a -> a
1073 f = ...
1074 Here we need to find the free type variables of (a -> a),
1075 so that we know what to quantify
1076
1077 * class C (a :: k) where ...
1078 This binds 'k' in ..., as well as 'a'
1079
1080 * f (x :: a -> [a]) = ....
1081 Here we bind 'a' in ....
1082
1083 * f (x :: T a -> T (b :: k)) = ...
1084 Here we bind both 'a' and the kind variable 'k'
1085
1086 * type instance F (T (a :: Maybe k)) = ...a...k...
1087 Here we want to constrain the kind of 'a', and bind 'k'.
1088
1089 In general we want to walk over a type, and find
1090 * Its free type variables
1091 * The free kind variables of any kind signatures in the type
1092
1093 Hence we returns a pair (kind-vars, type vars)
1094 See also Note [HsBSig binder lists] in HsTypes
1095 -}
1096
1097 type FreeKiTyVars = ([RdrName], [RdrName])
1098
1099 filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
1100 filterInScope rdr_env (kvs, tvs)
1101 = (filterOut in_scope kvs, filterOut in_scope tvs)
1102 where
1103 in_scope tv = tv `elemLocalRdrEnv` rdr_env
1104
1105 extractHsTyRdrTyVars :: LHsType RdrName -> FreeKiTyVars
1106 -- extractHsTyRdrNames finds the free (kind, type) variables of a HsType
1107 -- or the free (sort, kind) variables of a HsKind
1108 -- It's used when making the for-alls explicit.
1109 -- See Note [Kind and type-variable binders]
1110 extractHsTyRdrTyVars ty
1111 = case extract_lty ty ([],[]) of
1112 (kvs, tvs) -> (nub kvs, nub tvs)
1113
1114 extractHsTysRdrTyVars :: [LHsType RdrName] -> FreeKiTyVars
1115 -- See Note [Kind and type-variable binders]
1116 extractHsTysRdrTyVars ty
1117 = case extract_ltys ty ([],[]) of
1118 (kvs, tvs) -> (nub kvs, nub tvs)
1119
1120 extractRdrKindSigVars :: Maybe (LHsKind RdrName) -> [RdrName]
1121 extractRdrKindSigVars Nothing = []
1122 extractRdrKindSigVars (Just k) = nub (fst (extract_lkind k ([],[])))
1123
1124 extractDataDefnKindVars :: HsDataDefn RdrName -> [RdrName]
1125 -- Get the scoped kind variables mentioned free in the constructor decls
1126 -- Eg data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
1127 -- Here k should scope over the whole definition
1128 extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
1129 , dd_cons = cons, dd_derivs = derivs })
1130 = fst $ extract_lctxt ctxt $
1131 extract_mb extract_lkind ksig $
1132 extract_mb (extract_ltys . unLoc) derivs $
1133 foldr (extract_con . unLoc) ([],[]) cons
1134 where
1135 extract_con (ConDecl { con_res = ResTyGADT {} }) acc = acc
1136 extract_con (ConDecl { con_res = ResTyH98, con_qvars = qvs
1137 , con_cxt = ctxt, con_details = details }) acc
1138 = extract_hs_tv_bndrs qvs acc $
1139 extract_lctxt ctxt $
1140 extract_ltys (hsConDeclArgTys details) ([],[])
1141
1142
1143 extract_lctxt :: LHsContext RdrName -> FreeKiTyVars -> FreeKiTyVars
1144 extract_lctxt ctxt = extract_ltys (unLoc ctxt)
1145
1146 extract_ltys :: [LHsType RdrName] -> FreeKiTyVars -> FreeKiTyVars
1147 extract_ltys tys acc = foldr extract_lty acc tys
1148
1149 extract_mb :: (a -> FreeKiTyVars -> FreeKiTyVars) -> Maybe a -> FreeKiTyVars -> FreeKiTyVars
1150 extract_mb _ Nothing acc = acc
1151 extract_mb f (Just x) acc = f x acc
1152
1153 extract_lkind :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars
1154 extract_lkind kind (acc_kvs, acc_tvs) = case extract_lty kind ([], acc_kvs) of
1155 (_, res_kvs) -> (res_kvs, acc_tvs)
1156 -- Kinds shouldn't have sort signatures!
1157
1158 extract_lty :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars
1159 extract_lty (L _ ty) acc
1160 = case ty of
1161 HsTyVar tv -> extract_tv tv acc
1162 HsBangTy _ ty -> extract_lty ty acc
1163 HsRecTy flds -> foldr (extract_lty . cd_fld_type . unLoc) acc
1164 flds
1165 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
1166 HsListTy ty -> extract_lty ty acc
1167 HsPArrTy ty -> extract_lty ty acc
1168 HsTupleTy _ tys -> extract_ltys tys acc
1169 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
1170 HsIParamTy _ ty -> extract_lty ty acc
1171 HsEqTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
1172 HsOpTy ty1 (_, (L _ tv)) ty2 -> extract_tv tv (extract_lty ty1 (extract_lty ty2 acc))
1173 HsParTy ty -> extract_lty ty acc
1174 HsCoreTy {} -> acc -- The type is closed
1175 HsSpliceTy {} -> acc -- Type splices mention no type variables
1176 HsDocTy ty _ -> extract_lty ty acc
1177 HsExplicitListTy _ tys -> extract_ltys tys acc
1178 HsExplicitTupleTy _ tys -> extract_ltys tys acc
1179 HsTyLit _ -> acc
1180 HsWrapTy _ _ -> panic "extract_lty"
1181 HsKindSig ty ki -> extract_lty ty (extract_lkind ki acc)
1182 HsForAllTy _ _ tvs cx ty -> extract_hs_tv_bndrs tvs acc $
1183 extract_lctxt cx $
1184 extract_lty ty ([],[])
1185 -- We deal with these separately in rnLHsTypeWithWildCards
1186 HsWildCardTy _ -> acc
1187
1188 extract_hs_tv_bndrs :: LHsTyVarBndrs RdrName -> FreeKiTyVars
1189 -> FreeKiTyVars -> FreeKiTyVars
1190 extract_hs_tv_bndrs (HsQTvs { hsq_tvs = tvs })
1191 (acc_kvs, acc_tvs) -- Note accumulator comes first
1192 (body_kvs, body_tvs)
1193 | null tvs
1194 = (body_kvs ++ acc_kvs, body_tvs ++ acc_tvs)
1195 | otherwise
1196 = (acc_kvs ++ filterOut (`elem` local_kvs) body_kvs,
1197 acc_tvs ++ filterOut (`elem` local_tvs) body_tvs)
1198 where
1199 local_tvs = map hsLTyVarName tvs
1200 (_, local_kvs) = foldr extract_lty ([], []) [k | L _ (KindedTyVar _ k) <- tvs]
1201 -- These kind variables are bound here if not bound further out
1202
1203 extract_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars
1204 extract_tv tv acc
1205 | isRdrTyVar tv = case acc of (kvs,tvs) -> (kvs, tv : tvs)
1206 | otherwise = acc