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