    {-
    (c) The University of Glasgow 2006
    (c) The GRASP/AQUA Project, Glasgow University, 1992-1999

    -}

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

    {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

    -- | Analysis functions over data types. Specifically, detecting recursive types.
    --
    -- This stuff is only used for source-code decls; it's recorded in interface
    -- files for imported data types.
    module GHC.Tc.TyCl.Utils(
            RolesInfo,
            inferRoles,
            checkSynCycles,
            checkClassCycles,

            -- * Implicits
            addTyConsToGblEnv, mkDefaultMethodType,

            -- * Record selectors
            tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector
        ) where

    #include "HsVersions.h"

    import GHC.Prelude

    import GHC.Tc.Utils.Monad
    import GHC.Tc.Utils.Env
    import GHC.Tc.Gen.Bind( tcValBinds )
    import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) )
    import GHC.Core.Multiplicity
    import GHC.Tc.Utils.TcType
    import GHC.Core.Predicate
    import GHC.Builtin.Types( unitTy )
    import GHC.Core.Make( rEC_SEL_ERROR_ID )
    import GHC.Hs
    import GHC.Core.Class
    import GHC.Core.Type
    import GHC.Driver.Types
    import GHC.Core.TyCon
    import GHC.Core.ConLike
    import GHC.Core.DataCon
    import GHC.Types.Name
    import GHC.Types.Name.Env
    import GHC.Types.Name.Set hiding (unitFV)
    import GHC.Types.Name.Reader ( mkVarUnqual )
    import GHC.Types.Id
    import GHC.Types.Id.Info
    import GHC.Types.Var.Env
    import GHC.Types.Var.Set
    import GHC.Core.Coercion ( ltRole )
    import GHC.Types.Basic
    import GHC.Types.SrcLoc
    import GHC.Types.Unique ( mkBuiltinUnique )
    import GHC.Utils.Outputable
    import GHC.Utils.Misc
    import GHC.Data.Maybe
    import GHC.Data.Bag
    import GHC.Data.FastString
    import GHC.Utils.FV as FV
    import GHC.Unit.Module
    import qualified GHC.LanguageExtensions as LangExt

    import Control.Monad

    {-
    ************************************************************************
    *                                                                      *
            Cycles in type synonym declarations
    *                                                                      *
    ************************************************************************
    -}

    synonymTyConsOfType :: Type -> [TyCon]
    -- Does not look through type synonyms at all
    -- Return a list of synonym tycons
    -- Keep this synchronized with 'expandTypeSynonyms'
    synonymTyConsOfType :: PredType -> [TyCon]
    synonymTyConsOfType PredType
    ty
      = NameEnv TyCon -> [TyCon]
    forall a. NameEnv a -> [a]
    nameEnvElts (PredType -> NameEnv TyCon
    go PredType
    ty)
      where
         go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim
         go :: PredType -> NameEnv TyCon
    go (TyConApp TyCon
    tc [PredType]
    tys) = TyCon -> NameEnv TyCon
    go_tc TyCon
    tc NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
    forall a. NameEnv a -> NameEnv a -> NameEnv a
    `plusNameEnv` [PredType] -> NameEnv TyCon
    forall {t :: * -> *}. Foldable t => t PredType -> NameEnv TyCon
    go_s [PredType]
    tys
         go (LitTy TyLit
    _)         = NameEnv TyCon
    forall a. NameEnv a
    emptyNameEnv
         go (TyVarTy Id
    _)       = NameEnv TyCon
    forall a. NameEnv a
    emptyNameEnv
         go (AppTy PredType
    a PredType
    b)       = PredType -> NameEnv TyCon
    go PredType
    a NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
    forall a. NameEnv a -> NameEnv a -> NameEnv a
    `plusNameEnv` PredType -> NameEnv TyCon
    go PredType
    b
         go (FunTy AnonArgFlag
    _ PredType
    w PredType
    a PredType
    b)   = PredType -> NameEnv TyCon
    go PredType
    w NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
    forall a. NameEnv a -> NameEnv a -> NameEnv a
    `plusNameEnv` PredType -> NameEnv TyCon
    go PredType
    a NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
    forall a. NameEnv a -> NameEnv a -> NameEnv a
    `plusNameEnv` PredType -> NameEnv TyCon
    go PredType
    b
         go (ForAllTy TyCoVarBinder
    _ PredType
    ty)   = PredType -> NameEnv TyCon
    go PredType
    ty
         go (CastTy PredType
    ty KindCoercion
    co)    = PredType -> NameEnv TyCon
    go PredType
    ty NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
    forall a. NameEnv a -> NameEnv a -> NameEnv a
    `plusNameEnv` KindCoercion -> NameEnv TyCon
    go_co KindCoercion
    co
         go (CoercionTy KindCoercion
    co)   = KindCoercion -> NameEnv TyCon
    go_co KindCoercion
    co

         -- Note [TyCon cycles through coercions?!]
         -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         -- Although, in principle, it's possible for a type synonym loop
         -- could go through a coercion (since a coercion can refer to
         -- a TyCon or Type), it doesn't seem possible to actually construct
         -- a Haskell program which tickles this case.  Here is an example
         -- program which causes a coercion:
         --
         --   type family Star where
         --       Star = Type
         --
         --   data T :: Star -> Type
         --   data S :: forall (a :: Type). T a -> Type
         --
         -- Here, the application 'T a' must first coerce a :: Type to a :: Star,
         -- witnessed by the type family.  But if we now try to make Type refer
         -- to a type synonym which in turn refers to Star, we'll run into
         -- trouble: we're trying to define and use the type constructor
         -- in the same recursive group.  Possibly this restriction will be
         -- lifted in the future but for now, this code is "just for completeness
         -- sake".
         go_mco :: MCoercionN -> NameEnv TyCon
    go_mco MCoercionN
    MRefl    = NameEnv TyCon
    forall a. NameEnv a
    emptyNameEnv
         go_mco (MCo KindCoercion
    co) = KindCoercion -> NameEnv TyCon
    go_co KindCoercion
    co

         go_co :: KindCoercion -> NameEnv TyCon
    go_co (Refl PredType
    ty)              = PredType -> NameEnv TyCon
    go PredType
    ty
         go_co (GRefl Role
    _ PredType
    ty MCoercionN
    mco)       = PredType -> NameEnv TyCon
    go PredType
    ty NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
    forall a. NameEnv a -> NameEnv a -> NameEnv a
    `plusNameEnv` MCoercionN -> NameEnv TyCon
    go_mco MCoercionN
    mco
         go_co (TyConAppCo Role
    _ TyCon
    tc [KindCoercion]
    cs)   = TyCon -> NameEnv TyCon
    go_tc TyCon
    tc NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
    forall a. NameEnv a -> NameEnv a -> NameEnv a
    `plusNameEnv` [KindCoercion] -> NameEnv TyCon
    go_co_s [KindCoercion]
    cs
         go_co (AppCo KindCoercion
    co KindCoercion
    co')         = KindCoercion -> NameEnv TyCon
    go_co KindCoercion
    co NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
    forall a. NameEnv a -> NameEnv a -> NameEnv a
    `plusNameEnv` KindCoercion -> NameEnv TyCon
    go_co KindCoercion
    co'
         go_co (ForAllCo Id
    _ KindCoercion
    co KindCoercion
    co')    = KindCoercion -> NameEnv TyCon
    go_co KindCoercion
    co NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
    forall a. NameEnv a -> NameEnv a -> NameEnv a
    `plusNameEnv` KindCoercion -> NameEnv TyCon
    go_co KindCoercion
    co'
         go_co (FunCo Role
    _ KindCoercion
    co_mult KindCoercion
    co KindCoercion
    co') = KindCoercion -> NameEnv TyCon
    go_co KindCoercion
    co_mult NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
    forall a. NameEnv a -> NameEnv a -> NameEnv a
    `plusNameEnv` KindCoercion -> NameEnv TyCon
    go_co KindCoercion
    co NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
    forall a. NameEnv a -> NameEnv a -> NameEnv a
    `plusNameEnv` KindCoercion -> NameEnv TyCon
    go_co KindCoercion
    co'
         go_co (CoVarCo Id
    _)            = NameEnv TyCon
    forall a. NameEnv a
    emptyNameEnv
         go_co (HoleCo {})            = NameEnv TyCon
    forall a. NameEnv a
    emptyNameEnv
         go_co (AxiomInstCo CoAxiom Branched
    _ Int
    _ [KindCoercion]
    cs)   = [KindCoercion] -> NameEnv TyCon
    go_co_s [KindCoercion]
    cs
         go_co (UnivCo UnivCoProvenance
    p Role
    _ PredType
    ty PredType
    ty')    = UnivCoProvenance -> NameEnv TyCon
    go_prov UnivCoProvenance
    p NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
    forall a. NameEnv a -> NameEnv a -> NameEnv a
    `plusNameEnv` PredType -> NameEnv TyCon
    go PredType
    ty NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
    forall a. NameEnv a -> NameEnv a -> NameEnv a
    `plusNameEnv` PredType -> NameEnv TyCon
    go PredType
    ty'
         go_co (SymCo KindCoercion
    co)             = KindCoercion -> NameEnv TyCon
    go_co KindCoercion
    co
         go_co (TransCo KindCoercion
    co KindCoercion
    co')       = KindCoercion -> NameEnv TyCon
    go_co KindCoercion
    co NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
    forall a. NameEnv a -> NameEnv a -> NameEnv a
    `plusNameEnv` KindCoercion -> NameEnv TyCon
    go_co KindCoercion
    co'
         go_co (NthCo Role
    _ Int
    _ KindCoercion
    co)         = KindCoercion -> NameEnv TyCon
    go_co KindCoercion
    co
         go_co (LRCo LeftOrRight
    _ KindCoercion
    co)            = KindCoercion -> NameEnv TyCon
    go_co KindCoercion
    co
         go_co (InstCo KindCoercion
    co KindCoercion
    co')        = KindCoercion -> NameEnv TyCon
    go_co KindCoercion
    co NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
    forall a. NameEnv a -> NameEnv a -> NameEnv a
    `plusNameEnv` KindCoercion -> NameEnv TyCon
    go_co KindCoercion
    co'
         go_co (KindCo KindCoercion
    co)            = KindCoercion -> NameEnv TyCon
    go_co KindCoercion
    co
         go_co (SubCo KindCoercion
    co)             = KindCoercion -> NameEnv TyCon
    go_co KindCoercion
    co
         go_co (AxiomRuleCo CoAxiomRule
    _ [KindCoercion]
    cs)     = [KindCoercion] -> NameEnv TyCon
    go_co_s [KindCoercion]
    cs

         go_prov :: UnivCoProvenance -> NameEnv TyCon
    go_prov (PhantomProv KindCoercion
    co)     = KindCoercion -> NameEnv TyCon
    go_co KindCoercion
    co
         go_prov (ProofIrrelProv KindCoercion
    co)  = KindCoercion -> NameEnv TyCon
    go_co KindCoercion
    co
         go_prov (PluginProv String
    _)       = NameEnv TyCon
    forall a. NameEnv a
    emptyNameEnv
         go_prov UnivCoProvenance
    CorePrepProv         = NameEnv TyCon
    forall a. NameEnv a
    emptyNameEnv

         go_tc :: TyCon -> NameEnv TyCon
    go_tc TyCon
    tc | TyCon -> Bool
    isTypeSynonymTyCon TyCon
    tc = Name -> TyCon -> NameEnv TyCon
    forall a. Name -> a -> NameEnv a
    unitNameEnv (TyCon -> Name
    tyConName TyCon
    tc) TyCon
    tc
                  | Bool
    otherwise             = NameEnv TyCon
    forall a. NameEnv a
    emptyNameEnv
         go_s :: t PredType -> NameEnv TyCon
    go_s t PredType
    tys = (PredType -> NameEnv TyCon -> NameEnv TyCon)
    -> NameEnv TyCon -> t PredType -> NameEnv TyCon
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
    forall a. NameEnv a -> NameEnv a -> NameEnv a
    plusNameEnv (NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon)
    -> (PredType -> NameEnv TyCon)
    -> PredType
    -> NameEnv TyCon
    -> NameEnv TyCon
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . PredType -> NameEnv TyCon
    go) NameEnv TyCon
    forall a. NameEnv a
    emptyNameEnv t PredType
    tys
         go_co_s :: [KindCoercion] -> NameEnv TyCon
    go_co_s [KindCoercion]
    cos = (KindCoercion -> NameEnv TyCon -> NameEnv TyCon)
    -> NameEnv TyCon -> [KindCoercion] -> NameEnv TyCon
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
    forall a. NameEnv a -> NameEnv a -> NameEnv a
    plusNameEnv (NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon)
    -> (KindCoercion -> NameEnv TyCon)
    -> KindCoercion
    -> NameEnv TyCon
    -> NameEnv TyCon
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . KindCoercion -> NameEnv TyCon
    go_co) NameEnv TyCon
    forall a. NameEnv a
    emptyNameEnv [KindCoercion]
    cos

    -- | A monad for type synonym cycle checking, which keeps
    -- track of the TyCons which are known to be acyclic, or
    -- a failure message reporting that a cycle was found.
    newtype SynCycleM a = SynCycleM {
        forall a.
    SynCycleM a
    -> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
    runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) }
        deriving ((forall a b. (a -> b) -> SynCycleM a -> SynCycleM b)
    -> (forall a b. a -> SynCycleM b -> SynCycleM a)
    -> Functor SynCycleM
    forall a b. a -> SynCycleM b -> SynCycleM a
    forall a b. (a -> b) -> SynCycleM a -> SynCycleM b
    forall (f :: * -> *).
    (forall a b. (a -> b) -> f a -> f b)
    -> (forall a b. a -> f b -> f a) -> Functor f
    <$ :: forall a b. a -> SynCycleM b -> SynCycleM a
    $c<$ :: forall a b. a -> SynCycleM b -> SynCycleM a
    fmap :: forall a b. (a -> b) -> SynCycleM a -> SynCycleM b
    $cfmap :: forall a b. (a -> b) -> SynCycleM a -> SynCycleM b
    Functor)

    type SynCycleState = NameSet

    instance Applicative SynCycleM where
        pure :: forall a. a -> SynCycleM a
    pure a
    x = (SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
    -> SynCycleM a
    forall a.
    (SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
    -> SynCycleM a
    SynCycleM ((SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
     -> SynCycleM a)
    -> (SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
    -> SynCycleM a
    forall a b. (a -> b) -> a -> b
    $ \SynCycleState
    state -> (a, SynCycleState) -> Either (SrcSpan, SDoc) (a, SynCycleState)
    forall a b. b -> Either a b
    Right (a
    x, SynCycleState
    state)
        <*> :: forall a b. SynCycleM (a -> b) -> SynCycleM a -> SynCycleM b
    (<*>) = SynCycleM (a -> b) -> SynCycleM a -> SynCycleM b
    forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
    ap

    instance Monad SynCycleM where
        SynCycleM a
    m >>= :: forall a b. SynCycleM a -> (a -> SynCycleM b) -> SynCycleM b
    >>= a -> SynCycleM b
    f = (SynCycleState -> Either (SrcSpan, SDoc) (b, SynCycleState))
    -> SynCycleM b
    forall a.
    (SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
    -> SynCycleM a
    SynCycleM ((SynCycleState -> Either (SrcSpan, SDoc) (b, SynCycleState))
     -> SynCycleM b)
    -> (SynCycleState -> Either (SrcSpan, SDoc) (b, SynCycleState))
    -> SynCycleM b
    forall a b. (a -> b) -> a -> b
    $ \SynCycleState
    state ->
            case SynCycleM a
    -> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
    forall a.
    SynCycleM a
    -> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
    runSynCycleM SynCycleM a
    m SynCycleState
    state of
                Right (a
    x, SynCycleState
    state') ->
                    SynCycleM b
    -> SynCycleState -> Either (SrcSpan, SDoc) (b, SynCycleState)
    forall a.
    SynCycleM a
    -> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
    runSynCycleM (a -> SynCycleM b
    f a
    x) SynCycleState
    state'
                Left (SrcSpan, SDoc)
    err -> (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) (b, SynCycleState)
    forall a b. a -> Either a b
    Left (SrcSpan, SDoc)
    err

    failSynCycleM :: SrcSpan -> SDoc -> SynCycleM ()
    failSynCycleM :: SrcSpan -> SDoc -> SynCycleM ()
    failSynCycleM SrcSpan
    loc SDoc
    err = (SynCycleState -> Either (SrcSpan, SDoc) ((), SynCycleState))
    -> SynCycleM ()
    forall a.
    (SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
    -> SynCycleM a
    SynCycleM ((SynCycleState -> Either (SrcSpan, SDoc) ((), SynCycleState))
     -> SynCycleM ())
    -> (SynCycleState -> Either (SrcSpan, SDoc) ((), SynCycleState))
    -> SynCycleM ()
    forall a b. (a -> b) -> a -> b
    $ \SynCycleState
    _ -> (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) ((), SynCycleState)
    forall a b. a -> Either a b
    Left (SrcSpan
    loc, SDoc
    err)

    -- | Test if a 'Name' is acyclic, short-circuiting if we've
    -- seen it already.
    checkNameIsAcyclic :: Name -> SynCycleM () -> SynCycleM ()
    checkNameIsAcyclic :: Name -> SynCycleM () -> SynCycleM ()
    checkNameIsAcyclic Name
    n SynCycleM ()
    m = (SynCycleState -> Either (SrcSpan, SDoc) ((), SynCycleState))
    -> SynCycleM ()
    forall a.
    (SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
    -> SynCycleM a
    SynCycleM ((SynCycleState -> Either (SrcSpan, SDoc) ((), SynCycleState))
     -> SynCycleM ())
    -> (SynCycleState -> Either (SrcSpan, SDoc) ((), SynCycleState))
    -> SynCycleM ()
    forall a b. (a -> b) -> a -> b
    $ \SynCycleState
    s ->
        if Name
    n Name -> SynCycleState -> Bool
    `elemNameSet` SynCycleState
    s
            then ((), SynCycleState) -> Either (SrcSpan, SDoc) ((), SynCycleState)
    forall a b. b -> Either a b
    Right ((), SynCycleState
    s) -- short circuit
            else case SynCycleM ()
    -> SynCycleState -> Either (SrcSpan, SDoc) ((), SynCycleState)
    forall a.
    SynCycleM a
    -> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
    runSynCycleM SynCycleM ()
    m SynCycleState
    s of
                    Right ((), SynCycleState
    s') -> ((), SynCycleState) -> Either (SrcSpan, SDoc) ((), SynCycleState)
    forall a b. b -> Either a b
    Right ((), SynCycleState -> Name -> SynCycleState
    extendNameSet SynCycleState
    s' Name
    n)
                    Left (SrcSpan, SDoc)
    err -> (SrcSpan, SDoc) -> Either (SrcSpan, SDoc) ((), SynCycleState)
    forall a b. a -> Either a b
    Left (SrcSpan, SDoc)
    err

    -- | Checks if any of the passed in 'TyCon's have cycles.
    -- Takes the 'Unit' of the home package (as we can avoid
    -- checking those TyCons: cycles never go through foreign packages) and
    -- the corresponding @LTyClDecl Name@ for each 'TyCon', so we
    -- can give better error messages.
    checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM ()
    checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM ()
    checkSynCycles Unit
    this_uid [TyCon]
    tcs [LTyClDecl GhcRn]
    tyclds = do
        case SynCycleM ()
    -> SynCycleState -> Either (SrcSpan, SDoc) ((), SynCycleState)
    forall a.
    SynCycleM a
    -> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
    runSynCycleM ((TyCon -> SynCycleM ()) -> [TyCon] -> SynCycleM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (SynCycleState -> [TyCon] -> TyCon -> SynCycleM ()
    go SynCycleState
    emptyNameSet []) [TyCon]
    tcs) SynCycleState
    emptyNameSet of
            Left (SrcSpan
    loc, SDoc
    err) -> SrcSpan -> TcM () -> TcM ()
    forall a. SrcSpan -> TcRn a -> TcRn a
    setSrcSpan SrcSpan
    loc (TcM () -> TcM ()) -> TcM () -> TcM ()
    forall a b. (a -> b) -> a -> b
    $ SDoc -> TcM ()
    forall a. SDoc -> TcM a
    failWithTc SDoc
    err
            Right ((), SynCycleState)
    _  -> () -> TcM ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
      where
        -- Try our best to print the LTyClDecl for locally defined things
        lcl_decls :: NameEnv (LTyClDecl GhcRn)
    lcl_decls = [(Name, LTyClDecl GhcRn)] -> NameEnv (LTyClDecl GhcRn)
    forall a. [(Name, a)] -> NameEnv a
    mkNameEnv ([Name] -> [LTyClDecl GhcRn] -> [(Name, LTyClDecl GhcRn)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip ((TyCon -> Name) -> [TyCon] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map TyCon -> Name
    tyConName [TyCon]
    tcs) [LTyClDecl GhcRn]
    tyclds)

        -- Short circuit if we've already seen this Name and concluded
        -- it was acyclic.
        go :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()
        go :: SynCycleState -> [TyCon] -> TyCon -> SynCycleM ()
    go SynCycleState
    so_far [TyCon]
    seen_tcs TyCon
    tc =
            Name -> SynCycleM () -> SynCycleM ()
    checkNameIsAcyclic (TyCon -> Name
    tyConName TyCon
    tc) (SynCycleM () -> SynCycleM ()) -> SynCycleM () -> SynCycleM ()
    forall a b. (a -> b) -> a -> b
    $ SynCycleState -> [TyCon] -> TyCon -> SynCycleM ()
    go' SynCycleState
    so_far [TyCon]
    seen_tcs TyCon
    tc

        -- Expand type synonyms, complaining if you find the same
        -- type synonym a second time.
        go' :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()
        go' :: SynCycleState -> [TyCon] -> TyCon -> SynCycleM ()
    go' SynCycleState
    so_far [TyCon]
    seen_tcs TyCon
    tc
            | Name
    n Name -> SynCycleState -> Bool
    `elemNameSet` SynCycleState
    so_far
                = SrcSpan -> SDoc -> SynCycleM ()
    failSynCycleM (TyCon -> SrcSpan
    forall a. NamedThing a => a -> SrcSpan
    getSrcSpan ([TyCon] -> TyCon
    forall a. [a] -> a
    head [TyCon]
    seen_tcs)) (SDoc -> SynCycleM ()) -> SDoc -> SynCycleM ()
    forall a b. (a -> b) -> a -> b
    $
                      [SDoc] -> SDoc
    sep [ String -> SDoc
    text String
    "Cycle in type synonym declarations:"
                          , Int -> SDoc -> SDoc
    nest Int
    2 ([SDoc] -> SDoc
    vcat ((TyCon -> SDoc) -> [TyCon] -> [SDoc]
    forall a b. (a -> b) -> [a] -> [b]
    map TyCon -> SDoc
    ppr_decl [TyCon]
    seen_tcs)) ]
            -- Optimization: we don't allow cycles through external packages,
            -- so once we find a non-local name we are guaranteed to not
            -- have a cycle.
            --
            -- This won't hold once we get recursive packages with Backpack,
            -- but for now it's fine.
            | Bool -> Bool
    not (GenModule Unit -> Bool
    forall u. GenModule (GenUnit u) -> Bool
    isHoleModule GenModule Unit
    mod Bool -> Bool -> Bool
    ||
                   GenModule Unit -> Unit
    forall unit. GenModule unit -> unit
    moduleUnit GenModule Unit
    mod Unit -> Unit -> Bool
    forall a. Eq a => a -> a -> Bool
    == Unit
    this_uid Bool -> Bool -> Bool
    ||
                   GenModule Unit -> Bool
    isInteractiveModule GenModule Unit
    mod)
                = () -> SynCycleM ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
            | Just PredType
    ty <- TyCon -> Maybe PredType
    synTyConRhs_maybe TyCon
    tc =
                SynCycleState -> [TyCon] -> PredType -> SynCycleM ()
    go_ty (SynCycleState -> Name -> SynCycleState
    extendNameSet SynCycleState
    so_far (TyCon -> Name
    tyConName TyCon
    tc)) (TyCon
    tcTyCon -> [TyCon] -> [TyCon]
    forall a. a -> [a] -> [a]
    :[TyCon]
    seen_tcs) PredType
    ty
            | Bool
    otherwise = () -> SynCycleM ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
          where
            n :: Name
    n = TyCon -> Name
    tyConName TyCon
    tc
            mod :: GenModule Unit
    mod = HasDebugCallStack => Name -> GenModule Unit
    Name -> GenModule Unit
    nameModule Name
    n
            ppr_decl :: TyCon -> SDoc
    ppr_decl TyCon
    tc =
              case NameEnv (LTyClDecl GhcRn) -> Name -> Maybe (LTyClDecl GhcRn)
    forall a. NameEnv a -> Name -> Maybe a
    lookupNameEnv NameEnv (LTyClDecl GhcRn)
    lcl_decls Name
    n of
                Just (L SrcSpan
    loc TyClDecl GhcRn
    decl) -> SrcSpan -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr SrcSpan
    loc SDoc -> SDoc -> SDoc
    <> SDoc
    colon SDoc -> SDoc -> SDoc
    <+> TyClDecl GhcRn -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyClDecl GhcRn
    decl
                Maybe (LTyClDecl GhcRn)
    Nothing -> SrcSpan -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr (Name -> SrcSpan
    forall a. NamedThing a => a -> SrcSpan
    getSrcSpan Name
    n) SDoc -> SDoc -> SDoc
    <> SDoc
    colon SDoc -> SDoc -> SDoc
    <+> Name -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Name
    n
                           SDoc -> SDoc -> SDoc
    <+> String -> SDoc
    text String
    "from external module"
             where
              n :: Name
    n = TyCon -> Name
    tyConName TyCon
    tc

        go_ty :: NameSet -> [TyCon] -> Type -> SynCycleM ()
        go_ty :: SynCycleState -> [TyCon] -> PredType -> SynCycleM ()
    go_ty SynCycleState
    so_far [TyCon]
    seen_tcs PredType
    ty =
            (TyCon -> SynCycleM ()) -> [TyCon] -> SynCycleM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (SynCycleState -> [TyCon] -> TyCon -> SynCycleM ()
    go SynCycleState
    so_far [TyCon]
    seen_tcs) (PredType -> [TyCon]
    synonymTyConsOfType PredType
    ty)

    {- Note [Superclass cycle check]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    The superclass cycle check for C decides if we can statically
    guarantee that expanding C's superclass cycles transitively is
    guaranteed to terminate.  This is a Haskell98 requirement,
    but one that we lift with -XUndecidableSuperClasses.

    The worry is that a superclass cycle could make the type checker loop.
    More precisely, with a constraint (Given or Wanted)
        C ty1 .. tyn
    one approach is to instantiate all of C's superclasses, transitively.
    We can only do so if that set is finite.

    This potential loop occurs only through superclasses.  This, for
    example, is fine
      class C a where
        op :: C b => a -> b -> b
    even though C's full definition uses C.

    Making the check static also makes it conservative.  Eg
      type family F a
      class F a => C a
    Here an instance of (F a) might mention C:
      type instance F [a] = C a
    and now we'd have a loop.

    The static check works like this, starting with C
      * Look at C's superclass predicates
      * If any is a type-function application,
        or is headed by a type variable, fail
      * If any has C at the head, fail
      * If any has a type class D at the head,
        make the same test with D

    A tricky point is: what if there is a type variable at the head?
    Consider this:
       class f (C f) => C f
       class c       => Id c
    and now expand superclasses for constraint (C Id):
         C Id
     --> Id (C Id)
     --> C Id
     --> ....
    Each step expands superclasses one layer, and clearly does not terminate.
    -}

    checkClassCycles :: Class -> Maybe SDoc
    -- Nothing  <=> ok
    -- Just err <=> possible cycle error
    checkClassCycles :: Class -> Maybe SDoc
    checkClassCycles Class
    cls
      = do { (Bool
    definite_cycle, SDoc
    err) <- SynCycleState -> Class -> [PredType] -> Maybe (Bool, SDoc)
    go (Name -> SynCycleState
    unitNameSet (Class -> Name
    forall a. NamedThing a => a -> Name
    getName Class
    cls))
                                         Class
    cls ([Id] -> [PredType]
    mkTyVarTys (Class -> [Id]
    classTyVars Class
    cls))
           ; let herald :: SDoc
    herald | Bool
    definite_cycle = String -> SDoc
    text String
    "Superclass cycle for"
                        | Bool
    otherwise      = String -> SDoc
    text String
    "Potential superclass cycle for"
           ; SDoc -> Maybe SDoc
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([SDoc] -> SDoc
    vcat [ SDoc
    herald SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (Class -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Class
    cls)
                          , Int -> SDoc -> SDoc
    nest Int
    2 SDoc
    err, SDoc
    hint]) }
      where
        hint :: SDoc
    hint = String -> SDoc
    text String
    "Use UndecidableSuperClasses to accept this"

        -- Expand superclasses starting with (C a b), complaining
        -- if you find the same class a second time, or a type function
        -- or predicate headed by a type variable
        --
        -- NB: this code duplicates TcType.transSuperClasses, but
        --     with more error message generation clobber
        -- Make sure the two stay in sync.
        go :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc)
        go :: SynCycleState -> Class -> [PredType] -> Maybe (Bool, SDoc)
    go SynCycleState
    so_far Class
    cls [PredType]
    tys = [Maybe (Bool, SDoc)] -> Maybe (Bool, SDoc)
    forall a. [Maybe a] -> Maybe a
    firstJusts ([Maybe (Bool, SDoc)] -> Maybe (Bool, SDoc))
    -> [Maybe (Bool, SDoc)] -> Maybe (Bool, SDoc)
    forall a b. (a -> b) -> a -> b
    $
                            (PredType -> Maybe (Bool, SDoc))
    -> [PredType] -> [Maybe (Bool, SDoc)]
    forall a b. (a -> b) -> [a] -> [b]
    map (SynCycleState -> PredType -> Maybe (Bool, SDoc)
    go_pred SynCycleState
    so_far) ([PredType] -> [Maybe (Bool, SDoc)])
    -> [PredType] -> [Maybe (Bool, SDoc)]
    forall a b. (a -> b) -> a -> b
    $
                            Class -> [PredType] -> [PredType]
    immSuperClasses Class
    cls [PredType]
    tys

        go_pred :: NameSet -> PredType -> Maybe (Bool, SDoc)
           -- Nothing <=> ok
           -- Just (True, err)  <=> definite cycle
           -- Just (False, err) <=> possible cycle
        go_pred :: SynCycleState -> PredType -> Maybe (Bool, SDoc)
    go_pred SynCycleState
    so_far PredType
    pred  -- NB: tcSplitTyConApp looks through synonyms
           | Just (TyCon
    tc, [PredType]
    tys) <- HasCallStack => PredType -> Maybe (TyCon, [PredType])
    PredType -> Maybe (TyCon, [PredType])
    tcSplitTyConApp_maybe PredType
    pred
           = SynCycleState
    -> PredType -> TyCon -> [PredType] -> Maybe (Bool, SDoc)
    go_tc SynCycleState
    so_far PredType
    pred TyCon
    tc [PredType]
    tys
           | PredType -> Bool
    hasTyVarHead PredType
    pred
           = (Bool, SDoc) -> Maybe (Bool, SDoc)
    forall a. a -> Maybe a
    Just (Bool
    False, SDoc -> Int -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "one of whose superclass constraints is headed by a type variable:")
                             Int
    2 (SDoc -> SDoc
    quotes (PredType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr PredType
    pred)))
           | Bool
    otherwise
           = Maybe (Bool, SDoc)
    forall a. Maybe a
    Nothing

        go_tc :: NameSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc)
        go_tc :: SynCycleState
    -> PredType -> TyCon -> [PredType] -> Maybe (Bool, SDoc)
    go_tc SynCycleState
    so_far PredType
    pred TyCon
    tc [PredType]
    tys
          | TyCon -> Bool
    isFamilyTyCon TyCon
    tc
          = (Bool, SDoc) -> Maybe (Bool, SDoc)
    forall a. a -> Maybe a
    Just (Bool
    False, SDoc -> Int -> SDoc -> SDoc
    hang (String -> SDoc
    text String
    "one of whose superclass constraints is headed by a type family:")
                            Int
    2 (SDoc -> SDoc
    quotes (PredType -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr PredType
    pred)))
          | Just Class
    cls <- TyCon -> Maybe Class
    tyConClass_maybe TyCon
    tc
          = SynCycleState -> Class -> [PredType] -> Maybe (Bool, SDoc)
    go_cls SynCycleState
    so_far Class
    cls [PredType]
    tys
          | Bool
    otherwise   -- Equality predicate, for example
          = Maybe (Bool, SDoc)
    forall a. Maybe a
    Nothing

        go_cls :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc)
        go_cls :: SynCycleState -> Class -> [PredType] -> Maybe (Bool, SDoc)
    go_cls SynCycleState
    so_far Class
    cls [PredType]
    tys
           | Name
    cls_nm Name -> SynCycleState -> Bool
    `elemNameSet` SynCycleState
    so_far
           = (Bool, SDoc) -> Maybe (Bool, SDoc)
    forall a. a -> Maybe a
    Just (Bool
    True, String -> SDoc
    text String
    "one of whose superclasses is" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (Class -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Class
    cls))
           | Class -> Bool
    isCTupleClass Class
    cls
           = SynCycleState -> Class -> [PredType] -> Maybe (Bool, SDoc)
    go SynCycleState
    so_far Class
    cls [PredType]
    tys
           | Bool
    otherwise
           = do { (Bool
    b,SDoc
    err) <- SynCycleState -> Class -> [PredType] -> Maybe (Bool, SDoc)
    go  (SynCycleState
    so_far SynCycleState -> Name -> SynCycleState
    `extendNameSet` Name
    cls_nm) Class
    cls [PredType]
    tys
              ; (Bool, SDoc) -> Maybe (Bool, SDoc)
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Bool
    b, String -> SDoc
    text String
    "one of whose superclasses is" SDoc -> SDoc -> SDoc
    <+> SDoc -> SDoc
    quotes (Class -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Class
    cls)
                           SDoc -> SDoc -> SDoc
    $$ SDoc
    err) }
           where
             cls_nm :: Name
    cls_nm = Class -> Name
    forall a. NamedThing a => a -> Name
    getName Class
    cls

    {-
    ************************************************************************
    *                                                                      *
            Role inference
    *                                                                      *
    ************************************************************************

    Note [Role inference]
    ~~~~~~~~~~~~~~~~~~~~~
    The role inference algorithm datatype definitions to infer the roles on the
    parameters. Although these roles are stored in the tycons, we can perform this
    algorithm on the built tycons, as long as we don't peek at an as-yet-unknown
    roles field! Ah, the magic of laziness.

    First, we choose appropriate initial roles. For families and classes, roles
    (including initial roles) are N. For datatypes, we start with the role in the
    role annotation (if any), or otherwise use Phantom. This is done in
    initialRoleEnv1.

    The function irGroup then propagates role information until it reaches a
    fixpoint, preferring N over (R or P) and R over P. To aid in this, we have a
    monad RoleM, which is a combination reader and state monad. In its state are
    the current RoleEnv, which gets updated by role propagation, and an update
    bit, which we use to know whether or not we've reached the fixpoint. The
    environment of RoleM contains the tycon whose parameters we are inferring, and
    a VarEnv from parameters to their positions, so we can update the RoleEnv.
    Between tycons, this reader information is missing; it is added by
    addRoleInferenceInfo.

    There are two kinds of tycons to consider: algebraic ones (excluding classes)
    and type synonyms. (Remember, families don't participate -- all their parameters
    are N.) An algebraic tycon processes each of its datacons, in turn. Note that
    a datacon's universally quantified parameters might be different from the parent
    tycon's parameters, so we use the datacon's univ parameters in the mapping from
    vars to positions. Note also that we don't want to infer roles for existentials
    (they're all at N, too), so we put them in the set of local variables. As an
    optimisation, we skip any tycons whose roles are already all Nominal, as there
    nowhere else for them to go. For synonyms, we just analyse their right-hand sides.

    irType walks through a type, looking for uses of a variable of interest and
    propagating role information. Because anything used under a phantom position
    is at phantom and anything used under a nominal position is at nominal, the
    irType function can assume that anything it sees is at representational. (The
    other possibilities are pruned when they're encountered.)

    The rest of the code is just plumbing.

    How do we know that this algorithm is correct? It should meet the following
    specification:

    Let Z be a role context -- a mapping from variables to roles. The following
    rules define the property (Z |- t : r), where t is a type and r is a role:

    Z(a) = r'        r' <= r
    ------------------------- RCVar
    Z |- a : r

    ---------- RCConst
    Z |- T : r               -- T is a type constructor

    Z |- t1 : r
    Z |- t2 : N
    -------------- RCApp
    Z |- t1 t2 : r

    forall i<=n. (r_i is R or N) implies Z |- t_i : r_i
    roles(T) = r_1 .. r_n
    ---------------------------------------------------- RCDApp
    Z |- T t_1 .. t_n : R

    Z, a:N |- t : r
    ---------------------- RCAll
    Z |- forall a:k.t : r

    We also have the following rules:

    For all datacon_i in type T, where a_1 .. a_n are universally quantified
    and b_1 .. b_m are existentially quantified, and the arguments are t_1 .. t_p,
    then if forall j<=p, a_1 : r_1 .. a_n : r_n, b_1 : N .. b_m : N |- t_j : R,
    then roles(T) = r_1 .. r_n

    roles(->) = R, R
    roles(~#) = N, N

    With -dcore-lint on, the output of this algorithm is checked in checkValidRoles,
    called from checkValidTycon.

    Note [Role-checking data constructor arguments]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider
      data T a where
        MkT :: Eq b => F a -> (a->a) -> T (G a)

    Then we want to check the roles at which 'a' is used
    in MkT's type.  We want to work on the user-written type,
    so we need to take into account
      * the arguments:   (F a) and (a->a)
      * the context:     C a b
      * the result type: (G a)   -- this is in the eq_spec

    Note [Coercions in role inference]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Is (t |> co1) representationally equal to (t |> co2)? Of course they are! Changing
    the kind of a type is totally irrelevant to the representation of that type. So,
    we want to totally ignore coercions when doing role inference. This includes omitting
    any type variables that appear in nominal positions but only within coercions.
    -}

    type RolesInfo = Name -> [Role]

    type RoleEnv = NameEnv [Role]        -- from tycon names to roles

    -- This, and any of the functions it calls, must *not* look at the roles
    -- field of a tycon we are inferring roles about!
    -- See Note [Role inference]
    inferRoles :: HscSource -> RoleAnnotEnv -> [TyCon] -> Name -> [Role]
    inferRoles :: HscSource -> RoleAnnotEnv -> [TyCon] -> Name -> [Role]
    inferRoles HscSource
    hsc_src RoleAnnotEnv
    annots [TyCon]
    tycons
      = let role_env :: RoleEnv
    role_env  = HscSource -> RoleAnnotEnv -> [TyCon] -> RoleEnv
    initialRoleEnv HscSource
    hsc_src RoleAnnotEnv
    annots [TyCon]
    tycons
            role_env' :: RoleEnv
    role_env' = RoleEnv -> [TyCon] -> RoleEnv
    irGroup RoleEnv
    role_env [TyCon]
    tycons in
        \Name
    name -> case RoleEnv -> Name -> Maybe [Role]
    forall a. NameEnv a -> Name -> Maybe a
    lookupNameEnv RoleEnv
    role_env' Name
    name of
          Just [Role]
    roles -> [Role]
    roles
          Maybe [Role]
    Nothing    -> String -> SDoc -> [Role]
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "inferRoles" (Name -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Name
    name)

    initialRoleEnv :: HscSource -> RoleAnnotEnv -> [TyCon] -> RoleEnv
    initialRoleEnv :: HscSource -> RoleAnnotEnv -> [TyCon] -> RoleEnv
    initialRoleEnv HscSource
    hsc_src RoleAnnotEnv
    annots = RoleEnv -> [(Name, [Role])] -> RoleEnv
    forall a. NameEnv a -> [(Name, a)] -> NameEnv a
    extendNameEnvList RoleEnv
    forall a. NameEnv a
    emptyNameEnv ([(Name, [Role])] -> RoleEnv)
    -> ([TyCon] -> [(Name, [Role])]) -> [TyCon] -> RoleEnv
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .
                                    (TyCon -> (Name, [Role])) -> [TyCon] -> [(Name, [Role])]
    forall a b. (a -> b) -> [a] -> [b]
    map (HscSource -> RoleAnnotEnv -> TyCon -> (Name, [Role])
    initialRoleEnv1 HscSource
    hsc_src RoleAnnotEnv
    annots)

    initialRoleEnv1 :: HscSource -> RoleAnnotEnv -> TyCon -> (Name, [Role])
    initialRoleEnv1 :: HscSource -> RoleAnnotEnv -> TyCon -> (Name, [Role])
    initialRoleEnv1 HscSource
    hsc_src RoleAnnotEnv
    annots_env TyCon
    tc
      | TyCon -> Bool
    isFamilyTyCon TyCon
    tc      = (Name
    name, (TyConBinder -> Role) -> [TyConBinder] -> [Role]
    forall a b. (a -> b) -> [a] -> [b]
    map (Role -> TyConBinder -> Role
    forall a b. a -> b -> a
    const Role
    Nominal) [TyConBinder]
    bndrs)
      | TyCon -> Bool
    isAlgTyCon TyCon
    tc         = (Name
    name, [Role]
    default_roles)
      | TyCon -> Bool
    isTypeSynonymTyCon TyCon
    tc = (Name
    name, [Role]
    default_roles)
      | Bool
    otherwise             = String -> SDoc -> (Name, [Role])
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "initialRoleEnv1" (TyCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyCon
    tc)
      where name :: Name
    name         = TyCon -> Name
    tyConName TyCon
    tc
            bndrs :: [TyConBinder]
    bndrs        = TyCon -> [TyConBinder]
    tyConBinders TyCon
    tc
            argflags :: [ArgFlag]
    argflags     = (TyConBinder -> ArgFlag) -> [TyConBinder] -> [ArgFlag]
    forall a b. (a -> b) -> [a] -> [b]
    map TyConBinder -> ArgFlag
    tyConBinderArgFlag [TyConBinder]
    bndrs
            num_exps :: Int
    num_exps     = (ArgFlag -> Bool) -> [ArgFlag] -> Int
    forall a. (a -> Bool) -> [a] -> Int
    count ArgFlag -> Bool
    isVisibleArgFlag [ArgFlag]
    argflags

              -- if the number of annotations in the role annotation decl
              -- is wrong, just ignore it. We check this in the validity check.
            role_annots :: [Maybe Role]
    role_annots
              = case RoleAnnotEnv -> Name -> Maybe (LRoleAnnotDecl GhcRn)
    lookupRoleAnnot RoleAnnotEnv
    annots_env Name
    name of
                  Just (L SrcSpan
    _ (RoleAnnotDecl XCRoleAnnotDecl GhcRn
    _ Located (IdP GhcRn)
    _ [Located (Maybe Role)]
    annots))
                    | [Located (Maybe Role)]
    annots [Located (Maybe Role)] -> Int -> Bool
    forall a. [a] -> Int -> Bool
    `lengthIs` Int
    num_exps -> (Located (Maybe Role) -> Maybe Role)
    -> [Located (Maybe Role)] -> [Maybe Role]
    forall a b. (a -> b) -> [a] -> [b]
    map Located (Maybe Role) -> Maybe Role
    forall l e. GenLocated l e -> e
    unLoc [Located (Maybe Role)]
    annots
                  Maybe (LRoleAnnotDecl GhcRn)
    _                              -> Int -> Maybe Role -> [Maybe Role]
    forall a. Int -> a -> [a]
    replicate Int
    num_exps Maybe Role
    forall a. Maybe a
    Nothing
            default_roles :: [Role]
    default_roles = [ArgFlag] -> [Maybe Role] -> [Role]
    build_default_roles [ArgFlag]
    argflags [Maybe Role]
    role_annots

            build_default_roles :: [ArgFlag] -> [Maybe Role] -> [Role]
    build_default_roles (ArgFlag
    argf : [ArgFlag]
    argfs) (Maybe Role
    m_annot : [Maybe Role]
    ras)
              | ArgFlag -> Bool
    isVisibleArgFlag ArgFlag
    argf
              = (Maybe Role
    m_annot Maybe Role -> Role -> Role
    forall a. Maybe a -> a -> a
    `orElse` Role
    default_role) Role -> [Role] -> [Role]
    forall a. a -> [a] -> [a]
    : [ArgFlag] -> [Maybe Role] -> [Role]
    build_default_roles [ArgFlag]
    argfs [Maybe Role]
    ras
            build_default_roles (ArgFlag
    _argf : [ArgFlag]
    argfs) [Maybe Role]
    ras
              = Role
    Nominal Role -> [Role] -> [Role]
    forall a. a -> [a] -> [a]
    : [ArgFlag] -> [Maybe Role] -> [Role]
    build_default_roles [ArgFlag]
    argfs [Maybe Role]
    ras
            build_default_roles [] [] = []
            build_default_roles [ArgFlag]
    _ [Maybe Role]
    _ = String -> SDoc -> [Role]
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "initialRoleEnv1 (2)"
                                               ([SDoc] -> SDoc
    vcat [TyCon -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr TyCon
    tc, [Maybe Role] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [Maybe Role]
    role_annots])

            default_role :: Role
    default_role
              | TyCon -> Bool
    isClassTyCon TyCon
    tc               = Role
    Nominal
              -- Note [Default roles for abstract TyCons in hs-boot/hsig]
              | HscSource
    HsBootFile <- HscSource
    hsc_src
              , TyCon -> Bool
    isAbstractTyCon TyCon
    tc            = Role
    Representational
              | HscSource
    HsigFile   <- HscSource
    hsc_src
              , TyCon -> Bool
    isAbstractTyCon TyCon
    tc            = Role
    Nominal
              | Bool
    otherwise                     = Role
    Phantom

    -- Note [Default roles for abstract TyCons in hs-boot/hsig]
    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    -- What should the default role for an abstract TyCon be?
    --
    -- Originally, we inferred phantom role for abstract TyCons
    -- in hs-boot files, because the type variables were never used.
    --
    -- This was silly, because the role of the abstract TyCon
    -- was required to match the implementation, and the roles of
    -- data types are almost never phantom.  Thus, in ticket #9204,
    -- the default was changed so be representational (the most common case).  If
    -- the implementing data type was actually nominal, you'd get an easy
    -- to understand error, and add the role annotation yourself.
    --
    -- Then Backpack was added, and with it we added role *subtyping*
    -- the matching judgment: if an abstract TyCon has a nominal
    -- parameter, it's OK to implement it with a representational
    -- parameter.  But now, the representational default is not a good
    -- one, because you should *only* request representational if
    -- you're planning to do coercions. To be maximally flexible
    -- with what data types you will accept, you want the default
    -- for hsig files is nominal.  We don't allow role subtyping
    -- with hs-boot files (it's good practice to give an exactly
    -- accurate role here, because any types that use the abstract
    -- type will propagate the role information.)

    irGroup :: RoleEnv -> [TyCon] -> RoleEnv
    irGroup :: RoleEnv -> [TyCon] -> RoleEnv
    irGroup RoleEnv
    env [TyCon]
    tcs
      = let (RoleEnv
    env', Bool
    update) = RoleEnv -> RoleM () -> (RoleEnv, Bool)
    runRoleM RoleEnv
    env (RoleM () -> (RoleEnv, Bool)) -> RoleM () -> (RoleEnv, Bool)
    forall a b. (a -> b) -> a -> b
    $ (TyCon -> RoleM ()) -> [TyCon] -> RoleM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ TyCon -> RoleM ()
    irTyCon [TyCon]
    tcs in
        if Bool
    update
        then RoleEnv -> [TyCon] -> RoleEnv
    irGroup RoleEnv
    env' [TyCon]
    tcs
        else RoleEnv
    env'

    irTyCon :: TyCon -> RoleM ()
    irTyCon :: TyCon -> RoleM ()
    irTyCon TyCon
    tc
      | TyCon -> Bool
    isAlgTyCon TyCon
    tc
      = do { [Role]
    old_roles <- TyCon -> RoleM [Role]
    lookupRoles TyCon
    tc
           ; Bool -> RoleM () -> RoleM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless ((Role -> Bool) -> [Role] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all (Role -> Role -> Bool
    forall a. Eq a => a -> a -> Bool
    == Role
    Nominal) [Role]
    old_roles) (RoleM () -> RoleM ()) -> RoleM () -> RoleM ()
    forall a b. (a -> b) -> a -> b
    $  -- also catches data families,
                                                    -- which don't want or need role inference
             TyCon -> RoleM () -> RoleM ()
    forall a. TyCon -> RoleM a -> RoleM a
    irTcTyVars TyCon
    tc (RoleM () -> RoleM ()) -> RoleM () -> RoleM ()
    forall a b. (a -> b) -> a -> b
    $
             do { (PredType -> RoleM ()) -> [PredType] -> RoleM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (VarSet -> PredType -> RoleM ()
    irType VarSet
    emptyVarSet) (TyCon -> [PredType]
    tyConStupidTheta TyCon
    tc)  -- See #8958
                ; Maybe Class -> (Class -> RoleM ()) -> RoleM ()
    forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
    whenIsJust (TyCon -> Maybe Class
    tyConClass_maybe TyCon
    tc) Class -> RoleM ()
    irClass
                ; (DataCon -> RoleM ()) -> [DataCon] -> RoleM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ DataCon -> RoleM ()
    irDataCon (AlgTyConRhs -> [DataCon]
    visibleDataCons (AlgTyConRhs -> [DataCon]) -> AlgTyConRhs -> [DataCon]
    forall a b. (a -> b) -> a -> b
    $ TyCon -> AlgTyConRhs
    algTyConRhs TyCon
    tc) }}

      | Just PredType
    ty <- TyCon -> Maybe PredType
    synTyConRhs_maybe TyCon
    tc
      = TyCon -> RoleM () -> RoleM ()
    forall a. TyCon -> RoleM a -> RoleM a
    irTcTyVars TyCon
    tc (RoleM () -> RoleM ()) -> RoleM () -> RoleM ()
    forall a b. (a -> b) -> a -> b
    $
        VarSet -> PredType -> RoleM ()
    irType VarSet
    emptyVarSet PredType
    ty

      | Bool
    otherwise
      = () -> RoleM ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    -- any type variable used in an associated type must be Nominal
    irClass :: Class -> RoleM ()
    irClass :: Class -> RoleM ()
    irClass Class
    cls
      = (TyCon -> RoleM ()) -> [TyCon] -> RoleM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ TyCon -> RoleM ()
    ir_at (Class -> [TyCon]
    classATs Class
    cls)
      where
        cls_tvs :: [Id]
    cls_tvs    = Class -> [Id]
    classTyVars Class
    cls
        cls_tv_set :: VarSet
    cls_tv_set = [Id] -> VarSet
    mkVarSet [Id]
    cls_tvs

        ir_at :: TyCon -> RoleM ()
    ir_at TyCon
    at_tc
          = (Id -> RoleM ()) -> [Id] -> RoleM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (Role -> Id -> RoleM ()
    updateRole Role
    Nominal) [Id]
    nvars
          where nvars :: [Id]
    nvars = (Id -> Bool) -> [Id] -> [Id]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Id -> VarSet -> Bool
    `elemVarSet` VarSet
    cls_tv_set) ([Id] -> [Id]) -> [Id] -> [Id]
    forall a b. (a -> b) -> a -> b
    $ TyCon -> [Id]
    tyConTyVars TyCon
    at_tc

    -- See Note [Role inference]
    irDataCon :: DataCon -> RoleM ()
    irDataCon :: DataCon -> RoleM ()
    irDataCon DataCon
    datacon
      = [Id] -> RoleM () -> RoleM ()
    forall a. [Id] -> RoleM a -> RoleM a
    setRoleInferenceVars [Id]
    univ_tvs (RoleM () -> RoleM ()) -> RoleM () -> RoleM ()
    forall a b. (a -> b) -> a -> b
    $
        [Id] -> (VarSet -> RoleM ()) -> RoleM ()
    forall a. [Id] -> (VarSet -> RoleM a) -> RoleM a
    irExTyVars [Id]
    ex_tvs ((VarSet -> RoleM ()) -> RoleM ())
    -> (VarSet -> RoleM ()) -> RoleM ()
    forall a b. (a -> b) -> a -> b
    $ \ VarSet
    ex_var_set ->
          do (PredType -> RoleM ()) -> [PredType] -> RoleM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (VarSet -> PredType -> RoleM ()
    irType VarSet
    ex_var_set) ([EqSpec] -> [PredType]
    eqSpecPreds [EqSpec]
    eq_spec [PredType] -> [PredType] -> [PredType]
    forall a. [a] -> [a] -> [a]
    ++ [PredType]
    theta [PredType] -> [PredType] -> [PredType]
    forall a. [a] -> [a] -> [a]
    ++ (Scaled PredType -> PredType) -> [Scaled PredType] -> [PredType]
    forall a b. (a -> b) -> [a] -> [b]
    map Scaled PredType -> PredType
    forall a. Scaled a -> a
    scaledThing [Scaled PredType]
    arg_tys)
             (PredType -> RoleM ()) -> [PredType] -> RoleM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (VarSet -> PredType -> RoleM ()
    markNominal VarSet
    ex_var_set) ((Id -> PredType) -> [Id] -> [PredType]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> PredType
    tyVarKind [Id]
    ex_tvs [PredType] -> [PredType] -> [PredType]
    forall a. [a] -> [a] -> [a]
    ++ (Scaled PredType -> PredType) -> [Scaled PredType] -> [PredType]
    forall a b. (a -> b) -> [a] -> [b]
    map Scaled PredType -> PredType
    forall a. Scaled a -> PredType
    scaledMult [Scaled PredType]
    arg_tys)  -- Field multiplicities are nominal (#18799)
          -- See Note [Role-checking data constructor arguments]
      where
        ([Id]
    univ_tvs, [Id]
    ex_tvs, [EqSpec]
    eq_spec, [PredType]
    theta, [Scaled PredType]
    arg_tys, PredType
    _res_ty)
          = DataCon
    -> ([Id], [Id], [EqSpec], [PredType], [Scaled PredType], PredType)
    dataConFullSig DataCon
    datacon

    irType :: VarSet -> Type -> RoleM ()
    irType :: VarSet -> PredType -> RoleM ()
    irType = VarSet -> PredType -> RoleM ()
    go
      where
        go :: VarSet -> PredType -> RoleM ()
    go VarSet
    lcls PredType
    ty                 | Just PredType
    ty' <- PredType -> Maybe PredType
    coreView PredType
    ty -- #14101
                                   = VarSet -> PredType -> RoleM ()
    go VarSet
    lcls PredType
    ty'
        go VarSet
    lcls (TyVarTy Id
    tv)       = Bool -> RoleM () -> RoleM ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (Id
    tv Id -> VarSet -> Bool
    `elemVarSet` VarSet
    lcls) (RoleM () -> RoleM ()) -> RoleM () -> RoleM ()
    forall a b. (a -> b) -> a -> b
    $
                                     Role -> Id -> RoleM ()
    updateRole Role
    Representational Id
    tv
        go VarSet
    lcls (AppTy PredType
    t1 PredType
    t2)      = VarSet -> PredType -> RoleM ()
    go VarSet
    lcls PredType
    t1 RoleM () -> RoleM () -> RoleM ()
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> VarSet -> PredType -> RoleM ()
    markNominal VarSet
    lcls PredType
    t2
        go VarSet
    lcls (TyConApp TyCon
    tc [PredType]
    tys)  = do { [Role]
    roles <- TyCon -> RoleM [Role]
    lookupRolesX TyCon
    tc
                                        ; (Role -> PredType -> RoleM ()) -> [Role] -> [PredType] -> RoleM ()
    forall (m :: * -> *) a b c.
    Applicative m =>
    (a -> b -> m c) -> [a] -> [b] -> m ()
    zipWithM_ (VarSet -> Role -> PredType -> RoleM ()
    go_app VarSet
    lcls) [Role]
    roles [PredType]
    tys }
        go VarSet
    lcls (ForAllTy TyCoVarBinder
    tvb PredType
    ty)  = do { let tv :: Id
    tv = TyCoVarBinder -> Id
    forall tv argf. VarBndr tv argf -> tv
    binderVar TyCoVarBinder
    tvb
                                              lcls' :: VarSet
    lcls' = VarSet -> Id -> VarSet
    extendVarSet VarSet
    lcls Id
    tv
                                        ; VarSet -> PredType -> RoleM ()
    markNominal VarSet
    lcls (Id -> PredType
    tyVarKind Id
    tv)
                                        ; VarSet -> PredType -> RoleM ()
    go VarSet
    lcls' PredType
    ty }
        go VarSet
    lcls (FunTy AnonArgFlag
    _ PredType
    w PredType
    arg PredType
    res)  = VarSet -> PredType -> RoleM ()
    markNominal VarSet
    lcls PredType
    w RoleM () -> RoleM () -> RoleM ()
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> VarSet -> PredType -> RoleM ()
    go VarSet
    lcls PredType
    arg RoleM () -> RoleM () -> RoleM ()
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> VarSet -> PredType -> RoleM ()
    go VarSet
    lcls PredType
    res
        go VarSet
    _    (LitTy {})         = () -> RoleM ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
          -- See Note [Coercions in role inference]
        go VarSet
    lcls (CastTy PredType
    ty KindCoercion
    _)      = VarSet -> PredType -> RoleM ()
    go VarSet
    lcls PredType
    ty
        go VarSet
    _    (CoercionTy KindCoercion
    _)     = () -> RoleM ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

        go_app :: VarSet -> Role -> PredType -> RoleM ()
    go_app VarSet
    _ Role
    Phantom PredType
    _ = () -> RoleM ()
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()                 -- nothing to do here
        go_app VarSet
    lcls Role
    Nominal PredType
    ty = VarSet -> PredType -> RoleM ()
    markNominal VarSet
    lcls PredType
    ty  -- all vars below here are N
        go_app VarSet
    lcls Role
    Representational PredType
    ty = VarSet -> PredType -> RoleM ()
    go VarSet
    lcls PredType
    ty

    irTcTyVars :: TyCon -> RoleM a -> RoleM a
    irTcTyVars :: forall a. TyCon -> RoleM a -> RoleM a
    irTcTyVars TyCon
    tc RoleM a
    thing
      = Name -> RoleM a -> RoleM a
    forall a. Name -> RoleM a -> RoleM a
    setRoleInferenceTc (TyCon -> Name
    tyConName TyCon
    tc) (RoleM a -> RoleM a) -> RoleM a -> RoleM a
    forall a b. (a -> b) -> a -> b
    $ [Id] -> RoleM a
    go (TyCon -> [Id]
    tyConTyVars TyCon
    tc)
      where
        go :: [Id] -> RoleM a
    go []       = RoleM a
    thing
        go (Id
    tv:[Id]
    tvs) = do { VarSet -> PredType -> RoleM ()
    markNominal VarSet
    emptyVarSet (Id -> PredType
    tyVarKind Id
    tv)
                         ; Id -> RoleM a -> RoleM a
    forall a. Id -> RoleM a -> RoleM a
    addRoleInferenceVar Id
    tv (RoleM a -> RoleM a) -> RoleM a -> RoleM a
    forall a b. (a -> b) -> a -> b
    $ [Id] -> RoleM a
    go [Id]
    tvs }

    irExTyVars :: [TyVar] -> (TyVarSet -> RoleM a) -> RoleM a
    irExTyVars :: forall a. [Id] -> (VarSet -> RoleM a) -> RoleM a
    irExTyVars [Id]
    orig_tvs VarSet -> RoleM a
    thing = VarSet -> [Id] -> RoleM a
    go VarSet
    emptyVarSet [Id]
    orig_tvs
      where
        go :: VarSet -> [Id] -> RoleM a
    go VarSet
    lcls []       = VarSet -> RoleM a
    thing VarSet
    lcls
        go VarSet
    lcls (Id
    tv:[Id]
    tvs) = do { VarSet -> PredType -> RoleM ()
    markNominal VarSet
    lcls (Id -> PredType
    tyVarKind Id
    tv)
                              ; VarSet -> [Id] -> RoleM a
    go (VarSet -> Id -> VarSet
    extendVarSet VarSet
    lcls Id
    tv) [Id]
    tvs }

    markNominal :: TyVarSet   -- local variables
                -> Type -> RoleM ()
    markNominal :: VarSet -> PredType -> RoleM ()
    markNominal VarSet
    lcls PredType
    ty = let nvars :: [Id]
    nvars = FV -> [Id]
    fvVarList (VarSet -> FV -> FV
    FV.delFVs VarSet
    lcls (FV -> FV) -> FV -> FV
    forall a b. (a -> b) -> a -> b
    $ PredType -> FV
    get_ty_vars PredType
    ty) in
                          (Id -> RoleM ()) -> [Id] -> RoleM ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (Role -> Id -> RoleM ()
    updateRole Role
    Nominal) [Id]
    nvars
      where
         -- get_ty_vars gets all the tyvars (no covars!) from a type *without*
         -- recurring into coercions. Recall: coercions are totally ignored during
         -- role inference. See [Coercions in role inference]
        get_ty_vars :: Type -> FV
        get_ty_vars :: PredType -> FV
    get_ty_vars (TyVarTy Id
    tv)      = Id -> FV
    unitFV Id
    tv
        get_ty_vars (AppTy PredType
    t1 PredType
    t2)     = PredType -> FV
    get_ty_vars PredType
    t1 FV -> FV -> FV
    `unionFV` PredType -> FV
    get_ty_vars PredType
    t2
        get_ty_vars (FunTy AnonArgFlag
    _ PredType
    w PredType
    t1 PredType
    t2) = PredType -> FV
    get_ty_vars PredType
    w FV -> FV -> FV
    `unionFV` PredType -> FV
    get_ty_vars PredType
    t1 FV -> FV -> FV
    `unionFV` PredType -> FV
    get_ty_vars PredType
    t2
        get_ty_vars (TyConApp TyCon
    _ [PredType]
    tys)  = (PredType -> FV) -> [PredType] -> FV
    forall a. (a -> FV) -> [a] -> FV
    mapUnionFV PredType -> FV
    get_ty_vars [PredType]
    tys
        get_ty_vars (ForAllTy TyCoVarBinder
    tvb PredType
    ty) = TyCoVarBinder -> FV -> FV
    tyCoFVsBndr TyCoVarBinder
    tvb (PredType -> FV
    get_ty_vars PredType
    ty)
        get_ty_vars (LitTy {})        = FV
    emptyFV
        get_ty_vars (CastTy PredType
    ty KindCoercion
    _)     = PredType -> FV
    get_ty_vars PredType
    ty
        get_ty_vars (CoercionTy KindCoercion
    _)    = FV
    emptyFV

    -- like lookupRoles, but with Nominal tags at the end for oversaturated TyConApps
    lookupRolesX :: TyCon -> RoleM [Role]
    lookupRolesX :: TyCon -> RoleM [Role]
    lookupRolesX TyCon
    tc
      = do { [Role]
    roles <- TyCon -> RoleM [Role]
    lookupRoles TyCon
    tc
           ; [Role] -> RoleM [Role]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Role] -> RoleM [Role]) -> [Role] -> RoleM [Role]
    forall a b. (a -> b) -> a -> b
    $ [Role]
    roles [Role] -> [Role] -> [Role]
    forall a. [a] -> [a] -> [a]
    ++ Role -> [Role]
    forall a. a -> [a]
    repeat Role
    Nominal }

    -- gets the roles either from the environment or the tycon
    lookupRoles :: TyCon -> RoleM [Role]
    lookupRoles :: TyCon -> RoleM [Role]
    lookupRoles TyCon
    tc
      = do { RoleEnv
    env <- RoleM RoleEnv
    getRoleEnv
           ; case RoleEnv -> Name -> Maybe [Role]
    forall a. NameEnv a -> Name -> Maybe a
    lookupNameEnv RoleEnv
    env (TyCon -> Name
    tyConName TyCon
    tc) of
               Just [Role]
    roles -> [Role] -> RoleM [Role]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Role]
    roles
               Maybe [Role]
    Nothing    -> [Role] -> RoleM [Role]
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([Role] -> RoleM [Role]) -> [Role] -> RoleM [Role]
    forall a b. (a -> b) -> a -> b
    $ TyCon -> [Role]
    tyConRoles TyCon
    tc }

    -- tries to update a role; won't ever update a role "downwards"
    updateRole :: Role -> TyVar -> RoleM ()
    updateRole :: Role -> Id -> RoleM ()
    updateRole Role
    role Id
    tv
      = do { VarPositions
    var_ns <- RoleM VarPositions
    getVarNs
           ; Name
    name <- RoleM Name
    getTyConName
           ; case VarPositions -> Id -> Maybe Int
    forall a. VarEnv a -> Id -> Maybe a
    lookupVarEnv VarPositions
    var_ns Id
    tv of
               Maybe Int
    Nothing -> String -> SDoc -> RoleM ()
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "updateRole" (Name -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Name
    name SDoc -> SDoc -> SDoc
    $$ Id -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Id
    tv SDoc -> SDoc -> SDoc
    $$ VarPositions -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr VarPositions
    var_ns)
               Just Int
    n  -> Name -> Int -> Role -> RoleM ()
    updateRoleEnv Name
    name Int
    n Role
    role }

    -- the state in the RoleM monad
    data RoleInferenceState = RIS { RoleInferenceState -> RoleEnv
    role_env  :: RoleEnv
                                  , RoleInferenceState -> Bool
    update    :: Bool }

    -- the environment in the RoleM monad
    type VarPositions = VarEnv Int

    -- See [Role inference]
    newtype RoleM a = RM { forall a.
    RoleM a
    -> Maybe Name
    -> VarPositions
    -> Int
    -> RoleInferenceState
    -> (a, RoleInferenceState)
    unRM :: Maybe Name -- of the tycon
                                -> VarPositions
                                -> Int          -- size of VarPositions
                                -> RoleInferenceState
                                -> (a, RoleInferenceState) }
        deriving ((forall a b. (a -> b) -> RoleM a -> RoleM b)
    -> (forall a b. a -> RoleM b -> RoleM a) -> Functor RoleM
    forall a b. a -> RoleM b -> RoleM a
    forall a b. (a -> b) -> RoleM a -> RoleM b
    forall (f :: * -> *).
    (forall a b. (a -> b) -> f a -> f b)
    -> (forall a b. a -> f b -> f a) -> Functor f
    <$ :: forall a b. a -> RoleM b -> RoleM a
    $c<$ :: forall a b. a -> RoleM b -> RoleM a
    fmap :: forall a b. (a -> b) -> RoleM a -> RoleM b
    $cfmap :: forall a b. (a -> b) -> RoleM a -> RoleM b
    Functor)

    instance Applicative RoleM where
        pure :: forall a. a -> RoleM a
    pure a
    x = (Maybe Name
     -> VarPositions
     -> Int
     -> RoleInferenceState
     -> (a, RoleInferenceState))
    -> RoleM a
    forall a.
    (Maybe Name
     -> VarPositions
     -> Int
     -> RoleInferenceState
     -> (a, RoleInferenceState))
    -> RoleM a
    RM ((Maybe Name
      -> VarPositions
      -> Int
      -> RoleInferenceState
      -> (a, RoleInferenceState))
     -> RoleM a)
    -> (Maybe Name
        -> VarPositions
        -> Int
        -> RoleInferenceState
        -> (a, RoleInferenceState))
    -> RoleM a
    forall a b. (a -> b) -> a -> b
    $ \Maybe Name
    _ VarPositions
    _ Int
    _ RoleInferenceState
    state -> (a
    x, RoleInferenceState
    state)
        <*> :: forall a b. RoleM (a -> b) -> RoleM a -> RoleM b
    (<*>) = RoleM (a -> b) -> RoleM a -> RoleM b
    forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
    ap

    instance Monad RoleM where
      RoleM a
    a >>= :: forall a b. RoleM a -> (a -> RoleM b) -> RoleM b
    >>= a -> RoleM b
    f  = (Maybe Name
     -> VarPositions
     -> Int
     -> RoleInferenceState
     -> (b, RoleInferenceState))
    -> RoleM b
    forall a.
    (Maybe Name
     -> VarPositions
     -> Int
     -> RoleInferenceState
     -> (a, RoleInferenceState))
    -> RoleM a
    RM ((Maybe Name
      -> VarPositions
      -> Int
      -> RoleInferenceState
      -> (b, RoleInferenceState))
     -> RoleM b)
    -> (Maybe Name
        -> VarPositions
        -> Int
        -> RoleInferenceState
        -> (b, RoleInferenceState))
    -> RoleM b
    forall a b. (a -> b) -> a -> b
    $ \Maybe Name
    m_info VarPositions
    vps Int
    nvps RoleInferenceState
    state ->
                      let (a
    a', RoleInferenceState
    state') = RoleM a
    -> Maybe Name
    -> VarPositions
    -> Int
    -> RoleInferenceState
    -> (a, RoleInferenceState)
    forall a.
    RoleM a
    -> Maybe Name
    -> VarPositions
    -> Int
    -> RoleInferenceState
    -> (a, RoleInferenceState)
    unRM RoleM a
    a Maybe Name
    m_info VarPositions
    vps Int
    nvps RoleInferenceState
    state in
                      RoleM b
    -> Maybe Name
    -> VarPositions
    -> Int
    -> RoleInferenceState
    -> (b, RoleInferenceState)
    forall a.
    RoleM a
    -> Maybe Name
    -> VarPositions
    -> Int
    -> RoleInferenceState
    -> (a, RoleInferenceState)
    unRM (a -> RoleM b
    f a
    a') Maybe Name
    m_info VarPositions
    vps Int
    nvps RoleInferenceState
    state'

    runRoleM :: RoleEnv -> RoleM () -> (RoleEnv, Bool)
    runRoleM :: RoleEnv -> RoleM () -> (RoleEnv, Bool)
    runRoleM RoleEnv
    env RoleM ()
    thing = (RoleEnv
    env', Bool
    update)
      where RIS { role_env :: RoleInferenceState -> RoleEnv
    role_env = RoleEnv
    env', update :: RoleInferenceState -> Bool
    update = Bool
    update }
              = ((), RoleInferenceState) -> RoleInferenceState
    forall a b. (a, b) -> b
    snd (((), RoleInferenceState) -> RoleInferenceState)
    -> ((), RoleInferenceState) -> RoleInferenceState
    forall a b. (a -> b) -> a -> b
    $ RoleM ()
    -> Maybe Name
    -> VarPositions
    -> Int
    -> RoleInferenceState
    -> ((), RoleInferenceState)
    forall a.
    RoleM a
    -> Maybe Name
    -> VarPositions
    -> Int
    -> RoleInferenceState
    -> (a, RoleInferenceState)
    unRM RoleM ()
    thing Maybe Name
    forall a. Maybe a
    Nothing VarPositions
    forall a. VarEnv a
    emptyVarEnv Int
    0 RoleInferenceState
    state
            state :: RoleInferenceState
    state = RIS :: RoleEnv -> Bool -> RoleInferenceState
    RIS { role_env :: RoleEnv
    role_env  = RoleEnv
    env
                        , update :: Bool
    update    = Bool
    False }

    setRoleInferenceTc :: Name -> RoleM a -> RoleM a
    setRoleInferenceTc :: forall a. Name -> RoleM a -> RoleM a
    setRoleInferenceTc Name
    name RoleM a
    thing = (Maybe Name
     -> VarPositions
     -> Int
     -> RoleInferenceState
     -> (a, RoleInferenceState))
    -> RoleM a
    forall a.
    (Maybe Name
     -> VarPositions
     -> Int
     -> RoleInferenceState
     -> (a, RoleInferenceState))
    -> RoleM a
    RM ((Maybe Name
      -> VarPositions
      -> Int
      -> RoleInferenceState
      -> (a, RoleInferenceState))
     -> RoleM a)
    -> (Maybe Name
        -> VarPositions
        -> Int
        -> RoleInferenceState
        -> (a, RoleInferenceState))
    -> RoleM a
    forall a b. (a -> b) -> a -> b
    $ \Maybe Name
    m_name VarPositions
    vps Int
    nvps RoleInferenceState
    state ->
                                    ASSERT( isNothing m_name )
                                    ASSERT( isEmptyVarEnv vps )
                                    ASSERT( nvps == 0 )
                                    RoleM a
    -> Maybe Name
    -> VarPositions
    -> Int
    -> RoleInferenceState
    -> (a, RoleInferenceState)
    forall a.
    RoleM a
    -> Maybe Name
    -> VarPositions
    -> Int
    -> RoleInferenceState
    -> (a, RoleInferenceState)
    unRM RoleM a
    thing (Name -> Maybe Name
    forall a. a -> Maybe a
    Just Name
    name) VarPositions
    vps Int
    nvps RoleInferenceState
    state

    addRoleInferenceVar :: TyVar -> RoleM a -> RoleM a
    addRoleInferenceVar :: forall a. Id -> RoleM a -> RoleM a
    addRoleInferenceVar Id
    tv RoleM a
    thing
      = (Maybe Name
     -> VarPositions
     -> Int
     -> RoleInferenceState
     -> (a, RoleInferenceState))
    -> RoleM a
    forall a.
    (Maybe Name
     -> VarPositions
     -> Int
     -> RoleInferenceState
     -> (a, RoleInferenceState))
    -> RoleM a
    RM ((Maybe Name
      -> VarPositions
      -> Int
      -> RoleInferenceState
      -> (a, RoleInferenceState))
     -> RoleM a)
    -> (Maybe Name
        -> VarPositions
        -> Int
        -> RoleInferenceState
        -> (a, RoleInferenceState))
    -> RoleM a
    forall a b. (a -> b) -> a -> b
    $ \Maybe Name
    m_name VarPositions
    vps Int
    nvps RoleInferenceState
    state ->
        ASSERT( isJust m_name )
        RoleM a
    -> Maybe Name
    -> VarPositions
    -> Int
    -> RoleInferenceState
    -> (a, RoleInferenceState)
    forall a.
    RoleM a
    -> Maybe Name
    -> VarPositions
    -> Int
    -> RoleInferenceState
    -> (a, RoleInferenceState)
    unRM RoleM a
    thing Maybe Name
    m_name (VarPositions -> Id -> Int -> VarPositions
    forall a. VarEnv a -> Id -> a -> VarEnv a
    extendVarEnv VarPositions
    vps Id
    tv Int
    nvps) (Int
    nvpsInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1) RoleInferenceState
    state

    setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a
    setRoleInferenceVars :: forall a. [Id] -> RoleM a -> RoleM a
    setRoleInferenceVars [Id]
    tvs RoleM a
    thing
      = (Maybe Name
     -> VarPositions
     -> Int
     -> RoleInferenceState
     -> (a, RoleInferenceState))
    -> RoleM a
    forall a.
    (Maybe Name
     -> VarPositions
     -> Int
     -> RoleInferenceState
     -> (a, RoleInferenceState))
    -> RoleM a
    RM ((Maybe Name
      -> VarPositions
      -> Int
      -> RoleInferenceState
      -> (a, RoleInferenceState))
     -> RoleM a)
    -> (Maybe Name
        -> VarPositions
        -> Int
        -> RoleInferenceState
        -> (a, RoleInferenceState))
    -> RoleM a
    forall a b. (a -> b) -> a -> b
    $ \Maybe Name
    m_name VarPositions
    _vps Int
    _nvps RoleInferenceState
    state ->
        ASSERT( isJust m_name )
        RoleM a
    -> Maybe Name
    -> VarPositions
    -> Int
    -> RoleInferenceState
    -> (a, RoleInferenceState)
    forall a.
    RoleM a
    -> Maybe Name
    -> VarPositions
    -> Int
    -> RoleInferenceState
    -> (a, RoleInferenceState)
    unRM RoleM a
    thing Maybe Name
    m_name ([(Id, Int)] -> VarPositions
    forall a. [(Id, a)] -> VarEnv a
    mkVarEnv ([Id] -> [Int] -> [(Id, Int)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Id]
    tvs [Int
    0..])) (String -> Int
    forall a. String -> a
    panic String
    "setRoleInferenceVars")
             RoleInferenceState
    state

    getRoleEnv :: RoleM RoleEnv
    getRoleEnv :: RoleM RoleEnv
    getRoleEnv = (Maybe Name
     -> VarPositions
     -> Int
     -> RoleInferenceState
     -> (RoleEnv, RoleInferenceState))
    -> RoleM RoleEnv
    forall a.
    (Maybe Name
     -> VarPositions
     -> Int
     -> RoleInferenceState
     -> (a, RoleInferenceState))
    -> RoleM a
    RM ((Maybe Name
      -> VarPositions
      -> Int
      -> RoleInferenceState
      -> (RoleEnv, RoleInferenceState))
     -> RoleM RoleEnv)
    -> (Maybe Name
        -> VarPositions
        -> Int
        -> RoleInferenceState
        -> (RoleEnv, RoleInferenceState))
    -> RoleM RoleEnv
    forall a b. (a -> b) -> a -> b
    $ \Maybe Name
    _ VarPositions
    _ Int
    _ state :: RoleInferenceState
    state@(RIS { role_env :: RoleInferenceState -> RoleEnv
    role_env = RoleEnv
    env }) -> (RoleEnv
    env, RoleInferenceState
    state)

    getVarNs :: RoleM VarPositions
    getVarNs :: RoleM VarPositions
    getVarNs = (Maybe Name
     -> VarPositions
     -> Int
     -> RoleInferenceState
     -> (VarPositions, RoleInferenceState))
    -> RoleM VarPositions
    forall a.
    (Maybe Name
     -> VarPositions
     -> Int
     -> RoleInferenceState
     -> (a, RoleInferenceState))
    -> RoleM a
    RM ((Maybe Name
      -> VarPositions
      -> Int
      -> RoleInferenceState
      -> (VarPositions, RoleInferenceState))
     -> RoleM VarPositions)
    -> (Maybe Name
        -> VarPositions
        -> Int
        -> RoleInferenceState
        -> (VarPositions, RoleInferenceState))
    -> RoleM VarPositions
    forall a b. (a -> b) -> a -> b
    $ \Maybe Name
    _ VarPositions
    vps Int
    _ RoleInferenceState
    state -> (VarPositions
    vps, RoleInferenceState
    state)

    getTyConName :: RoleM Name
    getTyConName :: RoleM Name
    getTyConName = (Maybe Name
     -> VarPositions
     -> Int
     -> RoleInferenceState
     -> (Name, RoleInferenceState))
    -> RoleM Name
    forall a.
    (Maybe Name
     -> VarPositions
     -> Int
     -> RoleInferenceState
     -> (a, RoleInferenceState))
    -> RoleM a
    RM ((Maybe Name
      -> VarPositions
      -> Int
      -> RoleInferenceState
      -> (Name, RoleInferenceState))
     -> RoleM Name)
    -> (Maybe Name
        -> VarPositions
        -> Int
        -> RoleInferenceState
        -> (Name, RoleInferenceState))
    -> RoleM Name
    forall a b. (a -> b) -> a -> b
    $ \Maybe Name
    m_name VarPositions
    _ Int
    _ RoleInferenceState
    state ->
                        case Maybe Name
    m_name of
                          Maybe Name
    Nothing   -> String -> (Name, RoleInferenceState)
    forall a. String -> a
    panic String
    "getTyConName"
                          Just Name
    name -> (Name
    name, RoleInferenceState
    state)

    updateRoleEnv :: Name -> Int -> Role -> RoleM ()
    updateRoleEnv :: Name -> Int -> Role -> RoleM ()
    updateRoleEnv Name
    name Int
    n Role
    role
      = (Maybe Name
     -> VarPositions
     -> Int
     -> RoleInferenceState
     -> ((), RoleInferenceState))
    -> RoleM ()
    forall a.
    (Maybe Name
     -> VarPositions
     -> Int
     -> RoleInferenceState
     -> (a, RoleInferenceState))
    -> RoleM a
    RM ((Maybe Name
      -> VarPositions
      -> Int
      -> RoleInferenceState
      -> ((), RoleInferenceState))
     -> RoleM ())
    -> (Maybe Name
        -> VarPositions
        -> Int
        -> RoleInferenceState
        -> ((), RoleInferenceState))
    -> RoleM ()
    forall a b. (a -> b) -> a -> b
    $ \Maybe Name
    _ VarPositions
    _ Int
    _ state :: RoleInferenceState
    state@(RIS { role_env :: RoleInferenceState -> RoleEnv
    role_env = RoleEnv
    role_env }) -> ((),
             case RoleEnv -> Name -> Maybe [Role]
    forall a. NameEnv a -> Name -> Maybe a
    lookupNameEnv RoleEnv
    role_env Name
    name of
               Maybe [Role]
    Nothing -> String -> SDoc -> RoleInferenceState
    forall a. HasCallStack => String -> SDoc -> a
    pprPanic String
    "updateRoleEnv" (Name -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr Name
    name)
               Just [Role]
    roles -> let ([Role]
    before, Role
    old_role : [Role]
    after) = Int -> [Role] -> ([Role], [Role])
    forall a. Int -> [a] -> ([a], [a])
    splitAt Int
    n [Role]
    roles in
                             if Role
    role Role -> Role -> Bool
    `ltRole` Role
    old_role
                             then let roles' :: [Role]
    roles' = [Role]
    before [Role] -> [Role] -> [Role]
    forall a. [a] -> [a] -> [a]
    ++ Role
    role Role -> [Role] -> [Role]
    forall a. a -> [a] -> [a]
    : [Role]
    after
                                      role_env' :: RoleEnv
    role_env' = RoleEnv -> Name -> [Role] -> RoleEnv
    forall a. NameEnv a -> Name -> a -> NameEnv a
    extendNameEnv RoleEnv
    role_env Name
    name [Role]
    roles' in
                                  RIS :: RoleEnv -> Bool -> RoleInferenceState
    RIS { role_env :: RoleEnv
    role_env = RoleEnv
    role_env', update :: Bool
    update = Bool
    True }
                             else RoleInferenceState
    state )

    {- *********************************************************************
    *                                                                      *
                    Building implicits
    *                                                                      *
    ********************************************************************* -}

    addTyConsToGblEnv :: [TyCon] -> TcM TcGblEnv
    -- Given a [TyCon], add to the TcGblEnv
    --   * extend the TypeEnv with the tycons
    --   * extend the TypeEnv with their implicitTyThings
    --   * extend the TypeEnv with any default method Ids
    --   * add bindings for record selectors
    addTyConsToGblEnv :: [TyCon] -> TcM TcGblEnv
    addTyConsToGblEnv [TyCon]
    tyclss
      = [TyCon] -> TcM TcGblEnv -> TcM TcGblEnv
    forall r. [TyCon] -> TcM r -> TcM r
    tcExtendTyConEnv [TyCon]
    tyclss                    (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
    forall a b. (a -> b) -> a -> b
    $
        [TyThing] -> TcM TcGblEnv -> TcM TcGblEnv
    forall r. [TyThing] -> TcM r -> TcM r
    tcExtendGlobalEnvImplicit [TyThing]
    implicit_things  (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
    forall a b. (a -> b) -> a -> b
    $
        [Id] -> TcM TcGblEnv -> TcM TcGblEnv
    forall a. [Id] -> TcM a -> TcM a
    tcExtendGlobalValEnv [Id]
    def_meth_ids          (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
    forall a b. (a -> b) -> a -> b
    $
        do { String -> SDoc -> TcM ()
    traceTc String
    "tcAddTyCons" (SDoc -> TcM ()) -> SDoc -> TcM ()
    forall a b. (a -> b) -> a -> b
    $ [SDoc] -> SDoc
    vcat
                [ String -> SDoc
    text String
    "tycons" SDoc -> SDoc -> SDoc
    <+> [TyCon] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [TyCon]
    tyclss
                , String -> SDoc
    text String
    "implicits" SDoc -> SDoc -> SDoc
    <+> [TyThing] -> SDoc
    forall a. Outputable a => a -> SDoc
    ppr [TyThing]
    implicit_things ]
           ; TcGblEnv
    gbl_env <- [(Id, LHsBind GhcRn)] -> TcM TcGblEnv
    tcRecSelBinds ([TyCon] -> [(Id, LHsBind GhcRn)]
    mkRecSelBinds [TyCon]
    tyclss)
           ; TcGblEnv -> TcM TcGblEnv
    forall (m :: * -> *) a. Monad m => a -> m a
    return TcGblEnv
    gbl_env }
     where
       implicit_things :: [TyThing]
    implicit_things = (TyCon -> [TyThing]) -> [TyCon] -> [TyThing]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap TyCon -> [TyThing]
    implicitTyConThings [TyCon]
    tyclss
       def_meth_ids :: [Id]
    def_meth_ids    = [TyCon] -> [Id]
    mkDefaultMethodIds [TyCon]
    tyclss

    mkDefaultMethodIds :: [TyCon] -> [Id]
    -- We want to put the default-method Ids (both vanilla and generic)
    -- into the type environment so that they are found when we typecheck
    -- the filled-in default methods of each instance declaration
    -- See Note [Default method Ids and Template Haskell]
    mkDefaultMethodIds :: [TyCon] -> [Id]
    mkDefaultMethodIds [TyCon]
    tycons
      = [ Name -> PredType -> Id
    mkExportedVanillaId Name
    dm_name (Class -> Id -> DefMethSpec PredType -> PredType
    mkDefaultMethodType Class
    cls Id
    sel_id DefMethSpec PredType
    dm_spec)
        | TyCon
    tc <- [TyCon]
    tycons
        , Just Class
    cls <- [TyCon -> Maybe Class
    tyConClass_maybe TyCon
    tc]
        , (Id
    sel_id, Just (Name
    dm_name, DefMethSpec PredType
    dm_spec)) <- Class -> [(Id, DefMethInfo)]
    classOpItems Class
    cls ]

    mkDefaultMethodType :: Class -> Id -> DefMethSpec Type -> Type
    -- Returns the top-level type of the default method
    mkDefaultMethodType :: Class -> Id -> DefMethSpec PredType -> PredType
    mkDefaultMethodType Class
    _ Id
    sel_id DefMethSpec PredType
    VanillaDM        = Id -> PredType
    idType Id
    sel_id
    mkDefaultMethodType Class
    cls Id
    _   (GenericDM PredType
    dm_ty) = [TyCoVarBinder] -> [PredType] -> PredType -> PredType
    mkSigmaTy [TyCoVarBinder]
    tv_bndrs [PredType
    pred] PredType
    dm_ty
       where
         pred :: PredType
    pred      = Class -> [PredType] -> PredType
    mkClassPred Class
    cls ([Id] -> [PredType]
    mkTyVarTys ([TyConBinder] -> [Id]
    forall tv argf. [VarBndr tv argf] -> [tv]
    binderVars [TyConBinder]
    cls_bndrs))
         cls_bndrs :: [TyConBinder]
    cls_bndrs = TyCon -> [TyConBinder]
    tyConBinders (Class -> TyCon
    classTyCon Class
    cls)
         tv_bndrs :: [TyCoVarBinder]
    tv_bndrs  = [VarBndr Id Specificity] -> [TyCoVarBinder]
    forall a. [VarBndr a Specificity] -> [VarBndr a ArgFlag]
    tyVarSpecToBinders ([VarBndr Id Specificity] -> [TyCoVarBinder])
    -> [VarBndr Id Specificity] -> [TyCoVarBinder]
    forall a b. (a -> b) -> a -> b
    $ [TyConBinder] -> [VarBndr Id Specificity]
    tyConInvisTVBinders [TyConBinder]
    cls_bndrs
         -- NB: the Class doesn't have TyConBinders; we reach into its
         --     TyCon to get those.  We /do/ need the TyConBinders because
         --     we need the correct visibility: these default methods are
         --     used in code generated by the fill-in for missing
         --     methods in instances (GHC.Tc.TyCl.Instance.mkDefMethBind), and
         --     then typechecked.  So we need the right visibility info
         --     (#13998)

    {-
    ************************************************************************
    *                                                                      *
                    Building record selectors
    *                                                                      *
    ************************************************************************
    -}

    {-
    Note [Default method Ids and Template Haskell]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    Consider this (#4169):
       class Numeric a where
         fromIntegerNum :: a
         fromIntegerNum = ...

       ast :: Q [Dec]
       ast = [d| instance Numeric Int |]

    When we typecheck 'ast' we have done the first pass over the class decl
    (in tcTyClDecls), but we have not yet typechecked the default-method
    declarations (because they can mention value declarations).  So we
    must bring the default method Ids into scope first (so they can be seen
    when typechecking the [d| .. |] quote, and typecheck them later.
    -}

    {-
    ************************************************************************
    *                                                                      *
                    Building record selectors
    *                                                                      *
    ************************************************************************
    -}

    tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv
    tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv
    tcRecSelBinds [(Id, LHsBind GhcRn)]
    sel_bind_prs
      = [Id] -> TcM TcGblEnv -> TcM TcGblEnv
    forall a. [Id] -> TcM a -> TcM a
    tcExtendGlobalValEnv [Id
    sel_id | (L SrcSpan
    _ (IdSig XIdSig GhcRn
    _ Id
    sel_id)) <- [GenLocated SrcSpan (Sig GhcRn)]
    sigs] (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
    forall a b. (a -> b) -> a -> b
    $
        do { ([(RecFlag, LHsBinds GhcTc)]
    rec_sel_binds, TcGblEnv
    tcg_env) <- TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
    -> TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
    forall a. TcRn a -> TcRn a
    discardWarnings (TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
     -> TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv))
    -> TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
    -> TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
    forall a b. (a -> b) -> a -> b
    $
                                         -- See Note [Impredicative record selectors]
                                         Extension
    -> TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
    -> TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
    forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
    setXOptM Extension
    LangExt.ImpredicativeTypes (TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
     -> TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv))
    -> TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
    -> TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
    forall a b. (a -> b) -> a -> b
    $
                                         TopLevelFlag
    -> [(RecFlag, LHsBinds GhcRn)]
    -> [GenLocated SrcSpan (Sig GhcRn)]
    -> TcM TcGblEnv
    -> TcRn ([(RecFlag, LHsBinds GhcTc)], TcGblEnv)
    forall thing.
    TopLevelFlag
    -> [(RecFlag, LHsBinds GhcRn)]
    -> [GenLocated SrcSpan (Sig GhcRn)]
    -> TcM thing
    -> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
    tcValBinds TopLevelFlag
    TopLevel [(RecFlag, LHsBinds GhcRn)]
    binds [GenLocated SrcSpan (Sig GhcRn)]
    sigs TcM TcGblEnv
    forall gbl lcl. TcRnIf gbl lcl gbl
    getGblEnv
           ; TcGblEnv -> TcM TcGblEnv
    forall (m :: * -> *) a. Monad m => a -> m a
    return (TcGblEnv
    tcg_env TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
    `addTypecheckedBinds` ((RecFlag, LHsBinds GhcTc) -> LHsBinds GhcTc)
    -> [(RecFlag, LHsBinds GhcTc)] -> [LHsBinds GhcTc]
    forall a b. (a -> b) -> [a] -> [b]
    map (RecFlag, LHsBinds GhcTc) -> LHsBinds GhcTc
    forall a b. (a, b) -> b
    snd [(RecFlag, LHsBinds GhcTc)]
    rec_sel_binds) }
      where
        sigs :: [GenLocated SrcSpan (Sig GhcRn)]
    sigs = [ SrcSpan -> Sig GhcRn -> GenLocated SrcSpan (Sig GhcRn)
    forall l e. l -> e -> GenLocated l e
    L SrcSpan
    loc (XIdSig GhcRn -> Id -> Sig GhcRn
    forall pass. XIdSig pass -> Id -> Sig pass
    IdSig NoExtField
    XIdSig GhcRn
    noExtField Id
    sel_id) | (Id
    sel_id, LHsBind GhcRn
    _) <- [(Id, LHsBind GhcRn)]
    sel_bind_prs
                                                 , let loc :: SrcSpan
    loc = Id -> SrcSpan
    forall a. NamedThing a => a -> SrcSpan
    getSrcSpan Id
    sel_id ]
        binds :: [(RecFlag, LHsBinds GhcRn)]
    binds = [(RecFlag
    NonRecursive, LHsBind GhcRn -> LHsBinds GhcRn
    forall a. a -> Bag a
    unitBag LHsBind GhcRn
    bind) | (Id
    _, LHsBind GhcRn
    bind) <- [(Id, LHsBind GhcRn)]
    sel_bind_prs]

    mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)]
    -- NB We produce *un-typechecked* bindings, rather like 'deriving'
    --    This makes life easier, because the later type checking will add
    --    all necessary type abstractions and applications
    mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)]
    mkRecSelBinds [TyCon]
    tycons
      = ((TyCon, FieldLabel) -> (Id, LHsBind GhcRn))
    -> [(TyCon, FieldLabel)] -> [(Id, LHsBind GhcRn)]
    forall a b. (a -> b) -> [a] -> [b]
    map (TyCon, FieldLabel) -> (Id, LHsBind GhcRn)
    mkRecSelBind [ (TyCon
    tc,FieldLabel
    fld) | TyCon
    tc <- [TyCon]
    tycons
                                    , FieldLabel
    fld <- TyCon -> [FieldLabel]
    tyConFieldLabels TyCon
    tc ]

    mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn)
    mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn)
    mkRecSelBind (TyCon
    tycon, FieldLabel
    fl)
      = [ConLike] -> RecSelParent -> FieldLabel -> (Id, LHsBind GhcRn)
    mkOneRecordSelector [ConLike]
    all_cons (TyCon -> RecSelParent
    RecSelData TyCon
    tycon) FieldLabel
    fl
      where
        all_cons :: [ConLike]
    all_cons = (DataCon -> ConLike) -> [DataCon] -> [ConLike]
    forall a b. (a -> b) -> [a] -> [b]
    map DataCon -> ConLike
    RealDataCon (TyCon -> [DataCon]
    tyConDataCons TyCon
    tycon)

    mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel
                        -> (Id, LHsBind GhcRn)
    mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> (Id, LHsBind GhcRn)
    mkOneRecordSelector [ConLike]
    all_cons RecSelParent
    idDetails FieldLabel
    fl
      = (Id
    sel_id, SrcSpan -> HsBind GhcRn -> LHsBind GhcRn
    forall l e. l -> e -> GenLocated l e
    L SrcSpan
    loc HsBind GhcRn
    sel_bind)
      where
        loc :: SrcSpan
    loc      = Name -> SrcSpan
    forall a. NamedThing a => a -> SrcSpan
    getSrcSpan Name
    sel_name
        lbl :: FieldLabelString
    lbl      = FieldLabel -> FieldLabelString
    forall a. FieldLbl a -> FieldLabelString
    flLabel FieldLabel
    fl
        sel_name :: Name
    sel_name = FieldLabel -> Name
    forall a. FieldLbl a -> a
    flSelector FieldLabel
    fl

        sel_id :: Id
    sel_id = IdDetails -> Name -> PredType -> Id
    mkExportedLocalId IdDetails
    rec_details Name
    sel_name PredType
    sel_ty
        rec_details :: IdDetails
    rec_details = RecSelId :: RecSelParent -> Bool -> IdDetails
    RecSelId { sel_tycon :: RecSelParent
    sel_tycon = RecSelParent
    idDetails, sel_naughty :: Bool
    sel_naughty = Bool
    is_naughty }

        -- Find a representative constructor, con1
        cons_w_field :: [ConLike]
    cons_w_field = [ConLike] -> [FieldLabelString] -> [ConLike]
    conLikesWithFields [ConLike]
    all_cons [FieldLabelString
    lbl]
        con1 :: ConLike
    con1 = ASSERT( not (null cons_w_field) ) head cons_w_field

        -- Selector type; Note [Polymorphic selectors]
        field_ty :: PredType
    field_ty   = ConLike -> FieldLabelString -> PredType
    conLikeFieldType ConLike
    con1 FieldLabelString
    lbl
        data_tvbs :: [VarBndr Id Specificity]
    data_tvbs  = (VarBndr Id Specificity -> Bool)
    -> [VarBndr Id Specificity] -> [VarBndr Id Specificity]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (\VarBndr Id Specificity
    tvb -> VarBndr Id Specificity -> Id
    forall tv argf. VarBndr tv argf -> tv
    binderVar VarBndr Id Specificity
    tvb Id -> VarSet -> Bool
    `elemVarSet` VarSet
    data_tv_set) ([VarBndr Id Specificity] -> [VarBndr Id Specificity])
    -> [VarBndr Id Specificity] -> [VarBndr Id Specificity]
    forall a b. (a -> b) -> a -> b
    $
                     ConLike -> [VarBndr Id Specificity]
    conLikeUserTyVarBinders ConLike
    con1
        data_tv_set :: VarSet
    data_tv_set= [PredType] -> VarSet
    tyCoVarsOfTypes [PredType]
    inst_tys
        is_naughty :: Bool
    is_naughty = Bool -> Bool
    not (PredType -> VarSet
    tyCoVarsOfType PredType
    field_ty VarSet -> VarSet -> Bool
    `subVarSet` VarSet
    data_tv_set)
        sel_ty :: PredType
    sel_ty | Bool
    is_naughty = PredType
    unitTy  -- See Note [Naughty record selectors]
               | Bool
    otherwise  = [TyCoVarBinder] -> PredType -> PredType
    mkForAllTys ([VarBndr Id Specificity] -> [TyCoVarBinder]
    forall a. [VarBndr a Specificity] -> [VarBndr a ArgFlag]
    tyVarSpecToBinders [VarBndr Id Specificity]
    data_tvbs) (PredType -> PredType) -> PredType -> PredType
    forall a b. (a -> b) -> a -> b
    $
                              [PredType] -> PredType -> PredType
    mkPhiTy (ConLike -> [PredType]
    conLikeStupidTheta ConLike
    con1) (PredType -> PredType) -> PredType -> PredType
    forall a b. (a -> b) -> a -> b
    $   -- Urgh!
                              -- req_theta is empty for normal DataCon
                              [PredType] -> PredType -> PredType
    mkPhiTy [PredType]
    req_theta                 (PredType -> PredType) -> PredType -> PredType
    forall a b. (a -> b) -> a -> b
    $
                              PredType -> PredType -> PredType
    mkVisFunTyMany PredType
    data_ty            (PredType -> PredType) -> PredType -> PredType
    forall a b. (a -> b) -> a -> b
    $
                                -- Record selectors are always typed with Many. We
                                -- could improve on it in the case where all the
                                -- fields in all the constructor have multiplicity Many.
                              PredType
    field_ty

        -- Make the binding: sel (C2 { fld = x }) = x
        --                   sel (C7 { fld = x }) = x
        --    where cons_w_field = [C2,C7]
        sel_bind :: HsBind GhcRn
    sel_bind = Origin
    -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)] -> HsBind GhcRn
    mkTopFunBind Origin
    Generated Located Name
    sel_lname [LMatch GhcRn (LHsExpr GhcRn)]
    alts
          where
            alts :: [LMatch GhcRn (LHsExpr GhcRn)]
    alts | Bool
    is_naughty = [HsMatchContext (NoGhcTc GhcRn)
    -> [LPat GhcRn] -> LHsExpr GhcRn -> LMatch GhcRn (LHsExpr GhcRn)
    forall (p :: Pass) (body :: * -> *).
    HsMatchContext (NoGhcTc (GhcPass p))
    -> [LPat (GhcPass p)]
    -> Located (body (GhcPass p))
    -> LMatch (GhcPass p) (Located (body (GhcPass p)))
    mkSimpleMatch (Located (IdP GhcRn) -> HsMatchContext GhcRn
    forall p. LIdP p -> HsMatchContext p
    mkPrefixFunRhs Located Name
    Located (IdP GhcRn)
    sel_lname)
                                               [] LHsExpr GhcRn
    forall {a :: Pass}. LHsExpr (GhcPass a)
    unit_rhs]
                 | Bool
    otherwise =  (ConLike -> LMatch GhcRn (LHsExpr GhcRn))
    -> [ConLike] -> [LMatch GhcRn (LHsExpr GhcRn)]
    forall a b. (a -> b) -> [a] -> [b]
    map ConLike -> LMatch GhcRn (LHsExpr GhcRn)
    mk_match [ConLike]
    cons_w_field [LMatch GhcRn (LHsExpr GhcRn)]
    -> [LMatch GhcRn (LHsExpr GhcRn)] -> [LMatch GhcRn (LHsExpr GhcRn)]
    forall a. [a] -> [a] -> [a]
    ++ [LMatch GhcRn (LHsExpr GhcRn)]
    deflt
        mk_match :: ConLike -> LMatch GhcRn (LHsExpr GhcRn)
    mk_match ConLike
    con = HsMatchContext (NoGhcTc GhcRn)
    -> [LPat GhcRn] -> LHsExpr GhcRn -> LMatch GhcRn (LHsExpr GhcRn)
    forall (p :: Pass) (body :: * -> *).
    HsMatchContext (NoGhcTc (GhcPass p))
    -> [LPat (GhcPass p)]
    -> Located (body (GhcPass p))
    -> LMatch (GhcPass p) (Located (body (GhcPass p)))
    mkSimpleMatch (Located (IdP GhcRn) -> HsMatchContext GhcRn
    forall p. LIdP p -> HsMatchContext p
    mkPrefixFunRhs Located Name
    Located (IdP GhcRn)
    sel_lname)
                                     [SrcSpan -> Pat GhcRn -> GenLocated SrcSpan (Pat GhcRn)
    forall l e. l -> e -> GenLocated l e
    L SrcSpan
    loc (ConLike -> Pat GhcRn
    mk_sel_pat ConLike
    con)]
                                     (SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn
    forall l e. l -> e -> GenLocated l e
    L SrcSpan
    loc (XVar GhcRn -> Located (IdP GhcRn) -> HsExpr GhcRn
    forall p. XVar p -> Located (IdP p) -> HsExpr p
    HsVar NoExtField
    XVar GhcRn
    noExtField (SrcSpan -> Name -> Located Name
    forall l e. l -> e -> GenLocated l e
    L SrcSpan
    loc Name
    field_var)))
        mk_sel_pat :: ConLike -> Pat GhcRn
    mk_sel_pat ConLike
    con = XConPat GhcRn
    -> Located (ConLikeP GhcRn) -> HsConPatDetails GhcRn -> Pat GhcRn
    forall p.
    XConPat p -> Located (ConLikeP p) -> HsConPatDetails p -> Pat p
    ConPat NoExtField
    XConPat GhcRn
    NoExtField (SrcSpan -> Name -> Located Name
    forall l e. l -> e -> GenLocated l e
    L SrcSpan
    loc (ConLike -> Name
    forall a. NamedThing a => a -> Name
    getName ConLike
    con)) (HsRecFields GhcRn (GenLocated SrcSpan (Pat GhcRn))
    -> HsConDetails
         (GenLocated SrcSpan (Pat GhcRn))
         (HsRecFields GhcRn (GenLocated SrcSpan (Pat GhcRn)))
    forall arg rec. rec -> HsConDetails arg rec
    RecCon HsRecFields GhcRn (GenLocated SrcSpan (Pat GhcRn))
    rec_fields)
        rec_fields :: HsRecFields GhcRn (GenLocated SrcSpan (Pat GhcRn))
    rec_fields = HsRecFields :: forall p arg.
    [LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
    HsRecFields { rec_flds :: [LHsRecField GhcRn (GenLocated SrcSpan (Pat GhcRn))]
    rec_flds = [LHsRecField GhcRn (GenLocated SrcSpan (Pat GhcRn))
    rec_field], rec_dotdot :: Maybe (Located Int)
    rec_dotdot = Maybe (Located Int)
    forall a. Maybe a
    Nothing }
        rec_field :: LHsRecField GhcRn (GenLocated SrcSpan (Pat GhcRn))
    rec_field  = HsRecField' (FieldOcc GhcRn) (GenLocated SrcSpan (Pat GhcRn))
    -> LHsRecField GhcRn (GenLocated SrcSpan (Pat GhcRn))
    forall e. e -> Located e
    noLoc (HsRecField :: forall id arg. Located id -> arg -> Bool -> HsRecField' id arg
    HsRecField
                            { hsRecFieldLbl :: Located (FieldOcc GhcRn)
    hsRecFieldLbl
                               = SrcSpan -> FieldOcc GhcRn -> Located (FieldOcc GhcRn)
    forall l e. l -> e -> GenLocated l e
    L SrcSpan
    loc (XCFieldOcc GhcRn -> Located RdrName -> FieldOcc GhcRn
    forall pass. XCFieldOcc pass -> Located RdrName -> FieldOcc pass
    FieldOcc Name
    XCFieldOcc GhcRn
    sel_name
                                         (SrcSpan -> RdrName -> Located RdrName
    forall l e. l -> e -> GenLocated l e
    L SrcSpan
    loc (RdrName -> Located RdrName) -> RdrName -> Located RdrName
    forall a b. (a -> b) -> a -> b
    $ FieldLabelString -> RdrName
    mkVarUnqual FieldLabelString
    lbl))
                            , hsRecFieldArg :: GenLocated SrcSpan (Pat GhcRn)
    hsRecFieldArg
                               = SrcSpan -> Pat GhcRn -> GenLocated SrcSpan (Pat GhcRn)
    forall l e. l -> e -> GenLocated l e
    L SrcSpan
    loc (XVarPat GhcRn -> Located (IdP GhcRn) -> Pat GhcRn
    forall p. XVarPat p -> Located (IdP p) -> Pat p
    VarPat NoExtField
    XVarPat GhcRn
    noExtField (SrcSpan -> Name -> Located Name
    forall l e. l -> e -> GenLocated l e
    L SrcSpan
    loc Name
    field_var))
                            , hsRecPun :: Bool
    hsRecPun = Bool
    False })
        sel_lname :: Located Name
    sel_lname = SrcSpan -> Name -> Located Name
    forall l e. l -> e -> GenLocated l e
    L SrcSpan
    loc Name
    sel_name
        field_var :: Name
    field_var = Unique -> OccName -> SrcSpan -> Name
    mkInternalName (Int -> Unique
    mkBuiltinUnique Int
    1) (Name -> OccName
    forall a. NamedThing a => a -> OccName
    getOccName Name
    sel_name) SrcSpan
    loc

        -- Add catch-all default case unless the case is exhaustive
        -- We do this explicitly so that we get a nice error message that
        -- mentions this particular record selector
        deflt :: [LMatch GhcRn (LHsExpr GhcRn)]
    deflt | (ConLike -> Bool) -> [ConLike] -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    all ConLike -> Bool
    dealt_with [ConLike]
    all_cons = []
              | Bool
    otherwise = [HsMatchContext (NoGhcTc GhcRn)
    -> [LPat GhcRn] -> LHsExpr GhcRn -> LMatch GhcRn (LHsExpr GhcRn)
    forall (p :: Pass) (body :: * -> *).
    HsMatchContext (NoGhcTc (GhcPass p))
    -> [LPat (GhcPass p)]
    -> Located (body (GhcPass p))
    -> LMatch (GhcPass p) (Located (body (GhcPass p)))
    mkSimpleMatch HsMatchContext (NoGhcTc GhcRn)
    forall p. HsMatchContext p
    CaseAlt
                                [SrcSpan -> Pat GhcRn -> GenLocated SrcSpan (Pat GhcRn)
    forall l e. l -> e -> GenLocated l e
    L SrcSpan
    loc (XWildPat GhcRn -> Pat GhcRn
    forall p. XWildPat p -> Pat p
    WildPat NoExtField
    XWildPat GhcRn
    noExtField)]
                                (LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
    forall (id :: Pass).
    LHsExpr (GhcPass id)
    -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
    mkHsApp (SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn
    forall l e. l -> e -> GenLocated l e
    L SrcSpan
    loc (XVar GhcRn -> Located (IdP GhcRn) -> HsExpr GhcRn
    forall p. XVar p -> Located (IdP p) -> HsExpr p
    HsVar NoExtField
    XVar GhcRn
    noExtField
                                             (SrcSpan -> Name -> Located Name
    forall l e. l -> e -> GenLocated l e
    L SrcSpan
    loc (Id -> Name
    forall a. NamedThing a => a -> Name
    getName Id
    rEC_SEL_ERROR_ID))))
                                         (SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn
    forall l e. l -> e -> GenLocated l e
    L SrcSpan
    loc (XLitE GhcRn -> HsLit GhcRn -> HsExpr GhcRn
    forall p. XLitE p -> HsLit p -> HsExpr p
    HsLit NoExtField
    XLitE GhcRn
    noExtField HsLit GhcRn
    msg_lit)))]

            -- Do not add a default case unless there are unmatched
            -- constructors.  We must take account of GADTs, else we
            -- get overlap warning messages from the pattern-match checker
            -- NB: we need to pass type args for the *representation* TyCon
            --     to dataConCannotMatch, hence the calculation of inst_tys
            --     This matters in data families
            --              data instance T Int a where
            --                 A :: { fld :: Int } -> T Int Bool
            --                 B :: { fld :: Int } -> T Int Char
        dealt_with :: ConLike -> Bool
        dealt_with :: ConLike -> Bool
    dealt_with (PatSynCon PatSyn
    _) = Bool
    False -- We can't predict overlap
        dealt_with con :: ConLike
    con@(RealDataCon DataCon
    dc) =
          ConLike
    con ConLike -> [ConLike] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [ConLike]
    cons_w_field Bool -> Bool -> Bool
    || [PredType] -> DataCon -> Bool
    dataConCannotMatch [PredType]
    inst_tys DataCon
    dc

        ([Id]
    univ_tvs, [Id]
    _, [EqSpec]
    eq_spec, [PredType]
    _, [PredType]
    req_theta, [Scaled PredType]
    _, PredType
    data_ty) = ConLike
    -> ([Id], [Id], [EqSpec], [PredType], [PredType],
        [Scaled PredType], PredType)
    conLikeFullSig ConLike
    con1

        eq_subst :: TCvSubst
    eq_subst = [(Id, PredType)] -> TCvSubst
    mkTvSubstPrs ((EqSpec -> (Id, PredType)) -> [EqSpec] -> [(Id, PredType)]
    forall a b. (a -> b) -> [a] -> [b]
    map EqSpec -> (Id, PredType)
    eqSpecPair [EqSpec]
    eq_spec)
        -- inst_tys corresponds to one of the following:
        --
        -- * The arguments to the user-written return type (for GADT constructors).
        --   In this scenario, eq_subst provides a mapping from the universally
        --   quantified type variables to the argument types. Note that eq_subst
        --   does not need to be applied to any other part of the DataCon
        --   (see Note [The dcEqSpec domain invariant] in GHC.Core.DataCon).
        -- * The universally quantified type variables
        --   (for Haskell98-style constructors and pattern synonyms). In these
        --   scenarios, eq_subst is an empty substitution.
        inst_tys :: [PredType]
    inst_tys = TCvSubst -> [Id] -> [PredType]
    substTyVars TCvSubst
    eq_subst [Id]
    univ_tvs

        unit_rhs :: LHsExpr (GhcPass a)
    unit_rhs = [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)
    forall (a :: Pass). [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)
    mkLHsTupleExpr []
        msg_lit :: HsLit GhcRn
    msg_lit = XHsStringPrim GhcRn -> ByteString -> HsLit GhcRn
    forall x. XHsStringPrim x -> ByteString -> HsLit x
    HsStringPrim SourceText
    XHsStringPrim GhcRn
    NoSourceText (FieldLabelString -> ByteString
    bytesFS FieldLabelString
    lbl)

    {-
    Note [Polymorphic selectors]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    We take care to build the type of a polymorphic selector in the right
    order, so that visible type application works according to the specification in
    the GHC User's Guide (see the "Field selectors and TypeApplications" section).
    We won't bother rehashing the entire specification in this Note, but the tricky
    part is dealing with GADT constructor fields. Here is an appropriately tricky
    example to illustrate the challenges:

      {-# LANGUAGE PolyKinds #-}
      data T a b where
        MkT :: forall b a x.
               { field1 :: forall c. (Num a, Show c) => (Either a c, Proxy b)
               , field2 :: x
               }
            -> T a b

    Our goal is to obtain the following type for `field1`:

      field1 :: forall {k} (b :: k) a.
                T a b -> forall c. (Num a, Show c) => (Either a c, Proxy b)

    (`field2` is naughty, per Note [Naughty record selectors], so we cannot turn
    it into a top-level field selector.)

    Some potential gotchas, inspired by #18023:

    1. Since the user wrote `forall b a x.` in the type of `MkT`, we want the `b`
       to appear before the `a` when quantified in the type of `field1`.
    2. On the other hand, we *don't* want to quantify `x` in the type of `field1`.
       This is because `x` does not appear in the GADT return type, so it is not
       needed in the selector type.
    3. Because of PolyKinds, the kind of `b` is generalized to `k`. Moreover, since
       this `k` is not written in the source code, it is inferred (i.e., not
       available for explicit type applications) and thus written as {k} in the type
       of `field1`.

    In order to address these gotchas, we start by looking at the
    conLikeUserTyVarBinders, which gives the order and specificity of each binder.
    This effectively solves (1) and (3). To solve (2), we filter the binders to
    leave only those that are needed for the selector type.

    Note [Naughty record selectors]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    A "naughty" field is one for which we can't define a record
    selector, because an existential type variable would escape.  For example:
            data T = forall a. MkT { x,y::a }
    We obviously can't define
            x (MkT v _) = v
    Nevertheless we *do* put a RecSelId into the type environment
    so that if the user tries to use 'x' as a selector we can bleat
    helpfully, rather than saying unhelpfully that 'x' is not in scope.
    Hence the sel_naughty flag, to identify record selectors that don't really exist.

    In general, a field is "naughty" if its type mentions a type variable that
    isn't in the result type of the constructor.  Note that this *allows*
    GADT record selectors (Note [GADT record selectors]) whose types may look
    like     sel :: T [a] -> a

    For naughty selectors we make a dummy binding
       sel = ()
    so that the later type-check will add them to the environment, and they'll be
    exported.  The function is never called, because the typechecker spots the
    sel_naughty field.

    Note [GADT record selectors]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    For GADTs, we require that all constructors with a common field 'f' have the same
    result type (modulo alpha conversion).  [Checked in GHC.Tc.TyCl.checkValidTyCon]
    E.g.
            data T where
              T1 { f :: Maybe a } :: T [a]
              T2 { f :: Maybe a, y :: b  } :: T [a]
              T3 :: T Int

    and now the selector takes that result type as its argument:
       f :: forall a. T [a] -> Maybe a

    Details: the "real" types of T1,T2 are:
       T1 :: forall r a.   (r~[a]) => a -> T r
       T2 :: forall r a b. (r~[a]) => a -> b -> T r

    So the selector loooks like this:
       f :: forall a. T [a] -> Maybe a
       f (a:*) (t:T [a])
         = case t of
             T1 c   (g:[a]~[c]) (v:Maybe c)       -> v `cast` Maybe (right (sym g))
             T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g))
             T3 -> error "T3 does not have field f"

    Note the forall'd tyvars of the selector are just the free tyvars
    of the result type; there may be other tyvars in the constructor's
    type (e.g. 'b' in T2).

    Note the need for casts in the result!

    Note [Selector running example]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    It's OK to combine GADTs and type families.  Here's a running example:

            data instance T [a] where
              T1 { fld :: b } :: T [Maybe b]

    The representation type looks like this
            data :R7T a where
              T1 { fld :: b } :: :R7T (Maybe b)

    and there's coercion from the family type to the representation type
            :CoR7T a :: T [a] ~ :R7T a

    The selector we want for fld looks like this:

            fld :: forall b. T [Maybe b] -> b
            fld = /\b. \(d::T [Maybe b]).
                  case d `cast` :CoR7T (Maybe b) of
                    T1 (x::b) -> x

    The scrutinee of the case has type :R7T (Maybe b), which can be
    gotten by applying the eq_spec to the univ_tvs of the data con.

    Note [Impredicative record selectors]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    There are situations where generating code for record selectors requires the
    use of ImpredicativeTypes. Here is one example (adapted from #18005):

      type S = (forall b. b -> b) -> Int
      data T = MkT {unT :: S}
             | Dummy

    We want to generate HsBinds for unT that look something like this:

      unT :: S
      unT (MkT x) = x
      unT _       = recSelError "unT"#

    Note that the type of recSelError is `forall r (a :: TYPE r). Addr# -> a`.
    Therefore, when used in the right-hand side of `unT`, GHC attempts to
    instantiate `a` with `(forall b. b -> b) -> Int`, which is impredicative.
    To make sure that GHC is OK with this, we enable ImpredicativeTypes interally
    when typechecking these HsBinds so that the user does not have to.

    Although ImpredicativeTypes is somewhat fragile and unpredictable in GHC right
    now, it will become robust when Quick Look impredicativity is implemented. In
    the meantime, using ImpredicativeTypes to instantiate the `a` type variable in
    recSelError's type does actually work, so its use here is benign.
    -}