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

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

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

-}

-- | 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.Tc.Utils.TcType

import GHC.Builtin.Types( unitTy )
import GHC.Builtin.Uniques ( mkBuiltinUnique )

import GHC.Hs

import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) )
import GHC.Core.Multiplicity
import GHC.Core.Predicate
import GHC.Core.Make( rEC_SEL_ERROR_ID )
import GHC.Core.Class
import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Core.ConLike
import GHC.Core.DataCon
import GHC.Core.TyCon.Set
import GHC.Core.Coercion ( ltRole )

import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.FV as FV

import GHC.Data.Maybe
import GHC.Data.Bag
import GHC.Data.FastString

import GHC.Unit.Module

import GHC.Types.Basic
import GHC.Types.FieldLabel
import GHC.Types.SrcLoc
import GHC.Types.SourceFile
import GHC.Types.SourceText
import GHC.Types.Name
import GHC.Types.Name.Env
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.Types.Unique.Set
import GHC.Types.TyThing
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
  = 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 forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` forall {t :: * -> *}. Foldable t => t PredType -> NameEnv TyCon
go_s [PredType]
tys
     go (LitTy TyLit
_)         = forall a. NameEnv a
emptyNameEnv
     go (TyVarTy Id
_)       = forall a. NameEnv a
emptyNameEnv
     go (AppTy PredType
a PredType
b)       = PredType -> NameEnv TyCon
go PredType
a 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 forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` PredType -> NameEnv TyCon
go PredType
a 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 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    = 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 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 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 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 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 forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` KindCoercion -> NameEnv TyCon
go_co KindCoercion
co forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` KindCoercion -> NameEnv TyCon
go_co KindCoercion
co'
     go_co (CoVarCo Id
_)            = forall a. NameEnv a
emptyNameEnv
     go_co (HoleCo {})            = 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 forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` PredType -> NameEnv TyCon
go PredType
ty 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 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 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
_)       = forall a. NameEnv a
emptyNameEnv
     go_prov (CorePrepProv Bool
_)     = forall a. NameEnv a
emptyNameEnv

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

-- TODO: TyConSet is implemented as IntMap over uniques.
-- But we could get away with something based on IntSet
-- since we only check membershib, but never extract the
-- elements.
type SynCycleState = TyConSet

instance Applicative SynCycleM where
    pure :: forall a. a -> SynCycleM a
pure a
x = forall a.
(SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
-> SynCycleM a
SynCycleM forall a b. (a -> b) -> a -> b
$ \SynCycleState
state -> forall a b. b -> Either a b
Right (a
x, SynCycleState
state)
    <*> :: forall a 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 = forall a.
(SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
-> SynCycleM a
SynCycleM forall a b. (a -> b) -> a -> b
$ \SynCycleState
state ->
        case forall a.
SynCycleM a
-> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
runSynCycleM SynCycleM a
m SynCycleState
state of
            Right (a
x, SynCycleState
state') ->
                forall a.
SynCycleM a
-> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
runSynCycleM (a -> SynCycleM b
f a
x) SynCycleState
state'
            Left (SrcSpan, SDoc)
err -> forall a b. a -> Either a b
Left (SrcSpan, SDoc)
err

failSynCycleM :: SrcSpan -> SDoc -> SynCycleM ()
failSynCycleM :: SrcSpan -> SDoc -> SynCycleM ()
failSynCycleM SrcSpan
loc SDoc
err = forall a.
(SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
-> SynCycleM a
SynCycleM forall a b. (a -> b) -> a -> b
$ \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.
checkTyConIsAcyclic :: TyCon -> SynCycleM () -> SynCycleM ()
checkTyConIsAcyclic :: TyCon -> SynCycleM () -> SynCycleM ()
checkTyConIsAcyclic TyCon
tc SynCycleM ()
m = forall a.
(SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState))
-> SynCycleM a
SynCycleM forall a b. (a -> b) -> a -> b
$ \SynCycleState
s ->
    if TyCon
tc TyCon -> SynCycleState -> Bool
`elemTyConSet` SynCycleState
s
        then forall a b. b -> Either a b
Right ((), SynCycleState
s) -- short circuit
        else case forall a.
SynCycleM a
-> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
runSynCycleM SynCycleM ()
m SynCycleState
s of
                Right ((), SynCycleState
s') -> forall a b. b -> Either a b
Right ((), SynCycleState -> TyCon -> SynCycleState
extendTyConSet SynCycleState
s' TyCon
tc)
                Left (SrcSpan, SDoc)
err -> 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 (GhcPass 'Renamed)] -> TcM ()
checkSynCycles Unit
this_uid [TyCon]
tcs [LTyClDecl (GhcPass 'Renamed)]
tyclds =
    case forall a.
SynCycleM a
-> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
runSynCycleM (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SynCycleState -> [TyCon] -> TyCon -> SynCycleM ()
go SynCycleState
emptyTyConSet []) [TyCon]
tcs) SynCycleState
emptyTyConSet of
        Left (SrcSpan
loc, SDoc
err) -> forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan SrcSpan
loc forall a b. (a -> b) -> a -> b
$ forall a. SDoc -> TcM a
failWithTc SDoc
err
        Right ((), SynCycleState)
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    -- Try our best to print the LTyClDecl for locally defined things
    lcl_decls :: NameEnv (GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed)))
lcl_decls = forall a. [(Name, a)] -> NameEnv a
mkNameEnv (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map TyCon -> Name
tyConName [TyCon]
tcs) [LTyClDecl (GhcPass 'Renamed)]
tyclds)

    -- Short circuit if we've already seen this Name and concluded
    -- it was acyclic.
    go :: TyConSet -> [TyCon] -> TyCon -> SynCycleM ()
    go :: SynCycleState -> [TyCon] -> TyCon -> SynCycleM ()
go SynCycleState
so_far [TyCon]
seen_tcs TyCon
tc =
        TyCon -> SynCycleM () -> SynCycleM ()
checkTyConIsAcyclic TyCon
tc 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' :: TyConSet -> [TyCon] -> TyCon -> SynCycleM ()
    go' :: SynCycleState -> [TyCon] -> TyCon -> SynCycleM ()
go' SynCycleState
so_far [TyCon]
seen_tcs TyCon
tc
        | TyCon
tc TyCon -> SynCycleState -> Bool
`elemTyConSet` SynCycleState
so_far
            = SrcSpan -> SDoc -> SynCycleM ()
failSynCycleM (forall a. NamedThing a => a -> SrcSpan
getSrcSpan (forall a. [a] -> a
head [TyCon]
seen_tcs)) 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 (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 (forall u. GenModule (GenUnit u) -> Bool
isHoleModule Module
mod Bool -> Bool -> Bool
||
               forall unit. GenModule unit -> unit
moduleUnit Module
mod forall a. Eq a => a -> a -> Bool
== Unit
this_uid Bool -> Bool -> Bool
||
               Module -> Bool
isInteractiveModule Module
mod)
            = 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 -> TyCon -> SynCycleState
extendTyConSet SynCycleState
so_far TyCon
tc) (TyCon
tcforall a. a -> [a] -> [a]
:[TyCon]
seen_tcs) PredType
ty
        | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
      where
        n :: Name
n = TyCon -> Name
tyConName TyCon
tc
        mod :: Module
mod = HasDebugCallStack => Name -> Module
nameModule Name
n
        ppr_decl :: TyCon -> SDoc
ppr_decl TyCon
tc =
          case forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv NameEnv (GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed)))
lcl_decls Name
n of
            Just (L SrcSpanAnnA
loc TyClDecl (GhcPass 'Renamed)
decl) -> forall a. Outputable a => a -> SDoc
ppr (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyClDecl (GhcPass 'Renamed)
decl
            Maybe (GenLocated SrcSpanAnnA (TyClDecl (GhcPass 'Renamed)))
Nothing -> forall a. Outputable a => a -> SDoc
ppr (forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
n) SDoc -> SDoc -> SDoc
<> SDoc
colon SDoc -> SDoc -> 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 :: TyConSet -> [TyCon] -> Type -> SynCycleM ()
    go_ty :: SynCycleState -> [TyCon] -> PredType -> SynCycleM ()
go_ty SynCycleState
so_far [TyCon]
seen_tcs PredType
ty =
        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.
-}

type ClassSet = UniqSet Class

checkClassCycles :: Class -> Maybe SDoc
-- Nothing  <=> ok
-- Just err <=> possible cycle error
checkClassCycles :: Class -> Maybe SDoc
checkClassCycles Class
cls
  = do { (Bool
definite_cycle, SDoc
err) <- ClassSet -> Class -> [PredType] -> Maybe (Bool, SDoc)
go (forall a. Uniquable a => a -> UniqSet a
unitUniqSet 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"
       ; forall (m :: * -> *) a. Monad m => a -> m a
return ([SDoc] -> SDoc
vcat [ SDoc
herald SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (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 :: ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc)
    go :: ClassSet -> Class -> [PredType] -> Maybe (Bool, SDoc)
go ClassSet
so_far Class
cls [PredType]
tys = forall (f :: * -> *) a. Foldable f => f (Maybe a) -> Maybe a
firstJusts forall a b. (a -> b) -> a -> b
$
                        forall a b. (a -> b) -> [a] -> [b]
map (ClassSet -> PredType -> Maybe (Bool, SDoc)
go_pred ClassSet
so_far) forall a b. (a -> b) -> a -> b
$
                        Class -> [PredType] -> [PredType]
immSuperClasses Class
cls [PredType]
tys

    go_pred :: ClassSet -> PredType -> Maybe (Bool, SDoc)
       -- Nothing <=> ok
       -- Just (True, err)  <=> definite cycle
       -- Just (False, err) <=> possible cycle
    go_pred :: ClassSet -> PredType -> Maybe (Bool, SDoc)
go_pred ClassSet
so_far PredType
pred  -- NB: tcSplitTyConApp looks through synonyms
       | Just (TyCon
tc, [PredType]
tys) <- HasCallStack => PredType -> Maybe (TyCon, [PredType])
tcSplitTyConApp_maybe PredType
pred
       = ClassSet -> PredType -> TyCon -> [PredType] -> Maybe (Bool, SDoc)
go_tc ClassSet
so_far PredType
pred TyCon
tc [PredType]
tys
       | PredType -> Bool
hasTyVarHead PredType
pred
       = 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 (forall a. Outputable a => a -> SDoc
ppr PredType
pred)))
       | Bool
otherwise
       = forall a. Maybe a
Nothing

    go_tc :: ClassSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc)
    go_tc :: ClassSet -> PredType -> TyCon -> [PredType] -> Maybe (Bool, SDoc)
go_tc ClassSet
so_far PredType
pred TyCon
tc [PredType]
tys
      | TyCon -> Bool
isFamilyTyCon TyCon
tc
      = 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 (forall a. Outputable a => a -> SDoc
ppr PredType
pred)))
      | Just Class
cls <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc
      = ClassSet -> Class -> [PredType] -> Maybe (Bool, SDoc)
go_cls ClassSet
so_far Class
cls [PredType]
tys
      | Bool
otherwise   -- Equality predicate, for example
      = forall a. Maybe a
Nothing

    go_cls :: ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc)
    go_cls :: ClassSet -> Class -> [PredType] -> Maybe (Bool, SDoc)
go_cls ClassSet
so_far Class
cls [PredType]
tys
       | Class
cls forall a. Uniquable a => a -> UniqSet a -> Bool
`elementOfUniqSet` ClassSet
so_far
       = forall a. a -> Maybe a
Just (Bool
True, String -> SDoc
text String
"one of whose superclasses is" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (forall a. Outputable a => a -> SDoc
ppr Class
cls))
       | Class -> Bool
isCTupleClass Class
cls
       = ClassSet -> Class -> [PredType] -> Maybe (Bool, SDoc)
go ClassSet
so_far Class
cls [PredType]
tys
       | Bool
otherwise
       = do { (Bool
b,SDoc
err) <- ClassSet -> Class -> [PredType] -> Maybe (Bool, SDoc)
go  (ClassSet
so_far forall a. Uniquable a => UniqSet a -> a -> UniqSet a
`addOneToUniqSet` Class
cls) Class
cls [PredType]
tys
          ; 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 (forall a. Outputable a => a -> SDoc
ppr Class
cls)
                       SDoc -> SDoc -> SDoc
$$ SDoc
err) }

{-
************************************************************************
*                                                                      *
        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 forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv RoleEnv
role_env' Name
name of
      Just [Role]
roles -> [Role]
roles
      Maybe [Role]
Nothing    -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"inferRoles" (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 = forall a. NameEnv a -> [(Name, a)] -> NameEnv a
extendNameEnvList forall a. NameEnv a
emptyNameEnv forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                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, forall a b. (a -> b) -> [a] -> [b]
map (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             = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"initialRoleEnv1" (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     = forall a b. (a -> b) -> [a] -> [b]
map TyConBinder -> ArgFlag
tyConBinderArgFlag [TyConBinder]
bndrs
        num_exps :: Int
num_exps     = 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 (GhcPass 'Renamed))
lookupRoleAnnot RoleAnnotEnv
annots_env Name
name of
              Just (L SrcSpanAnnA
_ (RoleAnnotDecl XCRoleAnnotDecl (GhcPass 'Renamed)
_ LIdP (GhcPass 'Renamed)
_ [XRec (GhcPass 'Renamed) (Maybe Role)]
annots))
                | [XRec (GhcPass 'Renamed) (Maybe Role)]
annots forall a. [a] -> Int -> Bool
`lengthIs` Int
num_exps -> forall a b. (a -> b) -> [a] -> [b]
map forall l e. GenLocated l e -> e
unLoc [XRec (GhcPass 'Renamed) (Maybe Role)]
annots
              Maybe (LRoleAnnotDecl (GhcPass 'Renamed))
_                              -> forall a. Int -> a -> [a]
replicate Int
num_exps 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 forall a. Maybe a -> a -> a
`orElse` Role
default_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 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]
_ = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"initialRoleEnv1 (2)"
                                           ([SDoc] -> SDoc
vcat [forall a. Outputable a => a -> SDoc
ppr TyCon
tc, 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 forall a b. (a -> b) -> a -> b
$ 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
       ; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== Role
Nominal) [Role]
old_roles) forall a b. (a -> b) -> a -> b
$  -- also catches data families,
                                                -- which don't want or need role inference
         forall a. TyCon -> RoleM a -> RoleM a
irTcTyVars TyCon
tc forall a b. (a -> b) -> a -> b
$
         do { 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
            ; forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (TyCon -> Maybe Class
tyConClass_maybe TyCon
tc) Class -> RoleM ()
irClass
            ; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DataCon -> RoleM ()
irDataCon (AlgTyConRhs -> [DataCon]
visibleDataCons forall a b. (a -> b) -> a -> b
$ TyCon -> AlgTyConRhs
algTyConRhs TyCon
tc) }}

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

  | Bool
otherwise
  = 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
  = 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
      = 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 = forall a. (a -> Bool) -> [a] -> [a]
filter (Id -> VarSet -> Bool
`elemVarSet` VarSet
cls_tv_set) 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
  = forall a. [Id] -> RoleM a -> RoleM a
setRoleInferenceVars [Id]
univ_tvs forall a b. (a -> b) -> a -> b
$
    forall a. [Id] -> (VarSet -> RoleM a) -> RoleM a
irExTyVars [Id]
ex_tvs forall a b. (a -> b) -> a -> b
$ \ VarSet
ex_var_set ->
      do 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 forall a. [a] -> [a] -> [a]
++ [PredType]
theta forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. Scaled a -> a
scaledThing [Scaled PredType]
arg_tys)
         forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (VarSet -> PredType -> RoleM ()
markNominal VarSet
ex_var_set) (forall a b. (a -> b) -> [a] -> [b]
map Id -> PredType
tyVarKind [Id]
ex_tvs forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map 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)       = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Id
tv Id -> VarSet -> Bool
`elemVarSet` VarSet
lcls) 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 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
                                    ; 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 = 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VarSet -> PredType -> RoleM ()
go VarSet
lcls PredType
arg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> VarSet -> PredType -> RoleM ()
go VarSet
lcls PredType
res
    go VarSet
_    (LitTy {})         = 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
_)     = forall (m :: * -> *) a. Monad m => a -> m a
return ()

    go_app :: VarSet -> Role -> PredType -> RoleM ()
go_app VarSet
_ Role
Phantom PredType
_ = 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
  = forall a. Name -> RoleM a -> RoleM a
setRoleInferenceTc (TyCon -> Name
tyConName TyCon
tc) 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)
                     ; forall a. Id -> RoleM a -> RoleM a
addRoleInferenceVar Id
tv 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 forall a b. (a -> b) -> a -> b
$ PredType -> FV
get_ty_vars PredType
ty) in
                      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)  = 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
       ; forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Role]
roles forall a. [a] -> [a] -> [a]
++ 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 forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv RoleEnv
env (TyCon -> Name
tyConName TyCon
tc) of
           Just [Role]
roles -> forall (m :: * -> *) a. Monad m => a -> m a
return [Role]
roles
           Maybe [Role]
Nothing    -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv VarPositions
var_ns Id
tv of
           Maybe Int
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"updateRole" (forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr Id
tv SDoc -> SDoc -> 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 -> 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 = forall a.
(Maybe Name
 -> VarPositions
 -> Int
 -> RoleInferenceState
 -> (a, RoleInferenceState))
-> RoleM a
RM 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
(<*>) = 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  = forall a.
(Maybe Name
 -> VarPositions
 -> Int
 -> RoleInferenceState
 -> (a, RoleInferenceState))
-> RoleM a
RM forall a b. (a -> b) -> a -> b
$ \Maybe Name
m_info VarPositions
vps Int
nvps RoleInferenceState
state ->
                  let (a
a', RoleInferenceState
state') = 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
                  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 }
          = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a.
RoleM a
-> Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM RoleM ()
thing forall a. Maybe a
Nothing forall a. VarEnv a
emptyVarEnv Int
0 RoleInferenceState
state
        state :: RoleInferenceState
state = 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 = forall a.
(Maybe Name
 -> VarPositions
 -> Int
 -> RoleInferenceState
 -> (a, RoleInferenceState))
-> RoleM a
RM 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 )
                                forall a.
RoleM a
-> Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM RoleM a
thing (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
  = forall a.
(Maybe Name
 -> VarPositions
 -> Int
 -> RoleInferenceState
 -> (a, RoleInferenceState))
-> RoleM a
RM forall a b. (a -> b) -> a -> b
$ \Maybe Name
m_name VarPositions
vps Int
nvps RoleInferenceState
state ->
    ASSERT( isJust m_name )
    forall a.
RoleM a
-> Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM RoleM a
thing Maybe Name
m_name (forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv VarPositions
vps Id
tv Int
nvps) (Int
nvpsforall 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
  = forall a.
(Maybe Name
 -> VarPositions
 -> Int
 -> RoleInferenceState
 -> (a, RoleInferenceState))
-> RoleM a
RM forall a b. (a -> b) -> a -> b
$ \Maybe Name
m_name VarPositions
_vps Int
_nvps RoleInferenceState
state ->
    ASSERT( isJust m_name )
    forall a.
RoleM a
-> Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM RoleM a
thing Maybe Name
m_name (forall a. [(Id, a)] -> VarEnv a
mkVarEnv (forall a b. [a] -> [b] -> [(a, b)]
zip [Id]
tvs [Int
0..])) (forall a. String -> a
panic String
"setRoleInferenceVars")
         RoleInferenceState
state

getRoleEnv :: RoleM RoleEnv
getRoleEnv :: RoleM RoleEnv
getRoleEnv = forall a.
(Maybe Name
 -> VarPositions
 -> Int
 -> RoleInferenceState
 -> (a, RoleInferenceState))
-> RoleM a
RM 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 = forall a.
(Maybe Name
 -> VarPositions
 -> Int
 -> RoleInferenceState
 -> (a, RoleInferenceState))
-> RoleM a
RM 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 = forall a.
(Maybe Name
 -> VarPositions
 -> Int
 -> RoleInferenceState
 -> (a, RoleInferenceState))
-> RoleM a
RM forall a b. (a -> b) -> a -> b
$ \Maybe Name
m_name VarPositions
_ Int
_ RoleInferenceState
state ->
                    case Maybe Name
m_name of
                      Maybe Name
Nothing   -> 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
  = forall a.
(Maybe Name
 -> VarPositions
 -> Int
 -> RoleInferenceState
 -> (a, RoleInferenceState))
-> RoleM a
RM 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 forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv RoleEnv
role_env Name
name of
           Maybe [Role]
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"updateRoleEnv" (forall a. Outputable a => a -> SDoc
ppr Name
name)
           Just [Role]
roles -> let ([Role]
before, Role
old_role : [Role]
after) = 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 forall a. [a] -> [a] -> [a]
++ Role
role forall a. a -> [a] -> [a]
: [Role]
after
                                  role_env' :: RoleEnv
role_env' = forall a. NameEnv a -> Name -> a -> NameEnv a
extendNameEnv RoleEnv
role_env Name
name [Role]
roles' in
                              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
  = forall r. [TyCon] -> TcM r -> TcM r
tcExtendTyConEnv [TyCon]
tyclss                    forall a b. (a -> b) -> a -> b
$
    forall r. [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnvImplicit [TyThing]
implicit_things  forall a b. (a -> b) -> a -> b
$
    forall a. [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv [Id]
def_meth_ids          forall a b. (a -> b) -> a -> b
$
    do { String -> SDoc -> TcM ()
traceTc String
"tcAddTyCons" forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
            [ String -> SDoc
text String
"tycons" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TyCon]
tyclss
            , String -> SDoc
text String
"implicits" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [TyThing]
implicit_things ]
       ; [(Id, LHsBind (GhcPass 'Renamed))] -> TcM TcGblEnv
tcRecSelBinds ([TyCon] -> [(Id, LHsBind (GhcPass 'Renamed))]
mkRecSelBinds [TyCon]
tyclss) }
 where
   implicit_things :: [TyThing]
implicit_things = 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 (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  = forall a. [VarBndr a Specificity] -> [VarBndr a ArgFlag]
tyVarSpecToBinders forall a b. (a -> b) -> a -> b
$ [TyConBinder] -> [InvisTVBinder]
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 (GhcPass 'Renamed))] -> TcM TcGblEnv
tcRecSelBinds [(Id, LHsBind (GhcPass 'Renamed))]
sel_bind_prs
  = forall a. [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv [Id
sel_id | (L SrcSpanAnnA
_ (IdSig XIdSig (GhcPass 'Renamed)
_ Id
sel_id)) <- [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
sigs] forall a b. (a -> b) -> a -> b
$
    do { ([(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
rec_sel_binds, TcGblEnv
tcg_env) <- forall a. TcRn a -> TcRn a
discardWarnings forall a b. (a -> b) -> a -> b
$
                                     -- See Note [Impredicative record selectors]
                                     forall gbl lcl a. Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setXOptM Extension
LangExt.ImpredicativeTypes forall a b. (a -> b) -> a -> b
$
                                     forall thing.
TopLevelFlag
-> [(RecFlag, LHsBinds (GhcPass 'Renamed))]
-> [LSig (GhcPass 'Renamed)]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTc)], thing)
tcValBinds TopLevelFlag
TopLevel [(RecFlag,
  Bag
    (GenLocated
       SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))))]
binds [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
sigs forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
       ; forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tcg_env TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv
`addTypecheckedBinds` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(RecFlag, Bag (GenLocated SrcSpanAnnA (HsBindLR GhcTc GhcTc)))]
rec_sel_binds) }
  where
    sigs :: [GenLocated SrcSpanAnnA (Sig (GhcPass 'Renamed))]
sigs = [ forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (forall pass. XIdSig pass -> Id -> Sig pass
IdSig NoExtField
noExtField Id
sel_id)
                                             | (Id
sel_id, GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
_) <- [(Id, LHsBind (GhcPass 'Renamed))]
sel_bind_prs
                                             , let loc :: SrcSpan
loc = forall a. NamedThing a => a -> SrcSpan
getSrcSpan Id
sel_id ]
    binds :: [(RecFlag,
  Bag
    (GenLocated
       SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))))]
binds = [(RecFlag
NonRecursive, forall a. a -> Bag a
unitBag GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
bind) | (Id
_, GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed))
bind) <- [(Id, LHsBind (GhcPass 'Renamed))]
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 (GhcPass 'Renamed))]
mkRecSelBinds [TyCon]
tycons
  = forall a b. (a -> b) -> [a] -> [b]
map (TyCon, FieldLabel) -> (Id, LHsBind (GhcPass 'Renamed))
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 (GhcPass 'Renamed))
mkRecSelBind (TyCon
tycon, FieldLabel
fl)
  = [ConLike]
-> RecSelParent
-> FieldLabel
-> FieldSelectors
-> (Id, LHsBind (GhcPass 'Renamed))
mkOneRecordSelector [ConLike]
all_cons (TyCon -> RecSelParent
RecSelData TyCon
tycon) FieldLabel
fl
        FieldSelectors
FieldSelectors  -- See Note [NoFieldSelectors and naughty record selectors]
  where
    all_cons :: [ConLike]
all_cons = forall a b. (a -> b) -> [a] -> [b]
map DataCon -> ConLike
RealDataCon (TyCon -> [DataCon]
tyConDataCons TyCon
tycon)

mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> FieldSelectors
                    -> (Id, LHsBind GhcRn)
mkOneRecordSelector :: [ConLike]
-> RecSelParent
-> FieldLabel
-> FieldSelectors
-> (Id, LHsBind (GhcPass 'Renamed))
mkOneRecordSelector [ConLike]
all_cons RecSelParent
idDetails FieldLabel
fl FieldSelectors
has_sel
  = (Id
sel_id, forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
sel_bind)
  where
    loc :: SrcSpan
loc      = forall a. NamedThing a => a -> SrcSpan
getSrcSpan Name
sel_name
    loc' :: SrcSpanAnnA
loc'     = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
    locn :: SrcSpanAnnN
locn     = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
    lbl :: FieldLabelString
lbl      = FieldLabel -> FieldLabelString
flLabel FieldLabel
fl
    sel_name :: Name
sel_name = FieldLabel -> Name
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 { 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 :: [InvisTVBinder]
data_tvbs  = forall a. (a -> Bool) -> [a] -> [a]
filter (\InvisTVBinder
tvb -> forall tv argf. VarBndr tv argf -> tv
binderVar InvisTVBinder
tvb Id -> VarSet -> Bool
`elemVarSet` VarSet
data_tv_set) forall a b. (a -> b) -> a -> b
$
                 ConLike -> [InvisTVBinder]
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)
                    Bool -> Bool -> Bool
|| FieldSelectors
has_sel forall a. Eq a => a -> a -> Bool
== FieldSelectors
NoFieldSelectors
    sel_ty :: PredType
sel_ty | Bool
is_naughty = PredType
unitTy  -- See Note [Naughty record selectors]
           | Bool
otherwise  = [TyCoVarBinder] -> PredType -> PredType
mkForAllTys (forall a. [VarBndr a Specificity] -> [VarBndr a ArgFlag]
tyVarSpecToBinders [InvisTVBinder]
data_tvbs) forall a b. (a -> b) -> a -> b
$
                          [PredType] -> PredType -> PredType
mkPhiTy (ConLike -> [PredType]
conLikeStupidTheta ConLike
con1) forall a b. (a -> b) -> a -> b
$   -- Urgh!
                          -- req_theta is empty for normal DataCon
                          [PredType] -> PredType -> PredType
mkPhiTy [PredType]
req_theta                 forall a b. (a -> b) -> a -> b
$
                          PredType -> PredType -> PredType
mkVisFunTyMany PredType
data_ty            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 :: HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
sel_bind = Origin
-> GenLocated SrcSpanAnnN Name
-> [LMatch (GhcPass 'Renamed) (LHsExpr (GhcPass 'Renamed))]
-> HsBindLR (GhcPass 'Renamed) (GhcPass 'Renamed)
mkTopFunBind Origin
Generated GenLocated SrcSpanAnnN Name
sel_lname [GenLocated
   (Anno
      (Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))))
   (Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed))))]
alts
      where
        alts :: [GenLocated
   (Anno
      (Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))))
   (Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed))))]
alts | Bool
is_naughty = [forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA,
 Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan) =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch (forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs GenLocated SrcSpanAnnN Name
sel_lname)
                                           [] LocatedA (HsExpr (GhcPass 'Renamed))
unit_rhs]
             | Bool
otherwise =  forall a b. (a -> b) -> [a] -> [b]
map ConLike
-> LMatch (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))
mk_match [ConLike]
cons_w_field forall a. [a] -> [a] -> [a]
++ [GenLocated
   (Anno
      (Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))))
   (Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed))))]
deflt
    mk_match :: ConLike
-> LMatch (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))
mk_match ConLike
con = forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA,
 Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan) =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch (forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs GenLocated SrcSpanAnnN Name
sel_lname)
                                 [forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' (ConLike -> Pat (GhcPass 'Renamed)
mk_sel_pat ConLike
con)]
                                 (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
locn Name
field_var)))
    mk_sel_pat :: ConLike -> Pat (GhcPass 'Renamed)
mk_sel_pat ConLike
con = forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat NoExtField
NoExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
locn (forall a. NamedThing a => a -> Name
getName ConLike
con)) (forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon HsRecFields
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)))
rec_fields)
    rec_fields :: HsRecFields
  (GhcPass 'Renamed)
  (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)))
rec_fields = HsRecFields { rec_flds :: [LHsRecField
   (GhcPass 'Renamed)
   (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed)))]
rec_flds = [LocatedAn
  AnnListItem
  (HsRecField'
     (FieldOcc (GhcPass 'Renamed))
     (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))))
rec_field], rec_dotdot :: Maybe (Located Int)
rec_dotdot = forall a. Maybe a
Nothing }
    rec_field :: LocatedAn
  AnnListItem
  (HsRecField'
     (FieldOcc (GhcPass 'Renamed))
     (GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))))
rec_field  = forall a an. a -> LocatedAn an a
noLocA (HsRecField
                        { hsRecFieldAnn :: XHsRecField (FieldOcc (GhcPass 'Renamed))
hsRecFieldAnn = forall a. EpAnn a
noAnn
                        , hsRecFieldLbl :: Located (FieldOcc (GhcPass 'Renamed))
hsRecFieldLbl
                           = forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (forall pass. XCFieldOcc pass -> LocatedN RdrName -> FieldOcc pass
FieldOcc Name
sel_name
                                     (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
locn forall a b. (a -> b) -> a -> b
$ FieldLabelString -> RdrName
mkVarUnqual FieldLabelString
lbl))
                        , hsRecFieldArg :: GenLocated SrcSpanAnnA (Pat (GhcPass 'Renamed))
hsRecFieldArg
                           = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' (forall p. XVarPat p -> LIdP p -> Pat p
VarPat NoExtField
noExtField (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
locn Name
field_var))
                        , hsRecPun :: Bool
hsRecPun = Bool
False })
    sel_lname :: GenLocated SrcSpanAnnN Name
sel_lname = forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
locn Name
sel_name
    field_var :: Name
field_var = Unique -> OccName -> SrcSpan -> Name
mkInternalName (Int -> Unique
mkBuiltinUnique Int
1) (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 :: [GenLocated
   (Anno
      (Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed)))))
   (Match (GhcPass 'Renamed) (LocatedA (HsExpr (GhcPass 'Renamed))))]
deflt | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ConLike -> Bool
dealt_with [ConLike]
all_cons = []
          | Bool
otherwise = [forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA,
 Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan) =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch forall p. HsMatchContext p
CaseAlt
                            [forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' (forall p. XWildPat p -> Pat p
WildPat NoExtField
noExtField)]
                            (forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField
                                         (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
locn (forall a. NamedThing a => a -> Name
getName Id
rEC_SEL_ERROR_ID))))
                                     (forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loc' (forall p. XLitE p -> HsLit p -> HsExpr p
HsLit EpAnnCO
noComments HsLit (GhcPass 'Renamed)
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 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 (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 'Renamed)
unit_rhs = forall (p :: Pass).
[LHsExpr (GhcPass p)]
-> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)
mkLHsTupleExpr [] NoExtField
noExtField
    msg_lit :: HsLit (GhcPass 'Renamed)
msg_lit = forall x. XHsStringPrim x -> ByteString -> HsLit x
HsStringPrim SourceText
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 [NoFieldSelectors and naughty record selectors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Under NoFieldSelectors (see Note [NoFieldSelectors] in GHC.Rename.Env), record
selectors will not be in scope in the renamer.  However, for normal datatype
declarations we still generate the underlying selector functions, so they can be
used for constructing the dictionaries for HasField constraints (as described by
Note [HasField instances] in GHC.Tc.Instance.Class).  Hence the call to
mkOneRecordSelector in mkRecSelBind always uses FieldSelectors.

However, record pattern synonyms are not used with HasField, so when
NoFieldSelectors is used we do not need to generate selector functions.  Thus
mkPatSynRecSelBinds passes the current state of the FieldSelectors extension to
mkOneRecordSelector, and in the NoFieldSelectors case it will treat them as
"naughty" fields (see Note [Naughty record selectors]).

Why generate a naughty binding, rather than no binding at all? Because when
type-checking a record update, we need to look up Ids for the fields. In
particular, disambiguateRecordBinds calls lookupParents which needs to look up
the RecSelIds to determine the sel_tycon.

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 internally
when typechecking these HsBinds so that the user does not have to.
-}