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

-}

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

module GHC.Rename.HsType (
        -- Type related stuff
        rnHsType, rnLHsType, rnLHsTypes, rnContext,
        rnHsKind, rnLHsKind, rnLHsTypeArgs,
        rnHsSigType, rnHsWcType,
        HsSigWcTypeScoping(..), rnHsSigWcType, rnHsPatSigType,
        newTyVarNameRn,
        rnConDeclFields,
        rnLTyVar,

        rnScaledLHsType,

        -- Precence related stuff
        NegationHandling(..),
        mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
        checkPrecMatch, checkSectionPrec,

        -- Binding related stuff
        bindHsForAllTelescope,
        bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..),
        rnImplicitBndrs, bindSigTyVarsFV, bindHsQTyVars,
        FreeKiTyVars,
        extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
        extractHsTysRdrTyVars, extractRdrKindSigVars, extractDataDefnKindVars,
        extractHsTvBndrs, extractHsTyArgRdrKiTyVars,
        extractHsScaledTysRdrTyVars,
        forAllOrNothing, nubL
  ) where

import GHC.Prelude

import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType )

import GHC.Driver.Session
import GHC.Hs
import GHC.Rename.Doc    ( rnLHsDoc, rnMbLHsDoc )
import GHC.Rename.Env
import GHC.Rename.Utils  ( HsDocContext(..), inHsDocContext, withHsDocContext
                         , mapFvRn, pprHsDocContext, bindLocalNamesFV
                         , typeAppErr, newLocalBndrRn, checkDupRdrNames
                         , checkShadowedRdrNames )
import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn
                         , lookupTyFixityRn )
import GHC.Tc.Utils.Monad
import GHC.Types.Name.Reader
import GHC.Builtin.Names
import GHC.Builtin.Types.Prim ( funTyConName )
import GHC.Types.Name
import GHC.Types.SrcLoc
import GHC.Types.Name.Set
import GHC.Types.FieldLabel

import GHC.Utils.Misc
import GHC.Types.Basic  ( compareFixity, funTyFixity, negateFixity
                        , Fixity(..), FixityDirection(..), LexicalFixity(..)
                        , TypeOrKind(..) )
import GHC.Utils.Outputable
import GHC.Data.FastString
import GHC.Data.Maybe
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) GHC.Rename.Module,
to break several loops.

*********************************************************
*                                                       *
    HsSigWcType and HsPatSigType (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.
    --
    -- For pattern type sigs, 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.
    --
    -- RULES can also use 'AlwaysBind', such as in the following example:
    --
    -- > {-# RULES \"f\" forall (x :: forall a. a -> b). f x = ... b ... #-}
    --
    -- This only applies to RULES that do not explicitly bind their type
    -- variables. If a RULE explicitly quantifies its type variables, then
    -- 'NeverBind' is used instead. See also
    -- @Note [Pattern signature binders and scoping]@ in "GHC.Hs.Type".
  | BindUnlessForall
    -- ^ Unless there's forall at the top, do the same thing as 'AlwaysBind'.
    -- This is only ever used in places where the \"@forall@-or-nothing\" rule
    -- is in effect. See @Note [forall-or-nothing rule]@.
  | NeverBind
    -- ^ Never bind any free tyvars. This is used for RULES that have both
    -- explicit type and term variable binders, e.g.:
    --
    -- > {-# RULES \"const\" forall a. forall (x :: a) y. const x y = x #-}
    --
    -- The presence of the type variable binder @forall a.@ implies that the
    -- free variables in the types of the term variable binders @x@ and @y@
    -- are /not/ bound. In the example above, there are no such free variables,
    -- but if the user had written @(y :: b)@ instead of @y@ in the term
    -- variable binders, then @b@ would be rejected for being out of scope.
    -- See also @Note [Pattern signature binders and scoping]@ in
    -- "GHC.Hs.Type".

rnHsSigWcType :: HsDocContext
              -> LHsSigWcType GhcPs
              -> RnM (LHsSigWcType GhcRn, FreeVars)
rnHsSigWcType :: HsDocContext
-> LHsSigWcType GhcPs -> RnM (LHsSigWcType GhcRn, FreeVars)
rnHsSigWcType HsDocContext
doc (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 }})
  = HsSigWcTypeScoping
-> HsDocContext
-> LHsType GhcPs
-> ([Name]
    -> [Name] -> LHsType GhcRn -> RnM (LHsSigWcType GhcRn, FreeVars))
-> RnM (LHsSigWcType GhcRn, FreeVars)
forall a.
HsSigWcTypeScoping
-> HsDocContext
-> LHsType GhcPs
-> ([Name] -> [Name] -> LHsType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rn_hs_sig_wc_type HsSigWcTypeScoping
BindUnlessForall HsDocContext
doc LHsType GhcPs
hs_ty (([Name]
  -> [Name] -> LHsType GhcRn -> RnM (LHsSigWcType GhcRn, FreeVars))
 -> RnM (LHsSigWcType GhcRn, FreeVars))
-> ([Name]
    -> [Name] -> LHsType GhcRn -> RnM (LHsSigWcType GhcRn, FreeVars))
-> RnM (LHsSigWcType GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ \[Name]
nwcs [Name]
imp_tvs LHsType GhcRn
body ->
    let 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)
imp_tvs, hsib_body :: LHsType GhcRn
hsib_body = LHsType GhcRn
body  }
        wc_ty :: LHsSigWcType GhcRn
wc_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))
nwcs,    hswc_body :: HsImplicitBndrs GhcRn (LHsType GhcRn)
hswc_body = HsImplicitBndrs GhcRn (LHsType GhcRn)
ib_ty } in
    (LHsSigWcType GhcRn, FreeVars)
-> RnM (LHsSigWcType GhcRn, FreeVars)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LHsSigWcType GhcRn
wc_ty, FreeVars
emptyFVs)

rnHsPatSigType :: HsSigWcTypeScoping
               -> HsDocContext
               -> HsPatSigType GhcPs
               -> (HsPatSigType GhcRn -> RnM (a, FreeVars))
               -> RnM (a, FreeVars)
-- Used for
--   - Pattern type signatures, which are only allowed with ScopedTypeVariables
--   - Signatures on binders in a RULE, which are allowed even if
--     ScopedTypeVariables isn't enabled
-- Wildcards are allowed
--
-- See Note [Pattern signature binders and scoping] in GHC.Hs.Type
rnHsPatSigType :: forall a.
HsSigWcTypeScoping
-> HsDocContext
-> HsPatSigType GhcPs
-> (HsPatSigType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnHsPatSigType HsSigWcTypeScoping
scoping HsDocContext
ctx HsPatSigType GhcPs
sig_ty HsPatSigType 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 (HsPatSigType GhcPs -> MsgDoc
unexpectedPatSigTypeErr HsPatSigType GhcPs
sig_ty)
       ; HsSigWcTypeScoping
-> HsDocContext
-> LHsType GhcPs
-> ([Name] -> [Name] -> LHsType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall a.
HsSigWcTypeScoping
-> HsDocContext
-> LHsType GhcPs
-> ([Name] -> [Name] -> LHsType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rn_hs_sig_wc_type HsSigWcTypeScoping
scoping HsDocContext
ctx (HsPatSigType GhcPs -> LHsType GhcPs
forall pass. HsPatSigType pass -> LHsType pass
hsPatSigType HsPatSigType GhcPs
sig_ty) (([Name] -> [Name] -> LHsType GhcRn -> RnM (a, FreeVars))
 -> RnM (a, FreeVars))
-> ([Name] -> [Name] -> LHsType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$
         \[Name]
nwcs [Name]
imp_tvs LHsType GhcRn
body ->
    do { let sig_names :: HsPSRn
sig_names = HsPSRn :: [Name] -> [Name] -> HsPSRn
HsPSRn { hsps_nwcs :: [Name]
hsps_nwcs = [Name]
nwcs, hsps_imp_tvs :: [Name]
hsps_imp_tvs = [Name]
imp_tvs }
             sig_ty' :: HsPatSigType GhcRn
sig_ty'   = HsPS :: forall pass. XHsPS pass -> LHsType pass -> HsPatSigType pass
HsPS { hsps_ext :: XHsPS GhcRn
hsps_ext = XHsPS GhcRn
HsPSRn
sig_names, hsps_body :: LHsType GhcRn
hsps_body = LHsType GhcRn
body }
       ; HsPatSigType GhcRn -> RnM (a, FreeVars)
thing_inside HsPatSigType GhcRn
sig_ty'
       } }

-- The workhorse for rnHsSigWcType and rnHsPatSigType.
rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext
                  -> LHsType GhcPs
                  -> ([Name]    -- Wildcard names
                      -> [Name] -- Implicitly bound type variable names
                      -> LHsType GhcRn
                      -> RnM (a, FreeVars))
                  -> RnM (a, FreeVars)
rn_hs_sig_wc_type :: forall a.
HsSigWcTypeScoping
-> HsDocContext
-> LHsType GhcPs
-> ([Name] -> [Name] -> LHsType GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rn_hs_sig_wc_type HsSigWcTypeScoping
scoping HsDocContext
ctxt LHsType GhcPs
hs_ty [Name] -> [Name] -> LHsType GhcRn -> RnM (a, FreeVars)
thing_inside
  = do { FreeKiTyVars
free_vars <- FreeKiTyVars -> RnM FreeKiTyVars
filterInScopeM (LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVars LHsType GhcPs
hs_ty)
       ; (FreeKiTyVars
nwc_rdrs', FreeKiTyVars
tv_rdrs) <- FreeKiTyVars -> RnM (FreeKiTyVars, FreeKiTyVars)
partition_nwcs FreeKiTyVars
free_vars
       ; let nwc_rdrs :: FreeKiTyVars
nwc_rdrs = FreeKiTyVars -> FreeKiTyVars
forall a. Eq a => [Located a] -> [Located a]
nubL FreeKiTyVars
nwc_rdrs'
       ; FreeKiTyVars
implicit_bndrs <- case HsSigWcTypeScoping
scoping of
           HsSigWcTypeScoping
AlwaysBind       -> FreeKiTyVars -> RnM FreeKiTyVars
forall (f :: * -> *) a. Applicative f => a -> f a
pure FreeKiTyVars
tv_rdrs
           HsSigWcTypeScoping
BindUnlessForall -> Bool -> FreeKiTyVars -> RnM FreeKiTyVars
forAllOrNothing (LHsType GhcPs -> Bool
forall p. LHsType p -> Bool
isLHsForAllTy LHsType GhcPs
hs_ty) FreeKiTyVars
tv_rdrs
           HsSigWcTypeScoping
NeverBind        -> FreeKiTyVars -> RnM FreeKiTyVars
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
       ; Maybe Any
-> FreeKiTyVars
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall assoc a.
Maybe assoc
-> FreeKiTyVars
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnImplicitBndrs Maybe Any
forall a. Maybe a
Nothing FreeKiTyVars
implicit_bndrs (([Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars))
-> ([Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [Name]
vars ->
    do { ([Name]
wcs, LHsType GhcRn
hs_ty', FreeVars
fvs1) <- HsDocContext
-> FreeKiTyVars
-> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBody HsDocContext
ctxt FreeKiTyVars
nwc_rdrs LHsType GhcPs
hs_ty
       ; (a
res, FreeVars
fvs2) <- [Name] -> [Name] -> LHsType GhcRn -> RnM (a, FreeVars)
thing_inside [Name]
wcs [Name]
vars LHsType GhcRn
hs_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) } }

rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)
rnHsWcType HsDocContext
ctxt (HsWC { hswc_body :: forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body = LHsType GhcPs
hs_ty })
  = do { FreeKiTyVars
free_vars <- FreeKiTyVars -> RnM FreeKiTyVars
filterInScopeM (LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVars LHsType GhcPs
hs_ty)
       ; (FreeKiTyVars
nwc_rdrs', FreeKiTyVars
_) <- FreeKiTyVars -> RnM (FreeKiTyVars, FreeKiTyVars)
partition_nwcs FreeKiTyVars
free_vars
       ; let nwc_rdrs :: FreeKiTyVars
nwc_rdrs = FreeKiTyVars -> FreeKiTyVars
forall a. Eq a => [Located a] -> [Located a]
nubL FreeKiTyVars
nwc_rdrs'
       ; ([Name]
wcs, LHsType GhcRn
hs_ty', FreeVars
fvs) <- HsDocContext
-> FreeKiTyVars
-> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBody HsDocContext
ctxt FreeKiTyVars
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) }

rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs
         -> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBody :: HsDocContext
-> FreeKiTyVars
-> LHsType GhcPs
-> RnM ([Name], LHsType GhcRn, FreeVars)
rnWcBody HsDocContext
ctxt FreeKiTyVars
nwc_rdrs LHsType GhcPs
hs_ty
  = do { [Name]
nwcs <- (GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> FreeKiTyVars -> IOEnv (Env TcGblEnv TcLclEnv) [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newLocalBndrRn FreeKiTyVars
nwc_rdrs
       ; let env :: RnTyKiEnv
env = RTKE :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> FreeVars -> RnTyKiEnv
RTKE { rtke_level :: TypeOrKind
rtke_level = TypeOrKind
TypeLevel
                        , rtke_what :: RnTyKiWhat
rtke_what  = RnTyKiWhat
RnTypeBody
                        , rtke_nwcs :: FreeVars
rtke_nwcs  = [Name] -> FreeVars
mkNameSet [Name]
nwcs
                        , rtke_ctxt :: HsDocContext
rtke_ctxt  = HsDocContext
ctxt }
       ; (LHsType GhcRn
hs_ty', FreeVars
fvs) <- [Name]
-> RnM (LHsType GhcRn, FreeVars) -> RnM (LHsType GhcRn, FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
nwcs (RnM (LHsType GhcRn, FreeVars) -> RnM (LHsType GhcRn, FreeVars))
-> RnM (LHsType GhcRn, FreeVars) -> RnM (LHsType GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
                          RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
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 -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rn_lty RnTyKiEnv
env (L SrcSpan
loc HsType GhcPs
hs_ty)
      = SrcSpan
-> RnM (LHsType GhcRn, FreeVars) -> RnM (LHsType GhcRn, FreeVars)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc (RnM (LHsType GhcRn, FreeVars) -> RnM (LHsType GhcRn, FreeVars))
-> RnM (LHsType GhcRn, FreeVars) -> RnM (LHsType GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$
        do { (HsType GhcRn
hs_ty', FreeVars
fvs) <- RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rn_ty RnTyKiEnv
env HsType GhcPs
hs_ty
           ; (LHsType GhcRn, FreeVars) -> RnM (LHsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> HsType GhcRn -> LHsType GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc 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 RnTyKiEnv
env (HsForAllTy { hst_tele :: forall pass. HsType pass -> HsForAllTelescope pass
hst_tele = HsForAllTelescope GhcPs
tele, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcPs
hs_body })
      = HsDocContext
-> HsForAllTelescope GhcPs
-> (HsForAllTelescope GhcRn -> RnM (HsType GhcRn, FreeVars))
-> RnM (HsType GhcRn, FreeVars)
forall a.
HsDocContext
-> HsForAllTelescope GhcPs
-> (HsForAllTelescope GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsForAllTelescope (RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env) HsForAllTelescope GhcPs
tele ((HsForAllTelescope GhcRn -> RnM (HsType GhcRn, FreeVars))
 -> RnM (HsType GhcRn, FreeVars))
-> (HsForAllTelescope GhcRn -> RnM (HsType GhcRn, FreeVars))
-> RnM (HsType GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ HsForAllTelescope GhcRn
tele' ->
        do { (LHsType GhcRn
hs_body', FreeVars
fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, 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
-> HsForAllTelescope pass -> LHsType pass -> HsType pass
HsForAllTy { hst_xforall :: XForAllTy GhcRn
hst_xforall = NoExtField
XForAllTy GhcRn
noExtField
                                , hst_tele :: HsForAllTelescope GhcRn
hst_tele = HsForAllTelescope GhcRn
tele', hst_body :: LHsType GhcRn
hst_body = LHsType GhcRn
hs_body' }
                    , FreeVars
fvs) }

    rn_ty RnTyKiEnv
env (HsQualTy { hst_ctxt :: forall pass. HsType pass -> LHsContext pass
hst_ctxt = L SrcSpan
cx HsContext GhcPs
hs_ctxt
                        , hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcPs
hs_ty })
      | Just (HsContext GhcPs
hs_ctxt1, LHsType GhcPs
hs_ctxt_last) <- HsContext GhcPs -> Maybe (HsContext GhcPs, LHsType GhcPs)
forall a. [a] -> Maybe ([a], a)
snocView HsContext GhcPs
hs_ctxt
      , L SrcSpan
lx (HsWildCardTy XWildCardTy GhcPs
_)  <- LHsType GhcPs -> LHsType GhcPs
forall pass. LHsType pass -> LHsType pass
ignoreParens LHsType GhcPs
hs_ctxt_last
      = do { ([LHsType GhcRn]
hs_ctxt1', FreeVars
fvs1) <- (LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars))
-> HsContext 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) HsContext 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 -> HsContext GhcPs -> TcRn ()
checkExtraConstraintWildCard RnTyKiEnv
env HsContext 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 -> HsType GhcRn -> LHsType GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
lx (XWildCardTy GhcRn -> HsType GhcRn
forall pass. XWildCardTy pass -> HsType pass
HsWildCardTy NoExtField
XWildCardTy GhcRn
noExtField)]
           ; (LHsType GhcRn
hs_ty', FreeVars
fvs2) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
hs_ty
           ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQualTy :: forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy { hst_xqual :: XQualTy GhcRn
hst_xqual = NoExtField
XQualTy GhcRn
noExtField
                              , hst_ctxt :: LHsContext GhcRn
hst_ctxt = SrcSpan -> [LHsType GhcRn] -> LHsContext GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
cx [LHsType GhcRn]
hs_ctxt', hst_body :: LHsType GhcRn
hst_body = LHsType GhcRn
hs_ty' }
                    , FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }

      | Bool
otherwise
      = do { ([LHsType GhcRn]
hs_ctxt', FreeVars
fvs1) <- (LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars))
-> HsContext 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) HsContext GhcPs
hs_ctxt
           ; (LHsType GhcRn
hs_ty', FreeVars
fvs2)   <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
hs_ty
           ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsQualTy :: forall pass.
XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass
HsQualTy { hst_xqual :: XQualTy GhcRn
hst_xqual = NoExtField
XQualTy GhcRn
noExtField
                              , hst_ctxt :: LHsContext GhcRn
hst_ctxt = SrcSpan -> [LHsType GhcRn] -> LHsContext GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
cx [LHsType GhcRn]
hs_ctxt'
                              , hst_body :: LHsType GhcRn
hst_body = LHsType GhcRn
hs_ty' }
                    , FreeVars
fvs1 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs2) }

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

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


checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM ()
-- Rename the extra-constraint spot in a type signature
--    (blah, _) => type
-- Check that extra-constraints are allowed at all, and
-- if so that it's an anonymous wildcard
checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> TcRn ()
checkExtraConstraintWildCard RnTyKiEnv
env HsContext 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 (HsContext GhcPs -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null HsContext GhcPs
hs_ctxt)
           = MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just MsgDoc
deriv_decl_msg
           | Bool
otherwise
           = Maybe MsgDoc
forall a. Maybe a
Nothing

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

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

extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool
extraConstraintWildCardsAllowed RnTyKiEnv
env
  = case RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env of
      TypeSigCtx {}       -> Bool
True
      ExprWithTySigCtx {} -> Bool
True
      DerivDeclCtx {}     -> Bool
True
      StandaloneKindSigCtx {} -> Bool
False  -- See Note [Wildcards in standalone kind signatures] in "GHC.Hs.Decls"
      HsDocContext
_                   -> Bool
False

-- | 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 ([Located RdrName], FreeKiTyVars)
partition_nwcs :: FreeKiTyVars -> RnM (FreeKiTyVars, FreeKiTyVars)
partition_nwcs FreeKiTyVars
free_vars
  = do { Bool
wildcards_enabled <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.NamedWildCards
       ; (FreeKiTyVars, FreeKiTyVars) -> RnM (FreeKiTyVars, FreeKiTyVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ((FreeKiTyVars, FreeKiTyVars) -> RnM (FreeKiTyVars, FreeKiTyVars))
-> (FreeKiTyVars, FreeKiTyVars) -> RnM (FreeKiTyVars, FreeKiTyVars)
forall a b. (a -> b) -> a -> b
$
           if Bool
wildcards_enabled
           then (GenLocated SrcSpan RdrName -> Bool)
-> FreeKiTyVars -> (FreeKiTyVars, FreeKiTyVars)
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition GenLocated SrcSpan RdrName -> Bool
is_wildcard FreeKiTyVars
free_vars
           else ([], FreeKiTyVars
free_vars) }
  where
     is_wildcard :: Located RdrName -> Bool
     is_wildcard :: GenLocated SrcSpan RdrName -> Bool
is_wildcard GenLocated SrcSpan RdrName
rdr = OccName -> Bool
startsWithUnderscore (RdrName -> OccName
rdrNameOcc (GenLocated SrcSpan RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan 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 GHC.Hs.Type.

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
            -> TypeOrKind
            -> LHsSigType GhcPs
            -> RnM (LHsSigType GhcRn, FreeVars)
-- Used for source-language type signatures
-- that cannot have wildcards
rnHsSigType :: HsDocContext
-> TypeOrKind
-> HsImplicitBndrs GhcPs (LHsType GhcPs)
-> RnM (HsImplicitBndrs GhcRn (LHsType GhcRn), FreeVars)
rnHsSigType HsDocContext
ctx TypeOrKind
level (HsIB { hsib_body :: forall pass thing. HsImplicitBndrs pass thing -> thing
hsib_body = LHsType GhcPs
hs_ty })
  = do { String -> MsgDoc -> TcRn ()
traceRn String
"rnHsSigType" (LHsType GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsType GhcPs
hs_ty)
       ; LocalRdrEnv
rdr_env <- RnM LocalRdrEnv
getLocalRdrEnv
       ; FreeKiTyVars
vars0 <- Bool -> FreeKiTyVars -> RnM FreeKiTyVars
forAllOrNothing (LHsType GhcPs -> Bool
forall p. LHsType p -> Bool
isLHsForAllTy LHsType GhcPs
hs_ty)
           (FreeKiTyVars -> RnM FreeKiTyVars)
-> FreeKiTyVars -> RnM FreeKiTyVars
forall a b. (a -> b) -> a -> b
$ LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
filterInScope LocalRdrEnv
rdr_env
           (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVars LHsType GhcPs
hs_ty
       ; Maybe Any
-> FreeKiTyVars
-> ([Name]
    -> RnM (HsImplicitBndrs GhcRn (LHsType GhcRn), FreeVars))
-> RnM (HsImplicitBndrs GhcRn (LHsType GhcRn), FreeVars)
forall assoc a.
Maybe assoc
-> FreeKiTyVars
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnImplicitBndrs Maybe Any
forall a. Maybe a
Nothing FreeKiTyVars
vars0 (([Name] -> RnM (HsImplicitBndrs GhcRn (LHsType GhcRn), FreeVars))
 -> RnM (HsImplicitBndrs GhcRn (LHsType GhcRn), FreeVars))
-> ([Name]
    -> RnM (HsImplicitBndrs GhcRn (LHsType GhcRn), FreeVars))
-> RnM (HsImplicitBndrs GhcRn (LHsType GhcRn), FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [Name]
vars ->
    do { (LHsType GhcRn
body', FreeVars
fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi (HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
ctx TypeOrKind
level RnTyKiWhat
RnTypeBody) 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 ) } }

-- Note [forall-or-nothing rule]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Free variables in signatures are usually bound in an implicit
-- 'forall' at the beginning of user-written signatures. However, if the
-- signature has an explicit forall at the beginning, this is disabled.
--
-- The idea is nested foralls express something which is only
-- expressible explicitly, while a top level forall could (usually) be
-- replaced with an implicit binding. Top-level foralls alone ("forall.") are
-- therefore an indication that the user is trying to be fastidious, so
-- we don't implicitly bind any variables.

-- | See @Note [forall-or-nothing rule]@. This tiny little function is used
-- (rather than its small body inlined) to indicate that we are implementing
-- that rule.
forAllOrNothing :: Bool
                -- ^ True <=> explicit forall
                -- E.g.  f :: forall a. a->b
                --  we do not want to bring 'b' into scope, hence True
                -- But   f :: a -> b
                --  we want to bring both 'a' and 'b' into scope, hence False
                -> FreeKiTyVars
                -- ^ Free vars of the type
                -> RnM FreeKiTyVars
forAllOrNothing :: Bool -> FreeKiTyVars -> RnM FreeKiTyVars
forAllOrNothing Bool
has_outer_forall FreeKiTyVars
fvs = case Bool
has_outer_forall of
  Bool
True -> do
    String -> MsgDoc -> TcRn ()
traceRn String
"forAllOrNothing" (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text String
"has explicit outer forall"
    FreeKiTyVars -> RnM FreeKiTyVars
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  Bool
False -> do
    String -> MsgDoc -> TcRn ()
traceRn String
"forAllOrNothing" (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ String -> MsgDoc
text String
"no explicit forall. implicit binders:" MsgDoc -> MsgDoc -> MsgDoc
<+> FreeKiTyVars -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr FreeKiTyVars
fvs
    FreeKiTyVars -> RnM FreeKiTyVars
forall (f :: * -> *) a. Applicative f => a -> f a
pure FreeKiTyVars
fvs

rnImplicitBndrs :: Maybe assoc
                -- ^ @'Just' _@ => an associated type decl
                -> FreeKiTyVars
                -- ^ Surface-syntax free vars that we will implicitly bind.
                -- May have duplicates, which are removed here.
                -> ([Name] -> RnM (a, FreeVars))
                -> RnM (a, FreeVars)
rnImplicitBndrs :: forall assoc a.
Maybe assoc
-> FreeKiTyVars
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnImplicitBndrs Maybe assoc
mb_assoc FreeKiTyVars
implicit_vs_with_dups [Name] -> RnM (a, FreeVars)
thing_inside
  = do { let implicit_vs :: FreeKiTyVars
implicit_vs = FreeKiTyVars -> FreeKiTyVars
forall a. Eq a => [Located a] -> [Located a]
nubL FreeKiTyVars
implicit_vs_with_dups

       ; String -> MsgDoc -> TcRn ()
traceRn String
"rnImplicitBndrs" (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
         [MsgDoc] -> MsgDoc
vcat [ FreeKiTyVars -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr FreeKiTyVars
implicit_vs_with_dups, FreeKiTyVars -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr FreeKiTyVars
implicit_vs ]

         -- Use the currently set SrcSpan as the new source location for each Name.
         -- See Note [Source locations for implicitly bound type variables].
       ; SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
       ; [Name]
vars <- (GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> FreeKiTyVars -> IOEnv (Env TcGblEnv TcLclEnv) [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe assoc
-> GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a.
Maybe a
-> GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newTyVarNameRn Maybe assoc
mb_assoc (GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name)
-> (GenLocated SrcSpan RdrName -> GenLocated SrcSpan RdrName)
-> GenLocated SrcSpan RdrName
-> IOEnv (Env TcGblEnv TcLclEnv) Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (RdrName -> GenLocated SrcSpan RdrName)
-> (GenLocated SrcSpan RdrName -> RdrName)
-> GenLocated SrcSpan RdrName
-> GenLocated SrcSpan RdrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc) FreeKiTyVars
implicit_vs

       ; [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 }

{-
Note [Source locations for implicitly bound type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When bringing implicitly bound type variables into scope (in rnImplicitBndrs),
we do something peculiar: we drop the original SrcSpan attached to each
variable and replace it with the currently set SrcSpan. Moreover, this new
SrcSpan is usually /less/ precise than the original one, and that's OK. To see
why this is done, consider the following example:

  f :: a -> b -> a

Suppose that a warning or error message needs to point to the SrcSpans of the
binding sites for `a` and `b`. But where /are/ they bound, anyway? Technically,
they're bound by an unwritten `forall` at the front of the type signature, but
there is no SrcSpan for that. We could point to the first occurrence of `a` as
the binding site for `a`, but that would make the first occurrence of `a`
special. Moreover, we don't want IDEs to confuse binding sites and occurrences.

As a result, we make the `SrcSpan`s for `a` and `b` span the entirety of the
type signature, since the type signature implicitly carries their binding
sites. This is less precise, but more accurate.
-}

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

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

Note [QualTy in kinds]
~~~~~~~~~~~~~~~~~~~~~~
I was wondering whether QualTy could occur only at TypeLevel.  But no,
we can have a qualified type in a kind too. Here is an example:

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

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

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

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

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

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

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

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

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

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

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

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

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

rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)
rnLHsTypes :: HsDocContext -> HsContext GhcPs -> RnM ([LHsType GhcRn], FreeVars)
rnLHsTypes HsDocContext
doc HsContext GhcPs
tys = (LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars))
-> HsContext 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) HsContext GhcPs
tys

rnScaledLHsType :: HsDocContext -> HsScaled GhcPs (LHsType GhcPs)
                                  -> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
rnScaledLHsType :: HsDocContext
-> HsScaled GhcPs (LHsType GhcPs)
-> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
rnScaledLHsType HsDocContext
doc (HsScaled HsArrow GhcPs
w LHsType GhcPs
ty) = do
  (HsArrow GhcRn
w' , FreeVars
fvs_w) <- RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)
rnHsArrow (HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
doc TypeOrKind
TypeLevel RnTyKiWhat
RnTypeBody) HsArrow GhcPs
w
  (LHsType GhcRn
ty', FreeVars
fvs) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsType HsDocContext
doc LHsType GhcPs
ty
  (HsScaled GhcRn (LHsType GhcRn), FreeVars)
-> RnM (HsScaled GhcRn (LHsType GhcRn), FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsArrow GhcRn -> LHsType GhcRn -> HsScaled GhcRn (LHsType GhcRn)
forall pass a. HsArrow pass -> a -> HsScaled pass a
HsScaled HsArrow GhcRn
w' LHsType GhcRn
ty', FreeVars
fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
fvs_w)


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

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

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

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

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

--------------
rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs
              -> RnM (LHsContext GhcRn, FreeVars)
rnTyKiContext :: RnTyKiEnv
-> GenLocated SrcSpan (HsContext GhcPs)
-> RnM (LHsContext GhcRn, FreeVars)
rnTyKiContext RnTyKiEnv
env (L SrcSpan
loc HsContext GhcPs
cxt)
  = do { String -> MsgDoc -> TcRn ()
traceRn String
"rncontext" (HsContext GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsContext GhcPs
cxt)
       ; let env' :: RnTyKiEnv
env' = RnTyKiEnv
env { rtke_what :: RnTyKiWhat
rtke_what = RnTyKiWhat
RnConstraint }
       ; ([LHsType GhcRn]
cxt', FreeVars
fvs) <- (LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars))
-> HsContext 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') HsContext GhcPs
cxt
       ; (LHsContext GhcRn, FreeVars) -> RnM (LHsContext GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> [LHsType GhcRn] -> LHsContext GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc [LHsType GhcRn]
cxt', FreeVars
fvs) }

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

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

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

rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)
rnHsTyKi RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsForAllTy { hst_tele :: forall pass. HsType pass -> HsForAllTelescope pass
hst_tele = HsForAllTelescope GhcPs
tele, 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
-> HsForAllTelescope GhcPs
-> (HsForAllTelescope GhcRn -> RnM (HsType GhcRn, FreeVars))
-> RnM (HsType GhcRn, FreeVars)
forall a.
HsDocContext
-> HsForAllTelescope GhcPs
-> (HsForAllTelescope GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsForAllTelescope (RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env) HsForAllTelescope GhcPs
tele ((HsForAllTelescope GhcRn -> RnM (HsType GhcRn, FreeVars))
 -> RnM (HsType GhcRn, FreeVars))
-> (HsForAllTelescope GhcRn -> RnM (HsType GhcRn, FreeVars))
-> RnM (HsType GhcRn, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ HsForAllTelescope GhcRn
tele' ->
    do { (LHsType GhcRn
tau',  FreeVars
fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
tau
       ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return ( HsForAllTy :: forall pass.
XForAllTy pass
-> HsForAllTelescope pass -> LHsType pass -> HsType pass
HsForAllTy { hst_xforall :: XForAllTy GhcRn
hst_xforall = NoExtField
XForAllTy GhcRn
noExtField
                             , hst_tele :: HsForAllTelescope GhcRn
hst_tele = HsForAllTelescope GhcRn
tele' , hst_body :: LHsType GhcRn
hst_body =  LHsType GhcRn
tau' }
                , FreeVars
fvs) } }

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

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

rnHsTyKi RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsOpTy XOpTy GhcPs
_ LHsType GhcPs
ty1 GenLocated SrcSpan (IdP GhcPs)
l_op LHsType GhcPs
ty2)
  = SrcSpan
-> RnM (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (GenLocated SrcSpan RdrName -> SrcSpan
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpan RdrName
GenLocated SrcSpan (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  { (GenLocated SrcSpan Name
l_op', FreeVars
fvs1) <- RnTyKiEnv
-> HsType GhcPs
-> GenLocated SrcSpan RdrName
-> RnM (GenLocated SrcSpan Name, FreeVars)
forall a.
Outputable a =>
RnTyKiEnv
-> a
-> GenLocated SrcSpan RdrName
-> RnM (GenLocated SrcSpan Name, FreeVars)
rnHsTyOp RnTyKiEnv
env HsType GhcPs
ty GenLocated SrcSpan RdrName
GenLocated SrcSpan (IdP GhcPs)
l_op
        ; Fixity
fix   <- GenLocated SrcSpan Name -> RnM Fixity
lookupTyFixityRn GenLocated SrcSpan Name
l_op'
        ; (LHsType GhcRn
ty1', FreeVars
fvs2) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty1
        ; (LHsType GhcRn
ty2', FreeVars
fvs3) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty2
        ; HsType GhcRn
res_ty <- (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> Name
-> Fixity
-> LHsType GhcRn
-> LHsType GhcRn
-> RnM (HsType GhcRn)
mkHsOpTyRn (\LHsType GhcRn
t1 LHsType GhcRn
t2 -> XOpTy GhcRn
-> LHsType GhcRn
-> Located (IdP GhcRn)
-> LHsType GhcRn
-> HsType GhcRn
forall pass.
XOpTy pass
-> LHsType pass
-> Located (IdP pass)
-> LHsType pass
-> HsType pass
HsOpTy NoExtField
XOpTy GhcRn
noExtField LHsType GhcRn
t1 GenLocated SrcSpan Name
Located (IdP GhcRn)
l_op' LHsType GhcRn
t2)
                               (GenLocated SrcSpan Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan Name
l_op') Fixity
fix LHsType GhcRn
ty1' LHsType GhcRn
ty2'
        ; (HsType GhcRn, FreeVars) -> RnM (HsType GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsType GhcRn
res_ty, [FreeVars] -> FreeVars
plusFVs [FreeVars
fvs1, FreeVars
fvs2, FreeVars
fvs3]) }

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

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

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

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

        -- Check for fixity rearrangements
       ; (HsArrow GhcRn
mult', FreeVars
w_fvs) <- RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)
rnHsArrow RnTyKiEnv
env HsArrow GhcPs
mult
       ; HsType GhcRn
res_ty <- (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> Name
-> Fixity
-> LHsType GhcRn
-> LHsType GhcRn
-> RnM (HsType GhcRn)
mkHsOpTyRn (HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
hs_fun_ty HsArrow GhcRn
mult') 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 FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
w_fvs) }
  where
    hs_fun_ty :: HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
hs_fun_ty HsArrow GhcRn
w LHsType GhcRn
a LHsType GhcRn
b = XFunTy GhcRn
-> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy XFunTy GhcPs
XFunTy GhcRn
u HsArrow GhcRn
w LHsType GhcRn
a LHsType GhcRn
b

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

rnHsTyKi RnTyKiEnv
env t :: HsType GhcPs
t@(HsKindSig XKindSig GhcPs
_ LHsType GhcPs
ty LHsType GhcPs
k)
  = do { RnTyKiEnv -> HsType GhcPs -> TcRn ()
forall ty. Outputable ty => RnTyKiEnv -> ty -> TcRn ()
checkPolyKinds RnTyKiEnv
env HsType GhcPs
t
       ; Bool
kind_sigs_ok <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.KindSignatures
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
kind_sigs_ok (HsDocContext -> LHsType GhcPs -> TcRn ()
badKindSigErr (RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env) LHsType GhcPs
ty)
       ; (LHsType GhcRn
ty', FreeVars
lhs_fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
       ; (LHsType GhcRn
k', FreeVars
sig_fvs)  <- 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 NoExtField
XKindSig GhcRn
noExtField LHsType GhcRn
ty' LHsType GhcRn
k', FreeVars
lhs_fvs FreeVars -> FreeVars -> FreeVars
`plusFV` FreeVars
sig_fvs) }

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

rnHsTyKi RnTyKiEnv
env sumTy :: HsType GhcPs
sumTy@(HsSumTy XSumTy GhcPs
_ HsContext GhcPs
tys)
  = do { Bool
data_kinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
data_kinds Bool -> Bool -> Bool
&& RnTyKiEnv -> Bool
isRnKindLevel RnTyKiEnv
env)
              (MsgDoc -> TcRn ()
addErr (RnTyKiEnv -> HsType GhcPs -> MsgDoc
dataKindsErr RnTyKiEnv
env HsType GhcPs
sumTy))
       ; ([LHsType GhcRn]
tys', FreeVars
fvs) <- (LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars))
-> HsContext 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) HsContext 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 NoExtField
XSumTy GhcRn
noExtField [LHsType GhcRn]
tys', FreeVars
fvs) }

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

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

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

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

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

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

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

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

rnHsTyKi RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsExplicitListTy XExplicitListTy GhcPs
_ PromotionFlag
ip HsContext GhcPs
tys)
  = do { RnTyKiEnv -> HsType GhcPs -> TcRn ()
forall ty. Outputable ty => RnTyKiEnv -> ty -> TcRn ()
checkPolyKinds RnTyKiEnv
env HsType GhcPs
ty
       ; Bool
data_kinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
data_kinds (MsgDoc -> TcRn ()
addErr (RnTyKiEnv -> HsType GhcPs -> MsgDoc
dataKindsErr RnTyKiEnv
env HsType GhcPs
ty))
       ; ([LHsType GhcRn]
tys', FreeVars
fvs) <- (LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars))
-> HsContext 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) HsContext 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 NoExtField
XExplicitListTy GhcRn
noExtField PromotionFlag
ip [LHsType GhcRn]
tys', FreeVars
fvs) }

rnHsTyKi RnTyKiEnv
env ty :: HsType GhcPs
ty@(HsExplicitTupleTy XExplicitTupleTy GhcPs
_ HsContext GhcPs
tys)
  = do { RnTyKiEnv -> HsType GhcPs -> TcRn ()
forall ty. Outputable ty => RnTyKiEnv -> ty -> TcRn ()
checkPolyKinds RnTyKiEnv
env HsType GhcPs
ty
       ; Bool
data_kinds <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.DataKinds
       ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
data_kinds (MsgDoc -> TcRn ()
addErr (RnTyKiEnv -> HsType GhcPs -> MsgDoc
dataKindsErr RnTyKiEnv
env HsType GhcPs
ty))
       ; ([LHsType GhcRn]
tys', FreeVars
fvs) <- (LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars))
-> HsContext 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) HsContext 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 NoExtField
XExplicitTupleTy GhcRn
noExtField [LHsType GhcRn]
tys', FreeVars
fvs) }

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

rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)
rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars)
rnHsArrow RnTyKiEnv
_env (HsUnrestrictedArrow IsUnicodeSyntax
u) = (HsArrow GhcRn, FreeVars) -> RnM (HsArrow GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (IsUnicodeSyntax -> HsArrow GhcRn
forall pass. IsUnicodeSyntax -> HsArrow pass
HsUnrestrictedArrow IsUnicodeSyntax
u, FreeVars
emptyFVs)
rnHsArrow RnTyKiEnv
_env (HsLinearArrow IsUnicodeSyntax
u) = (HsArrow GhcRn, FreeVars) -> RnM (HsArrow GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (IsUnicodeSyntax -> HsArrow GhcRn
forall pass. IsUnicodeSyntax -> HsArrow pass
HsLinearArrow IsUnicodeSyntax
u, FreeVars
emptyFVs)
rnHsArrow RnTyKiEnv
env (HsExplicitMult IsUnicodeSyntax
u LHsType GhcPs
p)
  = (\(LHsType GhcRn
mult, FreeVars
fvs) -> (IsUnicodeSyntax -> LHsType GhcRn -> HsArrow GhcRn
forall pass. IsUnicodeSyntax -> LHsType pass -> HsArrow pass
HsExplicitMult IsUnicodeSyntax
u LHsType GhcRn
mult, FreeVars
fvs)) ((LHsType GhcRn, FreeVars) -> (HsArrow GhcRn, FreeVars))
-> RnM (LHsType GhcRn, FreeVars) -> RnM (HsArrow GhcRn, FreeVars)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
p

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

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

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

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

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

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

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

checkNamedWildCard :: RnTyKiEnv -> Name -> RnM ()
-- Report an error if a named wildcard is illegal here
checkNamedWildCard :: RnTyKiEnv -> Name -> TcRn ()
checkNamedWildCard RnTyKiEnv
env Name
name
  = RnTyKiEnv -> Maybe MsgDoc -> TcRn ()
checkWildCard RnTyKiEnv
env Maybe MsgDoc
mb_bad
  where
    mb_bad :: Maybe MsgDoc
mb_bad | Bool -> Bool
not (Name
name Name -> FreeVars -> Bool
`elemNameSet` RnTyKiEnv -> FreeVars
rtke_nwcs RnTyKiEnv
env)
           = Maybe MsgDoc
forall a. Maybe a
Nothing  -- Not a wildcard
           | Bool -> Bool
not (RnTyKiEnv -> Bool
wildCardsAllowed RnTyKiEnv
env)
           = MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just (MsgDoc -> MsgDoc
notAllowed (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name))
           | Bool
otherwise
           = case RnTyKiEnv -> RnTyKiWhat
rtke_what RnTyKiEnv
env of
               RnTyKiWhat
RnTypeBody      -> Maybe MsgDoc
forall a. Maybe a
Nothing   -- Allowed
               RnTyKiWhat
RnTopConstraint -> Maybe MsgDoc
forall a. Maybe a
Nothing   -- Allowed; e.g.
                  -- f :: (Eq _a) => _a -> Int
                  -- g :: (_a, _b) => T _a _b -> Int
                  -- The named tyvars get filled in from elsewhere
               RnTyKiWhat
RnConstraint    -> MsgDoc -> Maybe MsgDoc
forall a. a -> Maybe a
Just MsgDoc
constraint_msg
    constraint_msg :: MsgDoc
constraint_msg = MsgDoc -> MsgDoc
notAllowed (Name -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr Name
name) MsgDoc -> MsgDoc -> MsgDoc
<+> String -> MsgDoc
text String
"in a constraint"

wildCardsAllowed :: RnTyKiEnv -> Bool
-- ^ In what contexts are wildcards permitted
wildCardsAllowed :: RnTyKiEnv -> Bool
wildCardsAllowed RnTyKiEnv
env
   = case RnTyKiEnv -> HsDocContext
rtke_ctxt RnTyKiEnv
env of
       TypeSigCtx {}       -> Bool
True
       TypBrCtx {}         -> Bool
True   -- Template Haskell quoted type
       SpliceTypeCtx {}    -> Bool
True   -- Result of a Template Haskell splice
       ExprWithTySigCtx {} -> Bool
True
       PatCtx {}           -> Bool
True
       RuleCtx {}          -> Bool
True
       FamPatCtx {}        -> Bool
True   -- Not named wildcards though
       GHCiCtx {}          -> Bool
True
       HsTypeCtx {}        -> Bool
True
       StandaloneKindSigCtx {} -> Bool
False  -- See Note [Wildcards in standalone kind signatures] in "GHC.Hs.Decls"
       HsDocContext
_                   -> Bool
False



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

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

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

bindSigTyVarsFV :: [Name]
                -> RnM (a, FreeVars)
                -> RnM (a, FreeVars)
-- Used just before renaming the defn of a function
-- with a separate type signature, to bring its tyvars into scope
-- With no -XScopedTypeVariables, this is a no-op
bindSigTyVarsFV :: forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindSigTyVarsFV [Name]
tvs RnM (a, FreeVars)
thing_inside
  = do  { Bool
scoped_tyvars <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.ScopedTypeVariables
        ; if Bool -> Bool
not Bool
scoped_tyvars then
                RnM (a, FreeVars)
thing_inside
          else
                [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name]
tvs RnM (a, FreeVars)
thing_inside }

---------------
bindHsQTyVars :: forall a b.
                 HsDocContext
              -> Maybe a            -- Just _  => an associated type decl
              -> FreeKiTyVars       -- Kind variables from scope
              -> 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 GHC.Hs.Decls
              -> 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 :: forall a b.
HsDocContext
-> Maybe a
-> FreeKiTyVars
-> LHsQTyVars GhcPs
-> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindHsQTyVars HsDocContext
doc Maybe a
mb_assoc FreeKiTyVars
body_kv_occs LHsQTyVars GhcPs
hsq_bndrs LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars)
thing_inside
  = do { let bndr_kv_occs :: FreeKiTyVars
bndr_kv_occs = [LHsTyVarBndr () GhcPs] -> FreeKiTyVars
forall flag. [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
extractHsTyVarBndrsKVs [LHsTyVarBndr () GhcPs]
hs_tv_bndrs

       ; let -- See Note [bindHsQTyVars examples] for what
             -- all these various things are doing
             bndrs, implicit_kvs :: [Located RdrName]
             bndrs :: FreeKiTyVars
bndrs        = (LHsTyVarBndr () GhcPs -> GenLocated SrcSpan RdrName)
-> [LHsTyVarBndr () GhcPs] -> FreeKiTyVars
forall a b. (a -> b) -> [a] -> [b]
map LHsTyVarBndr () GhcPs -> GenLocated SrcSpan RdrName
forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> Located (IdP (GhcPass p))
hsLTyVarLocName [LHsTyVarBndr () GhcPs]
hs_tv_bndrs
             implicit_kvs :: FreeKiTyVars
implicit_kvs = FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
filterFreeVarsToBind FreeKiTyVars
bndrs (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
               FreeKiTyVars
bndr_kv_occs FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
forall a. [a] -> [a] -> [a]
++ FreeKiTyVars
body_kv_occs
             body_remaining :: FreeKiTyVars
body_remaining = FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
filterFreeVarsToBind FreeKiTyVars
bndr_kv_occs (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
              FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
filterFreeVarsToBind FreeKiTyVars
bndrs FreeKiTyVars
body_kv_occs
             all_bound_on_lhs :: Bool
all_bound_on_lhs = FreeKiTyVars -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FreeKiTyVars
body_remaining

       ; String -> MsgDoc -> TcRn ()
traceRn String
"checkMixedVars3" (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
           [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"bndrs"   MsgDoc -> MsgDoc -> MsgDoc
<+> [LHsTyVarBndr () GhcPs] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [LHsTyVarBndr () GhcPs]
hs_tv_bndrs
                , String -> MsgDoc
text String
"bndr_kv_occs"   MsgDoc -> MsgDoc -> MsgDoc
<+> FreeKiTyVars -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr FreeKiTyVars
bndr_kv_occs
                , String -> MsgDoc
text String
"body_kv_occs"   MsgDoc -> MsgDoc -> MsgDoc
<+> FreeKiTyVars -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr FreeKiTyVars
body_kv_occs
                , String -> MsgDoc
text String
"implicit_kvs"   MsgDoc -> MsgDoc -> MsgDoc
<+> FreeKiTyVars -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr FreeKiTyVars
implicit_kvs
                , String -> MsgDoc
text String
"body_remaining" MsgDoc -> MsgDoc -> MsgDoc
<+> FreeKiTyVars -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr FreeKiTyVars
body_remaining
                ]

       ; Maybe a
-> FreeKiTyVars
-> ([Name] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
forall assoc a.
Maybe assoc
-> FreeKiTyVars
-> ([Name] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
rnImplicitBndrs Maybe a
mb_assoc FreeKiTyVars
implicit_kvs (([Name] -> RnM (b, FreeVars)) -> RnM (b, FreeVars))
-> ([Name] -> RnM (b, FreeVars)) -> RnM (b, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [Name]
implicit_kv_nms' ->
         HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr () GhcPs]
-> ([LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
forall flag a b.
OutputableBndrFlag flag =>
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs HsDocContext
doc WarnUnusedForalls
NoWarnUnusedForalls Maybe a
mb_assoc [LHsTyVarBndr () GhcPs]
hs_tv_bndrs (([LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars))
 -> RnM (b, FreeVars))
-> ([LHsTyVarBndr () GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [LHsTyVarBndr () GhcRn]
rn_bndrs ->
           -- This is the only call site for bindLHsTyVarBndrs where we pass
           -- NoWarnUnusedForalls, which suppresses -Wunused-foralls warnings.
           -- See Note [Suppress -Wunused-foralls when binding LHsQTyVars].
    do { let -- The SrcSpan that rnImplicitBndrs will attach to each Name will
             -- span the entire declaration to which the LHsQTyVars belongs,
             -- which will be reflected in warning and error messages. We can
             -- be a little more precise than that by pointing to the location
             -- of the LHsQTyVars instead, which is what bndrs_loc
             -- corresponds to.
             implicit_kv_nms :: [Name]
implicit_kv_nms = (Name -> Name) -> [Name] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> SrcSpan -> Name
`setNameLoc` SrcSpan
bndrs_loc) [Name]
implicit_kv_nms'

       ; String -> MsgDoc -> TcRn ()
traceRn String
"bindHsQTyVars" (LHsQTyVars GhcPs -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsQTyVars GhcPs
hsq_bndrs MsgDoc -> MsgDoc -> MsgDoc
$$ [Name] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [Name]
implicit_kv_nms MsgDoc -> MsgDoc -> MsgDoc
$$ [LHsTyVarBndr () GhcRn] -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr [LHsTyVarBndr () GhcRn]
rn_bndrs)
       ; LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars)
thing_inside (HsQTvs :: forall pass.
XHsQTvs pass -> [LHsTyVarBndr () pass] -> LHsQTyVars pass
HsQTvs { hsq_ext :: XHsQTvs GhcRn
hsq_ext = [Name]
XHsQTvs GhcRn
implicit_kv_nms
                              , hsq_explicit :: [LHsTyVarBndr () GhcRn]
hsq_explicit  = [LHsTyVarBndr () GhcRn]
rn_bndrs })
                      Bool
all_bound_on_lhs } }
  where
    hs_tv_bndrs :: [LHsTyVarBndr () GhcPs]
hs_tv_bndrs = LHsQTyVars GhcPs -> [LHsTyVarBndr () GhcPs]
forall pass. LHsQTyVars pass -> [LHsTyVarBndr () pass]
hsQTvExplicit LHsQTyVars GhcPs
hsq_bndrs

    -- The SrcSpan of the LHsQTyVars. For example, bndrs_loc would be the
    -- highlighted part in the class below:
    --
    --   class C (a :: j) (b :: k) where
    --            ^^^^^^^^^^^^^^^
    bndrs_loc :: SrcSpan
bndrs_loc = case (LHsTyVarBndr () GhcPs -> SrcSpan)
-> [LHsTyVarBndr () GhcPs] -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map LHsTyVarBndr () GhcPs -> SrcSpan
forall l e. GenLocated l e -> l
getLoc [LHsTyVarBndr () GhcPs]
hs_tv_bndrs [SrcSpan] -> [SrcSpan] -> [SrcSpan]
forall a. [a] -> [a] -> [a]
++ (GenLocated SrcSpan RdrName -> SrcSpan)
-> FreeKiTyVars -> [SrcSpan]
forall a b. (a -> b) -> [a] -> [b]
map GenLocated SrcSpan RdrName -> SrcSpan
forall l e. GenLocated l e -> l
getLoc FreeKiTyVars
body_kv_occs of
      []         -> String -> SrcSpan
forall a. String -> a
panic String
"bindHsQTyVars.bndrs_loc"
      [SrcSpan
loc]      -> SrcSpan
loc
      (SrcSpan
loc:[SrcSpan]
locs) -> SrcSpan
loc SrcSpan -> SrcSpan -> SrcSpan
`combineSrcSpans` [SrcSpan] -> SrcSpan
forall a. [a] -> a
last [SrcSpan]
locs

{- 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,k1], 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

* If body_kv_occs 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.

* bndr_kv_occs, body_kv_occs, and implicit_kvs can contain duplicates. All
  duplicate occurrences are removed when we bind them with rnImplicitBndrs.

Finally, you may wonder why filterFreeVarsToBind 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'.

Note [Suppress -Wunused-foralls when binding LHsQTyVars]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The WarnUnusedForalls flag controls whether bindLHsTyVarBndrs should warn about
explicit type variable binders that go unused (e.g., the `a` in
`forall a. Int`). We almost always want to warn about these, since unused type
variables can usually be deleted without any repercussions. There is one
exception to this rule, however: binding LHsQTyVars. Consider this example:

  data Proxy a = Proxy

The `a` in `Proxy a` is bound by an LHsQTyVars, and the code which brings it
into scope, bindHsQTyVars, will invoke bindLHsTyVarBndrs in turn. As such, it
has a choice to make about whether to emit -Wunused-foralls warnings or not.
If it /did/ emit warnings, then the `a` would be flagged as unused. However,
this is not what we want! Removing the `a` in `Proxy a` would change its kind
entirely, which is a huge price to pay for fixing a warning.

Unlike other forms of type variable binders, dropping "unused" variables in
an LHsQTyVars can be semantically significant. As a result, we suppress
-Wunused-foralls warnings in exactly one place: in bindHsQTyVars.
-}

bindHsForAllTelescope :: HsDocContext
                      -> HsForAllTelescope GhcPs
                      -> (HsForAllTelescope GhcRn -> RnM (a, FreeVars))
                      -> RnM (a, FreeVars)
bindHsForAllTelescope :: forall a.
HsDocContext
-> HsForAllTelescope GhcPs
-> (HsForAllTelescope GhcRn -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
bindHsForAllTelescope HsDocContext
doc HsForAllTelescope GhcPs
tele HsForAllTelescope GhcRn -> RnM (a, FreeVars)
thing_inside =
  case HsForAllTelescope GhcPs
tele of
    HsForAllVis { hsf_vis_bndrs :: forall pass. HsForAllTelescope pass -> [LHsTyVarBndr () pass]
hsf_vis_bndrs = [LHsTyVarBndr () GhcPs]
bndrs } ->
      HsDocContext
-> WarnUnusedForalls
-> Maybe Any
-> [LHsTyVarBndr () GhcPs]
-> ([LHsTyVarBndr () GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall flag a b.
OutputableBndrFlag flag =>
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs HsDocContext
doc WarnUnusedForalls
WarnUnusedForalls Maybe Any
forall a. Maybe a
Nothing [LHsTyVarBndr () GhcPs]
bndrs (([LHsTyVarBndr () GhcRn] -> RnM (a, FreeVars))
 -> RnM (a, FreeVars))
-> ([LHsTyVarBndr () GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ \[LHsTyVarBndr () GhcRn]
bndrs' ->
        HsForAllTelescope GhcRn -> RnM (a, FreeVars)
thing_inside (HsForAllTelescope GhcRn -> RnM (a, FreeVars))
-> HsForAllTelescope GhcRn -> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ [LHsTyVarBndr () GhcRn] -> HsForAllTelescope GhcRn
forall (p :: Pass).
[LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p)
mkHsForAllVisTele [LHsTyVarBndr () GhcRn]
bndrs'
    HsForAllInvis { hsf_invis_bndrs :: forall pass.
HsForAllTelescope pass -> [LHsTyVarBndr Specificity pass]
hsf_invis_bndrs = [LHsTyVarBndr Specificity GhcPs]
bndrs } ->
      HsDocContext
-> WarnUnusedForalls
-> Maybe Any
-> [LHsTyVarBndr Specificity GhcPs]
-> ([LHsTyVarBndr Specificity GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall flag a b.
OutputableBndrFlag flag =>
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs HsDocContext
doc WarnUnusedForalls
WarnUnusedForalls Maybe Any
forall a. Maybe a
Nothing [LHsTyVarBndr Specificity GhcPs]
bndrs (([LHsTyVarBndr Specificity GhcRn] -> RnM (a, FreeVars))
 -> RnM (a, FreeVars))
-> ([LHsTyVarBndr Specificity GhcRn] -> RnM (a, FreeVars))
-> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ \[LHsTyVarBndr Specificity GhcRn]
bndrs' ->
        HsForAllTelescope GhcRn -> RnM (a, FreeVars)
thing_inside (HsForAllTelescope GhcRn -> RnM (a, FreeVars))
-> HsForAllTelescope GhcRn -> RnM (a, FreeVars)
forall a b. (a -> b) -> a -> b
$ [LHsTyVarBndr Specificity GhcRn] -> HsForAllTelescope GhcRn
forall (p :: Pass).
[LHsTyVarBndr Specificity (GhcPass p)]
-> HsForAllTelescope (GhcPass p)
mkHsForAllInvisTele [LHsTyVarBndr Specificity GhcRn]
bndrs'

-- | Should GHC warn if a quantified type variable goes unused? Usually, the
-- answer is \"yes\", but in the particular case of binding 'LHsQTyVars', we
-- avoid emitting warnings.
-- See @Note [Suppress -Wunused-foralls when binding LHsQTyVars]@.
data WarnUnusedForalls
  = WarnUnusedForalls
  | NoWarnUnusedForalls

instance Outputable WarnUnusedForalls where
  ppr :: WarnUnusedForalls -> MsgDoc
ppr WarnUnusedForalls
wuf = String -> MsgDoc
text (String -> MsgDoc) -> String -> MsgDoc
forall a b. (a -> b) -> a -> b
$ case WarnUnusedForalls
wuf of
    WarnUnusedForalls
WarnUnusedForalls   -> String
"WarnUnusedForalls"
    WarnUnusedForalls
NoWarnUnusedForalls -> String
"NoWarnUnusedForalls"

bindLHsTyVarBndrs :: (OutputableBndrFlag flag)
                  => HsDocContext
                  -> WarnUnusedForalls
                  -> Maybe a               -- Just _  => an associated type decl
                  -> [LHsTyVarBndr flag GhcPs]  -- User-written tyvars
                  -> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
                  -> RnM (b, FreeVars)
bindLHsTyVarBndrs :: forall flag a b.
OutputableBndrFlag flag =>
HsDocContext
-> WarnUnusedForalls
-> Maybe a
-> [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndrs HsDocContext
doc WarnUnusedForalls
wuf Maybe a
mb_assoc [LHsTyVarBndr flag GhcPs]
tv_bndrs [LHsTyVarBndr flag 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) (FreeKiTyVars -> TcRn ()
checkShadowedRdrNames FreeKiTyVars
tv_names_w_loc)
       ; FreeKiTyVars -> TcRn ()
checkDupRdrNames FreeKiTyVars
tv_names_w_loc
       ; [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
go [LHsTyVarBndr flag GhcPs]
tv_bndrs [LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars)
thing_inside }
  where
    tv_names_w_loc :: FreeKiTyVars
tv_names_w_loc = (LHsTyVarBndr flag GhcPs -> GenLocated SrcSpan RdrName)
-> [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
forall a b. (a -> b) -> [a] -> [b]
map LHsTyVarBndr flag GhcPs -> GenLocated SrcSpan RdrName
forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> Located (IdP (GhcPass p))
hsLTyVarLocName [LHsTyVarBndr flag GhcPs]
tv_bndrs

    go :: [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
go []     [LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars)
thing_inside = [LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars)
thing_inside []
    go (LHsTyVarBndr flag GhcPs
b:[LHsTyVarBndr flag GhcPs]
bs) [LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars)
thing_inside = HsDocContext
-> Maybe a
-> LHsTyVarBndr flag GhcPs
-> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
forall a flag b.
HsDocContext
-> Maybe a
-> LHsTyVarBndr flag GhcPs
-> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndr HsDocContext
doc Maybe a
mb_assoc LHsTyVarBndr flag GhcPs
b ((LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars))
 -> RnM (b, FreeVars))
-> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ LHsTyVarBndr flag GhcRn
b' ->
                             do { (b
res, FreeVars
fvs) <- [LHsTyVarBndr flag GhcPs]
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
go [LHsTyVarBndr flag GhcPs]
bs (([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
 -> RnM (b, FreeVars))
-> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
forall a b. (a -> b) -> a -> b
$ \ [LHsTyVarBndr flag GhcRn]
bs' ->
                                                [LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars)
thing_inside (LHsTyVarBndr flag GhcRn
b' LHsTyVarBndr flag GhcRn
-> [LHsTyVarBndr flag GhcRn] -> [LHsTyVarBndr flag GhcRn]
forall a. a -> [a] -> [a]
: [LHsTyVarBndr flag GhcRn]
bs')
                                ; LHsTyVarBndr flag GhcRn -> FreeVars -> TcRn ()
warn_unused LHsTyVarBndr flag 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 flag GhcRn -> FreeVars -> TcRn ()
warn_unused LHsTyVarBndr flag GhcRn
tv_bndr FreeVars
fvs = case WarnUnusedForalls
wuf of
      WarnUnusedForalls
WarnUnusedForalls   -> HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcRn ()
forall flag.
OutputableBndrFlag flag =>
HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcRn ()
warnUnusedForAll HsDocContext
doc LHsTyVarBndr flag GhcRn
tv_bndr FreeVars
fvs
      WarnUnusedForalls
NoWarnUnusedForalls -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

bindLHsTyVarBndr :: HsDocContext
                 -> Maybe a   -- associated class
                 -> LHsTyVarBndr flag GhcPs
                 -> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars))
                 -> RnM (b, FreeVars)
bindLHsTyVarBndr :: forall a flag b.
HsDocContext
-> Maybe a
-> LHsTyVarBndr flag GhcPs
-> (LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars))
-> RnM (b, FreeVars)
bindLHsTyVarBndr HsDocContext
_doc Maybe a
mb_assoc (L SrcSpan
loc
                                 (UserTyVar XUserTyVar GhcPs
x flag
fl
                                    lrdr :: GenLocated SrcSpan (IdP GhcPs)
lrdr@(L SrcSpan
lv IdP GhcPs
_))) LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars)
thing_inside
  = do { Name
nm <- Maybe a
-> GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a.
Maybe a
-> GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newTyVarNameRn Maybe a
mb_assoc GenLocated SrcSpan RdrName
GenLocated SrcSpan (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 flag GhcRn -> RnM (b, FreeVars)
thing_inside (SrcSpan -> HsTyVarBndr flag GhcRn -> LHsTyVarBndr flag GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XUserTyVar GhcRn
-> flag -> Located (IdP GhcRn) -> HsTyVarBndr flag GhcRn
forall flag pass.
XUserTyVar pass
-> flag -> Located (IdP pass) -> HsTyVarBndr flag pass
UserTyVar XUserTyVar GhcPs
XUserTyVar GhcRn
x flag
fl (SrcSpan -> Name -> GenLocated SrcSpan Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
lv Name
nm))) }

bindLHsTyVarBndr HsDocContext
doc Maybe a
mb_assoc (L SrcSpan
loc (KindedTyVar XKindedTyVar GhcPs
x flag
fl lrdr :: GenLocated SrcSpan (IdP GhcPs)
lrdr@(L SrcSpan
lv IdP GhcPs
_) LHsType GhcPs
kind))
                 LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars)
thing_inside
  = do { Bool
sig_ok <- Extension -> TcRnIf TcGblEnv TcLclEnv Bool
forall gbl lcl. Extension -> TcRnIf gbl lcl Bool
xoptM Extension
LangExt.KindSignatures
           ; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
sig_ok (HsDocContext -> LHsType GhcPs -> TcRn ()
badKindSigErr HsDocContext
doc LHsType GhcPs
kind)
           ; (LHsType GhcRn
kind', FreeVars
fvs1) <- HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsKind HsDocContext
doc LHsType GhcPs
kind
           ; Name
tv_nm  <- Maybe a
-> GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
forall a.
Maybe a
-> GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newTyVarNameRn Maybe a
mb_assoc GenLocated SrcSpan RdrName
GenLocated SrcSpan (IdP GhcPs)
lrdr
           ; (b
b, FreeVars
fvs2) <- [Name] -> RnM (b, FreeVars) -> RnM (b, FreeVars)
forall a. [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)
bindLocalNamesFV [Name
tv_nm]
               (RnM (b, FreeVars) -> RnM (b, FreeVars))
-> RnM (b, FreeVars) -> RnM (b, FreeVars)
forall a b. (a -> b) -> a -> b
$ LHsTyVarBndr flag GhcRn -> RnM (b, FreeVars)
thing_inside (SrcSpan -> HsTyVarBndr flag GhcRn -> LHsTyVarBndr flag GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XKindedTyVar GhcRn
-> flag
-> Located (IdP GhcRn)
-> LHsType GhcRn
-> HsTyVarBndr flag GhcRn
forall flag pass.
XKindedTyVar pass
-> flag
-> Located (IdP pass)
-> LHsKind pass
-> HsTyVarBndr flag pass
KindedTyVar XKindedTyVar GhcPs
XKindedTyVar GhcRn
x flag
fl (SrcSpan -> Name -> GenLocated SrcSpan Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
lv 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) }

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

           (Maybe a, Maybe Name)
_                -> GenLocated SrcSpan RdrName -> IOEnv (Env TcGblEnv TcLclEnv) Name
newLocalBndrRn GenLocated SrcSpan RdrName
lrdr }
{-
*********************************************************
*                                                       *
        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
GHC.Rename.Names.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 GHC.Rename.Module
-- No wildcards can appear in record fields
rnConDeclFields :: HsDocContext
-> [FieldLabel]
-> [LConDeclField GhcPs]
-> RnM ([LConDeclField GhcRn], FreeVars)
rnConDeclFields HsDocContext
ctxt [FieldLabel]
fls [LConDeclField GhcPs]
fields
   = (LConDeclField GhcPs -> RnM (LConDeclField GhcRn, FreeVars))
-> [LConDeclField GhcPs] -> RnM ([LConDeclField GhcRn], FreeVars)
forall a b. (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)
mapFvRn (FastStringEnv FieldLabel
-> RnTyKiEnv
-> LConDeclField GhcPs
-> RnM (LConDeclField GhcRn, FreeVars)
rnField FastStringEnv FieldLabel
fl_env RnTyKiEnv
env) [LConDeclField GhcPs]
fields
  where
    env :: RnTyKiEnv
env    = HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv
mkTyKiEnv HsDocContext
ctxt TypeOrKind
TypeLevel RnTyKiWhat
RnTypeBody
    fl_env :: FastStringEnv FieldLabel
fl_env = [(FastString, FieldLabel)] -> FastStringEnv FieldLabel
forall a. [(FastString, a)] -> FastStringEnv a
mkFsEnv [ (FieldLabel -> FastString
forall a. FieldLbl a -> FastString
flLabel FieldLabel
fl, FieldLabel
fl) | FieldLabel
fl <- [FieldLabel]
fls ]

rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs
        -> RnM (LConDeclField GhcRn, FreeVars)
rnField :: FastStringEnv FieldLabel
-> RnTyKiEnv
-> LConDeclField GhcPs
-> RnM (LConDeclField GhcRn, FreeVars)
rnField FastStringEnv FieldLabel
fl_env RnTyKiEnv
env (L SrcSpan
l (ConDeclField XConDeclField GhcPs
_ [LFieldOcc GhcPs]
names LHsType GhcPs
ty Maybe LHsDocString
haddock_doc))
  = do { let new_names :: [GenLocated SrcSpan (FieldOcc GhcRn)]
new_names = (LFieldOcc GhcPs -> GenLocated SrcSpan (FieldOcc GhcRn))
-> [LFieldOcc GhcPs] -> [GenLocated SrcSpan (FieldOcc GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map ((FieldOcc GhcPs -> FieldOcc GhcRn)
-> LFieldOcc GhcPs -> GenLocated SrcSpan (FieldOcc GhcRn)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FieldOcc GhcPs -> FieldOcc GhcRn
lookupField) [LFieldOcc GhcPs]
names
       ; (LHsType GhcRn
new_ty, FreeVars
fvs) <- RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)
rnLHsTyKi RnTyKiEnv
env LHsType GhcPs
ty
       ; Maybe LHsDocString
new_haddock_doc <- Maybe LHsDocString -> RnM (Maybe LHsDocString)
rnMbLHsDoc Maybe LHsDocString
haddock_doc
       ; (LConDeclField GhcRn, FreeVars)
-> RnM (LConDeclField GhcRn, FreeVars)
forall (m :: * -> *) a. Monad m => a -> m a
return (SrcSpan -> ConDeclField GhcRn -> LConDeclField GhcRn
forall l e. l -> e -> GenLocated l e
L 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 NoExtField
XConDeclField GhcRn
noExtField [GenLocated SrcSpan (FieldOcc GhcRn)]
new_names LHsType GhcRn
new_ty Maybe LHsDocString
new_haddock_doc)
                , FreeVars
fvs) }
  where
    lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn
    lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn
lookupField (FieldOcc XCFieldOcc GhcPs
_ (L SrcSpan
lr RdrName
rdr)) =
        XCFieldOcc GhcRn -> GenLocated SrcSpan RdrName -> FieldOcc GhcRn
forall pass.
XCFieldOcc pass -> GenLocated SrcSpan RdrName -> FieldOcc pass
FieldOcc (FieldLabel -> Name
forall a. FieldLbl a -> a
flSelector FieldLabel
fl) (SrcSpan -> RdrName -> GenLocated SrcSpan RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
lr RdrName
rdr)
      where
        lbl :: FastString
lbl = OccName -> FastString
occNameFS (OccName -> FastString) -> OccName -> FastString
forall a b. (a -> b) -> a -> b
$ RdrName -> OccName
rdrNameOcc RdrName
rdr
        fl :: FieldLabel
fl  = String -> Maybe FieldLabel -> FieldLabel
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"rnField" (Maybe FieldLabel -> FieldLabel) -> Maybe FieldLabel -> FieldLabel
forall a b. (a -> b) -> a -> b
$ FastStringEnv FieldLabel -> FastString -> Maybe FieldLabel
forall a. FastStringEnv a -> FastString -> Maybe a
lookupFsEnv FastStringEnv FieldLabel
fl_env FastString
lbl

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

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

Furthermore, the second argument is guaranteed not to be another
operator application.  Why? Because the parser parses all
operator applications left-associatively, EXCEPT negation, which
we need to handle specially.
Infix types are read in a *right-associative* way, so that
        a `op` b `op` c
is always read in as
        a `op` (b `op` c)

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

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

mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> Name
-> Fixity
-> LHsType GhcRn
-> LHsType GhcRn
-> RnM (HsType GhcRn)
mkHsOpTyRn LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk1 Name
pp_op1 Fixity
fix1 LHsType GhcRn
ty1 (L SrcSpan
loc2 (HsOpTy XOpTy GhcRn
noExtField LHsType GhcRn
ty21 Located (IdP GhcRn)
op2 LHsType GhcRn
ty22))
  = do  { Fixity
fix2 <- GenLocated SrcSpan Name -> RnM Fixity
lookupTyFixityRn GenLocated SrcSpan 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
                      (\LHsType GhcRn
t1 LHsType GhcRn
t2 -> XOpTy GhcRn
-> LHsType GhcRn
-> Located (IdP GhcRn)
-> LHsType GhcRn
-> HsType GhcRn
forall pass.
XOpTy pass
-> LHsType pass
-> Located (IdP pass)
-> LHsType pass
-> HsType pass
HsOpTy XOpTy GhcRn
noExtField LHsType GhcRn
t1 Located (IdP GhcRn)
op2 LHsType GhcRn
t2)
                      (GenLocated SrcSpan Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan Name
Located (IdP GhcRn)
op2) Fixity
fix2 LHsType GhcRn
ty21 LHsType GhcRn
ty22 SrcSpan
loc2 }

mkHsOpTyRn LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk1 Name
pp_op1 Fixity
fix1 LHsType GhcRn
ty1 (L SrcSpan
loc2 (HsFunTy XFunTy GhcRn
_ HsArrow GhcRn
mult LHsType GhcRn
ty21 LHsType GhcRn
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
                LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
hs_fun_ty Name
funTyConName Fixity
funTyFixity LHsType GhcRn
ty21 LHsType GhcRn
ty22 SrcSpan
loc2
  where
    hs_fun_ty :: LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
hs_fun_ty LHsType GhcRn
a LHsType GhcRn
b = XFunTy GhcRn
-> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
forall pass.
XFunTy pass
-> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass
HsFunTy NoExtField
XFunTy GhcRn
noExtField HsArrow GhcRn
mult LHsType GhcRn
a LHsType GhcRn
b

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

---------------
mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
            -> Name -> Fixity -> LHsType GhcRn
            -> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
            -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> SrcSpan
            -> RnM (HsType GhcRn)
mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> Name
-> Fixity
-> LHsType GhcRn
-> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)
-> Name
-> Fixity
-> LHsType GhcRn
-> LHsType GhcRn
-> SrcSpan
-> RnM (HsType GhcRn)
mk_hs_op_ty LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk1 Name
op1 Fixity
fix1 LHsType GhcRn
ty1
            LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk2 Name
op2 Fixity
fix2 LHsType GhcRn
ty21 LHsType GhcRn
ty22 SrcSpan
loc2
  | Bool
nofix_error     = do { (OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr (Name -> OpName
NormalOp Name
op1,Fixity
fix1) (Name -> OpName
NormalOp Name
op2,Fixity
fix2)
                         ; HsType GhcRn -> RnM (HsType GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn
mk1 LHsType GhcRn
ty1 (SrcSpan -> HsType GhcRn -> LHsType GhcRn
forall l e. l -> e -> GenLocated l e
L 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 -> HsType GhcRn -> LHsType GhcRn
forall l e. l -> e -> GenLocated l e
L 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 (HsType GhcRn -> LHsType GhcRn
forall e. e -> Located e
noLoc HsType GhcRn
new_ty) LHsType GhcRn
ty22) }
  where
    (Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 Fixity
fix2


---------------------------
mkOpAppRn :: NegationHandling
          -> 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 :: NegationHandling
-> LHsExpr GhcRn
-> LHsExpr GhcRn
-> Fixity
-> LHsExpr GhcRn
-> RnM (HsExpr GhcRn)
mkOpAppRn NegationHandling
negation_handling e1 :: LHsExpr GhcRn
e1@(L SrcSpan
_ (OpApp XOpApp GhcRn
fix1 LHsExpr GhcRn
e11 LHsExpr GhcRn
op1 LHsExpr GhcRn
e12)) LHsExpr GhcRn
op2 Fixity
fix2 LHsExpr GhcRn
e2
  | Bool
nofix_error
  = do (OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr (LHsExpr GhcRn -> OpName
get_op LHsExpr GhcRn
op1,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 <- NegationHandling
-> LHsExpr GhcRn
-> LHsExpr GhcRn
-> Fixity
-> LHsExpr GhcRn
-> RnM (HsExpr GhcRn)
mkOpAppRn NegationHandling
negation_handling 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 -> HsExpr GhcRn -> LHsExpr GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc' HsExpr GhcRn
new_e))
  where
    loc' :: SrcSpan
loc'= LHsExpr GhcRn -> LHsExpr GhcRn -> SrcSpan
forall a b. Located a -> Located b -> SrcSpan
combineLocs LHsExpr GhcRn
e12 LHsExpr GhcRn
e2
    (Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
XOpApp GhcRn
fix1 Fixity
fix2

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

  | Bool
associate_right
  = do HsExpr GhcRn
new_e <- NegationHandling
-> LHsExpr GhcRn
-> LHsExpr GhcRn
-> Fixity
-> LHsExpr GhcRn
-> RnM (HsExpr GhcRn)
mkOpAppRn NegationHandling
ReassociateNegation 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 NoExtField
XNegApp GhcRn
noExtField (SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc' HsExpr GhcRn
new_e) SyntaxExpr GhcRn
neg_name)
  where
    loc' :: SrcSpan
loc' = LHsExpr GhcRn -> LHsExpr GhcRn -> SrcSpan
forall a b. Located a -> Located b -> SrcSpan
combineLocs LHsExpr GhcRn
neg_arg LHsExpr GhcRn
e2
    (Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
negateFixity Fixity
fix2

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

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

data NegationHandling = ReassociateNegation | KeepNegationIntact

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

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

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

get_op :: LHsExpr GhcRn -> OpName
-- An unbound name could be either HsVar or HsUnboundVar
-- See GHC.Rename.Expr.rnUnboundVar
get_op :: LHsExpr GhcRn -> OpName
get_op (L SrcSpan
_ (HsVar XVar GhcRn
_ Located (IdP GhcRn)
n))         = Name -> OpName
NormalOp (GenLocated SrcSpan Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan Name
Located (IdP GhcRn)
n)
get_op (L SrcSpan
_ (HsUnboundVar XUnboundVar GhcRn
_ OccName
uv)) = OccName -> OpName
UnboundOp OccName
uv
get_op (L SrcSpan
_ (HsRecFld XRecFld GhcRn
_ AmbiguousFieldOcc GhcRn
fld))    = AmbiguousFieldOcc GhcRn -> OpName
RecFldOp AmbiguousFieldOcc GhcRn
fld
get_op LHsExpr GhcRn
other                     = String -> MsgDoc -> OpName
forall a. HasCallStack => String -> MsgDoc -> a
pprPanic String
"get_op" (LHsExpr GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr LHsExpr GhcRn
other)

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

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

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

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

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

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

--      Default case
mkOpFormRn LHsCmdTop GhcRn
arg1 LHsExpr GhcRn
op Fixity
fix LHsCmdTop GhcRn
arg2                     -- Default case, no rearrangment
  = HsCmd GhcRn -> RnM (HsCmd GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (XCmdArrForm GhcRn
-> LHsExpr GhcRn
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop GhcRn]
-> HsCmd GhcRn
forall id.
XCmdArrForm id
-> LHsExpr id
-> LexicalFixity
-> Maybe Fixity
-> [LHsCmdTop id]
-> HsCmd id
HsCmdArrForm NoExtField
XCmdArrForm GhcRn
noExtField 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 :: GenLocated SrcSpan Name
-> Fixity -> LPat GhcRn -> LPat GhcRn -> RnM (Pat GhcRn)
mkConOpPatRn GenLocated SrcSpan Name
op2 Fixity
fix2 p1 :: LPat GhcRn
p1@(L SrcSpan
loc (ConPat NoExtField
XConPat GhcRn
NoExtField Located (ConLikeP GhcRn)
op1 (InfixCon LPat GhcRn
p11 LPat GhcRn
p12))) LPat GhcRn
p2
  = do  { Fixity
fix1 <- Name -> RnM Fixity
lookupFixityRn (GenLocated SrcSpan Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan Name
Located (ConLikeP GhcRn)
op1)
        ; let (Bool
nofix_error, Bool
associate_right) = Fixity -> Fixity -> (Bool, Bool)
compareFixity Fixity
fix1 Fixity
fix2

        ; if Bool
nofix_error then do
                { (OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr (Name -> OpName
NormalOp (GenLocated SrcSpan Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan Name
Located (ConLikeP GhcRn)
op1),Fixity
fix1)
                               (Name -> OpName
NormalOp (GenLocated SrcSpan Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan Name
op2),Fixity
fix2)
                ; Pat GhcRn -> RnM (Pat GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat GhcRn -> RnM (Pat GhcRn)) -> Pat GhcRn -> RnM (Pat GhcRn)
forall a b. (a -> b) -> a -> b
$ ConPat :: forall p.
XConPat p -> Located (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat
                    { pat_con_ext :: XConPat GhcRn
pat_con_ext = NoExtField
XConPat GhcRn
noExtField
                    , pat_con :: Located (ConLikeP GhcRn)
pat_con = GenLocated SrcSpan Name
Located (ConLikeP GhcRn)
op2
                    , pat_args :: HsConDetails (LPat GhcRn) (HsRecFields GhcRn (LPat GhcRn))
pat_args = GenLocated SrcSpan (Pat GhcRn)
-> GenLocated SrcSpan (Pat GhcRn)
-> HsConDetails
     (GenLocated SrcSpan (Pat GhcRn))
     (HsRecFields GhcRn (GenLocated SrcSpan (Pat GhcRn)))
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon GenLocated SrcSpan (Pat GhcRn)
LPat GhcRn
p1 GenLocated SrcSpan (Pat GhcRn)
LPat GhcRn
p2
                    }
                }

          else if Bool
associate_right then do
                { Pat GhcRn
new_p <- GenLocated SrcSpan Name
-> Fixity -> LPat GhcRn -> LPat GhcRn -> RnM (Pat GhcRn)
mkConOpPatRn GenLocated SrcSpan Name
op2 Fixity
fix2 LPat GhcRn
p12 LPat GhcRn
p2
                ; Pat GhcRn -> RnM (Pat GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat GhcRn -> RnM (Pat GhcRn)) -> Pat GhcRn -> RnM (Pat GhcRn)
forall a b. (a -> b) -> a -> b
$ ConPat :: forall p.
XConPat p -> Located (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat
                    { pat_con_ext :: XConPat GhcRn
pat_con_ext = NoExtField
XConPat GhcRn
noExtField
                    , pat_con :: Located (ConLikeP GhcRn)
pat_con = Located (ConLikeP GhcRn)
op1
                    , pat_args :: HsConDetails (LPat GhcRn) (HsRecFields GhcRn (LPat GhcRn))
pat_args = GenLocated SrcSpan (Pat GhcRn)
-> GenLocated SrcSpan (Pat GhcRn)
-> HsConDetails
     (GenLocated SrcSpan (Pat GhcRn))
     (HsRecFields GhcRn (GenLocated SrcSpan (Pat GhcRn)))
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon GenLocated SrcSpan (Pat GhcRn)
LPat GhcRn
p11 (SrcSpan -> Pat GhcRn -> GenLocated SrcSpan (Pat GhcRn)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc Pat GhcRn
new_p)
                    }
                }
                -- XXX loc right?
          else Pat GhcRn -> RnM (Pat GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat GhcRn -> RnM (Pat GhcRn)) -> Pat GhcRn -> RnM (Pat GhcRn)
forall a b. (a -> b) -> a -> b
$ ConPat :: forall p.
XConPat p -> Located (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat
                 { pat_con_ext :: XConPat GhcRn
pat_con_ext = NoExtField
XConPat GhcRn
noExtField
                 , pat_con :: Located (ConLikeP GhcRn)
pat_con = GenLocated SrcSpan Name
Located (ConLikeP GhcRn)
op2
                 , pat_args :: HsConDetails (LPat GhcRn) (HsRecFields GhcRn (LPat GhcRn))
pat_args = GenLocated SrcSpan (Pat GhcRn)
-> GenLocated SrcSpan (Pat GhcRn)
-> HsConDetails
     (GenLocated SrcSpan (Pat GhcRn))
     (HsRecFields GhcRn (GenLocated SrcSpan (Pat GhcRn)))
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon GenLocated SrcSpan (Pat GhcRn)
LPat GhcRn
p1 GenLocated SrcSpan (Pat GhcRn)
LPat GhcRn
p2
                 }
        }

mkConOpPatRn GenLocated SrcSpan Name
op Fixity
_ LPat GhcRn
p1 LPat GhcRn
p2                         -- Default case, no rearrangment
  = ASSERT( not_op_pat (unLoc p2) )
    Pat GhcRn -> RnM (Pat GhcRn)
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat GhcRn -> RnM (Pat GhcRn)) -> Pat GhcRn -> RnM (Pat GhcRn)
forall a b. (a -> b) -> a -> b
$ ConPat :: forall p.
XConPat p -> Located (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat
      { pat_con_ext :: XConPat GhcRn
pat_con_ext = NoExtField
XConPat GhcRn
noExtField
      , pat_con :: Located (ConLikeP GhcRn)
pat_con = GenLocated SrcSpan Name
Located (ConLikeP GhcRn)
op
      , pat_args :: HsConDetails (LPat GhcRn) (HsRecFields GhcRn (LPat GhcRn))
pat_args = GenLocated SrcSpan (Pat GhcRn)
-> GenLocated SrcSpan (Pat GhcRn)
-> HsConDetails
     (GenLocated SrcSpan (Pat GhcRn))
     (HsRecFields GhcRn (GenLocated SrcSpan (Pat GhcRn)))
forall arg rec. arg -> arg -> HsConDetails arg rec
InfixCon GenLocated SrcSpan (Pat GhcRn)
LPat GhcRn
p1 GenLocated SrcSpan (Pat GhcRn)
LPat GhcRn
p2
      }

not_op_pat :: Pat GhcRn -> Bool
not_op_pat :: Pat GhcRn -> Bool
not_op_pat (ConPat NoExtField
XConPat GhcRn
NoExtField Located (ConLikeP GhcRn)
_ (InfixCon LPat GhcRn
_ LPat GhcRn
_)) = Bool
False
not_op_pat Pat GhcRn
_                                    = Bool
True

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

checkPrecMatch :: forall body. Name -> MatchGroup GhcRn body -> TcRn ()
checkPrecMatch Name
op (MG { mg_alts :: forall p body. MatchGroup p body -> Located [LMatch p body]
mg_alts = (L SrcSpan
_ [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]
ms
  where
    check :: LMatch GhcRn body -> TcRn ()
check (L SrcSpan
_ (Match { m_pats :: forall p body. Match p body -> [LPat p]
m_pats = (L SrcSpan
l1 Pat GhcRn
p1)
                               : (L SrcSpan
l2 Pat GhcRn
p2)
                               : [LPat GhcRn]
_ }))
      = 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 -> Pat GhcRn -> Bool -> TcRn ()
checkPrec Name
op Pat GhcRn
p1 Bool
False
           Name -> Pat GhcRn -> Bool -> TcRn ()
checkPrec Name
op Pat GhcRn
p2 Bool
True

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

checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkPrec :: Name -> Pat GhcRn -> Bool -> TcRn ()
checkPrec Name
op (ConPat NoExtField
XConPat GhcRn
NoExtField Located (ConLikeP GhcRn)
op1 (InfixCon LPat GhcRn
_ LPat GhcRn
_)) Bool
right = do
    op_fix :: Fixity
op_fix@(Fixity SourceText
_ Int
op_prec  FixityDirection
op_dir) <- Name -> RnM Fixity
lookupFixityRn Name
op
    op1_fix :: Fixity
op1_fix@(Fixity SourceText
_ Int
op1_prec FixityDirection
op1_dir) <- Name -> RnM Fixity
lookupFixityRn (GenLocated SrcSpan Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan Name
Located (ConLikeP 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 (GenLocated SrcSpan Name -> Name
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan Name
Located (ConLikeP GhcRn)
op1), Fixity
op1_fix)
        ((OpName, Fixity)
infol, (OpName, Fixity)
infor) = if Bool
right then ((OpName, Fixity)
info, (OpName, Fixity)
info1) else ((OpName, Fixity)
info1, (OpName, Fixity)
info)
    Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
inf_ok ((OpName, Fixity) -> (OpName, Fixity) -> TcRn ()
precParseErr (OpName, Fixity)
infol (OpName, Fixity)
infor)

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

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

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


-- Precedence-related error messages

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

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

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

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


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

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

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

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

warnUnusedForAll :: OutputableBndrFlag flag
                 => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM ()
warnUnusedForAll :: forall flag.
OutputableBndrFlag flag =>
HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcRn ()
warnUnusedForAll HsDocContext
doc (L SrcSpan
loc HsTyVarBndr flag GhcRn
tv) FreeVars
used_names
  = WarningFlag -> TcRn () -> TcRn ()
forall gbl lcl.
WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()
whenWOptM WarningFlag
Opt_WarnUnusedForalls (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
    Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (HsTyVarBndr flag GhcRn -> IdP GhcRn
forall flag (p :: Pass).
HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)
hsTyVarName HsTyVarBndr flag GhcRn
tv Name -> FreeVars -> Bool
`elemNameSet` FreeVars
used_names) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
    WarnReason -> SrcSpan -> MsgDoc -> TcRn ()
addWarnAt (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnUnusedForalls) SrcSpan
loc (MsgDoc -> TcRn ()) -> MsgDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
    [MsgDoc] -> MsgDoc
vcat [ String -> MsgDoc
text String
"Unused quantified type variable" MsgDoc -> MsgDoc -> MsgDoc
<+> MsgDoc -> MsgDoc
quotes (HsTyVarBndr flag GhcRn -> MsgDoc
forall a. Outputable a => a -> MsgDoc
ppr HsTyVarBndr flag GhcRn
tv)
         , HsDocContext -> MsgDoc
inHsDocContext HsDocContext
doc ]

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

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


Note [Kind and type-variable binders]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In a type signature we may implicitly bind type/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'.

To do that, we need to walk over a type and find its free type/kind variables.
We preserve the left-to-right order of each variable occurrence.
See Note [Ordering of implicit variables].

It is common for lists of free type variables to contain duplicates. For
example, in `f :: a -> a`, the free type variable list is [a, a]. When these
implicitly bound variables are brought into scope (with rnImplicitBndrs),
duplicates are removed with nubL.

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 GHC.Core.Type.

Implicitly bound variables are collected by any function which returns a
FreeKiTyVars, which notably includes the `extract-` family of functions
(extractHsTysRdrTyVars, extractHsTyVarBndrsKVs, etc.).
These functions thus promise to keep left-to-right ordering.

Note [Implicit quantification in type synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We typically bind type/kind variables implicitly when they are in a kind
annotation on the LHS, for example:

  data Proxy (a :: k) = Proxy
  type KindOf (a :: k) = k

Here 'k' is in the kind annotation of a type variable binding, KindedTyVar, and
we want to implicitly quantify over it.  This is easy: just extract all free
variables from the kind signature. That's what we do in extract_hs_tv_bndrs_kvs

By contrast, on the RHS we can't simply collect *all* free variables. Which of
the following are allowed?

  type TySyn1 = a :: Type
  type TySyn2 = 'Nothing :: Maybe a
  type TySyn3 = 'Just ('Nothing :: Maybe a)
  type TySyn4 = 'Left a :: Either Type a

After some design deliberations (see non-taken alternatives below), the answer
is to reject TySyn1 and TySyn3, but allow TySyn2 and TySyn4, at least for now.
We implicitly quantify over free variables of the outermost kind signature, if
one exists:

  * In TySyn1, the outermost kind signature is (:: Type), and it does not have
    any free variables.
  * In TySyn2, the outermost kind signature is (:: Maybe a), it contains a
    free variable 'a', which we implicitly quantify over.
  * In TySyn3, there is no outermost kind signature. The (:: Maybe a) signature
    is hidden inside 'Just.
  * In TySyn4, the outermost kind signature is (:: Either Type a), it contains
    a free variable 'a', which we implicitly quantify over. That is why we can
    also use it to the left of the double colon: 'Left a

The logic resides in extractHsTyRdrTyVarsKindVars. We use it both for type
synonyms and type family instances.

This is something of a stopgap solution until we can explicitly bind invisible
type/kind variables:

  type TySyn3 :: forall a. Maybe a
  type TySyn3 @a = 'Just ('Nothing :: Maybe a)

Note [Implicit quantification in type synonyms: non-taken alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Alternative I: No quantification
--------------------------------
We could offer no implicit quantification on the RHS, accepting none of the
TySyn<N> examples. The user would have to bind the variables explicitly:

  type TySyn1 a = a :: Type
  type TySyn2 a = 'Nothing :: Maybe a
  type TySyn3 a = 'Just ('Nothing :: Maybe a)
  type TySyn4 a = 'Left a :: Either Type a

However, this would mean that one would have to specify 'a' at call sites every
time, which could be undesired.

Alternative II: Indiscriminate quantification
---------------------------------------------
We could implicitly quantify over all free variables on the RHS just like we do
on the LHS. Then we would infer the following kinds:

  TySyn1 :: forall {a}. Type
  TySyn2 :: forall {a}. Maybe a
  TySyn3 :: forall {a}. Maybe (Maybe a)
  TySyn4 :: forall {a}. Either Type a

This would work fine for TySyn<2,3,4>, but TySyn1 is clearly bogus: the variable
is free-floating, not fixed by anything.

Alternative III: reportFloatingKvs
----------------------------------
We could augment Alternative II by hunting down free-floating variables during
type checking. While viable, this would mean we'd end up accepting this:

  data Prox k (a :: k)
  type T = Prox k

-}

-- A list of free type/kind variables, which can contain duplicates.
-- 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].
type FreeKiTyVars = [Located RdrName]

-- | Filter out any type and kind variables that are already in scope in the
-- the supplied LocalRdrEnv. Note that this includes named wildcards, which
-- look like perfectly ordinary type variables at this point.
filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
filterInScope LocalRdrEnv
rdr_env = (GenLocated SrcSpan RdrName -> Bool)
-> FreeKiTyVars -> FreeKiTyVars
forall a. (a -> Bool) -> [a] -> [a]
filterOut (LocalRdrEnv -> RdrName -> Bool
inScope LocalRdrEnv
rdr_env (RdrName -> Bool)
-> (GenLocated SrcSpan RdrName -> RdrName)
-> GenLocated SrcSpan RdrName
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenLocated SrcSpan RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc)

-- | Filter out any type and kind variables that are already in scope in the
-- the environment's LocalRdrEnv. Note that this includes named wildcards,
-- which look like perfectly ordinary type variables at this point.
filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars
filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars
filterInScopeM FreeKiTyVars
vars
  = do { LocalRdrEnv
rdr_env <- RnM LocalRdrEnv
getLocalRdrEnv
       ; FreeKiTyVars -> RnM FreeKiTyVars
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars
filterInScope LocalRdrEnv
rdr_env FreeKiTyVars
vars) }

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

extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_tyarg (HsValArg LHsType GhcPs
ty) FreeKiTyVars
acc = LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty FreeKiTyVars
acc
extract_tyarg (HsTypeArg SrcSpan
_ LHsType GhcPs
ki) FreeKiTyVars
acc = LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ki FreeKiTyVars
acc
extract_tyarg (HsArgPar SrcSpan
_) FreeKiTyVars
acc = FreeKiTyVars
acc

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

extractHsTyArgRdrKiTyVars :: [LHsTypeArg GhcPs] -> FreeKiTyVars
extractHsTyArgRdrKiTyVars :: [LHsTypeArg GhcPs] -> FreeKiTyVars
extractHsTyArgRdrKiTyVars [LHsTypeArg GhcPs]
args
  = [LHsTypeArg GhcPs] -> FreeKiTyVars -> FreeKiTyVars
extract_tyargs [LHsTypeArg GhcPs]
args []

-- | 'extractHsTyRdrTyVars' finds the type/kind variables
--                          of a HsType/HsKind.
-- It's used when making the @forall@s explicit.
-- See Note [Kind and type-variable binders]
extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVars LHsType GhcPs
ty = LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty []

extractHsScaledTysRdrTyVars :: [HsScaled GhcPs (LHsType GhcPs)] -> FreeKiTyVars -> FreeKiTyVars
extractHsScaledTysRdrTyVars :: [HsScaled GhcPs (LHsType GhcPs)] -> FreeKiTyVars -> FreeKiTyVars
extractHsScaledTysRdrTyVars [HsScaled GhcPs (LHsType GhcPs)]
args FreeKiTyVars
acc = (HsScaled GhcPs (LHsType GhcPs) -> FreeKiTyVars -> FreeKiTyVars)
-> FreeKiTyVars -> [HsScaled GhcPs (LHsType GhcPs)] -> FreeKiTyVars
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(HsScaled HsArrow GhcPs
m LHsType GhcPs
ty) -> LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty (FreeKiTyVars -> FreeKiTyVars)
-> (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HsArrow GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_hs_arrow HsArrow GhcPs
m) FreeKiTyVars
acc [HsScaled GhcPs (LHsType GhcPs)]
args

-- | Extracts the free type/kind variables from the kind signature of a HsType.
--   This is used to implicitly quantify over @k@ in @type T = Nothing :: Maybe k@.
-- The left-to-right order of variables is preserved.
-- See Note [Kind and type-variable binders] and
--     Note [Ordering of implicit variables] and
--     Note [Implicit quantification in type synonyms].
extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVarsKindVars (L SrcSpan
_ HsType GhcPs
ty) =
  case HsType GhcPs
ty of
    HsParTy XParTy GhcPs
_ LHsType GhcPs
ty -> LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVarsKindVars LHsType GhcPs
ty
    HsKindSig XKindSig GhcPs
_ LHsType GhcPs
_ LHsType GhcPs
ki -> LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVars LHsType GhcPs
ki
    HsType GhcPs
_ -> []

-- | 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.
extractHsTysRdrTyVars :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars
extractHsTysRdrTyVars :: HsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extractHsTysRdrTyVars HsContext GhcPs
tys = HsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_ltys HsContext GhcPs
tys

-- Returns the free kind variables of any explicitly-kinded binders, returning
-- variable occurrences in left-to-right order.
-- See Note [Ordering of implicit variables].
-- NB: Does /not/ delete the binders themselves.
--     E.g. given  [k1, a:k1, b:k2]
--          the function returns [k1,k2], even though k1 is bound here
extractHsTyVarBndrsKVs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
extractHsTyVarBndrsKVs :: forall flag. [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
extractHsTyVarBndrsKVs [LHsTyVarBndr flag GhcPs]
tv_bndrs = [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
forall flag. [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
extract_hs_tv_bndrs_kvs [LHsTyVarBndr flag GhcPs]
tv_bndrs

-- 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 -> FreeKiTyVars
extractRdrKindSigVars :: LFamilyResultSig GhcPs -> FreeKiTyVars
extractRdrKindSigVars (L SrcSpan
_ FamilyResultSig GhcPs
resultSig) = case FamilyResultSig GhcPs
resultSig of
  KindSig XCKindSig GhcPs
_ LHsType GhcPs
k                            -> LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVars LHsType GhcPs
k
  TyVarSig XTyVarSig GhcPs
_ (L SrcSpan
_ (KindedTyVar XKindedTyVar GhcPs
_ ()
_ GenLocated SrcSpan (IdP GhcPs)
_ LHsType GhcPs
k)) -> LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVars LHsType GhcPs
k
  FamilyResultSig GhcPs
_ -> []

-- | Get type/kind variables mentioned in the kind signature, preserving
-- left-to-right order:
--
--  * data T a (b :: k1) :: k2 -> k1 -> k2 -> Type   -- result: [k2,k1]
--  * data T a (b :: k1)                             -- result: []
--
-- See Note [Ordering of implicit variables].
extractDataDefnKindVars :: HsDataDefn GhcPs ->  FreeKiTyVars
extractDataDefnKindVars :: HsDataDefn GhcPs -> FreeKiTyVars
extractDataDefnKindVars (HsDataDefn { dd_kindSig :: forall pass. HsDataDefn pass -> Maybe (LHsKind pass)
dd_kindSig = Maybe (LHsType GhcPs)
ksig })
  = FreeKiTyVars
-> (LHsType GhcPs -> FreeKiTyVars)
-> Maybe (LHsType GhcPs)
-> FreeKiTyVars
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] LHsType GhcPs -> FreeKiTyVars
extractHsTyRdrTyVars Maybe (LHsType GhcPs)
ksig

extract_lctxt :: LHsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lctxt :: GenLocated SrcSpan (HsContext GhcPs)
-> FreeKiTyVars -> FreeKiTyVars
extract_lctxt GenLocated SrcSpan (HsContext GhcPs)
ctxt = HsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_ltys (GenLocated SrcSpan (HsContext GhcPs) -> HsContext GhcPs
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan (HsContext GhcPs)
ctxt)

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

extract_lty :: LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty :: LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty (L SrcSpan
_ HsType GhcPs
ty) FreeKiTyVars
acc
  = case HsType GhcPs
ty of
      HsTyVar XTyVar GhcPs
_ PromotionFlag
_  GenLocated SrcSpan (IdP GhcPs)
ltv            -> GenLocated SrcSpan RdrName -> FreeKiTyVars -> FreeKiTyVars
extract_tv GenLocated SrcSpan RdrName
GenLocated SrcSpan (IdP GhcPs)
ltv FreeKiTyVars
acc
      HsBangTy XBangTy GhcPs
_ HsSrcBang
_ LHsType GhcPs
ty             -> LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty FreeKiTyVars
acc
      HsRecTy XRecTy GhcPs
_ [LConDeclField GhcPs]
flds              -> (LConDeclField GhcPs -> FreeKiTyVars -> FreeKiTyVars)
-> FreeKiTyVars -> [LConDeclField GhcPs] -> FreeKiTyVars
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty
                                            (LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars)
-> (LConDeclField GhcPs -> LHsType GhcPs)
-> LConDeclField GhcPs
-> FreeKiTyVars
-> FreeKiTyVars
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 l e. GenLocated l e -> e
unLoc) FreeKiTyVars
acc
                                           [LConDeclField GhcPs]
flds
      HsAppTy XAppTy GhcPs
_ LHsType GhcPs
ty1 LHsType GhcPs
ty2           -> LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty1 (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
                                     LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty2 FreeKiTyVars
acc
      HsAppKindTy XAppKindTy GhcPs
_ LHsType GhcPs
ty LHsType GhcPs
k          -> LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
                                     LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
k FreeKiTyVars
acc
      HsListTy XListTy GhcPs
_ LHsType GhcPs
ty               -> LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty FreeKiTyVars
acc
      HsTupleTy XTupleTy GhcPs
_ HsTupleSort
_ HsContext GhcPs
tys           -> HsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_ltys HsContext GhcPs
tys FreeKiTyVars
acc
      HsSumTy XSumTy GhcPs
_ HsContext GhcPs
tys               -> HsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_ltys HsContext GhcPs
tys FreeKiTyVars
acc
      HsFunTy XFunTy GhcPs
_ HsArrow GhcPs
w LHsType GhcPs
ty1 LHsType GhcPs
ty2         -> LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty1 (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
                                     LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty2 (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
                                     HsArrow GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_hs_arrow HsArrow GhcPs
w FreeKiTyVars
acc
      HsIParamTy XIParamTy GhcPs
_ Located HsIPName
_ LHsType GhcPs
ty           -> LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty FreeKiTyVars
acc
      HsOpTy XOpTy GhcPs
_ LHsType GhcPs
ty1 GenLocated SrcSpan (IdP GhcPs)
tv LHsType GhcPs
ty2         -> GenLocated SrcSpan RdrName -> FreeKiTyVars -> FreeKiTyVars
extract_tv GenLocated SrcSpan RdrName
GenLocated SrcSpan (IdP GhcPs)
tv (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
                                     LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty1 (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
                                     LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty2 FreeKiTyVars
acc
      HsParTy XParTy GhcPs
_ LHsType GhcPs
ty                -> LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty FreeKiTyVars
acc
      HsSpliceTy {}               -> FreeKiTyVars
acc  -- Type splices mention no tvs
      HsDocTy XDocTy GhcPs
_ LHsType GhcPs
ty LHsDocString
_              -> LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty FreeKiTyVars
acc
      HsExplicitListTy XExplicitListTy GhcPs
_ PromotionFlag
_ HsContext GhcPs
tys    -> HsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_ltys HsContext GhcPs
tys FreeKiTyVars
acc
      HsExplicitTupleTy XExplicitTupleTy GhcPs
_ HsContext GhcPs
tys     -> HsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_ltys HsContext GhcPs
tys FreeKiTyVars
acc
      HsTyLit XTyLit GhcPs
_ HsTyLit
_                 -> FreeKiTyVars
acc
      HsStarTy XStarTy GhcPs
_ Bool
_                -> FreeKiTyVars
acc
      HsKindSig XKindSig GhcPs
_ LHsType GhcPs
ty LHsType GhcPs
ki           -> LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
                                     LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ki FreeKiTyVars
acc
      HsForAllTy { hst_tele :: forall pass. HsType pass -> HsForAllTelescope pass
hst_tele = HsForAllTelescope GhcPs
tele, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcPs
ty }
                                  -> HsForAllTelescope GhcPs
-> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
extract_hs_for_all_telescope HsForAllTelescope GhcPs
tele FreeKiTyVars
acc (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
                                     LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty []
      HsQualTy { hst_ctxt :: forall pass. HsType pass -> LHsContext pass
hst_ctxt = GenLocated SrcSpan (HsContext GhcPs)
ctxt, hst_body :: forall pass. HsType pass -> LHsType pass
hst_body = LHsType GhcPs
ty }
                                  -> GenLocated SrcSpan (HsContext GhcPs)
-> FreeKiTyVars -> FreeKiTyVars
extract_lctxt GenLocated SrcSpan (HsContext GhcPs)
ctxt (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$
                                     LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
ty FreeKiTyVars
acc
      XHsType {}                  -> FreeKiTyVars
acc
      -- We deal with these separately in rnLHsTypeWithWildCards
      HsWildCardTy {}             -> FreeKiTyVars
acc

extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars ->
                   FreeKiTyVars
extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_hs_arrow (HsExplicitMult IsUnicodeSyntax
_ LHsType GhcPs
p) FreeKiTyVars
acc = LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty LHsType GhcPs
p FreeKiTyVars
acc
extract_hs_arrow HsArrow GhcPs
_ FreeKiTyVars
acc = FreeKiTyVars
acc

extract_hs_for_all_telescope :: HsForAllTelescope GhcPs
                             -> FreeKiTyVars -- Accumulator
                             -> FreeKiTyVars -- Free in body
                             -> FreeKiTyVars
extract_hs_for_all_telescope :: HsForAllTelescope GhcPs
-> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
extract_hs_for_all_telescope HsForAllTelescope GhcPs
tele FreeKiTyVars
acc_vars FreeKiTyVars
body_fvs =
  case HsForAllTelescope GhcPs
tele of
    HsForAllVis { hsf_vis_bndrs :: forall pass. HsForAllTelescope pass -> [LHsTyVarBndr () pass]
hsf_vis_bndrs = [LHsTyVarBndr () GhcPs]
bndrs } ->
      [LHsTyVarBndr () GhcPs]
-> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
forall flag.
[LHsTyVarBndr flag GhcPs]
-> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
extract_hs_tv_bndrs [LHsTyVarBndr () GhcPs]
bndrs FreeKiTyVars
acc_vars FreeKiTyVars
body_fvs
    HsForAllInvis { hsf_invis_bndrs :: forall pass.
HsForAllTelescope pass -> [LHsTyVarBndr Specificity pass]
hsf_invis_bndrs = [LHsTyVarBndr Specificity GhcPs]
bndrs } ->
      [LHsTyVarBndr Specificity GhcPs]
-> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
forall flag.
[LHsTyVarBndr flag GhcPs]
-> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
extract_hs_tv_bndrs [LHsTyVarBndr Specificity GhcPs]
bndrs FreeKiTyVars
acc_vars FreeKiTyVars
body_fvs

extractHsTvBndrs :: [LHsTyVarBndr flag GhcPs]
                 -> FreeKiTyVars       -- Free in body
                 -> FreeKiTyVars       -- Free in result
extractHsTvBndrs :: forall flag.
[LHsTyVarBndr flag GhcPs] -> FreeKiTyVars -> FreeKiTyVars
extractHsTvBndrs [LHsTyVarBndr flag GhcPs]
tv_bndrs FreeKiTyVars
body_fvs
  = [LHsTyVarBndr flag GhcPs]
-> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
forall flag.
[LHsTyVarBndr flag GhcPs]
-> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
extract_hs_tv_bndrs [LHsTyVarBndr flag GhcPs]
tv_bndrs [] FreeKiTyVars
body_fvs

extract_hs_tv_bndrs :: [LHsTyVarBndr flag GhcPs]
                    -> FreeKiTyVars  -- Accumulator
                    -> FreeKiTyVars  -- Free in body
                    -> FreeKiTyVars
-- 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 :: forall flag.
[LHsTyVarBndr flag GhcPs]
-> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
extract_hs_tv_bndrs [LHsTyVarBndr flag GhcPs]
tv_bndrs FreeKiTyVars
acc_vars FreeKiTyVars
body_vars = FreeKiTyVars
new_vars FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
forall a. [a] -> [a] -> [a]
++ FreeKiTyVars
acc_vars
  where
    new_vars :: FreeKiTyVars
new_vars
      | [LHsTyVarBndr flag GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LHsTyVarBndr flag GhcPs]
tv_bndrs = FreeKiTyVars
body_vars
      | Bool
otherwise = FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
filterFreeVarsToBind FreeKiTyVars
tv_bndr_rdrs (FreeKiTyVars -> FreeKiTyVars) -> FreeKiTyVars -> FreeKiTyVars
forall a b. (a -> b) -> a -> b
$ FreeKiTyVars
bndr_vars FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
forall a. [a] -> [a] -> [a]
++ FreeKiTyVars
body_vars
    -- NB: delete all tv_bndr_rdrs from bndr_vars as well as body_vars.
    -- See Note [Kind variable scoping]
    bndr_vars :: FreeKiTyVars
bndr_vars = [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
forall flag. [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
extract_hs_tv_bndrs_kvs [LHsTyVarBndr flag GhcPs]
tv_bndrs
    tv_bndr_rdrs :: FreeKiTyVars
tv_bndr_rdrs = (LHsTyVarBndr flag GhcPs -> GenLocated SrcSpan RdrName)
-> [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
forall a b. (a -> b) -> [a] -> [b]
map LHsTyVarBndr flag GhcPs -> GenLocated SrcSpan RdrName
forall flag (p :: Pass).
LHsTyVarBndr flag (GhcPass p) -> Located (IdP (GhcPass p))
hsLTyVarLocName [LHsTyVarBndr flag GhcPs]
tv_bndrs

extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
-- Returns the free kind variables of any explicitly-kinded binders, returning
-- variable occurrences in left-to-right order.
-- See Note [Ordering of implicit variables].
-- NB: Does /not/ delete the binders themselves.
--     E.g. given  [k1, a:k1, b:k2]
--          the function returns [k1,k2], even though k1 is bound here
extract_hs_tv_bndrs_kvs :: forall flag. [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars
extract_hs_tv_bndrs_kvs [LHsTyVarBndr flag GhcPs]
tv_bndrs =
    (LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars)
-> FreeKiTyVars -> HsContext GhcPs -> FreeKiTyVars
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LHsType GhcPs -> FreeKiTyVars -> FreeKiTyVars
extract_lty []
          [LHsType GhcPs
k | L SrcSpan
_ (KindedTyVar XKindedTyVar GhcPs
_ flag
_ GenLocated SrcSpan (IdP GhcPs)
_ LHsType GhcPs
k) <- [LHsTyVarBndr flag GhcPs]
tv_bndrs]

extract_tv :: Located RdrName -> FreeKiTyVars -> FreeKiTyVars
extract_tv :: GenLocated SrcSpan RdrName -> FreeKiTyVars -> FreeKiTyVars
extract_tv GenLocated SrcSpan RdrName
tv FreeKiTyVars
acc =
  if RdrName -> Bool
isRdrTyVar (GenLocated SrcSpan RdrName -> RdrName
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan RdrName
tv) then GenLocated SrcSpan RdrName
tvGenLocated SrcSpan RdrName -> FreeKiTyVars -> FreeKiTyVars
forall a. a -> [a] -> [a]
:FreeKiTyVars
acc else FreeKiTyVars
acc

-- Deletes duplicates in a list of Located things. This is used to:
--
-- * Delete duplicate occurrences of implicitly bound type/kind variables when
--   bringing them into scope (in rnImplicitBndrs).
--
-- * Delete duplicate occurrences of named wildcards (in rn_hs_sig_wc_type and
--   rnHsWcType).
--
-- 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 :: forall a. Eq a => [Located a] -> [Located a]
nubL = (GenLocated SrcSpan a -> GenLocated SrcSpan a -> Bool)
-> [GenLocated SrcSpan a] -> [GenLocated SrcSpan a]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy GenLocated SrcSpan a -> GenLocated SrcSpan a -> Bool
forall a l. Eq a => GenLocated l a -> GenLocated l a -> Bool
eqLocated

-- | Filter out any potential implicit binders that are either
-- already in scope, or are explicitly bound in the binder.
filterFreeVarsToBind :: FreeKiTyVars
                     -- ^ Explicitly bound here
                     -> FreeKiTyVars
                     -- ^ Potential implicit binders
                     -> FreeKiTyVars
                     -- ^ Final implicit binders
filterFreeVarsToBind :: FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars
filterFreeVarsToBind FreeKiTyVars
bndrs = (GenLocated SrcSpan RdrName -> Bool)
-> FreeKiTyVars -> FreeKiTyVars
forall a. (a -> Bool) -> [a] -> [a]
filterOut GenLocated SrcSpan RdrName -> Bool
is_in_scope
    -- Make sure to list the binder kvs before the body kvs, as mandated by
    -- Note [Ordering of implicit variables]
  where
    is_in_scope :: GenLocated SrcSpan RdrName -> Bool
is_in_scope GenLocated SrcSpan RdrName
locc = (GenLocated SrcSpan RdrName -> Bool) -> FreeKiTyVars -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (GenLocated SrcSpan RdrName -> GenLocated SrcSpan RdrName -> Bool
forall a l. Eq a => GenLocated l a -> GenLocated l a -> Bool
eqLocated GenLocated SrcSpan RdrName
locc) FreeKiTyVars
bndrs