{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

\section[RnSource]{Main pass of renamer}
-}

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeFamilies #-}

module RnTypes (
        -- Type related stuff
        rnHsType, rnLHsType, rnLHsTypes, rnContext,
        rnHsKind, rnLHsKind, rnLHsTypeArgs,
        rnHsSigType, rnHsWcType,
        HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped,
        newTyVarNameRn,
        rnConDeclFields,
        rnLTyVar,

        -- Precence related stuff
        mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
        checkPrecMatch, checkSectionPrec,

        -- Binding related stuff
        bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs,
        bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,
        extractFilteredRdrTyVars, extractFilteredRdrTyVarsDups,
        extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
        extractHsTyRdrTyVarsDups, extractHsTysRdrTyVars,
        extractHsTysRdrTyVarsDups, rmDupsInRdrTyVars,
        extractRdrKindSigVars, extractDataDefnKindVars,
        extractHsTvBndrs, extractHsTyArgRdrKiTyVarsDup,
        freeKiTyVarsAllVars, freeKiTyVarsKindVars, freeKiTyVarsTypeVars,
        elemRdr
  ) where

import GhcPrelude

import {-# SOURCE #-} RnSplice( rnSpliceType )

import DynFlags
import HsSyn
import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )
import RnEnv
import RnUtils          ( HsDocContext(..), withHsDocContext, mapFvRn
                        , pprHsDocContext, bindLocalNamesFV, typeAppErr
                        , newLocalBndrRn, checkDupRdrNames, checkShadowedRdrNames )
import RnFixity         ( lookupFieldFixityRn, lookupFixityRn
                        , lookupTyFixityRn )
import TcRnMonad
import RdrName
import PrelNames
import TysPrim          ( funTyConName )
import Name
import SrcLoc
import NameSet
import FieldLabel

import Util
import ListSetOps       ( deleteBys )
import BasicTypes       ( compareFixity, funTyFixity, negateFixity,
                          Fixity(..), FixityDirection(..), LexicalFixity(..) )
import Outputable
import FastString
import Maybes
import qualified GHC.LanguageExtensions as LangExt

import Data.List          ( nubBy, partition, (\\) )
import Control.Monad      ( unless, when )

#include "GhclibHsVersions.h"

{-
These type renamers are in a separate module, rather than in (say) RnSource,
to break several loop.

*********************************************************
*                                                       *
           HsSigWcType (i.e with wildcards)
*                                                       *
*********************************************************
-}

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 :: HsSigWcTypeScoping
-> HsDocContext
-> LHsSigWcType GhcPs
-> RnM (LHsSigWcType GhcRn, FreeVars)
rnHsSigWcType HsSigWcTypeScoping
scoping HsDocContext
doc LHsSigWcType GhcPs
sig_ty
  = HsSigWcTypeScoping
-> HsDocContext
-> LHsSigWcType GhcPs
-> (LHsSigWcType GhcRn -> RnM (LHsSigWcType GhcRn, FreeVars))
-> RnM (LHsSigWcType GhcRn, FreeVars)
forall a.
HsSigWcTypeScoping
-> HsDocContext
-> LHsSigWcType GhcPs
-> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rn_hs_sig_wc_type HsSigWcTypeScoping
scoping HsDocContext
doc LHsSigWcType GhcPs
sig_ty ((LHsSigWcType GhcRn -> RnM (LHsSigWcType GhcRn, FreeVars))
 -> RnM (LHsSigWcType GhcRn, FreeVars))
-> (LHsSigWcType GhcRn -> RnM (LHsSigWcType GhcRn, FreeVars))
-> RnM (LHsSigWcType GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ \LHsSigWcType GhcRn
sig_ty' ->
    (LHsSigWcType GhcRn, FreeVars)
-> RnM (LHsSigWcType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsSigWcType GhcRn
sig_ty', FreeVars
emptyFVs)

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
                    -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
                    -> RnM (a, FreeVars)
-- Used for
--   - Signatures on binders in a RULE
--   - Pattern type signatures
-- Wildcards are allowed
-- type signatures on binders only allowed with ScopedTypeVariables
rnHsSigWcTypeScoped :: HsSigWcTypeScoping
-> HsDocContext
-> LHsSigWcType GhcPs
-> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnHsSigWcTypeScoped HsSigWcTypeScoping
scoping HsDocContext
ctx LHsSigWcType GhcPs
sig_ty LHsSigWcType GhcRn -> RnM (a, FreeVars)
thing_inside
  = do { Bool
ty_sig_okay <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ScopedTypeVariables
       ; Bool -> MsgDoc -> TcRn ()
checkErr Bool
ty_sig_okay (LHsSigWcType GhcPs -> MsgDoc
unexpectedTypeSigErr LHsSigWcType GhcPs
sig_ty)
       ; HsSigWcTypeScoping
-> HsDocContext
-> LHsSigWcType GhcPs
-> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall a.
HsSigWcTypeScoping
-> HsDocContext
-> LHsSigWcType GhcPs
-> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rn_hs_sig_wc_type HsSigWcTypeScoping
scoping HsDocContext
ctx LHsSigWcType GhcPs
sig_ty LHsSigWcType GhcRn -> RnM (a, FreeVars)
thing_inside
       }

rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs
                  -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
                  -> RnM (a, FreeVars)
-- rn_hs_sig_wc_type is used for source-language type signatures
rn_hs_sig_wc_type :: HsSigWcTypeScoping
-> HsDocContext
-> LHsSigWcType GhcPs
-> (LHsSigWcType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rn_hs_sig_wc_type HsSigWcTypeScoping
scoping HsDocContext
ctxt
                  (HsWC { hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = HsIB { hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = LHsType GhcPs
hs_ty }})
                  LHsSigWcType GhcRn -> RnM (a, FreeVars)
thing_inside
  = do { FreeKiTyVarsWithDups
free_vars <- LHsType GhcPs -> RnM FreeKiTyVarsWithDups
extractFilteredRdrTyVarsDups LHsType GhcPs
hs_ty
       ; (FreeKiTyVarsWithDups
tv_rdrs, [Located RdrName]
nwc_rdrs') <- FreeKiTyVarsWithDups
-> RnM (FreeKiTyVarsWithDups, [Located RdrName])
partition_nwcs FreeKiTyVarsWithDups
free_vars
       ; let nwc_rdrs :: [Located RdrName]
nwc_rdrs = [Located RdrName] -> [Located RdrName]
forall a. Eq a => [Located a] -> [Located a]
nubL [Located RdrName]
nwc_rdrs'
             bind_free_tvs :: Bool
bind_free_tvs = case HsSigWcTypeScoping
scoping of
                               HsSigWcTypeScoping
AlwaysBind       -> Bool
True
                               HsSigWcTypeScoping
BindUnlessForall -> Bool -> Bool
not (LHsType GhcPs -> Bool
forall p. LHsType p -> Bool
isLHsForAllTy LHsType GhcPs
hs_ty)
                               HsSigWcTypeScoping
NeverBind        -> Bool
False
       ; Bool
-> FreeKiTyVarsWithDups
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall a.
Bool
-> FreeKiTyVarsWithDups
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnImplicitBndrs Bool
bind_free_tvs FreeKiTyVarsWithDups
tv_rdrs (([Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars))
-> ([Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [Name]
vars ->
    do { ([Name]
wcs, LHsType GhcRn
hs_ty', FreeVars
fvs1) <- HsDocContext
-> [Located RdrName]
-> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBody HsDocContext
ctxt [Located RdrName]
nwc_rdrs LHsType GhcPs
hs_ty
       ; let sig_ty' :: LHsSigWcType GhcRn
sig_ty' = HsWC :: forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC { hswc_ext :: XHsWC GhcRn (HsImplicitBndrs GhcRn (LHsType GhcRn))
hswc_ext = [Name]
XHsWC GhcRn (HsImplicitBndrs GhcRn (LHsType GhcRn))
wcs, hswc_body :: HsImplicitBndrs GhcRn (LHsType GhcRn)
hswc_body = HsImplicitBndrs GhcRn (LHsType GhcRn)
ib_ty' }
             ib_ty' :: HsImplicitBndrs GhcRn (LHsType GhcRn)
ib_ty'  = HsIB :: forall pass thing.
XHsIB pass thing -> thing -> HsImplicitBndrs pass thing
HsIB { hsib_ext :: XHsIB GhcRn (LHsType GhcRn)
hsib_ext = [Name]
XHsIB GhcRn (LHsType GhcRn)
vars
                            , hsib_body :: LHsType GhcRn
hsib_body = LHsType GhcRn
hs_ty' }
       ; (a
res, FreeVars
fvs2) <- LHsSigWcType GhcRn -> RnM (a, FreeVars)
thing_inside LHsSigWcType GhcRn
sig_ty'
       ; (a, FreeVars) -> RnM (a, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
res, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) } }
rn_hs_sig_wc_type HsSigWcTypeScoping
_ HsDocContext
_ (HsWC XHsWC GhcPs (HsImplicitBndrs GhcPs (LHsType GhcPs))
_ (XHsImplicitBndrs XXHsImplicitBndrs GhcPs (LHsType GhcPs)
_)) LHsSigWcType GhcRn -> RnM (a, FreeVars)
_
  = String -> RnM (a, FreeVars)
forall a. String -> a
panic String
"rn_hs_sig_wc_type"
rn_hs_sig_wc_type HsSigWcTypeScoping
_ HsDocContext
_ (XHsWildCardBndrs XXHsWildCardBndrs GhcPs (HsImplicitBndrs GhcPs (LHsType GhcPs))
_) LHsSigWcType GhcRn -> RnM (a, FreeVars)
_
  = String -> RnM (a, FreeVars)
forall a. String -> a
panic String
"rn_hs_sig_wc_type"

rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
rnHsWcType HsDocContext
ctxt (HsWC { hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = LHsType GhcPs
hs_ty })
  = do { FreeKiTyVarsWithDups
free_vars <- LHsType GhcPs -> RnM FreeKiTyVarsWithDups
extractFilteredRdrTyVars LHsType GhcPs
hs_ty
       ; (FreeKiTyVarsWithDups
_, [Located RdrName]
nwc_rdrs) <- FreeKiTyVarsWithDups
-> RnM (FreeKiTyVarsWithDups, [Located RdrName])
partition_nwcs FreeKiTyVarsWithDups
free_vars
       ; ([Name]
wcs, LHsType GhcRn
hs_ty', FreeVars
fvs) <- HsDocContext
-> [Located RdrName]
-> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBody HsDocContext
ctxt [Located RdrName]
nwc_rdrs LHsType GhcPs
hs_ty
       ; let sig_ty' :: LHsWcType GhcRn
sig_ty' = HsWC :: forall pass thing.
XHsWC pass thing -> thing -> HsWildCardBndrs pass thing
HsWC { hswc_ext :: XHsWC GhcRn (LHsType GhcRn)
hswc_ext = [Name]
XHsWC GhcRn (LHsType GhcRn)
wcs, hswc_body :: LHsType GhcRn
hswc_body = LHsType GhcRn
hs_ty' }
       ; (LHsWcType GhcRn, FreeVars) -> RnM (LHsWcType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsWcType GhcRn
sig_ty', FreeVars
fvs) }
rnHsWcType HsDocContext
_ (XHsWildCardBndrs XXHsWildCardBndrs GhcPs (LHsType GhcPs)
_) = String -> RnM (LHsWcType GhcRn, FreeVars)
forall a. String -> a
panic String
"rnHsWcType"

rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs
         -> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBody :: HsDocContext
-> [Located RdrName]
-> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBody HsDocContext
ctxt [Located RdrName]
nwc_rdrs LHsType GhcPs
hs_ty
  = do { [Name]
nwcs <- (Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> [Located RdrName] -> IOEnv (Env TcGblEnv TcLclEnv) [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newLocalBndrRn [Located RdrName]
nwc_rdrs
       ; let env :: RnTyKiEnv
env = RTKE :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> FreeVars -> RnTyKiEnv
RTKE { rtke_level :: TypeOrKind
rtke_level = TypeOrKind
TypeLevel
                        , rtke_what :: RnTyKiWhat
rtke_what  = RnTyKiWhat
RnTypeBody
                        , rtke_nwcs :: FreeVars
rtke_nwcs  = [Name] -> FreeVars
mkNameSet [Name]
nwcs
                        , rtke_ctxt :: HsDocContext
rtke_ctxt  = HsDocContext
ctxt }
       ; (LHsType GhcRn
hs_ty', FreeVars
fvs) <- [Name]
-> RnM (LHsType GhcRn, FreeVars) -> RnM (LHsType GhcRn, FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
nwcs (RnM (LHsType GhcRn, FreeVars) -> RnM (LHsType GhcRn, FreeVars))
-> RnM (LHsType GhcRn, FreeVars) -> RnM (LHsType GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
                          RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
forall a a.
(HasSrcSpan a, HasSrcSpan a, SrcSpanLess a ~ HsType GhcRn,
 SrcSpanLess a ~ HsType GhcPs) =>
RnTyKiEnv -> a -> TcRn (a, FreeVars)
rn_lty RnTyKiEnv
env LHsType GhcPs
hs_ty
       ; ([Name], LHsType GhcRn, FreeVars)
-> RnM ([Name], LHsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name]
nwcs, LHsType GhcRn
hs_ty', FreeVars
fvs) }
  where
    rn_lty :: RnTyKiEnv -> a -> TcRn (a, FreeVars)
rn_lty RnTyKiEnv
env (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess a
hs_ty)
      = SrcSpan -> TcRn (a, FreeVars) -> TcRn (a, FreeVars)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn (a, FreeVars) -> TcRn (a, FreeVars))
-> TcRn (a, FreeVars) -> TcRn (a, FreeVars)
forall a b. (a -> b) -> a -> b
$
        do { (HsType GhcRn
hs_ty', FreeVars
fvs) <- RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rn_ty RnTyKiEnv
env HsType GhcPs
SrcSpanLess a
hs_ty
           ; (a, FreeVars) -> TcRn (a, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess a -> a
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc HsType GhcRn
SrcSpanLess a
hs_ty', FreeVars
fvs) }

    rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
    -- A lot of faff just to allow the extra-constraints wildcard to appear
    rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rn_ty RnTyKiEnv
env hs_ty :: HsType GhcPs
hs_ty@(HsForAllTy { hst_bndrs :: forall pass. HsType pass -> [LHsTyVarBndr pass]
hst_bndrs = [LHsTyVarBndr GhcPs]
tvs, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcPs
hs_body })
      = HsDocContext
-> Maybe MsgDoc
-> Maybe Any
-> [LHsTyVarBndr GhcPs]
-> ([LHsTyVarBndr GhcRn] -> RnM (HsType GhcRn, FreeVars))
-> RnM (HsType GhcRn, FreeVars)
forall a b.
HsDocContext
-> Maybe MsgDoc
-> Maybe a
-> [LHsTyVarBndr GhcPs]
-> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs (RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env) (MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just (MsgDoc -> Maybe MsgDoc) -> MsgDoc -> Maybe MsgDoc
forall a b. (a -> b) -> a -> b
$ HsType GhcPs -> MsgDoc
inTypeDoc HsType GhcPs
hs_ty) Maybe Any
forall a. Maybe a
Nothing [LHsTyVarBndr GhcPs]
tvs (([LHsTyVarBndr GhcRn] -> RnM (HsType GhcRn, FreeVars))
 -> RnM (HsType GhcRn, FreeVars))
-> ([LHsTyVarBndr GhcRn] -> RnM (HsType GhcRn, FreeVars))
-> RnM (HsType GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [LHsTyVarBndr GhcRn]
tvs' ->
        do { (LHsType GhcRn
hs_body', FreeVars
fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
forall a a.
(HasSrcSpan a, HasSrcSpan a, SrcSpanLess a ~ HsType GhcRn,
 SrcSpanLess a ~ HsType GhcPs) =>
RnTyKiEnv -> a -> TcRn (a, FreeVars)
rn_lty RnTyKiEnv
env LHsType GhcPs
hs_body
           ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsForAllTy :: forall pass.
XForAllTy pass
-> [LHsTyVarBndr pass] -> LHsType pass -> HsType pass
HsForAllTy { hst_xforall :: XForAllTy GhcRn
hst_xforall = NoExt
XForAllTy GhcRn
noExt, hst_bndrs :: [LHsTyVarBndr GhcRn]
hst_bndrs = [LHsTyVarBndr GhcRn]
tvs'
                                , hst_body :: LHsType GhcRn
hst_body = LHsType GhcRn
hs_body' }, FreeVars
fvs) }

    rn_ty RnTyKiEnv
env (HsQualTy { hst_ctxt :: forall pass. HsType pass -> LHsContext pass
hst_ctxt = LHsContext GhcPs -> Located (SrcSpanLess (LHsContext GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
cx SrcSpanLess (LHsContext GhcPs)
hs_ctxt
                        , hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcPs
hs_ty })
      | Just ([LHsType GhcPs]
hs_ctxt1, LHsType GhcPs
hs_ctxt_last) <- [LHsType GhcPs] -> Maybe ([LHsType GhcPs], LHsType GhcPs)
forall a. [a] -> Maybe ([a], a)
snocView [LHsType GhcPs]
SrcSpanLess (LHsContext GhcPs)
hs_ctxt
      , (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
lx (HsWildCardTy _))  <- LHsType GhcPs -> LHsType GhcPs
forall pass. LHsType pass -> LHsType pass
ignoreParens LHsType GhcPs
hs_ctxt_last
      = do { ([LHsType GhcRn]
hs_ctxt1', FreeVars
fvs1) <- (LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars))
-> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rn_top_constraint RnTyKiEnv
env) [LHsType GhcPs]
hs_ctxt1
           ; SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
lx (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ RnTyKiEnv -> [LHsType GhcPs] -> TcRn ()
checkExtraConstraintWildCard RnTyKiEnv
env [LHsType GhcPs]
hs_ctxt1
           ; let hs_ctxt' :: [LHsType GhcRn]
hs_ctxt' = [LHsType GhcRn]
hs_ctxt1' [LHsType GhcRn] -> [LHsType GhcRn] -> [LHsType GhcRn]
forall a. [a] -> [a] -> [a]
++ [SrcSpan -> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
lx (XWildCardTy GhcRn -> HsType GhcRn
forall pass. XWildCardTy pass -> HsType pass
HsWildCardTy NoExt
XWildCardTy GhcRn
noExt)]
           ; (LHsType GhcRn
hs_ty', FreeVars
fvs2) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
hs_ty
           ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQualTy :: forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy { hst_xqual :: XQualTy GhcRn
hst_xqual = NoExt
XQualTy GhcRn
noExt
                              , hst_ctxt :: LHsContext GhcRn
hst_ctxt = SrcSpan -> SrcSpanLess (LHsContext GhcRn) -> LHsContext GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
cx [LHsType GhcRn]
SrcSpanLess (LHsContext GhcRn)
hs_ctxt', hst_body :: LHsType GhcRn
hst_body = LHsType GhcRn
hs_ty' }
                    , FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }

      | Bool
otherwise
      = do { ([LHsType GhcRn]
hs_ctxt', FreeVars
fvs1) <- (LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars))
-> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rn_top_constraint RnTyKiEnv
env) [LHsType GhcPs]
SrcSpanLess (LHsContext GhcPs)
hs_ctxt
           ; (LHsType GhcRn
hs_ty', FreeVars
fvs2)   <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
hs_ty
           ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQualTy :: forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy { hst_xqual :: XQualTy GhcRn
hst_xqual = NoExt
XQualTy GhcRn
noExt
                              , hst_ctxt :: LHsContext GhcRn
hst_ctxt = SrcSpan -> SrcSpanLess (LHsContext GhcRn) -> LHsContext GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
cx [LHsType GhcRn]
SrcSpanLess (LHsContext GhcRn)
hs_ctxt'
                              , hst_body :: LHsType GhcRn
hst_body = LHsType GhcRn
hs_ty' }
                    , FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }

    rn_ty RnTyKiEnv
env HsType GhcPs
hs_ty = RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsTyKi RnTyKiEnv
env HsType GhcPs
hs_ty

    rn_top_constraint :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rn_top_constraint RnTyKiEnv
env = RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi (RnTyKiEnv
env { rtke_what :: RnTyKiWhat
rtke_what = RnTyKiWhat
RnTopConstraint })


checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM ()
-- 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
checkExtraConstraintWildCard :: RnTyKiEnv -> [LHsType GhcPs] -> TcRn ()
checkExtraConstraintWildCard RnTyKiEnv
env [LHsType GhcPs]
hs_ctxt
  = RnTyKiEnv -> Maybe MsgDoc -> TcRn ()
checkWildCard RnTyKiEnv
env Maybe MsgDoc
mb_bad
  where
    mb_bad :: Maybe MsgDoc
mb_bad | Bool -> Bool
not (RnTyKiEnv -> Bool
extraConstraintWildCardsAllowed RnTyKiEnv
env)
           = MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just MsgDoc
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 {} <- RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env
           , Bool -> Bool
not ([LHsType GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsType GhcPs]
hs_ctxt)
           = MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just MsgDoc
deriv_decl_msg
           | Bool
otherwise
           = Maybe MsgDoc
forall a. Maybe a
Nothing

    base_msg :: MsgDoc
base_msg = String -> MsgDoc
text String
"Extra-constraint wildcard" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes MsgDoc
pprAnonWildCard
                   MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"not allowed"

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

extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
extraConstraintWildCardsAllowed RnTyKiEnv
env
  = case RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env of
      TypeSigCtx {}       -> Bool
True
      ExprWithTySigCtx {} -> Bool
True
      DerivDeclCtx {}     -> Bool
True
      HsDocContext
_                   -> Bool
False

-- | Finds free type and kind variables in a type,
--     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
extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups
extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups
extractFilteredRdrTyVars LHsType GhcPs
hs_ty
  = do { LocalRdrEnv
rdr_env <- RnM LocalRdrEnv
getLocalRdrEnv
       ; FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalRdrEnv -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
filterInScope LocalRdrEnv
rdr_env (LHsType GhcPs -> FreeKiTyVarsWithDups
extractHsTyRdrTyVars LHsType GhcPs
hs_ty)) }

-- | 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 :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups
extractFilteredRdrTyVarsDups LHsType GhcPs
hs_ty
  = do { LocalRdrEnv
rdr_env <- RnM LocalRdrEnv
getLocalRdrEnv
       ; FreeKiTyVarsWithDups -> RnM FreeKiTyVarsWithDups
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalRdrEnv -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
filterInScope LocalRdrEnv
rdr_env (LHsType GhcPs -> FreeKiTyVarsWithDups
extractHsTyRdrTyVarsDups LHsType GhcPs
hs_ty)) }

-- | 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])
partition_nwcs :: FreeKiTyVarsWithDups
-> RnM (FreeKiTyVarsWithDups, [Located RdrName])
partition_nwcs free_vars :: FreeKiTyVarsWithDups
free_vars@(FKTV { fktv_tys :: FreeKiTyVarsWithDups -> [Located RdrName]
fktv_tys = [Located RdrName]
tys })
  = do { Bool
wildcards_enabled <- (DynFlags -> Bool)
-> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
-> TcRnIf TcGblEnv TcLclEnv Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Extension -> DynFlags -> Bool
xopt Extension
LangExt.NamedWildCards) IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
       ; let ([Located RdrName]
nwcs, [Located RdrName]
no_nwcs) | Bool
wildcards_enabled = (Located RdrName -> Bool)
-> [Located RdrName] -> ([Located RdrName], [Located RdrName])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Located RdrName -> Bool
is_wildcard [Located RdrName]
tys
                             | Bool
otherwise         = ([], [Located RdrName]
tys)
             free_vars' :: FreeKiTyVarsWithDups
free_vars' = FreeKiTyVarsWithDups
free_vars { fktv_tys :: [Located RdrName]
fktv_tys = [Located RdrName]
no_nwcs }
       ; (FreeKiTyVarsWithDups, [Located RdrName])
-> RnM (FreeKiTyVarsWithDups, [Located RdrName])
forall (m :: * -> *) a. Monad m => a -> m a
return (FreeKiTyVarsWithDups
free_vars', [Located RdrName]
nwcs) }
  where
     is_wildcard :: Located RdrName -> Bool
     is_wildcard :: Located RdrName -> Bool
is_wildcard Located RdrName
rdr = OccName -> Bool
startsWithUnderscore (RdrName -> OccName
rdrNameOcc (Located RdrName -> SrcSpanLess (Located RdrName)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located RdrName
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.


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

rnHsSigType :: HsDocContext -> LHsSigType GhcPs
            -> RnM (LHsSigType GhcRn, FreeVars)
-- Used for source-language type signatures
-- that cannot have wildcards
rnHsSigType :: HsDocContext
-> HsImplicitBndrs GhcPs (LHsType GhcPs)
-> RnM (HsImplicitBndrs GhcRn (LHsType GhcRn), FreeVars)
rnHsSigType HsDocContext
ctx (HsIB { hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = LHsType GhcPs
hs_ty })
  = do { String -> MsgDoc -> TcRn ()
traceRn String
"rnHsSigType" (LHsType GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsType GhcPs
hs_ty)
       ; FreeKiTyVarsWithDups
vars <- LHsType GhcPs -> RnM FreeKiTyVarsWithDups
extractFilteredRdrTyVarsDups LHsType GhcPs
hs_ty
       ; Bool
-> FreeKiTyVarsWithDups
-> ([Name]
    -> RnM (HsImplicitBndrs GhcRn (LHsType GhcRn), FreeVars))
-> RnM (HsImplicitBndrs GhcRn (LHsType GhcRn), FreeVars)
forall a.
Bool
-> FreeKiTyVarsWithDups
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnImplicitBndrs (Bool -> Bool
not (LHsType GhcPs -> Bool
forall p. LHsType p -> Bool
isLHsForAllTy LHsType GhcPs
hs_ty)) FreeKiTyVarsWithDups
vars (([Name] -> RnM (HsImplicitBndrs GhcRn (LHsType GhcRn), FreeVars))
 -> RnM (HsImplicitBndrs GhcRn (LHsType GhcRn), FreeVars))
-> ([Name]
    -> RnM (HsImplicitBndrs GhcRn (LHsType GhcRn), FreeVars))
-> RnM (HsImplicitBndrs GhcRn (LHsType GhcRn), FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [Name]
vars ->
    do { (LHsType GhcRn
body', FreeVars
fvs) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType HsDocContext
ctx LHsType GhcPs
hs_ty
       ; (HsImplicitBndrs GhcRn (LHsType GhcRn), FreeVars)
-> RnM (HsImplicitBndrs GhcRn (LHsType GhcRn), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsIB :: forall pass thing.
XHsIB pass thing -> thing -> HsImplicitBndrs pass thing
HsIB { hsib_ext :: XHsIB GhcRn (LHsType GhcRn)
hsib_ext = [Name]
XHsIB GhcRn (LHsType GhcRn)
vars
                       , hsib_body :: LHsType GhcRn
hsib_body = LHsType GhcRn
body' }
                , FreeVars
fvs ) } }
rnHsSigType HsDocContext
_ (XHsImplicitBndrs XXHsImplicitBndrs GhcPs (LHsType GhcPs)
_) = String -> RnM (HsImplicitBndrs GhcRn (LHsType GhcRn), FreeVars)
forall a. String -> a
panic String
"rnHsSigType"

rnImplicitBndrs :: Bool    -- True <=> bring into scope any free type variables
                           -- E.g.  f :: forall a. a->b
                           --  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
                -> FreeKiTyVarsWithDups
                                   -- Free vars of hs_ty (excluding wildcards)
                                   -- May have duplicates, which is
                                   -- checked here
                -> ([Name] -> RnM (a, FreeVars))
                -> RnM (a, FreeVars)
rnImplicitBndrs :: Bool
-> FreeKiTyVarsWithDups
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnImplicitBndrs Bool
bind_free_tvs
                fvs_with_dups :: FreeKiTyVarsWithDups
fvs_with_dups@(FKTV { fktv_kis :: FreeKiTyVarsWithDups -> [Located RdrName]
fktv_kis = [Located RdrName]
kvs_with_dups
                                    , fktv_tys :: FreeKiTyVarsWithDups -> [Located RdrName]
fktv_tys = [Located RdrName]
tvs_with_dups })
                [Name] -> RnM (a, FreeVars)
thing_inside
  = do { let FKTV [Located RdrName]
kvs [Located RdrName]
tvs = FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
rmDupsInRdrTyVars FreeKiTyVarsWithDups
fvs_with_dups
             real_tvs :: [Located RdrName]
real_tvs | Bool
bind_free_tvs = [Located RdrName]
tvs
                      | Bool
otherwise     = []
             -- We always bind over free /kind/ variables.
             -- Bind free /type/ variables only if there is no
             -- 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

       ; String -> MsgDoc -> TcRn ()
traceRn String
"rnImplicitBndrs" ([MsgDoc] -> MsgDoc
vcat [ [Located RdrName] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Located RdrName]
kvs, [Located RdrName] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Located RdrName]
tvs, [Located RdrName] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Located RdrName]
real_tvs ])

       ; WarningFlag -> TcRn () -> TcRn ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnImplicitKindVars (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
bind_free_tvs Bool -> Bool -> Bool
|| [Located RdrName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located RdrName]
kvs) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         WarnReason -> SrcSpan -> MsgDoc -> TcRn ()
addWarnAt (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnImplicitKindVars) (Located RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc ([Located RdrName] -> Located RdrName
forall a. [a] -> a
head [Located RdrName]
kvs)) (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         [Located RdrName] -> MsgDoc
forall a. Outputable a => [a] -> MsgDoc
implicit_kind_vars_msg [Located RdrName]
kvs

       ; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
          -- NB: kinds before tvs, as mandated by
          -- Note [Ordering of implicit variables]
       ; [Name]
vars <- (Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> [Located RdrName] -> IOEnv (Env TcGblEnv TcLclEnv) [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newLocalBndrRn (Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> (Located RdrName -> Located RdrName)
-> Located RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (RdrName -> Located RdrName)
-> (Located RdrName -> RdrName)
-> Located RdrName
-> Located RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located RdrName -> RdrName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) ([Located RdrName]
kvs [Located RdrName] -> [Located RdrName] -> [Located RdrName]
forall a. [a] -> [a] -> [a]
++ [Located RdrName]
real_tvs)

       ; String -> MsgDoc -> TcRn ()
traceRn String
"checkMixedVars2" (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
           [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"kvs_with_dups" MsgDoc -> MsgDoc -> MsgDoc
<+> [Located RdrName] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Located RdrName]
kvs_with_dups
                , String -> MsgDoc
text String
"tvs_with_dups" MsgDoc -> MsgDoc -> MsgDoc
<+> [Located RdrName] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Located RdrName]
tvs_with_dups ]

       ; [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
vars (RnM (a, FreeVars) -> RnM (a, FreeVars))
-> RnM (a, FreeVars) -> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$
         [Name] -> RnM (a, FreeVars)
thing_inside [Name]
vars }
  where
    implicit_kind_vars_msg :: [a] -> MsgDoc
implicit_kind_vars_msg [a]
kvs =
      [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"An explicit" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (String -> MsgDoc
text String
"forall") MsgDoc -> MsgDoc -> MsgDoc
<+>
             String -> MsgDoc
text String
"was used, but the following kind variables" MsgDoc -> MsgDoc -> MsgDoc
<+>
             String -> MsgDoc
text String
"are not quantified:" MsgDoc -> MsgDoc -> MsgDoc
<+>
             [MsgDoc] -> MsgDoc
hsep (MsgDoc -> [MsgDoc] -> [MsgDoc]
punctuate MsgDoc
comma ((a -> MsgDoc) -> [a] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map (MsgDoc -> MsgDoc
quotes (MsgDoc -> MsgDoc) -> (a -> MsgDoc) -> a -> MsgDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr) [a]
kvs))
           , String -> MsgDoc
text String
"Despite this fact, GHC will introduce them into scope," MsgDoc -> MsgDoc -> MsgDoc
<+>
             String -> MsgDoc
text String
"but it will stop doing so in the future."
           , String -> MsgDoc
text String
"Suggested fix: add" MsgDoc -> MsgDoc -> MsgDoc
<+>
             MsgDoc -> MsgDoc
quotes (String -> MsgDoc
text String
"forall" MsgDoc -> MsgDoc -> MsgDoc
<+> [MsgDoc] -> MsgDoc
hsep ((a -> MsgDoc) -> [a] -> [MsgDoc]
forall a b. (a -> b) -> [a] -> [b]
map a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [a]
kvs) MsgDoc -> MsgDoc -> MsgDoc
<> Char -> MsgDoc
char Char
'.') ]

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

{-
rnHsType is here because we call it from loadInstDecl, and I didn't
want a gratuitous knot.

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"

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

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.
-}

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

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

instance Outputable RnTyKiEnv where
  ppr :: RnTyKiEnv -> MsgDoc
ppr (RTKE { rtke_level :: RnTyKiEnv -> TypeOrKind
rtke_level = TypeOrKind
lev, rtke_what :: RnTyKiEnv -> RnTyKiWhat
rtke_what = RnTyKiWhat
what
            , rtke_nwcs :: RnTyKiEnv -> FreeVars
rtke_nwcs = FreeVars
wcs, rtke_ctxt :: RnTyKiEnv -> HsDocContext
rtke_ctxt = HsDocContext
ctxt })
    = String -> MsgDoc
text String
"RTKE"
      MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
braces ([MsgDoc] -> MsgDoc
sep [ TypeOrKind -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr TypeOrKind
lev, RnTyKiWhat -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr RnTyKiWhat
what, FreeVars -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr FreeVars
wcs
                      , HsDocContext -> MsgDoc
pprHsDocContext HsDocContext
ctxt ])

instance Outputable RnTyKiWhat where
  ppr :: RnTyKiWhat -> MsgDoc
ppr RnTyKiWhat
RnTypeBody      = String -> MsgDoc
text String
"RnTypeBody"
  ppr RnTyKiWhat
RnTopConstraint = String -> MsgDoc
text String
"RnTopConstraint"
  ppr RnTyKiWhat
RnConstraint    = String -> MsgDoc
text String
"RnConstraint"

mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
cxt TypeOrKind
level RnTyKiWhat
what
 = RTKE :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> FreeVars -> RnTyKiEnv
RTKE { rtke_level :: TypeOrKind
rtke_level = TypeOrKind
level, rtke_nwcs :: FreeVars
rtke_nwcs = FreeVars
emptyNameSet
        , rtke_what :: RnTyKiWhat
rtke_what = RnTyKiWhat
what, rtke_ctxt :: HsDocContext
rtke_ctxt = HsDocContext
cxt }

isRnKindLevel :: RnTyKiEnv -> Bool
isRnKindLevel :: RnTyKiEnv -> Bool
isRnKindLevel (RTKE { rtke_level :: RnTyKiEnv -> TypeOrKind
rtke_level = TypeOrKind
KindLevel }) = Bool
True
isRnKindLevel RnTyKiEnv
_                                 = Bool
False

--------------
rnLHsType  :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType HsDocContext
ctxt LHsType GhcPs
ty = RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi (HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
ctxt TypeOrKind
TypeLevel RnTyKiWhat
RnTypeBody) LHsType GhcPs
ty

rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
rnLHsTypes HsDocContext
doc [LHsType GhcPs]
tys = (LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars))
-> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType HsDocContext
doc) [LHsType GhcPs]
tys

rnHsType  :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsType :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsType HsDocContext
ctxt HsType GhcPs
ty = RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsTyKi (HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
ctxt TypeOrKind
TypeLevel RnTyKiWhat
RnTypeBody) HsType GhcPs
ty

rnLHsKind  :: HsDocContext -> LHsKind GhcPs -> RnM (LHsKind GhcRn, FreeVars)
rnLHsKind :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsKind HsDocContext
ctxt LHsType GhcPs
kind = RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi (HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
ctxt TypeOrKind
KindLevel RnTyKiWhat
RnTypeBody) LHsType GhcPs
kind

rnHsKind  :: HsDocContext -> HsKind GhcPs -> RnM (HsKind GhcRn, FreeVars)
rnHsKind :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsKind HsDocContext
ctxt HsType GhcPs
kind = RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsTyKi  (HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
ctxt TypeOrKind
KindLevel RnTyKiWhat
RnTypeBody) HsType GhcPs
kind

-- renaming a type only, not a kind
rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs
                -> RnM (LHsTypeArg GhcRn, FreeVars)
rnLHsTypeArg :: HsDocContext
-> LHsTypeArg GhcPs -> RnM (LHsTypeArg GhcRn, FreeVars)
rnLHsTypeArg HsDocContext
ctxt (HsValArg LHsType GhcPs
ty)
   = do { (LHsType GhcRn
tys_rn, FreeVars
fvs) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType HsDocContext
ctxt LHsType GhcPs
ty
        ; (LHsTypeArg GhcRn, FreeVars) -> RnM (LHsTypeArg GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsType GhcRn -> LHsTypeArg GhcRn
forall tm ty. tm -> HsArg tm ty
HsValArg LHsType GhcRn
tys_rn, FreeVars
fvs) }
rnLHsTypeArg HsDocContext
ctxt (HsTypeArg SrcSpan
l LHsType GhcPs
ki)
   = do { (LHsType GhcRn
kis_rn, FreeVars
fvs) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsKind HsDocContext
ctxt LHsType GhcPs
ki
        ; (LHsTypeArg GhcRn, FreeVars) -> RnM (LHsTypeArg GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> LHsType GhcRn -> LHsTypeArg GhcRn
forall tm ty. SrcSpan -> ty -> HsArg tm ty
HsTypeArg SrcSpan
l LHsType GhcRn
kis_rn, FreeVars
fvs) }
rnLHsTypeArg HsDocContext
_ (HsArgPar SrcSpan
sp)
   = (LHsTypeArg GhcRn, FreeVars) -> RnM (LHsTypeArg GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> LHsTypeArg GhcRn
forall tm ty. SrcSpan -> HsArg tm ty
HsArgPar SrcSpan
sp, FreeVars
emptyFVs)

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

--------------
rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs
              -> RnM (LHsContext GhcRn, FreeVars)
rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars)
rnTyKiContext RnTyKiEnv
env (LHsContext GhcPs -> Located (SrcSpanLess (LHsContext GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LHsContext GhcPs)
cxt)
  = do { String -> MsgDoc -> TcRn ()
traceRn String
"rncontext" ([LHsType GhcPs] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [LHsType GhcPs]
SrcSpanLess (LHsContext GhcPs)
cxt)
       ; let env' :: RnTyKiEnv
env' = RnTyKiEnv
env { rtke_what :: RnTyKiWhat
rtke_what = RnTyKiWhat
RnConstraint }
       ; ([LHsType GhcRn]
cxt', FreeVars
fvs) <- (LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars))
-> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env') [LHsType GhcPs]
SrcSpanLess (LHsContext GhcPs)
cxt
       ; (LHsContext GhcRn, FreeVars) -> RnM (LHsContext GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LHsContext GhcRn) -> LHsContext GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc [LHsType GhcRn]
SrcSpanLess (LHsContext GhcRn)
cxt', FreeVars
fvs) }

rnContext :: HsDocContext -> LHsContext GhcPs
          -> RnM (LHsContext GhcRn, FreeVars)
rnContext :: HsDocContext
-> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars)
rnContext HsDocContext
doc LHsContext GhcPs
theta = RnTyKiEnv -> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars)
rnTyKiContext (HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
doc TypeOrKind
TypeLevel RnTyKiWhat
RnConstraint) LHsContext GhcPs
theta

--------------
rnLHsTyKi  :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LHsType GhcPs)
ty)
  = SrcSpan
-> RnM (LHsType GhcRn, FreeVars) -> RnM (LHsType GhcRn, FreeVars)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (RnM (LHsType GhcRn, FreeVars) -> RnM (LHsType GhcRn, FreeVars))
-> RnM (LHsType GhcRn, FreeVars) -> RnM (LHsType GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
    do { (HsType GhcRn
ty', FreeVars
fvs) <- RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsTyKi RnTyKiEnv
env HsType GhcPs
SrcSpanLess (LHsType GhcPs)
ty
       ; (LHsType GhcRn, FreeVars) -> RnM (LHsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc HsType GhcRn
SrcSpanLess (LHsType GhcRn)
ty', FreeVars
fvs) }

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

rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsTyKi RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsForAllTy { hst_bndrs :: forall pass. HsType pass -> [LHsTyVarBndr pass]
hst_bndrs = [LHsTyVarBndr GhcPs]
tyvars, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body  = LHsType GhcPs
tau })
  = do { RnTyKiEnv -> HsType GhcPs -> TcRn ()
forall ty. Outputable ty => RnTyKiEnv -> ty -> TcRn ()
checkPolyKinds RnTyKiEnv
env HsType GhcPs
ty
       ; HsDocContext
-> Maybe MsgDoc
-> Maybe Any
-> [LHsTyVarBndr GhcPs]
-> ([LHsTyVarBndr GhcRn] -> RnM (HsType GhcRn, FreeVars))
-> RnM (HsType GhcRn, FreeVars)
forall a b.
HsDocContext
-> Maybe MsgDoc
-> Maybe a
-> [LHsTyVarBndr GhcPs]
-> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs (RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env) (MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just (MsgDoc -> Maybe MsgDoc) -> MsgDoc -> Maybe MsgDoc
forall a b. (a -> b) -> a -> b
$ HsType GhcPs -> MsgDoc
inTypeDoc HsType GhcPs
ty)
                           Maybe Any
forall a. Maybe a
Nothing [LHsTyVarBndr GhcPs]
tyvars (([LHsTyVarBndr GhcRn] -> RnM (HsType GhcRn, FreeVars))
 -> RnM (HsType GhcRn, FreeVars))
-> ([LHsTyVarBndr GhcRn] -> RnM (HsType GhcRn, FreeVars))
-> RnM (HsType GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [LHsTyVarBndr GhcRn]
tyvars' ->
    do { (LHsType GhcRn
tau',  FreeVars
fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
tau
       ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsForAllTy :: forall pass.
XForAllTy pass
-> [LHsTyVarBndr pass] -> LHsType pass -> HsType pass
HsForAllTy { hst_xforall :: XForAllTy GhcRn
hst_xforall = NoExt
XForAllTy GhcRn
noExt, hst_bndrs :: [LHsTyVarBndr GhcRn]
hst_bndrs = [LHsTyVarBndr GhcRn]
tyvars'
                             , hst_body :: LHsType GhcRn
hst_body =  LHsType GhcRn
tau' }
                , FreeVars
fvs) } }

rnHsTyKi RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsQualTy { hst_ctxt :: forall pass. HsType pass -> LHsContext pass
hst_ctxt = LHsContext GhcPs
lctxt, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcPs
tau })
  = do { RnTyKiEnv -> HsType GhcPs -> TcRn ()
forall ty. Outputable ty => RnTyKiEnv -> ty -> TcRn ()
checkPolyKinds RnTyKiEnv
env HsType GhcPs
ty  -- See Note [QualTy in kinds]
       ; (LHsContext GhcRn
ctxt', FreeVars
fvs1) <- RnTyKiEnv -> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars)
rnTyKiContext RnTyKiEnv
env LHsContext GhcPs
lctxt
       ; (LHsType GhcRn
tau',  FreeVars
fvs2) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
tau
       ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQualTy :: forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy { hst_xqual :: XQualTy GhcRn
hst_xqual = NoExt
XQualTy GhcRn
noExt, hst_ctxt :: LHsContext GhcRn
hst_ctxt = LHsContext GhcRn
ctxt'
                          , hst_body :: LHsType GhcRn
hst_body =  LHsType GhcRn
tau' }
                , FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }

rnHsTyKi RnTyKiEnv
env (HsTyVar XTyVar GhcPs
_ PromotionFlag
ip (Located (IdP GhcPs) -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (Located RdrName)
rdr_name))
  = do { Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env Bool -> Bool -> Bool
&& RdrName -> Bool
isRdrTyVar RdrName
SrcSpanLess (Located RdrName)
rdr_name) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         Extension -> TcRn () -> TcRn ()
forall gbl lcl. Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
unlessXOptM Extension
LangExt.PolyKinds (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ MsgDoc -> TcRn ()
addErr (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         HsDocContext -> MsgDoc -> MsgDoc
withHsDocContext (RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env) (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$
         [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"Unexpected kind variable" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr RdrName
SrcSpanLess (Located RdrName)
rdr_name)
              , String -> MsgDoc
text String
"Perhaps you intended to use PolyKinds" ]
           -- Any type variable at the kind level is illegal without the use
           -- of PolyKinds (see #14710)
       ; Name
name <- RnTyKiEnv -> RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
rnTyVar RnTyKiEnv
env RdrName
SrcSpanLess (Located RdrName)
rdr_name
       ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XTyVar GhcRn
-> PromotionFlag -> Located (IdP GhcRn) -> HsType GhcRn
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar NoExt
XTyVar GhcRn
noExt PromotionFlag
ip (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (Located Name)
Name
name), Name -> FreeVars
unitFV Name
name) }

rnHsTyKi RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsOpTy XOpTy GhcPs
_ LHsType GhcPs
ty1 Located (IdP GhcPs)
l_op LHsType GhcPs
ty2)
  = SrcSpan
-> RnM (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (Located RdrName -> SrcSpan
forall a. HasSrcSpan a => a -> SrcSpan
getLoc Located (IdP GhcPs)
Located RdrName
l_op) (RnM (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars))
-> RnM (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
    do  { (Located Name
l_op', FreeVars
fvs1) <- RnTyKiEnv
-> HsType GhcPs -> Located RdrName -> RnM (Located Name, FreeVars)
forall a.
Outputable a =>
RnTyKiEnv -> a -> Located RdrName -> RnM (Located Name, FreeVars)
rnHsTyOp RnTyKiEnv
env HsType GhcPs
ty Located (IdP GhcPs)
Located RdrName
l_op
        ; Fixity
fix   <- Located Name -> RnM Fixity
lookupTyFixityRn Located Name
l_op'
        ; (LHsType GhcRn
ty1', FreeVars
fvs2) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty1
        ; (LHsType GhcRn
ty2', FreeVars
fvs3) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty2
        ; HsType GhcRn
res_ty <- (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> Name
-> Fixity
-> LHsType GhcRn
-> LHsType GhcRn
-> RnM (HsType GhcRn)
mkHsOpTyRn (\LHsType GhcRn
t1 LHsType GhcRn
t2 -> XOpTy GhcRn
-> LHsType GhcRn
-> Located (IdP GhcRn)
-> LHsType GhcRn
-> HsType GhcRn
forall pass.
XOpTy pass
-> LHsType pass
-> Located (IdP pass)
-> LHsType pass
-> HsType pass
HsOpTy NoExt
XOpTy GhcRn
noExt LHsType GhcRn
t1 Located (IdP GhcRn)
Located Name
l_op' LHsType GhcRn
t2)
                               (Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located Name
l_op') Fixity
fix LHsType GhcRn
ty1' LHsType GhcRn
ty2'
        ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsType GhcRn
res_ty, [FreeVars] -> FreeVars
plusFVs [FreeVars
fvs1, FreeVars
fvs2, FreeVars
fvs3]) }

rnHsTyKi RnTyKiEnv
env (HsParTy XParTy GhcPs
_ LHsType GhcPs
ty)
  = do { (LHsType GhcRn
ty', FreeVars
fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
       ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XParTy GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass. XParTy pass -> LHsType pass -> HsType pass
HsParTy NoExt
XParTy GhcRn
noExt LHsType GhcRn
ty', FreeVars
fvs) }

rnHsTyKi RnTyKiEnv
env (HsBangTy XBangTy GhcPs
_ HsSrcBang
b LHsType GhcPs
ty)
  = do { (LHsType GhcRn
ty', FreeVars
fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
       ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XBangTy GhcRn -> HsSrcBang -> LHsType GhcRn -> HsType GhcRn
forall pass.
XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass
HsBangTy NoExt
XBangTy GhcRn
noExt HsSrcBang
b LHsType GhcRn
ty', FreeVars
fvs) }

rnHsTyKi RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsRecTy XRecTy GhcPs
_ [LConDeclField GhcPs]
flds)
  = do { let ctxt :: HsDocContext
ctxt = RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env
       ; [FieldLabel]
fls          <- HsDocContext -> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
get_fields HsDocContext
ctxt
       ; ([LConDeclField GhcRn]
flds', FreeVars
fvs) <- HsDocContext
-> [FieldLabel]
-> [LConDeclField GhcPs]
-> RnM ([LConDeclField GhcRn], FreeVars)
rnConDeclFields HsDocContext
ctxt [FieldLabel]
fls [LConDeclField GhcPs]
flds
       ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XRecTy GhcRn -> [LConDeclField GhcRn] -> HsType GhcRn
forall pass. XRecTy pass -> [LConDeclField pass] -> HsType pass
HsRecTy NoExt
XRecTy GhcRn
noExt [LConDeclField GhcRn]
flds', FreeVars
fvs) }
  where
    get_fields :: HsDocContext -> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
get_fields (ConDeclCtx [Located Name]
names)
      = (Located Name -> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel])
-> [Located Name] -> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
forall (m :: * -> *) a b. Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM (Name -> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
lookupConstructorFields (Name -> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel])
-> (Located Name -> Name)
-> Located Name
-> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located Name -> Name
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [Located Name]
names
    get_fields HsDocContext
_
      = do { MsgDoc -> TcRn ()
addErr (MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"Record syntax is illegal here:")
                                   Int
2 (HsType GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsType GhcPs
ty))
           ; [FieldLabel] -> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
forall (m :: * -> *) a. Monad m => a -> m a
return [] }

rnHsTyKi RnTyKiEnv
env (HsFunTy XFunTy GhcPs
_ LHsType GhcPs
ty1 LHsType GhcPs
ty2)
  = do { (LHsType GhcRn
ty1', FreeVars
fvs1) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty1
        -- Might find a for-all as the arg of a function type
       ; (LHsType GhcRn
ty2', FreeVars
fvs2) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty2
        -- Or as the result.  This happens when reading Prelude.hi
        -- when we find return :: forall m. Monad m -> forall a. a -> m a

        -- Check for fixity rearrangements
       ; HsType GhcRn
res_ty <- (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> Name
-> Fixity
-> LHsType GhcRn
-> LHsType GhcRn
-> RnM (HsType GhcRn)
mkHsOpTyRn (XFunTy GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XFunTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy NoExt
XFunTy GhcRn
noExt) Name
funTyConName Fixity
funTyFixity LHsType GhcRn
ty1' LHsType GhcRn
ty2'
       ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsType GhcRn
res_ty, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }

rnHsTyKi RnTyKiEnv
env listTy :: HsType GhcPs
listTy@(HsListTy XListTy GhcPs
_ LHsType GhcPs
ty)
  = do { Bool
data_kinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
data_kinds Bool -> Bool -> Bool
&& RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env)
              (MsgDoc -> TcRn ()
addErr (RnTyKiEnv -> HsType GhcPs -> MsgDoc
dataKindsErr RnTyKiEnv
env HsType GhcPs
listTy))
       ; (LHsType GhcRn
ty', FreeVars
fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
       ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XListTy GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass. XListTy pass -> LHsType pass -> HsType pass
HsListTy NoExt
XListTy GhcRn
noExt LHsType GhcRn
ty', FreeVars
fvs) }

rnHsTyKi RnTyKiEnv
env t :: HsType GhcPs
t@(HsKindSig XKindSig GhcPs
_ LHsType GhcPs
ty LHsType GhcPs
k)
  = do { RnTyKiEnv -> HsType GhcPs -> TcRn ()
forall ty. Outputable ty => RnTyKiEnv -> ty -> TcRn ()
checkPolyKinds RnTyKiEnv
env HsType GhcPs
t
       ; Bool
kind_sigs_ok <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.KindSignatures
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
kind_sigs_ok (HsDocContext -> LHsType GhcPs -> TcRn ()
badKindSigErr (RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env) LHsType GhcPs
ty)
       ; (LHsType GhcRn
ty', FreeVars
fvs1) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
       ; (LHsType GhcRn
k', FreeVars
fvs2)  <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi (RnTyKiEnv
env { rtke_level :: TypeOrKind
rtke_level = TypeOrKind
KindLevel }) LHsType GhcPs
k
       ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XKindSig GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XKindSig pass -> LHsType pass -> LHsType pass -> HsType pass
HsKindSig NoExt
XKindSig GhcRn
noExt LHsType GhcRn
ty' LHsType GhcRn
k', FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }

-- Unboxed tuples are allowed to have poly-typed arguments.  These
-- sometimes crop up as a result of CPR worker-wrappering dictionaries.
rnHsTyKi RnTyKiEnv
env tupleTy :: HsType GhcPs
tupleTy@(HsTupleTy XTupleTy GhcPs
_ HsTupleSort
tup_con [LHsType GhcPs]
tys)
  = do { Bool
data_kinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
data_kinds Bool -> Bool -> Bool
&& RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env)
              (MsgDoc -> TcRn ()
addErr (RnTyKiEnv -> HsType GhcPs -> MsgDoc
dataKindsErr RnTyKiEnv
env HsType GhcPs
tupleTy))
       ; ([LHsType GhcRn]
tys', FreeVars
fvs) <- (LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars))
-> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env) [LHsType GhcPs]
tys
       ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XTupleTy GhcRn -> HsTupleSort -> [LHsType GhcRn] -> HsType GhcRn
forall pass.
XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass
HsTupleTy NoExt
XTupleTy GhcRn
noExt HsTupleSort
tup_con [LHsType GhcRn]
tys', FreeVars
fvs) }

rnHsTyKi RnTyKiEnv
env sumTy :: HsType GhcPs
sumTy@(HsSumTy XSumTy GhcPs
_ [LHsType GhcPs]
tys)
  = do { Bool
data_kinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
data_kinds Bool -> Bool -> Bool
&& RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env)
              (MsgDoc -> TcRn ()
addErr (RnTyKiEnv -> HsType GhcPs -> MsgDoc
dataKindsErr RnTyKiEnv
env HsType GhcPs
sumTy))
       ; ([LHsType GhcRn]
tys', FreeVars
fvs) <- (LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars))
-> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env) [LHsType GhcPs]
tys
       ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XSumTy GhcRn -> [LHsType GhcRn] -> HsType GhcRn
forall pass. XSumTy pass -> [LHsType pass] -> HsType pass
HsSumTy NoExt
XSumTy GhcRn
noExt [LHsType GhcRn]
tys', FreeVars
fvs) }

-- Ensure that a type-level integer is nonnegative (#8306, #8412)
rnHsTyKi RnTyKiEnv
env tyLit :: HsType GhcPs
tyLit@(HsTyLit XTyLit GhcPs
_ HsTyLit
t)
  = do { Bool
data_kinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
data_kinds (MsgDoc -> TcRn ()
addErr (RnTyKiEnv -> HsType GhcPs -> MsgDoc
dataKindsErr RnTyKiEnv
env HsType GhcPs
tyLit))
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (HsTyLit -> Bool
negLit HsTyLit
t) (MsgDoc -> TcRn ()
addErr MsgDoc
negLitErr)
       ; RnTyKiEnv -> HsType GhcPs -> TcRn ()
forall ty. Outputable ty => RnTyKiEnv -> ty -> TcRn ()
checkPolyKinds RnTyKiEnv
env HsType GhcPs
tyLit
       ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XTyLit GhcRn -> HsTyLit -> HsType GhcRn
forall pass. XTyLit pass -> HsTyLit -> HsType pass
HsTyLit NoExt
XTyLit GhcRn
noExt HsTyLit
t, FreeVars
emptyFVs) }
  where
    negLit :: HsTyLit -> Bool
negLit (HsStrTy SourceText
_ FastString
_) = Bool
False
    negLit (HsNumTy SourceText
_ Integer
i) = Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
    negLitErr :: MsgDoc
negLitErr = String -> MsgDoc
text String
"Illegal literal in type (type literals must not be negative):" MsgDoc -> MsgDoc -> MsgDoc
<+> HsType GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsType GhcPs
tyLit

rnHsTyKi RnTyKiEnv
env (HsAppTy XAppTy GhcPs
_ LHsType GhcPs
ty1 LHsType GhcPs
ty2)
  = do { (LHsType GhcRn
ty1', FreeVars
fvs1) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty1
       ; (LHsType GhcRn
ty2', FreeVars
fvs2) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty2
       ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XAppTy GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy NoExt
XAppTy GhcRn
noExt LHsType GhcRn
ty1' LHsType GhcRn
ty2', FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }

rnHsTyKi RnTyKiEnv
env (HsAppKindTy XAppKindTy GhcPs
l LHsType GhcPs
ty LHsType GhcPs
k)
  = do { Bool
kind_app <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TypeApplications
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
kind_app (MsgDoc -> TcRn ()
addErr (String -> LHsType GhcPs -> MsgDoc
typeAppErr String
"kind" LHsType GhcPs
k))
       ; (LHsType GhcRn
ty', FreeVars
fvs1) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
       ; (LHsType GhcRn
k', FreeVars
fvs2) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi (RnTyKiEnv
env {rtke_level :: TypeOrKind
rtke_level = TypeOrKind
KindLevel }) LHsType GhcPs
k
       ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XAppKindTy GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XAppKindTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppKindTy XAppKindTy GhcRn
XAppKindTy GhcPs
l LHsType GhcRn
ty' LHsType GhcRn
k', FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }

rnHsTyKi RnTyKiEnv
env t :: HsType GhcPs
t@(HsIParamTy XIParamTy GhcPs
_ Located HsIPName
n LHsType GhcPs
ty)
  = do { RnTyKiEnv -> HsType GhcPs -> TcRn ()
forall ty. Outputable ty => RnTyKiEnv -> ty -> TcRn ()
notInKinds RnTyKiEnv
env HsType GhcPs
t
       ; (LHsType GhcRn
ty', FreeVars
fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
       ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XIParamTy GhcRn
-> Located HsIPName -> LHsType GhcRn -> HsType GhcRn
forall pass.
XIParamTy pass -> Located HsIPName -> LHsType pass -> HsType pass
HsIParamTy NoExt
XIParamTy GhcRn
noExt Located HsIPName
n LHsType GhcRn
ty', FreeVars
fvs) }

rnHsTyKi RnTyKiEnv
_ (HsStarTy XStarTy GhcPs
_ Bool
isUni)
  = (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XStarTy GhcRn -> Bool -> HsType GhcRn
forall pass. XStarTy pass -> Bool -> HsType pass
HsStarTy NoExt
XStarTy GhcRn
noExt Bool
isUni, FreeVars
emptyFVs)

rnHsTyKi RnTyKiEnv
_ (HsSpliceTy XSpliceTy GhcPs
_ HsSplice GhcPs
sp)
  = HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars)
rnSpliceType HsSplice GhcPs
sp

rnHsTyKi RnTyKiEnv
env (HsDocTy XDocTy GhcPs
_ LHsType GhcPs
ty LHsDocString
haddock_doc)
  = do { (LHsType GhcRn
ty', FreeVars
fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
       ; LHsDocString
haddock_doc' <- LHsDocString -> RnM LHsDocString
rnLHsDoc LHsDocString
haddock_doc
       ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XDocTy GhcRn -> LHsType GhcRn -> LHsDocString -> HsType GhcRn
forall pass.
XDocTy pass -> LHsType pass -> LHsDocString -> HsType pass
HsDocTy NoExt
XDocTy GhcRn
noExt LHsType GhcRn
ty' LHsDocString
haddock_doc', FreeVars
fvs) }

rnHsTyKi RnTyKiEnv
_ (XHsType (NHsCoreTy ty))
  = (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XXType GhcRn -> HsType GhcRn
forall pass. XXType pass -> HsType pass
XHsType (Type -> NewHsTypeX
NHsCoreTy Type
ty), FreeVars
emptyFVs)
    -- The emptyFVs probably isn't quite right
    -- but I don't think it matters

rnHsTyKi RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsExplicitListTy XExplicitListTy GhcPs
_ PromotionFlag
ip [LHsType GhcPs]
tys)
  = do { RnTyKiEnv -> HsType GhcPs -> TcRn ()
forall ty. Outputable ty => RnTyKiEnv -> ty -> TcRn ()
checkPolyKinds RnTyKiEnv
env HsType GhcPs
ty
       ; Bool
data_kinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
data_kinds (MsgDoc -> TcRn ()
addErr (RnTyKiEnv -> HsType GhcPs -> MsgDoc
dataKindsErr RnTyKiEnv
env HsType GhcPs
ty))
       ; ([LHsType GhcRn]
tys', FreeVars
fvs) <- (LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars))
-> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env) [LHsType GhcPs]
tys
       ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XExplicitListTy GhcRn
-> PromotionFlag -> [LHsType GhcRn] -> HsType GhcRn
forall pass.
XExplicitListTy pass
-> PromotionFlag -> [LHsType pass] -> HsType pass
HsExplicitListTy NoExt
XExplicitListTy GhcRn
noExt PromotionFlag
ip [LHsType GhcRn]
tys', FreeVars
fvs) }

rnHsTyKi RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsExplicitTupleTy XExplicitTupleTy GhcPs
_ [LHsType GhcPs]
tys)
  = do { RnTyKiEnv -> HsType GhcPs -> TcRn ()
forall ty. Outputable ty => RnTyKiEnv -> ty -> TcRn ()
checkPolyKinds RnTyKiEnv
env HsType GhcPs
ty
       ; Bool
data_kinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
data_kinds (MsgDoc -> TcRn ()
addErr (RnTyKiEnv -> HsType GhcPs -> MsgDoc
dataKindsErr RnTyKiEnv
env HsType GhcPs
ty))
       ; ([LHsType GhcRn]
tys', FreeVars
fvs) <- (LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars))
-> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env) [LHsType GhcPs]
tys
       ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XExplicitTupleTy GhcRn -> [LHsType GhcRn] -> HsType GhcRn
forall pass. XExplicitTupleTy pass -> [LHsType pass] -> HsType pass
HsExplicitTupleTy NoExt
XExplicitTupleTy GhcRn
noExt [LHsType GhcRn]
tys', FreeVars
fvs) }

rnHsTyKi RnTyKiEnv
env (HsWildCardTy XWildCardTy GhcPs
_)
  = do { RnTyKiEnv -> TcRn ()
checkAnonWildCard RnTyKiEnv
env
       ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (XWildCardTy GhcRn -> HsType GhcRn
forall pass. XWildCardTy pass -> HsType pass
HsWildCardTy NoExt
XWildCardTy GhcRn
noExt, FreeVars
emptyFVs) }

--------------
rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name
rnTyVar :: RnTyKiEnv -> RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
rnTyVar RnTyKiEnv
env RdrName
rdr_name
  = do { Name
name <- RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
lookupTypeOccRn RdrName
rdr_name
       ; RnTyKiEnv -> Name -> TcRn ()
checkNamedWildCard RnTyKiEnv
env Name
name
       ; Name -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
name }

rnLTyVar :: Located RdrName -> RnM (Located Name)
-- Called externally; does not deal with wildards
rnLTyVar :: Located RdrName -> RnM (Located Name)
rnLTyVar (Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (Located RdrName)
rdr_name)
  = do { Name
tyvar <- RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
lookupTypeOccRn RdrName
SrcSpanLess (Located RdrName)
rdr_name
       ; Located Name -> RnM (Located Name)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (Located Name)
Name
tyvar) }

--------------
rnHsTyOp :: Outputable a
         => RnTyKiEnv -> a -> Located RdrName
         -> RnM (Located Name, FreeVars)
rnHsTyOp :: RnTyKiEnv -> a -> Located RdrName -> RnM (Located Name, FreeVars)
rnHsTyOp RnTyKiEnv
env a
overall_ty (Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (Located RdrName)
op)
  = do { Bool
ops_ok <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.TypeOperators
       ; Name
op' <- RnTyKiEnv -> RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
rnTyVar RnTyKiEnv
env RdrName
SrcSpanLess (Located RdrName)
op
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
ops_ok Bool -> Bool -> Bool
|| Name
op' Name -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqTyConKey) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
           MsgDoc -> TcRn ()
addErr (RdrName -> a -> MsgDoc
forall a. Outputable a => RdrName -> a -> MsgDoc
opTyErr RdrName
SrcSpanLess (Located RdrName)
op a
overall_ty)
       ; let l_op' :: Located Name
l_op' = SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (Located Name)
Name
op'
       ; (Located Name, FreeVars) -> RnM (Located Name, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located Name
l_op', Name -> FreeVars
unitFV Name
op') }

--------------
notAllowed :: SDoc -> SDoc
notAllowed :: MsgDoc -> MsgDoc
notAllowed MsgDoc
doc
  = String -> MsgDoc
text String
"Wildcard" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes MsgDoc
doc MsgDoc -> MsgDoc -> MsgDoc
<+> PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"not allowed")

checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM ()
checkWildCard :: RnTyKiEnv -> Maybe MsgDoc -> TcRn ()
checkWildCard RnTyKiEnv
env (Just MsgDoc
doc)
  = MsgDoc -> TcRn ()
addErr (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [MsgDoc] -> MsgDoc
vcat [MsgDoc
doc, Int -> MsgDoc -> MsgDoc
nest Int
2 (String -> MsgDoc
text String
"in" MsgDoc -> MsgDoc -> MsgDoc
<+> HsDocContext -> MsgDoc
pprHsDocContext (RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env))]
checkWildCard RnTyKiEnv
_ Maybe MsgDoc
Nothing
  = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

checkAnonWildCard :: RnTyKiEnv -> RnM ()
-- Report an error if an anonymous wildcard is illegal here
checkAnonWildCard :: RnTyKiEnv -> TcRn ()
checkAnonWildCard RnTyKiEnv
env
  = RnTyKiEnv -> Maybe MsgDoc -> TcRn ()
checkWildCard RnTyKiEnv
env Maybe MsgDoc
mb_bad
  where
    mb_bad :: Maybe SDoc
    mb_bad :: Maybe MsgDoc
mb_bad | Bool -> Bool
not (RnTyKiEnv -> Bool
wildCardsAllowed RnTyKiEnv
env)
           = MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just (MsgDoc -> MsgDoc
notAllowed MsgDoc
pprAnonWildCard)
           | Bool
otherwise
           = case RnTyKiEnv -> RnTyKiWhat
rtke_what RnTyKiEnv
env of
               RnTyKiWhat
RnTypeBody      -> Maybe MsgDoc
forall a. Maybe a
Nothing
               RnTyKiWhat
RnConstraint    -> MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just MsgDoc
constraint_msg
               RnTyKiWhat
RnTopConstraint -> MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just MsgDoc
constraint_msg

    constraint_msg :: MsgDoc
constraint_msg = MsgDoc -> Int -> MsgDoc -> MsgDoc
hang
                         (MsgDoc -> MsgDoc
notAllowed MsgDoc
pprAnonWildCard MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"in a constraint")
                        Int
2 MsgDoc
hint_msg
    hint_msg :: MsgDoc
hint_msg = [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"except as the last top-level constraint of a type signature"
                    , Int -> MsgDoc -> MsgDoc
nest Int
2 (String -> MsgDoc
text String
"e.g  f :: (Eq a, _) => blah") ]

checkNamedWildCard :: RnTyKiEnv -> Name -> RnM ()
-- Report an error if a named wildcard is illegal here
checkNamedWildCard :: RnTyKiEnv -> Name -> TcRn ()
checkNamedWildCard RnTyKiEnv
env Name
name
  = RnTyKiEnv -> Maybe MsgDoc -> TcRn ()
checkWildCard RnTyKiEnv
env Maybe MsgDoc
mb_bad
  where
    mb_bad :: Maybe MsgDoc
mb_bad | Bool -> Bool
not (Name
name Name -> FreeVars -> Bool
`elemNameSet` RnTyKiEnv -> FreeVars
rtke_nwcs RnTyKiEnv
env)
           = Maybe MsgDoc
forall a. Maybe a
Nothing  -- Not a wildcard
           | Bool -> Bool
not (RnTyKiEnv -> Bool
wildCardsAllowed RnTyKiEnv
env)
           = MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just (MsgDoc -> MsgDoc
notAllowed (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name))
           | Bool
otherwise
           = case RnTyKiEnv -> RnTyKiWhat
rtke_what RnTyKiEnv
env of
               RnTyKiWhat
RnTypeBody      -> Maybe MsgDoc
forall a. Maybe a
Nothing   -- Allowed
               RnTyKiWhat
RnTopConstraint -> Maybe MsgDoc
forall a. Maybe a
Nothing   -- Allowed
               RnTyKiWhat
RnConstraint    -> MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just MsgDoc
constraint_msg
    constraint_msg :: MsgDoc
constraint_msg = MsgDoc -> MsgDoc
notAllowed (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name) MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"in a constraint"

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



---------------
-- | Ensures either that we're in a type or that -XPolyKinds is set
checkPolyKinds :: Outputable ty
                => RnTyKiEnv
                -> ty      -- ^ type
                -> RnM ()
checkPolyKinds :: RnTyKiEnv -> ty -> TcRn ()
checkPolyKinds RnTyKiEnv
env ty
ty
  | RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env
  = do { Bool
polykinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.PolyKinds
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
polykinds (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         MsgDoc -> TcRn ()
addErr (String -> MsgDoc
text String
"Illegal kind:" MsgDoc -> MsgDoc -> MsgDoc
<+> ty -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ty
ty MsgDoc -> MsgDoc -> MsgDoc
$$
                 String -> MsgDoc
text String
"Did you mean to enable PolyKinds?") }
checkPolyKinds RnTyKiEnv
_ ty
_ = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

notInKinds :: Outputable ty
           => RnTyKiEnv
           -> ty
           -> RnM ()
notInKinds :: RnTyKiEnv -> ty -> TcRn ()
notInKinds RnTyKiEnv
env ty
ty
  | RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env
  = MsgDoc -> TcRn ()
addErr (String -> MsgDoc
text String
"Illegal kind:" MsgDoc -> MsgDoc -> MsgDoc
<+> ty -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ty
ty)
notInKinds RnTyKiEnv
_ ty
_ = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

{- *****************************************************
*                                                      *
          Binding type variables
*                                                      *
***************************************************** -}

bindSigTyVarsFV :: [Name]
                -> RnM (a, FreeVars)
                -> RnM (a, FreeVars)
-- 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 :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindSigTyVarsFV [Name]
tvs RnM (a, FreeVars)
thing_inside
  = do  { Bool
scoped_tyvars <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ScopedTypeVariables
        ; if Bool -> Bool
not Bool
scoped_tyvars then
                RnM (a, FreeVars)
thing_inside
          else
                [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
tvs RnM (a, FreeVars)
thing_inside }

-- | 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 :: [Located RdrName]
-> ([Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars)
bindLRdrNames [Located RdrName]
rdrs [Name] -> RnM (a, FreeVars)
thing_inside
  = do { [Name]
var_names <- (Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> [Located RdrName] -> IOEnv (Env TcGblEnv TcLclEnv) [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe Any -> Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a.
Maybe a -> Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newTyVarNameRn Maybe Any
forall a. Maybe a
Nothing) [Located RdrName]
rdrs
       ; [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
var_names (RnM (a, FreeVars) -> RnM (a, FreeVars))
-> RnM (a, FreeVars) -> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$
         [Name] -> RnM (a, FreeVars)
thing_inside [Name]
var_names }

---------------
bindHsQTyVars :: forall a b.
                 HsDocContext
              -> 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))
                  -- The Bool is True <=> all kind variables used in the
                  -- kind signature are bound on the left.  Reason:
                  -- the last clause of Note [CUSKs: Complete user-supplied
                  -- kind signatures] in HsDecls
              -> RnM (b, FreeVars)

-- See Note [bindHsQTyVars examples]
-- (a) Bring kind variables into scope
--     both (i)  passed in body_kv_occs
--     and  (ii) mentioned in the kinds of hsq_bndrs
-- (b) Bring type variables into scope
--
bindHsQTyVars :: HsDocContext
-> Maybe MsgDoc
-> Maybe a
-> [Located RdrName]
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsQTyVars HsDocContext
doc Maybe MsgDoc
mb_in_doc Maybe a
mb_assoc [Located RdrName]
body_kv_occs LHsQTyVars GhcPs
hsq_bndrs LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars)
thing_inside
  = do { let hs_tv_bndrs :: [LHsTyVarBndr GhcPs]
hs_tv_bndrs = LHsQTyVars GhcPs -> [LHsTyVarBndr GhcPs]
forall pass. LHsQTyVars pass -> [LHsTyVarBndr pass]
hsQTvExplicit LHsQTyVars GhcPs
hsq_bndrs
             bndr_kv_occs :: [Located RdrName]
bndr_kv_occs = [LHsTyVarBndr GhcPs] -> [Located RdrName]
extractHsTyVarBndrsKVs [LHsTyVarBndr GhcPs]
hs_tv_bndrs

       ; let -- See Note [bindHsQTyVars examples] for what
             -- all these various things are doing
             bndrs, kv_occs, implicit_kvs :: [Located RdrName]
             bndrs :: [Located RdrName]
bndrs        = (LHsTyVarBndr GhcPs -> Located RdrName)
-> [LHsTyVarBndr GhcPs] -> [Located RdrName]
forall a b. (a -> b) -> [a] -> [b]
map LHsTyVarBndr GhcPs -> Located RdrName
forall pass. LHsTyVarBndr pass -> Located (IdP pass)
hsLTyVarLocName [LHsTyVarBndr GhcPs]
hs_tv_bndrs
             kv_occs :: [Located RdrName]
kv_occs      = [Located RdrName] -> [Located RdrName]
forall a. Eq a => [Located a] -> [Located a]
nubL ([Located RdrName]
bndr_kv_occs [Located RdrName] -> [Located RdrName] -> [Located RdrName]
forall a. [a] -> [a] -> [a]
++ [Located RdrName]
body_kv_occs)
                                 -- Make sure to list the binder kvs before the
                                 -- body kvs, as mandated by
                                 -- Note [Ordering of implicit variables]
             implicit_kvs :: [Located RdrName]
implicit_kvs = [Located RdrName] -> [Located RdrName] -> [Located RdrName]
filter_occs [Located RdrName]
bndrs [Located RdrName]
kv_occs
             -- dep_bndrs is the subset of bndrs that are dependent
             --   i.e. appear in bndr/body_kv_occs
             -- Can't use implicit_kvs because we've deleted bndrs from that!
             dep_bndrs :: [Located RdrName]
dep_bndrs = (Located RdrName -> Bool) -> [Located RdrName] -> [Located RdrName]
forall a. (a -> Bool) -> [a] -> [a]
filter (Located RdrName -> [Located RdrName] -> Bool
`elemRdr` [Located RdrName]
kv_occs) [Located RdrName]
bndrs
             del :: [Located RdrName] -> [Located RdrName] -> [Located RdrName]
del       = (Located RdrName -> Located RdrName -> Bool)
-> [Located RdrName] -> [Located RdrName] -> [Located RdrName]
forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
deleteBys Located RdrName -> Located RdrName -> Bool
forall a. (HasSrcSpan a, Eq (SrcSpanLess a)) => a -> a -> Bool
eqLocated
             all_bound_on_lhs :: Bool
all_bound_on_lhs = [Located RdrName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (([Located RdrName]
body_kv_occs [Located RdrName] -> [Located RdrName] -> [Located RdrName]
`del` [Located RdrName]
bndrs) [Located RdrName] -> [Located RdrName] -> [Located RdrName]
`del` [Located RdrName]
bndr_kv_occs)

       ; String -> MsgDoc -> TcRn ()
traceRn String
"checkMixedVars3" (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
           [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"kv_occs" MsgDoc -> MsgDoc -> MsgDoc
<+> [Located RdrName] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Located RdrName]
kv_occs
                , String -> MsgDoc
text String
"bndrs"   MsgDoc -> MsgDoc -> MsgDoc
<+> [LHsTyVarBndr GhcPs] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [LHsTyVarBndr GhcPs]
hs_tv_bndrs
                , String -> MsgDoc
text String
"bndr_kv_occs"   MsgDoc -> MsgDoc -> MsgDoc
<+> [Located RdrName] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Located RdrName]
bndr_kv_occs
                , String -> MsgDoc
text String
"wubble" MsgDoc -> MsgDoc -> MsgDoc
<+> [Located RdrName] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr (([Located RdrName]
kv_occs [Located RdrName] -> [Located RdrName] -> [Located RdrName]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Located RdrName]
bndrs) [Located RdrName] -> [Located RdrName] -> [Located RdrName]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Located RdrName]
bndr_kv_occs)
                ]

       ; [Name]
implicit_kv_nms <- (Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> [Located RdrName] -> IOEnv (Env TcGblEnv TcLclEnv) [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe a -> Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a.
Maybe a -> Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newTyVarNameRn Maybe a
mb_assoc) [Located RdrName]
implicit_kvs

       ; [Name] -> RnM (b, FreeVars) -> RnM (b, FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
implicit_kv_nms                     (RnM (b, FreeVars) -> RnM (b, FreeVars))
-> RnM (b, FreeVars) -> RnM (b, FreeVars)
forall a b. (a -> b) -> a -> b
$
         HsDocContext
-> Maybe MsgDoc
-> Maybe a
-> [LHsTyVarBndr GhcPs]
-> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
forall a b.
HsDocContext
-> Maybe MsgDoc
-> Maybe a
-> [LHsTyVarBndr GhcPs]
-> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs HsDocContext
doc Maybe MsgDoc
mb_in_doc Maybe a
mb_assoc [LHsTyVarBndr GhcPs]
hs_tv_bndrs (([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)) -> RnM (b, FreeVars))
-> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)) -> RnM (b, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [LHsTyVarBndr GhcRn]
rn_bndrs ->
    do { String -> MsgDoc -> TcRn ()
traceRn String
"bindHsQTyVars" (LHsQTyVars GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsQTyVars GhcPs
hsq_bndrs MsgDoc -> MsgDoc -> MsgDoc
$$ [Name] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Name]
implicit_kv_nms MsgDoc -> MsgDoc -> MsgDoc
$$ [LHsTyVarBndr GhcRn] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [LHsTyVarBndr GhcRn]
rn_bndrs)
       ; [Name]
dep_bndr_nms <- (Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> [Located RdrName] -> IOEnv (Env TcGblEnv TcLclEnv) [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
lookupLocalOccRn (RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> (Located RdrName -> RdrName)
-> Located RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located RdrName -> RdrName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) [Located RdrName]
dep_bndrs
       ; LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars)
thing_inside (HsQTvs :: forall pass. XHsQTvs pass -> [LHsTyVarBndr pass] -> LHsQTyVars pass
HsQTvs { hsq_ext :: XHsQTvs GhcRn
hsq_ext = HsQTvsRn :: [Name] -> FreeVars -> HsQTvsRn
HsQTvsRn
                                   { hsq_implicit :: [Name]
hsq_implicit  = [Name]
implicit_kv_nms
                                   , hsq_dependent :: FreeVars
hsq_dependent = [Name] -> FreeVars
mkNameSet [Name]
dep_bndr_nms }
                              , hsq_explicit :: [LHsTyVarBndr GhcRn]
hsq_explicit  = [LHsTyVarBndr GhcRn]
rn_bndrs })
                      Bool
all_bound_on_lhs } }

  where
    filter_occs :: [Located RdrName]   -- Bound here
                -> [Located RdrName]   -- Potential implicit binders
                -> [Located RdrName]   -- Final implicit binders
    -- Filter out any potential implicit binders that are either
    -- already in scope, or are explicitly bound in the same HsQTyVars
    filter_occs :: [Located RdrName] -> [Located RdrName] -> [Located RdrName]
filter_occs [Located RdrName]
bndrs [Located RdrName]
occs
      = (Located RdrName -> Bool) -> [Located RdrName] -> [Located RdrName]
forall a. (a -> Bool) -> [a] -> [a]
filterOut Located RdrName -> Bool
is_in_scope [Located RdrName]
occs
      where
        is_in_scope :: Located RdrName -> Bool
is_in_scope Located RdrName
locc = Located RdrName
locc Located RdrName -> [Located RdrName] -> Bool
`elemRdr` [Located RdrName]
bndrs

{- Note [bindHsQTyVars examples]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have
   data T k (a::k1) (b::k) :: k2 -> k1 -> *

Then:
  hs_tv_bndrs = [k, a::k1, b::k], the explicitly-bound variables
  bndrs       = [k,a,b]

  bndr_kv_occs = [k,k1], kind variables free in kind signatures
                         of hs_tv_bndrs

  body_kv_occs = [k2,k1], kind variables free in the
                          result kind signature

  implicit_kvs = [k1,k2], kind variables free in kind signatures
                          of hs_tv_bndrs, and not bound by bndrs

* We want to quantify add implicit bindings for implicit_kvs

* The "dependent" bndrs (hsq_dependent) are the subset of
  bndrs that are free in bndr_kv_occs or body_kv_occs

* If implicit_body_kvs is non-empty, then there is a kind variable
  mentioned in the kind signature that is not bound "on the left".
  That's one of the rules for a CUSK, so we pass that info on
  as the second argument to thing_inside.

* Order is not important in these lists.  All we are doing is
  bring Names into scope.

Finally, you may wonder why filter_occs removes in-scope variables
from bndr/body_kv_occs.  How can anything be in scope?  Answer:
HsQTyVars is /also/ used (slightly oddly) for Haskell-98 syntax
ConDecls
   data T a = forall (b::k). MkT a b
The ConDecl has a LHsQTyVars in it; but 'a' scopes over the entire
ConDecl.  Hence the local RdrEnv may be non-empty and we must filter
out 'a' from the free vars.  (Mind you, in this situation all the
implicit kind variables are bound at the data type level, so there
are none to bind in the ConDecl, so there are no implicitly bound
variables at all.

Note [Kind variable scoping]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If we have
  data T (a :: k) k = ...
we report "k is out of scope" for (a::k).  Reason: k is not brought
into scope until the explicit k-binding that follows.  It would be
terribly confusing to bring into scope an /implicit/ k for a's kind
and a distinct, shadowing explicit k that follows, something like
  data T {k1} (a :: k1) k = ...

So the rule is:

   the implicit binders never include any
   of the explicit binders in the group

Note that in the denerate case
  data T (a :: a) = blah
we get a complaint the second 'a' is not in scope.

That applies to foralls too: e.g.
   forall (a :: k) k . blah

But if the foralls are split, we treat the two groups separately:
   forall (a :: k). forall k. blah
Here we bring into scope an implicit k, which is later shadowed
by the explicit k.

In implementation terms

* In bindHsQTyVars 'k' is free in bndr_kv_occs; then we delete
  the binders {a,k}, and so end with no implicit binders.  Then we
  rename the binders left-to-right, and hence see that 'k' is out of
  scope in the kind of 'a'.

* Similarly in extract_hs_tv_bndrs

Note [Variables used as both types and kinds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We bind the type variables tvs, and kvs is the set of free variables of the
kinds in the scope of the binding. Here is one typical example:

   forall a b. a -> (b::k) -> (c::a)

Here, tvs will be {a,b}, and kvs {k,a}.

We must make sure that kvs includes all of variables in the kinds of type
variable bindings. For instance:

   forall k (a :: k). Proxy a

If we only look in the body of the `forall` type, we will mistakenly conclude
that kvs is {}. But in fact, the type variable `k` is also used as a kind
variable in (a :: k), later in the binding. (This mistake lead to #14710.)
So tvs is {k,a} and kvs is {k}.

NB: we do this only at the binding site of 'tvs'.
-}

bindLHsTyVarBndrs :: HsDocContext
                  -> Maybe SDoc            -- Just d => check for unused tvs
                                           --   d is a phrase like "in the type ..."
                  -> Maybe a               -- Just _  => an associated type decl
                  -> [LHsTyVarBndr GhcPs]  -- User-written tyvars
                  -> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars))
                  -> RnM (b, FreeVars)
bindLHsTyVarBndrs :: HsDocContext
-> Maybe MsgDoc
-> Maybe a
-> [LHsTyVarBndr GhcPs]
-> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs HsDocContext
doc Maybe MsgDoc
mb_in_doc Maybe a
mb_assoc [LHsTyVarBndr GhcPs]
tv_bndrs [LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)
thing_inside
  = do { Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing Maybe a
mb_assoc) ([Located RdrName] -> TcRn ()
checkShadowedRdrNames [Located RdrName]
tv_names_w_loc)
       ; [Located RdrName] -> TcRn ()
checkDupRdrNames [Located RdrName]
tv_names_w_loc
       ; [LHsTyVarBndr GhcPs]
-> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)) -> RnM (b, FreeVars)
go [LHsTyVarBndr GhcPs]
tv_bndrs [LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)
thing_inside }
  where
    tv_names_w_loc :: [Located RdrName]
tv_names_w_loc = (LHsTyVarBndr GhcPs -> Located RdrName)
-> [LHsTyVarBndr GhcPs] -> [Located RdrName]
forall a b. (a -> b) -> [a] -> [b]
map LHsTyVarBndr GhcPs -> Located RdrName
forall pass. LHsTyVarBndr pass -> Located (IdP pass)
hsLTyVarLocName [LHsTyVarBndr GhcPs]
tv_bndrs

    go :: [LHsTyVarBndr GhcPs]
-> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)) -> RnM (b, FreeVars)
go []     [LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)
thing_inside = [LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)
thing_inside []
    go (LHsTyVarBndr GhcPs
b:[LHsTyVarBndr GhcPs]
bs) [LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)
thing_inside = HsDocContext
-> Maybe a
-> LHsTyVarBndr GhcPs
-> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
forall a b.
HsDocContext
-> Maybe a
-> LHsTyVarBndr GhcPs
-> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndr HsDocContext
doc Maybe a
mb_assoc LHsTyVarBndr GhcPs
b ((LHsTyVarBndr GhcRn -> RnM (b, FreeVars)) -> RnM (b, FreeVars))
-> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars)) -> RnM (b, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ LHsTyVarBndr GhcRn
b' ->
                             do { (b
res, FreeVars
fvs) <- [LHsTyVarBndr GhcPs]
-> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)) -> RnM (b, FreeVars)
go [LHsTyVarBndr GhcPs]
bs (([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)) -> RnM (b, FreeVars))
-> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)) -> RnM (b, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [LHsTyVarBndr GhcRn]
bs' ->
                                                [LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)
thing_inside (LHsTyVarBndr GhcRn
b' LHsTyVarBndr GhcRn -> [LHsTyVarBndr GhcRn] -> [LHsTyVarBndr GhcRn]
forall a. a -> [a] -> [a]
: [LHsTyVarBndr GhcRn]
bs')
                                ; LHsTyVarBndr GhcRn -> FreeVars -> TcRn ()
warn_unused LHsTyVarBndr GhcRn
b' FreeVars
fvs
                                ; (b, FreeVars) -> RnM (b, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
res, FreeVars
fvs) }

    warn_unused :: LHsTyVarBndr GhcRn -> FreeVars -> TcRn ()
warn_unused LHsTyVarBndr GhcRn
tv_bndr FreeVars
fvs = case Maybe MsgDoc
mb_in_doc of
      Just MsgDoc
in_doc -> MsgDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcRn ()
warnUnusedForAll MsgDoc
in_doc LHsTyVarBndr GhcRn
tv_bndr FreeVars
fvs
      Maybe MsgDoc
Nothing     -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

bindLHsTyVarBndr :: HsDocContext
                 -> Maybe a   -- associated class
                 -> LHsTyVarBndr GhcPs
                 -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars))
                 -> RnM (b, FreeVars)
bindLHsTyVarBndr :: HsDocContext
-> Maybe a
-> LHsTyVarBndr GhcPs
-> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndr HsDocContext
_doc Maybe a
mb_assoc (LHsTyVarBndr GhcPs -> Located (SrcSpanLess (LHsTyVarBndr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc
                                 (UserTyVar x
                                    lrdr@(dL->L lv _))) LHsTyVarBndr GhcRn -> RnM (b, FreeVars)
thing_inside
  = do { Name
nm <- Maybe a -> Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a.
Maybe a -> Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newTyVarNameRn Maybe a
mb_assoc Located (IdP GhcPs)
Located RdrName
lrdr
       ; [Name] -> RnM (b, FreeVars) -> RnM (b, FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name
nm] (RnM (b, FreeVars) -> RnM (b, FreeVars))
-> RnM (b, FreeVars) -> RnM (b, FreeVars)
forall a b. (a -> b) -> a -> b
$
         LHsTyVarBndr GhcRn -> RnM (b, FreeVars)
thing_inside (SrcSpan -> SrcSpanLess (LHsTyVarBndr GhcRn) -> LHsTyVarBndr GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XUserTyVar GhcRn -> Located (IdP GhcRn) -> HsTyVarBndr GhcRn
forall pass.
XUserTyVar pass -> Located (IdP pass) -> HsTyVarBndr pass
UserTyVar XUserTyVar GhcRn
XUserTyVar GhcPs
x (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
lv SrcSpanLess (Located Name)
Name
nm))) }

bindLHsTyVarBndr HsDocContext
doc Maybe a
mb_assoc (LHsTyVarBndr GhcPs -> Located (SrcSpanLess (LHsTyVarBndr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc (KindedTyVar x lrdr@(dL->L lv _) kind))
                 LHsTyVarBndr GhcRn -> RnM (b, FreeVars)
thing_inside
  = do { Bool
sig_ok <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.KindSignatures
           ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
sig_ok (HsDocContext -> LHsType GhcPs -> TcRn ()
badKindSigErr HsDocContext
doc LHsType GhcPs
kind)
           ; (LHsType GhcRn
kind', FreeVars
fvs1) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsKind HsDocContext
doc LHsType GhcPs
kind
           ; Name
tv_nm  <- Maybe a -> Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a.
Maybe a -> Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newTyVarNameRn Maybe a
mb_assoc Located (IdP GhcPs)
Located RdrName
lrdr
           ; (b
b, FreeVars
fvs2) <- [Name] -> RnM (b, FreeVars) -> RnM (b, FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name
tv_nm]
               (RnM (b, FreeVars) -> RnM (b, FreeVars))
-> RnM (b, FreeVars) -> RnM (b, FreeVars)
forall a b. (a -> b) -> a -> b
$ LHsTyVarBndr GhcRn -> RnM (b, FreeVars)
thing_inside (SrcSpan -> SrcSpanLess (LHsTyVarBndr GhcRn) -> LHsTyVarBndr GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XKindedTyVar GhcRn
-> Located (IdP GhcRn) -> LHsType GhcRn -> HsTyVarBndr GhcRn
forall pass.
XKindedTyVar pass
-> Located (IdP pass) -> LHsKind pass -> HsTyVarBndr pass
KindedTyVar XKindedTyVar GhcRn
XKindedTyVar GhcPs
x (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
lv SrcSpanLess (Located Name)
Name
tv_nm) LHsType GhcRn
kind'))
           ; (b, FreeVars) -> RnM (b, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }

bindLHsTyVarBndr HsDocContext
_ Maybe a
_ (LHsTyVarBndr GhcPs -> Located (SrcSpanLess (LHsTyVarBndr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (XTyVarBndr{})) LHsTyVarBndr GhcRn -> RnM (b, FreeVars)
_ = String -> RnM (b, FreeVars)
forall a. String -> a
panic String
"bindLHsTyVarBndr"
bindLHsTyVarBndr HsDocContext
_ Maybe a
_ LHsTyVarBndr GhcPs
_ LHsTyVarBndr GhcRn -> RnM (b, FreeVars)
_ = String -> RnM (b, FreeVars)
forall a. String -> a
panic String
"bindLHsTyVarBndr: Impossible Match"
                             -- due to #15884

newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name
newTyVarNameRn :: Maybe a -> Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newTyVarNameRn Maybe a
mb_assoc (Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (Located RdrName)
rdr)
  = do { LocalRdrEnv
rdr_env <- RnM LocalRdrEnv
getLocalRdrEnv
       ; case (Maybe a
mb_assoc, LocalRdrEnv -> RdrName -> Maybe Name
lookupLocalRdrEnv LocalRdrEnv
rdr_env RdrName
SrcSpanLess (Located RdrName)
rdr) of
           (Just a
_, Just Name
n) -> Name -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
              -- Use the same Name as the parent class decl

           (Maybe a, Maybe Name)
_                -> Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newLocalBndrRn (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (Located RdrName)
rdr) }
{-
*********************************************************
*                                                       *
        ConDeclField
*                                                       *
*********************************************************

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.
-}

rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs]
                -> RnM ([LConDeclField GhcRn], FreeVars)
-- Also called from RnSource
-- No wildcards can appear in record fields
rnConDeclFields :: HsDocContext
-> [FieldLabel]
-> [LConDeclField GhcPs]
-> RnM ([LConDeclField GhcRn], FreeVars)
rnConDeclFields HsDocContext
ctxt [FieldLabel]
fls [LConDeclField GhcPs]
fields
   = (LConDeclField GhcPs -> RnM (LConDeclField GhcRn, FreeVars))
-> [LConDeclField GhcPs] -> RnM ([LConDeclField GhcRn], FreeVars)
forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (FastStringEnv FieldLabel
-> RnTyKiEnv
-> LConDeclField GhcPs
-> RnM (LConDeclField GhcRn, FreeVars)
rnField FastStringEnv FieldLabel
fl_env RnTyKiEnv
env) [LConDeclField GhcPs]
fields
  where
    env :: RnTyKiEnv
env    = HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
ctxt TypeOrKind
TypeLevel RnTyKiWhat
RnTypeBody
    fl_env :: FastStringEnv FieldLabel
fl_env = [(FastString, FieldLabel)] -> FastStringEnv FieldLabel
forall a. [(FastString, a)] -> FastStringEnv a
mkFsEnv [ (FieldLabel -> FastString
forall a. FieldLbl a -> FastString
flLabel FieldLabel
fl, FieldLabel
fl) | FieldLabel
fl <- [FieldLabel]
fls ]

rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs
        -> RnM (LConDeclField GhcRn, FreeVars)
rnField :: FastStringEnv FieldLabel
-> RnTyKiEnv
-> LConDeclField GhcPs
-> RnM (LConDeclField GhcRn, FreeVars)
rnField FastStringEnv FieldLabel
fl_env RnTyKiEnv
env (LConDeclField GhcPs -> Located (SrcSpanLess (LConDeclField GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
l (ConDeclField _ names ty haddock_doc))
  = do { let new_names :: [GenLocated SrcSpan (FieldOcc GhcRn)]
new_names = (GenLocated SrcSpan (FieldOcc GhcPs)
 -> GenLocated SrcSpan (FieldOcc GhcRn))
-> [GenLocated SrcSpan (FieldOcc GhcPs)]
-> [GenLocated SrcSpan (FieldOcc GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map ((FieldOcc GhcPs -> FieldOcc GhcRn)
-> GenLocated SrcSpan (FieldOcc GhcPs)
-> GenLocated SrcSpan (FieldOcc GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldOcc GhcPs -> FieldOcc GhcRn
lookupField) [GenLocated SrcSpan (FieldOcc GhcPs)]
names
       ; (LHsType GhcRn
new_ty, FreeVars
fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
       ; Maybe LHsDocString
new_haddock_doc <- Maybe LHsDocString -> RnM (Maybe LHsDocString)
rnMbLHsDoc Maybe LHsDocString
haddock_doc
       ; (LConDeclField GhcRn, FreeVars)
-> RnM (LConDeclField GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> SrcSpanLess (LConDeclField GhcRn) -> LConDeclField GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
l (XConDeclField GhcRn
-> [GenLocated SrcSpan (FieldOcc GhcRn)]
-> LHsType GhcRn
-> Maybe LHsDocString
-> ConDeclField GhcRn
forall pass.
XConDeclField pass
-> [LFieldOcc pass]
-> LBangType pass
-> Maybe LHsDocString
-> ConDeclField pass
ConDeclField NoExt
XConDeclField GhcRn
noExt [GenLocated SrcSpan (FieldOcc GhcRn)]
new_names LHsType GhcRn
new_ty Maybe LHsDocString
new_haddock_doc)
                , FreeVars
fvs) }
  where
    lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn
    lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn
lookupField (FieldOcc XCFieldOcc GhcPs
_ (Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
lr SrcSpanLess (Located RdrName)
rdr)) =
        XCFieldOcc GhcRn -> Located RdrName -> FieldOcc GhcRn
forall pass. XCFieldOcc pass -> Located RdrName -> FieldOcc pass
FieldOcc (FieldLabel -> Name
forall a. FieldLbl a -> a
flSelector FieldLabel
fl) (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
lr SrcSpanLess (Located RdrName)
rdr)
      where
        lbl :: FastString
lbl = OccName -> FastString
occNameFS (OccName -> FastString) -> OccName -> FastString
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
rdrNameOcc RdrName
SrcSpanLess (Located RdrName)
rdr
        fl :: FieldLabel
fl  = String -> Maybe FieldLabel -> FieldLabel
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"rnField" (Maybe FieldLabel -> FieldLabel) -> Maybe FieldLabel -> FieldLabel
forall a b. (a -> b) -> a -> b
$ FastStringEnv FieldLabel -> FastString -> Maybe FieldLabel
forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv FastStringEnv FieldLabel
fl_env FastString
lbl
    lookupField (XFieldOcc{}) = String -> FieldOcc GhcRn
forall a. String -> a
panic String
"rnField"
rnField FastStringEnv FieldLabel
_ RnTyKiEnv
_ (LConDeclField GhcPs -> Located (SrcSpanLess (LConDeclField GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (XConDeclField _)) = String -> RnM (LConDeclField GhcRn, FreeVars)
forall a. String -> a
panic String
"rnField"
rnField FastStringEnv FieldLabel
_ RnTyKiEnv
_ LConDeclField GhcPs
_ = String -> RnM (LConDeclField GhcRn, FreeVars)
forall a. String -> a
panic String
"rnField: Impossible Match"
                             -- due to #15884

{-
************************************************************************
*                                                                      *
        Fixities and precedence parsing
*                                                                      *
************************************************************************

@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 applications left-associatively, EXCEPT negation, which
we need to handle specially.
Infix types are read in a *right-associative* way, so that
        a `op` b `op` c
is always read in as
        a `op` (b `op` c)

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

---------------
-- Building (ty1 `op1` (ty21 `op2` ty22))
mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
           -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn
           -> RnM (HsType GhcRn)

mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> Name
-> Fixity
-> LHsType GhcRn
-> LHsType GhcRn
-> RnM (HsType GhcRn)
mkHsOpTyRn LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk1 Name
pp_op1 Fixity
fix1 LHsType GhcRn
ty1 (LHsType GhcRn -> Located (SrcSpanLess (LHsType GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc2 (HsOpTy noExt ty21 op2 ty22))
  = do  { Fixity
fix2 <- Located Name -> RnM Fixity
lookupTyFixityRn Located (IdP GhcRn)
Located Name
op2
        ; (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> Name
-> Fixity
-> LHsType GhcRn
-> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> Name
-> Fixity
-> LHsType GhcRn
-> LHsType GhcRn
-> SrcSpan
-> RnM (HsType GhcRn)
mk_hs_op_ty LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk1 Name
pp_op1 Fixity
fix1 LHsType GhcRn
ty1
                      (\LHsType GhcRn
t1 LHsType GhcRn
t2 -> XOpTy GhcRn
-> LHsType GhcRn
-> Located (IdP GhcRn)
-> LHsType GhcRn
-> HsType GhcRn
forall pass.
XOpTy pass
-> LHsType pass
-> Located (IdP pass)
-> LHsType pass
-> HsType pass
HsOpTy XOpTy GhcRn
noExt LHsType GhcRn
t1 Located (IdP GhcRn)
op2 LHsType GhcRn
t2)
                      (Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP GhcRn)
Located Name
op2) Fixity
fix2 LHsType GhcRn
ty21 LHsType GhcRn
ty22 SrcSpan
loc2 }

mkHsOpTyRn LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk1 Name
pp_op1 Fixity
fix1 LHsType GhcRn
ty1 (LHsType GhcRn -> Located (SrcSpanLess (LHsType GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc2 (HsFunTy _ ty21 ty22))
  = (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> Name
-> Fixity
-> LHsType GhcRn
-> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> Name
-> Fixity
-> LHsType GhcRn
-> LHsType GhcRn
-> SrcSpan
-> RnM (HsType GhcRn)
mk_hs_op_ty LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk1 Name
pp_op1 Fixity
fix1 LHsType GhcRn
ty1
                (XFunTy GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XFunTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy NoExt
XFunTy GhcRn
noExt) Name
funTyConName Fixity
funTyFixity LHsType GhcRn
ty21 LHsType GhcRn
ty22 SrcSpan
loc2

mkHsOpTyRn LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk1 Name
_ Fixity
_ LHsType GhcRn
ty1 LHsType GhcRn
ty2              -- Default case, no rearrangment
  = HsType GhcRn -> RnM (HsType GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk1 LHsType GhcRn
ty1 LHsType GhcRn
ty2)

---------------
mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
            -> Name -> Fixity -> LHsType GhcRn
            -> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
            -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> SrcSpan
            -> RnM (HsType GhcRn)
mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> Name
-> Fixity
-> LHsType GhcRn
-> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> Name
-> Fixity
-> LHsType GhcRn
-> LHsType GhcRn
-> SrcSpan
-> RnM (HsType GhcRn)
mk_hs_op_ty LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk1 Name
op1 Fixity
fix1 LHsType GhcRn
ty1
            LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk2 Name
op2 Fixity
fix2 LHsType GhcRn
ty21 LHsType GhcRn
ty22 SrcSpan
loc2
  | Bool
nofix_error     = do { (OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr (Name -> OpName
NormalOp Name
op1,Fixity
fix1) (Name -> OpName
NormalOp Name
op2,Fixity
fix2)
                         ; HsType GhcRn -> RnM (HsType GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk1 LHsType GhcRn
ty1 (SrcSpan -> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc2 (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk2 LHsType GhcRn
ty21 LHsType GhcRn
ty22))) }
  | Bool
associate_right = HsType GhcRn -> RnM (HsType GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk1 LHsType GhcRn
ty1 (SrcSpan -> SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc2 (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk2 LHsType GhcRn
ty21 LHsType GhcRn
ty22)))
  | Bool
otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
                           HsType GhcRn
new_ty <- (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> Name
-> Fixity
-> LHsType GhcRn
-> LHsType GhcRn
-> RnM (HsType GhcRn)
mkHsOpTyRn LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk1 Name
op1 Fixity
fix1 LHsType GhcRn
ty1 LHsType GhcRn
ty21
                         ; HsType GhcRn -> RnM (HsType GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk2 (SrcSpanLess (LHsType GhcRn) -> LHsType GhcRn
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc HsType GhcRn
SrcSpanLess (LHsType GhcRn)
new_ty) LHsType GhcRn
ty22) }
  where
    (Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 Fixity
fix2


---------------------------
mkOpAppRn :: LHsExpr GhcRn             -- Left operand; already rearranged
          -> LHsExpr GhcRn -> Fixity   -- Operator and fixity
          -> LHsExpr GhcRn             -- Right operand (not an OpApp, but might
                                       -- be a NegApp)
          -> RnM (HsExpr GhcRn)

-- (e11 `op1` e12) `op2` e2
mkOpAppRn :: LHsExpr GhcRn
-> LHsExpr GhcRn -> Fixity -> LHsExpr GhcRn -> RnM (HsExpr GhcRn)
mkOpAppRn e1 :: LHsExpr GhcRn
e1@(LHsExpr GhcRn -> Located (SrcSpanLess (LHsExpr GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (OpApp fix1 e11 op1 e12)) LHsExpr GhcRn
op2 Fixity
fix2 LHsExpr GhcRn
e2
  | Bool
nofix_error
  = do (OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr (LHsExpr GhcRn -> OpName
get_op LHsExpr GhcRn
op1,XOpApp GhcRn
Fixity
fix1) (LHsExpr GhcRn -> OpName
get_op LHsExpr GhcRn
op2,Fixity
fix2)
       HsExpr GhcRn -> RnM (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (XOpApp GhcRn
-> LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcRn
Fixity
fix2 LHsExpr GhcRn
e1 LHsExpr GhcRn
op2 LHsExpr GhcRn
e2)

  | Bool
associate_right = do
    HsExpr GhcRn
new_e <- LHsExpr GhcRn
-> LHsExpr GhcRn -> Fixity -> LHsExpr GhcRn -> RnM (HsExpr GhcRn)
mkOpAppRn LHsExpr GhcRn
e12 LHsExpr GhcRn
op2 Fixity
fix2 LHsExpr GhcRn
e2
    HsExpr GhcRn -> RnM (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (XOpApp GhcRn
-> LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcRn
fix1 LHsExpr GhcRn
e11 LHsExpr GhcRn
op1 (SrcSpan -> SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc' HsExpr GhcRn
SrcSpanLess (LHsExpr GhcRn)
new_e))
  where
    loc' :: SrcSpan
loc'= LHsExpr GhcRn -> LHsExpr GhcRn -> SrcSpan
forall a b. (HasSrcSpan a, HasSrcSpan b) => a -> b -> SrcSpan
combineLocs LHsExpr GhcRn
e12 LHsExpr GhcRn
e2
    (Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity XOpApp GhcRn
Fixity
fix1 Fixity
fix2

---------------------------
--      (- neg_arg) `op` e2
mkOpAppRn e1 :: LHsExpr GhcRn
e1@(LHsExpr GhcRn -> Located (SrcSpanLess (LHsExpr GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (NegApp _ neg_arg neg_name)) LHsExpr GhcRn
op2 Fixity
fix2 LHsExpr GhcRn
e2
  | Bool
nofix_error
  = do (OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr (OpName
NegateOp,Fixity
negateFixity) (LHsExpr GhcRn -> OpName
get_op LHsExpr GhcRn
op2,Fixity
fix2)
       HsExpr GhcRn -> RnM (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (XOpApp GhcRn
-> LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcRn
Fixity
fix2 LHsExpr GhcRn
e1 LHsExpr GhcRn
op2 LHsExpr GhcRn
e2)

  | Bool
associate_right
  = do HsExpr GhcRn
new_e <- LHsExpr GhcRn
-> LHsExpr GhcRn -> Fixity -> LHsExpr GhcRn -> RnM (HsExpr GhcRn)
mkOpAppRn LHsExpr GhcRn
neg_arg LHsExpr GhcRn
op2 Fixity
fix2 LHsExpr GhcRn
e2
       HsExpr GhcRn -> RnM (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (XNegApp GhcRn -> LHsExpr GhcRn -> SyntaxExpr GhcRn -> HsExpr GhcRn
forall p. XNegApp p -> LHsExpr p -> SyntaxExpr p -> HsExpr p
NegApp NoExt
XNegApp GhcRn
noExt (SrcSpan -> SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc' HsExpr GhcRn
SrcSpanLess (LHsExpr GhcRn)
new_e) SyntaxExpr GhcRn
neg_name)
  where
    loc' :: SrcSpan
loc' = LHsExpr GhcRn -> LHsExpr GhcRn -> SrcSpan
forall a b. (HasSrcSpan a, HasSrcSpan b) => a -> b -> SrcSpan
combineLocs LHsExpr GhcRn
neg_arg LHsExpr GhcRn
e2
    (Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
negateFixity Fixity
fix2

---------------------------
--      e1 `op` - neg_arg
mkOpAppRn LHsExpr GhcRn
e1 LHsExpr GhcRn
op1 Fixity
fix1 e2 :: LHsExpr GhcRn
e2@(LHsExpr GhcRn -> Located (SrcSpanLess (LHsExpr GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (NegApp {})) -- NegApp can occur on the right
  | Bool -> Bool
not Bool
associate_right                        -- We *want* right association
  = do (OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr (LHsExpr GhcRn -> OpName
get_op LHsExpr GhcRn
op1, Fixity
fix1) (OpName
NegateOp, Fixity
negateFixity)
       HsExpr GhcRn -> RnM (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (XOpApp GhcRn
-> LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcRn
Fixity
fix1 LHsExpr GhcRn
e1 LHsExpr GhcRn
op1 LHsExpr GhcRn
e2)
  where
    (Bool
_, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 Fixity
negateFixity

---------------------------
--      Default case
mkOpAppRn LHsExpr GhcRn
e1 LHsExpr GhcRn
op Fixity
fix LHsExpr GhcRn
e2                  -- Default case, no rearrangment
  = ASSERT2( right_op_ok fix (unLoc e2),
             ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
    )
    HsExpr GhcRn -> RnM (HsExpr GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (XOpApp GhcRn
-> LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
forall p.
XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p
OpApp XOpApp GhcRn
Fixity
fix LHsExpr GhcRn
e1 LHsExpr GhcRn
op LHsExpr GhcRn
e2)

----------------------------

-- | Name of an operator in an operator application or section
data OpName = NormalOp Name         -- ^ A normal identifier
            | NegateOp              -- ^ Prefix negation
            | UnboundOp UnboundVar  -- ^ An unbound indentifier
            | RecFldOp (AmbiguousFieldOcc GhcRn)
              -- ^ A (possibly ambiguous) record field occurrence

instance Outputable OpName where
  ppr :: OpName -> MsgDoc
ppr (NormalOp Name
n)   = Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
n
  ppr OpName
NegateOp       = Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
negateName
  ppr (UnboundOp UnboundVar
uv) = UnboundVar -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr UnboundVar
uv
  ppr (RecFldOp AmbiguousFieldOcc GhcRn
fld) = AmbiguousFieldOcc GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr AmbiguousFieldOcc GhcRn
fld

get_op :: LHsExpr GhcRn -> OpName
-- An unbound name could be either HsVar or HsUnboundVar
-- See RnExpr.rnUnboundVar
get_op :: LHsExpr GhcRn -> OpName
get_op (LHsExpr GhcRn -> Located (SrcSpanLess (LHsExpr GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsVar _ n))         = Name -> OpName
NormalOp (Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP GhcRn)
Located Name
n)
get_op (LHsExpr GhcRn -> Located (SrcSpanLess (LHsExpr GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsUnboundVar _ uv)) = UnboundVar -> OpName
UnboundOp UnboundVar
uv
get_op (LHsExpr GhcRn -> Located (SrcSpanLess (LHsExpr GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (HsRecFld _ fld))    = AmbiguousFieldOcc GhcRn -> OpName
RecFldOp AmbiguousFieldOcc GhcRn
fld
get_op LHsExpr GhcRn
other                         = String -> MsgDoc -> OpName
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"get_op" (LHsExpr GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsExpr GhcRn
other)

-- Parser left-associates everything, but
-- derived instances may have correctly-associated things to
-- in the right operand.  So we just check that the right operand is OK
right_op_ok :: Fixity -> HsExpr GhcRn -> Bool
right_op_ok :: Fixity -> HsExpr GhcRn -> Bool
right_op_ok Fixity
fix1 (OpApp XOpApp GhcRn
fix2 LHsExpr GhcRn
_ LHsExpr GhcRn
_ LHsExpr GhcRn
_)
  = Bool -> Bool
not Bool
error_please Bool -> Bool -> Bool
&& Bool
associate_right
  where
    (Bool
error_please, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 XOpApp GhcRn
Fixity
fix2
right_op_ok Fixity
_ HsExpr GhcRn
_
  = Bool
True

-- Parser initially makes negation bind more tightly than any other operator
-- And "deriving" code should respect this (use HsPar if not)
mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id)
           -> RnM (HsExpr (GhcPass id))
mkNegAppRn :: LHsExpr (GhcPass id)
-> SyntaxExpr (GhcPass id) -> RnM (HsExpr (GhcPass id))
mkNegAppRn LHsExpr (GhcPass id)
neg_arg SyntaxExpr (GhcPass id)
neg_name
  = ASSERT( not_op_app (unLoc neg_arg) )
    HsExpr (GhcPass id) -> RnM (HsExpr (GhcPass id))
forall (m :: * -> *) a. Monad m => a -> m a
return (XNegApp (GhcPass id)
-> LHsExpr (GhcPass id)
-> SyntaxExpr (GhcPass id)
-> HsExpr (GhcPass id)
forall p. XNegApp p -> LHsExpr p -> SyntaxExpr p -> HsExpr p
NegApp NoExt
XNegApp (GhcPass id)
noExt LHsExpr (GhcPass id)
neg_arg SyntaxExpr (GhcPass id)
neg_name)

not_op_app :: HsExpr id -> Bool
not_op_app :: HsExpr id -> Bool
not_op_app (OpApp {}) = Bool
False
not_op_app HsExpr id
_          = Bool
True

---------------------------
mkOpFormRn :: LHsCmdTop GhcRn            -- Left operand; already rearranged
          -> LHsExpr GhcRn -> Fixity     -- Operator and fixity
          -> LHsCmdTop GhcRn             -- Right operand (not an infix)
          -> RnM (HsCmd GhcRn)

-- (e11 `op1` e12) `op2` e2
mkOpFormRn :: LHsCmdTop GhcRn
-> LHsExpr GhcRn -> Fixity -> LHsCmdTop GhcRn -> RnM (HsCmd GhcRn)
mkOpFormRn a1 :: LHsCmdTop GhcRn
a1@(LHsCmdTop GhcRn -> Located (SrcSpanLess (LHsCmdTop GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc
                    (HsCmdTop _
                     (dL->L _ (HsCmdArrForm x op1 f (Just fix1)
                        [a11,a12]))))
        LHsExpr GhcRn
op2 Fixity
fix2 LHsCmdTop GhcRn
a2
  | Bool
nofix_error
  = do (OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr (LHsExpr GhcRn -> OpName
get_op LHsExpr GhcRn
op1,Fixity
fix1) (LHsExpr GhcRn -> OpName
get_op LHsExpr GhcRn
op2,Fixity
fix2)
       HsCmd GhcRn -> RnM (HsCmd GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdArrForm GhcRn
-> LHsExpr GhcRn
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop GhcRn]
-> HsCmd GhcRn
forall id.
XCmdArrForm id
-> LHsExpr id
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop id]
-> HsCmd id
HsCmdArrForm XCmdArrForm GhcRn
x LHsExpr GhcRn
op2 LexicalFixity
f (Fixity -> Maybe Fixity
forall a. a -> Maybe a
Just Fixity
fix2) [LHsCmdTop GhcRn
a1, LHsCmdTop GhcRn
a2])

  | Bool
associate_right
  = do HsCmd GhcRn
new_c <- LHsCmdTop GhcRn
-> LHsExpr GhcRn -> Fixity -> LHsCmdTop GhcRn -> RnM (HsCmd GhcRn)
mkOpFormRn LHsCmdTop GhcRn
a12 LHsExpr GhcRn
op2 Fixity
fix2 LHsCmdTop GhcRn
a2
       HsCmd GhcRn -> RnM (HsCmd GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdArrForm GhcRn
-> LHsExpr GhcRn
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop GhcRn]
-> HsCmd GhcRn
forall id.
XCmdArrForm id
-> LHsExpr id
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop id]
-> HsCmd id
HsCmdArrForm NoExt
XCmdArrForm GhcRn
noExt LHsExpr GhcRn
op1 LexicalFixity
f (Fixity -> Maybe Fixity
forall a. a -> Maybe a
Just Fixity
fix1)
               [LHsCmdTop GhcRn
a11, SrcSpan -> SrcSpanLess (LHsCmdTop GhcRn) -> LHsCmdTop GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XCmdTop GhcRn -> LHsCmd GhcRn -> HsCmdTop GhcRn
forall p. XCmdTop p -> LHsCmd p -> HsCmdTop p
HsCmdTop [] (SrcSpan -> SrcSpanLess (LHsCmd GhcRn) -> LHsCmd GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc HsCmd GhcRn
SrcSpanLess (LHsCmd GhcRn)
new_c))])
        -- TODO: locs are wrong
  where
    (Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 Fixity
fix2

--      Default case
mkOpFormRn LHsCmdTop GhcRn
arg1 LHsExpr GhcRn
op Fixity
fix LHsCmdTop GhcRn
arg2                     -- Default case, no rearrangment
  = HsCmd GhcRn -> RnM (HsCmd GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdArrForm GhcRn
-> LHsExpr GhcRn
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop GhcRn]
-> HsCmd GhcRn
forall id.
XCmdArrForm id
-> LHsExpr id
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop id]
-> HsCmd id
HsCmdArrForm NoExt
XCmdArrForm GhcRn
noExt LHsExpr GhcRn
op LexicalFixity
Infix (Fixity -> Maybe Fixity
forall a. a -> Maybe a
Just Fixity
fix) [LHsCmdTop GhcRn
arg1, LHsCmdTop GhcRn
arg2])


--------------------------------------
mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn
             -> RnM (Pat GhcRn)

mkConOpPatRn :: Located Name
-> Fixity -> LPat GhcRn -> LPat GhcRn -> RnM (LPat GhcRn)
mkConOpPatRn Located Name
op2 Fixity
fix2 p1 :: LPat GhcRn
p1@(LPat GhcRn -> Located (SrcSpanLess (LPat GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc (ConPatIn op1 (InfixCon p11 p12))) LPat GhcRn
p2
  = do  { Fixity
fix1 <- Name -> RnM Fixity
lookupFixityRn (Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP GhcRn)
Located Name
op1)
        ; let (Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 Fixity
fix2

        ; if Bool
nofix_error then do
                { (OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr (Name -> OpName
NormalOp (Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP GhcRn)
Located Name
op1),Fixity
fix1)
                               (Name -> OpName
NormalOp (Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located Name
op2),Fixity
fix2)
                ; LPat GhcRn -> RnM (LPat GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (IdP GhcRn) -> HsConPatDetails GhcRn -> LPat GhcRn
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn Located (IdP GhcRn)
Located Name
op2 (LPat GhcRn -> LPat GhcRn -> HsConPatDetails GhcRn
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon LPat GhcRn
p1 LPat GhcRn
p2)) }

          else if Bool
associate_right then do
                { LPat GhcRn
new_p <- Located Name
-> Fixity -> LPat GhcRn -> LPat GhcRn -> RnM (LPat GhcRn)
mkConOpPatRn Located Name
op2 Fixity
fix2 LPat GhcRn
p12 LPat GhcRn
p2
                ; LPat GhcRn -> RnM (LPat GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (IdP GhcRn) -> HsConPatDetails GhcRn -> LPat GhcRn
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn Located (IdP GhcRn)
op1 (LPat GhcRn -> LPat GhcRn -> HsConPatDetails GhcRn
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon LPat GhcRn
p11 (SrcSpan -> SrcSpanLess (LPat GhcRn) -> LPat GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc LPat GhcRn
SrcSpanLess (LPat GhcRn)
new_p))) }
                -- XXX loc right?
          else LPat GhcRn -> RnM (LPat GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (IdP GhcRn) -> HsConPatDetails GhcRn -> LPat GhcRn
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn Located (IdP GhcRn)
Located Name
op2 (LPat GhcRn -> LPat GhcRn -> HsConPatDetails GhcRn
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon LPat GhcRn
p1 LPat GhcRn
p2)) }

mkConOpPatRn Located Name
op Fixity
_ LPat GhcRn
p1 LPat GhcRn
p2                         -- Default case, no rearrangment
  = ASSERT( not_op_pat (unLoc p2) )
    LPat GhcRn -> RnM (LPat GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (Located (IdP GhcRn) -> HsConPatDetails GhcRn -> LPat GhcRn
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn Located (IdP GhcRn)
Located Name
op (LPat GhcRn -> LPat GhcRn -> HsConPatDetails GhcRn
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon LPat GhcRn
p1 LPat GhcRn
p2))

not_op_pat :: Pat GhcRn -> Bool
not_op_pat :: LPat GhcRn -> Bool
not_op_pat (ConPatIn Located (IdP GhcRn)
_ (InfixCon LPat GhcRn
_ LPat GhcRn
_)) = Bool
False
not_op_pat LPat GhcRn
_                           = Bool
True

--------------------------------------
checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM ()
  -- Check precedence of a function binding written infix
  --   eg  a `op` b `C` c = ...
  -- See comments with rnExpr (OpApp ...) about "deriving"

checkPrecMatch :: Name -> MatchGroup GhcRn body -> TcRn ()
checkPrecMatch Name
op (MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = (Located [LMatch GhcRn body]
-> Located (SrcSpanLess (Located [LMatch GhcRn body]))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located [LMatch GhcRn body])
ms) })
  = (LMatch GhcRn body -> TcRn ()) -> [LMatch GhcRn body] -> TcRn ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ LMatch GhcRn body -> TcRn ()
check [LMatch GhcRn body]
SrcSpanLess (Located [LMatch GhcRn body])
ms
  where
    check :: LMatch GhcRn body -> TcRn ()
check (LMatch GhcRn body -> Located (SrcSpanLess (LMatch GhcRn body))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (Match { m_pats = (dL->L l1 p1)
                                   : (dL->L l2 p2)
                                   : _ }))
      = SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans SrcSpan
l1 SrcSpan
l2) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
        do Name -> LPat GhcRn -> Bool -> TcRn ()
checkPrec Name
op LPat GhcRn
SrcSpanLess (LPat GhcRn)
p1 Bool
False
           Name -> LPat GhcRn -> Bool -> TcRn ()
checkPrec Name
op LPat GhcRn
SrcSpanLess (LPat GhcRn)
p2 Bool
True

    check LMatch GhcRn body
_ = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        -- This can happen.  Consider
        --      a `op` True = ...
        --      op          = ...
        -- The infix flag comes from the first binding of the group
        -- but the second eqn has no args (an error, but not discovered
        -- until the type checker).  So we don't want to crash on the
        -- second eqn.
checkPrecMatch Name
_ (XMatchGroup {}) = String -> TcRn ()
forall a. String -> a
panic String
"checkPrecMatch"

checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkPrec :: Name -> LPat GhcRn -> Bool -> TcRn ()
checkPrec Name
op (ConPatIn Located (IdP GhcRn)
op1 (InfixCon LPat GhcRn
_ LPat GhcRn
_)) Bool
right = do
    op_fix :: Fixity
op_fix@(Fixity SourceText
_ Int
op_prec  FixityDirection
op_dir) <- Name -> RnM Fixity
lookupFixityRn Name
op
    op1_fix :: Fixity
op1_fix@(Fixity SourceText
_ Int
op1_prec FixityDirection
op1_dir) <- Name -> RnM Fixity
lookupFixityRn (Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP GhcRn)
Located Name
op1)
    let
        inf_ok :: Bool
inf_ok = Int
op1_prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
op_prec Bool -> Bool -> Bool
||
                 (Int
op1_prec Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
op_prec Bool -> Bool -> Bool
&&
                  (FixityDirection
op1_dir FixityDirection -> FixityDirection -> Bool
forall a. Eq a => a -> a -> Bool
== FixityDirection
InfixR Bool -> Bool -> Bool
&& FixityDirection
op_dir FixityDirection -> FixityDirection -> Bool
forall a. Eq a => a -> a -> Bool
== FixityDirection
InfixR Bool -> Bool -> Bool
&& Bool
right Bool -> Bool -> Bool
||
                   FixityDirection
op1_dir FixityDirection -> FixityDirection -> Bool
forall a. Eq a => a -> a -> Bool
== FixityDirection
InfixL Bool -> Bool -> Bool
&& FixityDirection
op_dir FixityDirection -> FixityDirection -> Bool
forall a. Eq a => a -> a -> Bool
== FixityDirection
InfixL Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
right))

        info :: (OpName, Fixity)
info  = (Name -> OpName
NormalOp Name
op,          Fixity
op_fix)
        info1 :: (OpName, Fixity)
info1 = (Name -> OpName
NormalOp (Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located (IdP GhcRn)
Located Name
op1), Fixity
op1_fix)
        ((OpName, Fixity)
infol, (OpName, Fixity)
infor) = if Bool
right then ((OpName, Fixity)
info, (OpName, Fixity)
info1) else ((OpName, Fixity)
info1, (OpName, Fixity)
info)
    Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
inf_ok ((OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr (OpName, Fixity)
infol (OpName, Fixity)
infor)

checkPrec Name
_ LPat GhcRn
_ Bool
_
  = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Check precedence of (arg op) or (op arg) respectively
-- If arg is itself an operator application, then either
--   (a) its precedence must be higher than that of op
--   (b) its precedency & associativity must be the same as that of op
checkSectionPrec :: FixityDirection -> HsExpr GhcPs
        -> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM ()
checkSectionPrec :: FixityDirection
-> HsExpr GhcPs -> LHsExpr GhcRn -> LHsExpr GhcRn -> TcRn ()
checkSectionPrec FixityDirection
direction HsExpr GhcPs
section LHsExpr GhcRn
op LHsExpr GhcRn
arg
  = case LHsExpr GhcRn -> SrcSpanLess (LHsExpr GhcRn)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsExpr GhcRn
arg of
        OpApp fix _ op' _ -> OpName -> Fixity -> TcRn ()
go_for_it (LHsExpr GhcRn -> OpName
get_op LHsExpr GhcRn
op') XOpApp GhcRn
Fixity
fix
        NegApp _ _ _      -> OpName -> Fixity -> TcRn ()
go_for_it OpName
NegateOp     Fixity
negateFixity
        SrcSpanLess (LHsExpr GhcRn)
_                 -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    op_name :: OpName
op_name = LHsExpr GhcRn -> OpName
get_op LHsExpr GhcRn
op
    go_for_it :: OpName -> Fixity -> TcRn ()
go_for_it OpName
arg_op arg_fix :: Fixity
arg_fix@(Fixity SourceText
_ Int
arg_prec FixityDirection
assoc) = do
          op_fix :: Fixity
op_fix@(Fixity SourceText
_ Int
op_prec FixityDirection
_) <- OpName -> RnM Fixity
lookupFixityOp OpName
op_name
          Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
op_prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
arg_prec
                  Bool -> Bool -> Bool
|| (Int
op_prec Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
arg_prec Bool -> Bool -> Bool
&& FixityDirection
direction FixityDirection -> FixityDirection -> Bool
forall a. Eq a => a -> a -> Bool
== FixityDirection
assoc))
                 ((OpName, Fixity) -> (OpName, Fixity) -> HsExpr GhcPs -> TcRn ()
sectionPrecErr (LHsExpr GhcRn -> OpName
get_op LHsExpr GhcRn
op, Fixity
op_fix)
                                 (OpName
arg_op, Fixity
arg_fix) HsExpr GhcPs
section)

-- | Look up the fixity for an operator name.  Be careful to use
-- 'lookupFieldFixityRn' for (possibly ambiguous) record fields
-- (see Trac #13132).
lookupFixityOp :: OpName -> RnM Fixity
lookupFixityOp :: OpName -> RnM Fixity
lookupFixityOp (NormalOp Name
n)  = Name -> RnM Fixity
lookupFixityRn Name
n
lookupFixityOp OpName
NegateOp      = Name -> RnM Fixity
lookupFixityRn Name
negateName
lookupFixityOp (UnboundOp UnboundVar
u) = Name -> RnM Fixity
lookupFixityRn (OccName -> Name
mkUnboundName (UnboundVar -> OccName
unboundVarOcc UnboundVar
u))
lookupFixityOp (RecFldOp AmbiguousFieldOcc GhcRn
f)  = AmbiguousFieldOcc GhcRn -> RnM Fixity
lookupFieldFixityRn AmbiguousFieldOcc GhcRn
f


-- Precedence-related error messages

precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM ()
precParseErr :: (OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr op1 :: (OpName, Fixity)
op1@(OpName
n1,Fixity
_) op2 :: (OpName, Fixity)
op2@(OpName
n2,Fixity
_)
  | OpName -> Bool
is_unbound OpName
n1 Bool -> Bool -> Bool
|| OpName -> Bool
is_unbound OpName
n2
  = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()     -- Avoid error cascade
  | Bool
otherwise
  = MsgDoc -> TcRn ()
addErr (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"Precedence parsing error")
      Int
4 ([MsgDoc] -> MsgDoc
hsep [String -> MsgDoc
text String
"cannot mix", (OpName, Fixity) -> MsgDoc
ppr_opfix (OpName, Fixity)
op1, PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"and"),
               (OpName, Fixity) -> MsgDoc
ppr_opfix (OpName, Fixity)
op2,
               String -> MsgDoc
text String
"in the same infix expression"])

sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr GhcPs -> RnM ()
sectionPrecErr :: (OpName, Fixity) -> (OpName, Fixity) -> HsExpr GhcPs -> TcRn ()
sectionPrecErr op :: (OpName, Fixity)
op@(OpName
n1,Fixity
_) arg_op :: (OpName, Fixity)
arg_op@(OpName
n2,Fixity
_) HsExpr GhcPs
section
  | OpName -> Bool
is_unbound OpName
n1 Bool -> Bool -> Bool
|| OpName -> Bool
is_unbound OpName
n2
  = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()     -- Avoid error cascade
  | Bool
otherwise
  = MsgDoc -> TcRn ()
addErr (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ [MsgDoc] -> MsgDoc
vcat [String -> MsgDoc
text String
"The operator" MsgDoc -> MsgDoc -> MsgDoc
<+> (OpName, Fixity) -> MsgDoc
ppr_opfix (OpName, Fixity)
op MsgDoc -> MsgDoc -> MsgDoc
<+> PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"of a section"),
         Int -> MsgDoc -> MsgDoc
nest Int
4 ([MsgDoc] -> MsgDoc
sep [String -> MsgDoc
text String
"must have lower precedence than that of the operand,",
                      Int -> MsgDoc -> MsgDoc
nest Int
2 (String -> MsgDoc
text String
"namely" MsgDoc -> MsgDoc -> MsgDoc
<+> (OpName, Fixity) -> MsgDoc
ppr_opfix (OpName, Fixity)
arg_op)]),
         Int -> MsgDoc -> MsgDoc
nest Int
4 (String -> MsgDoc
text String
"in the section:" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (HsExpr GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsExpr GhcPs
section))]

is_unbound :: OpName -> Bool
is_unbound :: OpName -> Bool
is_unbound (NormalOp Name
n) = Name -> Bool
isUnboundName Name
n
is_unbound UnboundOp{}  = Bool
True
is_unbound OpName
_            = Bool
False

ppr_opfix :: (OpName, Fixity) -> SDoc
ppr_opfix :: (OpName, Fixity) -> MsgDoc
ppr_opfix (OpName
op, Fixity
fixity) = MsgDoc
pp_op MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
brackets (Fixity -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Fixity
fixity)
   where
     pp_op :: MsgDoc
pp_op | OpName
NegateOp <- OpName
op = String -> MsgDoc
text String
"prefix `-'"
           | Bool
otherwise      = MsgDoc -> MsgDoc
quotes (OpName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr OpName
op)


{- *****************************************************
*                                                      *
                 Errors
*                                                      *
***************************************************** -}

unexpectedTypeSigErr :: LHsSigWcType GhcPs -> SDoc
unexpectedTypeSigErr :: LHsSigWcType GhcPs -> MsgDoc
unexpectedTypeSigErr LHsSigWcType GhcPs
ty
  = MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"Illegal type signature:" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (LHsSigWcType GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsSigWcType GhcPs
ty))
       Int
2 (String -> MsgDoc
text String
"Type signatures are only allowed in patterns with ScopedTypeVariables")

badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM ()
badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcRn ()
badKindSigErr HsDocContext
doc (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LHsType GhcPs)
ty)
  = SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$ MsgDoc -> TcRn ()
addErr (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
    HsDocContext -> MsgDoc -> MsgDoc
withHsDocContext HsDocContext
doc (MsgDoc -> MsgDoc) -> MsgDoc -> MsgDoc
forall a b. (a -> b) -> a -> b
$
    MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"Illegal kind signature:" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (HsType GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsType GhcPs
SrcSpanLess (LHsType GhcPs)
ty))
       Int
2 (String -> MsgDoc
text String
"Perhaps you intended to use KindSignatures")

dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc
dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> MsgDoc
dataKindsErr RnTyKiEnv
env HsType GhcPs
thing
  = MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"Illegal" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc
pp_what MsgDoc -> MsgDoc -> MsgDoc
<> MsgDoc
colon MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (HsType GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsType GhcPs
thing))
       Int
2 (String -> MsgDoc
text String
"Perhaps you intended to use DataKinds")
  where
    pp_what :: MsgDoc
pp_what | RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env = String -> MsgDoc
text String
"kind"
            | Bool
otherwise          = String -> MsgDoc
text String
"type"

inTypeDoc :: HsType GhcPs -> SDoc
inTypeDoc :: HsType GhcPs -> MsgDoc
inTypeDoc HsType GhcPs
ty = String -> MsgDoc
text String
"In the type" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (HsType GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsType GhcPs
ty)

warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM ()
warnUnusedForAll :: MsgDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcRn ()
warnUnusedForAll MsgDoc
in_doc (LHsTyVarBndr GhcRn -> Located (SrcSpanLess (LHsTyVarBndr GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
loc SrcSpanLess (LHsTyVarBndr GhcRn)
tv) FreeVars
used_names
  = WarningFlag -> TcRn () -> TcRn ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnUnusedForalls (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
    Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (HsTyVarBndr GhcRn -> IdP GhcRn
forall pass. HsTyVarBndr pass -> IdP pass
hsTyVarName HsTyVarBndr GhcRn
SrcSpanLess (LHsTyVarBndr GhcRn)
tv Name -> FreeVars -> Bool
`elemNameSet` FreeVars
used_names) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
    WarnReason -> SrcSpan -> MsgDoc -> TcRn ()
addWarnAt (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnUnusedForalls) SrcSpan
loc (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
    [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"Unused quantified type variable" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (HsTyVarBndr GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsTyVarBndr GhcRn
SrcSpanLess (LHsTyVarBndr GhcRn)
tv)
         , MsgDoc
in_doc ]

opTyErr :: Outputable a => RdrName -> a -> SDoc
opTyErr :: RdrName -> a -> MsgDoc
opTyErr RdrName
op a
overall_ty
  = MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text String
"Illegal operator" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr RdrName
op) MsgDoc -> MsgDoc -> MsgDoc
<+> PtrString -> MsgDoc
ptext (String -> PtrString
sLit String
"in type") MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr a
overall_ty))
         Int
2 (String -> MsgDoc
text String
"Use TypeOperators to allow operators in types")

{-
************************************************************************
*                                                                      *
      Finding the free type variables of a (HsType RdrName)
*                                                                      *
************************************************************************


Note [Kind and type-variable binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In a type signature we may implicitly bind type variable and, more
recently, kind variables.  For example:
  *   f :: a -> a
      f = ...
    Here we need to find the free type variables of (a -> a),
    so that we know what to quantify

  *   class C (a :: k) where ...
    This binds 'k' in ..., as well as 'a'

  *   f (x :: a -> [a]) = ....
    Here we bind 'a' in ....

  *   f (x :: T a -> T (b :: k)) = ...
    Here we bind both 'a' and the kind variable 'k'

  *   type instance F (T (a :: Maybe k)) = ...a...k...
    Here we want to constrain the kind of 'a', and bind 'k'.

In general we want to walk over a type, and find
  * Its free type variables
  * The free kind variables of any kind signatures in the type

Hence we return a pair (kind-vars, type vars)
(See Note [HsBSig binder lists] in HsTypes.)
Moreover, we preserve the left-to-right order of the first occurrence of each
variable, while preserving dependency order.
(See Note [Ordering of implicit variables].)

Most clients of this code just want to know the kind/type vars, without
duplicates. The function rmDupsInRdrTyVars removes duplicates. That function
also makes sure that no variable is reported as both a kind var and
a type var, preferring kind vars. Why kind vars? Consider this:

 foo :: forall (a :: k). Proxy k -> Proxy a -> ...

Should that be accepted?

Normally, if a type signature has an explicit forall, it must list *all*
tyvars mentioned in the type. But there's an exception for tyvars mentioned in
a kind, as k is above. Note that k is also used "as a type variable", as the
argument to the first Proxy. So, do we consider k to be type-variable-like and
require it in the forall? Or do we consider k to be kind-variable-like and not
require it?

It's not just in type signatures: kind variables are implicitly brought into
scope in a variety of places. Should vars used at both the type level and kind
level be treated this way?

GHC indeed allows kind variables to be brought into scope implicitly even when
the kind variable is also used as a type variable. Thus, we must prefer to keep
a variable listed as a kind var in rmDupsInRdrTyVars. If we kept it as a type
var, then this would prevent it from being implicitly quantified (see
rnImplicitBndrs). In the `foo` example above, that would have the consequence
of the k in Proxy k being reported as out of scope.

Note [Ordering of implicit variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Since the advent of -XTypeApplications, GHC makes promises about the ordering
of implicit variable quantification. Specifically, we offer that implicitly
quantified variables (such as those in const :: a -> b -> a, without a `forall`)
will occur in left-to-right order of first occurrence. Here are a few examples:

  const :: a -> b -> a       -- forall a b. ...
  f :: Eq a => b -> a -> a   -- forall a b. ...  contexts are included

  type a <-< b = b -> a
  g :: a <-< b               -- forall a b. ...  type synonyms matter

  class Functor f where
    fmap :: (a -> b) -> f a -> f b   -- forall f a b. ...
    -- The f is quantified by the class, so only a and b are considered in fmap

This simple story is complicated by the possibility of dependency: all variables
must come after any variables mentioned in their kinds.

  typeRep :: Typeable a => TypeRep (a :: k)   -- forall k a. ...

The k comes first because a depends on k, even though the k appears later than
the a in the code. Thus, GHC does ScopedSort on the variables.
See Note [ScopedSort] in Type.

Implicitly bound variables are collected by any function which returns a
FreeKiTyVars, FreeKiTyVarsWithDups, or FreeKiTyVarsNoDups, which notably
includes the `extract-` family of functions (extractHsTysRdrTyVars,
extractHsTyVarBndrsKVs, etc.).
These functions thus promise to keep left-to-right ordering.
Look for pointers to this note to see the places where the action happens.

Note that we also maintain this ordering in kind signatures. Even though
there's no visible kind application (yet), having implicit variables be
quantified in left-to-right order in kind signatures is nice since:

* It's consistent with the treatment for type signatures.
* It can affect how types are displayed with -fprint-explicit-kinds (see
  #15568 for an example), which is a situation where knowing the order in
  which implicit variables are quantified can be useful.
* In the event that visible kind application is implemented, the order in
  which we would expect implicit variables to be ordered in kinds will have
  already been established.
-}

-- See Note [Kind and type-variable binders]
-- These lists are guaranteed to preserve left-to-right ordering of
-- the types the variables were extracted from. See also
-- Note [Ordering of implicit variables].
data FreeKiTyVars = FKTV { FreeKiTyVarsWithDups -> [Located RdrName]
fktv_kis    :: [Located RdrName]
                         , FreeKiTyVarsWithDups -> [Located RdrName]
fktv_tys    :: [Located RdrName] }

-- | A 'FreeKiTyVars' list that is allowed to have duplicate variables.
type FreeKiTyVarsWithDups = FreeKiTyVars

-- | A 'FreeKiTyVars' list that contains no duplicate variables.
type FreeKiTyVarsNoDups   = FreeKiTyVars

instance Outputable FreeKiTyVars where
  ppr :: FreeKiTyVarsWithDups -> MsgDoc
ppr (FKTV { fktv_kis :: FreeKiTyVarsWithDups -> [Located RdrName]
fktv_kis = [Located RdrName]
kis, fktv_tys :: FreeKiTyVarsWithDups -> [Located RdrName]
fktv_tys = [Located RdrName]
tys}) = ([Located RdrName], [Located RdrName]) -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ([Located RdrName]
kis, [Located RdrName]
tys)

emptyFKTV :: FreeKiTyVarsNoDups
emptyFKTV :: FreeKiTyVarsWithDups
emptyFKTV = FKTV :: [Located RdrName] -> [Located RdrName] -> FreeKiTyVarsWithDups
FKTV { fktv_kis :: [Located RdrName]
fktv_kis = [], fktv_tys :: [Located RdrName]
fktv_tys = [] }

freeKiTyVarsAllVars :: FreeKiTyVars -> [Located RdrName]
freeKiTyVarsAllVars :: FreeKiTyVarsWithDups -> [Located RdrName]
freeKiTyVarsAllVars (FKTV { fktv_kis :: FreeKiTyVarsWithDups -> [Located RdrName]
fktv_kis = [Located RdrName]
kvs, fktv_tys :: FreeKiTyVarsWithDups -> [Located RdrName]
fktv_tys = [Located RdrName]
tvs }) = [Located RdrName]
kvs [Located RdrName] -> [Located RdrName] -> [Located RdrName]
forall a. [a] -> [a] -> [a]
++ [Located RdrName]
tvs

freeKiTyVarsKindVars :: FreeKiTyVars -> [Located RdrName]
freeKiTyVarsKindVars :: FreeKiTyVarsWithDups -> [Located RdrName]
freeKiTyVarsKindVars = FreeKiTyVarsWithDups -> [Located RdrName]
fktv_kis

freeKiTyVarsTypeVars :: FreeKiTyVars -> [Located RdrName]
freeKiTyVarsTypeVars :: FreeKiTyVarsWithDups -> [Located RdrName]
freeKiTyVarsTypeVars = FreeKiTyVarsWithDups -> [Located RdrName]
fktv_tys

filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
filterInScope :: LocalRdrEnv -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
filterInScope LocalRdrEnv
rdr_env (FKTV { fktv_kis :: FreeKiTyVarsWithDups -> [Located RdrName]
fktv_kis = [Located RdrName]
kis, fktv_tys :: FreeKiTyVarsWithDups -> [Located RdrName]
fktv_tys = [Located RdrName]
tys })
  = FKTV :: [Located RdrName] -> [Located RdrName] -> FreeKiTyVarsWithDups
FKTV { fktv_kis :: [Located RdrName]
fktv_kis = (Located RdrName -> Bool) -> [Located RdrName] -> [Located RdrName]
forall a. (a -> Bool) -> [a] -> [a]
filterOut Located RdrName -> Bool
in_scope [Located RdrName]
kis
         , fktv_tys :: [Located RdrName]
fktv_tys = (Located RdrName -> Bool) -> [Located RdrName] -> [Located RdrName]
forall a. (a -> Bool) -> [a] -> [a]
filterOut Located RdrName -> Bool
in_scope [Located RdrName]
tys }
  where
    in_scope :: Located RdrName -> Bool
in_scope = LocalRdrEnv -> RdrName -> Bool
inScope LocalRdrEnv
rdr_env (RdrName -> Bool)
-> (Located RdrName -> RdrName) -> Located RdrName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located RdrName -> RdrName
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc

inScope :: LocalRdrEnv -> RdrName -> Bool
inScope :: LocalRdrEnv -> RdrName -> Bool
inScope LocalRdrEnv
rdr_env RdrName
rdr = RdrName
rdr RdrName -> LocalRdrEnv -> Bool
`elemLocalRdrEnv` LocalRdrEnv
rdr_env

-- | 'extractHsTyRdrTyVars' finds the
--        free (kind, type) variables of an 'HsType'
-- or the free (sort, kind) variables of an 'HsKind'.
-- It's used when making the @forall@s explicit.
-- Does not return any wildcards.
-- When the same name occurs multiple times in the types, only the first
-- occurrence is returned.
-- See Note [Kind and type-variable binders]


extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_tyarg (HsValArg LHsType GhcPs
ty) FreeKiTyVarsWithDups
acc = TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
TypeLevel LHsType GhcPs
ty FreeKiTyVarsWithDups
acc
extract_tyarg (HsTypeArg SrcSpan
_ LHsType GhcPs
ki) FreeKiTyVarsWithDups
acc = TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
KindLevel LHsType GhcPs
ki FreeKiTyVarsWithDups
acc
extract_tyarg (HsArgPar SrcSpan
_) FreeKiTyVarsWithDups
acc = FreeKiTyVarsWithDups
acc

extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_tyargs [LHsTypeArg GhcPs]
args FreeKiTyVarsWithDups
acc = (LHsTypeArg GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> FreeKiTyVarsWithDups
-> [LHsTypeArg GhcPs]
-> FreeKiTyVarsWithDups
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LHsTypeArg GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_tyarg FreeKiTyVarsWithDups
acc [LHsTypeArg GhcPs]
args

extractHsTyArgRdrKiTyVarsDup :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups
extractHsTyArgRdrKiTyVarsDup :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups
extractHsTyArgRdrKiTyVarsDup [LHsTypeArg GhcPs]
args = [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_tyargs [LHsTypeArg GhcPs]
args FreeKiTyVarsWithDups
emptyFKTV

extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVarsNoDups
extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVarsWithDups
extractHsTyRdrTyVars LHsType GhcPs
ty
  = FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
rmDupsInRdrTyVars (LHsType GhcPs -> FreeKiTyVarsWithDups
extractHsTyRdrTyVarsDups LHsType GhcPs
ty)

-- | 'extractHsTyRdrTyVarsDups' find the
--        free (kind, type) variables of an 'HsType'
-- or the free (sort, kind) variables of an 'HsKind'.
-- It's used when making the @forall@s explicit.
-- Does not return any wildcards.
-- When the same name occurs multiple times in the types, all occurrences
-- are returned.
extractHsTyRdrTyVarsDups :: LHsType GhcPs -> FreeKiTyVarsWithDups
extractHsTyRdrTyVarsDups :: LHsType GhcPs -> FreeKiTyVarsWithDups
extractHsTyRdrTyVarsDups LHsType GhcPs
ty
  = TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
TypeLevel LHsType GhcPs
ty FreeKiTyVarsWithDups
emptyFKTV

-- | Extracts the free kind variables (but not the type variables) of an
-- 'HsType'. Does not return any wildcards.
-- When the same name occurs multiple times in the type, only the first
-- occurrence is returned, and the left-to-right order of variables is
-- preserved.
-- See Note [Kind and type-variable binders] and
-- Note [Ordering of implicit variables].
extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> [Located RdrName]
extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> [Located RdrName]
extractHsTyRdrTyVarsKindVars LHsType GhcPs
ty
  = FreeKiTyVarsWithDups -> [Located RdrName]
freeKiTyVarsKindVars (LHsType GhcPs -> FreeKiTyVarsWithDups
extractHsTyRdrTyVars LHsType GhcPs
ty)

-- | Extracts free type and kind variables from types in a list.
-- When the same name occurs multiple times in the types, only the first
-- occurrence is returned and the rest is filtered out.
-- See Note [Kind and type-variable binders]
extractHsTysRdrTyVars :: [LHsType GhcPs] -> FreeKiTyVarsNoDups
extractHsTysRdrTyVars :: [LHsType GhcPs] -> FreeKiTyVarsWithDups
extractHsTysRdrTyVars [LHsType GhcPs]
tys
  = FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
rmDupsInRdrTyVars ([LHsType GhcPs] -> FreeKiTyVarsWithDups
extractHsTysRdrTyVarsDups [LHsType GhcPs]
tys)

-- | Extracts free type and kind variables from types in a list.
-- When the same name occurs multiple times in the types, all occurrences
-- are returned.
extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> FreeKiTyVarsWithDups
extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> FreeKiTyVarsWithDups
extractHsTysRdrTyVarsDups [LHsType GhcPs]
tys
  = TypeOrKind
-> [LHsType GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_ltys TypeOrKind
TypeLevel [LHsType GhcPs]
tys FreeKiTyVarsWithDups
emptyFKTV

extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> [Located RdrName]
-- Returns the free kind variables of any explictly-kinded binders, returning
-- variable occurrences in left-to-right order.
-- See Note [Ordering of implicit variables].
-- NB: Does /not/ delete the binders themselves.
--     However duplicates are removed
--     E.g. given  [k1, a:k1, b:k2]
--          the function returns [k1,k2], even though k1 is bound here
extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> [Located RdrName]
extractHsTyVarBndrsKVs [LHsTyVarBndr GhcPs]
tv_bndrs
  = [Located RdrName] -> [Located RdrName]
forall a. Eq a => [Located a] -> [Located a]
nubL ([LHsTyVarBndr GhcPs] -> [Located RdrName]
extract_hs_tv_bndrs_kvs [LHsTyVarBndr GhcPs]
tv_bndrs)

-- | Removes multiple occurrences of the same name from FreeKiTyVars. If a
-- variable occurs as both a kind and a type variable, only keep the occurrence
-- as a kind variable.
-- See also Note [Kind and type-variable binders]
rmDupsInRdrTyVars :: FreeKiTyVarsWithDups -> FreeKiTyVarsNoDups
rmDupsInRdrTyVars :: FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
rmDupsInRdrTyVars (FKTV { fktv_kis :: FreeKiTyVarsWithDups -> [Located RdrName]
fktv_kis = [Located RdrName]
kis, fktv_tys :: FreeKiTyVarsWithDups -> [Located RdrName]
fktv_tys = [Located RdrName]
tys })
  = FKTV :: [Located RdrName] -> [Located RdrName] -> FreeKiTyVarsWithDups
FKTV { fktv_kis :: [Located RdrName]
fktv_kis = [Located RdrName]
kis'
         , fktv_tys :: [Located RdrName]
fktv_tys = [Located RdrName] -> [Located RdrName]
forall a. Eq a => [Located a] -> [Located a]
nubL ((Located RdrName -> Bool) -> [Located RdrName] -> [Located RdrName]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (Located RdrName -> [Located RdrName] -> Bool
`elemRdr` [Located RdrName]
kis') [Located RdrName]
tys) }
  where
    kis' :: [Located RdrName]
kis' = [Located RdrName] -> [Located RdrName]
forall a. Eq a => [Located a] -> [Located a]
nubL [Located RdrName]
kis

extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName]
-- Returns the free kind variables in a type family result signature, returning
-- variable occurrences in left-to-right order.
-- See Note [Ordering of implicit variables].
extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName]
extractRdrKindSigVars (LFamilyResultSig GhcPs
-> Located (SrcSpanLess (LFamilyResultSig GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (LFamilyResultSig GhcPs)
resultSig)
  | KindSig _ k                              <- SrcSpanLess (LFamilyResultSig GhcPs)
resultSig = LHsType GhcPs -> [Located RdrName]
kindRdrNameFromSig LHsType GhcPs
k
  | TyVarSig _ (dL->L _ (KindedTyVar _ _ k)) <- SrcSpanLess (LFamilyResultSig GhcPs)
resultSig = LHsType GhcPs -> [Located RdrName]
kindRdrNameFromSig LHsType GhcPs
k
  | Bool
otherwise =  []
    where
      kindRdrNameFromSig :: LHsType GhcPs -> [Located RdrName]
kindRdrNameFromSig LHsType GhcPs
k = FreeKiTyVarsWithDups -> [Located RdrName]
freeKiTyVarsAllVars (LHsType GhcPs -> FreeKiTyVarsWithDups
extractHsTyRdrTyVars LHsType GhcPs
k)

extractDataDefnKindVars :: HsDataDefn GhcPs -> [Located RdrName]
-- Get the scoped kind variables mentioned free in the constructor decls
-- Eg: data T a = T1 (S (a :: k) | forall (b::k). T2 (S b)
--     Here k should scope over the whole definition
--
-- However, do NOT collect free kind vars from the deriving clauses:
-- Eg: (Trac #14331)    class C p q
--                      data D = D deriving ( C (a :: k) )
--     Here k should /not/ scope over the whole definition.  We intend
--     this to elaborate to:
--         class C @k1 @k2 (p::k1) (q::k2)
--         data D = D
--         instance forall k (a::k). C @k @* a D where ...
--
-- This returns variable occurrences in left-to-right order.
-- See Note [Ordering of implicit variables].
extractDataDefnKindVars :: HsDataDefn GhcPs -> [Located RdrName]
extractDataDefnKindVars (HsDataDefn { dd_ctxt :: forall pass. HsDataDefn pass -> LHsContext pass
dd_ctxt = LHsContext GhcPs
ctxt, dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_kindSig = Maybe (LHsType GhcPs)
ksig
                                    , dd_cons :: forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons = [LConDecl GhcPs]
cons })
  = ([Located RdrName] -> [Located RdrName]
forall a. Eq a => [Located a] -> [Located a]
nubL ([Located RdrName] -> [Located RdrName])
-> (FreeKiTyVarsWithDups -> [Located RdrName])
-> FreeKiTyVarsWithDups
-> [Located RdrName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FreeKiTyVarsWithDups -> [Located RdrName]
freeKiTyVarsKindVars) (FreeKiTyVarsWithDups -> [Located RdrName])
-> FreeKiTyVarsWithDups -> [Located RdrName]
forall a b. (a -> b) -> a -> b
$
    (TypeOrKind
-> LHsContext GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lctxt TypeOrKind
TypeLevel LHsContext GhcPs
ctxt  (FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
forall a b. (a -> b) -> a -> b
$
     (LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> Maybe (LHsType GhcPs)
-> FreeKiTyVarsWithDups
-> FreeKiTyVarsWithDups
forall a.
(a -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> Maybe a -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_mb LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lkind Maybe (LHsType GhcPs)
ksig (FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
forall a b. (a -> b) -> a -> b
$
     (LConDecl GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> FreeKiTyVarsWithDups -> [LConDecl GhcPs] -> FreeKiTyVarsWithDups
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (ConDecl GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_con (ConDecl GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> (LConDecl GhcPs -> ConDecl GhcPs)
-> LConDecl GhcPs
-> FreeKiTyVarsWithDups
-> FreeKiTyVarsWithDups
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LConDecl GhcPs -> ConDecl GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) FreeKiTyVarsWithDups
emptyFKTV [LConDecl GhcPs]
cons)
  where
    extract_con :: ConDecl GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_con (ConDeclGADT { }) FreeKiTyVarsWithDups
acc = FreeKiTyVarsWithDups
acc
    extract_con (ConDeclH98 { con_ex_tvs :: forall pass. ConDecl pass -> [LHsTyVarBndr pass]
con_ex_tvs = [LHsTyVarBndr GhcPs]
ex_tvs
                            , con_mb_cxt :: forall pass. ConDecl pass -> Maybe (LHsContext pass)
con_mb_cxt = Maybe (LHsContext GhcPs)
ctxt, con_args :: forall pass. ConDecl pass -> HsConDeclDetails pass
con_args = HsConDeclDetails GhcPs
args }) FreeKiTyVarsWithDups
acc
      = [LHsTyVarBndr GhcPs]
-> FreeKiTyVarsWithDups
-> FreeKiTyVarsWithDups
-> FreeKiTyVarsWithDups
extract_hs_tv_bndrs [LHsTyVarBndr GhcPs]
ex_tvs FreeKiTyVarsWithDups
acc (FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
forall a b. (a -> b) -> a -> b
$
        Maybe (LHsContext GhcPs)
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_mlctxt Maybe (LHsContext GhcPs)
ctxt            (FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
forall a b. (a -> b) -> a -> b
$
        TypeOrKind
-> [LHsType GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_ltys TypeOrKind
TypeLevel (HsConDeclDetails GhcPs -> [LHsType GhcPs]
forall pass. HsConDeclDetails pass -> [LBangType pass]
hsConDeclArgTys HsConDeclDetails GhcPs
args) FreeKiTyVarsWithDups
emptyFKTV
    extract_con (XConDecl { }) FreeKiTyVarsWithDups
_ = String -> FreeKiTyVarsWithDups
forall a. String -> a
panic String
"extractDataDefnKindVars"
extractDataDefnKindVars (XHsDataDefn XXHsDataDefn GhcPs
_) = String -> [Located RdrName]
forall a. String -> a
panic String
"extractDataDefnKindVars"

extract_mlctxt :: Maybe (LHsContext GhcPs)
               -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_mlctxt :: Maybe (LHsContext GhcPs)
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_mlctxt Maybe (LHsContext GhcPs)
Nothing     FreeKiTyVarsWithDups
acc = FreeKiTyVarsWithDups
acc
extract_mlctxt (Just LHsContext GhcPs
ctxt) FreeKiTyVarsWithDups
acc = TypeOrKind
-> LHsContext GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lctxt TypeOrKind
TypeLevel LHsContext GhcPs
ctxt FreeKiTyVarsWithDups
acc

extract_lctxt :: TypeOrKind
              -> LHsContext GhcPs
              -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lctxt :: TypeOrKind
-> LHsContext GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lctxt TypeOrKind
t_or_k LHsContext GhcPs
ctxt = TypeOrKind
-> [LHsType GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_ltys TypeOrKind
t_or_k (LHsContext GhcPs -> SrcSpanLess (LHsContext GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsContext GhcPs
ctxt)

extract_ltys :: TypeOrKind
             -> [LHsType GhcPs]
             -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_ltys :: TypeOrKind
-> [LHsType GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_ltys TypeOrKind
t_or_k [LHsType GhcPs]
tys FreeKiTyVarsWithDups
acc = (LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> FreeKiTyVarsWithDups -> [LHsType GhcPs] -> FreeKiTyVarsWithDups
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
t_or_k) FreeKiTyVarsWithDups
acc [LHsType GhcPs]
tys

extract_mb :: (a -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
           -> Maybe a
           -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_mb :: (a -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> Maybe a -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_mb a -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
_ Maybe a
Nothing  FreeKiTyVarsWithDups
acc = FreeKiTyVarsWithDups
acc
extract_mb a -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
f (Just a
x) FreeKiTyVarsWithDups
acc = a -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
f a
x FreeKiTyVarsWithDups
acc

extract_lkind :: LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lkind :: LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lkind = TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
KindLevel

extract_lty :: TypeOrKind -> LHsType GhcPs
            -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty :: TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
t_or_k (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (LHsType GhcPs)
ty) FreeKiTyVarsWithDups
acc
  = case SrcSpanLess (LHsType GhcPs)
ty of
      HsTyVar _ _  ltv            -> TypeOrKind
-> Located RdrName -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_tv TypeOrKind
t_or_k Located (IdP GhcPs)
Located RdrName
ltv FreeKiTyVarsWithDups
acc
      HsBangTy _ _ ty             -> TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
t_or_k LHsType GhcPs
ty FreeKiTyVarsWithDups
acc
      HsRecTy _ flds              -> (LConDeclField GhcPs
 -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> FreeKiTyVarsWithDups
-> [LConDeclField GhcPs]
-> FreeKiTyVarsWithDups
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
t_or_k
                                            (LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> (LConDeclField GhcPs -> LHsType GhcPs)
-> LConDeclField GhcPs
-> FreeKiTyVarsWithDups
-> FreeKiTyVarsWithDups
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConDeclField GhcPs -> LHsType GhcPs
forall pass. ConDeclField pass -> LBangType pass
cd_fld_type (ConDeclField GhcPs -> LHsType GhcPs)
-> (LConDeclField GhcPs -> ConDeclField GhcPs)
-> LConDeclField GhcPs
-> LHsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LConDeclField GhcPs -> ConDeclField GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc) FreeKiTyVarsWithDups
acc
                                           [LConDeclField GhcPs]
flds
      HsAppTy _ ty1 ty2           -> TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
t_or_k LHsType GhcPs
ty1 (FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
forall a b. (a -> b) -> a -> b
$
                                     TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
t_or_k LHsType GhcPs
ty2 FreeKiTyVarsWithDups
acc
      HsAppKindTy _ ty k          -> TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
t_or_k LHsType GhcPs
ty (FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
forall a b. (a -> b) -> a -> b
$
                                     TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
KindLevel LHsType GhcPs
k FreeKiTyVarsWithDups
acc
      HsListTy _ ty               -> TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
t_or_k LHsType GhcPs
ty FreeKiTyVarsWithDups
acc
      HsTupleTy _ _ tys           -> TypeOrKind
-> [LHsType GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_ltys TypeOrKind
t_or_k [LHsType GhcPs]
tys FreeKiTyVarsWithDups
acc
      HsSumTy _ tys               -> TypeOrKind
-> [LHsType GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_ltys TypeOrKind
t_or_k [LHsType GhcPs]
tys FreeKiTyVarsWithDups
acc
      HsFunTy _ ty1 ty2           -> TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
t_or_k LHsType GhcPs
ty1 (FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
forall a b. (a -> b) -> a -> b
$
                                     TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
t_or_k LHsType GhcPs
ty2 FreeKiTyVarsWithDups
acc
      HsIParamTy _ _ ty           -> TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
t_or_k LHsType GhcPs
ty FreeKiTyVarsWithDups
acc
      HsOpTy _ ty1 tv ty2         -> TypeOrKind
-> Located RdrName -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_tv TypeOrKind
t_or_k Located (IdP GhcPs)
Located RdrName
tv   (FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
forall a b. (a -> b) -> a -> b
$
                                     TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
t_or_k LHsType GhcPs
ty1 (FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
forall a b. (a -> b) -> a -> b
$
                                     TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
t_or_k LHsType GhcPs
ty2 FreeKiTyVarsWithDups
acc
      HsParTy _ ty                -> TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
t_or_k LHsType GhcPs
ty FreeKiTyVarsWithDups
acc
      HsSpliceTy {}               -> FreeKiTyVarsWithDups
acc  -- Type splices mention no tvs
      HsDocTy _ ty _              -> TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
t_or_k LHsType GhcPs
ty FreeKiTyVarsWithDups
acc
      HsExplicitListTy _ _ tys    -> TypeOrKind
-> [LHsType GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_ltys TypeOrKind
t_or_k [LHsType GhcPs]
tys FreeKiTyVarsWithDups
acc
      HsExplicitTupleTy _ tys     -> TypeOrKind
-> [LHsType GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_ltys TypeOrKind
t_or_k [LHsType GhcPs]
tys FreeKiTyVarsWithDups
acc
      HsTyLit _ _                 -> FreeKiTyVarsWithDups
acc
      HsStarTy _ _                -> FreeKiTyVarsWithDups
acc
      HsKindSig _ ty ki           -> TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
t_or_k LHsType GhcPs
ty (FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
forall a b. (a -> b) -> a -> b
$
                                     LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lkind LHsType GhcPs
ki FreeKiTyVarsWithDups
acc
      HsForAllTy { hst_bndrs = tvs, hst_body = ty }
                                  -> [LHsTyVarBndr GhcPs]
-> FreeKiTyVarsWithDups
-> FreeKiTyVarsWithDups
-> FreeKiTyVarsWithDups
extract_hs_tv_bndrs [LHsTyVarBndr GhcPs]
tvs FreeKiTyVarsWithDups
acc (FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
forall a b. (a -> b) -> a -> b
$
                                     TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
t_or_k LHsType GhcPs
ty FreeKiTyVarsWithDups
emptyFKTV
      HsQualTy { hst_ctxt = ctxt, hst_body = ty }
                                  -> TypeOrKind
-> LHsContext GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lctxt TypeOrKind
t_or_k LHsContext GhcPs
ctxt (FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
forall a b. (a -> b) -> a -> b
$
                                     TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
t_or_k LHsType GhcPs
ty FreeKiTyVarsWithDups
acc
      XHsType {}                  -> FreeKiTyVarsWithDups
acc
      -- We deal with these separately in rnLHsTypeWithWildCards
      HsWildCardTy {}             -> FreeKiTyVarsWithDups
acc

extractHsTvBndrs :: [LHsTyVarBndr GhcPs]
                 -> FreeKiTyVarsWithDups           -- Free in body
                 -> FreeKiTyVarsWithDups       -- Free in result
extractHsTvBndrs :: [LHsTyVarBndr GhcPs]
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extractHsTvBndrs [LHsTyVarBndr GhcPs]
tv_bndrs FreeKiTyVarsWithDups
body_fvs
  = [LHsTyVarBndr GhcPs]
-> FreeKiTyVarsWithDups
-> FreeKiTyVarsWithDups
-> FreeKiTyVarsWithDups
extract_hs_tv_bndrs [LHsTyVarBndr GhcPs]
tv_bndrs FreeKiTyVarsWithDups
emptyFKTV FreeKiTyVarsWithDups
body_fvs

extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs]
                    -> FreeKiTyVarsWithDups  -- Accumulator
                    -> FreeKiTyVarsWithDups  -- Free in body
                    -> FreeKiTyVarsWithDups
-- In (forall (a :: Maybe e). a -> b) we have
--     'a' is bound by the forall
--     'b' is a free type variable
--     'e' is a free kind variable
extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs]
-> FreeKiTyVarsWithDups
-> FreeKiTyVarsWithDups
-> FreeKiTyVarsWithDups
extract_hs_tv_bndrs [LHsTyVarBndr GhcPs]
tv_bndrs
      (FKTV { fktv_kis :: FreeKiTyVarsWithDups -> [Located RdrName]
fktv_kis = [Located RdrName]
acc_kvs,  fktv_tys :: FreeKiTyVarsWithDups -> [Located RdrName]
fktv_tys = [Located RdrName]
acc_tvs })   -- Accumulator
      (FKTV { fktv_kis :: FreeKiTyVarsWithDups -> [Located RdrName]
fktv_kis = [Located RdrName]
body_kvs, fktv_tys :: FreeKiTyVarsWithDups -> [Located RdrName]
fktv_tys = [Located RdrName]
body_tvs })  -- Free in the body
  | [LHsTyVarBndr GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTyVarBndr GhcPs]
tv_bndrs
  = FKTV :: [Located RdrName] -> [Located RdrName] -> FreeKiTyVarsWithDups
FKTV { fktv_kis :: [Located RdrName]
fktv_kis = [Located RdrName]
body_kvs [Located RdrName] -> [Located RdrName] -> [Located RdrName]
forall a. [a] -> [a] -> [a]
++ [Located RdrName]
acc_kvs
         , fktv_tys :: [Located RdrName]
fktv_tys = [Located RdrName]
body_tvs [Located RdrName] -> [Located RdrName] -> [Located RdrName]
forall a. [a] -> [a] -> [a]
++ [Located RdrName]
acc_tvs }
  | Bool
otherwise
  = FKTV :: [Located RdrName] -> [Located RdrName] -> FreeKiTyVarsWithDups
FKTV { fktv_kis :: [Located RdrName]
fktv_kis = (Located RdrName -> Bool) -> [Located RdrName] -> [Located RdrName]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (Located RdrName -> [Located RdrName] -> Bool
`elemRdr` [Located RdrName]
tv_bndr_rdrs) [Located RdrName]
all_kv_occs
                      -- NB: delete all tv_bndr_rdrs from bndr_kvs as well
                      -- as body_kvs; see Note [Kind variable scoping]
                      [Located RdrName] -> [Located RdrName] -> [Located RdrName]
forall a. [a] -> [a] -> [a]
++ [Located RdrName]
acc_kvs
         , fktv_tys :: [Located RdrName]
fktv_tys = (Located RdrName -> Bool) -> [Located RdrName] -> [Located RdrName]
forall a. (a -> Bool) -> [a] -> [a]
filterOut (Located RdrName -> [Located RdrName] -> Bool
`elemRdr` [Located RdrName]
tv_bndr_rdrs) [Located RdrName]
body_tvs [Located RdrName] -> [Located RdrName] -> [Located RdrName]
forall a. [a] -> [a] -> [a]
++ [Located RdrName]
acc_tvs }
  where
    bndr_kvs :: [Located RdrName]
bndr_kvs = [LHsTyVarBndr GhcPs] -> [Located RdrName]
extract_hs_tv_bndrs_kvs [LHsTyVarBndr GhcPs]
tv_bndrs

    tv_bndr_rdrs, all_kv_occs :: [Located RdrName]
    tv_bndr_rdrs :: [Located RdrName]
tv_bndr_rdrs = (LHsTyVarBndr GhcPs -> Located RdrName)
-> [LHsTyVarBndr GhcPs] -> [Located RdrName]
forall a b. (a -> b) -> [a] -> [b]
map LHsTyVarBndr GhcPs -> Located RdrName
forall pass. LHsTyVarBndr pass -> Located (IdP pass)
hsLTyVarLocName [LHsTyVarBndr GhcPs]
tv_bndrs
    all_kv_occs :: [Located RdrName]
all_kv_occs = [Located RdrName]
bndr_kvs [Located RdrName] -> [Located RdrName] -> [Located RdrName]
forall a. [a] -> [a] -> [a]
++ [Located RdrName]
body_kvs
       -- We must include both kind variables from the binding as well
       -- as the body of the `forall` type.
       -- See Note [Variables used as both types and kinds].

extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName]
-- Returns the free kind variables of any explictly-kinded binders, returning
-- variable occurrences in left-to-right order.
-- See Note [Ordering of implicit variables].
-- NB: Does /not/ delete the binders themselves.
--     Duplicates are /not/ removed
--     E.g. given  [k1, a:k1, b:k2]
--          the function returns [k1,k2], even though k1 is bound here
extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName]
extract_hs_tv_bndrs_kvs [LHsTyVarBndr GhcPs]
tv_bndrs
  = FreeKiTyVarsWithDups -> [Located RdrName]
freeKiTyVarsKindVars (FreeKiTyVarsWithDups -> [Located RdrName])
-> FreeKiTyVarsWithDups -> [Located RdrName]
forall a b. (a -> b) -> a -> b
$        -- There will /be/ no free tyvars!
    (LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups)
-> FreeKiTyVarsWithDups -> [LHsType GhcPs] -> FreeKiTyVarsWithDups
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lkind FreeKiTyVarsWithDups
emptyFKTV
          [LHsType GhcPs
k | (LHsTyVarBndr GhcPs -> Located (SrcSpanLess (LHsTyVarBndr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ (KindedTyVar _ _ k)) <- [LHsTyVarBndr GhcPs]
tv_bndrs]

extract_tv :: TypeOrKind -> Located RdrName
           -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_tv :: TypeOrKind
-> Located RdrName -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_tv TypeOrKind
t_or_k ltv :: Located RdrName
ltv@(Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L SrcSpan
_ SrcSpanLess (Located RdrName)
tv) acc :: FreeKiTyVarsWithDups
acc@(FKTV [Located RdrName]
kvs [Located RdrName]
tvs)
  | Bool -> Bool
not (RdrName -> Bool
isRdrTyVar RdrName
SrcSpanLess (Located RdrName)
tv) = FreeKiTyVarsWithDups
acc
  | TypeOrKind -> Bool
isTypeLevel TypeOrKind
t_or_k  = FKTV :: [Located RdrName] -> [Located RdrName] -> FreeKiTyVarsWithDups
FKTV { fktv_kis :: [Located RdrName]
fktv_kis = [Located RdrName]
kvs, fktv_tys :: [Located RdrName]
fktv_tys = Located RdrName
ltv Located RdrName -> [Located RdrName] -> [Located RdrName]
forall a. a -> [a] -> [a]
: [Located RdrName]
tvs }
  | Bool
otherwise           = FKTV :: [Located RdrName] -> [Located RdrName] -> FreeKiTyVarsWithDups
FKTV { fktv_kis :: [Located RdrName]
fktv_kis = Located RdrName
ltv Located RdrName -> [Located RdrName] -> [Located RdrName]
forall a. a -> [a] -> [a]
: [Located RdrName]
kvs, fktv_tys :: [Located RdrName]
fktv_tys = [Located RdrName]
tvs }

-- Deletes duplicates in a list of Located things.
--
-- Importantly, this function is stable with respect to the original ordering
-- of things in the list. This is important, as it is a property that GHC
-- relies on to maintain the left-to-right ordering of implicitly quantified
-- type variables.
-- See Note [Ordering of implicit variables].
nubL :: Eq a => [Located a] -> [Located a]
nubL :: [Located a] -> [Located a]
nubL = (Located a -> Located a -> Bool) -> [Located a] -> [Located a]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy Located a -> Located a -> Bool
forall a. (HasSrcSpan a, Eq (SrcSpanLess a)) => a -> a -> Bool
eqLocated

elemRdr :: Located RdrName -> [Located RdrName] -> Bool
elemRdr :: Located RdrName -> [Located RdrName] -> Bool
elemRdr Located RdrName
x = (Located RdrName -> Bool) -> [Located RdrName] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Located RdrName -> Located RdrName -> Bool
forall a. (HasSrcSpan a, Eq (SrcSpanLess a)) => a -> a -> Bool
eqLocated Located RdrName
x)