{-
(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 "HsVersions.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 scoping :: HsSigWcTypeScoping
scoping doc :: HsDocContext
doc sig_ty :: 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
$ \sig_ty' :: 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 scoping :: HsSigWcTypeScoping
scoping ctx :: HsDocContext
ctx sig_ty :: LHsSigWcType GhcPs
sig_ty thing_inside :: 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 scoping :: HsSigWcTypeScoping
scoping ctxt :: 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 }})
                  thing_inside :: LHsSigWcType GhcRn -> RnM (a, FreeVars)
thing_inside
  = do { FreeKiTyVarsWithDups
free_vars <- LHsType GhcPs -> RnM FreeKiTyVarsWithDups
extractFilteredRdrTyVarsDups LHsType GhcPs
hs_ty
       ; (tv_rdrs :: FreeKiTyVarsWithDups
tv_rdrs, nwc_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
                               AlwaysBind       -> Bool
True
                               BindUnlessForall -> Bool -> Bool
not (LHsType GhcPs -> Bool
forall p. LHsType p -> Bool
isLHsForAllTy LHsType GhcPs
hs_ty)
                               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
$ \ vars :: [Name]
vars ->
    do { (wcs :: [Name]
wcs, hs_ty' :: LHsType GhcRn
hs_ty', fvs1 :: 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' }
       ; (res :: a
res, fvs2 :: 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 _ _ (HsWC _ (XHsImplicitBndrs _)) _
  = String -> RnM (a, FreeVars)
forall a. String -> a
panic "rn_hs_sig_wc_type"
rn_hs_sig_wc_type _ _ (XHsWildCardBndrs _) _
  = String -> RnM (a, FreeVars)
forall a. String -> a
panic "rn_hs_sig_wc_type"

rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
rnHsWcType ctxt :: 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
       ; (_, nwc_rdrs :: [Located RdrName]
nwc_rdrs) <- FreeKiTyVarsWithDups
-> RnM (FreeKiTyVarsWithDups, [Located RdrName])
partition_nwcs FreeKiTyVarsWithDups
free_vars
       ; (wcs :: [Name]
wcs, hs_ty' :: LHsType GhcRn
hs_ty', fvs :: 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 _ (XHsWildCardBndrs _) = String -> RnM (LHsWcType GhcRn, FreeVars)
forall a. String -> a
panic "rnHsWcType"

rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs
         -> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBody :: HsDocContext
-> [Located RdrName]
-> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBody ctxt :: HsDocContext
ctxt nwc_rdrs :: [Located RdrName]
nwc_rdrs hs_ty :: 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 }
       ; (hs_ty' :: LHsType GhcRn
hs_ty', fvs :: 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 env :: RnTyKiEnv
env (a -> Located (SrcSpanLess a)
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc hs_ty :: 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 { (hs_ty' :: HsType GhcRn
hs_ty', fvs :: FreeVars
fvs) <- RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rn_ty RnTyKiEnv
env SrcSpanLess a
HsType GhcPs
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 SrcSpanLess a
HsType GhcRn
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 env :: 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
$ \ tvs' :: [LHsTyVarBndr GhcRn]
tvs' ->
        do { (hs_body' :: LHsType GhcRn
hs_body', fvs :: 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 = XForAllTy GhcRn
NoExt
noExt, hst_bndrs :: [LHsTyVarBndr GhcRn]
hst_bndrs = [LHsTyVarBndr GhcRn]
tvs'
                                , hst_body :: LHsType GhcRn
hst_body = LHsType GhcRn
hs_body' }, FreeVars
fvs) }

    rn_ty env :: 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 cx :: SrcSpan
cx hs_ctxt :: SrcSpanLess (LHsContext GhcPs)
hs_ctxt
                        , hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcPs
hs_ty })
      | Just (hs_ctxt1 :: [LHsType GhcPs]
hs_ctxt1, hs_ctxt_last :: 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 lx :: SrcSpan
lx (HsWildCardTy _))  <- LHsType GhcPs -> LHsType GhcPs
forall pass. LHsType pass -> LHsType pass
ignoreParens LHsType GhcPs
hs_ctxt_last
      = do { (hs_ctxt1' :: [LHsType GhcRn]
hs_ctxt1', fvs1 :: 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 XWildCardTy GhcRn
NoExt
noExt)]
           ; (hs_ty' :: LHsType GhcRn
hs_ty', fvs2 :: 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 = XQualTy GhcRn
NoExt
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 { (hs_ctxt' :: [LHsType GhcRn]
hs_ctxt', fvs1 :: 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
           ; (hs_ty' :: LHsType GhcRn
hs_ty', fvs2 :: 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 = XQualTy GhcRn
NoExt
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 env :: RnTyKiEnv
env hs_ty :: 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 env :: 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 env :: RnTyKiEnv
env hs_ctxt :: [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 "Extra-constraint wildcard" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes MsgDoc
pprAnonWildCard
                   MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text "not allowed"

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

extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
extraConstraintWildCardsAllowed env :: RnTyKiEnv
env
  = case RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env of
      TypeSigCtx {}       -> Bool
True
      ExprWithTySigCtx {} -> Bool
True
      DerivDeclCtx {}     -> Bool
True
      _                   -> 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 hs_ty :: 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 hs_ty :: 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 (nwcs :: [Located RdrName]
nwcs, no_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 rdr :: 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 ctx :: HsDocContext
ctx (HsIB { hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = LHsType GhcPs
hs_ty })
  = do { String -> MsgDoc -> TcRn ()
traceRn "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
$ \ vars :: [Name]
vars ->
    do { (body' :: LHsType GhcRn
body', fvs :: 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 _ (XHsImplicitBndrs _) = String -> RnM (HsImplicitBndrs GhcRn (LHsType GhcRn), FreeVars)
forall a. String -> a
panic "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 bind_free_tvs :: 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 })
                thing_inside :: [Name] -> RnM (a, FreeVars)
thing_inside
  = do { let FKTV kvs :: [Located RdrName]
kvs tvs :: [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 "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 "checkMixedVars2" (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
           [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text "kvs_with_dups" MsgDoc -> MsgDoc -> MsgDoc
<+> [Located RdrName] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Located RdrName]
kvs_with_dups
                , String -> MsgDoc
text "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 kvs :: [a]
kvs =
      [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text "An explicit" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (String -> MsgDoc
text "forall") MsgDoc -> MsgDoc -> MsgDoc
<+>
             String -> MsgDoc
text "was used, but the following kind variables" MsgDoc -> MsgDoc -> MsgDoc
<+>
             String -> MsgDoc
text "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 "Despite this fact, GHC will introduce them into scope," MsgDoc -> MsgDoc -> MsgDoc
<+>
             String -> MsgDoc
text "but it will stop doing so in the future."
           , String -> MsgDoc
text "Suggested fix: add" MsgDoc -> MsgDoc -> MsgDoc
<+>
             MsgDoc -> MsgDoc
quotes (String -> MsgDoc
text "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 '.') ]

{- ******************************************************
*                                                       *
           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 "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 RnTypeBody      = String -> MsgDoc
text "RnTypeBody"
  ppr RnTopConstraint = String -> MsgDoc
text "RnTopConstraint"
  ppr RnConstraint    = String -> MsgDoc
text "RnConstraint"

mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv cxt :: HsDocContext
cxt level :: TypeOrKind
level what :: 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 _                                 = Bool
False

--------------
rnLHsType  :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType ctxt :: HsDocContext
ctxt ty :: 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 doc :: HsDocContext
doc tys :: [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 ctxt :: HsDocContext
ctxt ty :: 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 ctxt :: HsDocContext
ctxt kind :: 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 ctxt :: HsDocContext
ctxt kind :: 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 ctxt :: HsDocContext
ctxt (HsValArg ty :: LHsType GhcPs
ty)
   = do { (tys_rn :: LHsType GhcRn
tys_rn, fvs :: 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 ctxt :: HsDocContext
ctxt (HsTypeArg l :: SrcSpan
l ki :: LHsType GhcPs
ki)
   = do { (kis_rn :: LHsType GhcRn
kis_rn, fvs :: 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 _ (HsArgPar sp :: 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 doc :: HsDocContext
doc args :: [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 env :: RnTyKiEnv
env (LHsContext GhcPs -> Located (SrcSpanLess (LHsContext GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc cxt :: SrcSpanLess (LHsContext GhcPs)
cxt)
  = do { String -> MsgDoc -> TcRn ()
traceRn "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 }
       ; (cxt' :: [LHsType GhcRn]
cxt', fvs :: 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 doc :: HsDocContext
doc theta :: 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 env :: RnTyKiEnv
env (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc ty :: 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 { (ty' :: HsType GhcRn
ty', fvs :: FreeVars
fvs) <- RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsTyKi RnTyKiEnv
env SrcSpanLess (LHsType GhcPs)
HsType 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 SrcSpanLess (LHsType GhcRn)
HsType GhcRn
ty', FreeVars
fvs) }

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

rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsTyKi env :: 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
$ \ tyvars' :: [LHsTyVarBndr GhcRn]
tyvars' ->
    do { (tau' :: LHsType GhcRn
tau',  fvs :: 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 = XForAllTy GhcRn
NoExt
noExt, hst_bndrs :: [LHsTyVarBndr GhcRn]
hst_bndrs = [LHsTyVarBndr GhcRn]
tyvars'
                             , hst_body :: LHsType GhcRn
hst_body =  LHsType GhcRn
tau' }
                , FreeVars
fvs) } }

rnHsTyKi env :: 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]
       ; (ctxt' :: LHsContext GhcRn
ctxt', fvs1 :: FreeVars
fvs1) <- RnTyKiEnv -> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars)
rnTyKiContext RnTyKiEnv
env LHsContext GhcPs
lctxt
       ; (tau' :: LHsType GhcRn
tau',  fvs2 :: 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 = XQualTy GhcRn
NoExt
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 env :: RnTyKiEnv
env (HsTyVar _ ip :: PromotionFlag
ip (Located (IdP GhcPs) -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc rdr_name :: 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 SrcSpanLess (Located RdrName)
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 "Unexpected kind variable" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (RdrName -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr SrcSpanLess (Located RdrName)
RdrName
rdr_name)
              , String -> MsgDoc
text "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 SrcSpanLess (Located RdrName)
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 XTyVar GhcRn
NoExt
noExt PromotionFlag
ip (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc Name
SrcSpanLess (Located Name)
name), Name -> FreeVars
unitFV Name
name) }

rnHsTyKi env :: RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsOpTy _ ty1 :: LHsType GhcPs
ty1 l_op :: Located (IdP GhcPs)
l_op ty2 :: 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 RdrName
Located (IdP GhcPs)
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  { (l_op' :: Located Name
l_op', fvs1 :: 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 RdrName
Located (IdP GhcPs)
l_op
        ; Fixity
fix   <- Located Name -> RnM Fixity
lookupTyFixityRn Located Name
l_op'
        ; (ty1' :: LHsType GhcRn
ty1', fvs2 :: FreeVars
fvs2) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty1
        ; (ty2' :: LHsType GhcRn
ty2', fvs3 :: 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 (\t1 :: LHsType GhcRn
t1 t2 :: 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
noExt LHsType GhcRn
t1 Located Name
Located (IdP GhcRn)
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 env :: RnTyKiEnv
env (HsParTy _ ty :: LHsType GhcPs
ty)
  = do { (ty' :: LHsType GhcRn
ty', fvs :: 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 XParTy GhcRn
NoExt
noExt LHsType GhcRn
ty', FreeVars
fvs) }

rnHsTyKi env :: RnTyKiEnv
env (HsBangTy _ b :: HsSrcBang
b ty :: LHsType GhcPs
ty)
  = do { (ty' :: LHsType GhcRn
ty', fvs :: 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 XBangTy GhcRn
NoExt
noExt HsSrcBang
b LHsType GhcRn
ty', FreeVars
fvs) }

rnHsTyKi env :: RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsRecTy _ flds :: [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
       ; (flds' :: [LConDeclField GhcRn]
flds', fvs :: 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 XRecTy GhcRn
NoExt
noExt [LConDeclField GhcRn]
flds', FreeVars
fvs) }
  where
    get_fields :: HsDocContext -> IOEnv (Env TcGblEnv TcLclEnv) [FieldLabel]
get_fields (ConDeclCtx names :: [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 _
      = do { MsgDoc -> TcRn ()
addErr (MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text "Record syntax is illegal here:")
                                   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 env :: RnTyKiEnv
env (HsFunTy _ ty1 :: LHsType GhcPs
ty1 ty2 :: LHsType GhcPs
ty2)
  = do { (ty1' :: LHsType GhcRn
ty1', fvs1 :: 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
       ; (ty2' :: LHsType GhcRn
ty2', fvs2 :: 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 XFunTy GhcRn
NoExt
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 env :: RnTyKiEnv
env listTy :: HsType GhcPs
listTy@(HsListTy _ ty :: 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))
       ; (ty' :: LHsType GhcRn
ty', fvs :: 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 XListTy GhcRn
NoExt
noExt LHsType GhcRn
ty', FreeVars
fvs) }

rnHsTyKi env :: RnTyKiEnv
env t :: HsType GhcPs
t@(HsKindSig _ ty :: LHsType GhcPs
ty k :: 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)
       ; (ty' :: LHsType GhcRn
ty', fvs1 :: FreeVars
fvs1) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
       ; (k' :: LHsType GhcRn
k', fvs2 :: 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 XKindSig GhcRn
NoExt
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 env :: RnTyKiEnv
env tupleTy :: HsType GhcPs
tupleTy@(HsTupleTy _ tup_con :: HsTupleSort
tup_con tys :: [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))
       ; (tys' :: [LHsType GhcRn]
tys', fvs :: 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 XTupleTy GhcRn
NoExt
noExt HsTupleSort
tup_con [LHsType GhcRn]
tys', FreeVars
fvs) }

rnHsTyKi env :: RnTyKiEnv
env sumTy :: HsType GhcPs
sumTy@(HsSumTy _ tys :: [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))
       ; (tys' :: [LHsType GhcRn]
tys', fvs :: 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 XSumTy GhcRn
NoExt
noExt [LHsType GhcRn]
tys', FreeVars
fvs) }

-- Ensure that a type-level integer is nonnegative (#8306, #8412)
rnHsTyKi env :: RnTyKiEnv
env tyLit :: HsType GhcPs
tyLit@(HsTyLit _ t :: 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 XTyLit GhcRn
NoExt
noExt HsTyLit
t, FreeVars
emptyFVs) }
  where
    negLit :: HsTyLit -> Bool
negLit (HsStrTy _ _) = Bool
False
    negLit (HsNumTy _ i :: Integer
i) = Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 0
    negLitErr :: MsgDoc
negLitErr = String -> MsgDoc
text "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 env :: RnTyKiEnv
env (HsAppTy _ ty1 :: LHsType GhcPs
ty1 ty2 :: LHsType GhcPs
ty2)
  = do { (ty1' :: LHsType GhcRn
ty1', fvs1 :: FreeVars
fvs1) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty1
       ; (ty2' :: LHsType GhcRn
ty2', fvs2 :: 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 XAppTy GhcRn
NoExt
noExt LHsType GhcRn
ty1' LHsType GhcRn
ty2', FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }

rnHsTyKi env :: RnTyKiEnv
env (HsAppKindTy l :: XAppKindTy GhcPs
l ty :: LHsType GhcPs
ty k :: 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 "kind" LHsType GhcPs
k))
       ; (ty' :: LHsType GhcRn
ty', fvs1 :: FreeVars
fvs1) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
       ; (k' :: LHsType GhcRn
k', fvs2 :: 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 GhcPs
XAppKindTy GhcRn
l LHsType GhcRn
ty' LHsType GhcRn
k', FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }

rnHsTyKi env :: RnTyKiEnv
env t :: HsType GhcPs
t@(HsIParamTy _ n :: Located HsIPName
n ty :: LHsType GhcPs
ty)
  = do { RnTyKiEnv -> HsType GhcPs -> TcRn ()
forall ty. Outputable ty => RnTyKiEnv -> ty -> TcRn ()
notInKinds RnTyKiEnv
env HsType GhcPs
t
       ; (ty' :: LHsType GhcRn
ty', fvs :: 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 XIParamTy GhcRn
NoExt
noExt Located HsIPName
n LHsType GhcRn
ty', FreeVars
fvs) }

rnHsTyKi _ (HsStarTy _ isUni :: 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 XStarTy GhcRn
NoExt
noExt Bool
isUni, FreeVars
emptyFVs)

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

rnHsTyKi env :: RnTyKiEnv
env (HsDocTy _ ty :: LHsType GhcPs
ty haddock_doc :: LHsDocString
haddock_doc)
  = do { (ty' :: LHsType GhcRn
ty', fvs :: 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 XDocTy GhcRn
NoExt
noExt LHsType GhcRn
ty' LHsDocString
haddock_doc', FreeVars
fvs) }

rnHsTyKi _ (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 env :: RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsExplicitListTy _ ip :: PromotionFlag
ip tys :: [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))
       ; (tys' :: [LHsType GhcRn]
tys', fvs :: 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 XExplicitListTy GhcRn
NoExt
noExt PromotionFlag
ip [LHsType GhcRn]
tys', FreeVars
fvs) }

rnHsTyKi env :: RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsExplicitTupleTy _ tys :: [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))
       ; (tys' :: [LHsType GhcRn]
tys', fvs :: 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 XExplicitTupleTy GhcRn
NoExt
noExt [LHsType GhcRn]
tys', FreeVars
fvs) }

rnHsTyKi env :: RnTyKiEnv
env (HsWildCardTy _)
  = 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 XWildCardTy GhcRn
NoExt
noExt, FreeVars
emptyFVs) }

--------------
rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name
rnTyVar :: RnTyKiEnv -> RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
rnTyVar env :: RnTyKiEnv
env rdr_name :: 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 loc :: SrcSpan
loc rdr_name :: SrcSpanLess (Located RdrName)
rdr_name)
  = do { Name
tyvar <- RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
lookupTypeOccRn SrcSpanLess (Located RdrName)
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 Name
SrcSpanLess (Located Name)
tyvar) }

--------------
rnHsTyOp :: Outputable a
         => RnTyKiEnv -> a -> Located RdrName
         -> RnM (Located Name, FreeVars)
rnHsTyOp :: RnTyKiEnv -> a -> Located RdrName -> RnM (Located Name, FreeVars)
rnHsTyOp env :: RnTyKiEnv
env overall_ty :: a
overall_ty (Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc op :: 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 SrcSpanLess (Located RdrName)
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 SrcSpanLess (Located RdrName)
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 Name
SrcSpanLess (Located 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 doc :: MsgDoc
doc
  = String -> MsgDoc
text "Wildcard" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes MsgDoc
doc MsgDoc -> MsgDoc -> MsgDoc
<+> PtrString -> MsgDoc
ptext (String -> PtrString
sLit "not allowed")

checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM ()
checkWildCard :: RnTyKiEnv -> Maybe MsgDoc -> TcRn ()
checkWildCard env :: RnTyKiEnv
env (Just doc :: 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 2 (String -> MsgDoc
text "in" MsgDoc -> MsgDoc -> MsgDoc
<+> HsDocContext -> MsgDoc
pprHsDocContext (RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env))]
checkWildCard _ 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 env :: 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
               RnTypeBody      -> Maybe MsgDoc
forall a. Maybe a
Nothing
               RnConstraint    -> MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just MsgDoc
constraint_msg
               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 "in a constraint")
                        2 MsgDoc
hint_msg
    hint_msg :: MsgDoc
hint_msg = [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text "except as the last top-level constraint of a type signature"
                    , Int -> MsgDoc -> MsgDoc
nest 2 (String -> MsgDoc
text "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 env :: RnTyKiEnv
env name :: 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
               RnTypeBody      -> Maybe MsgDoc
forall a. Maybe a
Nothing   -- Allowed
               RnTopConstraint -> Maybe MsgDoc
forall a. Maybe a
Nothing   -- Allowed
               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 "in a constraint"

wildCardsAllowed :: RnTyKiEnv -> Bool
-- ^ In what contexts are wildcards permitted
wildCardsAllowed :: RnTyKiEnv -> Bool
wildCardsAllowed env :: 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
       _                   -> 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 env :: RnTyKiEnv
env ty :: 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 "Illegal kind:" MsgDoc -> MsgDoc -> MsgDoc
<+> ty -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ty
ty MsgDoc -> MsgDoc -> MsgDoc
$$
                 String -> MsgDoc
text "Did you mean to enable PolyKinds?") }
checkPolyKinds _ _ = () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

notInKinds :: Outputable ty
           => RnTyKiEnv
           -> ty
           -> RnM ()
notInKinds :: RnTyKiEnv -> ty -> TcRn ()
notInKinds env :: RnTyKiEnv
env ty :: ty
ty
  | RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env
  = MsgDoc -> TcRn ()
addErr (String -> MsgDoc
text "Illegal kind:" MsgDoc -> MsgDoc -> MsgDoc
<+> ty -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr ty
ty)
notInKinds _ _ = () -> 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 tvs :: [Name]
tvs thing_inside :: 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 rdrs :: [Located RdrName]
rdrs thing_inside :: [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 doc :: HsDocContext
doc mb_in_doc :: Maybe MsgDoc
mb_in_doc mb_assoc :: Maybe a
mb_assoc body_kv_occs :: [Located RdrName]
body_kv_occs hsq_bndrs :: LHsQTyVars GhcPs
hsq_bndrs thing_inside :: 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 "checkMixedVars3" (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
           [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text "kv_occs" MsgDoc -> MsgDoc -> MsgDoc
<+> [Located RdrName] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Located RdrName]
kv_occs
                , String -> MsgDoc
text "bndrs"   MsgDoc -> MsgDoc -> MsgDoc
<+> [LHsTyVarBndr GhcPs] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [LHsTyVarBndr GhcPs]
hs_tv_bndrs
                , String -> MsgDoc
text "bndr_kv_occs"   MsgDoc -> MsgDoc -> MsgDoc
<+> [Located RdrName] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Located RdrName]
bndr_kv_occs
                , String -> MsgDoc
text "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
$ \ rn_bndrs :: [LHsTyVarBndr GhcRn]
rn_bndrs ->
    do { String -> MsgDoc -> TcRn ()
traceRn "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 bndrs :: [Located RdrName]
bndrs occs :: [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 locc :: 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 doc :: HsDocContext
doc mb_in_doc :: Maybe MsgDoc
mb_in_doc mb_assoc :: Maybe a
mb_assoc tv_bndrs :: [LHsTyVarBndr GhcPs]
tv_bndrs thing_inside :: [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 []     thing_inside :: [LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)
thing_inside = [LHsTyVarBndr GhcRn] -> RnM (b, FreeVars)
thing_inside []
    go (b :: LHsTyVarBndr GhcPs
b:bs :: [LHsTyVarBndr GhcPs]
bs) thing_inside :: [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
$ \ b' :: LHsTyVarBndr GhcRn
b' ->
                             do { (res :: b
res, fvs :: 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
$ \ bs' :: [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 tv_bndr :: LHsTyVarBndr GhcRn
tv_bndr fvs :: FreeVars
fvs = case Maybe MsgDoc
mb_in_doc of
      Just in_doc :: MsgDoc
in_doc -> MsgDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcRn ()
warnUnusedForAll MsgDoc
in_doc LHsTyVarBndr GhcRn
tv_bndr FreeVars
fvs
      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 _doc :: HsDocContext
_doc mb_assoc :: Maybe a
mb_assoc (LHsTyVarBndr GhcPs -> Located (SrcSpanLess (LHsTyVarBndr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc
                                 (UserTyVar x
                                    lrdr@(dL->L lv _))) thing_inside :: 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 RdrName
Located (IdP GhcPs)
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 GhcPs
XUserTyVar GhcRn
x (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
lv Name
SrcSpanLess (Located Name)
nm))) }

bindLHsTyVarBndr doc :: HsDocContext
doc mb_assoc :: Maybe a
mb_assoc (LHsTyVarBndr GhcPs -> Located (SrcSpanLess (LHsTyVarBndr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc (KindedTyVar x lrdr@(dL->L lv _) kind))
                 thing_inside :: 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)
           ; (kind' :: LHsType GhcRn
kind', fvs1 :: 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 RdrName
Located (IdP GhcPs)
lrdr
           ; (b :: b
b, fvs2 :: 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 GhcPs
XKindedTyVar GhcRn
x (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
lv Name
SrcSpanLess (Located 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 _ _ (LHsTyVarBndr GhcPs -> Located (SrcSpanLess (LHsTyVarBndr GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (XTyVarBndr{})) _ = String -> RnM (b, FreeVars)
forall a. String -> a
panic "bindLHsTyVarBndr"
bindLHsTyVarBndr _ _ _ _ = String -> RnM (b, FreeVars)
forall a. String -> a
panic "bindLHsTyVarBndr: Impossible Match"
                             -- due to #15884

newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name
newTyVarNameRn :: Maybe a -> Located RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newTyVarNameRn mb_assoc :: Maybe a
mb_assoc (Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc rdr :: SrcSpanLess (Located RdrName)
rdr)
  = do { LocalRdrEnv
rdr_env <- RnM LocalRdrEnv
getLocalRdrEnv
       ; case (Maybe a
mb_assoc, LocalRdrEnv -> RdrName -> Maybe Name
lookupLocalRdrEnv LocalRdrEnv
rdr_env SrcSpanLess (Located RdrName)
RdrName
rdr) of
           (Just _, Just n :: 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

           _                -> 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 ctxt :: HsDocContext
ctxt fls :: [FieldLabel]
fls fields :: [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 fl_env :: FastStringEnv FieldLabel
fl_env env :: RnTyKiEnv
env (LConDeclField GhcPs -> Located (SrcSpanLess (LConDeclField GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L 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
       ; (new_ty :: LHsType GhcRn
new_ty, fvs :: 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 XConDeclField GhcRn
NoExt
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 _ (Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L lr :: SrcSpan
lr rdr :: 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 SrcSpanLess (Located RdrName)
RdrName
rdr
        fl :: FieldLabel
fl  = String -> Maybe FieldLabel -> FieldLabel
forall a. HasCallStack => String -> Maybe a -> a
expectJust "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 "rnField"
rnField _ _ (LConDeclField GhcPs -> Located (SrcSpanLess (LConDeclField GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (XConDeclField _)) = String -> RnM (LConDeclField GhcRn, FreeVars)
forall a. String -> a
panic "rnField"
rnField _ _ _ = String -> RnM (LConDeclField GhcRn, FreeVars)
forall a. String -> a
panic "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 mk1 :: LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk1 pp_op1 :: Name
pp_op1 fix1 :: Fixity
fix1 ty1 :: LHsType GhcRn
ty1 (LHsType GhcRn -> Located (SrcSpanLess (LHsType GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc2 :: SrcSpan
loc2 (HsOpTy noExt ty21 op2 ty22))
  = do  { Fixity
fix2 <- Located Name -> RnM Fixity
lookupTyFixityRn Located Name
Located (IdP GhcRn)
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
                      (\t1 :: LHsType GhcRn
t1 t2 :: 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 Name
Located (IdP GhcRn)
op2) Fixity
fix2 LHsType GhcRn
ty21 LHsType GhcRn
ty22 SrcSpan
loc2 }

mkHsOpTyRn mk1 :: LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk1 pp_op1 :: Name
pp_op1 fix1 :: Fixity
fix1 ty1 :: LHsType GhcRn
ty1 (LHsType GhcRn -> Located (SrcSpanLess (LHsType GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc2 :: 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 XFunTy GhcRn
NoExt
noExt) Name
funTyConName Fixity
funTyFixity LHsType GhcRn
ty21 LHsType GhcRn
ty22 SrcSpan
loc2

mkHsOpTyRn mk1 :: LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk1 _ _ ty1 :: LHsType GhcRn
ty1 ty2 :: 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 mk1 :: LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk1 op1 :: Name
op1 fix1 :: Fixity
fix1 ty1 :: LHsType GhcRn
ty1
            mk2 :: LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk2 op2 :: Name
op2 fix2 :: Fixity
fix2 ty21 :: LHsType GhcRn
ty21 ty22 :: LHsType GhcRn
ty22 loc2 :: 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 SrcSpanLess (LHsType GhcRn)
HsType GhcRn
new_ty) LHsType GhcRn
ty22) }
  where
    (nofix_error :: Bool
nofix_error, associate_right :: 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 _ (OpApp fix1 e11 op1 e12)) op2 :: LHsExpr GhcRn
op2 fix2 :: Fixity
fix2 e2 :: LHsExpr GhcRn
e2
  | Bool
nofix_error
  = do (OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr (LHsExpr GhcRn -> OpName
get_op LHsExpr GhcRn
op1,Fixity
XOpApp GhcRn
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 Fixity
XOpApp GhcRn
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' SrcSpanLess (LHsExpr GhcRn)
HsExpr 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
    (nofix_error :: Bool
nofix_error, associate_right :: Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
XOpApp GhcRn
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 _ (NegApp _ neg_arg neg_name)) op2 :: LHsExpr GhcRn
op2 fix2 :: Fixity
fix2 e2 :: 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 Fixity
XOpApp GhcRn
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 XNegApp GhcRn
NoExt
noExt (SrcSpan -> SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc' SrcSpanLess (LHsExpr GhcRn)
HsExpr 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
    (nofix_error :: Bool
nofix_error, associate_right :: Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
negateFixity Fixity
fix2

---------------------------
--      e1 `op` - neg_arg
mkOpAppRn e1 :: LHsExpr GhcRn
e1 op1 :: LHsExpr GhcRn
op1 fix1 :: Fixity
fix1 e2 :: LHsExpr GhcRn
e2@(LHsExpr GhcRn -> Located (SrcSpanLess (LHsExpr GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (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 Fixity
XOpApp GhcRn
fix1 LHsExpr GhcRn
e1 LHsExpr GhcRn
op1 LHsExpr GhcRn
e2)
  where
    (_, associate_right :: Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 Fixity
negateFixity

---------------------------
--      Default case
mkOpAppRn e1 :: LHsExpr GhcRn
e1 op :: LHsExpr GhcRn
op fix :: Fixity
fix e2 :: 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 Fixity
XOpApp GhcRn
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 n :: Name
n)   = Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
n
  ppr NegateOp       = Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
negateName
  ppr (UnboundOp uv :: UnboundVar
uv) = UnboundVar -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr UnboundVar
uv
  ppr (RecFldOp fld :: 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 _ (HsVar _ n))         = Name -> OpName
NormalOp (Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located Name
Located (IdP GhcRn)
n)
get_op (LHsExpr GhcRn -> Located (SrcSpanLess (LHsExpr GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (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 _ (HsRecFld _ fld))    = AmbiguousFieldOcc GhcRn -> OpName
RecFldOp AmbiguousFieldOcc GhcRn
fld
get_op other :: LHsExpr GhcRn
other                         = String -> MsgDoc -> OpName
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic "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 fix1 :: Fixity
fix1 (OpApp fix2 :: XOpApp GhcRn
fix2 _ _ _)
  = Bool -> Bool
not Bool
error_please Bool -> Bool -> Bool
&& Bool
associate_right
  where
    (error_please :: Bool
error_please, associate_right :: Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 Fixity
XOpApp GhcRn
fix2
right_op_ok _ _
  = 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 neg_arg :: LHsExpr (GhcPass id)
neg_arg neg_name :: 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 XNegApp (GhcPass id)
NoExt
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 _          = 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 loc :: SrcSpan
loc
                    (HsCmdTop _
                     (dL->L _ (HsCmdArrForm x op1 f (Just fix1)
                        [a11,a12]))))
        op2 :: LHsExpr GhcRn
op2 fix2 :: Fixity
fix2 a2 :: 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 XCmdArrForm GhcRn
NoExt
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 SrcSpanLess (LHsCmd GhcRn)
HsCmd GhcRn
new_c))])
        -- TODO: locs are wrong
  where
    (nofix_error :: Bool
nofix_error, associate_right :: Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 Fixity
fix2

--      Default case
mkOpFormRn arg1 :: LHsCmdTop GhcRn
arg1 op :: LHsExpr GhcRn
op fix :: Fixity
fix arg2 :: 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 XCmdArrForm GhcRn
NoExt
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 op2 :: Located Name
op2 fix2 :: Fixity
fix2 p1 :: LPat GhcRn
p1@(LPat GhcRn -> Located (SrcSpanLess (LPat GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc (ConPatIn op1 (InfixCon p11 p12))) p2 :: LPat GhcRn
p2
  = do  { Fixity
fix1 <- Name -> RnM Fixity
lookupFixityRn (Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located Name
Located (IdP GhcRn)
op1)
        ; let (nofix_error :: Bool
nofix_error, associate_right :: 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 Name
Located (IdP GhcRn)
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 Name
Located (IdP GhcRn)
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 SrcSpanLess (LPat GhcRn)
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 Name
Located (IdP GhcRn)
op2 (LPat GhcRn -> LPat GhcRn -> HsConPatDetails GhcRn
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon LPat GhcRn
p1 LPat GhcRn
p2)) }

mkConOpPatRn op :: Located Name
op _ p1 :: LPat GhcRn
p1 p2 :: 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 Name
Located (IdP GhcRn)
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 _ (InfixCon _ _)) = Bool
False
not_op_pat _                           = 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 op :: 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 _ ms :: 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 _ (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 SrcSpanLess (LPat GhcRn)
LPat GhcRn
p1 Bool
False
           Name -> LPat GhcRn -> Bool -> TcRn ()
checkPrec Name
op SrcSpanLess (LPat GhcRn)
LPat GhcRn
p2 Bool
True

    check _ = () -> 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 _ (XMatchGroup {}) = String -> TcRn ()
forall a. String -> a
panic "checkPrecMatch"

checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkPrec :: Name -> LPat GhcRn -> Bool -> TcRn ()
checkPrec op :: Name
op (ConPatIn op1 :: Located (IdP GhcRn)
op1 (InfixCon _ _)) right :: Bool
right = do
    op_fix :: Fixity
op_fix@(Fixity _ op_prec :: Int
op_prec  op_dir :: FixityDirection
op_dir) <- Name -> RnM Fixity
lookupFixityRn Name
op
    op1_fix :: Fixity
op1_fix@(Fixity _ op1_prec :: Int
op1_prec op1_dir :: FixityDirection
op1_dir) <- Name -> RnM Fixity
lookupFixityRn (Located Name -> SrcSpanLess (Located Name)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc Located Name
Located (IdP GhcRn)
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 Name
Located (IdP GhcRn)
op1), Fixity
op1_fix)
        (infol :: (OpName, Fixity)
infol, infor :: (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 _ _ _
  = () -> 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 direction :: FixityDirection
direction section :: HsExpr GhcPs
section op :: LHsExpr GhcRn
op arg :: 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') Fixity
XOpApp GhcRn
fix
        NegApp _ _ _      -> OpName -> Fixity -> TcRn ()
go_for_it OpName
NegateOp     Fixity
negateFixity
        _                 -> () -> 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 arg_op :: OpName
arg_op arg_fix :: Fixity
arg_fix@(Fixity _ arg_prec :: Int
arg_prec assoc :: FixityDirection
assoc) = do
          op_fix :: Fixity
op_fix@(Fixity _ op_prec :: Int
op_prec _) <- 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 n :: Name
n)  = Name -> RnM Fixity
lookupFixityRn Name
n
lookupFixityOp NegateOp      = Name -> RnM Fixity
lookupFixityRn Name
negateName
lookupFixityOp (UnboundOp u :: UnboundVar
u) = Name -> RnM Fixity
lookupFixityRn (OccName -> Name
mkUnboundName (UnboundVar -> OccName
unboundVarOcc UnboundVar
u))
lookupFixityOp (RecFldOp f :: 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@(n1 :: OpName
n1,_) op2 :: (OpName, Fixity)
op2@(n2 :: OpName
n2,_)
  | 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 "Precedence parsing error")
      4 ([MsgDoc] -> MsgDoc
hsep [String -> MsgDoc
text "cannot mix", (OpName, Fixity) -> MsgDoc
ppr_opfix (OpName, Fixity)
op1, PtrString -> MsgDoc
ptext (String -> PtrString
sLit "and"),
               (OpName, Fixity) -> MsgDoc
ppr_opfix (OpName, Fixity)
op2,
               String -> MsgDoc
text "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@(n1 :: OpName
n1,_) arg_op :: (OpName, Fixity)
arg_op@(n2 :: OpName
n2,_) section :: 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 "The operator" MsgDoc -> MsgDoc -> MsgDoc
<+> (OpName, Fixity) -> MsgDoc
ppr_opfix (OpName, Fixity)
op MsgDoc -> MsgDoc -> MsgDoc
<+> PtrString -> MsgDoc
ptext (String -> PtrString
sLit "of a section"),
         Int -> MsgDoc -> MsgDoc
nest 4 ([MsgDoc] -> MsgDoc
sep [String -> MsgDoc
text "must have lower precedence than that of the operand,",
                      Int -> MsgDoc -> MsgDoc
nest 2 (String -> MsgDoc
text "namely" MsgDoc -> MsgDoc -> MsgDoc
<+> (OpName, Fixity) -> MsgDoc
ppr_opfix (OpName, Fixity)
arg_op)]),
         Int -> MsgDoc -> MsgDoc
nest 4 (String -> MsgDoc
text "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 n :: Name
n) = Name -> Bool
isUnboundName Name
n
is_unbound UnboundOp{}  = Bool
True
is_unbound _            = Bool
False

ppr_opfix :: (OpName, Fixity) -> SDoc
ppr_opfix :: (OpName, Fixity) -> MsgDoc
ppr_opfix (op :: OpName
op, fixity :: 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 "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 ty :: LHsSigWcType GhcPs
ty
  = MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text "Illegal type signature:" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (LHsSigWcType GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsSigWcType GhcPs
ty))
       2 (String -> MsgDoc
text "Type signatures are only allowed in patterns with ScopedTypeVariables")

badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM ()
badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcRn ()
badKindSigErr doc :: HsDocContext
doc (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc ty :: 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 "Illegal kind signature:" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (HsType GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr SrcSpanLess (LHsType GhcPs)
HsType GhcPs
ty))
       2 (String -> MsgDoc
text "Perhaps you intended to use KindSignatures")

dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc
dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> MsgDoc
dataKindsErr env :: RnTyKiEnv
env thing :: HsType GhcPs
thing
  = MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text "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))
       2 (String -> MsgDoc
text "Perhaps you intended to use DataKinds")
  where
    pp_what :: MsgDoc
pp_what | RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env = String -> MsgDoc
text "kind"
            | Bool
otherwise          = String -> MsgDoc
text "type"

inTypeDoc :: HsType GhcPs -> SDoc
inTypeDoc :: HsType GhcPs -> MsgDoc
inTypeDoc ty :: HsType GhcPs
ty = String -> MsgDoc
text "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 in_doc :: MsgDoc
in_doc (LHsTyVarBndr GhcRn -> Located (SrcSpanLess (LHsTyVarBndr GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc tv :: SrcSpanLess (LHsTyVarBndr GhcRn)
tv) used_names :: 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 SrcSpanLess (LHsTyVarBndr GhcRn)
HsTyVarBndr 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 "Unused quantified type variable" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (HsTyVarBndr GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr SrcSpanLess (LHsTyVarBndr GhcRn)
HsTyVarBndr GhcRn
tv)
         , MsgDoc
in_doc ]

opTyErr :: Outputable a => RdrName -> a -> SDoc
opTyErr :: RdrName -> a -> MsgDoc
opTyErr op :: RdrName
op overall_ty :: a
overall_ty
  = MsgDoc -> Int -> MsgDoc -> MsgDoc
hang (String -> MsgDoc
text "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 "in type") MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (a -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr a
overall_ty))
         2 (String -> MsgDoc
text "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 rdr_env :: 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 rdr_env :: LocalRdrEnv
rdr_env rdr :: 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 ty :: LHsType GhcPs
ty) acc :: FreeKiTyVarsWithDups
acc = TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
TypeLevel LHsType GhcPs
ty FreeKiTyVarsWithDups
acc
extract_tyarg (HsTypeArg _ ki :: LHsType GhcPs
ki) acc :: FreeKiTyVarsWithDups
acc = TypeOrKind
-> LHsType GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_lty TypeOrKind
KindLevel LHsType GhcPs
ki FreeKiTyVarsWithDups
acc
extract_tyarg (HsArgPar _) acc :: FreeKiTyVarsWithDups
acc = FreeKiTyVarsWithDups
acc

extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_tyargs args :: [LHsTypeArg GhcPs]
args acc :: 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 args :: [LHsTypeArg GhcPs]
args = [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_tyargs [LHsTypeArg GhcPs]
args FreeKiTyVarsWithDups
emptyFKTV

extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVarsNoDups
extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVarsWithDups
extractHsTyRdrTyVars ty :: 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 ty :: 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 ty :: 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 tys :: [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 tys :: [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 tv_bndrs :: [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 _ resultSig :: 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 k :: 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 { }) acc :: 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 }) acc :: 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 { }) _ = String -> FreeKiTyVarsWithDups
forall a. String -> a
panic "extractDataDefnKindVars"
extractDataDefnKindVars (XHsDataDefn _) = String -> [Located RdrName]
forall a. String -> a
panic "extractDataDefnKindVars"

extract_mlctxt :: Maybe (LHsContext GhcPs)
               -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_mlctxt :: Maybe (LHsContext GhcPs)
-> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_mlctxt Nothing     acc :: FreeKiTyVarsWithDups
acc = FreeKiTyVarsWithDups
acc
extract_mlctxt (Just ctxt :: LHsContext GhcPs
ctxt) acc :: 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 t_or_k :: TypeOrKind
t_or_k ctxt :: 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 t_or_k :: TypeOrKind
t_or_k tys :: [LHsType GhcPs]
tys acc :: 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 _ Nothing  acc :: FreeKiTyVarsWithDups
acc = FreeKiTyVarsWithDups
acc
extract_mb f :: a -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
f (Just x :: a
x) acc :: 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 t_or_k :: TypeOrKind
t_or_k (LHsType GhcPs -> Located (SrcSpanLess (LHsType GhcPs))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ ty :: SrcSpanLess (LHsType GhcPs)
ty) acc :: FreeKiTyVarsWithDups
acc
  = case SrcSpanLess (LHsType GhcPs)
ty of
      HsTyVar _ _  ltv            -> TypeOrKind
-> Located RdrName -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_tv TypeOrKind
t_or_k Located RdrName
Located (IdP GhcPs)
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 RdrName
Located (IdP GhcPs)
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 tv_bndrs :: [LHsTyVarBndr GhcPs]
tv_bndrs body_fvs :: 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 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 tv_bndrs :: [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 _ (KindedTyVar _ _ k)) <- [LHsTyVarBndr GhcPs]
tv_bndrs]

extract_tv :: TypeOrKind -> Located RdrName
           -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_tv :: TypeOrKind
-> Located RdrName -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups
extract_tv t_or_k :: TypeOrKind
t_or_k ltv :: Located RdrName
ltv@(Located RdrName -> Located (SrcSpanLess (Located RdrName))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ tv :: SrcSpanLess (Located RdrName)
tv) acc :: FreeKiTyVarsWithDups
acc@(FKTV kvs :: [Located RdrName]
kvs tvs :: [Located RdrName]
tvs)
  | Bool -> Bool
not (RdrName -> Bool
isRdrTyVar SrcSpanLess (Located RdrName)
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 x :: 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)