2 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[RnSource]{Main pass of renamer}
11 rnHsType
, rnLHsType
, rnLHsTypes
, rnContext
,
12 rnHsKind
, rnLHsKind
, rnLHsMaybeKind
,
13 rnHsSigType
, rnLHsInstType
, rnConDeclFields
,
16 -- Precence related stuff
17 mkOpAppRn
, mkNegAppRn
, mkOpFormRn
, mkConOpPatRn
,
18 checkPrecMatch
, checkSectionPrec
,
20 -- Binding related stuff
21 warnContextQuantification
, warnUnusedForAlls
,
22 bindSigTyVarsFV
, bindHsTyVars
, rnHsBndrSig
,
23 extractHsTyRdrTyVars
, extractHsTysRdrTyVars
,
24 extractRdrKindSigVars
, extractDataDefnKindVars
,
25 extractWildcards
, filterInScope
28 import {-# SOURCE #-} RnSplice
( rnSpliceType
)
32 import RnHsDoc
( rnLHsDoc
, rnMbLHsDoc
)
37 import TysPrim
( funTyConName
)
43 import BasicTypes
( compareFixity
, funTyFixity
, negateFixity
,
44 Fixity
(..), FixityDirection
(..) )
48 import Data
.List
( nub, nubBy )
49 import Control
.Monad
( unless, when )
51 #include
"HsVersions.h"
54 These type renamers are in a separate module, rather than in (say) RnSource,
55 to break several loop.
57 *********************************************************
59 \subsection{Renaming types}
61 *********************************************************
64 rnHsSigType
:: SDoc
-> LHsType RdrName
-> RnM
(LHsType Name
, FreeVars
)
65 -- rnHsSigType is used for source-language type signatures,
66 -- which use *implicit* universal quantification.
67 rnHsSigType doc_str ty
= rnLHsType
(TypeSigCtx doc_str
) ty
69 rnLHsInstType
:: SDoc
-> LHsType RdrName
-> RnM
(LHsType Name
, FreeVars
)
70 -- Rename the type in an instance or standalone deriving decl
71 rnLHsInstType doc_str ty
72 = do { (ty
', fvs
) <- rnLHsType
(GenericCtx doc_str
) ty
73 ; unless good_inst_ty
(addErrAt
(getLoc ty
) (badInstTy ty
))
77 | Just
(_
, _
, L _ cls
, _
) <- splitLHsInstDeclTy_maybe ty
78 , isTcOcc
(rdrNameOcc cls
) = True
81 badInstTy
:: LHsType RdrName
-> SDoc
82 badInstTy ty
= ptext
(sLit
"Malformed instance:") <+> ppr ty
85 rnHsType is here because we call it from loadInstDecl, and I didn't
86 want a gratuitous knot.
88 Note [Context quantification]
89 -----------------------------
90 Variables in type signatures are implicitly quantified
91 when (1) they are in a type signature not beginning
92 with "forall" or (2) in any qualified type T => R.
93 We are phasing out (2) since it leads to inconsistencies
96 data A = A (a -> a) is an error
97 data A = A (Eq a => a -> a) binds "a"
98 data A = A (Eq a => a -> b) binds "a" and "b"
99 data A = A (() => a -> b) binds "a" and "b"
100 f :: forall a. a -> b is an error
101 f :: forall a. () => a -> b is an error
102 f :: forall a. a -> (() => b) binds "a" and "b"
104 The -fwarn-context-quantification flag warns about
105 this situation. See rnHsTyKi for case HsForAllTy Qualified.
108 rnLHsTyKi
:: Bool -- True <=> renaming a type, False <=> a kind
109 -> HsDocContext
-> LHsType RdrName
-> RnM
(LHsType Name
, FreeVars
)
110 rnLHsTyKi isType doc
(L loc ty
)
112 do { (ty
', fvs
) <- rnHsTyKi isType doc ty
113 ; return (L loc ty
', fvs
) }
115 rnLHsType
:: HsDocContext
-> LHsType RdrName
-> RnM
(LHsType Name
, FreeVars
)
116 rnLHsType
= rnLHsTyKi
True
118 rnLHsKind
:: HsDocContext
-> LHsKind RdrName
-> RnM
(LHsKind Name
, FreeVars
)
119 rnLHsKind
= rnLHsTyKi
False
121 rnLHsMaybeKind
:: HsDocContext
-> Maybe (LHsKind RdrName
)
122 -> RnM
(Maybe (LHsKind Name
), FreeVars
)
123 rnLHsMaybeKind _ Nothing
124 = return (Nothing
, emptyFVs
)
125 rnLHsMaybeKind doc
(Just kind
)
126 = do { (kind
', fvs
) <- rnLHsKind doc kind
127 ; return (Just kind
', fvs
) }
129 rnHsType
:: HsDocContext
-> HsType RdrName
-> RnM
(HsType Name
, FreeVars
)
130 rnHsType
= rnHsTyKi
True
131 rnHsKind
:: HsDocContext
-> HsKind RdrName
-> RnM
(HsKind Name
, FreeVars
)
132 rnHsKind
= rnHsTyKi
False
134 rnHsTyKi
:: Bool -> HsDocContext
-> HsType RdrName
-> RnM
(HsType Name
, FreeVars
)
136 rnHsTyKi isType doc
(HsForAllTy Implicit extra _ lctxt
@(L _ ctxt
) ty
)
137 = ASSERT
( isType
) do
138 -- Implicit quantifiction in source code (no kinds on tyvars)
139 -- Given the signature C => T we universally quantify
140 -- over FV(T) \ {in-scope-tyvars}
141 rdr_env
<- getLocalRdrEnv
144 (forall_kvs
, forall_tvs
) = filterInScope rdr_env
$
145 extractHsTysRdrTyVars
(ty
:ctxt
)
146 -- In for-all types we don't bring in scope
147 -- kind variables mentioned in kind signatures
148 -- (Well, not yet anyway....)
149 -- f :: Int -> T (a::k) -- Not allowed
151 -- The filterInScope is to ensure that we don't quantify over
152 -- type variables that are in scope; when GlasgowExts is off,
153 -- there usually won't be any, except for class signatures:
154 -- class C a where { op :: a -> a }
155 tyvar_bndrs
= userHsTyVarBndrs loc forall_tvs
157 rnForAll doc Implicit extra forall_kvs
(mkHsQTvs tyvar_bndrs
) lctxt ty
159 rnHsTyKi isType doc fulltype
@(HsForAllTy Qualified extra _ lctxt
@(L _ ctxt
) ty
)
160 = ASSERT
( isType
) do
161 rdr_env
<- getLocalRdrEnv
164 (forall_kvs
, forall_tvs
) = filterInScope rdr_env
$
165 extractHsTysRdrTyVars
(ty
:ctxt
)
166 tyvar_bndrs
= userHsTyVarBndrs loc forall_tvs
167 in_type_doc
= ptext
(sLit
"In the type") <+> quotes
(ppr fulltype
)
169 -- See Note [Context quantification]
170 warnContextQuantification
(in_type_doc
$$ docOfHsDocContext doc
) tyvar_bndrs
171 rnForAll doc Implicit extra forall_kvs
(mkHsQTvs tyvar_bndrs
) lctxt ty
173 rnHsTyKi isType doc ty
@(HsForAllTy Explicit extra forall_tyvars lctxt
@(L _ ctxt
) tau
)
174 = ASSERT
( isType
) do { -- Explicit quantification.
175 -- Check that the forall'd tyvars are actually
176 -- mentioned in the type, and produce a warning if not
177 let (kvs
, mentioned
) = extractHsTysRdrTyVars
(tau
:ctxt
)
178 in_type_doc
= ptext
(sLit
"In the type") <+> quotes
(ppr ty
)
179 ; warnUnusedForAlls
(in_type_doc
$$ docOfHsDocContext doc
) forall_tyvars mentioned
181 ; rnForAll doc Explicit extra kvs forall_tyvars lctxt tau
}
183 rnHsTyKi isType _
(HsTyVar rdr_name
)
184 = do { name
<- rnTyVar isType rdr_name
185 ; return (HsTyVar name
, unitFV name
) }
187 -- If we see (forall a . ty), without foralls on, the forall will give
188 -- a sensible error message, but we don't want to complain about the dot too
189 -- Hence the jiggery pokery with ty1
190 rnHsTyKi isType doc ty
@(HsOpTy ty1
(wrapper
, L loc op
) ty2
)
191 = ASSERT
( isType
) setSrcSpan loc
$
192 do { ops_ok
<- xoptM Opt_TypeOperators
194 then rnTyVar isType op
195 else do { addErr
(opTyErr op ty
)
196 ; return (mkUnboundName op
) } -- Avoid double complaint
197 ; let l_op
' = L loc op
'
198 ; fix
<- lookupTyFixityRn l_op
'
199 ; (ty1
', fvs1
) <- rnLHsType doc ty1
200 ; (ty2
', fvs2
) <- rnLHsType doc ty2
201 ; res_ty
<- mkHsOpTyRn
(\t1 t2
-> HsOpTy t1
(wrapper
, l_op
') t2
)
203 ; return (res_ty
, (fvs1 `plusFV` fvs2
) `addOneFV` op
') }
205 rnHsTyKi isType doc
(HsParTy ty
)
206 = do { (ty
', fvs
) <- rnLHsTyKi isType doc ty
207 ; return (HsParTy ty
', fvs
) }
209 rnHsTyKi isType doc
(HsBangTy b ty
)
211 do { (ty
', fvs
) <- rnLHsType doc ty
212 ; return (HsBangTy b ty
', fvs
) }
214 rnHsTyKi _ doc ty
@(HsRecTy flds
)
215 = do { addErr
(hang
(ptext
(sLit
"Record syntax is illegal here:"))
217 ; (flds
', fvs
) <- rnConDeclFields doc flds
218 ; return (HsRecTy flds
', fvs
) }
220 rnHsTyKi isType doc
(HsFunTy ty1 ty2
)
221 = do { (ty1
', fvs1
) <- rnLHsTyKi isType doc ty1
222 -- Might find a for-all as the arg of a function type
223 ; (ty2
', fvs2
) <- rnLHsTyKi isType doc ty2
224 -- Or as the result. This happens when reading Prelude.hi
225 -- when we find return :: forall m. Monad m -> forall a. a -> m a
227 -- Check for fixity rearrangements
228 ; res_ty
<- if isType
229 then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1
' ty2
'
230 else return (HsFunTy ty1
' ty2
')
231 ; return (res_ty
, fvs1 `plusFV` fvs2
) }
233 rnHsTyKi isType doc listTy
@(HsListTy ty
)
234 = do { data_kinds
<- xoptM Opt_DataKinds
235 ; unless (data_kinds || isType
) (addErr
(dataKindsErr isType listTy
))
236 ; (ty
', fvs
) <- rnLHsTyKi isType doc ty
237 ; return (HsListTy ty
', fvs
) }
239 rnHsTyKi isType doc
(HsKindSig ty k
)
241 do { kind_sigs_ok
<- xoptM Opt_KindSignatures
242 ; unless kind_sigs_ok
(badSigErr
False doc ty
)
243 ; (ty
', fvs1
) <- rnLHsType doc ty
244 ; (k
', fvs2
) <- rnLHsKind doc k
245 ; return (HsKindSig ty
' k
', fvs1 `plusFV` fvs2
) }
247 rnHsTyKi isType doc
(HsPArrTy ty
)
249 do { (ty
', fvs
) <- rnLHsType doc ty
250 ; return (HsPArrTy ty
', fvs
) }
252 -- Unboxed tuples are allowed to have poly-typed arguments. These
253 -- sometimes crop up as a result of CPR worker-wrappering dictionaries.
254 rnHsTyKi isType doc tupleTy
@(HsTupleTy tup_con tys
)
255 = do { data_kinds
<- xoptM Opt_DataKinds
256 ; unless (data_kinds || isType
) (addErr
(dataKindsErr isType tupleTy
))
257 ; (tys
', fvs
) <- mapFvRn
(rnLHsTyKi isType doc
) tys
258 ; return (HsTupleTy tup_con tys
', fvs
) }
260 -- Ensure that a type-level integer is nonnegative (#8306, #8412)
261 rnHsTyKi isType _ tyLit
@(HsTyLit t
)
262 = do { data_kinds
<- xoptM Opt_DataKinds
263 ; unless data_kinds
(addErr
(dataKindsErr isType tyLit
))
264 ; when (negLit t
) (addErr negLitErr
)
265 ; return (HsTyLit t
, emptyFVs
) }
267 negLit
(HsStrTy _ _
) = False
268 negLit
(HsNumTy _ i
) = i
< 0
269 negLitErr
= ptext
(sLit
"Illegal literal in type (type literals must not be negative):") <+> ppr tyLit
271 rnHsTyKi isType doc
(HsAppTy ty1 ty2
)
272 = do { (ty1
', fvs1
) <- rnLHsTyKi isType doc ty1
273 ; (ty2
', fvs2
) <- rnLHsTyKi isType doc ty2
274 ; return (HsAppTy ty1
' ty2
', fvs1 `plusFV` fvs2
) }
276 rnHsTyKi isType doc
(HsIParamTy n ty
)
278 do { (ty
', fvs
) <- rnLHsType doc ty
279 ; return (HsIParamTy n ty
', fvs
) }
281 rnHsTyKi isType doc
(HsEqTy ty1 ty2
)
283 do { (ty1
', fvs1
) <- rnLHsType doc ty1
284 ; (ty2
', fvs2
) <- rnLHsType doc ty2
285 ; return (HsEqTy ty1
' ty2
', fvs1 `plusFV` fvs2
) }
287 rnHsTyKi isType _
(HsSpliceTy sp k
)
291 rnHsTyKi isType doc
(HsDocTy ty haddock_doc
)
293 do { (ty
', fvs
) <- rnLHsType doc ty
294 ; haddock_doc
' <- rnLHsDoc haddock_doc
295 ; return (HsDocTy ty
' haddock_doc
', fvs
) }
297 rnHsTyKi isType _
(HsCoreTy ty
)
299 return (HsCoreTy ty
, emptyFVs
)
300 -- The emptyFVs probably isn't quite right
301 -- but I don't think it matters
303 rnHsTyKi _ _
(HsWrapTy
{})
306 rnHsTyKi isType doc ty
@(HsExplicitListTy k tys
)
308 do { data_kinds
<- xoptM Opt_DataKinds
309 ; unless data_kinds
(addErr
(dataKindsErr isType ty
))
310 ; (tys
', fvs
) <- rnLHsTypes doc tys
311 ; return (HsExplicitListTy k tys
', fvs
) }
313 rnHsTyKi isType doc ty
@(HsExplicitTupleTy kis tys
)
315 do { data_kinds
<- xoptM Opt_DataKinds
316 ; unless data_kinds
(addErr
(dataKindsErr isType ty
))
317 ; (tys
', fvs
) <- rnLHsTypes doc tys
318 ; return (HsExplicitTupleTy kis tys
', fvs
) }
320 rnHsTyKi _ _ HsWildcardTy
= panic
"rnHsTyKi HsWildcardTy"
321 -- Should be replaced by a HsNamedWildcardTy
323 rnHsTyKi isType _doc
(HsNamedWildcardTy rdr_name
)
325 do { name
<- rnTyVar isType rdr_name
326 ; return (HsNamedWildcardTy name
, unitFV name
) }
329 rnTyVar
:: Bool -> RdrName
-> RnM Name
330 rnTyVar is_type rdr_name
331 | is_type
= lookupTypeOccRn rdr_name
332 |
otherwise = lookupKindOccRn rdr_name
336 rnLHsTypes
:: HsDocContext
-> [LHsType RdrName
]
337 -> RnM
([LHsType Name
], FreeVars
)
338 rnLHsTypes doc tys
= mapFvRn
(rnLHsType doc
) tys
340 rnForAll
:: HsDocContext
-> HsExplicitFlag
341 -> Maybe SrcSpan
-- Location of an extra-constraints wildcard
342 -> [RdrName
] -- Kind variables
343 -> LHsTyVarBndrs RdrName
-- Type variables
344 -> LHsContext RdrName
-> LHsType RdrName
345 -> RnM
(HsType Name
, FreeVars
)
347 rnForAll doc
exp extra kvs forall_tyvars ctxt ty
348 |
null kvs
, null (hsQTvBndrs forall_tyvars
), null (unLoc ctxt
), isNothing extra
349 = rnHsType doc
(unLoc ty
)
350 -- One reason for this case is that a type like Int#
351 -- starts off as (HsForAllTy Implicit Nothing [] Int), in case
352 -- there is some quantification. Now that we have quantified
353 -- and discovered there are no type variables, it's nicer to turn
354 -- it into plain Int. If it were Int# instead of Int, we'd actually
355 -- get an error, because the body of a genuine for-all is
359 = bindHsTyVars doc Nothing kvs forall_tyvars
$ \ new_tyvars
->
360 do { (new_ctxt
, fvs1
) <- rnContext doc ctxt
361 ; (new_ty
, fvs2
) <- rnLHsType doc ty
362 ; return (HsForAllTy
exp extra new_tyvars new_ctxt new_ty
, fvs1 `plusFV` fvs2
) }
363 -- Retain the same implicit/explicit flag as before
364 -- so that we can later print it correctly
367 bindSigTyVarsFV
:: [Name
]
370 -- Used just before renaming the defn of a function
371 -- with a separate type signature, to bring its tyvars into scope
372 -- With no -XScopedTypeVariables, this is a no-op
373 bindSigTyVarsFV tvs thing_inside
374 = do { scoped_tyvars
<- xoptM Opt_ScopedTypeVariables
375 ; if not scoped_tyvars
then
378 bindLocalNamesFV tvs thing_inside
}
381 bindHsTyVars
:: HsDocContext
382 -> Maybe a
-- Just _ => an associated type decl
383 -> [RdrName
] -- Kind variables from scope
384 -> LHsTyVarBndrs RdrName
-- Type variables
385 -> (LHsTyVarBndrs Name
-> RnM
(b
, FreeVars
))
387 -- (a) Bring kind variables into scope
388 -- both (i) passed in (kv_bndrs)
389 -- and (ii) mentioned in the kinds of tv_bndrs
390 -- (b) Bring type variables into scope
391 bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
392 = do { rdr_env
<- getLocalRdrEnv
393 ; let tvs
= hsQTvBndrs tv_bndrs
394 kvs_from_tv_bndrs
= [ kv | L _
(KindedTyVar _ kind
) <- tvs
395 , let (_
, kvs
) = extractHsTyRdrTyVars kind
397 all_kvs
' = nub (kv_bndrs
++ kvs_from_tv_bndrs
)
398 all_kvs
= filterOut
(`elemLocalRdrEnv` rdr_env
) all_kvs
'
400 overlap_kvs
= [ kv | kv
<- all_kvs
, any ((==) kv
. hsLTyVarName
) tvs
]
401 -- These variables appear both as kind and type variables
402 -- in the same declaration; eg type family T (x :: *) (y :: x)
403 -- We disallow this: too confusing!
405 ; poly_kind
<- xoptM Opt_PolyKinds
406 ; unless (poly_kind ||
null all_kvs
)
407 (addErr
(badKindBndrs doc all_kvs
))
408 ; unless (null overlap_kvs
)
409 (addErr
(overlappingKindVars doc overlap_kvs
))
412 ; kv_names
<- mapM (newLocalBndrRn
. L loc
) all_kvs
413 ; bindLocalNamesFV kv_names
$
414 do { let tv_names_w_loc
= hsLTyVarLocNames tv_bndrs
416 rn_tv_bndr
:: LHsTyVarBndr RdrName
-> RnM
(LHsTyVarBndr Name
, FreeVars
)
417 rn_tv_bndr
(L loc
(UserTyVar rdr
))
418 = do { nm
<- newTyVarNameRn mb_assoc rdr_env loc rdr
419 ; return (L loc
(UserTyVar nm
), emptyFVs
) }
420 rn_tv_bndr
(L loc
(KindedTyVar
(L lv rdr
) kind
))
421 = do { sig_ok
<- xoptM Opt_KindSignatures
422 ; unless sig_ok
(badSigErr
False doc kind
)
423 ; nm
<- newTyVarNameRn mb_assoc rdr_env loc rdr
424 ; (kind
', fvs
) <- rnLHsKind doc kind
425 ; return (L loc
(KindedTyVar
(L lv nm
) kind
'), fvs
) }
427 -- Check for duplicate or shadowed tyvar bindrs
428 ; checkDupRdrNames tv_names_w_loc
429 ; when (isNothing mb_assoc
) (checkShadowedRdrNames tv_names_w_loc
)
431 ; (tv_bndrs
', fvs1
) <- mapFvRn rn_tv_bndr tvs
432 ; (res
, fvs2
) <- bindLocalNamesFV
(map hsLTyVarName tv_bndrs
') $
433 do { inner_rdr_env
<- getLocalRdrEnv
434 ; traceRn
(text
"bhtv" <+> vcat
435 [ ppr tvs
, ppr kv_bndrs
, ppr kvs_from_tv_bndrs
436 , ppr
$ map (`elemLocalRdrEnv` rdr_env
) all_kvs
'
437 , ppr
$ map (getUnique
. rdrNameOcc
) all_kvs
'
438 , ppr all_kvs
, ppr rdr_env
, ppr inner_rdr_env
])
439 ; thing_inside
(HsQTvs
{ hsq_tvs
= tv_bndrs
', hsq_kvs
= kv_names
}) }
440 ; return (res
, fvs1 `plusFV` fvs2
) } }
442 newTyVarNameRn
:: Maybe a
-> LocalRdrEnv
-> SrcSpan
-> RdrName
-> RnM Name
443 newTyVarNameRn mb_assoc rdr_env loc rdr
444 | Just _
<- mb_assoc
-- Use the same Name as the parent class decl
445 , Just n
<- lookupLocalRdrEnv rdr_env rdr
448 = newLocalBndrRn
(L loc rdr
)
450 --------------------------------
451 rnHsBndrSig
:: HsDocContext
452 -> HsWithBndrs RdrName
(LHsType RdrName
)
453 -> (HsWithBndrs Name
(LHsType Name
) -> RnM
(a
, FreeVars
))
455 rnHsBndrSig doc
(HsWB
{ hswb_cts
= ty
@(L loc _
) }) thing_inside
456 = do { sig_ok
<- xoptM Opt_ScopedTypeVariables
457 ; unless sig_ok
(badSigErr
True doc ty
)
458 ; let (kv_bndrs
, tv_bndrs
) = extractHsTyRdrTyVars ty
459 ; name_env
<- getLocalRdrEnv
460 ; tv_names
<- newLocalBndrsRn
[L loc tv | tv
<- tv_bndrs
461 , not (tv `elemLocalRdrEnv` name_env
) ]
462 ; kv_names
<- newLocalBndrsRn
[L loc kv | kv
<- kv_bndrs
463 , not (kv `elemLocalRdrEnv` name_env
) ]
464 ; (wcs
, ty
') <- extractWildcards ty
465 ; bindLocalNamesFV kv_names
$
466 bindLocalNamesFV tv_names
$
467 bindLocatedLocalsFV wcs
$ \wcs_new
->
468 do { (ty
'', fvs1
) <- rnLHsType doc ty
'
469 ; (res
, fvs2
) <- thing_inside
(HsWB
{ hswb_cts
= ty
'', hswb_kvs
= kv_names
,
470 hswb_tvs
= tv_names
, hswb_wcs
= wcs_new
})
471 ; return (res
, fvs1 `plusFV` fvs2
) } }
473 overlappingKindVars
:: HsDocContext
-> [RdrName
] -> SDoc
474 overlappingKindVars doc kvs
475 = vcat
[ ptext
(sLit
"Kind variable") <> plural kvs
<+>
476 ptext
(sLit
"also used as type variable") <> plural kvs
477 <> colon
<+> pprQuotedList kvs
478 , docOfHsDocContext doc
]
480 badKindBndrs
:: HsDocContext
-> [RdrName
] -> SDoc
482 = vcat
[ hang
(ptext
(sLit
"Unexpected kind variable") <> plural kvs
483 <+> pprQuotedList kvs
)
484 2 (ptext
(sLit
"Perhaps you intended to use PolyKinds"))
485 , docOfHsDocContext doc
]
487 badSigErr
:: Bool -> HsDocContext
-> LHsType RdrName
-> TcM
()
488 badSigErr is_type doc
(L loc ty
)
489 = setSrcSpan loc
$ addErr
$
490 vcat
[ hang
(ptext
(sLit
"Illegal") <+> what
491 <+> ptext
(sLit
"signature:") <+> quotes
(ppr ty
))
492 2 (ptext
(sLit
"Perhaps you intended to use") <+> flag
)
493 , docOfHsDocContext doc
]
495 what | is_type
= ptext
(sLit
"type")
496 |
otherwise = ptext
(sLit
"kind")
497 flag | is_type
= ptext
(sLit
"ScopedTypeVariables")
498 |
otherwise = ptext
(sLit
"KindSignatures")
500 dataKindsErr
:: Bool -> HsType RdrName
-> SDoc
501 dataKindsErr is_type thing
502 = hang
(ptext
(sLit
"Illegal") <+> what
<> colon
<+> quotes
(ppr thing
))
503 2 (ptext
(sLit
"Perhaps you intended to use DataKinds"))
505 what | is_type
= ptext
(sLit
"type")
506 |
otherwise = ptext
(sLit
"kind")
509 *********************************************************
511 \subsection{Contexts and predicates}
513 *********************************************************
516 rnConDeclFields
:: HsDocContext
-> [LConDeclField RdrName
]
517 -> RnM
([LConDeclField Name
], FreeVars
)
518 rnConDeclFields doc fields
= mapFvRn
(rnField doc
) fields
520 rnField
:: HsDocContext
-> LConDeclField RdrName
521 -> RnM
(LConDeclField Name
, FreeVars
)
522 rnField doc
(L l
(ConDeclField names ty haddock_doc
))
523 = do { new_names
<- mapM lookupLocatedTopBndrRn names
524 ; (new_ty
, fvs
) <- rnLHsType doc ty
525 ; new_haddock_doc
<- rnMbLHsDoc haddock_doc
526 ; return (L l
(ConDeclField new_names new_ty new_haddock_doc
), fvs
) }
528 rnContext
:: HsDocContext
-> LHsContext RdrName
-> RnM
(LHsContext Name
, FreeVars
)
529 rnContext doc
(L loc cxt
)
530 = do { (cxt
', fvs
) <- rnLHsTypes doc cxt
531 ; return (L loc cxt
', fvs
) }
534 ************************************************************************
536 Fixities and precedence parsing
538 ************************************************************************
540 @mkOpAppRn@ deals with operator fixities. The argument expressions
541 are assumed to be already correctly arranged. It needs the fixities
542 recorded in the OpApp nodes, because fixity info applies to the things
543 the programmer actually wrote, so you can't find it out from the Name.
545 Furthermore, the second argument is guaranteed not to be another
546 operator application. Why? Because the parser parses all
547 operator appications left-associatively, EXCEPT negation, which
548 we need to handle specially.
549 Infix types are read in a *right-associative* way, so that
554 mkHsOpTyRn rearranges where necessary. The two arguments
555 have already been renamed and rearranged. It's made rather tiresome
556 by the presence of ->, which is a separate syntactic construct.
560 -- Building (ty1 `op1` (ty21 `op2` ty22))
561 mkHsOpTyRn
:: (LHsType Name
-> LHsType Name
-> HsType Name
)
562 -> Name
-> Fixity
-> LHsType Name
-> LHsType Name
565 mkHsOpTyRn mk1 pp_op1 fix1 ty1
(L loc2
(HsOpTy ty21
(w2
, op2
) ty22
))
566 = do { fix2
<- lookupTyFixityRn op2
567 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
568 (\t1 t2
-> HsOpTy t1
(w2
, op2
) t2
)
569 (unLoc op2
) fix2 ty21 ty22 loc2
}
571 mkHsOpTyRn mk1 pp_op1 fix1 ty1
(L loc2
(HsFunTy ty21 ty22
))
572 = mk_hs_op_ty mk1 pp_op1 fix1 ty1
573 HsFunTy funTyConName funTyFixity ty21 ty22 loc2
575 mkHsOpTyRn mk1 _ _ ty1 ty2
-- Default case, no rearrangment
576 = return (mk1 ty1 ty2
)
579 mk_hs_op_ty
:: (LHsType Name
-> LHsType Name
-> HsType Name
)
580 -> Name
-> Fixity
-> LHsType Name
581 -> (LHsType Name
-> LHsType Name
-> HsType Name
)
582 -> Name
-> Fixity
-> LHsType Name
-> LHsType Name
-> SrcSpan
584 mk_hs_op_ty mk1 op1 fix1 ty1
585 mk2 op2 fix2 ty21 ty22 loc2
586 | nofix_error
= do { precParseErr
(op1
,fix1
) (op2
,fix2
)
587 ; return (mk1 ty1
(L loc2
(mk2 ty21 ty22
))) }
588 | associate_right
= return (mk1 ty1
(L loc2
(mk2 ty21 ty22
)))
589 |
otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
590 new_ty
<- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
591 ; return (mk2
(noLoc new_ty
) ty22
) }
593 (nofix_error
, associate_right
) = compareFixity fix1 fix2
596 ---------------------------
597 mkOpAppRn
:: LHsExpr Name
-- Left operand; already rearranged
598 -> LHsExpr Name
-> Fixity
-- Operator and fixity
599 -> LHsExpr Name
-- Right operand (not an OpApp, but might
603 -- (e11 `op1` e12) `op2` e2
604 mkOpAppRn e1
@(L _
(OpApp e11 op1 fix1 e12
)) op2 fix2 e2
606 = do precParseErr
(get_op op1
,fix1
) (get_op op2
,fix2
)
607 return (OpApp e1 op2 fix2 e2
)
609 | associate_right
= do
610 new_e
<- mkOpAppRn e12 op2 fix2 e2
611 return (OpApp e11 op1 fix1
(L loc
' new_e
))
613 loc
'= combineLocs e12 e2
614 (nofix_error
, associate_right
) = compareFixity fix1 fix2
616 ---------------------------
617 -- (- neg_arg) `op` e2
618 mkOpAppRn e1
@(L _
(NegApp neg_arg neg_name
)) op2 fix2 e2
620 = do precParseErr
(negateName
,negateFixity
) (get_op op2
,fix2
)
621 return (OpApp e1 op2 fix2 e2
)
624 = do new_e
<- mkOpAppRn neg_arg op2 fix2 e2
625 return (NegApp
(L loc
' new_e
) neg_name
)
627 loc
' = combineLocs neg_arg e2
628 (nofix_error
, associate_right
) = compareFixity negateFixity fix2
630 ---------------------------
632 mkOpAppRn e1 op1 fix1 e2
@(L _
(NegApp _ _
)) -- NegApp can occur on the right
633 |
not associate_right
-- We *want* right association
634 = do precParseErr
(get_op op1
, fix1
) (negateName
, negateFixity
)
635 return (OpApp e1 op1 fix1 e2
)
637 (_
, associate_right
) = compareFixity fix1 negateFixity
639 ---------------------------
641 mkOpAppRn e1 op fix e2
-- Default case, no rearrangment
642 = ASSERT2
( right_op_ok fix
(unLoc e2
),
643 ppr e1
$$ text
"---" $$ ppr op
$$ text
"---" $$ ppr fix
$$ text
"---" $$ ppr e2
645 return (OpApp e1 op fix e2
)
647 ----------------------------
648 get_op
:: LHsExpr Name
-> Name
649 get_op
(L _
(HsVar n
)) = n
650 get_op other
= pprPanic
"get_op" (ppr other
)
652 -- Parser left-associates everything, but
653 -- derived instances may have correctly-associated things to
654 -- in the right operarand. So we just check that the right operand is OK
655 right_op_ok
:: Fixity
-> HsExpr Name
-> Bool
656 right_op_ok fix1
(OpApp _ _ fix2 _
)
657 = not error_please
&& associate_right
659 (error_please
, associate_right
) = compareFixity fix1 fix2
663 -- Parser initially makes negation bind more tightly than any other operator
664 -- And "deriving" code should respect this (use HsPar if not)
665 mkNegAppRn
:: LHsExpr
id -> SyntaxExpr
id -> RnM
(HsExpr
id)
666 mkNegAppRn neg_arg neg_name
667 = ASSERT
( not_op_app
(unLoc neg_arg
) )
668 return (NegApp neg_arg neg_name
)
670 not_op_app
:: HsExpr
id -> Bool
671 not_op_app
(OpApp _ _ _ _
) = False
674 ---------------------------
675 mkOpFormRn
:: LHsCmdTop Name
-- Left operand; already rearranged
676 -> LHsExpr Name
-> Fixity
-- Operator and fixity
677 -> LHsCmdTop Name
-- Right operand (not an infix)
680 -- (e11 `op1` e12) `op2` e2
681 mkOpFormRn a1
@(L loc
(HsCmdTop
(L _
(HsCmdArrForm op1
(Just fix1
) [a11
,a12
])) _ _ _
))
684 = do precParseErr
(get_op op1
,fix1
) (get_op op2
,fix2
)
685 return (HsCmdArrForm op2
(Just fix2
) [a1
, a2
])
688 = do new_c
<- mkOpFormRn a12 op2 fix2 a2
689 return (HsCmdArrForm op1
(Just fix1
)
690 [a11
, L loc
(HsCmdTop
(L loc new_c
)
691 placeHolderType placeHolderType
[])])
692 -- TODO: locs are wrong
694 (nofix_error
, associate_right
) = compareFixity fix1 fix2
697 mkOpFormRn arg1 op fix arg2
-- Default case, no rearrangment
698 = return (HsCmdArrForm op
(Just fix
) [arg1
, arg2
])
701 --------------------------------------
702 mkConOpPatRn
:: Located Name
-> Fixity
-> LPat Name
-> LPat Name
705 mkConOpPatRn op2 fix2 p1
@(L loc
(ConPatIn op1
(InfixCon p11 p12
))) p2
706 = do { fix1
<- lookupFixityRn
(unLoc op1
)
707 ; let (nofix_error
, associate_right
) = compareFixity fix1 fix2
709 ; if nofix_error
then do
710 { precParseErr
(unLoc op1
,fix1
) (unLoc op2
,fix2
)
711 ; return (ConPatIn op2
(InfixCon p1 p2
)) }
713 else if associate_right
then do
714 { new_p
<- mkConOpPatRn op2 fix2 p12 p2
715 ; return (ConPatIn op1
(InfixCon p11
(L loc new_p
))) } -- XXX loc right?
716 else return (ConPatIn op2
(InfixCon p1 p2
)) }
718 mkConOpPatRn op _ p1 p2
-- Default case, no rearrangment
719 = ASSERT
( not_op_pat
(unLoc p2
) )
720 return (ConPatIn op
(InfixCon p1 p2
))
722 not_op_pat
:: Pat Name
-> Bool
723 not_op_pat
(ConPatIn _
(InfixCon _ _
)) = False
726 --------------------------------------
727 checkPrecMatch
:: Name
-> MatchGroup Name body
-> RnM
()
728 -- Check precedence of a function binding written infix
729 -- eg a `op` b `C` c = ...
730 -- See comments with rnExpr (OpApp ...) about "deriving"
732 checkPrecMatch op
(MG
{ mg_alts
= ms
})
735 check
(L _
(Match _
(L l1 p1
: L l2 p2
:_
) _ _
))
736 = setSrcSpan
(combineSrcSpans l1 l2
) $
737 do checkPrec op p1
False
741 -- This can happen. Consider
744 -- The infix flag comes from the first binding of the group
745 -- but the second eqn has no args (an error, but not discovered
746 -- until the type checker). So we don't want to crash on the
749 checkPrec
:: Name
-> Pat Name
-> Bool -> IOEnv
(Env TcGblEnv TcLclEnv
) ()
750 checkPrec op
(ConPatIn op1
(InfixCon _ _
)) right
= do
751 op_fix
@(Fixity op_prec op_dir
) <- lookupFixityRn op
752 op1_fix
@(Fixity op1_prec op1_dir
) <- lookupFixityRn
(unLoc op1
)
754 inf_ok
= op1_prec
> op_prec ||
755 (op1_prec
== op_prec
&&
756 (op1_dir
== InfixR
&& op_dir
== InfixR
&& right ||
757 op1_dir
== InfixL
&& op_dir
== InfixL
&& not right
))
760 info1
= (unLoc op1
, op1_fix
)
761 (infol
, infor
) = if right
then (info
, info1
) else (info1
, info
)
762 unless inf_ok
(precParseErr infol infor
)
767 -- Check precedence of (arg op) or (op arg) respectively
768 -- If arg is itself an operator application, then either
769 -- (a) its precedence must be higher than that of op
770 -- (b) its precedency & associativity must be the same as that of op
771 checkSectionPrec
:: FixityDirection
-> HsExpr RdrName
772 -> LHsExpr Name
-> LHsExpr Name
-> RnM
()
773 checkSectionPrec direction section op arg
775 OpApp _ op fix _
-> go_for_it
(get_op op
) fix
776 NegApp _ _
-> go_for_it negateName negateFixity
780 go_for_it arg_op arg_fix
@(Fixity arg_prec assoc
) = do
781 op_fix
@(Fixity op_prec _
) <- lookupFixityRn op_name
782 unless (op_prec
< arg_prec
783 ||
(op_prec
== arg_prec
&& direction
== assoc
))
784 (sectionPrecErr
(op_name
, op_fix
)
785 (arg_op
, arg_fix
) section
)
787 -- Precedence-related error messages
789 precParseErr
:: (Name
, Fixity
) -> (Name
, Fixity
) -> RnM
()
790 precParseErr op1
@(n1
,_
) op2
@(n2
,_
)
791 | isUnboundName n1 || isUnboundName n2
792 = return () -- Avoid error cascade
794 = addErr
$ hang
(ptext
(sLit
"Precedence parsing error"))
795 4 (hsep
[ptext
(sLit
"cannot mix"), ppr_opfix op1
, ptext
(sLit
"and"),
797 ptext
(sLit
"in the same infix expression")])
799 sectionPrecErr
:: (Name
, Fixity
) -> (Name
, Fixity
) -> HsExpr RdrName
-> RnM
()
800 sectionPrecErr op
@(n1
,_
) arg_op
@(n2
,_
) section
801 | isUnboundName n1 || isUnboundName n2
802 = return () -- Avoid error cascade
804 = addErr
$ vcat
[ptext
(sLit
"The operator") <+> ppr_opfix op
<+> ptext
(sLit
"of a section"),
805 nest
4 (sep
[ptext
(sLit
"must have lower precedence than that of the operand,"),
806 nest
2 (ptext
(sLit
"namely") <+> ppr_opfix arg_op
)]),
807 nest
4 (ptext
(sLit
"in the section:") <+> quotes
(ppr section
))]
809 ppr_opfix
:: (Name
, Fixity
) -> SDoc
810 ppr_opfix
(op
, fixity
) = pp_op
<+> brackets
(ppr fixity
)
812 pp_op | op
== negateName
= ptext
(sLit
"prefix `-'")
813 |
otherwise = quotes
(ppr op
)
816 *********************************************************
820 *********************************************************
823 warnUnusedForAlls
:: SDoc
-> LHsTyVarBndrs RdrName
-> [RdrName
] -> TcM
()
824 warnUnusedForAlls in_doc bound mentioned_rdrs
825 = whenWOptM Opt_WarnUnusedMatches
$
826 mapM_ add_warn bound_but_not_used
828 bound_names
= hsLTyVarLocNames bound
829 bound_but_not_used
= filterOut
((`
elem` mentioned_rdrs
) . unLoc
) bound_names
833 vcat
[ ptext
(sLit
"Unused quantified type variable") <+> quotes
(ppr tv
)
836 warnContextQuantification
:: SDoc
-> [LHsTyVarBndr RdrName
] -> TcM
()
837 warnContextQuantification in_doc tvs
838 = whenWOptM Opt_WarnContextQuantification
$
843 vcat
[ ptext
(sLit
"Variable") <+> quotes
(ppr tv
) <+>
844 ptext
(sLit
"is implicitly quantified due to a context") $$
845 ptext
(sLit
"Use explicit forall syntax instead.") $$
846 ptext
(sLit
"This will become an error in GHC 7.12.")
849 opTyErr
:: RdrName
-> HsType RdrName
-> SDoc
850 opTyErr op ty
@(HsOpTy ty1 _ _
)
851 = hang
(ptext
(sLit
"Illegal operator") <+> quotes
(ppr op
) <+> ptext
(sLit
"in type") <+> quotes
(ppr ty
))
854 extra | op
== dot_tv_RDR
&& forall_head ty1
857 = ptext
(sLit
"Use TypeOperators to allow operators in types")
859 forall_head
(L _
(HsTyVar tv
)) = tv
== forall_tv_RDR
860 forall_head
(L _
(HsAppTy ty _
)) = forall_head ty
861 forall_head _other
= False
862 opTyErr _ ty
= pprPanic
"opTyErr: Not an op" (ppr ty
)
865 ************************************************************************
867 Finding the free type variables of a (HsType RdrName)
869 ************************************************************************
872 Note [Kind and type-variable binders]
873 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
874 In a type signature we may implicitly bind type variable and, more
875 recently, kind variables. For example:
878 Here we need to find the free type variables of (a -> a),
879 so that we know what to quantify
881 * class C (a :: k) where ...
882 This binds 'k' in ..., as well as 'a'
884 * f (x :: a -> [a]) = ....
885 Here we bind 'a' in ....
887 * f (x :: T a -> T (b :: k)) = ...
888 Here we bind both 'a' and the kind variable 'k'
890 * type instance F (T (a :: Maybe k)) = ...a...k...
891 Here we want to constrain the kind of 'a', and bind 'k'.
893 In general we want to walk over a type, and find
894 * Its free type variables
895 * The free kind variables of any kind signatures in the type
897 Hence we returns a pair (kind-vars, type vars)
898 See also Note [HsBSig binder lists] in HsTypes
901 type FreeKiTyVars
= ([RdrName
], [RdrName
])
903 filterInScope
:: LocalRdrEnv
-> FreeKiTyVars
-> FreeKiTyVars
904 filterInScope rdr_env
(kvs
, tvs
)
905 = (filterOut in_scope kvs
, filterOut in_scope tvs
)
907 in_scope tv
= tv `elemLocalRdrEnv` rdr_env
909 extractHsTyRdrTyVars
:: LHsType RdrName
-> FreeKiTyVars
910 -- extractHsTyRdrNames finds the free (kind, type) variables of a HsType
911 -- or the free (sort, kind) variables of a HsKind
912 -- It's used when making the for-alls explicit.
913 -- See Note [Kind and type-variable binders]
914 extractHsTyRdrTyVars ty
915 = case extract_lty ty
([],[]) of
916 (kvs
, tvs
) -> (nub kvs
, nub tvs
)
918 extractHsTysRdrTyVars
:: [LHsType RdrName
] -> FreeKiTyVars
919 -- See Note [Kind and type-variable binders]
920 extractHsTysRdrTyVars ty
921 = case extract_ltys ty
([],[]) of
922 (kvs
, tvs
) -> (nub kvs
, nub tvs
)
924 extractRdrKindSigVars
:: Maybe (LHsKind RdrName
) -> [RdrName
]
925 extractRdrKindSigVars Nothing
= []
926 extractRdrKindSigVars
(Just k
) = nub (fst (extract_lkind k
([],[])))
928 extractDataDefnKindVars
:: HsDataDefn RdrName
-> [RdrName
]
929 -- Get the scoped kind variables mentioned free in the constructor decls
930 -- Eg data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
931 -- Here k should scope over the whole definition
932 extractDataDefnKindVars
(HsDataDefn
{ dd_ctxt
= ctxt
, dd_kindSig
= ksig
933 , dd_cons
= cons
, dd_derivs
= derivs
})
934 = fst $ extract_lctxt ctxt
$
935 extract_mb extract_lkind ksig
$
936 extract_mb
(extract_ltys
. unLoc
) derivs
$
937 foldr (extract_con
. unLoc
) ([],[]) cons
939 extract_con
(ConDecl
{ con_res
= ResTyGADT
{} }) acc
= acc
940 extract_con
(ConDecl
{ con_res
= ResTyH98
, con_qvars
= qvs
941 , con_cxt
= ctxt
, con_details
= details
}) acc
942 = extract_hs_tv_bndrs qvs acc
$
944 extract_ltys
(hsConDeclArgTys details
) ([],[])
947 extract_lctxt
:: LHsContext RdrName
-> FreeKiTyVars
-> FreeKiTyVars
948 extract_lctxt ctxt
= extract_ltys
(unLoc ctxt
)
950 extract_ltys
:: [LHsType RdrName
] -> FreeKiTyVars
-> FreeKiTyVars
951 extract_ltys tys acc
= foldr extract_lty acc tys
953 extract_mb
:: (a
-> FreeKiTyVars
-> FreeKiTyVars
) -> Maybe a
-> FreeKiTyVars
-> FreeKiTyVars
954 extract_mb _ Nothing acc
= acc
955 extract_mb f
(Just x
) acc
= f x acc
957 extract_lkind
:: LHsType RdrName
-> FreeKiTyVars
-> FreeKiTyVars
958 extract_lkind kind
(acc_kvs
, acc_tvs
) = case extract_lty kind
([], acc_kvs
) of
959 (_
, res_kvs
) -> (res_kvs
, acc_tvs
)
960 -- Kinds shouldn't have sort signatures!
962 extract_lty
:: LHsType RdrName
-> FreeKiTyVars
-> FreeKiTyVars
963 extract_lty
(L _ ty
) acc
965 HsTyVar tv
-> extract_tv tv acc
966 HsBangTy _ ty
-> extract_lty ty acc
967 HsRecTy flds
-> foldr (extract_lty
. cd_fld_type
. unLoc
) acc
969 HsAppTy ty1 ty2
-> extract_lty ty1
(extract_lty ty2 acc
)
970 HsListTy ty
-> extract_lty ty acc
971 HsPArrTy ty
-> extract_lty ty acc
972 HsTupleTy _ tys
-> extract_ltys tys acc
973 HsFunTy ty1 ty2
-> extract_lty ty1
(extract_lty ty2 acc
)
974 HsIParamTy _ ty
-> extract_lty ty acc
975 HsEqTy ty1 ty2
-> extract_lty ty1
(extract_lty ty2 acc
)
976 HsOpTy ty1
(_
, (L _ tv
)) ty2
-> extract_tv tv
(extract_lty ty1
(extract_lty ty2 acc
))
977 HsParTy ty
-> extract_lty ty acc
978 HsCoreTy
{} -> acc
-- The type is closed
979 HsSpliceTy
{} -> acc
-- Type splices mention no type variables
980 HsDocTy ty _
-> extract_lty ty acc
981 HsExplicitListTy _ tys
-> extract_ltys tys acc
982 HsExplicitTupleTy _ tys
-> extract_ltys tys acc
984 HsWrapTy _ _
-> panic
"extract_lty"
985 HsKindSig ty ki
-> extract_lty ty
(extract_lkind ki acc
)
986 HsForAllTy _ _ tvs cx ty
-> extract_hs_tv_bndrs tvs acc
$
988 extract_lty ty
([],[])
989 -- We deal with these to in a later stage, because they need to be
990 -- replaced by fresh HsTyVars.
992 HsNamedWildcardTy _
-> acc
994 extract_hs_tv_bndrs
:: LHsTyVarBndrs RdrName
-> FreeKiTyVars
995 -> FreeKiTyVars
-> FreeKiTyVars
996 extract_hs_tv_bndrs
(HsQTvs
{ hsq_tvs
= tvs
})
997 (acc_kvs
, acc_tvs
) -- Note accumulator comes first
1000 = (body_kvs
++ acc_kvs
, body_tvs
++ acc_tvs
)
1002 = (acc_kvs
++ filterOut
(`
elem` local_kvs
) body_kvs
,
1003 acc_tvs
++ filterOut
(`
elem` local_tvs
) body_tvs
)
1005 local_tvs
= map hsLTyVarName tvs
1006 (_
, local_kvs
) = foldr extract_lty
([], []) [k | L _
(KindedTyVar _ k
) <- tvs
]
1007 -- These kind variables are bound here if not bound further out
1009 extract_tv
:: RdrName
-> FreeKiTyVars
-> FreeKiTyVars
1011 | isRdrTyVar tv
= case acc
of (kvs
,tvs
) -> (kvs
, tv
: tvs
)
1014 -- | Replace all unnamed wildcards in the given type with named wildcards.
1015 -- These names are freshly generated, based on "_". Return a tuple of the
1016 -- named wildcards that weren't already in scope (amongst them the named
1017 -- wildcards the unnamed ones were converted into), and the type in which the
1018 -- unnamed wildcards are replaced by named wildcards.
1019 extractWildcards
:: LHsType RdrName
-> RnM
([Located RdrName
], LHsType RdrName
)
1021 = do { (nwcs
, awcs
, ty
') <- go ty
1022 ; rdr_env
<- getLocalRdrEnv
1023 -- Filter out named wildcards that are already in scope
1024 ; let nwcs
' = nubBy eqLocated
$ filterOut
(flip (elemLocalRdrEnv
. unLoc
) rdr_env
) nwcs
1025 ; return (nwcs
' ++ awcs
, ty
') }
1027 go orig
@(L l ty
) = case ty
of
1028 (HsForAllTy
exp extra bndrs
(L locCxt cxt
) ty
) ->
1029 do (nwcs1
, awcs1
, cxt
') <- extList cxt
1030 (nwcs2
, awcs2
, ty
') <- go ty
1031 return (nwcs1
++ nwcs2
, awcs1
++ awcs2
,
1032 L l
(HsForAllTy
exp extra bndrs
(L locCxt cxt
') ty
'))
1033 (HsAppTy ty1 ty2
) -> go2 HsAppTy ty1 ty2
1034 (HsFunTy ty1 ty2
) -> go2 HsFunTy ty1 ty2
1035 (HsListTy ty
) -> go1 HsListTy ty
1036 (HsPArrTy ty
) -> go1 HsPArrTy ty
1037 (HsTupleTy con tys
) -> goList
(HsTupleTy con
) tys
1038 (HsOpTy ty1 op ty2
) -> go2
(\t1 t2
-> HsOpTy t1 op t2
) ty1 ty2
1039 (HsParTy ty
) -> go1 HsParTy ty
1040 (HsIParamTy n ty
) -> go1
(HsIParamTy n
) ty
1041 (HsEqTy ty1 ty2
) -> go2 HsEqTy ty1 ty2
1042 (HsKindSig ty kind
) -> go2 HsKindSig ty kind
1043 (HsDocTy ty doc
) -> go1
(flip HsDocTy doc
) ty
1044 (HsBangTy b ty
) -> go1
(HsBangTy b
) ty
1045 (HsExplicitListTy ptk tys
) -> goList
(HsExplicitListTy ptk
) tys
1046 (HsExplicitTupleTy ptk tys
) -> goList
(HsExplicitTupleTy ptk
) tys
1049 let name
= mkInternalName uniq
(mkTyVarOcc
"_") l
1050 rdrName
= nameRdrName name
1051 return ([], [L l rdrName
], L l
$ HsNamedWildcardTy rdrName
)
1052 (HsNamedWildcardTy name
) -> return ([L l name
], [], orig
)
1053 -- HsQuasiQuoteTy, HsSpliceTy, HsRecTy, HsCoreTy, HsTyLit, HsWrapTy
1054 _
-> return ([], [], orig
)
1056 go1 f t
= do (nwcs
, awcs
, t
') <- go t
1057 return (nwcs
, awcs
, L l
$ f t
')
1059 do (nwcs1
, awcs1
, t1
') <- go t1
1060 (nwcs2
, awcs2
, t2
') <- go t2
1061 return (nwcs1
++ nwcs2
, awcs1
++ awcs2
, L l
$ f t1
' t2
')
1062 extList l
= do rec_res
<- mapM go l
1063 let (nwcs
, awcs
, tys
') =
1064 foldr (\(nwcs
, awcs
, ty
) (nwcss
, awcss
, tys
) ->
1065 (nwcs
++ nwcss
, awcs
++ awcss
, ty
: tys
))
1066 ([], [], []) rec_res
1067 return (nwcs
, awcs
, tys
')
1068 goList f tys
= do (nwcs
, awcs
, tys
') <- extList tys
1069 return (nwcs
, awcs
, L l
$ f tys
')