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

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

module TcTyDecls(
        RolesInfo,
        inferRoles,
        checkSynCycles,
        checkClassCycles,

        -- * Implicits
        addTyConsToGblEnv, mkDefaultMethodType,

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

#include "HsVersions.h"

import GhcPrelude

import TcRnMonad
import TcEnv
import TcBinds( tcValBinds, addTypecheckedBinds )
import TyCoRep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) )
import TcType
import TysWiredIn( unitTy )
import MkCore( rEC_SEL_ERROR_ID )
import HsSyn
import Class
import Type
import HscTypes
import TyCon
import ConLike
import DataCon
import Name
import NameEnv
import NameSet hiding (unitFV)
import RdrName ( mkVarUnqual )
import Id
import IdInfo
import VarEnv
import VarSet
import Coercion ( ltRole )
import BasicTypes
import SrcLoc
import Unique ( mkBuiltinUnique )
import Outputable
import Util
import Maybes
import Bag
import FastString
import FV
import Module

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 :: Type -> [TyCon]
synonymTyConsOfType ty :: Type
ty
  = NameEnv TyCon -> [TyCon]
forall a. NameEnv a -> [a]
nameEnvElts (Type -> NameEnv TyCon
go Type
ty)
  where
     go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim
     go :: Type -> NameEnv TyCon
go (TyConApp tc :: TyCon
tc tys :: [Type]
tys)         = TyCon -> NameEnv TyCon
go_tc TyCon
tc NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` [Type] -> NameEnv TyCon
forall (t :: * -> *). Foldable t => t Type -> NameEnv TyCon
go_s [Type]
tys
     go (LitTy _)                 = NameEnv TyCon
forall a. NameEnv a
emptyNameEnv
     go (TyVarTy _)               = NameEnv TyCon
forall a. NameEnv a
emptyNameEnv
     go (AppTy a :: Type
a b :: Type
b)               = Type -> NameEnv TyCon
go Type
a NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` Type -> NameEnv TyCon
go Type
b
     go (FunTy a :: Type
a b :: Type
b)               = Type -> NameEnv TyCon
go Type
a NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` Type -> NameEnv TyCon
go Type
b
     go (ForAllTy _ ty :: Type
ty)           = Type -> NameEnv TyCon
go Type
ty
     go (CastTy ty :: Type
ty co :: KindCoercion
co)            = Type -> NameEnv TyCon
go Type
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 co :: 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 MRefl    = NameEnv TyCon
forall a. NameEnv a
emptyNameEnv
     go_mco (MCo co :: KindCoercion
co) = KindCoercion -> NameEnv TyCon
go_co KindCoercion
co

     go_co :: KindCoercion -> NameEnv TyCon
go_co (Refl ty :: Type
ty)              = Type -> NameEnv TyCon
go Type
ty
     go_co (GRefl _ ty :: Type
ty mco :: MCoercionN
mco)       = Type -> NameEnv TyCon
go Type
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 _ tc :: TyCon
tc cs :: [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 co :: KindCoercion
co 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 _ co :: KindCoercion
co 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 _ co :: KindCoercion
co 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 (CoVarCo _)            = NameEnv TyCon
forall a. NameEnv a
emptyNameEnv
     go_co (HoleCo {})            = NameEnv TyCon
forall a. NameEnv a
emptyNameEnv
     go_co (AxiomInstCo _ _ cs :: [KindCoercion]
cs)   = [KindCoercion] -> NameEnv TyCon
go_co_s [KindCoercion]
cs
     go_co (UnivCo p :: UnivCoProvenance
p _ ty :: Type
ty ty' :: Type
ty')    = UnivCoProvenance -> NameEnv TyCon
go_prov UnivCoProvenance
p NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` Type -> NameEnv TyCon
go Type
ty NameEnv TyCon -> NameEnv TyCon -> NameEnv TyCon
forall a. NameEnv a -> NameEnv a -> NameEnv a
`plusNameEnv` Type -> NameEnv TyCon
go Type
ty'
     go_co (SymCo co :: KindCoercion
co)             = KindCoercion -> NameEnv TyCon
go_co KindCoercion
co
     go_co (TransCo co :: KindCoercion
co 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 _ _ co :: KindCoercion
co)         = KindCoercion -> NameEnv TyCon
go_co KindCoercion
co
     go_co (LRCo _ co :: KindCoercion
co)            = KindCoercion -> NameEnv TyCon
go_co KindCoercion
co
     go_co (InstCo co :: KindCoercion
co 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 co :: KindCoercion
co)            = KindCoercion -> NameEnv TyCon
go_co KindCoercion
co
     go_co (SubCo co :: KindCoercion
co)             = KindCoercion -> NameEnv TyCon
go_co KindCoercion
co
     go_co (AxiomRuleCo _ cs :: [KindCoercion]
cs)     = [KindCoercion] -> NameEnv TyCon
go_co_s [KindCoercion]
cs

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

     go_tc :: TyCon -> NameEnv TyCon
go_tc 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 Type -> NameEnv TyCon
go_s tys :: t Type
tys = (Type -> NameEnv TyCon -> NameEnv TyCon)
-> NameEnv TyCon -> t Type -> 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)
-> (Type -> NameEnv TyCon)
-> Type
-> NameEnv TyCon
-> NameEnv TyCon
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> NameEnv TyCon
go) NameEnv TyCon
forall a. NameEnv a
emptyNameEnv t Type
tys
     go_co_s :: [KindCoercion] -> NameEnv TyCon
go_co_s cos :: [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 {
    SynCycleM a
-> SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState)
runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) }

type SynCycleState = NameSet

instance Functor SynCycleM where
    fmap :: (a -> b) -> SynCycleM a -> SynCycleM b
fmap = (a -> b) -> SynCycleM a -> SynCycleM b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative SynCycleM where
    pure :: a -> SynCycleM a
pure x :: 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
$ \state :: SynCycleState
state -> (a, SynCycleState) -> Either (SrcSpan, SDoc) (a, SynCycleState)
forall a b. b -> Either a b
Right (a
x, SynCycleState
state)
    <*> :: 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
    m :: SynCycleM a
m >>= :: SynCycleM a -> (a -> SynCycleM b) -> SynCycleM b
>>= f :: 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
$ \state :: 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 (x :: a
x, state' :: 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 err :: (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 loc :: SrcSpan
loc err :: 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
$ \_ -> (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 n :: Name
n m :: 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
$ \s :: 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 ((), s' :: SynCycleState
s') -> ((), SynCycleState) -> Either (SrcSpan, SDoc) ((), SynCycleState)
forall a b. b -> Either a b
Right ((), SynCycleState -> Name -> SynCycleState
extendNameSet SynCycleState
s' Name
n)
                Left err :: (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 'UnitId' 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 :: UnitId -> [TyCon] -> [LTyClDecl GhcRn] -> TcM ()
checkSynCycles :: UnitId -> [TyCon] -> [LTyClDecl GhcRn] -> TcM ()
checkSynCycles this_uid :: UnitId
this_uid tcs :: [TyCon]
tcs tyclds :: [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 (loc :: SrcSpan
loc, err :: 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 _  -> () -> 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 so_far :: SynCycleState
so_far seen_tcs :: [TyCon]
seen_tcs tc :: 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' so_far :: SynCycleState
so_far seen_tcs :: [TyCon]
seen_tcs tc :: 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 "Cycle in type synonym declarations:"
                      , Int -> SDoc -> SDoc
nest 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 (Module -> Bool
isHoleModule Module
mod Bool -> Bool -> Bool
||
               Module -> UnitId
moduleUnitId Module
mod UnitId -> UnitId -> Bool
forall a. Eq a => a -> a -> Bool
== UnitId
this_uid Bool -> Bool -> Bool
||
               Module -> Bool
isInteractiveModule Module
mod)
            = () -> SynCycleM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | Just ty :: Type
ty <- TyCon -> Maybe Type
synTyConRhs_maybe TyCon
tc =
            SynCycleState -> [TyCon] -> Type -> 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) Type
ty
        | Bool
otherwise = () -> SynCycleM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      where
        n :: Name
n = TyCon -> Name
tyConName TyCon
tc
        mod :: Module
mod = HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
n
        ppr_decl :: TyCon -> SDoc
ppr_decl tc :: 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 (LTyClDecl GhcRn -> Located (SrcSpanLess (LTyClDecl GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L loc :: SrcSpan
loc decl :: SrcSpanLess (LTyClDecl 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 SrcSpanLess (LTyClDecl GhcRn)
TyClDecl GhcRn
decl
            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 "from external module"
         where
          n :: Name
n = TyCon -> Name
tyConName TyCon
tc

    go_ty :: NameSet -> [TyCon] -> Type -> SynCycleM ()
    go_ty :: SynCycleState -> [TyCon] -> Type -> SynCycleM ()
go_ty so_far :: SynCycleState
so_far seen_tcs :: [TyCon]
seen_tcs ty :: Type
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) (Type -> [TyCon]
synonymTyConsOfType Type
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 cls :: Class
cls
  = do { (definite_cycle :: Bool
definite_cycle, err :: SDoc
err) <- SynCycleState -> Class -> [Type] -> Maybe (Bool, SDoc)
go (Name -> SynCycleState
unitNameSet (Class -> Name
forall a. NamedThing a => a -> Name
getName Class
cls))
                                     Class
cls ([TyVar] -> [Type]
mkTyVarTys (Class -> [TyVar]
classTyVars Class
cls))
       ; let herald :: SDoc
herald | Bool
definite_cycle = String -> SDoc
text "Superclass cycle for"
                    | Bool
otherwise      = String -> SDoc
text "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 2 SDoc
err, SDoc
hint]) }
  where
    hint :: SDoc
hint = String -> SDoc
text "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 -> [Type] -> Maybe (Bool, SDoc)
go so_far :: SynCycleState
so_far cls :: Class
cls tys :: [Type]
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
$
                        (Type -> Maybe (Bool, SDoc)) -> [Type] -> [Maybe (Bool, SDoc)]
forall a b. (a -> b) -> [a] -> [b]
map (SynCycleState -> Type -> Maybe (Bool, SDoc)
go_pred SynCycleState
so_far) ([Type] -> [Maybe (Bool, SDoc)]) -> [Type] -> [Maybe (Bool, SDoc)]
forall a b. (a -> b) -> a -> b
$
                        Class -> [Type] -> [Type]
immSuperClasses Class
cls [Type]
tys

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

    go_tc :: NameSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc)
    go_tc :: SynCycleState -> Type -> TyCon -> [Type] -> Maybe (Bool, SDoc)
go_tc so_far :: SynCycleState
so_far pred :: Type
pred tc :: TyCon
tc tys :: [Type]
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 "one of whose superclass constraints is headed by a type family:")
                        2 (SDoc -> SDoc
quotes (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pred)))
      | Just cls :: Class
cls <- TyCon -> Maybe Class
tyConClass_maybe TyCon
tc
      = SynCycleState -> Class -> [Type] -> Maybe (Bool, SDoc)
go_cls SynCycleState
so_far Class
cls [Type]
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 -> [Type] -> Maybe (Bool, SDoc)
go_cls so_far :: SynCycleState
so_far cls :: Class
cls tys :: [Type]
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 "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 -> [Type] -> Maybe (Bool, SDoc)
go SynCycleState
so_far Class
cls [Type]
tys
       | Bool
otherwise
       = do { (b :: Bool
b,err :: SDoc
err) <- SynCycleState -> Class -> [Type] -> Maybe (Bool, SDoc)
go  (SynCycleState
so_far SynCycleState -> Name -> SynCycleState
`extendNameSet` Name
cls_nm) Class
cls [Type]
tys
          ; (Bool, SDoc) -> Maybe (Bool, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
b, String -> SDoc
text "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 hsc_src :: HscSource
hsc_src annots :: RoleAnnotEnv
annots tycons :: [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
name -> case RoleEnv -> Name -> Maybe [Role]
forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv RoleEnv
role_env' Name
name of
      Just roles :: [Role]
roles -> [Role]
roles
      Nothing    -> String -> SDoc -> [Role]
forall a. HasCallStack => String -> SDoc -> a
pprPanic "inferRoles" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)

initialRoleEnv :: HscSource -> RoleAnnotEnv -> [TyCon] -> RoleEnv
initialRoleEnv :: HscSource -> RoleAnnotEnv -> [TyCon] -> RoleEnv
initialRoleEnv hsc_src :: HscSource
hsc_src annots :: 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 hsc_src :: HscSource
hsc_src annots_env :: RoleAnnotEnv
annots_env tc :: 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 "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 (LRoleAnnotDecl GhcRn
-> Located (SrcSpanLess (LRoleAnnotDecl GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (RoleAnnotDecl _ _ 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 a. HasSrcSpan a => a -> SrcSpanLess a
unLoc [Located (Maybe Role)]
annots
              _                              -> 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 (argf :: ArgFlag
argf : argfs :: [ArgFlag]
argfs) (m_annot :: Maybe Role
m_annot : ras :: [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 (_argf :: ArgFlag
_argf : argfs :: [ArgFlag]
argfs) ras :: [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 _ _ = String -> SDoc -> [Role]
forall a. HasCallStack => String -> SDoc -> a
pprPanic "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 env :: RoleEnv
env tcs :: [TyCon]
tcs
  = let (env' :: RoleEnv
env', update :: 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 tc :: 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 { (Type -> RoleM ()) -> [Type] -> RoleM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (VarSet -> Type -> RoleM ()
irType VarSet
emptyVarSet) (TyCon -> [Type]
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 ty :: Type
ty <- TyCon -> Maybe Type
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 -> Type -> RoleM ()
irType VarSet
emptyVarSet Type
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 cls :: 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 :: [TyVar]
cls_tvs    = Class -> [TyVar]
classTyVars Class
cls
    cls_tv_set :: VarSet
cls_tv_set = [TyVar] -> VarSet
mkVarSet [TyVar]
cls_tvs

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

-- See Note [Role inference]
irDataCon :: DataCon -> RoleM ()
irDataCon :: DataCon -> RoleM ()
irDataCon datacon :: DataCon
datacon
  = [TyVar] -> RoleM () -> RoleM ()
forall a. [TyVar] -> RoleM a -> RoleM a
setRoleInferenceVars [TyVar]
univ_tvs (RoleM () -> RoleM ()) -> RoleM () -> RoleM ()
forall a b. (a -> b) -> a -> b
$
    [TyVar] -> (VarSet -> RoleM ()) -> RoleM ()
forall a. [TyVar] -> (VarSet -> RoleM a) -> RoleM a
irExTyVars [TyVar]
ex_tvs ((VarSet -> RoleM ()) -> RoleM ())
-> (VarSet -> RoleM ()) -> RoleM ()
forall a b. (a -> b) -> a -> b
$ \ ex_var_set :: VarSet
ex_var_set ->
    (Type -> RoleM ()) -> [Type] -> RoleM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (VarSet -> Type -> RoleM ()
irType VarSet
ex_var_set)
          ((TyVar -> Type) -> [TyVar] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Type
tyVarKind [TyVar]
ex_tvs [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [EqSpec] -> [Type]
eqSpecPreds [EqSpec]
eq_spec [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
theta [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
++ [Type]
arg_tys)
      -- See Note [Role-checking data constructor arguments]
  where
    (univ_tvs :: [TyVar]
univ_tvs, ex_tvs :: [TyVar]
ex_tvs, eq_spec :: [EqSpec]
eq_spec, theta :: [Type]
theta, arg_tys :: [Type]
arg_tys, _res_ty :: Type
_res_ty)
      = DataCon -> ([TyVar], [TyVar], [EqSpec], [Type], [Type], Type)
dataConFullSig DataCon
datacon

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

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

irTcTyVars :: TyCon -> RoleM a -> RoleM a
irTcTyVars :: TyCon -> RoleM a -> RoleM a
irTcTyVars tc :: TyCon
tc thing :: 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
$ [TyVar] -> RoleM a
go (TyCon -> [TyVar]
tyConTyVars TyCon
tc)
  where
    go :: [TyVar] -> RoleM a
go []       = RoleM a
thing
    go (tv :: TyVar
tv:tvs :: [TyVar]
tvs) = do { VarSet -> Type -> RoleM ()
markNominal VarSet
emptyVarSet (TyVar -> Type
tyVarKind TyVar
tv)
                     ; TyVar -> RoleM a -> RoleM a
forall a. TyVar -> RoleM a -> RoleM a
addRoleInferenceVar TyVar
tv (RoleM a -> RoleM a) -> RoleM a -> RoleM a
forall a b. (a -> b) -> a -> b
$ [TyVar] -> RoleM a
go [TyVar]
tvs }

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

markNominal :: TyVarSet   -- local variables
            -> Type -> RoleM ()
markNominal :: VarSet -> Type -> RoleM ()
markNominal lcls :: VarSet
lcls ty :: Type
ty = let nvars :: [TyVar]
nvars = FV -> [TyVar]
fvVarList (VarSet -> FV -> FV
FV.delFVs VarSet
lcls (FV -> FV) -> FV -> FV
forall a b. (a -> b) -> a -> b
$ Type -> FV
get_ty_vars Type
ty) in
                      (TyVar -> RoleM ()) -> [TyVar] -> RoleM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Role -> TyVar -> RoleM ()
updateRole Role
Nominal) [TyVar]
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 :: Type -> FV
get_ty_vars (TyVarTy tv :: TyVar
tv)      = TyVar -> FV
unitFV TyVar
tv
    get_ty_vars (AppTy t1 :: Type
t1 t2 :: Type
t2)     = Type -> FV
get_ty_vars Type
t1 FV -> FV -> FV
`unionFV` Type -> FV
get_ty_vars Type
t2
    get_ty_vars (FunTy t1 :: Type
t1 t2 :: Type
t2)     = Type -> FV
get_ty_vars Type
t1 FV -> FV -> FV
`unionFV` Type -> FV
get_ty_vars Type
t2
    get_ty_vars (TyConApp _ tys :: [Type]
tys)  = (Type -> FV) -> [Type] -> FV
forall a. (a -> FV) -> [a] -> FV
mapUnionFV Type -> FV
get_ty_vars [Type]
tys
    get_ty_vars (ForAllTy tvb :: TyCoVarBinder
tvb ty :: Type
ty) = TyCoVarBinder -> FV -> FV
tyCoFVsBndr TyCoVarBinder
tvb (Type -> FV
get_ty_vars Type
ty)
    get_ty_vars (LitTy {})        = FV
emptyFV
    get_ty_vars (CastTy ty :: Type
ty _)     = Type -> FV
get_ty_vars Type
ty
    get_ty_vars (CoercionTy _)    = FV
emptyFV

-- like lookupRoles, but with Nominal tags at the end for oversaturated TyConApps
lookupRolesX :: TyCon -> RoleM [Role]
lookupRolesX :: TyCon -> RoleM [Role]
lookupRolesX tc :: 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 tc :: 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 roles :: [Role]
roles -> [Role] -> RoleM [Role]
forall (m :: * -> *) a. Monad m => a -> m a
return [Role]
roles
           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 -> TyVar -> RoleM ()
updateRole role :: Role
role tv :: TyVar
tv
  = do { VarPositions
var_ns <- RoleM VarPositions
getVarNs
       ; Name
name <- RoleM Name
getTyConName
       ; case VarPositions -> TyVar -> Maybe Int
forall a. VarEnv a -> TyVar -> Maybe a
lookupVarEnv VarPositions
var_ns TyVar
tv of
           Nothing -> String -> SDoc -> RoleM ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic "updateRole" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name SDoc -> SDoc -> SDoc
$$ TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
tv SDoc -> SDoc -> SDoc
$$ VarPositions -> SDoc
forall a. Outputable a => a -> SDoc
ppr VarPositions
var_ns)
           Just n :: 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 { RoleM a
-> Maybe Name
-> VarPositions
-> Int
-> RoleInferenceState
-> (a, RoleInferenceState)
unRM :: Maybe Name -- of the tycon
                            -> VarPositions
                            -> Int          -- size of VarPositions
                            -> RoleInferenceState
                            -> (a, RoleInferenceState) }

instance Functor RoleM where
    fmap :: (a -> b) -> RoleM a -> RoleM b
fmap = (a -> b) -> RoleM a -> RoleM b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Applicative RoleM where
    pure :: a -> RoleM a
pure x :: 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
$ \_ _ _ state :: RoleInferenceState
state -> (a
x, RoleInferenceState
state)
    <*> :: 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
  a :: RoleM a
a >>= :: RoleM a -> (a -> RoleM b) -> RoleM b
>>= f :: 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
$ \m_info :: Maybe Name
m_info vps :: VarPositions
vps nvps :: Int
nvps state :: RoleInferenceState
state ->
                  let (a' :: a
a', state' :: 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 env :: RoleEnv
env thing :: 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. NameEnv a
emptyVarEnv 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 :: Name -> RoleM a -> RoleM a
setRoleInferenceTc name :: Name
name thing :: 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
$ \m_name :: Maybe Name
m_name vps :: VarPositions
vps nvps :: Int
nvps state :: 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 :: TyVar -> RoleM a -> RoleM a
addRoleInferenceVar tv :: TyVar
tv thing :: 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
$ \m_name :: Maybe Name
m_name vps :: VarPositions
vps nvps :: Int
nvps state :: 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 -> TyVar -> Int -> VarPositions
forall a. VarEnv a -> TyVar -> a -> VarEnv a
extendVarEnv VarPositions
vps TyVar
tv Int
nvps) (Int
nvpsInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) RoleInferenceState
state

setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a
setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a
setRoleInferenceVars tvs :: [TyVar]
tvs thing :: 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
$ \m_name :: Maybe Name
m_name _vps :: VarPositions
_vps _nvps :: Int
_nvps state :: 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 ([(TyVar, Int)] -> VarPositions
forall a. [(TyVar, a)] -> VarEnv a
mkVarEnv ([TyVar] -> [Int] -> [(TyVar, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [TyVar]
tvs [0..])) (String -> Int
forall a. String -> a
panic "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
$ \_ _ _ 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
$ \_ vps :: VarPositions
vps _ state :: 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
$ \m_name :: Maybe Name
m_name _ _ state :: RoleInferenceState
state ->
                    case Maybe Name
m_name of
                      Nothing   -> String -> (Name, RoleInferenceState)
forall a. String -> a
panic "getTyConName"
                      Just name :: Name
name -> (Name
name, RoleInferenceState
state)

updateRoleEnv :: Name -> Int -> Role -> RoleM ()
updateRoleEnv :: Name -> Int -> Role -> RoleM ()
updateRoleEnv name :: Name
name n :: Int
n role :: 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
$ \_ _ _ 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
           Nothing -> String -> SDoc -> RoleInferenceState
forall a. HasCallStack => String -> SDoc -> a
pprPanic "updateRoleEnv" (Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name)
           Just roles :: [Role]
roles -> let (before :: [Role]
before, old_role :: Role
old_role : after :: [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 tyclss :: [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
$
    [TyVar] -> TcM TcGblEnv -> TcM TcGblEnv
forall a. [TyVar] -> TcM a -> TcM a
tcExtendGlobalValEnv [TyVar]
def_meth_ids          (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
    do { String -> SDoc -> TcM ()
traceTc "tcAddTyCons" (SDoc -> TcM ()) -> SDoc -> TcM ()
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
            [ String -> SDoc
text "tycons" SDoc -> SDoc -> SDoc
<+> [TyCon] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyCon]
tyclss
            , String -> SDoc
text "implicits" SDoc -> SDoc -> SDoc
<+> [TyThing] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyThing]
implicit_things ]
       ; TcGblEnv
gbl_env <- [(TyVar, LHsBind GhcRn)] -> TcM TcGblEnv
tcRecSelBinds ([TyCon] -> [(TyVar, 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 :: [TyVar]
def_meth_ids    = [TyCon] -> [TyVar]
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] -> [TyVar]
mkDefaultMethodIds tycons :: [TyCon]
tycons
  = [ Name -> Type -> TyVar
mkExportedVanillaId Name
dm_name (Class -> TyVar -> DefMethSpec Type -> Type
mkDefaultMethodType Class
cls TyVar
sel_id DefMethSpec Type
dm_spec)
    | TyCon
tc <- [TyCon]
tycons
    , Just cls :: Class
cls <- [TyCon -> Maybe Class
tyConClass_maybe TyCon
tc]
    , (sel_id :: TyVar
sel_id, Just (dm_name :: Name
dm_name, dm_spec :: DefMethSpec Type
dm_spec)) <- Class -> [(TyVar, DefMethInfo)]
classOpItems Class
cls ]

mkDefaultMethodType :: Class -> Id -> DefMethSpec Type -> Type
-- Returns the top-level type of the default method
mkDefaultMethodType :: Class -> TyVar -> DefMethSpec Type -> Type
mkDefaultMethodType _ sel_id :: TyVar
sel_id VanillaDM        = TyVar -> Type
idType TyVar
sel_id
mkDefaultMethodType cls :: Class
cls _   (GenericDM dm_ty :: Type
dm_ty) = [TyCoVarBinder] -> [Type] -> Type -> Type
mkSigmaTy [TyCoVarBinder]
tv_bndrs [Type
pred] Type
dm_ty
   where
     pred :: Type
pred      = Class -> [Type] -> Type
mkClassPred Class
cls ([TyVar] -> [Type]
mkTyVarTys ([TyConBinder] -> [TyVar]
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  = [TyConBinder] -> [TyCoVarBinder]
tyConTyVarBinders [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 (TcInstDcls.mkDefMethBind), and
     --     then typechecked.  So we need the right visibilty info
     --     (Trac #13998)

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

{-
Note [Default method Ids and Template Haskell]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this (Trac #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 :: [(TyVar, LHsBind GhcRn)] -> TcM TcGblEnv
tcRecSelBinds sel_bind_prs :: [(TyVar, LHsBind GhcRn)]
sel_bind_prs
  = [TyVar] -> TcM TcGblEnv -> TcM TcGblEnv
forall a. [TyVar] -> TcM a -> TcM a
tcExtendGlobalValEnv [TyVar
sel_id | (LSig GhcRn -> Located (SrcSpanLess (LSig GhcRn))
forall a. HasSrcSpan a => a -> Located (SrcSpanLess a)
dL->L _ (IdSig _ sel_id)) <- [LSig GhcRn]
sigs] (TcM TcGblEnv -> TcM TcGblEnv) -> TcM TcGblEnv -> TcM TcGblEnv
forall a b. (a -> b) -> a -> b
$
    do { (rec_sel_binds :: [(RecFlag, LHsBinds GhcTcId)]
rec_sel_binds, tcg_env :: TcGblEnv
tcg_env) <- TcRn ([(RecFlag, LHsBinds GhcTcId)], TcGblEnv)
-> TcRn ([(RecFlag, LHsBinds GhcTcId)], TcGblEnv)
forall a. TcRn a -> TcRn a
discardWarnings (TcRn ([(RecFlag, LHsBinds GhcTcId)], TcGblEnv)
 -> TcRn ([(RecFlag, LHsBinds GhcTcId)], TcGblEnv))
-> TcRn ([(RecFlag, LHsBinds GhcTcId)], TcGblEnv)
-> TcRn ([(RecFlag, LHsBinds GhcTcId)], TcGblEnv)
forall a b. (a -> b) -> a -> b
$
                                     TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)]
-> [LSig GhcRn]
-> TcM TcGblEnv
-> TcRn ([(RecFlag, LHsBinds GhcTcId)], TcGblEnv)
forall thing.
TopLevelFlag
-> [(RecFlag, LHsBinds GhcRn)]
-> [LSig GhcRn]
-> TcM thing
-> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)
tcValBinds TopLevelFlag
TopLevel [(RecFlag, LHsBinds GhcRn)]
binds [LSig 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 GhcTcId] -> TcGblEnv
`addTypecheckedBinds` ((RecFlag, LHsBinds GhcTcId) -> LHsBinds GhcTcId)
-> [(RecFlag, LHsBinds GhcTcId)] -> [LHsBinds GhcTcId]
forall a b. (a -> b) -> [a] -> [b]
map (RecFlag, LHsBinds GhcTcId) -> LHsBinds GhcTcId
forall a b. (a, b) -> b
snd [(RecFlag, LHsBinds GhcTcId)]
rec_sel_binds) }
  where
    sigs :: [LSig GhcRn]
sigs = [ SrcSpan -> SrcSpanLess (LSig GhcRn) -> LSig GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XIdSig GhcRn -> TyVar -> Sig GhcRn
forall pass. XIdSig pass -> TyVar -> Sig pass
IdSig XIdSig GhcRn
NoExt
noExt TyVar
sel_id)   | (sel_id :: TyVar
sel_id, _) <- [(TyVar, LHsBind GhcRn)]
sel_bind_prs
                                          , let loc :: SrcSpan
loc = TyVar -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan TyVar
sel_id ]
    binds :: [(RecFlag, LHsBinds GhcRn)]
binds = [(RecFlag
NonRecursive, LHsBind GhcRn -> LHsBinds GhcRn
forall a. a -> Bag a
unitBag LHsBind GhcRn
bind) | (_, bind :: LHsBind GhcRn
bind) <- [(TyVar, 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] -> [(TyVar, LHsBind GhcRn)]
mkRecSelBinds tycons :: [TyCon]
tycons
  = ((TyCon, FieldLabel) -> (TyVar, LHsBind GhcRn))
-> [(TyCon, FieldLabel)] -> [(TyVar, LHsBind GhcRn)]
forall a b. (a -> b) -> [a] -> [b]
map (TyCon, FieldLabel) -> (TyVar, 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) -> (TyVar, LHsBind GhcRn)
mkRecSelBind (tycon :: TyCon
tycon, fl :: FieldLabel
fl)
  = [ConLike] -> RecSelParent -> FieldLabel -> (TyVar, 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 -> (TyVar, LHsBind GhcRn)
mkOneRecordSelector all_cons :: [ConLike]
all_cons idDetails :: RecSelParent
idDetails fl :: FieldLabel
fl
  = (TyVar
sel_id, SrcSpan -> SrcSpanLess (LHsBind GhcRn) -> LHsBind GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc SrcSpanLess (LHsBind GhcRn)
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 :: TyVar
sel_id = IdDetails -> Name -> Type -> TyVar
mkExportedLocalId IdDetails
rec_details Name
sel_name Type
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 :: Type
field_ty   = ConLike -> FieldLabelString -> Type
conLikeFieldType ConLike
con1 FieldLabelString
lbl
    data_tvs :: [TyVar]
data_tvs   = [Type] -> [TyVar]
tyCoVarsOfTypesWellScoped [Type]
inst_tys
    data_tv_set :: VarSet
data_tv_set= [TyVar] -> VarSet
mkVarSet [TyVar]
data_tvs
    is_naughty :: Bool
is_naughty = Bool -> Bool
not (Type -> VarSet
tyCoVarsOfType Type
field_ty VarSet -> VarSet -> Bool
`subVarSet` VarSet
data_tv_set)
    (field_tvs :: [TyVar]
field_tvs, field_theta :: [Type]
field_theta, field_tau :: Type
field_tau) = Type -> ([TyVar], [Type], Type)
tcSplitSigmaTy Type
field_ty
    sel_ty :: Type
sel_ty | Bool
is_naughty = Type
unitTy  -- See Note [Naughty record selectors]
           | Bool
otherwise  = [TyVar] -> Type -> Type
mkSpecForAllTys [TyVar]
data_tvs          (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                          [Type] -> Type -> Type
mkPhiTy (ConLike -> [Type]
conLikeStupidTheta ConLike
con1) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$   -- Urgh!
                          Type -> Type -> Type
mkFunTy Type
data_ty                   (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                          [TyVar] -> Type -> Type
mkSpecForAllTys [TyVar]
field_tvs         (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                          [Type] -> Type -> Type
mkPhiTy [Type]
field_theta               (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                          -- req_theta is empty for normal DataCon
                          [Type] -> Type -> Type
mkPhiTy [Type]
req_theta                 (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
                          Type
field_tau

    -- 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 (NameOrRdrName (IdP GhcRn))
-> [LPat GhcRn] -> LHsExpr GhcRn -> LMatch GhcRn (LHsExpr GhcRn)
forall (p :: Pass) (body :: * -> *).
HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
-> [LPat (GhcPass p)]
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch (Located Name -> HsMatchContext Name
forall id. Located id -> HsMatchContext id
mkPrefixFunRhs Located Name
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 con :: ConLike
con = HsMatchContext (NameOrRdrName (IdP GhcRn))
-> [LPat GhcRn] -> LHsExpr GhcRn -> LMatch GhcRn (LHsExpr GhcRn)
forall (p :: Pass) (body :: * -> *).
HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
-> [LPat (GhcPass p)]
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch (Located Name -> HsMatchContext Name
forall id. Located id -> HsMatchContext id
mkPrefixFunRhs Located Name
sel_lname)
                                 [SrcSpan -> SrcSpanLess (LPat GhcRn) -> LPat GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (ConLike -> LPat GhcRn
mk_sel_pat ConLike
con)]
                                 (SrcSpan -> SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XVar GhcRn -> Located (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcRn
NoExt
noExt (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc Name
SrcSpanLess (Located Name)
field_var)))
    mk_sel_pat :: ConLike -> LPat GhcRn
mk_sel_pat con :: ConLike
con = Located (IdP GhcRn) -> HsConPatDetails GhcRn -> LPat GhcRn
forall p. Located (IdP p) -> HsConPatDetails p -> Pat p
ConPatIn (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (ConLike -> Name
forall a. NamedThing a => a -> Name
getName ConLike
con)) (HsRecFields GhcRn (LPat GhcRn) -> HsConPatDetails GhcRn
forall arg rec. rec -> HsConDetails arg rec
RecCon HsRecFields GhcRn (LPat GhcRn)
rec_fields)
    rec_fields :: HsRecFields GhcRn (LPat GhcRn)
rec_fields = HsRecFields :: forall p arg. [LHsRecField p arg] -> Maybe Int -> HsRecFields p arg
HsRecFields { rec_flds :: [LHsRecField GhcRn (LPat GhcRn)]
rec_flds = [LHsRecField GhcRn (LPat GhcRn)
rec_field], rec_dotdot :: Maybe Int
rec_dotdot = Maybe Int
forall a. Maybe a
Nothing }
    rec_field :: LHsRecField GhcRn (LPat GhcRn)
rec_field  = SrcSpanLess (LHsRecField GhcRn (LPat GhcRn))
-> LHsRecField GhcRn (LPat GhcRn)
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc (HsRecField :: forall id arg. Located id -> arg -> Bool -> HsRecField' id arg
HsRecField
                        { hsRecFieldLbl :: Located (FieldOcc GhcRn)
hsRecFieldLbl
                           = SrcSpan
-> SrcSpanLess (Located (FieldOcc GhcRn))
-> Located (FieldOcc GhcRn)
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XCFieldOcc GhcRn -> Located RdrName -> FieldOcc GhcRn
forall pass. XCFieldOcc pass -> Located RdrName -> FieldOcc pass
FieldOcc Name
XCFieldOcc GhcRn
sel_name
                                     (SrcSpan -> SrcSpanLess (Located RdrName) -> Located RdrName
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (SrcSpanLess (Located RdrName) -> Located RdrName)
-> SrcSpanLess (Located RdrName) -> Located RdrName
forall a b. (a -> b) -> a -> b
$ FieldLabelString -> RdrName
mkVarUnqual FieldLabelString
lbl))
                        , hsRecFieldArg :: LPat GhcRn
hsRecFieldArg
                           = SrcSpan -> SrcSpanLess (LPat GhcRn) -> LPat GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XVarPat GhcRn -> Located (IdP GhcRn) -> LPat GhcRn
forall p. XVarPat p -> Located (IdP p) -> Pat p
VarPat XVarPat GhcRn
NoExt
noExt (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc Name
SrcSpanLess (Located Name)
field_var))
                        , hsRecPun :: Bool
hsRecPun = Bool
False })
    sel_lname :: Located Name
sel_lname = SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc Name
SrcSpanLess (Located Name)
sel_name
    field_var :: Name
field_var = Unique -> OccName -> SrcSpan -> Name
mkInternalName (Int -> Unique
mkBuiltinUnique 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 (NameOrRdrName (IdP GhcRn))
-> [LPat GhcRn] -> LHsExpr GhcRn -> LMatch GhcRn (LHsExpr GhcRn)
forall (p :: Pass) (body :: * -> *).
HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
-> [LPat (GhcPass p)]
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch HsMatchContext (NameOrRdrName (IdP GhcRn))
forall id. HsMatchContext id
CaseAlt
                            [SrcSpan -> SrcSpanLess (LPat GhcRn) -> LPat GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XWildPat GhcRn -> LPat GhcRn
forall p. XWildPat p -> Pat p
WildPat XWildPat GhcRn
NoExt
noExt)]
                            (LHsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp (SrcSpan -> SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XVar GhcRn -> Located (IdP GhcRn) -> HsExpr GhcRn
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar XVar GhcRn
NoExt
noExt
                                         (SrcSpan -> SrcSpanLess (Located Name) -> Located Name
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (TyVar -> Name
forall a. NamedThing a => a -> Name
getName TyVar
rEC_SEL_ERROR_ID))))
                                     (SrcSpan -> SrcSpanLess (LHsExpr GhcRn) -> LHsExpr GhcRn
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
loc (XLitE GhcRn -> HsLit GhcRn -> HsExpr GhcRn
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcRn
NoExt
noExt 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 _) = Bool
False -- We can't predict overlap
    dealt_with con :: ConLike
con@(RealDataCon dc :: 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
|| [Type] -> DataCon -> Bool
dataConCannotMatch [Type]
inst_tys DataCon
dc

    (univ_tvs :: [TyVar]
univ_tvs, _, eq_spec :: [EqSpec]
eq_spec, _, req_theta :: [Type]
req_theta, _, data_ty :: Type
data_ty) = ConLike
-> ([TyVar], [TyVar], [EqSpec], [Type], [Type], [Type], Type)
conLikeFullSig ConLike
con1

    eq_subst :: TCvSubst
eq_subst = [(TyVar, Type)] -> TCvSubst
mkTvSubstPrs ((EqSpec -> (TyVar, Type)) -> [EqSpec] -> [(TyVar, Type)]
forall a b. (a -> b) -> [a] -> [b]
map EqSpec -> (TyVar, Type)
eqSpecPair [EqSpec]
eq_spec)
    inst_tys :: [Type]
inst_tys = TCvSubst -> [TyVar] -> [Type]
substTyVars TCvSubst
eq_subst [TyVar]
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
fastStringToByteString 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.

  data Ord a => T a = MkT { field :: forall b. (Num a, Show b) => (a, b) }

We want

  field :: forall a. Ord a => T a -> forall b. (Num a, Show b) => (a, b)

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 TcTyClsDecls.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 appying the eq_spec to the univ_tvs of the data con.

-}