{-# LANGUAGE CPP #-}

module ClsInst (
     matchGlobalInst,
     ClsInstResult(..),
     InstanceWhat(..), safeOverlap,
     AssocInstInfo(..), isNotAssociated
  ) where

#include "HsVersions.h"

import GhcPrelude

import TcEnv
import TcRnMonad
import TcType
import TcMType
import TcEvidence
import TcTypeableValidity
import RnEnv( addUsedGRE )
import RdrName( lookupGRE_FieldLabel )
import InstEnv
import Inst( instDFunType )
import FamInst( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst )

import TysWiredIn
import TysPrim( eqPrimTyCon, eqReprPrimTyCon )
import PrelNames

import Id
import Type
import MkCore ( mkStringExprFS, mkNaturalExpr )

import Name   ( Name )
import VarEnv ( VarEnv )
import DataCon
import TyCon
import Class
import DynFlags
import Outputable
import Util( splitAtList, fstOf3 )
import Data.Maybe

{- *******************************************************************
*                                                                    *
              A helper for associated types within
              class instance declarations
*                                                                    *
**********************************************************************-}

-- | Extra information about the parent instance declaration, needed
-- when type-checking associated types. The 'Class' is the enclosing
-- class, the [TyVar] are the /scoped/ type variable of the instance decl.
-- The @VarEnv Type@ maps class variables to their instance types.
data AssocInstInfo
  = NotAssociated
  | InClsInst { AssocInstInfo -> Class
ai_class    :: Class
              , AssocInstInfo -> [TyVar]
ai_tyvars   :: [TyVar]      -- ^ The /scoped/ tyvars of the instance
                                            -- Why scoped?  See bind_me in
                                            -- TcValidity.checkConsistentFamInst
              , AssocInstInfo -> VarEnv Type
ai_inst_env :: VarEnv Type  -- ^ Maps /class/ tyvars to their instance types
                -- See Note [Matching in the consistent-instantation check]
    }

isNotAssociated :: AssocInstInfo -> Bool
isNotAssociated :: AssocInstInfo -> Bool
isNotAssociated NotAssociated  = Bool
True
isNotAssociated (InClsInst {}) = Bool
False


{- *******************************************************************
*                                                                    *
                       Class lookup
*                                                                    *
**********************************************************************-}

-- | Indicates if Instance met the Safe Haskell overlapping instances safety
-- check.
--
-- See Note [Safe Haskell Overlapping Instances] in TcSimplify
-- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify
type SafeOverlapping = Bool

data ClsInstResult
  = NoInstance   -- Definitely no instance

  | OneInst { ClsInstResult -> [Type]
cir_new_theta :: [TcPredType]
            , ClsInstResult -> [EvExpr] -> EvTerm
cir_mk_ev     :: [EvExpr] -> EvTerm
            , ClsInstResult -> InstanceWhat
cir_what      :: InstanceWhat }

  | NotSure      -- Multiple matches and/or one or more unifiers

data InstanceWhat
  = BuiltinInstance
  | LocalInstance
  | TopLevInstance { InstanceWhat -> TyVar
iw_dfun_id   :: DFunId
                   , InstanceWhat -> Bool
iw_safe_over :: SafeOverlapping }

instance Outputable ClsInstResult where
  ppr :: ClsInstResult -> SDoc
ppr NoInstance = String -> SDoc
text "NoInstance"
  ppr NotSure    = String -> SDoc
text "NotSure"
  ppr (OneInst { cir_new_theta :: ClsInstResult -> [Type]
cir_new_theta = [Type]
ev
               , cir_what :: ClsInstResult -> InstanceWhat
cir_what = InstanceWhat
what })
    = String -> SDoc
text "OneInst" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat [[Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
ev, InstanceWhat -> SDoc
forall a. Outputable a => a -> SDoc
ppr InstanceWhat
what]

instance Outputable InstanceWhat where
  ppr :: InstanceWhat -> SDoc
ppr BuiltinInstance = String -> SDoc
text "built-in instance"
  ppr LocalInstance   = String -> SDoc
text "locally-quantified instance"
  ppr (TopLevInstance { iw_safe_over :: InstanceWhat -> Bool
iw_safe_over = Bool
so })
     = String -> SDoc
text "top-level instance" SDoc -> SDoc -> SDoc
<+> (String -> SDoc
text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ if Bool
so then "[safe]" else "[unsafe]")

safeOverlap :: InstanceWhat -> Bool
safeOverlap :: InstanceWhat -> Bool
safeOverlap (TopLevInstance { iw_safe_over :: InstanceWhat -> Bool
iw_safe_over = Bool
so }) = Bool
so
safeOverlap _                                      = Bool
True

matchGlobalInst :: DynFlags
                -> Bool      -- True <=> caller is the short-cut solver
                             -- See Note [Shortcut solving: overlap]
                -> Class -> [Type] -> TcM ClsInstResult
matchGlobalInst :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchGlobalInst dflags :: DynFlags
dflags short_cut :: Bool
short_cut clas :: Class
clas tys :: [Type]
tys
  | Name
cls_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
knownNatClassName
  = DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchKnownNat    DynFlags
dflags Bool
short_cut Class
clas [Type]
tys
  | Name
cls_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
knownSymbolClassName
  = DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchKnownSymbol DynFlags
dflags Bool
short_cut Class
clas [Type]
tys
  | Class -> Bool
isCTupleClass Class
clas                = Class -> [Type] -> TcM ClsInstResult
matchCTuple          Class
clas [Type]
tys
  | Name
cls_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
typeableClassName     = Class -> [Type] -> TcM ClsInstResult
matchTypeable        Class
clas [Type]
tys
  | Class
clas Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
heqTyConKey         = [Type] -> TcM ClsInstResult
matchHeteroEquality       [Type]
tys
  | Class
clas Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqTyConKey          = [Type] -> TcM ClsInstResult
matchHomoEquality         [Type]
tys
  | Class
clas Class -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
coercibleTyConKey   = [Type] -> TcM ClsInstResult
matchCoercible            [Type]
tys
  | Name
cls_name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
hasFieldClassName     = DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchHasField DynFlags
dflags Bool
short_cut Class
clas [Type]
tys
  | Bool
otherwise                         = DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchInstEnv DynFlags
dflags Bool
short_cut Class
clas [Type]
tys
  where
    cls_name :: Name
cls_name = Class -> Name
className Class
clas


{- ********************************************************************
*                                                                     *
                   Looking in the instance environment
*                                                                     *
***********************************************************************-}


matchInstEnv :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchInstEnv :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchInstEnv dflags :: DynFlags
dflags short_cut_solver :: Bool
short_cut_solver clas :: Class
clas tys :: [Type]
tys
   = do { InstEnvs
instEnvs <- TcM InstEnvs
tcGetInstEnvs
        ; let safeOverlapCheck :: Bool
safeOverlapCheck = DynFlags -> SafeHaskellMode
safeHaskell DynFlags
dflags SafeHaskellMode -> [SafeHaskellMode] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SafeHaskellMode
Sf_Safe, SafeHaskellMode
Sf_Trustworthy]
              (matches :: [InstMatch]
matches, unify :: [ClsInst]
unify, unsafeOverlaps :: [InstMatch]
unsafeOverlaps) = Bool
-> InstEnvs
-> Class
-> [Type]
-> ([InstMatch], [ClsInst], [InstMatch])
lookupInstEnv Bool
True InstEnvs
instEnvs Class
clas [Type]
tys
              safeHaskFail :: Bool
safeHaskFail = Bool
safeOverlapCheck Bool -> Bool -> Bool
&& Bool -> Bool
not ([InstMatch] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InstMatch]
unsafeOverlaps)
        ; String -> SDoc -> TcRn ()
traceTc "matchInstEnv" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
            [SDoc] -> SDoc
vcat [ String -> SDoc
text "goal:" SDoc -> SDoc -> SDoc
<+> Class -> SDoc
forall a. Outputable a => a -> SDoc
ppr Class
clas SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
tys
                 , String -> SDoc
text "matches:" SDoc -> SDoc -> SDoc
<+> [InstMatch] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InstMatch]
matches
                 , String -> SDoc
text "unify:" SDoc -> SDoc -> SDoc
<+> [ClsInst] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [ClsInst]
unify ]
        ; case ([InstMatch]
matches, [ClsInst]
unify, Bool
safeHaskFail) of

            -- Nothing matches
            ([], [], _)
                -> do { String -> SDoc -> TcRn ()
traceTc "matchClass not matching" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pred)
                      ; ClsInstResult -> TcM ClsInstResult
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInstResult
NoInstance }

            -- A single match (& no safe haskell failure)
            ([(ispec :: ClsInst
ispec, inst_tys :: [DFunInstType]
inst_tys)], [], False)
                | Bool
short_cut_solver      -- Called from the short-cut solver
                , ClsInst -> Bool
isOverlappable ClsInst
ispec
                -- If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT
                -- then don't let the short-cut solver choose it, because a
                -- later instance might overlap it.  Trac #14434 is an example
                -- See Note [Shortcut solving: overlap]
                -> do { String -> SDoc -> TcRn ()
traceTc "matchClass: ignoring overlappable" (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pred)
                      ; ClsInstResult -> TcM ClsInstResult
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInstResult
NotSure }

                | Bool
otherwise
                -> do { let dfun_id :: TyVar
dfun_id = ClsInst -> TyVar
instanceDFunId ClsInst
ispec
                      ; String -> SDoc -> TcRn ()
traceTc "matchClass success" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
                        [SDoc] -> SDoc
vcat [String -> SDoc
text "dict" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pred,
                              String -> SDoc
text "witness" SDoc -> SDoc -> SDoc
<+> TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
dfun_id
                                             SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TyVar -> Type
idType TyVar
dfun_id) ]
                                -- Record that this dfun is needed
                      ; Bool -> TyVar -> [DFunInstType] -> TcM ClsInstResult
match_one ([InstMatch] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InstMatch]
unsafeOverlaps) TyVar
dfun_id [DFunInstType]
inst_tys }

            -- More than one matches (or Safe Haskell fail!). Defer any
            -- reactions of a multitude until we learn more about the reagent
            _   -> do { String -> SDoc -> TcRn ()
traceTc "matchClass multiple matches, deferring choice" (SDoc -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$
                        [SDoc] -> SDoc
vcat [String -> SDoc
text "dict" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
pred,
                              String -> SDoc
text "matches" SDoc -> SDoc -> SDoc
<+> [InstMatch] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [InstMatch]
matches]
                      ; ClsInstResult -> TcM ClsInstResult
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInstResult
NotSure } }
   where
     pred :: Type
pred = Class -> [Type] -> Type
mkClassPred Class
clas [Type]
tys

match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcM ClsInstResult
             -- See Note [DFunInstType: instantiating types] in InstEnv
match_one :: Bool -> TyVar -> [DFunInstType] -> TcM ClsInstResult
match_one so :: Bool
so dfun_id :: TyVar
dfun_id mb_inst_tys :: [DFunInstType]
mb_inst_tys
  = do { String -> SDoc -> TcRn ()
traceTc "match_one" (TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
dfun_id SDoc -> SDoc -> SDoc
$$ [DFunInstType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [DFunInstType]
mb_inst_tys)
       ; (tys :: [Type]
tys, theta :: [Type]
theta) <- TyVar -> [DFunInstType] -> TcM ([Type], [Type])
instDFunType TyVar
dfun_id [DFunInstType]
mb_inst_tys
       ; String -> SDoc -> TcRn ()
traceTc "match_one 2" (TyVar -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyVar
dfun_id SDoc -> SDoc -> SDoc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
tys SDoc -> SDoc -> SDoc
$$ [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
theta)
       ; ClsInstResult -> TcM ClsInstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ClsInstResult -> TcM ClsInstResult)
-> ClsInstResult -> TcM ClsInstResult
forall a b. (a -> b) -> a -> b
$ OneInst :: [Type] -> ([EvExpr] -> EvTerm) -> InstanceWhat -> ClsInstResult
OneInst { cir_new_theta :: [Type]
cir_new_theta = [Type]
theta
                          , cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev     = TyVar -> [Type] -> [EvExpr] -> EvTerm
evDFunApp TyVar
dfun_id [Type]
tys
                          , cir_what :: InstanceWhat
cir_what      = TopLevInstance :: TyVar -> Bool -> InstanceWhat
TopLevInstance { iw_dfun_id :: TyVar
iw_dfun_id = TyVar
dfun_id
                                                           , iw_safe_over :: Bool
iw_safe_over = Bool
so } } }


{- Note [Shortcut solving: overlap]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have
  instance {-# OVERLAPPABLE #-} C a where ...
and we are typechecking
  f :: C a => a -> a
  f = e  -- Gives rise to [W] C a

We don't want to solve the wanted constraint with the overlappable
instance; rather we want to use the supplied (C a)! That was the whole
point of it being overlappable!  Trac #14434 wwas an example.

Alas even if the instance has no overlap flag, thus
  instance C a where ...
there is nothing to stop it being overlapped. GHC provides no way to
declare an instance as "final" so it can't be overlapped.  But really
only final instances are OK for short-cut solving.  Sigh. Trac #15135
was a puzzling example.
-}


{- ********************************************************************
*                                                                     *
                   Class lookup for CTuples
*                                                                     *
***********************************************************************-}

matchCTuple :: Class -> [Type] -> TcM ClsInstResult
matchCTuple :: Class -> [Type] -> TcM ClsInstResult
matchCTuple clas :: Class
clas tys :: [Type]
tys   -- (isCTupleClass clas) holds
  = ClsInstResult -> TcM ClsInstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (OneInst :: [Type] -> ([EvExpr] -> EvTerm) -> InstanceWhat -> ClsInstResult
OneInst { cir_new_theta :: [Type]
cir_new_theta = [Type]
tys
                    , cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev     = [EvExpr] -> EvTerm
tuple_ev
                    , cir_what :: InstanceWhat
cir_what      = InstanceWhat
BuiltinInstance })
            -- The dfun *is* the data constructor!
  where
     data_con :: DataCon
data_con = TyCon -> DataCon
tyConSingleDataCon (Class -> TyCon
classTyCon Class
clas)
     tuple_ev :: [EvExpr] -> EvTerm
tuple_ev = TyVar -> [Type] -> [EvExpr] -> EvTerm
evDFunApp (DataCon -> TyVar
dataConWrapId DataCon
data_con) [Type]
tys

{- ********************************************************************
*                                                                     *
                   Class lookup for Literals
*                                                                     *
***********************************************************************-}

{-
Note [KnownNat & KnownSymbol and EvLit]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A part of the type-level literals implementation are the classes
"KnownNat" and "KnownSymbol", which provide a "smart" constructor for
defining singleton values.  Here is the key stuff from GHC.TypeLits

  class KnownNat (n :: Nat) where
    natSing :: SNat n

  newtype SNat (n :: Nat) = SNat Integer

Conceptually, this class has infinitely many instances:

  instance KnownNat 0       where natSing = SNat 0
  instance KnownNat 1       where natSing = SNat 1
  instance KnownNat 2       where natSing = SNat 2
  ...

In practice, we solve `KnownNat` predicates in the type-checker
(see typecheck/TcInteract.hs) because we can't have infinitely many instances.
The evidence (aka "dictionary") for `KnownNat` is of the form `EvLit (EvNum n)`.

We make the following assumptions about dictionaries in GHC:
  1. The "dictionary" for classes with a single method---like `KnownNat`---is
     a newtype for the type of the method, so using a evidence amounts
     to a coercion, and
  2. Newtypes use the same representation as their definition types.

So, the evidence for `KnownNat` is just a value of the representation type,
wrapped in two newtype constructors: one to make it into a `SNat` value,
and another to make it into a `KnownNat` dictionary.

Also note that `natSing` and `SNat` are never actually exposed from the
library---they are just an implementation detail.  Instead, users see
a more convenient function, defined in terms of `natSing`:

  natVal :: KnownNat n => proxy n -> Integer

The reason we don't use this directly in the class is that it is simpler
and more efficient to pass around an integer rather than an entire function,
especially when the `KnowNat` evidence is packaged up in an existential.

The story for kind `Symbol` is analogous:
  * class KnownSymbol
  * newtype SSymbol
  * Evidence: a Core literal (e.g. mkNaturalExpr)


Note [Fabricating Evidence for Literals in Backpack]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Let `T` be a type of kind `Nat`. When solving for a purported instance
of `KnownNat T`, ghc tries to resolve the type `T` to an integer `n`,
in which case the evidence `EvLit (EvNum n)` is generated on the
fly. It might appear that this is sufficient as users cannot define
their own instances of `KnownNat`. However, for backpack module this
would not work (see issue #15379). Consider the signature `Abstract`

> signature Abstract where
>   data T :: Nat
>   instance KnownNat T

and a module `Util` that depends on it:

> module Util where
>  import Abstract
>  printT :: IO ()
>  printT = do print $ natVal (Proxy :: Proxy T)

Clearly, we need to "use" the dictionary associated with `KnownNat T`
in the module `Util`, but it is too early for the compiler to produce
a real dictionary as we still have not fixed what `T` is. Only when we
mixin a concrete module

> module Concrete where
>   type T = 42

do we really get hold of the underlying integer. So the strategy that
we follow is the following

1. If T is indeed available as a type alias for an integer constant,
   generate the dictionary on the fly, failing which

2. Look up the type class environment for the evidence.

Finally actual code gets generate for Util only when a module like
Concrete gets "mixed-in" in place of the signature Abstract. As a
result all things, including the typeclass instances, in Concrete gets
reexported. So `KnownNat` gets resolved the normal way post-Backpack.

A similar generation works for `KnownSymbol` as well

-}

matchKnownNat :: DynFlags
              -> Bool      -- True <=> caller is the short-cut solver
                           -- See Note [Shortcut solving: overlap]
              -> Class -> [Type] -> TcM ClsInstResult
matchKnownNat :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchKnownNat _ _ clas :: Class
clas [ty :: Type
ty]     -- clas = KnownNat
  | Just n :: Integer
n <- Type -> Maybe Integer
isNumLitTy Type
ty = do
        EvExpr
et <- Integer -> IOEnv (Env TcGblEnv TcLclEnv) EvExpr
forall (m :: * -> *). MonadThings m => Integer -> m EvExpr
mkNaturalExpr Integer
n
        Class -> Type -> EvExpr -> TcM ClsInstResult
makeLitDict Class
clas Type
ty EvExpr
et
matchKnownNat df :: DynFlags
df sc :: Bool
sc clas :: Class
clas tys :: [Type]
tys = DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchInstEnv DynFlags
df Bool
sc Class
clas [Type]
tys
 -- See Note [Fabricating Evidence for Literals in Backpack] for why
 -- this lookup into the instance environment is required.

matchKnownSymbol :: DynFlags
                 -> Bool      -- True <=> caller is the short-cut solver
                              -- See Note [Shortcut solving: overlap]
                 -> Class -> [Type] -> TcM ClsInstResult
matchKnownSymbol :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchKnownSymbol _ _ clas :: Class
clas [ty :: Type
ty]  -- clas = KnownSymbol
  | Just s :: FastString
s <- Type -> Maybe FastString
isStrLitTy Type
ty = do
        EvExpr
et <- FastString -> IOEnv (Env TcGblEnv TcLclEnv) EvExpr
forall (m :: * -> *). MonadThings m => FastString -> m EvExpr
mkStringExprFS FastString
s
        Class -> Type -> EvExpr -> TcM ClsInstResult
makeLitDict Class
clas Type
ty EvExpr
et
matchKnownSymbol df :: DynFlags
df sc :: Bool
sc clas :: Class
clas tys :: [Type]
tys = DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchInstEnv DynFlags
df Bool
sc Class
clas [Type]
tys
 -- See Note [Fabricating Evidence for Literals in Backpack] for why
 -- this lookup into the instance environment is required.

makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult
-- makeLitDict adds a coercion that will convert the literal into a dictionary
-- of the appropriate type.  See Note [KnownNat & KnownSymbol and EvLit]
-- in TcEvidence.  The coercion happens in 2 steps:
--
--     Integer -> SNat n     -- representation of literal to singleton
--     SNat n  -> KnownNat n -- singleton to dictionary
--
--     The process is mirrored for Symbols:
--     String    -> SSymbol n
--     SSymbol n -> KnownSymbol n
makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult
makeLitDict clas :: Class
clas ty :: Type
ty et :: EvExpr
et
    | Just (_, co_dict :: TcCoercion
co_dict) <- TyCon -> [Type] -> Maybe (Type, TcCoercion)
tcInstNewTyCon_maybe (Class -> TyCon
classTyCon Class
clas) [Type
ty]
          -- co_dict :: KnownNat n ~ SNat n
    , [ meth :: TyVar
meth ]   <- Class -> [TyVar]
classMethods Class
clas
    , Just tcRep :: TyCon
tcRep <- Type -> Maybe TyCon
tyConAppTyCon_maybe -- SNat
                      (Type -> Maybe TyCon) -> Type -> Maybe TyCon
forall a b. (a -> b) -> a -> b
$ Type -> Type
funResultTy         -- SNat n
                      (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Type -> Type
dropForAlls         -- KnownNat n => SNat n
                      (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ TyVar -> Type
idType TyVar
meth         -- forall n. KnownNat n => SNat n
    , Just (_, co_rep :: TcCoercion
co_rep) <- TyCon -> [Type] -> Maybe (Type, TcCoercion)
tcInstNewTyCon_maybe TyCon
tcRep [Type
ty]
          -- SNat n ~ Integer
    , let ev_tm :: EvTerm
ev_tm = EvExpr -> TcCoercion -> EvTerm
mkEvCast EvExpr
et (TcCoercion -> TcCoercion
mkTcSymCo (TcCoercion -> TcCoercion -> TcCoercion
mkTcTransCo TcCoercion
co_dict TcCoercion
co_rep))
    = ClsInstResult -> TcM ClsInstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ClsInstResult -> TcM ClsInstResult)
-> ClsInstResult -> TcM ClsInstResult
forall a b. (a -> b) -> a -> b
$ OneInst :: [Type] -> ([EvExpr] -> EvTerm) -> InstanceWhat -> ClsInstResult
OneInst { cir_new_theta :: [Type]
cir_new_theta = []
                       , cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev     = \_ -> EvTerm
ev_tm
                       , cir_what :: InstanceWhat
cir_what      = InstanceWhat
BuiltinInstance }

    | Bool
otherwise
    = String -> SDoc -> TcM ClsInstResult
forall a. HasCallStack => String -> SDoc -> a
pprPanic "makeLitDict" (SDoc -> TcM ClsInstResult) -> SDoc -> TcM ClsInstResult
forall a b. (a -> b) -> a -> b
$
      String -> SDoc
text "Unexpected evidence for" SDoc -> SDoc -> SDoc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Class -> Name
className Class
clas)
      SDoc -> SDoc -> SDoc
$$ [SDoc] -> SDoc
vcat ((TyVar -> SDoc) -> [TyVar] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Type -> SDoc) -> (TyVar -> Type) -> TyVar -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVar -> Type
idType) (Class -> [TyVar]
classMethods Class
clas))

{- ********************************************************************
*                                                                     *
                   Class lookup for Typeable
*                                                                     *
***********************************************************************-}

-- | Assumes that we've checked that this is the 'Typeable' class,
-- and it was applied to the correct argument.
matchTypeable :: Class -> [Type] -> TcM ClsInstResult
matchTypeable :: Class -> [Type] -> TcM ClsInstResult
matchTypeable clas :: Class
clas [k :: Type
k,t :: Type
t]  -- clas = Typeable
  -- For the first two cases, See Note [No Typeable for polytypes or qualified types]
  | Type -> Bool
isForAllTy Type
k                      = ClsInstResult -> TcM ClsInstResult
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInstResult
NoInstance   -- Polytype
  | Maybe (Type, Type) -> Bool
forall a. Maybe a -> Bool
isJust (Type -> Maybe (Type, Type)
tcSplitPredFunTy_maybe Type
t) = ClsInstResult -> TcM ClsInstResult
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInstResult
NoInstance   -- Qualified type

  -- Now cases that do work
  | Type
k Type -> Type -> Bool
`eqType` Type
typeNatKind                 = Name -> Type -> TcM ClsInstResult
doTyLit Name
knownNatClassName         Type
t
  | Type
k Type -> Type -> Bool
`eqType` Type
typeSymbolKind              = Name -> Type -> TcM ClsInstResult
doTyLit Name
knownSymbolClassName      Type
t
  | Type -> Bool
tcIsConstraintKind Type
t                   = Class -> Type -> TyCon -> [Type] -> TcM ClsInstResult
doTyConApp Class
clas Type
t TyCon
constraintKindTyCon []
  | Just (arg :: Type
arg,ret :: Type
ret) <- Type -> Maybe (Type, Type)
splitFunTy_maybe Type
t   = Class -> Type -> Type -> Type -> TcM ClsInstResult
doFunTy    Class
clas Type
t Type
arg Type
ret
  | Just (tc :: TyCon
tc, ks :: [Type]
ks) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
t -- See Note [Typeable (T a b c)]
  , TyCon -> [Type] -> Bool
onlyNamedBndrsApplied TyCon
tc [Type]
ks            = Class -> Type -> TyCon -> [Type] -> TcM ClsInstResult
doTyConApp Class
clas Type
t TyCon
tc [Type]
ks
  | Just (f :: Type
f,kt :: Type
kt)   <- Type -> Maybe (Type, Type)
splitAppTy_maybe Type
t    = Class -> Type -> Type -> Type -> TcM ClsInstResult
doTyApp    Class
clas Type
t Type
f Type
kt

matchTypeable _ _ = ClsInstResult -> TcM ClsInstResult
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInstResult
NoInstance

-- | Representation for a type @ty@ of the form @arg -> ret@.
doFunTy :: Class -> Type -> Type -> Type -> TcM ClsInstResult
doFunTy :: Class -> Type -> Type -> Type -> TcM ClsInstResult
doFunTy clas :: Class
clas ty :: Type
ty arg_ty :: Type
arg_ty ret_ty :: Type
ret_ty
  = ClsInstResult -> TcM ClsInstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ClsInstResult -> TcM ClsInstResult)
-> ClsInstResult -> TcM ClsInstResult
forall a b. (a -> b) -> a -> b
$ OneInst :: [Type] -> ([EvExpr] -> EvTerm) -> InstanceWhat -> ClsInstResult
OneInst { cir_new_theta :: [Type]
cir_new_theta = [Type]
preds
                     , cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev     = [EvExpr] -> EvTerm
mk_ev
                     , cir_what :: InstanceWhat
cir_what      = InstanceWhat
BuiltinInstance }
  where
    preds :: [Type]
preds = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Class -> Type -> Type
mk_typeable_pred Class
clas) [Type
arg_ty, Type
ret_ty]
    mk_ev :: [EvExpr] -> EvTerm
mk_ev [arg_ev :: EvExpr
arg_ev, ret_ev :: EvExpr
ret_ev] = Type -> EvTypeable -> EvTerm
evTypeable Type
ty (EvTypeable -> EvTerm) -> EvTypeable -> EvTerm
forall a b. (a -> b) -> a -> b
$
                             EvTerm -> EvTerm -> EvTypeable
EvTypeableTrFun (EvExpr -> EvTerm
EvExpr EvExpr
arg_ev) (EvExpr -> EvTerm
EvExpr EvExpr
ret_ev)
    mk_ev _ = String -> EvTerm
forall a. String -> a
panic "TcInteract.doFunTy"


-- | Representation for type constructor applied to some kinds.
-- 'onlyNamedBndrsApplied' has ensured that this application results in a type
-- of monomorphic kind (e.g. all kind variables have been instantiated).
doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult
doTyConApp :: Class -> Type -> TyCon -> [Type] -> TcM ClsInstResult
doTyConApp clas :: Class
clas ty :: Type
ty tc :: TyCon
tc kind_args :: [Type]
kind_args
  | TyCon -> Bool
tyConIsTypeable TyCon
tc
  = ClsInstResult -> TcM ClsInstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ClsInstResult -> TcM ClsInstResult)
-> ClsInstResult -> TcM ClsInstResult
forall a b. (a -> b) -> a -> b
$ OneInst :: [Type] -> ([EvExpr] -> EvTerm) -> InstanceWhat -> ClsInstResult
OneInst { cir_new_theta :: [Type]
cir_new_theta = ((Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Class -> Type -> Type
mk_typeable_pred Class
clas) [Type]
kind_args)
                     , cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev     = [EvExpr] -> EvTerm
mk_ev
                     , cir_what :: InstanceWhat
cir_what      = InstanceWhat
BuiltinInstance }
  | Bool
otherwise
  = ClsInstResult -> TcM ClsInstResult
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInstResult
NoInstance
  where
    mk_ev :: [EvExpr] -> EvTerm
mk_ev kinds :: [EvExpr]
kinds = Type -> EvTypeable -> EvTerm
evTypeable Type
ty (EvTypeable -> EvTerm) -> EvTypeable -> EvTerm
forall a b. (a -> b) -> a -> b
$ TyCon -> [EvTerm] -> EvTypeable
EvTypeableTyCon TyCon
tc ((EvExpr -> EvTerm) -> [EvExpr] -> [EvTerm]
forall a b. (a -> b) -> [a] -> [b]
map EvExpr -> EvTerm
EvExpr [EvExpr]
kinds)

-- | Representation for TyCon applications of a concrete kind. We just use the
-- kind itself, but first we must make sure that we've instantiated all kind-
-- polymorphism, but no more.
onlyNamedBndrsApplied :: TyCon -> [KindOrType] -> Bool
onlyNamedBndrsApplied :: TyCon -> [Type] -> Bool
onlyNamedBndrsApplied tc :: TyCon
tc ks :: [Type]
ks
 = (TyConBinder -> Bool) -> [TyConBinder] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all TyConBinder -> Bool
isNamedTyConBinder [TyConBinder]
used_bndrs Bool -> Bool -> Bool
&&
   Bool -> Bool
not ((TyConBinder -> Bool) -> [TyConBinder] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TyConBinder -> Bool
isNamedTyConBinder [TyConBinder]
leftover_bndrs)
 where
   bndrs :: [TyConBinder]
bndrs                        = TyCon -> [TyConBinder]
tyConBinders TyCon
tc
   (used_bndrs :: [TyConBinder]
used_bndrs, leftover_bndrs :: [TyConBinder]
leftover_bndrs) = [Type] -> [TyConBinder] -> ([TyConBinder], [TyConBinder])
forall b a. [b] -> [a] -> ([a], [a])
splitAtList [Type]
ks [TyConBinder]
bndrs

doTyApp :: Class -> Type -> Type -> KindOrType -> TcM ClsInstResult
-- Representation for an application of a type to a type-or-kind.
--  This may happen when the type expression starts with a type variable.
--  Example (ignoring kind parameter):
--    Typeable (f Int Char)                      -->
--    (Typeable (f Int), Typeable Char)          -->
--    (Typeable f, Typeable Int, Typeable Char)  --> (after some simp. steps)
--    Typeable f
doTyApp :: Class -> Type -> Type -> Type -> TcM ClsInstResult
doTyApp clas :: Class
clas ty :: Type
ty f :: Type
f tk :: Type
tk
  | Type -> Bool
isForAllTy (HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
f)
  = ClsInstResult -> TcM ClsInstResult
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInstResult
NoInstance -- We can't solve until we know the ctr.
  | Bool
otherwise
  = ClsInstResult -> TcM ClsInstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (ClsInstResult -> TcM ClsInstResult)
-> ClsInstResult -> TcM ClsInstResult
forall a b. (a -> b) -> a -> b
$ OneInst :: [Type] -> ([EvExpr] -> EvTerm) -> InstanceWhat -> ClsInstResult
OneInst { cir_new_theta :: [Type]
cir_new_theta = (Type -> Type) -> [Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map (Class -> Type -> Type
mk_typeable_pred Class
clas) [Type
f, Type
tk]
                     , cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev     = [EvExpr] -> EvTerm
mk_ev
                     , cir_what :: InstanceWhat
cir_what      = InstanceWhat
BuiltinInstance }
  where
    mk_ev :: [EvExpr] -> EvTerm
mk_ev [t1 :: EvExpr
t1,t2 :: EvExpr
t2] = Type -> EvTypeable -> EvTerm
evTypeable Type
ty (EvTypeable -> EvTerm) -> EvTypeable -> EvTerm
forall a b. (a -> b) -> a -> b
$ EvTerm -> EvTerm -> EvTypeable
EvTypeableTyApp (EvExpr -> EvTerm
EvExpr EvExpr
t1) (EvExpr -> EvTerm
EvExpr EvExpr
t2)
    mk_ev _ = String -> EvTerm
forall a. String -> a
panic "doTyApp"


-- Emit a `Typeable` constraint for the given type.
mk_typeable_pred :: Class -> Type -> PredType
mk_typeable_pred :: Class -> Type -> Type
mk_typeable_pred clas :: Class
clas ty :: Type
ty = Class -> [Type] -> Type
mkClassPred Class
clas [ HasDebugCallStack => Type -> Type
Type -> Type
tcTypeKind Type
ty, Type
ty ]

  -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal
  -- we generate a sub-goal for the appropriate class.
  -- See Note [Typeable for Nat and Symbol]
doTyLit :: Name -> Type -> TcM ClsInstResult
doTyLit :: Name -> Type -> TcM ClsInstResult
doTyLit kc :: Name
kc t :: Type
t = do { Class
kc_clas <- Name -> TcM Class
tcLookupClass Name
kc
                  ; let kc_pred :: Type
kc_pred    = Class -> [Type] -> Type
mkClassPred Class
kc_clas [ Type
t ]
                        mk_ev :: [EvExpr] -> EvTerm
mk_ev [ev :: EvExpr
ev] = Type -> EvTypeable -> EvTerm
evTypeable Type
t (EvTypeable -> EvTerm) -> EvTypeable -> EvTerm
forall a b. (a -> b) -> a -> b
$ EvTerm -> EvTypeable
EvTypeableTyLit (EvExpr -> EvTerm
EvExpr EvExpr
ev)
                        mk_ev _    = String -> EvTerm
forall a. String -> a
panic "doTyLit"
                  ; ClsInstResult -> TcM ClsInstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (OneInst :: [Type] -> ([EvExpr] -> EvTerm) -> InstanceWhat -> ClsInstResult
OneInst { cir_new_theta :: [Type]
cir_new_theta = [Type
kc_pred]
                                    , cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev     = [EvExpr] -> EvTerm
mk_ev
                                    , cir_what :: InstanceWhat
cir_what      = InstanceWhat
BuiltinInstance }) }

{- Note [Typeable (T a b c)]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For type applications we always decompose using binary application,
via doTyApp, until we get to a *kind* instantiation.  Example
   Proxy :: forall k. k -> *

To solve Typeable (Proxy (* -> *) Maybe) we
  - First decompose with doTyApp,
    to get (Typeable (Proxy (* -> *))) and Typeable Maybe
  - Then solve (Typeable (Proxy (* -> *))) with doTyConApp

If we attempt to short-cut by solving it all at once, via
doTyConApp

(this note is sadly truncated FIXME)


Note [No Typeable for polytypes or qualified types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We do not support impredicative typeable, such as
   Typeable (forall a. a->a)
   Typeable (Eq a => a -> a)
   Typeable (() => Int)
   Typeable (((),()) => Int)

See Trac #9858.  For forall's the case is clear: we simply don't have
a TypeRep for them.  For qualified but not polymorphic types, like
(Eq a => a -> a), things are murkier.  But:

 * We don't need a TypeRep for these things.  TypeReps are for
   monotypes only.

 * Perhaps we could treat `=>` as another type constructor for `Typeable`
   purposes, and thus support things like `Eq Int => Int`, however,
   at the current state of affairs this would be an odd exception as
   no other class works with impredicative types.
   For now we leave it off, until we have a better story for impredicativity.


Note [Typeable for Nat and Symbol]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We have special Typeable instances for Nat and Symbol.  Roughly we
have this instance, implemented here by doTyLit:
      instance KnownNat n => Typeable (n :: Nat) where
         typeRep = typeNatTypeRep @n
where
   Data.Typeable.Internals.typeNatTypeRep :: KnownNat a => TypeRep a

Ultimately typeNatTypeRep uses 'natSing' from KnownNat to get a
runtime value 'n'; it turns it into a string with 'show' and uses
that to whiz up a TypeRep TyCon for 'n', with mkTypeLitTyCon.
See #10348.

Because of this rule it's inadvisable (see #15322) to have a constraint
    f :: (Typeable (n :: Nat)) => blah
in a function signature; it gives rise to overlap problems just as
if you'd written
    f :: Eq [a] => blah
-}

{- ********************************************************************
*                                                                     *
                   Class lookup for lifted equality
*                                                                     *
***********************************************************************-}

-- See also Note [The equality types story] in TysPrim
matchHeteroEquality :: [Type] -> TcM ClsInstResult
-- Solves (t1 ~~ t2)
matchHeteroEquality :: [Type] -> TcM ClsInstResult
matchHeteroEquality args :: [Type]
args
  = ClsInstResult -> TcM ClsInstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (OneInst :: [Type] -> ([EvExpr] -> EvTerm) -> InstanceWhat -> ClsInstResult
OneInst { cir_new_theta :: [Type]
cir_new_theta = [ TyCon -> [Type] -> Type
mkTyConApp TyCon
eqPrimTyCon [Type]
args ]
                    , cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev     = DataCon -> [Type] -> [EvExpr] -> EvTerm
evDataConApp DataCon
heqDataCon [Type]
args
                    , cir_what :: InstanceWhat
cir_what      = InstanceWhat
BuiltinInstance })

matchHomoEquality :: [Type] -> TcM ClsInstResult
-- Solves (t1 ~ t2)
matchHomoEquality :: [Type] -> TcM ClsInstResult
matchHomoEquality args :: [Type]
args@[k :: Type
k,t1 :: Type
t1,t2 :: Type
t2]
  = ClsInstResult -> TcM ClsInstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (OneInst :: [Type] -> ([EvExpr] -> EvTerm) -> InstanceWhat -> ClsInstResult
OneInst { cir_new_theta :: [Type]
cir_new_theta = [ TyCon -> [Type] -> Type
mkTyConApp TyCon
eqPrimTyCon [Type
k,Type
k,Type
t1,Type
t2] ]
                    , cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev     = DataCon -> [Type] -> [EvExpr] -> EvTerm
evDataConApp DataCon
eqDataCon [Type]
args
                    , cir_what :: InstanceWhat
cir_what      = InstanceWhat
BuiltinInstance })
matchHomoEquality args :: [Type]
args = String -> SDoc -> TcM ClsInstResult
forall a. HasCallStack => String -> SDoc -> a
pprPanic "matchHomoEquality" ([Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
args)

-- See also Note [The equality types story] in TysPrim
matchCoercible :: [Type] -> TcM ClsInstResult
matchCoercible :: [Type] -> TcM ClsInstResult
matchCoercible args :: [Type]
args@[k :: Type
k, t1 :: Type
t1, t2 :: Type
t2]
  = ClsInstResult -> TcM ClsInstResult
forall (m :: * -> *) a. Monad m => a -> m a
return (OneInst :: [Type] -> ([EvExpr] -> EvTerm) -> InstanceWhat -> ClsInstResult
OneInst { cir_new_theta :: [Type]
cir_new_theta = [ TyCon -> [Type] -> Type
mkTyConApp TyCon
eqReprPrimTyCon [Type]
args' ]
                    , cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev     = DataCon -> [Type] -> [EvExpr] -> EvTerm
evDataConApp DataCon
coercibleDataCon [Type]
args
                    , cir_what :: InstanceWhat
cir_what      = InstanceWhat
BuiltinInstance })
  where
    args' :: [Type]
args' = [Type
k, Type
k, Type
t1, Type
t2]
matchCoercible args :: [Type]
args = String -> SDoc -> TcM ClsInstResult
forall a. HasCallStack => String -> SDoc -> a
pprPanic "matchLiftedCoercible" ([Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
args)


{- ********************************************************************
*                                                                     *
              Class lookup for overloaded record fields
*                                                                     *
***********************************************************************-}

{-
Note [HasField instances]
~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have

    data T y = MkT { foo :: [y] }

and `foo` is in scope.  Then GHC will automatically solve a constraint like

    HasField "foo" (T Int) b

by emitting a new wanted

    T alpha -> [alpha] ~# T Int -> b

and building a HasField dictionary out of the selector function `foo`,
appropriately cast.

The HasField class is defined (in GHC.Records) thus:

    class HasField (x :: k) r a | x r -> a where
      getField :: r -> a

Since this is a one-method class, it is represented as a newtype.
Hence we can solve `HasField "foo" (T Int) b` by taking an expression
of type `T Int -> b` and casting it using the newtype coercion.
Note that

    foo :: forall y . T y -> [y]

so the expression we construct is

    foo @alpha |> co

where

    co :: (T alpha -> [alpha]) ~# HasField "foo" (T Int) b

is built from

    co1 :: (T alpha -> [alpha]) ~# (T Int -> b)

which is the new wanted, and

    co2 :: (T Int -> b) ~# HasField "foo" (T Int) b

which can be derived from the newtype coercion.

If `foo` is not in scope, or has a higher-rank or existentially
quantified type, then the constraint is not solved automatically, but
may be solved by a user-supplied HasField instance.  Similarly, if we
encounter a HasField constraint where the field is not a literal
string, or does not belong to the type, then we fall back on the
normal constraint solver behaviour.
-}

-- See Note [HasField instances]
matchHasField :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchHasField :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchHasField dflags :: DynFlags
dflags short_cut :: Bool
short_cut clas :: Class
clas tys :: [Type]
tys
  = do { FamInstEnvs
fam_inst_envs <- TcM FamInstEnvs
tcGetFamInstEnvs
       ; GlobalRdrEnv
rdr_env       <- TcRn GlobalRdrEnv
getGlobalRdrEnv
       ; case [Type]
tys of
           -- We are matching HasField {k} x r a...
           [_k_ty :: Type
_k_ty, x_ty :: Type
x_ty, r_ty :: Type
r_ty, a_ty :: Type
a_ty]
               -- x should be a literal string
             | Just x :: FastString
x <- Type -> Maybe FastString
isStrLitTy Type
x_ty
               -- r should be an applied type constructor
             , Just (tc :: TyCon
tc, args :: [Type]
args) <- HasCallStack => Type -> Maybe (TyCon, [Type])
Type -> Maybe (TyCon, [Type])
tcSplitTyConApp_maybe Type
r_ty
               -- use representation tycon (if data family); it has the fields
             , let r_tc :: TyCon
r_tc = (TyCon, [Type], TcCoercion) -> TyCon
forall a b c. (a, b, c) -> a
fstOf3 (FamInstEnvs -> TyCon -> [Type] -> (TyCon, [Type], TcCoercion)
tcLookupDataFamInst FamInstEnvs
fam_inst_envs TyCon
tc [Type]
args)
               -- x should be a field of r
             , Just fl :: FieldLabel
fl <- FastString -> TyCon -> Maybe FieldLabel
lookupTyConFieldLabel FastString
x TyCon
r_tc
               -- the field selector should be in scope
             , Just gre :: GlobalRdrElt
gre <- GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt
lookupGRE_FieldLabel GlobalRdrEnv
rdr_env FieldLabel
fl

             -> do { TyVar
sel_id <- Name -> TcM TyVar
tcLookupId (FieldLabel -> Name
forall a. FieldLbl a -> a
flSelector FieldLabel
fl)
                   ; (tv_prs :: [(Name, TyVar)]
tv_prs, preds :: [Type]
preds, sel_ty :: Type
sel_ty) <- ([TyVar] -> TcM (TCvSubst, [TyVar]))
-> TyVar -> TcM ([(Name, TyVar)], [Type], Type)
tcInstType [TyVar] -> TcM (TCvSubst, [TyVar])
newMetaTyVars TyVar
sel_id

                         -- The first new wanted constraint equates the actual
                         -- type of the selector with the type (r -> a) within
                         -- the HasField x r a dictionary.  The preds will
                         -- typically be empty, but if the datatype has a
                         -- "stupid theta" then we have to include it here.
                   ; let theta :: [Type]
theta = Type -> Type -> Type
mkPrimEqPred Type
sel_ty (Type -> Type -> Type
mkFunTy Type
r_ty Type
a_ty) Type -> [Type] -> [Type]
forall a. a -> [a] -> [a]
: [Type]
preds

                         -- Use the equality proof to cast the selector Id to
                         -- type (r -> a), then use the newtype coercion to cast
                         -- it to a HasField dictionary.
                         mk_ev :: [EvExpr] -> EvTerm
mk_ev (ev1 :: EvExpr
ev1:evs :: [EvExpr]
evs) = TyVar -> [Type] -> [EvExpr] -> EvExpr
evSelector TyVar
sel_id [Type]
tvs [EvExpr]
evs EvExpr -> TcCoercion -> EvTerm
`evCast` TcCoercion
co
                           where
                             co :: TcCoercion
co = TcCoercion -> TcCoercion
mkTcSubCo (EvTerm -> TcCoercion
evTermCoercion (EvExpr -> EvTerm
EvExpr EvExpr
ev1))
                                      TcCoercion -> TcCoercion -> TcCoercion
`mkTcTransCo` TcCoercion -> TcCoercion
mkTcSymCo TcCoercion
co2
                         mk_ev [] = String -> EvTerm
forall a. String -> a
panic "matchHasField.mk_ev"

                         Just (_, co2 :: TcCoercion
co2) = TyCon -> [Type] -> Maybe (Type, TcCoercion)
tcInstNewTyCon_maybe (Class -> TyCon
classTyCon Class
clas)
                                                              [Type]
tys

                         tvs :: [Type]
tvs = [TyVar] -> [Type]
mkTyVarTys (((Name, TyVar) -> TyVar) -> [(Name, TyVar)] -> [TyVar]
forall a b. (a -> b) -> [a] -> [b]
map (Name, TyVar) -> TyVar
forall a b. (a, b) -> b
snd [(Name, TyVar)]
tv_prs)

                     -- The selector must not be "naughty" (i.e. the field
                     -- cannot have an existentially quantified type), and
                     -- it must not be higher-rank.
                   ; if Bool -> Bool
not (TyVar -> Bool
isNaughtyRecordSelector TyVar
sel_id) Bool -> Bool -> Bool
&& Type -> Bool
isTauTy Type
sel_ty
                     then do { Bool -> GlobalRdrElt -> TcRn ()
addUsedGRE Bool
True GlobalRdrElt
gre
                             ; ClsInstResult -> TcM ClsInstResult
forall (m :: * -> *) a. Monad m => a -> m a
return OneInst :: [Type] -> ([EvExpr] -> EvTerm) -> InstanceWhat -> ClsInstResult
OneInst { cir_new_theta :: [Type]
cir_new_theta = [Type]
theta
                                              , cir_mk_ev :: [EvExpr] -> EvTerm
cir_mk_ev     = [EvExpr] -> EvTerm
mk_ev
                                              , cir_what :: InstanceWhat
cir_what      = InstanceWhat
BuiltinInstance } }
                     else DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchInstEnv DynFlags
dflags Bool
short_cut Class
clas [Type]
tys }

           _ -> DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult
matchInstEnv DynFlags
dflags Bool
short_cut Class
clas [Type]
tys }