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