RnTypes.hs 76.2 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
10
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}
11

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
12
13
14
module RnTypes (
        -- Type related stuff
        rnHsType, rnLHsType, rnLHsTypes, rnContext,
My Nguyen's avatar
My Nguyen committed
15
        rnHsKind, rnLHsKind, rnLHsTypeArgs,
16
        rnHsSigType, rnHsWcType,
17
        HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped,
My Nguyen's avatar
My Nguyen committed
18
        newTyVarNameRn,
19
        rnConDeclFields,
20
        rnLTyVar,
21

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

dreixel's avatar
dreixel committed
26
        -- Binding related stuff
27
        bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs,
28
        bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,
29
        extractFilteredRdrTyVars, extractFilteredRdrTyVarsDups,
30
31
        extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
        extractHsTyRdrTyVarsDups, extractHsTysRdrTyVars,
32
        extractHsTysRdrTyVarsDups, rmDupsInRdrTyVars,
33
        extractRdrKindSigVars, extractDataDefnKindVars,
My Nguyen's avatar
My Nguyen committed
34
        extractHsTvBndrs, extractHsTyArgRdrKiTyVarsDup,
35
36
        freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars,
        elemRdr
37
  ) where
38

39
40
import GhcPrelude

gmainland's avatar
gmainland committed
41
import {-# SOURCE #-} RnSplice( rnSpliceType )
42

43
import DynFlags
44
import HsSyn
45
import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )
46
import RnEnv
47
48
import RnUnbound        ( perhapsForallMsg )
import RnUtils          ( HsDocContext(..), withHsDocContext, mapFvRn
49
                        , pprHsDocContext, bindLocalNamesFV, typeAppErr
50
                        , newLocalBndrRn, checkDupRdrNames, checkShadowedRdrNames )
51
52
import RnFixity         ( lookupFieldFixityRn, lookupFixityRn
                        , lookupTyFixityRn )
53
import TcRnMonad
54
import RdrName
55
import PrelNames
56
import TysPrim          ( funTyConName )
57
58
import Name
import SrcLoc
59
import NameSet
Adam Gundry's avatar
Adam Gundry committed
60
import FieldLabel
61

62
import Util
63
import ListSetOps       ( deleteBys )
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
64
import BasicTypes       ( compareFixity, funTyFixity, negateFixity,
65
                          Fixity(..), FixityDirection(..), LexicalFixity(..) )
66
import Outputable
67
import FastString
68
import Maybes
69
70
import qualified GHC.LanguageExtensions as LangExt

71
import Data.List          ( nubBy, partition, (\\) )
72
import Control.Monad      ( unless, when )
73
74
75

#include "HsVersions.h"

Austin Seipp's avatar
Austin Seipp committed
76
{-
77
78
79
These type renamers are in a separate module, rather than in (say) RnSource,
to break several loop.

Austin Seipp's avatar
Austin Seipp committed
80
*********************************************************
81
82
83
*                                                       *
           HsSigWcType (i.e with wildcards)
*                                                       *
Austin Seipp's avatar
Austin Seipp committed
84
85
*********************************************************
-}
86

87
88
89
90
91
92
93
94
95
96
97
98
99
data HsSigWcTypeScoping = AlwaysBind
                          -- ^ Always bind any free tyvars of the given type,
                          --   regardless of whether we have a forall at the top
                        | BindUnlessForall
                          -- ^ Unless there's forall at the top, do the same
                          --   thing as 'AlwaysBind'
                        | NeverBind
                          -- ^ Never bind any free tyvars

rnHsSigWcType :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs
              -> RnM (LHsSigWcType GhcRn, FreeVars)
rnHsSigWcType scoping doc sig_ty
  = rn_hs_sig_wc_type scoping doc sig_ty $ \sig_ty' ->
100
101
    return (sig_ty', emptyFVs)

102
103
104
105
106
107
108
109
rnHsSigWcTypeScoped :: HsSigWcTypeScoping
                       -- AlwaysBind: for pattern type sigs and rules we /do/ want
                       --             to bring those type variables into scope, even
                       --             if there's a forall at the top which usually
                       --             stops that happening
                       -- e.g  \ (x :: forall a. a-> b) -> e
                       -- Here we do bring 'b' into scope
                    -> HsDocContext -> LHsSigWcType GhcPs
110
                    -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
111
112
113
114
115
                    -> RnM (a, FreeVars)
-- Used for
--   - Signatures on binders in a RULE
--   - Pattern type signatures
-- Wildcards are allowed
116
-- type signatures on binders only allowed with ScopedTypeVariables
117
rnHsSigWcTypeScoped scoping ctx sig_ty thing_inside
118
119
  = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables
       ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty)
120
       ; rn_hs_sig_wc_type scoping ctx sig_ty thing_inside
121
       }
122
123

rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs
124
                  -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
125
126
                  -> RnM (a, FreeVars)
-- rn_hs_sig_wc_type is used for source-language type signatures
127
rn_hs_sig_wc_type scoping ctxt
128
129
                  (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})
                  thing_inside
130
131
132
  = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty
       ; (tv_rdrs, nwc_rdrs') <- partition_nwcs free_vars
       ; let nwc_rdrs = nubL nwc_rdrs'
133
134
135
136
             bind_free_tvs = case scoping of
                               AlwaysBind       -> True
                               BindUnlessForall -> not (isLHsForAllTy hs_ty)
                               NeverBind        -> False
137
       ; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars ->
138
    do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty
139
       ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' }
140
141
             ib_ty'  = HsIB { hsib_ext = vars
                            , hsib_body = hs_ty' }
142
143
       ; (res, fvs2) <- thing_inside sig_ty'
       ; return (res, fvs1 `plusFV` fvs2) } }
144
145
146
147
rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs _)) _
  = panic "rn_hs_sig_wc_type"
rn_hs_sig_wc_type _ _ (XHsWildCardBndrs _) _
  = panic "rn_hs_sig_wc_type"
148

149
rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
150
rnHsWcType ctxt (HsWC { hswc_body = hs_ty })
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
151
  = do { free_vars <- extractFilteredRdrTyVars hs_ty
152
       ; (_, nwc_rdrs) <- partition_nwcs free_vars
153
       ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty
154
       ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' }
155
       ; return (sig_ty', fvs) }
156
rnHsWcType _ (XHsWildCardBndrs _) = panic "rnHsWcType"
157

158
159
rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs
         -> RnM ([Name], LHsType GhcRn, FreeVars)
160
rnWcBody ctxt nwc_rdrs hs_ty
161
  = do { nwcs <- mapM newLocalBndrRn nwc_rdrs
162
       ; let env = RTKE { rtke_level = TypeLevel
163
164
165
                        , rtke_what  = RnTypeBody
                        , rtke_nwcs  = mkNameSet nwcs
                        , rtke_ctxt  = ctxt }
166
167
       ; (hs_ty', fvs) <- bindLocalNamesFV nwcs $
                          rn_lty env hs_ty
My Nguyen's avatar
My Nguyen committed
168
       ; return (nwcs, hs_ty', fvs) }
169
  where
170
    rn_lty env (dL->L loc hs_ty)
171
172
      = setSrcSpan loc $
        do { (hs_ty', fvs) <- rn_ty env hs_ty
173
           ; return (cL loc hs_ty', fvs) }
174

175
    rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
176
177
    -- A lot of faff just to allow the extra-constraints wildcard to appear
    rn_ty env hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_body })
178
      = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) Nothing tvs $ \ tvs' ->
179
        do { (hs_body', fvs) <- rn_lty env hs_body
180
181
           ; return (HsForAllTy { hst_xforall = noExt, hst_bndrs = tvs'
                                , hst_body = hs_body' }, fvs) }
182

183
184
    rn_ty env (HsQualTy { hst_ctxt = dL->L cx hs_ctxt
                        , hst_body = hs_ty })
185
      | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt
186
      , (dL->L lx (HsWildCardTy _))  <- ignoreParens hs_ctxt_last
187
      = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1
My Nguyen's avatar
My Nguyen committed
188
189
           ; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1
           ; let hs_ctxt' = hs_ctxt1' ++ [cL lx (HsWildCardTy noExt)]
190
           ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty
191
           ; return (HsQualTy { hst_xqual = noExt
192
                              , hst_ctxt = cL cx hs_ctxt', hst_body = hs_ty' }
193
194
195
196
197
                    , fvs1 `plusFV` fvs2) }

      | otherwise
      = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt
           ; (hs_ty', fvs2)   <- rnLHsTyKi env hs_ty
198
           ; return (HsQualTy { hst_xqual = noExt
199
200
                              , hst_ctxt = cL cx hs_ctxt'
                              , hst_body = hs_ty' }
201
202
203
204
205
                    , fvs1 `plusFV` fvs2) }

    rn_ty env hs_ty = rnHsTyKi env hs_ty

    rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint })
206

207

208
checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM ()
209
210
211
212
-- 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
213
checkExtraConstraintWildCard env hs_ctxt
214
  = checkWildCard env mb_bad
215
  where
216
    mb_bad | not (extraConstraintWildCardsAllowed env)
217
218
219
220
221
222
223
224
225
226
227
228
229
           = Just base_msg
             -- Currently, we do not allow wildcards in their full glory in
             -- standalone deriving declarations. We only allow a single
             -- extra-constraints wildcard à la:
             --
             --   deriving instance _ => Eq (Foo a)
             --
             -- i.e., we don't support things like
             --
             --   deriving instance (Eq a, _) => Eq (Foo a)
           | DerivDeclCtx {} <- rtke_ctxt env
           , not (null hs_ctxt)
           = Just deriv_decl_msg
230
231
           | otherwise
           = Nothing
232

233
    base_msg = text "Extra-constraint wildcard" <+> quotes pprAnonWildCard
234
235
236
237
238
239
240
                   <+> text "not allowed"

    deriv_decl_msg
      = hang base_msg
           2 (vcat [ text "except as the sole constraint"
                   , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ])

241
242
243
244
245
extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
extraConstraintWildCardsAllowed env
  = case rtke_ctxt env of
      TypeSigCtx {}       -> True
      ExprWithTySigCtx {} -> True
246
      DerivDeclCtx {}     -> True
247
      _                   -> False
248

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
249
-- | Finds free type and kind variables in a type,
250
251
252
253
--     without duplicates, and
--     without variables that are already in scope in LocalRdrEnv
--   NB: this includes named wildcards, which look like perfectly
--       ordinary type variables at this point
254
extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
255
extractFilteredRdrTyVars hs_ty
256
  = do { rdr_env <- getLocalRdrEnv
257
       ; return (filterInScope rdr_env (extractHsTyRdrTyVars hs_ty)) }
258

259
260
261
262
263
264
265
266
-- | Finds free type and kind variables in a type,
--     with duplicates, but
--     without variables that are already in scope in LocalRdrEnv
--   NB: this includes named wildcards, which look like perfectly
--       ordinary type variables at this point
extractFilteredRdrTyVarsDups :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups
extractFilteredRdrTyVarsDups hs_ty
  = do { rdr_env <- getLocalRdrEnv
267
       ; return (filterInScope rdr_env (extractHsTyRdrTyVarsDups hs_ty)) }
268

269
270
271
272
273
274
-- | When the NamedWildCards extension is enabled, partition_nwcs
-- removes type variables that start with an underscore from the
-- FreeKiTyVars in the argument and returns them in a separate list.
-- When the extension is disabled, the function returns the argument
-- and empty list.  See Note [Renaming named wild cards]
partition_nwcs :: FreeKiTyVars -> RnM (FreeKiTyVars, [Located RdrName])
275
partition_nwcs free_vars@(FKTV { fktv_tys = tys })
276
277
278
  = do { wildcards_enabled <- fmap (xopt LangExt.NamedWildCards) getDynFlags
       ; let (nwcs, no_nwcs) | wildcards_enabled = partition is_wildcard tys
                             | otherwise         = ([], tys)
279
             free_vars' = free_vars { fktv_tys = no_nwcs }
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
       ; return (free_vars', nwcs) }
  where
     is_wildcard :: Located RdrName -> Bool
     is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr))

{- Note [Renaming named wild cards]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Identifiers starting with an underscore are always parsed as type variables.
It is only here in the renamer that we give the special treatment.
See Note [The wildcard story for types] in HsTypes.

It's easy!  When we collect the implicitly bound type variables, ready
to bring them into scope, and NamedWildCards is on, we partition the
variables into the ones that start with an underscore (the named
wildcards) and the rest. Then we just add them to the hswc_wcs field
of the HsWildCardBndrs structure, and we are done.


*********************************************************
299
300
301
302
303
*                                                       *
           HsSigtype (i.e. no wildcards)
*                                                       *
****************************************************** -}

304
305
rnHsSigType :: HsDocContext -> LHsSigType GhcPs
            -> RnM (LHsSigType GhcRn, FreeVars)
306
307
308
-- Used for source-language type signatures
-- that cannot have wildcards
rnHsSigType ctx (HsIB { hsib_body = hs_ty })
309
  = do { traceRn "rnHsSigType" (ppr hs_ty)
310
       ; vars <- extractFilteredRdrTyVarsDups hs_ty
311
       ; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) vars $ \ vars ->
312
    do { (body', fvs) <- rnLHsType ctx hs_ty
313
314
315
       ; return ( HsIB { hsib_ext = vars
                       , hsib_body = body' }
                , fvs ) } }
316
rnHsSigType _ (XHsImplicitBndrs _) = panic "rnHsSigType"
317

318
rnImplicitBndrs :: Bool    -- True <=> bring into scope any free type variables
319
                           -- E.g.  f :: forall a. a->b
320
321
322
                           --  we do not want to bring 'b' into scope, hence False
                           -- But   f :: a -> b
                           --  we want to bring both 'a' and 'b' into scope
323
324
325
326
                -> FreeKiTyVarsWithDups
                                   -- Free vars of hs_ty (excluding wildcards)
                                   -- May have duplicates, which is
                                   -- checked here
327
                -> ([Name] -> RnM (a, FreeVars))
328
                -> RnM (a, FreeVars)
329
rnImplicitBndrs bind_free_tvs
330
331
                fvs_with_dups@(FKTV { fktv_kis = kvs_with_dups
                                    , fktv_tys = tvs_with_dups })
Simon Peyton Jones's avatar
Simon Peyton Jones committed
332
                thing_inside
333
  = do { let FKTV kvs tvs = rmDupsInRdrTyVars fvs_with_dups
334
335
336
337
             real_tvs | bind_free_tvs = tvs
                      | otherwise     = []
             -- We always bind over free /kind/ variables.
             -- Bind free /type/ variables only if there is no
Simon Peyton Jones's avatar
Simon Peyton Jones committed
338
339
340
341
342
343
344
345
346
             -- explicit forall.  E.g.
             --    f :: Proxy (a :: k) -> b
             --         Quantify over {k} and {a,b}
             --    g :: forall a. Proxy (a :: k) -> b
             --         Quantify over {k} and {}
             -- Note that we always do the implicit kind-quantification
             -- but, rather arbitrarily, we switch off the type-quantification
             -- if there is an explicit forall

347
       ; traceRn "rnImplicitBndrs" (vcat [ ppr kvs, ppr tvs, ppr real_tvs ])
348

349
350
351
352
353
       ; whenWOptM Opt_WarnImplicitKindVars $
         unless (bind_free_tvs || null kvs) $
         addWarnAt (Reason Opt_WarnImplicitKindVars) (getLoc (head kvs)) $
         implicit_kind_vars_msg kvs

354
       ; loc <- getSrcSpanM
355
          -- NB: kinds before tvs, as mandated by
356
          -- Note [Ordering of implicit variables]
357
       ; vars <- mapM (newLocalBndrRn . cL loc . unLoc) (kvs ++ real_tvs)
358

359
360
361
       ; traceRn "checkMixedVars2" $
           vcat [ text "kvs_with_dups" <+> ppr kvs_with_dups
                , text "tvs_with_dups" <+> ppr tvs_with_dups ]
362

363
364
       ; bindLocalNamesFV vars $
         thing_inside vars }
365
366
367
368
369
370
371
372
373
374
  where
    implicit_kind_vars_msg kvs =
      vcat [ text "An explicit" <+> quotes (text "forall") <+>
             text "was used, but the following kind variables" <+>
             text "are not quantified:" <+>
             hsep (punctuate comma (map (quotes . ppr) kvs))
           , text "Despite this fact, GHC will introduce them into scope," <+>
             text "but it will stop doing so in the future."
           , text "Suggested fix: add" <+>
             quotes (text "forall" <+> hsep (map ppr kvs) <> char '.') ]
375
376
377
378
379
380

{- ******************************************************
*                                                       *
           LHsType and HsType
*                                                       *
****************************************************** -}
381

Austin Seipp's avatar
Austin Seipp committed
382
{-
383
384
385
rnHsType is here because we call it from loadInstDecl, and I didn't
want a gratuitous knot.

386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
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"

402
403
This situation is now considered to be an error. See rnHsTyKi for case
HsForAllTy Qualified.
404

Simon Peyton Jones's avatar
Simon Peyton Jones committed
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
Note [QualTy in kinds]
~~~~~~~~~~~~~~~~~~~~~~
I was wondering whether QualTy could occur only at TypeLevel.  But no,
we can have a qualified type in a kind too. Here is an example:

  type family F a where
    F Bool = Nat
    F Nat  = Type

  type family G a where
    G Type = Type -> Type
    G ()   = Nat

  data X :: forall k1 k2. (F k1 ~ G k2) => k1 -> k2 -> Type where
    MkX :: X 'True '()

See that k1 becomes Bool and k2 becomes (), so the equality is
satisfied. If I write MkX :: X 'True 'False, compilation fails with a
suitable message:

  MkX :: X 'True '()
    • Couldn't match kind ‘G Bool’ with ‘Nat’
      Expected kind: G Bool
        Actual kind: F Bool

However: in a kind, the constraints in the QualTy must all be
equalities; or at least, any kinds with a class constraint are
uninhabited.
433
-}
434

435
436
437
438
439
440
data RnTyKiEnv
  = RTKE { rtke_ctxt  :: HsDocContext
         , rtke_level :: TypeOrKind  -- Am I renaming a type or a kind?
         , rtke_what  :: RnTyKiWhat  -- And within that what am I renaming?
         , rtke_nwcs  :: NameSet     -- These are the in-scope named wildcards
    }
441

442
443
444
data RnTyKiWhat = RnTypeBody
                | RnTopConstraint   -- Top-level context of HsSigWcTypes
                | RnConstraint      -- All other constraints
445

446
447
448
instance Outputable RnTyKiEnv where
  ppr (RTKE { rtke_level = lev, rtke_what = what
            , rtke_nwcs = wcs, rtke_ctxt = ctxt })
449
    = text "RTKE"
450
451
      <+> braces (sep [ ppr lev, ppr what, ppr wcs
                      , pprHsDocContext ctxt ])
452

453
454
455
456
instance Outputable RnTyKiWhat where
  ppr RnTypeBody      = text "RnTypeBody"
  ppr RnTopConstraint = text "RnTopConstraint"
  ppr RnConstraint    = text "RnConstraint"
457

458
459
460
461
mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv cxt level what
 = RTKE { rtke_level = level, rtke_nwcs = emptyNameSet
        , rtke_what = what, rtke_ctxt = cxt }
462

463
464
465
isRnKindLevel :: RnTyKiEnv -> Bool
isRnKindLevel (RTKE { rtke_level = KindLevel }) = True
isRnKindLevel _                                 = False
dreixel's avatar
dreixel committed
466

467
--------------
468
rnLHsType  :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
469
rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty
470

471
rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
472
473
rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys

474
rnHsType  :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
475
rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty
476

477
rnLHsKind  :: HsDocContext -> LHsKind GhcPs -> RnM (LHsKind GhcRn, FreeVars)
478
479
rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind

480
rnHsKind  :: HsDocContext -> HsKind GhcPs -> RnM (HsKind GhcRn, FreeVars)
481
rnHsKind ctxt kind = rnHsTyKi  (mkTyKiEnv ctxt KindLevel RnTypeBody) kind
dreixel's avatar
dreixel committed
482

My Nguyen's avatar
My Nguyen committed
483
484
485
486
487
488
-- renaming a type only, not a kind
rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs
                -> RnM (LHsTypeArg GhcRn, FreeVars)
rnLHsTypeArg ctxt (HsValArg ty)
   = do { (tys_rn, fvs) <- rnLHsType ctxt ty
        ; return (HsValArg tys_rn, fvs) }
489
rnLHsTypeArg ctxt (HsTypeArg l ki)
My Nguyen's avatar
My Nguyen committed
490
   = do { (kis_rn, fvs) <- rnLHsKind ctxt ki
491
        ; return (HsTypeArg l kis_rn, fvs) }
My Nguyen's avatar
My Nguyen committed
492
493
494
495
496
497
498
rnLHsTypeArg _ (HsArgPar sp)
   = return (HsArgPar sp, emptyFVs)

rnLHsTypeArgs :: HsDocContext -> [LHsTypeArg GhcPs]
                 -> RnM ([LHsTypeArg GhcRn], FreeVars)
rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args

499
--------------
500
501
rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs
              -> RnM (LHsContext GhcRn, FreeVars)
502
rnTyKiContext env (dL->L loc cxt)
503
  = do { traceRn "rncontext" (ppr cxt)
504
505
       ; let env' = env { rtke_what = RnConstraint }
       ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt
506
       ; return (cL loc cxt', fvs) }
507

508
509
rnContext :: HsDocContext -> LHsContext GhcPs
          -> RnM (LHsContext GhcRn, FreeVars)
510
rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta
511

512
--------------
513
rnLHsTyKi  :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
514
rnLHsTyKi env (dL->L loc ty)
515
516
  = setSrcSpan loc $
    do { (ty', fvs) <- rnHsTyKi env ty
517
       ; return (cL loc ty', fvs) }
518

519
rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
520
521

rnHsTyKi env ty@(HsForAllTy { hst_bndrs = tyvars, hst_body  = tau })
522
  = do { checkPolyKinds env ty
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
523
       ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty)
524
                           Nothing tyvars $ \ tyvars' ->
525
    do { (tau',  fvs) <- rnLHsTyKi env tau
526
527
       ; return ( HsForAllTy { hst_xforall = noExt, hst_bndrs = tyvars'
                             , hst_body =  tau' }
528
                , fvs) } }
529

Simon Peyton Jones's avatar
Simon Peyton Jones committed
530
rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })
531
  = do { checkPolyKinds env ty  -- See Note [QualTy in kinds]
532
533
       ; (ctxt', fvs1) <- rnTyKiContext env lctxt
       ; (tau',  fvs2) <- rnLHsTyKi env tau
534
535
       ; return (HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt'
                          , hst_body =  tau' }
536
537
                , fvs1 `plusFV` fvs2) }

538
rnHsTyKi env (HsTyVar _ ip (dL->L loc rdr_name))
539
540
541
542
543
544
545
546
  = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $
         unlessXOptM LangExt.PolyKinds $ addErr $
         withHsDocContext (rtke_ctxt env) $
         vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name)
              , text "Perhaps you intended to use PolyKinds" ]
           -- Any type variable at the kind level is illegal without the use
           -- of PolyKinds (see #14710)
       ; name <- rnTyVar env rdr_name
547
       ; return (HsTyVar noExt ip (cL loc name), unitFV name) }
548

549
rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2)
550
  = setSrcSpan (getLoc l_op) $
551
    do  { (l_op', fvs1) <- rnHsTyOp env ty l_op
552
        ; fix   <- lookupTyFixityRn l_op'
553
554
        ; (ty1', fvs2) <- rnLHsTyKi env ty1
        ; (ty2', fvs3) <- rnLHsTyKi env ty2
555
        ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExt t1 l_op' t2)
556
557
                               (unLoc l_op') fix ty1' ty2'
        ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }
558

559
rnHsTyKi env (HsParTy _ ty)
560
  = do { (ty', fvs) <- rnLHsTyKi env ty
561
       ; return (HsParTy noExt ty', fvs) }
562

563
rnHsTyKi env (HsBangTy _ b ty)
564
  = do { (ty', fvs) <- rnLHsTyKi env ty
565
       ; return (HsBangTy noExt b ty', fvs) }
566

567
rnHsTyKi env ty@(HsRecTy _ flds)
568
569
570
  = do { let ctxt = rtke_ctxt env
       ; fls          <- get_fields ctxt
       ; (flds', fvs) <- rnConDeclFields ctxt fls flds
571
       ; return (HsRecTy noExt flds', fvs) }
572
573
574
575
  where
    get_fields (ConDeclCtx names)
      = concatMapM (lookupConstructorFields . unLoc) names
    get_fields _
576
      = do { addErr (hang (text "Record syntax is illegal here:")
577
578
579
                                   2 (ppr ty))
           ; return [] }

580
rnHsTyKi env (HsFunTy _ ty1 ty2)
581
  = do { (ty1', fvs1) <- rnLHsTyKi env ty1
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
582
        -- Might find a for-all as the arg of a function type
583
       ; (ty2', fvs2) <- rnLHsTyKi env ty2
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
584
585
        -- Or as the result.  This happens when reading Prelude.hi
        -- when we find return :: forall m. Monad m -> forall a. a -> m a
586

gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
587
        -- Check for fixity rearrangements
588
       ; res_ty <- mkHsOpTyRn (HsFunTy noExt) funTyConName funTyFixity ty1' ty2'
589
       ; return (res_ty, fvs1 `plusFV` fvs2) }
dreixel's avatar
dreixel committed
590

591
rnHsTyKi env listTy@(HsListTy _ ty)
592
  = do { data_kinds <- xoptM LangExt.DataKinds
593
594
595
       ; when (not data_kinds && isRnKindLevel env)
              (addErr (dataKindsErr env listTy))
       ; (ty', fvs) <- rnLHsTyKi env ty
596
       ; return (HsListTy noExt ty', fvs) }
597

598
rnHsTyKi env t@(HsKindSig _ ty k)
599
  = do { checkPolyKinds env t
600
       ; kind_sigs_ok <- xoptM LangExt.KindSignatures
601
602
603
       ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty)
       ; (ty', fvs1) <- rnLHsTyKi env ty
       ; (k', fvs2)  <- rnLHsTyKi (env { rtke_level = KindLevel }) k
604
       ; return (HsKindSig noExt ty' k', fvs1 `plusFV` fvs2) }
605

606
607
-- Unboxed tuples are allowed to have poly-typed arguments.  These
-- sometimes crop up as a result of CPR worker-wrappering dictionaries.
608
rnHsTyKi env tupleTy@(HsTupleTy _ tup_con tys)
609
  = do { data_kinds <- xoptM LangExt.DataKinds
610
611
612
       ; when (not data_kinds && isRnKindLevel env)
              (addErr (dataKindsErr env tupleTy))
       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
613
       ; return (HsTupleTy noExt tup_con tys', fvs) }
614

615
rnHsTyKi env sumTy@(HsSumTy _ tys)
616
617
618
619
  = do { data_kinds <- xoptM LangExt.DataKinds
       ; when (not data_kinds && isRnKindLevel env)
              (addErr (dataKindsErr env sumTy))
       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
620
       ; return (HsSumTy noExt tys', fvs) }
621

622
-- Ensure that a type-level integer is nonnegative (#8306, #8412)
623
rnHsTyKi env tyLit@(HsTyLit _ t)
624
  = do { data_kinds <- xoptM LangExt.DataKinds
625
       ; unless data_kinds (addErr (dataKindsErr env tyLit))
626
       ; when (negLit t) (addErr negLitErr)
627
       ; checkPolyKinds env tyLit
628
       ; return (HsTyLit noExt t, emptyFVs) }
629
  where
Alan Zimmerman's avatar
Alan Zimmerman committed
630
631
    negLit (HsStrTy _ _) = False
    negLit (HsNumTy _ i) = i < 0
632
    negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit
633

634
rnHsTyKi env (HsAppTy _ ty1 ty2)
635
636
  = do { (ty1', fvs1) <- rnLHsTyKi env ty1
       ; (ty2', fvs2) <- rnLHsTyKi env ty2
637
       ; return (HsAppTy noExt ty1' ty2', fvs1 `plusFV` fvs2) }
638

639
rnHsTyKi env (HsAppKindTy l ty k)
My Nguyen's avatar
My Nguyen committed
640
  = do { kind_app <- xoptM LangExt.TypeApplications
641
       ; unless kind_app (addErr (typeAppErr "kind" k))
My Nguyen's avatar
My Nguyen committed
642
643
       ; (ty', fvs1) <- rnLHsTyKi env ty
       ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k
644
       ; return (HsAppKindTy l ty' k', fvs1 `plusFV` fvs2) }
My Nguyen's avatar
My Nguyen committed
645

646
rnHsTyKi env t@(HsIParamTy _ n ty)
647
648
  = do { notInKinds env t
       ; (ty', fvs) <- rnLHsTyKi env ty
649
       ; return (HsIParamTy noExt n ty', fvs) }
650

651
652
653
rnHsTyKi _ (HsStarTy _ isUni)
  = return (HsStarTy noExt isUni, emptyFVs)

654
655
rnHsTyKi _ (HsSpliceTy _ sp)
  = rnSpliceType sp
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
656

657
rnHsTyKi env (HsDocTy _ ty haddock_doc)
658
  = do { (ty', fvs) <- rnLHsTyKi env ty
659
       ; haddock_doc' <- rnLHsDoc haddock_doc
660
       ; return (HsDocTy noExt ty' haddock_doc', fvs) }
661

662
663
rnHsTyKi _ (XHsType (NHsCoreTy ty))
  = return (XHsType (NHsCoreTy ty), emptyFVs)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
664
    -- The emptyFVs probably isn't quite right
665
666
    -- but I don't think it matters

667
rnHsTyKi env ty@(HsExplicitListTy _ ip tys)
668
  = do { checkPolyKinds env ty
669
       ; data_kinds <- xoptM LangExt.DataKinds
670
671
       ; unless data_kinds (addErr (dataKindsErr env ty))
       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
672
       ; return (HsExplicitListTy noExt ip tys', fvs) }
673

674
rnHsTyKi env ty@(HsExplicitTupleTy _ tys)
675
  = do { checkPolyKinds env ty
676
       ; data_kinds <- xoptM LangExt.DataKinds
677
678
       ; unless data_kinds (addErr (dataKindsErr env ty))
       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys
679
       ; return (HsExplicitTupleTy noExt tys', fvs) }
680

681
682
rnHsTyKi env (HsWildCardTy _)
  = do { checkAnonWildCard env
My Nguyen's avatar
My Nguyen committed
683
       ; return (HsWildCardTy noExt, emptyFVs) }
thomasw's avatar
thomasw committed
684

685
--------------
686
687
rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name
rnTyVar env rdr_name
688
  = do { name <- lookupTypeOccRn rdr_name
689
690
       ; checkNamedWildCard env name
       ; return name }
691

692
rnLTyVar :: Located RdrName -> RnM (Located Name)
693
-- Called externally; does not deal with wildards
694
rnLTyVar (dL->L loc rdr_name)
695
  = do { tyvar <- lookupTypeOccRn rdr_name
696
       ; return (cL loc tyvar) }
697

698
699
--------------
rnHsTyOp :: Outputable a
700
701
         => RnTyKiEnv -> a -> Located RdrName
         -> RnM (Located Name, FreeVars)
702
rnHsTyOp env overall_ty (dL->L loc op)
703
  = do { ops_ok <- xoptM LangExt.TypeOperators
704
       ; op' <- rnTyVar env op
705
       ; unless (ops_ok || op' `hasKey` eqTyConKey) $
706
           addErr (opTyErr op overall_ty)
707
       ; let l_op' = cL loc op'
708
709
       ; return (l_op', unitFV op') }

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
710
--------------
711
712
notAllowed :: SDoc -> SDoc
notAllowed doc
713
  = text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed")
714
715
716

checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM ()
checkWildCard env (Just doc)
717
  = addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))]
718
719
checkWildCard _ Nothing
  = return ()
720

721
checkAnonWildCard :: RnTyKiEnv -> RnM ()
Gabor Greif's avatar
Gabor Greif committed
722
-- Report an error if an anonymous wildcard is illegal here
723
checkAnonWildCard env
724
725
726
727
  = checkWildCard env mb_bad
  where
    mb_bad :: Maybe SDoc
    mb_bad | not (wildCardsAllowed env)
728
           = Just (notAllowed pprAnonWildCard)
729
730
731
732
733
734
           | otherwise
           = case rtke_what env of
               RnTypeBody      -> Nothing
               RnConstraint    -> Just constraint_msg
               RnTopConstraint -> Just constraint_msg

735
736
    constraint_msg = hang
                         (notAllowed pprAnonWildCard <+> text "in a constraint")
737
                        2 hint_msg
738
739
    hint_msg = vcat [ text "except as the last top-level constraint of a type signature"
                    , nest 2 (text "e.g  f :: (Eq a, _) => blah") ]
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754

checkNamedWildCard :: RnTyKiEnv -> Name -> RnM ()
-- Report an error if a named wildcard is illegal here
checkNamedWildCard env name
  = checkWildCard env mb_bad
  where
    mb_bad | not (name `elemNameSet` rtke_nwcs env)
           = Nothing  -- Not a wildcard
           | not (wildCardsAllowed env)
           = Just (notAllowed (ppr name))
           | otherwise
           = case rtke_what env of
               RnTypeBody      -> Nothing   -- Allowed
               RnTopConstraint -> Nothing   -- Allowed
               RnConstraint    -> Just constraint_msg
755
    constraint_msg = notAllowed (ppr name) <+> text "in a constraint"
756
757

wildCardsAllowed :: RnTyKiEnv -> Bool
758
-- ^ In what contexts are wildcards permitted
759
760
wildCardsAllowed env
   = case rtke_ctxt env of
761
762
763
764
765
766
767
768
       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
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
769
       HsTypeCtx {}        -> True
770
771
       _                   -> False

My Nguyen's avatar
My Nguyen committed
772

773

774
---------------
775
776
-- | Ensures either that we're in a type or that -XPolyKinds is set
checkPolyKinds :: Outputable ty
777
                => RnTyKiEnv
778
779
                -> ty      -- ^ type
                -> RnM ()
780
checkPolyKinds env ty
781
  | isRnKindLevel env
782
783
  = do { polykinds <- xoptM LangExt.PolyKinds
       ; unless polykinds $
784
         addErr (text "Illegal kind:" <+> ppr ty $$
785
786
                 text "Did you mean to enable PolyKinds?") }
checkPolyKinds _ _ = return ()
787
788

notInKinds :: Outputable ty
789
           => RnTyKiEnv
790
791
           -> ty
           -> RnM ()
792
793
notInKinds env ty
  | isRnKindLevel env
794
  = addErr (text "Illegal kind:" <+> ppr ty)
795
796
notInKinds _ _ = return ()

797
798
799
800
801
802
{- *****************************************************
*                                                      *
          Binding type variables
*                                                      *
***************************************************** -}

803
bindSigTyVarsFV :: [Name]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
804
805
                -> RnM (a, FreeVars)
                -> RnM (a, FreeVars)
806
807
808
809
-- 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
810
  = do  { scoped_tyvars <- xoptM LangExt.ScopedTypeVariables
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
811
812
813
814
        ; if not scoped_tyvars then
                thing_inside
          else
                bindLocalNamesFV tvs thing_inside }
815

816
817
818
819
820
821
822
823
824
825
826
-- | 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 }

827
---------------
828
829
bindHsQTyVars :: forall a b.
                 HsDocContext
830
831
832
833
834
835
              -> Maybe SDoc         -- Just d => check for unused tvs
                                    --   d is a phrase like "in the type ..."
              -> Maybe a            -- Just _  => an associated type decl
              -> [Located RdrName]  -- Kind variables from scope, no dups
              -> (LHsQTyVars GhcPs)
              -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
Simon Peyton Jones's avatar
Simon Peyton Jones committed
836
                  -- The Bool is True <=> all kind variables used in the
837
                  -- kind signature are bound on the left.  Reason:
Tobias Dammers's avatar
Tobias Dammers committed
838
                  -- the last clause of Note [CUSKs: Complete user-supplied
839
                  -- kind signatures] in HsDecls
840
              -> RnM (b, FreeVars)
841

Simon Peyton Jones's avatar
Simon Peyton Jones committed
842
-- See Note [bindHsQTyVars examples]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
843
-- (a) Bring kind variables into scope
844
845
--     both (i)  passed in body_kv_occs
--     and  (ii) mentioned in the kinds of hsq_bndrs
846
-- (b) Bring type variables into scope