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