RnTypes.hs 64.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

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 56
import qualified GHC.LanguageExtensions as LangExt

57
import Data.List        ( nubBy )
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
58
import Control.Monad    ( unless, when )
59

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

64 65
#include "HsVersions.h"

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

Austin Seipp's avatar
Austin Seipp committed
70
*********************************************************
71 72 73
*                                                       *
           HsSigWcType (i.e with wildcards)
*                                                       *
Austin Seipp's avatar
Austin Seipp committed
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 103 104
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
105
  = rnImplicitBndrs no_implicit_if_forall (hswc_body wc_ty) $ \ vars ->
106
    rn_hs_wc_type ctxt wc_ty $ \ wc_ty' ->
107
    thing_inside (HsIB { hsib_vars = vars
108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130
                       , 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) } }
131

132 133 134 135 136 137 138
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 }))
139
  = bindLHsTyVarBndrs ctxt Nothing [] tvs $ \ _ tvs' ->
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 181 182
    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) }
183

184 185 186 187 188 189 190 191 192 193 194 195

{- ******************************************************
*                                                       *
           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 })
196
  = rnImplicitBndrs True hs_ty $ \ vars ->
197
    do { (body', fvs) <- rnLHsType ctx hs_ty
198
       ; return (HsIB { hsib_vars = vars
199 200 201 202 203 204 205
                      , 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
206
                -> ([Name] -> RnM (a, FreeVars))
207 208 209
                -> RnM (a, FreeVars)
rnImplicitBndrs no_implicit_if_forall hs_ty@(L loc _) thing_inside
  = do { rdr_env <- getLocalRdrEnv
210 211 212 213
       ; free_vars <- filterInScope rdr_env <$>
                      extractHsTyRdrTyVars hs_ty
       ; let real_tv_rdrs  -- Implicit quantification only if
                        -- there is no explicit forall
214 215
               | no_implicit_if_forall
               , L _ (HsForAllTy {}) <- hs_ty = []
216 217 218 219 220 221 222
               | 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 }
223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247

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
*                                                       *
****************************************************** -}
248

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

253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268
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"

269 270
This situation is now considered to be an error. See rnHsTyKi for case
HsForAllTy Qualified.
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 298 299

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
300
-}
301

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

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

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

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

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

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

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

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

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

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

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

350 351 352 353
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
354 355
       ; warnUnusedForAlls (inTypeDoc ty) tyvars' fvs
       ; return ( HsForAllTy { hst_bndrs = tyvars', hst_body =  tau' }
356
                , fvs) }}
357

358 359 360 361 362
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
363 364 365 366 367 368
       ; 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) }
369

370 371 372 373 374 375 376 377 378
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]) }
379

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

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

Alan Zimmerman's avatar
Alan Zimmerman committed
388 389 390 391 392 393 394 395
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) }

396 397 398
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
399
       ; (flds', fvs) <- rnConDeclFields [] doc flds
400
       ; return (HsRecTy flds', fvs) }
401

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

553 554 555 556 557 558 559 560 561 562
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) }
563
         -- emptyFVs: this occurrence does not refer to a
564 565 566 567 568 569 570 571
         --           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
572 573
               RnTypeBody _    -> Nothing
               RnConstraint _  -> Just constraint_msg
574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592
               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
593

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

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

605 606 607 608
--------------
rnHsTyOp :: Outputable a
         => RnTyKiWhat -> a -> Located RdrName -> RnM (Located Name, FreeVars)
rnHsTyOp what overall_ty (L loc op)
609
  = do { ops_ok <- xoptM LangExt.TypeOperators
610 611 612 613 614 615 616 617 618
       ; 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
619
--------------
dreixel's avatar
dreixel committed
620
rnLHsTypes :: HsDocContext -> [LHsType RdrName]
621 622
           -> RnM ([LHsType Name], FreeVars)
rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys
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 683 684
--------------
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)
685

686

687 688 689 690 691 692 693 694
---------------
-- | 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
695
  = do { type_in_type <- xoptM LangExt.TypeInType
696 697 698 699 700 701 702 703 704 705 706 707 708 709
       ; 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 ()

710 711 712 713 714 715
{- *****************************************************
*                                                      *
          Binding type variables
*                                                      *
***************************************************** -}

716
bindSigTyVarsFV :: [Name]
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
717 718
                -> RnM (a, FreeVars)
                -> RnM (a, FreeVars)
719 720 721 722
-- 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
723
  = do  { scoped_tyvars <- xoptM LangExt.ScopedTypeVariables
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
724 725 726 727
        ; if not scoped_tyvars then
                thing_inside
          else
                bindLocalNamesFV tvs thing_inside }
728

729 730 731 732 733 734 735 736 737 738 739
-- | 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 }

740
---------------
741 742 743 744 745 746
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
747 748
              -> (LHsQTyVars Name -> RnM (b, FreeVars))
              -> RnM (b, FreeVars)
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
749 750
-- (a) Bring kind variables into scope
--     both (i)  passed in (kv_bndrs)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
751
--     and  (ii) mentioned in the kinds of tv_bndrs
752
-- (b) Bring type variables into scope
753
bindHsQTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside
754 755 756 757 758 759 760 761 762 763 764 765 766 767
  = 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))
768
                  -> RnM (b, FreeVars)
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
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
820
           ; sig_ok <- xoptM LangExt.KindSignatures
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
           ; 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
869
       ; type_in_type <- xoptM LangExt.TypeInType
870 871 872
       ; unless type_in_type $
         mapM_ (check_tv_used_in_kind tv_names) bound_kvs

873
       ; poly_kinds <- xoptM LangExt.PolyKinds
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 899 900
       ; 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
901

902
           _                -> newLocalBndrRn (L loc rdr) }
903

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

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

914 915 916
collectWildCards :: LHsType name -> [Located (HsWildCardInfo name)]
-- | Extract all wild cards from a type.
collectWildCards lty = go lty
917
  where
thomasw's avatar
thomasw committed
918
    go (L loc ty) = case ty of
919
      HsAppsTy tys            -> gos (mapMaybe prefix_types_only tys)
thomasw's avatar
thomasw committed
920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935
      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
936 937 938 939
      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
940 941 942
      -- HsQuasiQuoteTy, HsSpliceTy, HsCoreTy, HsTyLit
      _ -> mempty

943
    gos = mconcat . map go
thomasw's avatar
thomasw committed
944

945 946 947
    prefix_types_only (HsAppPrefix ty) = Just ty
    prefix_types_only (HsAppInfix _)   = Nothing

thomasw's avatar
thomasw committed
948

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

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
961
-}
962

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

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


{-
*********************************************************
*                                                       *
        Contexts
*                                                       *
*********************************************************
-}
991

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

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

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

1009 1010 1011 1012 1013 1014 1015 1016 1017
@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.
1018
Infix types are read in a *right-associative* way, so that
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1019
        a `op` b `op` c
1020
is always read in as
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1021
        a `op` (b `op` c)
1022 1023 1024

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

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

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

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

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

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

1064

1065
---------------------------
gmainlan@microsoft.com's avatar
gmainlan@microsoft.com committed
1066 1067 1068