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