Add typed holes support in Template Haskell.
[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,
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 import FieldLabel
44
45 import Util
46 import BasicTypes ( compareFixity, funTyFixity, negateFixity,
47 Fixity(..), FixityDirection(..) )
48 import Outputable
49 import FastString
50 import Maybes
51 import Data.List ( nub, nubBy, deleteFirstsBy )
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 ConDeclField
711 * *
712 *********************************************************
713
714 When renaming a ConDeclField, we have to find the FieldLabel
715 associated with each field. But we already have all the FieldLabels
716 available (since they were brought into scope by
717 RnNames.getLocalNonValBinders), so we just take the list as an
718 argument, build a map and look them up.
719 -}
720
721 rnConDeclFields :: [FieldLabel] -> HsDocContext -> [LConDeclField RdrName]
722 -> RnM ([LConDeclField Name], FreeVars)
723 rnConDeclFields fls doc fields = mapFvRn (rnField fl_env doc) fields
724 where
725 fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]
726
727 rnField :: FastStringEnv FieldLabel -> HsDocContext -> LConDeclField RdrName
728 -> RnM (LConDeclField Name, FreeVars)
729 rnField fl_env doc (L l (ConDeclField names ty haddock_doc))
730 = do { let new_names = map (fmap lookupField) names
731 ; (new_ty, fvs) <- rnLHsType doc ty
732 ; new_haddock_doc <- rnMbLHsDoc haddock_doc
733 ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
734 where
735 lookupField :: FieldOcc RdrName -> FieldOcc Name
736 lookupField (FieldOcc rdr _) = FieldOcc rdr (flSelector fl)
737 where
738 lbl = occNameFS $ rdrNameOcc rdr
739 fl = expectJust "rnField" $ lookupFsEnv fl_env lbl
740
741
742 {-
743 *********************************************************
744 * *
745 Contexts
746 * *
747 *********************************************************
748 -}
749
750 rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
751 rnContext doc (L loc cxt)
752 = do { (cxt', fvs) <- rnLHsTypes doc cxt
753 ; return (L loc cxt', fvs) }
754
755 {-
756 ************************************************************************
757 * *
758 Fixities and precedence parsing
759 * *
760 ************************************************************************
761
762 @mkOpAppRn@ deals with operator fixities. The argument expressions
763 are assumed to be already correctly arranged. It needs the fixities
764 recorded in the OpApp nodes, because fixity info applies to the things
765 the programmer actually wrote, so you can't find it out from the Name.
766
767 Furthermore, the second argument is guaranteed not to be another
768 operator application. Why? Because the parser parses all
769 operator appications left-associatively, EXCEPT negation, which
770 we need to handle specially.
771 Infix types are read in a *right-associative* way, so that
772 a `op` b `op` c
773 is always read in as
774 a `op` (b `op` c)
775
776 mkHsOpTyRn rearranges where necessary. The two arguments
777 have already been renamed and rearranged. It's made rather tiresome
778 by the presence of ->, which is a separate syntactic construct.
779 -}
780
781 ---------------
782 -- Building (ty1 `op1` (ty21 `op2` ty22))
783 mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
784 -> Name -> Fixity -> LHsType Name -> LHsType Name
785 -> RnM (HsType Name)
786
787 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 (w2, op2) ty22))
788 = do { fix2 <- lookupTyFixityRn op2
789 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
790 (\t1 t2 -> HsOpTy t1 (w2, op2) t2)
791 (unLoc op2) fix2 ty21 ty22 loc2 }
792
793 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
794 = mk_hs_op_ty mk1 pp_op1 fix1 ty1
795 HsFunTy funTyConName funTyFixity ty21 ty22 loc2
796
797 mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment
798 = return (mk1 ty1 ty2)
799
800 ---------------
801 mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
802 -> Name -> Fixity -> LHsType Name
803 -> (LHsType Name -> LHsType Name -> HsType Name)
804 -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
805 -> RnM (HsType Name)
806 mk_hs_op_ty mk1 op1 fix1 ty1
807 mk2 op2 fix2 ty21 ty22 loc2
808 | nofix_error = do { precParseErr (op1,fix1) (op2,fix2)
809 ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
810 | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
811 | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
812 new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
813 ; return (mk2 (noLoc new_ty) ty22) }
814 where
815 (nofix_error, associate_right) = compareFixity fix1 fix2
816
817
818 ---------------------------
819 mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged
820 -> LHsExpr Name -> Fixity -- Operator and fixity
821 -> LHsExpr Name -- Right operand (not an OpApp, but might
822 -- be a NegApp)
823 -> RnM (HsExpr Name)
824
825 -- (e11 `op1` e12) `op2` e2
826 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
827 | nofix_error
828 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
829 return (OpApp e1 op2 fix2 e2)
830
831 | associate_right = do
832 new_e <- mkOpAppRn e12 op2 fix2 e2
833 return (OpApp e11 op1 fix1 (L loc' new_e))
834 where
835 loc'= combineLocs e12 e2
836 (nofix_error, associate_right) = compareFixity fix1 fix2
837
838 ---------------------------
839 -- (- neg_arg) `op` e2
840 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
841 | nofix_error
842 = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
843 return (OpApp e1 op2 fix2 e2)
844
845 | associate_right
846 = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
847 return (NegApp (L loc' new_e) neg_name)
848 where
849 loc' = combineLocs neg_arg e2
850 (nofix_error, associate_right) = compareFixity negateFixity fix2
851
852 ---------------------------
853 -- e1 `op` - neg_arg
854 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right
855 | not associate_right -- We *want* right association
856 = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
857 return (OpApp e1 op1 fix1 e2)
858 where
859 (_, associate_right) = compareFixity fix1 negateFixity
860
861 ---------------------------
862 -- Default case
863 mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
864 = ASSERT2( right_op_ok fix (unLoc e2),
865 ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
866 )
867 return (OpApp e1 op fix e2)
868
869 ----------------------------
870 get_op :: LHsExpr Name -> Name
871 -- An unbound name could be either HsVar or HsUnboundVar
872 -- See RnExpr.rnUnboundVar
873 get_op (L _ (HsVar n)) = n
874 get_op (L _ (HsUnboundVar occ)) = mkUnboundName (mkRdrUnqual occ)
875 get_op other = pprPanic "get_op" (ppr other)
876
877 -- Parser left-associates everything, but
878 -- derived instances may have correctly-associated things to
879 -- in the right operarand. So we just check that the right operand is OK
880 right_op_ok :: Fixity -> HsExpr Name -> Bool
881 right_op_ok fix1 (OpApp _ _ fix2 _)
882 = not error_please && associate_right
883 where
884 (error_please, associate_right) = compareFixity fix1 fix2
885 right_op_ok _ _
886 = True
887
888 -- Parser initially makes negation bind more tightly than any other operator
889 -- And "deriving" code should respect this (use HsPar if not)
890 mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
891 mkNegAppRn neg_arg neg_name
892 = ASSERT( not_op_app (unLoc neg_arg) )
893 return (NegApp neg_arg neg_name)
894
895 not_op_app :: HsExpr id -> Bool
896 not_op_app (OpApp _ _ _ _) = False
897 not_op_app _ = True
898
899 ---------------------------
900 mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged
901 -> LHsExpr Name -> Fixity -- Operator and fixity
902 -> LHsCmdTop Name -- Right operand (not an infix)
903 -> RnM (HsCmd Name)
904
905 -- (e11 `op1` e12) `op2` e2
906 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _))
907 op2 fix2 a2
908 | nofix_error
909 = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
910 return (HsCmdArrForm op2 (Just fix2) [a1, a2])
911
912 | associate_right
913 = do new_c <- mkOpFormRn a12 op2 fix2 a2
914 return (HsCmdArrForm op1 (Just fix1)
915 [a11, L loc (HsCmdTop (L loc new_c)
916 placeHolderType placeHolderType [])])
917 -- TODO: locs are wrong
918 where
919 (nofix_error, associate_right) = compareFixity fix1 fix2
920
921 -- Default case
922 mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment
923 = return (HsCmdArrForm op (Just fix) [arg1, arg2])
924
925
926 --------------------------------------
927 mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
928 -> RnM (Pat Name)
929
930 mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
931 = do { fix1 <- lookupFixityRn (unLoc op1)
932 ; let (nofix_error, associate_right) = compareFixity fix1 fix2
933
934 ; if nofix_error then do
935 { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
936 ; return (ConPatIn op2 (InfixCon p1 p2)) }
937
938 else if associate_right then do
939 { new_p <- mkConOpPatRn op2 fix2 p12 p2
940 ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
941 else return (ConPatIn op2 (InfixCon p1 p2)) }
942
943 mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment
944 = ASSERT( not_op_pat (unLoc p2) )
945 return (ConPatIn op (InfixCon p1 p2))
946
947 not_op_pat :: Pat Name -> Bool
948 not_op_pat (ConPatIn _ (InfixCon _ _)) = False
949 not_op_pat _ = True
950
951 --------------------------------------
952 checkPrecMatch :: Name -> MatchGroup Name body -> RnM ()
953 -- Check precedence of a function binding written infix
954 -- eg a `op` b `C` c = ...
955 -- See comments with rnExpr (OpApp ...) about "deriving"
956
957 checkPrecMatch op (MG { mg_alts = ms })
958 = mapM_ check ms
959 where
960 check (L _ (Match _ (L l1 p1 : L l2 p2 :_) _ _))
961 = setSrcSpan (combineSrcSpans l1 l2) $
962 do checkPrec op p1 False
963 checkPrec op p2 True
964
965 check _ = return ()
966 -- This can happen. Consider
967 -- a `op` True = ...
968 -- op = ...
969 -- The infix flag comes from the first binding of the group
970 -- but the second eqn has no args (an error, but not discovered
971 -- until the type checker). So we don't want to crash on the
972 -- second eqn.
973
974 checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
975 checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
976 op_fix@(Fixity op_prec op_dir) <- lookupFixityRn op
977 op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
978 let
979 inf_ok = op1_prec > op_prec ||
980 (op1_prec == op_prec &&
981 (op1_dir == InfixR && op_dir == InfixR && right ||
982 op1_dir == InfixL && op_dir == InfixL && not right))
983
984 info = (op, op_fix)
985 info1 = (unLoc op1, op1_fix)
986 (infol, infor) = if right then (info, info1) else (info1, info)
987 unless inf_ok (precParseErr infol infor)
988
989 checkPrec _ _ _
990 = return ()
991
992 -- Check precedence of (arg op) or (op arg) respectively
993 -- If arg is itself an operator application, then either
994 -- (a) its precedence must be higher than that of op
995 -- (b) its precedency & associativity must be the same as that of op
996 checkSectionPrec :: FixityDirection -> HsExpr RdrName
997 -> LHsExpr Name -> LHsExpr Name -> RnM ()
998 checkSectionPrec direction section op arg
999 = case unLoc arg of
1000 OpApp _ op fix _ -> go_for_it (get_op op) fix
1001 NegApp _ _ -> go_for_it negateName negateFixity
1002 _ -> return ()
1003 where
1004 op_name = get_op op
1005 go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
1006 op_fix@(Fixity op_prec _) <- lookupFixityRn op_name
1007 unless (op_prec < arg_prec
1008 || (op_prec == arg_prec && direction == assoc))
1009 (sectionPrecErr (op_name, op_fix)
1010 (arg_op, arg_fix) section)
1011
1012 -- Precedence-related error messages
1013
1014 precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
1015 precParseErr op1@(n1,_) op2@(n2,_)
1016 | isUnboundName n1 || isUnboundName n2
1017 = return () -- Avoid error cascade
1018 | otherwise
1019 = addErr $ hang (ptext (sLit "Precedence parsing error"))
1020 4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"),
1021 ppr_opfix op2,
1022 ptext (sLit "in the same infix expression")])
1023
1024 sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
1025 sectionPrecErr op@(n1,_) arg_op@(n2,_) section
1026 | isUnboundName n1 || isUnboundName n2
1027 = return () -- Avoid error cascade
1028 | otherwise
1029 = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
1030 nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"),
1031 nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]),
1032 nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))]
1033
1034 ppr_opfix :: (Name, Fixity) -> SDoc
1035 ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
1036 where
1037 pp_op | op == negateName = ptext (sLit "prefix `-'")
1038 | otherwise = quotes (ppr op)
1039
1040 {-
1041 *********************************************************
1042 * *
1043 \subsection{Errors}
1044 * *
1045 *********************************************************
1046 -}
1047
1048 warnUnusedForAlls :: SDoc -> LHsTyVarBndrs RdrName -> [RdrName] -> TcM ()
1049 warnUnusedForAlls in_doc bound mentioned_rdrs
1050 = whenWOptM Opt_WarnUnusedMatches $
1051 mapM_ add_warn bound_but_not_used
1052 where
1053 bound_names = hsLTyVarLocNames bound
1054 bound_but_not_used = filterOut ((`elem` mentioned_rdrs) . unLoc) bound_names
1055
1056 add_warn (L loc tv)
1057 = addWarnAt loc $
1058 vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv)
1059 , in_doc ]
1060
1061 warnContextQuantification :: SDoc -> [LHsTyVarBndr RdrName] -> TcM ()
1062 warnContextQuantification in_doc tvs
1063 = whenWOptM Opt_WarnContextQuantification $
1064 mapM_ add_warn tvs
1065 where
1066 add_warn (L loc tv)
1067 = addWarnAt loc $
1068 vcat [ ptext (sLit "Variable") <+> quotes (ppr tv) <+>
1069 ptext (sLit "is implicitly quantified due to a context") $$
1070 ptext (sLit "Use explicit forall syntax instead.") $$
1071 ptext (sLit "This will become an error in GHC 7.12.")
1072 , in_doc ]
1073
1074 opTyErr :: RdrName -> HsType RdrName -> SDoc
1075 opTyErr op ty@(HsOpTy ty1 _ _)
1076 = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty))
1077 2 extra
1078 where
1079 extra | op == dot_tv_RDR && forall_head ty1
1080 = perhapsForallMsg
1081 | otherwise
1082 = ptext (sLit "Use TypeOperators to allow operators in types")
1083
1084 forall_head (L _ (HsTyVar tv)) = tv == forall_tv_RDR
1085 forall_head (L _ (HsAppTy ty _)) = forall_head ty
1086 forall_head _other = False
1087 opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty)
1088
1089 {-
1090 ************************************************************************
1091 * *
1092 Finding the free type variables of a (HsType RdrName)
1093 * *
1094 ************************************************************************
1095
1096
1097 Note [Kind and type-variable binders]
1098 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1099 In a type signature we may implicitly bind type variable and, more
1100 recently, kind variables. For example:
1101 * f :: a -> a
1102 f = ...
1103 Here we need to find the free type variables of (a -> a),
1104 so that we know what to quantify
1105
1106 * class C (a :: k) where ...
1107 This binds 'k' in ..., as well as 'a'
1108
1109 * f (x :: a -> [a]) = ....
1110 Here we bind 'a' in ....
1111
1112 * f (x :: T a -> T (b :: k)) = ...
1113 Here we bind both 'a' and the kind variable 'k'
1114
1115 * type instance F (T (a :: Maybe k)) = ...a...k...
1116 Here we want to constrain the kind of 'a', and bind 'k'.
1117
1118 In general we want to walk over a type, and find
1119 * Its free type variables
1120 * The free kind variables of any kind signatures in the type
1121
1122 Hence we returns a pair (kind-vars, type vars)
1123 See also Note [HsBSig binder lists] in HsTypes
1124 -}
1125
1126 type FreeKiTyVars = ([RdrName], [RdrName])
1127
1128 filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
1129 filterInScope rdr_env (kvs, tvs)
1130 = (filterOut in_scope kvs, filterOut in_scope tvs)
1131 where
1132 in_scope tv = tv `elemLocalRdrEnv` rdr_env
1133
1134 extractHsTyRdrTyVars :: LHsType RdrName -> FreeKiTyVars
1135 -- extractHsTyRdrNames finds the free (kind, type) variables of a HsType
1136 -- or the free (sort, kind) variables of a HsKind
1137 -- It's used when making the for-alls explicit.
1138 -- See Note [Kind and type-variable binders]
1139 extractHsTyRdrTyVars ty
1140 = case extract_lty ty ([],[]) of
1141 (kvs, tvs) -> (nub kvs, nub tvs)
1142
1143 extractHsTysRdrTyVars :: [LHsType RdrName] -> FreeKiTyVars
1144 -- See Note [Kind and type-variable binders]
1145 extractHsTysRdrTyVars ty
1146 = case extract_ltys ty ([],[]) of
1147 (kvs, tvs) -> (nub kvs, nub tvs)
1148
1149 extractRdrKindSigVars :: LFamilyResultSig RdrName -> [RdrName]
1150 extractRdrKindSigVars (L _ resultSig)
1151 | KindSig k <- resultSig = kindRdrNameFromSig k
1152 | TyVarSig (L _ (KindedTyVar _ k)) <- resultSig = kindRdrNameFromSig k
1153 | TyVarSig (L _ (UserTyVar _)) <- resultSig = []
1154 | otherwise = [] -- this can only be NoSig but pattern exhasutiveness
1155 -- checker complains about "NoSig <- resultSig"
1156 where kindRdrNameFromSig k = nub (fst (extract_lkind k ([],[])))
1157
1158 extractDataDefnKindVars :: HsDataDefn RdrName -> [RdrName]
1159 -- Get the scoped kind variables mentioned free in the constructor decls
1160 -- Eg data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
1161 -- Here k should scope over the whole definition
1162 extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig
1163 , dd_cons = cons, dd_derivs = derivs })
1164 = fst $ extract_lctxt ctxt $
1165 extract_mb extract_lkind ksig $
1166 extract_mb (extract_ltys . unLoc) derivs $
1167 foldr (extract_con . unLoc) ([],[]) cons
1168 where
1169 extract_con (ConDecl { con_res = ResTyGADT {} }) acc = acc
1170 extract_con (ConDecl { con_res = ResTyH98, con_qvars = qvs
1171 , con_cxt = ctxt, con_details = details }) acc
1172 = extract_hs_tv_bndrs qvs acc $
1173 extract_lctxt ctxt $
1174 extract_ltys (hsConDeclArgTys details) ([],[])
1175
1176
1177 extract_lctxt :: LHsContext RdrName -> FreeKiTyVars -> FreeKiTyVars
1178 extract_lctxt ctxt = extract_ltys (unLoc ctxt)
1179
1180 extract_ltys :: [LHsType RdrName] -> FreeKiTyVars -> FreeKiTyVars
1181 extract_ltys tys acc = foldr extract_lty acc tys
1182
1183 extract_mb :: (a -> FreeKiTyVars -> FreeKiTyVars) -> Maybe a -> FreeKiTyVars -> FreeKiTyVars
1184 extract_mb _ Nothing acc = acc
1185 extract_mb f (Just x) acc = f x acc
1186
1187 extract_lkind :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars
1188 extract_lkind kind (acc_kvs, acc_tvs) = case extract_lty kind ([], acc_kvs) of
1189 (_, res_kvs) -> (res_kvs, acc_tvs)
1190 -- Kinds shouldn't have sort signatures!
1191
1192 extract_lty :: LHsType RdrName -> FreeKiTyVars -> FreeKiTyVars
1193 extract_lty (L _ ty) acc
1194 = case ty of
1195 HsTyVar tv -> extract_tv tv acc
1196 HsBangTy _ ty -> extract_lty ty acc
1197 HsRecTy flds -> foldr (extract_lty . cd_fld_type . unLoc) acc
1198 flds
1199 HsAppTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
1200 HsListTy ty -> extract_lty ty acc
1201 HsPArrTy ty -> extract_lty ty acc
1202 HsTupleTy _ tys -> extract_ltys tys acc
1203 HsFunTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
1204 HsIParamTy _ ty -> extract_lty ty acc
1205 HsEqTy ty1 ty2 -> extract_lty ty1 (extract_lty ty2 acc)
1206 HsOpTy ty1 (_, (L _ tv)) ty2 -> extract_tv tv (extract_lty ty1 (extract_lty ty2 acc))
1207 HsParTy ty -> extract_lty ty acc
1208 HsCoreTy {} -> acc -- The type is closed
1209 HsSpliceTy {} -> acc -- Type splices mention no type variables
1210 HsDocTy ty _ -> extract_lty ty acc
1211 HsExplicitListTy _ tys -> extract_ltys tys acc
1212 HsExplicitTupleTy _ tys -> extract_ltys tys acc
1213 HsTyLit _ -> acc
1214 HsWrapTy _ _ -> panic "extract_lty"
1215 HsKindSig ty ki -> extract_lty ty (extract_lkind ki acc)
1216 HsForAllTy _ _ tvs cx ty -> extract_hs_tv_bndrs tvs acc $
1217 extract_lctxt cx $
1218 extract_lty ty ([],[])
1219 -- We deal with these separately in rnLHsTypeWithWildCards
1220 HsWildCardTy _ -> acc
1221
1222 extract_hs_tv_bndrs :: LHsTyVarBndrs RdrName -> FreeKiTyVars
1223 -> FreeKiTyVars -> FreeKiTyVars
1224 extract_hs_tv_bndrs (HsQTvs { hsq_tvs = tvs })
1225 (acc_kvs, acc_tvs) -- Note accumulator comes first
1226 (body_kvs, body_tvs)
1227 | null tvs
1228 = (body_kvs ++ acc_kvs, body_tvs ++ acc_tvs)
1229 | otherwise
1230 = (acc_kvs ++ filterOut (`elem` local_kvs) body_kvs,
1231 acc_tvs ++ filterOut (`elem` local_tvs) body_tvs)
1232 where
1233 local_tvs = map hsLTyVarName tvs
1234 (_, local_kvs) = foldr extract_lty ([], []) [k | L _ (KindedTyVar _ k) <- tvs]
1235 -- These kind variables are bound here if not bound further out
1236
1237 extract_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars
1238 extract_tv tv acc
1239 | isRdrTyVar tv = case acc of (kvs,tvs) -> (kvs, tv : tvs)
1240 | otherwise = acc