RnTypes.hs 64.1 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
2
3
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

4
\section[RnSource]{Main pass of renamer}
Austin Seipp's avatar
Austin Seipp committed
5
-}
6

thomasw's avatar
thomasw committed
7
{-# LANGUAGE ScopedTypeVariables #-}
8
{-# LANGUAGE CPP #-}
9

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
10
11
12
module RnTypes (
        -- Type related stuff
        rnHsType, rnLHsType, rnLHsTypes, rnContext,
dreixel's avatar
dreixel committed
13
        rnHsKind, rnLHsKind, rnLHsMaybeKind,
14
15
16
17
18
        rnHsSigType, rnHsWcType,
        rnHsSigWcType, rnHsSigWcTypeScoped,
        rnLHsInstType,
        newTyVarNameRn, collectAnonWildCards,
        rnConDeclFields,
19
        rnLTyVar,
20

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
21
22
        -- Precence related stuff
        mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
23
        checkPrecMatch, checkSectionPrec,
24

dreixel's avatar
dreixel committed
25
        -- Binding related stuff
26
27
        warnUnusedForAlls, bindLHsTyVarBndr,
        bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,
28
        extractHsTyRdrTyVars, extractHsTysRdrTyVars,
29
30
        extractRdrKindSigVars, extractDataDefnKindVars,
        freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars
31
  ) where
32

gmainland's avatar
gmainland committed
33
import {-# SOURCE #-} RnSplice( rnSpliceType )
34

35
import DynFlags
36
import HsSyn
37
import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )
38
import RnEnv
39
import TcRnMonad
40
import RdrName
41
import PrelNames
42
import TysPrim          ( funTyConName )
43
import TysWiredIn       ( starKindTyConName, unicodeStarKindTyConName )
44
45
import Name
import SrcLoc
46
import NameSet
Adam Gundry's avatar
Adam Gundry committed
47
import FieldLabel
48

49
import Util
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
50
51
import BasicTypes       ( compareFixity, funTyFixity, negateFixity,
                          Fixity(..), FixityDirection(..) )
52
import Outputable
53
import FastString
54
import Maybes
55
import Data.List        ( nubBy )
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
56
import Control.Monad    ( unless, when )
57

thomasw's avatar
thomasw committed
58
59
60
61
#if __GLASGOW_HASKELL__ < 709
import Data.Monoid      ( mappend, mempty, mconcat )
#endif

62
63
#include "HsVersions.h"

Austin Seipp's avatar
Austin Seipp committed
64
{-
65
66
67
These type renamers are in a separate module, rather than in (say) RnSource,
to break several loop.

Austin Seipp's avatar
Austin Seipp committed
68
*********************************************************
69
70
71
*                                                       *
           HsSigWcType (i.e with wildcards)
*                                                       *
Austin Seipp's avatar
Austin Seipp committed
72
73
*********************************************************
-}
74

75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
rnHsSigWcType :: HsDocContext -> LHsSigWcType RdrName
            -> RnM (LHsSigWcType Name, FreeVars)
rnHsSigWcType doc sig_ty
  = rn_hs_sig_wc_type True doc sig_ty $ \sig_ty' ->
    return (sig_ty', emptyFVs)

rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType RdrName
                    -> (LHsSigWcType Name -> RnM (a, FreeVars))
                    -> RnM (a, FreeVars)
-- Used for
--   - Signatures on binders in a RULE
--   - Pattern type signatures
-- Wildcards are allowed
rnHsSigWcTypeScoped ctx sig_ty thing_inside
  = rn_hs_sig_wc_type False ctx sig_ty thing_inside
    -- False: for pattern type sigs and rules we /do/ want
    --        to bring those type varibles into scope
    -- e.g  \ (x :: forall a. a-> b) -> e
    -- Here we do bring 'b' into scope

rn_hs_sig_wc_type :: Bool   -- see rnImplicitBndrs
                  -> HsDocContext
                  -> LHsSigWcType RdrName
                  -> (LHsSigWcType Name -> RnM (a, FreeVars))
                  -> RnM (a, FreeVars)
-- rn_hs_sig_wc_type is used for source-language type signatures
rn_hs_sig_wc_type no_implicit_if_forall ctxt
                  (HsIB { hsib_body = wc_ty }) thing_inside
103
  = rnImplicitBndrs no_implicit_if_forall (hswc_body wc_ty) $ \ vars ->
104
    rn_hs_wc_type ctxt wc_ty $ \ wc_ty' ->
105
    thing_inside (HsIB { hsib_vars = vars
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
                       , hsib_body = wc_ty' })

rnHsWcType :: HsDocContext -> LHsWcType RdrName -> RnM (LHsWcType Name, FreeVars)
rnHsWcType ctxt wc_ty
  = rn_hs_wc_type ctxt wc_ty $ \ wc_ty' ->
    return (wc_ty', emptyFVs)

rn_hs_wc_type :: HsDocContext -> LHsWcType RdrName
              -> (LHsWcType Name -> RnM (a, FreeVars))
              -> RnM (a, FreeVars)
rn_hs_wc_type ctxt (HsWC { hswc_body = hs_ty }) thing_inside
  = do { let nwc_rdrs = collectNamedWildCards hs_ty
       ; rdr_env <- getLocalRdrEnv
       ; nwcs <- sequence [ newLocalBndrRn lrdr
                          | lrdr@(L _ rdr) <- nwc_rdrs
                          , not (inScope rdr_env rdr) ]
                 -- nwcs :: [Name]   Named wildcards
       ; bindLocalNamesFV nwcs $
    do { (wc_ty, fvs1) <- rnWcSigTy ctxt hs_ty
       ; let wc_ty' :: HsWildCardBndrs Name (LHsType Name)
             wc_ty' = wc_ty { hswc_wcs = nwcs ++ hswc_wcs wc_ty }
       ; (res, fvs2) <- thing_inside wc_ty'
       ; return (res, fvs1 `plusFV` fvs2) } }
129

130
131
132
133
134
135
136
rnWcSigTy :: HsDocContext -> LHsType RdrName
          -> RnM (LHsWcType Name, FreeVars)
-- Renames just the top level of a type signature
-- It's exactly like rnHsTyKi, except that it uses rnWcSigContext
-- on a qualified type, and return info on any extra-constraints
-- wildcard.  Some code duplication, but no big deal.
rnWcSigTy ctxt (L loc hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_tau }))
137
  = bindLHsTyVarBndrs ctxt Nothing [] tvs $ \ _ tvs' ->
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
    do { (hs_tau', fvs) <- rnWcSigTy ctxt hs_tau
       ; warnUnusedForAlls (inTypeDoc hs_ty) tvs' fvs
       ; let hs_ty' = HsForAllTy { hst_bndrs = tvs', hst_body = hswc_body hs_tau' }
       ; return ( hs_tau' { hswc_body = L loc hs_ty' }, fvs) }

rnWcSigTy ctxt (L loc (HsQualTy { hst_ctxt = hs_ctxt, hst_body = tau }))
  = do { (hs_ctxt', fvs1) <- rnWcSigContext ctxt hs_ctxt
       ; (tau',     fvs2) <- rnLHsType ctxt tau
       ; let awcs_tau = collectAnonWildCards tau'
             hs_ty'   = HsQualTy { hst_ctxt = hswc_body hs_ctxt'
                                 , hst_body = tau' }
       ; return ( HsWC { hswc_wcs = hswc_wcs hs_ctxt' ++ awcs_tau
                       , hswc_ctx = hswc_ctx hs_ctxt'
                       , hswc_body = L loc hs_ty' }
                , fvs1 `plusFV` fvs2) }

rnWcSigTy ctxt hs_ty
  = do { (hs_ty', fvs) <- rnLHsType ctxt hs_ty
       ; return (HsWC { hswc_wcs = collectAnonWildCards hs_ty'
                      , hswc_ctx = Nothing
                      , hswc_body = hs_ty' }
                , fvs) }

rnWcSigContext :: HsDocContext -> LHsContext RdrName
               -> RnM (HsWildCardBndrs Name (LHsContext Name), FreeVars)
rnWcSigContext ctxt (L loc hs_ctxt)
  | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt
  , L lx (HsWildCardTy wc) <- ignoreParens hs_ctxt_last
  = do { (hs_ctxt1', fvs) <- mapFvRn (rnLHsTyKi RnTopConstraint ctxt) hs_ctxt1
       ; wc'              <- setSrcSpan lx $
                             rnExtraConstraintWildCard ctxt wc
       ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy wc')]
             awcs     = concatMap collectAnonWildCards hs_ctxt1'
             -- NB: *not* including the extra-constraint wildcard
       ; return ( HsWC { hswc_wcs = awcs
                       , hswc_ctx = Just lx
                       , hswc_body = L loc hs_ctxt' }
                , fvs ) }
  | otherwise
  = do { (hs_ctxt', fvs) <- mapFvRn (rnLHsTyKi RnTopConstraint ctxt) hs_ctxt
       ; return (HsWC { hswc_wcs = concatMap collectAnonWildCards hs_ctxt'
                      , hswc_ctx = Nothing
                      , hswc_body = L loc hs_ctxt' }, fvs) }
181

182
183
184
185
186
187
188
189
190
191
192
193

{- ******************************************************
*                                                       *
           HsSigtype (i.e. no wildcards)
*                                                       *
****************************************************** -}

rnHsSigType :: HsDocContext -> LHsSigType RdrName
            -> RnM (LHsSigType Name, FreeVars)
-- Used for source-language type signatures
-- that cannot have wildcards
rnHsSigType ctx (HsIB { hsib_body = hs_ty })
194
  = rnImplicitBndrs True hs_ty $ \ vars ->
195
    do { (body', fvs) <- rnLHsType ctx hs_ty
196
       ; return (HsIB { hsib_vars = vars
197
198
199
200
201
202
203
                      , hsib_body = body' }, fvs) }

rnImplicitBndrs :: Bool    -- True <=> no implicit quantification
                           --          if type is headed by a forall
                           -- E.g.  f :: forall a. a->b
                           -- Do not quantify over 'b' too.
                -> LHsType RdrName
204
                -> ([Name] -> RnM (a, FreeVars))
205
206
207
                -> RnM (a, FreeVars)
rnImplicitBndrs no_implicit_if_forall hs_ty@(L loc _) thing_inside
  = do { rdr_env <- getLocalRdrEnv
208
209
210
211
       ; free_vars <- filterInScope rdr_env <$>
                      extractHsTyRdrTyVars hs_ty
       ; let real_tv_rdrs  -- Implicit quantification only if
                        -- there is no explicit forall
212
213
               | no_implicit_if_forall
               , L _ (HsForAllTy {}) <- hs_ty = []
214
215
216
217
218
219
220
               | otherwise                    = freeKiTyVarsTypeVars free_vars
             real_rdrs = freeKiTyVarsKindVars free_vars ++ real_tv_rdrs
       ; traceRn (text "rnSigType" <+> (ppr hs_ty $$ ppr free_vars $$
                                        ppr real_rdrs))
       ; vars <- mapM (newLocalBndrRn . L loc . unLoc) real_rdrs
       ; bindLocalNamesFV vars $
         thing_inside vars }
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245

rnLHsInstType :: SDoc -> LHsSigType RdrName -> RnM (LHsSigType Name, FreeVars)
-- Rename the type in an instance or standalone deriving decl
-- The 'doc_str' is "an instance declaration" or "a VECTORISE pragma"
rnLHsInstType doc_str inst_ty
  | Just cls <- getLHsInstDeclClass_maybe inst_ty
  , isTcOcc (rdrNameOcc (unLoc cls))
         -- The guards check that the instance type looks like
         --   blah => C ty1 .. tyn
  = do { let full_doc = doc_str <+> ptext (sLit "for") <+> quotes (ppr cls)
       ; rnHsSigType (GenericCtx full_doc) inst_ty }

  | otherwise  -- The instance is malformed, but we'd still like
               -- to make progress rather than failing outright, so
               -- we report more errors.  So we rename it anyway.
  = do { addErrAt (getLoc (hsSigType inst_ty)) $
         ptext (sLit "Malformed instance:") <+> ppr inst_ty
       ; rnHsSigType (GenericCtx doc_str) inst_ty }


{- ******************************************************
*                                                       *
           LHsType and HsType
*                                                       *
****************************************************** -}
246

Austin Seipp's avatar
Austin Seipp committed
247
{-
248
249
250
rnHsType is here because we call it from loadInstDecl, and I didn't
want a gratuitous knot.

251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
Note [Context quantification]
-----------------------------
Variables in type signatures are implicitly quantified
when (1) they are in a type signature not beginning
with "forall" or (2) in any qualified type T => R.
We are phasing out (2) since it leads to inconsistencies
(Trac #4426):

data A = A (a -> a)           is an error
data A = A (Eq a => a -> a)   binds "a"
data A = A (Eq a => a -> b)   binds "a" and "b"
data A = A (() => a -> b)     binds "a" and "b"
f :: forall a. a -> b         is an error
f :: forall a. () => a -> b   is an error
f :: forall a. a -> (() => b) binds "a" and "b"

267
268
This situation is now considered to be an error. See rnHsTyKi for case
HsForAllTy Qualified.
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297

Note [Dealing with *]
~~~~~~~~~~~~~~~~~~~~~
As a legacy from the days when types and kinds were different, we use
the type * to mean what we now call GHC.Types.Type. The problem is that
* should associate just like an identifier, *not* a symbol.
Running example: the user has written

  T (Int, Bool) b + c * d

At this point, we have a bunch of stretches of types

  [[T, (Int, Bool), b], [c], [d]]

these are the [[LHsType Name]] and a bunch of operators

  [GHC.TypeLits.+, GHC.Types.*]

Note that the * is GHC.Types.*. So, we want to rearrange to have

  [[T, (Int, Bool), b], [c, *, d]]

and

  [GHC.TypeLits.+]

as our lists. We can then do normal fixity resolution on these. The fixities
must come along for the ride just so that the list stays in sync with the
operators.
Austin Seipp's avatar
Austin Seipp committed
298
-}
299

300
rnLHsTyKi  :: RnTyKiWhat
301
           -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
302
rnLHsTyKi what doc (L loc ty)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
303
  = setSrcSpan loc $
304
    do { (ty', fvs) <- rnHsTyKi what doc ty
305
       ; return (L loc ty', fvs) }
dreixel's avatar
dreixel committed
306

307
rnLHsType  :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
308
rnLHsType cxt ty = -- pprTrace "rnHsType" (pprHsDocContext cxt $$ ppr ty) $
309
                   rnLHsTyKi (RnTypeBody TypeLevel) cxt ty
310

311
312
313
rnLHsPred  :: RnTyKiWhat -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars)
rnLHsPred (RnTypeBody level) = rnLHsTyKi (RnConstraint level)
rnLHsPred what               = rnLHsTyKi what
314
315

rnLHsKind  :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars)
316
rnLHsKind = rnLHsTyKi (RnTypeBody KindLevel)
dreixel's avatar
dreixel committed
317

318
319
rnLHsMaybeKind  :: HsDocContext -> Maybe (LHsKind RdrName)
                -> RnM (Maybe (LHsKind Name), FreeVars)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
320
rnLHsMaybeKind _ Nothing
321
  = return (Nothing, emptyFVs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
322
rnLHsMaybeKind doc (Just kind)
323
324
  = do { (kind', fvs) <- rnLHsKind doc kind
       ; return (Just kind', fvs) }
325
326

rnHsType  :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)
327
rnHsType cxt ty = rnHsTyKi (RnTypeBody TypeLevel) cxt ty
328

329
rnHsKind  :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars)
330
rnHsKind = rnHsTyKi (RnTypeBody KindLevel)
331

332
333
334
data RnTyKiWhat = RnTypeBody TypeOrKind
                | RnTopConstraint           -- Top-level context of HsSigWcTypes
                | RnConstraint TypeOrKind   -- All other constraints
335
336

instance Outputable RnTyKiWhat where
337
338
339
  ppr (RnTypeBody lev)   = text "RnTypeBody" <+> ppr lev
  ppr RnTopConstraint    = text "RnTopConstraint"
  ppr (RnConstraint lev) = text "RnConstraint" <+> ppr lev
340

341
342
343
344
isRnKindLevel :: RnTyKiWhat -> Bool
isRnKindLevel (RnTypeBody KindLevel)   = True
isRnKindLevel (RnConstraint KindLevel) = True
isRnKindLevel _                        = False
345
346
347

rnHsTyKi :: RnTyKiWhat -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars)

348
349
350
351
rnHsTyKi what doc ty@(HsForAllTy { hst_bndrs = tyvars, hst_body  = tau })
  = do { checkTypeInType what ty
       ; bindLHsTyVarBndrs doc Nothing [] tyvars $ \ _ tyvars' ->
    do { (tau',  fvs) <- rnLHsTyKi what doc tau
352
353
       ; warnUnusedForAlls (inTypeDoc ty) tyvars' fvs
       ; return ( HsForAllTy { hst_bndrs = tyvars', hst_body =  tau' }
354
                , fvs) }}
355

356
357
358
359
360
rnHsTyKi what doc ty@(HsQualTy { hst_ctxt = lctxt
                               , hst_body = tau })
  = do { checkTypeInType what ty
       ; (ctxt', fvs1) <- rnTyKiContext what doc lctxt
       ; (tau',  fvs2) <- rnLHsTyKi what doc tau
361
362
363
364
365
366
       ; return (HsQualTy { hst_ctxt = ctxt', hst_body =  tau' }
                , fvs1 `plusFV` fvs2) }

rnHsTyKi what _ (HsTyVar (L loc rdr_name))
  = do { name <- rnTyVar what rdr_name
       ; return (HsTyVar (L loc name), unitFV name) }
367

368
369
370
371
372
373
374
375
376
rnHsTyKi what doc ty@(HsOpTy ty1 l_op ty2)
  = setSrcSpan (getLoc l_op) $
    do  { (l_op', fvs1) <- rnHsTyOp what ty l_op
        ; fix   <- lookupTyFixityRn l_op'
        ; (ty1', fvs2) <- rnLHsTyKi what doc ty1
        ; (ty2', fvs3) <- rnLHsTyKi what doc ty2
        ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2)
                               (unLoc l_op') fix ty1' ty2'
        ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }
377

378
379
rnHsTyKi what doc (HsParTy ty)
  = do { (ty', fvs) <- rnLHsTyKi what doc ty
380
       ; return (HsParTy ty', fvs) }
381

382
383
rnHsTyKi _ doc (HsBangTy b ty)
  = do { (ty', fvs) <- rnLHsType doc ty
384
       ; return (HsBangTy b ty', fvs) }
385

Alan Zimmerman's avatar
Alan Zimmerman committed
386
387
388
389
390
391
392
393
rnHsTyKi _ doc@(ConDeclCtx names) (HsRecTy flds)
  = do {
       -- AZ:reviewers: is there a monadic version of concatMap?
         flss <- mapM (lookupConstructorFields . unLoc) names
       ; let fls = concat flss
       ; (flds', fvs) <- rnConDeclFields fls doc flds
       ; return (HsRecTy flds', fvs) }

394
395
396
rnHsTyKi _ doc ty@(HsRecTy flds)
  = do { addErr (hang (ptext (sLit "Record syntax is illegal here:"))
                    2 (ppr ty))
Adam Gundry's avatar
Adam Gundry committed
397
       ; (flds', fvs) <- rnConDeclFields [] doc flds
398
       ; return (HsRecTy flds', fvs) }
399

400
401
rnHsTyKi what doc (HsFunTy ty1 ty2)
  = do { (ty1', fvs1) <- rnLHsTyKi what doc ty1
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
402
        -- Might find a for-all as the arg of a function type
403
       ; (ty2', fvs2) <- rnLHsTyKi what doc ty2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
404
405
        -- Or as the result.  This happens when reading Prelude.hi
        -- when we find return :: forall m. Monad m -> forall a. a -> m a
406

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
407
        -- Check for fixity rearrangements
408
       ; res_ty <- mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
409
       ; return (res_ty, fvs1 `plusFV` fvs2) }
dreixel's avatar
dreixel committed
410

411
rnHsTyKi what doc listTy@(HsListTy ty)
412
  = do { data_kinds <- xoptM Opt_DataKinds
413
       ; when (not data_kinds && isRnKindLevel what)
414
415
              (addErr (dataKindsErr what listTy))
       ; (ty', fvs) <- rnLHsTyKi what doc ty
416
       ; return (HsListTy ty', fvs) }
417

418
419
420
rnHsTyKi what doc t@(HsKindSig ty k)
  = do { checkTypeInType what t
       ; kind_sigs_ok <- xoptM Opt_KindSignatures
421
       ; unless kind_sigs_ok (badKindSigErr doc ty)
422
       ; (ty', fvs1) <- rnLHsTyKi what doc ty
423
424
       ; (k', fvs2) <- rnLHsKind doc k
       ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) }
425

426
427
428
rnHsTyKi what doc t@(HsPArrTy ty)
  = do { notInKinds what t
       ; (ty', fvs) <- rnLHsType doc ty
429
       ; return (HsPArrTy ty', fvs) }
chak's avatar
chak committed
430

431
432
-- Unboxed tuples are allowed to have poly-typed arguments.  These
-- sometimes crop up as a result of CPR worker-wrappering dictionaries.
433
rnHsTyKi what doc tupleTy@(HsTupleTy tup_con tys)
434
  = do { data_kinds <- xoptM Opt_DataKinds
435
       ; when (not data_kinds && isRnKindLevel what)
436
437
              (addErr (dataKindsErr what tupleTy))
       ; (tys', fvs) <- mapFvRn (rnLHsTyKi what doc) tys
438
439
       ; return (HsTupleTy tup_con tys', fvs) }

440
-- Ensure that a type-level integer is nonnegative (#8306, #8412)
441
rnHsTyKi what _ tyLit@(HsTyLit t)
442
  = do { data_kinds <- xoptM Opt_DataKinds
443
       ; unless data_kinds (addErr (dataKindsErr what tyLit))
444
       ; when (negLit t) (addErr negLitErr)
445
       ; checkTypeInType what tyLit
446
       ; return (HsTyLit t, emptyFVs) }
447
  where
Alan Zimmerman's avatar
Alan Zimmerman committed
448
449
    negLit (HsStrTy _ _) = False
    negLit (HsNumTy _ i) = i < 0
450
    negLitErr = ptext (sLit "Illegal literal in type (type literals must not be negative):") <+> ppr tyLit
451

452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
rnHsTyKi isType doc overall_ty@(HsAppsTy tys)
  = do { -- Step 1: Break up the HsAppsTy into symbols and non-symbol regions
         let (non_syms, syms) = splitHsAppsTy tys

             -- Step 2: rename the pieces
       ; (syms1, fvs1)      <- mapFvRn (rnHsTyOp isType overall_ty) syms
       ; (non_syms1, fvs2)  <- (mapFvRn . mapFvRn) (rnLHsTyKi isType doc) non_syms

             -- Step 3: deal with *. See Note [Dealing with *]
       ; let (non_syms2, syms2) = deal_with_star [] [] non_syms1 syms1

             -- Step 4: collapse the non-symbol regions with HsAppTy
       ; non_syms3 <- mapM deal_with_non_syms non_syms2

             -- Step 5: assemble the pieces, using mkHsOpTyRn
       ; L _ res_ty <- build_res_ty non_syms3 syms2

        -- all done. Phew.
       ; return (res_ty, fvs1 `plusFV` fvs2) }
  where
    -- See Note [Dealing with *]
    deal_with_star :: [[LHsType Name]] -> [Located Name]
                   -> [[LHsType Name]] -> [Located Name]
                   -> ([[LHsType Name]], [Located Name])
    deal_with_star acc1 acc2
                   (non_syms1 : non_syms2 : non_syms) (L loc star : ops)
      | star `hasKey` starKindTyConKey || star `hasKey` unicodeStarKindTyConKey
      = deal_with_star acc1 acc2
                       ((non_syms1 ++ L loc (HsTyVar (L loc star)) : non_syms2) : non_syms)
                       ops
    deal_with_star acc1 acc2 (non_syms1 : non_syms) (op1 : ops)
      = deal_with_star (non_syms1 : acc1) (op1 : acc2) non_syms ops
    deal_with_star acc1 acc2 [non_syms] []
      = (reverse (non_syms : acc1), reverse acc2)
    deal_with_star _ _ _ _
      = pprPanic "deal_with_star" (ppr overall_ty)

    -- collapse [LHsType Name] to LHsType Name by making applications
    -- monadic only for failure
    deal_with_non_syms :: [LHsType Name] -> RnM (LHsType Name)
    deal_with_non_syms (non_sym : non_syms) = return $ mkHsAppTys non_sym non_syms
    deal_with_non_syms []                   = failWith (emptyNonSymsErr overall_ty)

    -- assemble a right-biased OpTy for use in mkHsOpTyRn
    build_res_ty :: [LHsType Name] -> [Located Name] -> RnM (LHsType Name)
    build_res_ty (arg1 : args) (op1 : ops)
      = do { rhs <- build_res_ty args ops
           ; fix <- lookupTyFixityRn op1
           ; res <-
               mkHsOpTyRn (\t1 t2 -> HsOpTy t1 op1 t2) (unLoc op1) fix arg1 rhs
           ; let loc = combineSrcSpans (getLoc arg1) (getLoc rhs)
           ; return (L loc res)
           }
    build_res_ty [arg] [] = return arg
    build_res_ty _ _ = pprPanic "build_op_ty" (ppr overall_ty)

508
509
510
rnHsTyKi what doc (HsAppTy ty1 ty2)
  = do { (ty1', fvs1) <- rnLHsTyKi what doc ty1
       ; (ty2', fvs2) <- rnLHsTyKi what doc ty2
511
512
       ; return (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) }

513
514
515
rnHsTyKi what doc t@(HsIParamTy n ty)
  = do { notInKinds what t
       ; (ty', fvs) <- rnLHsType doc ty
516
       ; return (HsIParamTy n ty', fvs) }
517

518
519
520
521
rnHsTyKi what doc t@(HsEqTy ty1 ty2)
  = do { checkTypeInType what t
       ; (ty1', fvs1) <- rnLHsTyKi what doc ty1
       ; (ty2', fvs2) <- rnLHsTyKi what doc ty2
522
       ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) }
523

524
525
rnHsTyKi _ _ (HsSpliceTy sp k)
  = rnSpliceType sp k
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
526

527
528
rnHsTyKi _ doc (HsDocTy ty haddock_doc)
  = do { (ty', fvs) <- rnLHsType doc ty
529
530
       ; haddock_doc' <- rnLHsDoc haddock_doc
       ; return (HsDocTy ty' haddock_doc', fvs) }
531

532
533
rnHsTyKi _ _ (HsCoreTy ty)
  = return (HsCoreTy ty, emptyFVs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
534
    -- The emptyFVs probably isn't quite right
535
536
    -- but I don't think it matters

537
rnHsTyKi what doc ty@(HsExplicitListTy k tys)
538
539
  = do { checkTypeInType what ty
       ; data_kinds <- xoptM Opt_DataKinds
540
       ; unless data_kinds (addErr (dataKindsErr what ty))
541
       ; (tys', fvs) <- mapFvRn (rnLHsTyKi what doc) tys
542
543
       ; return (HsExplicitListTy k tys', fvs) }

544
rnHsTyKi what doc ty@(HsExplicitTupleTy kis tys)
545
546
  = do { checkTypeInType what ty
       ; data_kinds <- xoptM Opt_DataKinds
547
       ; unless data_kinds (addErr (dataKindsErr what ty))
548
       ; (tys', fvs) <- mapFvRn (rnLHsTyKi what doc) tys
549
550
       ; return (HsExplicitTupleTy kis tys', fvs) }

551
552
553
554
555
556
557
558
559
560
rnHsTyKi what ctxt (HsWildCardTy wc)
  = do { wc' <- case mb_bad of
           Just msg -> do { addErr (wildCardMsg ctxt msg)
                          ; discardErrs (rnWildCard ctxt wc) }
                          -- discardErrs: avoid reporting
                          -- a second error
           Nothing  -> rnWildCard ctxt wc

       ; traceRn (text "rnHsTyKi wild" <+> ppr wc <+> ppr (isJust mb_bad))
       ; return (HsWildCardTy wc', emptyFVs) }
561
         -- emptyFVs: this occurrence does not refer to a
562
563
564
565
566
567
568
569
         --           user-written binding site, so don't treat
         --           it as a free variable
  where
    mb_bad :: Maybe SDoc
    mb_bad | not (wildCardsAllowed ctxt)
           = Just (notAllowed wc)
           | otherwise
           = case what of
570
571
               RnTypeBody _    -> Nothing
               RnConstraint _  -> Just constraint_msg
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
               RnTopConstraint -> case wc of
                     AnonWildCard {}  -> Just constraint_msg
                     NamedWildCard {} -> Nothing

    constraint_msg = hang (notAllowed wc <+> ptext (sLit "in a constraint"))
                        2 hint_msg

    hint_msg = case wc of
       NamedWildCard {} -> empty
       AnonWildCard {}  -> vcat [ ptext (sLit "except as the last top-level constraint of a type signature")
                                , nest 2 (ptext (sLit "e.g  f :: (Eq a, _) => blah")) ]

notAllowed :: HsWildCardInfo RdrName -> SDoc
notAllowed wc =  ptext (sLit "Wildcard") <+> quotes (ppr wc)
                 <+> ptext (sLit "not allowed")

wildCardMsg :: HsDocContext -> SDoc -> SDoc
wildCardMsg ctxt doc
  = vcat [doc, nest 2 (ptext (sLit "in") <+> pprHsDocContext ctxt)]
thomasw's avatar
thomasw committed
591

592
--------------
593
594
rnTyVar :: RnTyKiWhat -> RdrName -> RnM Name
rnTyVar what rdr_name
595
596
  | isRnKindLevel what = lookupKindOccRn rdr_name
  | otherwise          = lookupTypeOccRn rdr_name
597

598
599
600
601
rnLTyVar :: Located RdrName -> RnM (Located Name)
rnLTyVar (L loc rdr_name)
  = do { tyvar <- lookupTypeOccRn rdr_name
       ; return (L loc tyvar) }
602

603
604
605
606
607
608
609
610
611
612
613
614
615
616
--------------
rnHsTyOp :: Outputable a
         => RnTyKiWhat -> a -> Located RdrName -> RnM (Located Name, FreeVars)
rnHsTyOp what overall_ty (L loc op)
  = do { ops_ok <- xoptM Opt_TypeOperators
       ; op' <- rnTyVar what op
       ; unless (ops_ok
                 || op' == starKindTyConName
                 || op' == unicodeStarKindTyConName
                 || op' `hasKey` eqTyConKey) $
           addErr (opTyErr op overall_ty)
       ; let l_op' = L loc op'
       ; return (l_op', unitFV op') }

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
617
--------------
dreixel's avatar
dreixel committed
618
rnLHsTypes :: HsDocContext -> [LHsType RdrName]
619
620
           -> RnM ([LHsType Name], FreeVars)
rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
621

622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
--------------
extraConstraintWildCardsAllowed :: HsDocContext -> Bool
extraConstraintWildCardsAllowed ctxt
  = case ctxt of
      TypeSigCtx {}       -> True
      _                   -> False

wildCardsAllowed :: HsDocContext -> Bool
-- ^ In what contexts are wildcards permitted
wildCardsAllowed ctxt
   = case ctxt of
       TypeSigCtx {}       -> True
       TypBrCtx {}         -> True   -- Template Haskell quoted type
       SpliceTypeCtx {}    -> True   -- Result of a Template Haskell splice
       ExprWithTySigCtx {} -> True
       PatCtx {}           -> True
       RuleCtx {}          -> True
       FamPatCtx {}        -> True   -- Not named wildcards though
       GHCiCtx {}          -> True
       _                   -> False

rnExtraConstraintWildCard :: HsDocContext -> HsWildCardInfo RdrName
                          -> RnM (HsWildCardInfo Name)
-- Rename the extra-constraint spot in a type signature
--    (blah, _) => type
-- Check that extra-constraints are allowed at all, and
-- if so that it's an anonymous wildcard
rnExtraConstraintWildCard ctxt wc
  = case mb_bad of
      Nothing  -> rnWildCard ctxt wc
      Just msg -> do { addErr (wildCardMsg ctxt msg)
                     ; discardErrs (rnWildCard ctxt wc) }
  where
    mb_bad | not (extraConstraintWildCardsAllowed ctxt)
           = Just (ptext (sLit "Extra-contraint wildcard") <+> quotes (ppr wc)
                   <+> ptext (sLit "not allowed"))
           | isNamedWildCard wc
           = Just (hang (ptext (sLit "Named wildcard") <+> quotes (ppr wc)
                         <+> ptext (sLit "not allowed as an extra-contraint"))
                      2 (ptext (sLit "Use an anonymous wildcard instead")))
           | otherwise
           = Nothing

rnWildCard :: HsDocContext -> HsWildCardInfo RdrName -> RnM (HsWildCardInfo Name)
rnWildCard _ (AnonWildCard _)
  = do { loc <- getSrcSpanM
       ; uniq <- newUnique
       ; let name = mkInternalName uniq (mkTyVarOcc "_") loc
       ; return (AnonWildCard (L loc name)) }

rnWildCard ctxt wc@(NamedWildCard (L loc rdr_name))
  -- NB: The parser only generates NamedWildCard if -XNamedWildCards
  --     is on, so we don't need to check for that here
  = do { mb_name <- lookupOccRn_maybe rdr_name
       ; traceRn (text "rnWildCard named" <+> (ppr rdr_name $$ ppr mb_name))
       ; case mb_name of
           Just n  -> return (NamedWildCard (L loc n))
           Nothing -> do { addErr msg  -- I'm not sure how this can happen
                         ; return (NamedWildCard (L loc (mkUnboundNameRdr rdr_name))) } }
  where
    msg = wildCardMsg ctxt (notAllowed wc)
683

684

685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
---------------
-- | Ensures either that we're in a type or that -XTypeInType is set
checkTypeInType :: Outputable ty
                => RnTyKiWhat
                -> ty      -- ^ type
                -> RnM ()
checkTypeInType what ty
  | isRnKindLevel what
  = do { type_in_type <- xoptM Opt_TypeInType
       ; unless type_in_type $
         addErr (text "Illegal kind:" <+> ppr ty $$
                 text "Did you mean to enable TypeInType?") }
checkTypeInType _ _ = return ()

notInKinds :: Outputable ty
           => RnTyKiWhat
           -> ty
           -> RnM ()
notInKinds what ty
  | isRnKindLevel what
  = addErr (text "Illegal kind (even with TypeInType enabled):" <+> ppr ty)
notInKinds _ _ = return ()

708
709
710
711
712
713
{- *****************************************************
*                                                      *
          Binding type variables
*                                                      *
***************************************************** -}

714
bindSigTyVarsFV :: [Name]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
715
716
                -> RnM (a, FreeVars)
                -> RnM (a, FreeVars)
717
718
719
720
-- Used just before renaming the defn of a function
-- with a separate type signature, to bring its tyvars into scope
-- With no -XScopedTypeVariables, this is a no-op
bindSigTyVarsFV tvs thing_inside
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
721
722
723
724
725
  = do  { scoped_tyvars <- xoptM Opt_ScopedTypeVariables
        ; if not scoped_tyvars then
                thing_inside
          else
                bindLocalNamesFV tvs thing_inside }
726

727
728
729
730
731
732
733
734
735
736
737
-- | Simply bring a bunch of RdrNames into scope. No checking for
-- validity, at all. The binding location is taken from the location
-- on each name.
bindLRdrNames :: [Located RdrName]
              -> ([Name] -> RnM (a, FreeVars))
              -> RnM (a, FreeVars)
bindLRdrNames rdrs thing_inside
  = do { var_names <- mapM (newTyVarNameRn Nothing) rdrs
       ; bindLocalNamesFV var_names $
         thing_inside var_names }

738
---------------
739
740
741
742
743
744
bindHsQTyVars :: forall a b.
                 HsDocContext
              -> Maybe a                 -- Just _  => an associated type decl
              -> [Located RdrName]       -- Kind variables from scope, in l-to-r
                                         -- order, but not from ...
              -> (LHsQTyVars RdrName)     -- ... these user-written tyvars
745
746
              -> (LHsQTyVars Name -> RnM (b, FreeVars))
              -> RnM (b, FreeVars)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
747
748
-- (a) Bring kind variables into scope
--     both (i)  passed in (kv_bndrs)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
749
--     and  (ii) mentioned in the kinds of tv_bndrs
750
-- (b) Bring type variables into scope
751
bindHsQTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
752
753
754
755
756
757
758
759
760
761
762
763
764
765
  = do { bindLHsTyVarBndrs doc mb_assoc kv_bndrs (hsQTvExplicit tv_bndrs) $
         \ rn_kvs rn_bndrs ->
         thing_inside (HsQTvs { hsq_implicit = rn_kvs
                              , hsq_explicit = rn_bndrs }) }

bindLHsTyVarBndrs :: forall a b.
                     HsDocContext
                  -> Maybe a            -- Just _  => an associated type decl
                  -> [Located RdrName]  -- Unbound kind variables from scope,
                                        -- in l-to-r order, but not from ...
                  -> [LHsTyVarBndr RdrName]  -- ... these user-written tyvars
                  -> (   [Name]  -- all kv names
                      -> [LHsTyVarBndr Name]
                      -> RnM (b, FreeVars))
766
                  -> RnM (b, FreeVars)
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
bindLHsTyVarBndrs doc mb_assoc kv_bndrs tv_bndrs thing_inside
  = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)
       ; go [] [] emptyNameSet emptyNameSet tv_bndrs }
  where
    tv_names_w_loc = map hsLTyVarLocName tv_bndrs

    go :: [Name]                 -- kind-vars found (in reverse order)
       -> [LHsTyVarBndr Name]    -- already renamed (in reverse order)
       -> NameSet                -- kind vars already in scope (for dup checking)
       -> NameSet                -- type vars already in scope (for dup checking)
       -> [LHsTyVarBndr RdrName] -- still to be renamed, scoped
       -> RnM (b, FreeVars)
    go rn_kvs rn_tvs kv_names tv_names (tv_bndr : tv_bndrs)
      = bindLHsTyVarBndr doc mb_assoc kv_names tv_names tv_bndr $
        \ kv_nms tv_bndr' -> go (reverse kv_nms ++ rn_kvs)
                                (tv_bndr' : rn_tvs)
                                (kv_names `extendNameSetList` kv_nms)
                                (tv_names `extendNameSet` hsLTyVarName tv_bndr')
                                tv_bndrs

    go rn_kvs rn_tvs _kv_names tv_names []
      = -- still need to deal with the kv_bndrs passed in originally
        bindImplicitKvs doc mb_assoc kv_bndrs tv_names $ \ kv_nms ->
        do { let all_rn_kvs = reverse (reverse kv_nms ++ rn_kvs)
                 all_rn_tvs = reverse rn_tvs
           ; env <- getLocalRdrEnv
           ; traceRn (text "bindHsTyVars" <+> (ppr env $$
                                               ppr all_rn_kvs $$
                                               ppr all_rn_tvs))
           ; thing_inside all_rn_kvs all_rn_tvs }

bindLHsTyVarBndr :: HsDocContext
                 -> Maybe a   -- associated class
                 -> NameSet   -- kind vars already in scope
                 -> NameSet   -- type vars already in scope
                 -> LHsTyVarBndr RdrName
                 -> ([Name] -> LHsTyVarBndr Name -> RnM (b, FreeVars))
                   -- passed the newly-bound implicitly-declared kind vars,
                   -- and the renamed LHsTyVarBndr
                 -> RnM (b, FreeVars)
bindLHsTyVarBndr doc mb_assoc kv_names tv_names hs_tv_bndr thing_inside
  = case hs_tv_bndr of
      L loc (UserTyVar lrdr@(L lv rdr)) ->
        do { check_dup loc rdr
           ; nm <- newTyVarNameRn mb_assoc lrdr
           ; bindLocalNamesFV [nm] $
             thing_inside [] (L loc (UserTyVar (L lv nm))) }
      L loc (KindedTyVar lrdr@(L lv rdr) kind) ->
        do { check_dup lv rdr

             -- check for -XKindSignatures
           ; sig_ok <- xoptM Opt_KindSignatures
           ; unless sig_ok (badKindSigErr doc kind)

             -- deal with kind vars in the user-written kind
           ; free_kvs <- freeKiTyVarsAllVars <$> extractHsTyRdrTyVars kind
           ; bindImplicitKvs doc mb_assoc free_kvs tv_names $ \ kv_nms ->
             do { (kind', fvs1) <- rnLHsKind doc kind
                ; tv_nm  <- newTyVarNameRn mb_assoc lrdr
                ; (b, fvs2) <- bindLocalNamesFV [tv_nm] $
                               thing_inside kv_nms
                                 (L loc (KindedTyVar (L lv tv_nm) kind'))
                ; return (b, fvs1 `plusFV` fvs2) }}
  where
      -- make sure that the RdrName isn't in the sets of
      -- names. We can't just check that it's not in scope at all
      -- because we might be inside an associated class.
    check_dup :: SrcSpan -> RdrName -> RnM ()
    check_dup loc rdr
      = do { m_name <- lookupLocalOccRn_maybe rdr
           ; whenIsJust m_name $ \name ->
        do { when (name `elemNameSet` kv_names) $
             addErrAt loc (vcat [ ki_ty_err_msg name
                                , pprHsDocContext doc ])
           ; when (name `elemNameSet` tv_names) $
             dupNamesErr getLoc [L loc name, L (nameSrcSpan name) name] }}

    ki_ty_err_msg n = text "Variable" <+> quotes (ppr n) <+>
                      text "used as a kind variable before being bound" $$
                      text "as a type variable. Perhaps reorder your variables?"


bindImplicitKvs :: HsDocContext
                -> Maybe a
                -> [Located RdrName]  -- ^ kind var *occurrences*, from which
                                      -- intent to bind is inferred
                -> NameSet            -- ^ *type* variables, for type/kind
                                      -- misuse check for -XNoTypeInType
                -> ([Name] -> RnM (b, FreeVars)) -- ^ passed new kv_names
                -> RnM (b, FreeVars)
bindImplicitKvs _   _        []       _        thing_inside = thing_inside []
bindImplicitKvs doc mb_assoc free_kvs tv_names thing_inside
  = do { rdr_env <- getLocalRdrEnv
       ; let part_kvs lrdr@(L loc kv_rdr)
               = case lookupLocalRdrEnv rdr_env kv_rdr of
                   Just kv_name -> Left (L loc kv_name)
                   _            -> Right lrdr
             (bound_kvs, new_kvs) = partitionWith part_kvs free_kvs

          -- check whether we're mixing types & kinds illegally
       ; type_in_type <- xoptM Opt_TypeInType
       ; unless type_in_type $
         mapM_ (check_tv_used_in_kind tv_names) bound_kvs

       ; poly_kinds <- xoptM Opt_PolyKinds
       ; unless poly_kinds $
         addErr (badKindBndrs doc new_kvs)

          -- bind the vars and move on
       ; kv_nms <- mapM (newTyVarNameRn mb_assoc) new_kvs
       ; bindLocalNamesFV kv_nms $
         thing_inside kv_nms }
  where
      -- check to see if the variables free in a kind are bound as type
      -- variables. Assume -XNoTypeInType.
    check_tv_used_in_kind :: NameSet       -- ^ *type* variables
                          -> Located Name  -- ^ renamed var used in kind
                          -> RnM ()
    check_tv_used_in_kind tv_names (L loc kv_name)
      = when (kv_name `elemNameSet` tv_names) $
        addErrAt loc (vcat [ text "Type variable" <+> quotes (ppr kv_name) <+>
                             text "used in a kind." $$
                             text "Did you mean to use TypeInType?"
                           , pprHsDocContext doc ])


newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name
newTyVarNameRn mb_assoc (L loc rdr)
  = do { rdr_env <- getLocalRdrEnv
       ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of
           (Just _, Just n) -> return n
              -- Use the same Name as the parent class decl
899

900
           _                -> newLocalBndrRn (L loc rdr) }
901

902
903
904
905
906
---------------------
collectNamedWildCards :: LHsType RdrName -> [Located RdrName]
collectNamedWildCards hs_ty
  = nubBy eqLocated $
    [n | L _ (NamedWildCard n) <- collectWildCards hs_ty ]
907

908
909
910
collectAnonWildCards :: LHsType Name -> [Name]
collectAnonWildCards hs_ty
  = [n | L _ (AnonWildCard (L _ n)) <- collectWildCards hs_ty ]
911

912
913
914
collectWildCards :: LHsType name -> [Located (HsWildCardInfo name)]
-- | Extract all wild cards from a type.
collectWildCards lty = go lty
915
  where
thomasw's avatar
thomasw committed
916
    go (L loc ty) = case ty of
917
      HsAppsTy tys            -> gos (mapMaybe prefix_types_only tys)
thomasw's avatar
thomasw committed
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
      HsAppTy ty1 ty2         -> go ty1 `mappend` go ty2
      HsFunTy ty1 ty2         -> go ty1 `mappend` go ty2
      HsListTy ty             -> go ty
      HsPArrTy ty             -> go ty
      HsTupleTy _ tys         -> gos tys
      HsOpTy ty1 _ ty2        -> go ty1 `mappend` go ty2
      HsParTy ty              -> go ty
      HsIParamTy _ ty         -> go ty
      HsEqTy ty1 ty2          -> go ty1 `mappend` go ty2
      HsKindSig ty kind       -> go ty `mappend` go kind
      HsDocTy ty _            -> go ty
      HsBangTy _ ty           -> go ty
      HsRecTy flds            -> gos $ map (cd_fld_type . unLoc) flds
      HsExplicitListTy _ tys  -> gos tys
      HsExplicitTupleTy _ tys -> gos tys
      -- Interesting cases
934
935
936
937
      HsWildCardTy wc         -> [L loc wc]
      HsForAllTy { hst_body = ty } -> go ty
      HsQualTy { hst_ctxt = L _ ctxt
               , hst_body = ty }  -> gos ctxt `mappend` go ty
thomasw's avatar
thomasw committed
938
939
940
      -- HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit
      _ -> mempty

941
    gos = mconcat . map go
thomasw's avatar
thomasw committed
942

943
944
945
    prefix_types_only (HsAppPrefix ty) = Just ty
    prefix_types_only (HsAppInfix _)   = Nothing

thomasw's avatar
thomasw committed
946

Austin Seipp's avatar
Austin Seipp committed
947
948
{-
*********************************************************
Adam Gundry's avatar
Adam Gundry committed
949
950
951
*                                                       *
        ConDeclField
*                                                       *
Austin Seipp's avatar
Austin Seipp committed
952
*********************************************************
Adam Gundry's avatar
Adam Gundry committed
953
954
955
956
957
958

When renaming a ConDeclField, we have to find the FieldLabel
associated with each field.  But we already have all the FieldLabels
available (since they were brought into scope by
RnNames.getLocalNonValBinders), so we just take the list as an
argument, build a map and look them up.
Austin Seipp's avatar
Austin Seipp committed
959
-}
960

Adam Gundry's avatar
Adam Gundry committed
961
rnConDeclFields :: [FieldLabel] -> HsDocContext -> [LConDeclField RdrName]
962
                -> RnM ([LConDeclField Name], FreeVars)
Adam Gundry's avatar
Adam Gundry committed
963
964
965
rnConDeclFields fls doc fields = mapFvRn (rnField fl_env doc) fields
  where
    fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]
966

Adam Gundry's avatar
Adam Gundry committed
967
rnField :: FastStringEnv FieldLabel -> HsDocContext -> LConDeclField RdrName
968
        -> RnM (LConDeclField Name, FreeVars)
Adam Gundry's avatar
Adam Gundry committed
969
970
rnField fl_env doc (L l (ConDeclField names ty haddock_doc))
  = do { let new_names = map (fmap lookupField) names
971
972
       ; (new_ty, fvs) <- rnLHsType doc ty
       ; new_haddock_doc <- rnMbLHsDoc haddock_doc
973
       ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) }
Adam Gundry's avatar
Adam Gundry committed
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
  where
    lookupField :: FieldOcc RdrName -> FieldOcc Name
    lookupField (FieldOcc rdr _) = FieldOcc rdr (flSelector fl)
      where
        lbl = occNameFS $ rdrNameOcc rdr
        fl  = expectJust "rnField" $ lookupFsEnv fl_env lbl


{-
*********************************************************
*                                                       *
        Contexts
*                                                       *
*********************************************************
-}
989

990
991
992
rnTyKiContext :: RnTyKiWhat
              -> HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
rnTyKiContext what doc (L loc cxt)
993
  = do { traceRn (text "rncontext" <+> ppr cxt)
994
       ; (cxt', fvs) <- mapFvRn (rnLHsPred what doc) cxt
995
       ; return (L loc cxt', fvs) }
996

997
998
999
rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars)
rnContext = rnTyKiContext (RnConstraint TypeLevel)

Austin Seipp's avatar
Austin Seipp committed
1000
1001
1002
{-
************************************************************************
*                                                                      *
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1003
        Fixities and precedence parsing
Austin Seipp's avatar
Austin Seipp committed
1004
1005
*                                                                      *
************************************************************************
1006

1007
1008
1009
1010
1011
1012
1013
1014
1015
@mkOpAppRn@ deals with operator fixities.  The argument expressions
are assumed to be already correctly arranged.  It needs the fixities
recorded in the OpApp nodes, because fixity info applies to the things
the programmer actually wrote, so you can't find it out from the Name.

Furthermore, the second argument is guaranteed not to be another
operator application.  Why? Because the parser parses all
operator appications left-associatively, EXCEPT negation, which
we need to handle specially.
1016
Infix types are read in a *right-associative* way, so that
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1017
        a `op` b `op` c
1018
is always read in as
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1019
        a `op` (b `op` c)
1020
1021
1022

mkHsOpTyRn rearranges where necessary.  The two arguments
have already been renamed and rearranged.  It's made rather tiresome
1023
by the presence of ->, which is a separate syntactic construct.
Austin Seipp's avatar
Austin Seipp committed
1024
-}
1025

1026
1027
1028
---------------
-- Building (ty1 `op1` (ty21 `op2` ty22))
mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1029
1030
           -> Name -> Fixity -> LHsType Name -> LHsType Name
           -> RnM (HsType Name)
1031

1032
mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
1033
  = do  { fix2 <- lookupTyFixityRn op2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1034
        ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
1035
                      (\t1 t2 -> HsOpTy t1 op2 t2)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1036
                      (unLoc op2) fix2 ty21 ty22 loc2 }
1037

Ian Lynagh's avatar
Ian Lynagh committed
1038
mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1039
1040
  = mk_hs_op_ty mk1 pp_op1 fix1 ty1
                HsFunTy funTyConName funTyFixity ty21 ty22 loc2
1041

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1042
mkHsOpTyRn mk1 _ _ ty1 ty2              -- Default case, no rearrangment
1043
1044
1045
1046
  = return (mk1 ty1 ty2)

---------------
mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1047
1048
1049
1050
1051
1052
            -> Name -> Fixity -> LHsType Name
            -> (LHsType Name -> LHsType Name -> HsType Name)
            -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
            -> RnM (HsType Name)
mk_hs_op_ty mk1 op1 fix1 ty1
            mk2 op2 fix2 ty21 ty22 loc2
1053
  | nofix_error     = do { precParseErr (op1,fix1) (op2,fix2)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1054
                         ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
1055
  | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1056
1057
1058
  | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
                           new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
                         ; return (mk2 (noLoc new_ty) ty22) }
1059
1060
1061
  where
    (nofix_error, associate_right) = compareFixity fix1 fix2

1062

1063
---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1064
1065
1066
1067
1068
mkOpAppRn :: LHsExpr Name                       -- Left operand; already rearranged
          -> LHsExpr Name -> Fixity             -- Operator and fixity
          -> LHsExpr Name                       -- Right operand (not an OpApp, but might
                                                -- be a NegApp)
          -> RnM (HsExpr Name)
1069
1070
1071

-- (e11 `op1` e12) `op2` e2
mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
1072
1073
1074
  | nofix_error
  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
       return (OpApp e1 op2 fix2 e2)
1075

1076
1077
1078
  | associate_right = do
    new_e <- mkOpAppRn e12 op2 fix2 e2
    return (OpApp e11 op1 fix1 (L loc' new_e))
1079
1080
1081
1082
1083
  where
    loc'= combineLocs e12 e2
    (nofix_error, associate_right) = compareFixity fix1 fix2

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1084
--      (- neg_arg) `op` e2
1085
mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
1086
1087
1088
  | nofix_error
  = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
       return (OpApp e1 op2 fix2 e2)
1089

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1090
  | associate_right
1091
1092
  = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
       return (NegApp (L loc' new_e) neg_name)
1093
1094
1095
1096
1097
  where
    loc' = combineLocs neg_arg e2
    (nofix_error, associate_right) = compareFixity negateFixity fix2

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1098
1099
1100
--      e1 `op` - neg_arg
mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _))     -- NegApp can occur on the right
  | not associate_right                 -- We *want* right association
1101
1102
  = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
       return (OpApp e1 op1 fix1 e2)
1103
1104
1105
1106
  where
    (_, associate_right) = compareFixity fix1 negateFixity

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1107
1108
--      Default case
mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
1109
  = ASSERT2( right_op_ok fix (unLoc e2),
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1110
             ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
1111
    )
1112
    return (OpApp e1 op fix e2)
1113

1114
1115
----------------------------
get_op :: LHsExpr Name -> Name
1116
-- An unbound name could be either HsVar or HsUnboundVar
1117
-- See RnExpr.rnUnboundVar
1118
get_op (L _ (HsVar (L _ n)))    = n
1119
get_op (L _ (HsUnboundVar occ)) = mkUnboundName occ
1120
get_op other                    = pprPanic "get_op" (ppr other)
1121

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1122
-- Parser left-associates everything, but
1123
1124
-- derived instances may have correctly-associated things to
-- in the right operarand.  So we just check that the right operand is OK
Ian Lynagh's avatar
Ian Lynagh committed
1125
right_op_ok :: Fixity -> HsExpr Name -> Bool
1126
1127
1128
1129
right_op_ok fix1 (OpApp _ _ fix2 _)
  = not error_please && associate_right
  where
    (error_please, associate_right) = compareFixity fix1 fix2
Ian Lynagh's avatar
Ian Lynagh committed
1130
right_op_ok _ _
1131
1132
1133
1134
1135
1136
1137
  = True

-- Parser initially makes negation bind more tightly than any other operator
-- And "deriving" code should respect this (use HsPar if not)
mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id)
mkNegAppRn neg_arg neg_name
  = ASSERT( not_op_app (unLoc neg_arg) )
1138
    return (NegApp neg_arg neg_name)
1139

Ian Lynagh's avatar
Ian Lynagh committed
1140
not_op_app :: HsExpr id -> Bool
1141
not_op_app (OpApp _ _ _ _) = False
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1142
not_op_app _               = True
1143
1144

---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1145
1146
1147
1148
mkOpFormRn :: LHsCmdTop Name            -- Left operand; already rearranged
          -> LHsExpr Name -> Fixity     -- Operator and fixity
          -> LHsCmdTop Name             -- Right operand (not an infix)
          -> RnM (HsCmd Name)
1149
1150

-- (e11 `op1` e12) `op2` e2
1151
mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _))
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1152
        op2 fix2 a2
1153
1154
  | nofix_error
  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
1155
       return (HsCmdArrForm op2 (Just fix2) [a1, a2])
1156
1157
1158

  | associate_right
  = do new_c <- mkOpFormRn a12 op2 fix2 a2
1159
       return (HsCmdArrForm op1 (Just fix1)
1160
1161
               [a11, L loc (HsCmdTop (L loc new_c)
               placeHolderType placeHolderType [])])
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1162
        -- TODO: locs are wrong
1163
1164
1165
  where
    (nofix_error, associate_right) = compareFixity fix1 fix2

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1166
1167
--      Default case
mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment
1168
  = return (HsCmdArrForm op (Just fix) [arg1, arg2])
1169
1170
1171
1172


--------------------------------------
mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1173
             -> RnM (Pat Name)
1174
1175

mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1176
1177
  = do  { fix1 <- lookupFixityRn (unLoc op1)
        ; let (nofix_error, associate_right) = compareFixity fix1 fix2
1178

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1179
1180
1181
        ; if nofix_error then do
                { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
                ; return (ConPatIn op2 (InfixCon p1 p2)) }
1182

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1183
1184
1185
1186
          else if associate_right then do
                { new_p <- mkConOpPatRn op2 fix2 p12 p2
                ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
          else return (ConPatIn op2 (InfixCon p1 p2)) }
1187

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1188
mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment
1189
  = ASSERT( not_op_pat (unLoc p2) )
1190
    return (ConPatIn op (InfixCon p1 p2))