{-# LANGUAGE CPP, MultiWayIf, TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Tc.Utils.Instantiate (
topSkolemise,
topInstantiate, topInstantiateInferred,
instCall, instDFunType, instStupidTheta, instTyVarsWith,
newWanted, newWanteds,
tcInstType, tcInstTypeBndrs,
tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt,
tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX,
freshenTyVarBndrs, freshenCoVarBndrsX,
tcInstInvisibleTyBindersN, tcInstInvisibleTyBinders, tcInstInvisibleTyBinder,
newOverloadedLit, mkOverLit,
newClsInst,
tcGetInsts, tcGetInstEnvs, getOverlapFlag,
tcExtendLocalInstEnv,
instCallConstraints, newMethodFromName,
tcSyntaxName,
tyCoVarsOfWC,
tyCoVarsOfCt, tyCoVarsOfCts,
) where
#include "GhclibHsVersions.h"
import GHC.Prelude
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckPolyExpr, tcSyntaxOp )
import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType, unifyKind )
import GHC.Types.Basic ( IntegralLit(..), SourceText(..) )
import GHC.Hs
import GHC.Tc.Utils.Zonk
import GHC.Tc.Utils.Monad
import GHC.Tc.Types.Constraint
import GHC.Core.Predicate
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.Env
import GHC.Tc.Types.Evidence
import GHC.Core.InstEnv
import GHC.Builtin.Types ( heqDataCon, eqDataCon, integerTyConName )
import GHC.Core ( isOrphan )
import GHC.Tc.Instance.FunDeps
import GHC.Tc.Utils.TcMType
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr ( debugPprType )
import GHC.Tc.Utils.TcType
import GHC.Driver.Types
import GHC.Core.Class( Class )
import GHC.Types.Id.Make( mkDictFunId )
import GHC.Core( Expr(..) )
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Var
import GHC.Core.DataCon
import GHC.Types.Var.Env
import GHC.Builtin.Names
import GHC.Types.SrcLoc as SrcLoc
import GHC.Driver.Session
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Types.Basic ( TypeOrKind(..) )
import qualified GHC.LanguageExtensions as LangExt
import Data.List ( sortBy, mapAccumL )
import Control.Monad( unless )
import Data.Function ( on )
newMethodFromName
:: CtOrigin
-> Name
-> [TcRhoType]
-> TcM (HsExpr GhcTc)
newMethodFromName :: CtOrigin -> Name -> [TcRhoType] -> TcM (HsExpr GhcTc)
newMethodFromName CtOrigin
origin Name
name [TcRhoType]
ty_args
= do { Id
id <- Name -> TcM Id
tcLookupId Name
name
; let ty :: TcRhoType
ty = HasDebugCallStack => TcRhoType -> [TcRhoType] -> TcRhoType
TcRhoType -> [TcRhoType] -> TcRhoType
piResultTys (Id -> TcRhoType
idType Id
id) [TcRhoType]
ty_args
([TcRhoType]
theta, TcRhoType
_caller_knows_this) = TcRhoType -> ([TcRhoType], TcRhoType)
tcSplitPhiTy TcRhoType
ty
; HsWrapper
wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )
CtOrigin
-> [TcRhoType]
-> [TcRhoType]
-> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
instCall CtOrigin
origin [TcRhoType]
ty_args [TcRhoType]
theta
; HsExpr GhcTc -> TcM (HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (XVar GhcTc -> Located (IdP GhcTc) -> HsExpr GhcTc
forall p. XVar p -> Located (IdP p) -> HsExpr p
HsVar NoExtField
XVar GhcTc
noExtField (Id -> Located Id
forall e. e -> Located e
noLoc Id
id))) }
topSkolemise :: TcSigmaType
-> TcM ( HsWrapper
, [(Name,TyVar)]
, [EvVar]
, TcRhoType )
topSkolemise :: TcRhoType -> TcM (HsWrapper, [(Name, Id)], [Id], TcRhoType)
topSkolemise TcRhoType
ty
= TCvSubst
-> HsWrapper
-> [(Name, Id)]
-> [Id]
-> TcRhoType
-> TcM (HsWrapper, [(Name, Id)], [Id], TcRhoType)
go TCvSubst
init_subst HsWrapper
idHsWrapper [] [] TcRhoType
ty
where
init_subst :: TCvSubst
init_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (VarSet -> InScopeSet
mkInScopeSet (TcRhoType -> VarSet
tyCoVarsOfType TcRhoType
ty))
go :: TCvSubst
-> HsWrapper
-> [(Name, Id)]
-> [Id]
-> TcRhoType
-> TcM (HsWrapper, [(Name, Id)], [Id], TcRhoType)
go TCvSubst
subst HsWrapper
wrap [(Name, Id)]
tv_prs [Id]
ev_vars TcRhoType
ty
| ([Id]
tvs, [TcRhoType]
theta, TcRhoType
inner_ty) <- TcRhoType -> ([Id], [TcRhoType], TcRhoType)
tcSplitSigmaTy TcRhoType
ty
, Bool -> Bool
not ([Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
tvs Bool -> Bool -> Bool
&& [TcRhoType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcRhoType]
theta)
= do { (TCvSubst
subst', [Id]
tvs1) <- TCvSubst -> [Id] -> TcM (TCvSubst, [Id])
tcInstSkolTyVarsX TCvSubst
subst [Id]
tvs
; [Id]
ev_vars1 <- [TcRhoType] -> TcM [Id]
newEvVars (HasCallStack => TCvSubst -> [TcRhoType] -> [TcRhoType]
TCvSubst -> [TcRhoType] -> [TcRhoType]
substTheta TCvSubst
subst' [TcRhoType]
theta)
; TCvSubst
-> HsWrapper
-> [(Name, Id)]
-> [Id]
-> TcRhoType
-> TcM (HsWrapper, [(Name, Id)], [Id], TcRhoType)
go TCvSubst
subst'
(HsWrapper
wrap HsWrapper -> HsWrapper -> HsWrapper
<.> [Id] -> HsWrapper
mkWpTyLams [Id]
tvs1 HsWrapper -> HsWrapper -> HsWrapper
<.> [Id] -> HsWrapper
mkWpLams [Id]
ev_vars1)
([(Name, Id)]
tv_prs [(Name, Id)] -> [(Name, Id)] -> [(Name, Id)]
forall a. [a] -> [a] -> [a]
++ ((Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
tyVarName [Id]
tvs [Name] -> [Id] -> [(Name, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
tvs1))
([Id]
ev_vars [Id] -> [Id] -> [Id]
forall a. [a] -> [a] -> [a]
++ [Id]
ev_vars1)
TcRhoType
inner_ty }
| Bool
otherwise
= (HsWrapper, [(Name, Id)], [Id], TcRhoType)
-> TcM (HsWrapper, [(Name, Id)], [Id], TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
wrap, [(Name, Id)]
tv_prs, [Id]
ev_vars, HasCallStack => TCvSubst -> TcRhoType -> TcRhoType
TCvSubst -> TcRhoType -> TcRhoType
substTy TCvSubst
subst TcRhoType
ty)
topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
topInstantiate :: CtOrigin -> TcRhoType -> TcM (HsWrapper, TcRhoType)
topInstantiate = Bool -> CtOrigin -> TcRhoType -> TcM (HsWrapper, TcRhoType)
top_instantiate Bool
True
topInstantiateInferred :: CtOrigin -> TcSigmaType
-> TcM (HsWrapper, TcSigmaType)
topInstantiateInferred :: CtOrigin -> TcRhoType -> TcM (HsWrapper, TcRhoType)
topInstantiateInferred = Bool -> CtOrigin -> TcRhoType -> TcM (HsWrapper, TcRhoType)
top_instantiate Bool
False
top_instantiate :: Bool
-> CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
top_instantiate :: Bool -> CtOrigin -> TcRhoType -> TcM (HsWrapper, TcRhoType)
top_instantiate Bool
inst_all CtOrigin
orig TcRhoType
ty
| ([TyVarBinder]
binders, TcRhoType
phi) <- TcRhoType -> ([TyVarBinder], TcRhoType)
tcSplitForAllVarBndrs TcRhoType
ty
, ([TcRhoType]
theta, TcRhoType
rho) <- TcRhoType -> ([TcRhoType], TcRhoType)
tcSplitPhiTy TcRhoType
phi
, Bool -> Bool
not ([TyVarBinder] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBinder]
binders Bool -> Bool -> Bool
&& [TcRhoType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcRhoType]
theta)
= do { let ([TyVarBinder]
inst_bndrs, [TyVarBinder]
leave_bndrs) = (TyVarBinder -> Bool)
-> [TyVarBinder] -> ([TyVarBinder], [TyVarBinder])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span TyVarBinder -> Bool
forall tv. VarBndr tv ArgFlag -> Bool
should_inst [TyVarBinder]
binders
([TcRhoType]
inst_theta, [TcRhoType]
leave_theta)
| [TyVarBinder] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBinder]
leave_bndrs = ([TcRhoType]
theta, [])
| Bool
otherwise = ([], [TcRhoType]
theta)
in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet (TcRhoType -> VarSet
tyCoVarsOfType TcRhoType
ty)
empty_subst :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst InScopeSet
in_scope
inst_tvs :: [Id]
inst_tvs = [TyVarBinder] -> [Id]
forall tv argf. [VarBndr tv argf] -> [tv]
binderVars [TyVarBinder]
inst_bndrs
; (TCvSubst
subst, [Id]
inst_tvs') <- (TCvSubst -> Id -> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, Id))
-> TCvSubst -> [Id] -> TcM (TCvSubst, [Id])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM TCvSubst -> Id -> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, Id)
newMetaTyVarX TCvSubst
empty_subst [Id]
inst_tvs
; let inst_theta' :: [TcRhoType]
inst_theta' = HasCallStack => TCvSubst -> [TcRhoType] -> [TcRhoType]
TCvSubst -> [TcRhoType] -> [TcRhoType]
substTheta TCvSubst
subst [TcRhoType]
inst_theta
sigma' :: TcRhoType
sigma' = HasCallStack => TCvSubst -> TcRhoType -> TcRhoType
TCvSubst -> TcRhoType -> TcRhoType
substTy TCvSubst
subst ([TyVarBinder] -> TcRhoType -> TcRhoType
mkForAllTys [TyVarBinder]
leave_bndrs (TcRhoType -> TcRhoType) -> TcRhoType -> TcRhoType
forall a b. (a -> b) -> a -> b
$
[TcRhoType] -> TcRhoType -> TcRhoType
mkPhiTy [TcRhoType]
leave_theta TcRhoType
rho)
inst_tv_tys' :: [TcRhoType]
inst_tv_tys' = [Id] -> [TcRhoType]
mkTyVarTys [Id]
inst_tvs'
; HsWrapper
wrap1 <- CtOrigin
-> [TcRhoType]
-> [TcRhoType]
-> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
instCall CtOrigin
orig [TcRhoType]
inst_tv_tys' [TcRhoType]
inst_theta'
; String -> SDoc -> TcRn ()
traceTc String
"Instantiating"
([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"all tyvars?" SDoc -> SDoc -> SDoc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
inst_all
, String -> SDoc
text String
"origin" SDoc -> SDoc -> SDoc
<+> CtOrigin -> SDoc
pprCtOrigin CtOrigin
orig
, String -> SDoc
text String
"type" SDoc -> SDoc -> SDoc
<+> TcRhoType -> SDoc
debugPprType TcRhoType
ty
, String -> SDoc
text String
"theta" SDoc -> SDoc -> SDoc
<+> [TcRhoType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcRhoType]
theta
, String -> SDoc
text String
"leave_bndrs" SDoc -> SDoc -> SDoc
<+> [TyVarBinder] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TyVarBinder]
leave_bndrs
, String -> SDoc
text String
"with" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat ((TcRhoType -> SDoc) -> [TcRhoType] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map TcRhoType -> SDoc
debugPprType [TcRhoType]
inst_tv_tys')
, String -> SDoc
text String
"theta:" SDoc -> SDoc -> SDoc
<+> [TcRhoType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcRhoType]
inst_theta' ])
; (HsWrapper
wrap2, TcRhoType
rho2) <-
if [TyVarBinder] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TyVarBinder]
leave_bndrs
then Bool -> CtOrigin -> TcRhoType -> TcM (HsWrapper, TcRhoType)
top_instantiate Bool
inst_all CtOrigin
orig TcRhoType
sigma'
else (HsWrapper, TcRhoType) -> TcM (HsWrapper, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
idHsWrapper, TcRhoType
sigma')
; (HsWrapper, TcRhoType) -> TcM (HsWrapper, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
wrap2 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap1, TcRhoType
rho2) }
| Bool
otherwise = (HsWrapper, TcRhoType) -> TcM (HsWrapper, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
idHsWrapper, TcRhoType
ty)
where
should_inst :: VarBndr tv ArgFlag -> Bool
should_inst VarBndr tv ArgFlag
bndr
| Bool
inst_all = Bool
True
| Bool
otherwise = VarBndr tv ArgFlag -> ArgFlag
forall tv argf. VarBndr tv argf -> argf
binderArgFlag VarBndr tv ArgFlag
bndr ArgFlag -> ArgFlag -> Bool
forall a. Eq a => a -> a -> Bool
== ArgFlag
Inferred
instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM TCvSubst
instTyVarsWith :: CtOrigin -> [Id] -> [TcRhoType] -> TcM TCvSubst
instTyVarsWith CtOrigin
orig [Id]
tvs [TcRhoType]
tys
= TCvSubst -> [Id] -> [TcRhoType] -> TcM TCvSubst
go TCvSubst
emptyTCvSubst [Id]
tvs [TcRhoType]
tys
where
go :: TCvSubst -> [Id] -> [TcRhoType] -> TcM TCvSubst
go TCvSubst
subst [] []
= TCvSubst -> TcM TCvSubst
forall (m :: * -> *) a. Monad m => a -> m a
return TCvSubst
subst
go TCvSubst
subst (Id
tv:[Id]
tvs) (TcRhoType
ty:[TcRhoType]
tys)
| TcRhoType
tv_kind HasDebugCallStack => TcRhoType -> TcRhoType -> Bool
TcRhoType -> TcRhoType -> Bool
`tcEqType` TcRhoType
ty_kind
= TCvSubst -> [Id] -> [TcRhoType] -> TcM TCvSubst
go (TCvSubst -> Id -> TcRhoType -> TCvSubst
extendTvSubstAndInScope TCvSubst
subst Id
tv TcRhoType
ty) [Id]
tvs [TcRhoType]
tys
| Bool
otherwise
= do { Coercion
co <- CtOrigin
-> TypeOrKind -> Role -> TcRhoType -> TcRhoType -> TcM Coercion
emitWantedEq CtOrigin
orig TypeOrKind
KindLevel Role
Nominal TcRhoType
ty_kind TcRhoType
tv_kind
; TCvSubst -> [Id] -> [TcRhoType] -> TcM TCvSubst
go (TCvSubst -> Id -> TcRhoType -> TCvSubst
extendTvSubstAndInScope TCvSubst
subst Id
tv (TcRhoType
ty TcRhoType -> Coercion -> TcRhoType
`mkCastTy` Coercion
co)) [Id]
tvs [TcRhoType]
tys }
where
tv_kind :: TcRhoType
tv_kind = HasCallStack => TCvSubst -> TcRhoType -> TcRhoType
TCvSubst -> TcRhoType -> TcRhoType
substTy TCvSubst
subst (Id -> TcRhoType
tyVarKind Id
tv)
ty_kind :: TcRhoType
ty_kind = HasDebugCallStack => TcRhoType -> TcRhoType
TcRhoType -> TcRhoType
tcTypeKind TcRhoType
ty
go TCvSubst
_ [Id]
_ [TcRhoType]
_ = String -> SDoc -> TcM TCvSubst
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"instTysWith" ([Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
tvs SDoc -> SDoc -> SDoc
$$ [TcRhoType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcRhoType]
tys)
instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
instCall :: CtOrigin
-> [TcRhoType]
-> [TcRhoType]
-> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
instCall CtOrigin
orig [TcRhoType]
tys [TcRhoType]
theta
= do { HsWrapper
dict_app <- CtOrigin -> [TcRhoType] -> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
instCallConstraints CtOrigin
orig [TcRhoType]
theta
; HsWrapper -> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
dict_app HsWrapper -> HsWrapper -> HsWrapper
<.> [TcRhoType] -> HsWrapper
mkWpTyApps [TcRhoType]
tys) }
instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper
instCallConstraints :: CtOrigin -> [TcRhoType] -> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
instCallConstraints CtOrigin
orig [TcRhoType]
preds
| [TcRhoType] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TcRhoType]
preds
= HsWrapper -> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
forall (m :: * -> *) a. Monad m => a -> m a
return HsWrapper
idHsWrapper
| Bool
otherwise
= do { [EvTerm]
evs <- (TcRhoType -> IOEnv (Env TcGblEnv TcLclEnv) EvTerm)
-> [TcRhoType] -> IOEnv (Env TcGblEnv TcLclEnv) [EvTerm]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TcRhoType -> IOEnv (Env TcGblEnv TcLclEnv) EvTerm
go [TcRhoType]
preds
; String -> SDoc -> TcRn ()
traceTc String
"instCallConstraints" ([EvTerm] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [EvTerm]
evs)
; HsWrapper -> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
forall (m :: * -> *) a. Monad m => a -> m a
return ([EvTerm] -> HsWrapper
mkWpEvApps [EvTerm]
evs) }
where
go :: TcPredType -> TcM EvTerm
go :: TcRhoType -> IOEnv (Env TcGblEnv TcLclEnv) EvTerm
go TcRhoType
pred
| Just (Role
Nominal, TcRhoType
ty1, TcRhoType
ty2) <- TcRhoType -> Maybe (Role, TcRhoType, TcRhoType)
getEqPredTys_maybe TcRhoType
pred
= do { Coercion
co <- Maybe (HsExpr GhcRn) -> TcRhoType -> TcRhoType -> TcM Coercion
unifyType Maybe (HsExpr GhcRn)
forall a. Maybe a
Nothing TcRhoType
ty1 TcRhoType
ty2
; EvTerm -> IOEnv (Env TcGblEnv TcLclEnv) EvTerm
forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> EvTerm
evCoercion Coercion
co) }
| Just (TyCon
tc, args :: [TcRhoType]
args@[TcRhoType
_, TcRhoType
_, TcRhoType
ty1, TcRhoType
ty2]) <- HasDebugCallStack => TcRhoType -> Maybe (TyCon, [TcRhoType])
TcRhoType -> Maybe (TyCon, [TcRhoType])
splitTyConApp_maybe TcRhoType
pred
, TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
heqTyConKey
= do { Coercion
co <- Maybe (HsExpr GhcRn) -> TcRhoType -> TcRhoType -> TcM Coercion
unifyType Maybe (HsExpr GhcRn)
forall a. Maybe a
Nothing TcRhoType
ty1 TcRhoType
ty2
; EvTerm -> IOEnv (Env TcGblEnv TcLclEnv) EvTerm
forall (m :: * -> *) a. Monad m => a -> m a
return (Id -> [TcRhoType] -> [EvExpr] -> EvTerm
evDFunApp (DataCon -> Id
dataConWrapId DataCon
heqDataCon) [TcRhoType]
args [Coercion -> EvExpr
forall b. Coercion -> Expr b
Coercion Coercion
co]) }
| Bool
otherwise
= CtOrigin -> TcRhoType -> IOEnv (Env TcGblEnv TcLclEnv) EvTerm
emitWanted CtOrigin
orig TcRhoType
pred
instDFunType :: DFunId -> [DFunInstType]
-> TcM ( [TcType]
, TcThetaType )
instDFunType :: Id -> [DFunInstType] -> TcM ([TcRhoType], [TcRhoType])
instDFunType Id
dfun_id [DFunInstType]
dfun_inst_tys
= do { (TCvSubst
subst, [TcRhoType]
inst_tys) <- TCvSubst -> [Id] -> [DFunInstType] -> TcM (TCvSubst, [TcRhoType])
go TCvSubst
empty_subst [Id]
dfun_tvs [DFunInstType]
dfun_inst_tys
; ([TcRhoType], [TcRhoType]) -> TcM ([TcRhoType], [TcRhoType])
forall (m :: * -> *) a. Monad m => a -> m a
return ([TcRhoType]
inst_tys, HasCallStack => TCvSubst -> [TcRhoType] -> [TcRhoType]
TCvSubst -> [TcRhoType] -> [TcRhoType]
substTheta TCvSubst
subst [TcRhoType]
dfun_theta) }
where
dfun_ty :: TcRhoType
dfun_ty = Id -> TcRhoType
idType Id
dfun_id
([Id]
dfun_tvs, [TcRhoType]
dfun_theta, TcRhoType
_) = TcRhoType -> ([Id], [TcRhoType], TcRhoType)
tcSplitSigmaTy TcRhoType
dfun_ty
empty_subst :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (VarSet -> InScopeSet
mkInScopeSet (TcRhoType -> VarSet
tyCoVarsOfType TcRhoType
dfun_ty))
go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType])
go :: TCvSubst -> [Id] -> [DFunInstType] -> TcM (TCvSubst, [TcRhoType])
go TCvSubst
subst [] [] = (TCvSubst, [TcRhoType]) -> TcM (TCvSubst, [TcRhoType])
forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst, [])
go TCvSubst
subst (Id
tv:[Id]
tvs) (Just TcRhoType
ty : [DFunInstType]
mb_tys)
= do { (TCvSubst
subst', [TcRhoType]
tys) <- TCvSubst -> [Id] -> [DFunInstType] -> TcM (TCvSubst, [TcRhoType])
go (TCvSubst -> Id -> TcRhoType -> TCvSubst
extendTvSubstAndInScope TCvSubst
subst Id
tv TcRhoType
ty)
[Id]
tvs
[DFunInstType]
mb_tys
; (TCvSubst, [TcRhoType]) -> TcM (TCvSubst, [TcRhoType])
forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst', TcRhoType
ty TcRhoType -> [TcRhoType] -> [TcRhoType]
forall a. a -> [a] -> [a]
: [TcRhoType]
tys) }
go TCvSubst
subst (Id
tv:[Id]
tvs) (DFunInstType
Nothing : [DFunInstType]
mb_tys)
= do { (TCvSubst
subst', Id
tv') <- TCvSubst -> Id -> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, Id)
newMetaTyVarX TCvSubst
subst Id
tv
; (TCvSubst
subst'', [TcRhoType]
tys) <- TCvSubst -> [Id] -> [DFunInstType] -> TcM (TCvSubst, [TcRhoType])
go TCvSubst
subst' [Id]
tvs [DFunInstType]
mb_tys
; (TCvSubst, [TcRhoType]) -> TcM (TCvSubst, [TcRhoType])
forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst'', Id -> TcRhoType
mkTyVarTy Id
tv' TcRhoType -> [TcRhoType] -> [TcRhoType]
forall a. a -> [a] -> [a]
: [TcRhoType]
tys) }
go TCvSubst
_ [Id]
_ [DFunInstType]
_ = String -> SDoc -> TcM (TCvSubst, [TcRhoType])
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"instDFunTypes" (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
dfun_id SDoc -> SDoc -> SDoc
$$ [DFunInstType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [DFunInstType]
dfun_inst_tys)
instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
instStupidTheta :: CtOrigin -> [TcRhoType] -> TcRn ()
instStupidTheta CtOrigin
orig [TcRhoType]
theta
= do { HsWrapper
_co <- CtOrigin -> [TcRhoType] -> IOEnv (Env TcGblEnv TcLclEnv) HsWrapper
instCallConstraints CtOrigin
orig [TcRhoType]
theta
; () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
tcInstInvisibleTyBinders :: TcType -> TcKind -> TcM (TcType, TcKind)
tcInstInvisibleTyBinders :: TcRhoType -> TcRhoType -> TcM (TcRhoType, TcRhoType)
tcInstInvisibleTyBinders TcRhoType
ty TcRhoType
kind
= do { ([TcRhoType]
extra_args, TcRhoType
kind') <- Int -> TcRhoType -> TcM ([TcRhoType], TcRhoType)
tcInstInvisibleTyBindersN Int
n_invis TcRhoType
kind
; (TcRhoType, TcRhoType) -> TcM (TcRhoType, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcRhoType -> [TcRhoType] -> TcRhoType
mkAppTys TcRhoType
ty [TcRhoType]
extra_args, TcRhoType
kind') }
where
n_invis :: Int
n_invis = TcRhoType -> Int
invisibleTyBndrCount TcRhoType
kind
tcInstInvisibleTyBindersN :: Int -> TcKind -> TcM ([TcType], TcKind)
tcInstInvisibleTyBindersN :: Int -> TcRhoType -> TcM ([TcRhoType], TcRhoType)
tcInstInvisibleTyBindersN Int
0 TcRhoType
kind
= ([TcRhoType], TcRhoType) -> TcM ([TcRhoType], TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], TcRhoType
kind)
tcInstInvisibleTyBindersN Int
n TcRhoType
ty
= Int -> TCvSubst -> TcRhoType -> TcM ([TcRhoType], TcRhoType)
forall t.
(Ord t, Num t) =>
t -> TCvSubst -> TcRhoType -> TcM ([TcRhoType], TcRhoType)
go Int
n TCvSubst
empty_subst TcRhoType
ty
where
empty_subst :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (VarSet -> InScopeSet
mkInScopeSet (TcRhoType -> VarSet
tyCoVarsOfType TcRhoType
ty))
go :: t -> TCvSubst -> TcRhoType -> TcM ([TcRhoType], TcRhoType)
go t
n TCvSubst
subst TcRhoType
kind
| t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
> t
0
, Just (TyBinder
bndr, TcRhoType
body) <- TcRhoType -> Maybe (TyBinder, TcRhoType)
tcSplitPiTy_maybe TcRhoType
kind
, TyBinder -> Bool
isInvisibleBinder TyBinder
bndr
= do { (TCvSubst
subst', TcRhoType
arg) <- TCvSubst -> TyBinder -> TcM (TCvSubst, TcRhoType)
tcInstInvisibleTyBinder TCvSubst
subst TyBinder
bndr
; ([TcRhoType]
args, TcRhoType
inner_ty) <- t -> TCvSubst -> TcRhoType -> TcM ([TcRhoType], TcRhoType)
go (t
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) TCvSubst
subst' TcRhoType
body
; ([TcRhoType], TcRhoType) -> TcM ([TcRhoType], TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (TcRhoType
argTcRhoType -> [TcRhoType] -> [TcRhoType]
forall a. a -> [a] -> [a]
:[TcRhoType]
args, TcRhoType
inner_ty) }
| Bool
otherwise
= ([TcRhoType], TcRhoType) -> TcM ([TcRhoType], TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], HasCallStack => TCvSubst -> TcRhoType -> TcRhoType
TCvSubst -> TcRhoType -> TcRhoType
substTy TCvSubst
subst TcRhoType
kind)
tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)
tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, TcRhoType)
tcInstInvisibleTyBinder TCvSubst
subst (Named (Bndr Id
tv ArgFlag
_))
= do { (TCvSubst
subst', Id
tv') <- TCvSubst -> Id -> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, Id)
newMetaTyVarX TCvSubst
subst Id
tv
; (TCvSubst, TcRhoType) -> TcM (TCvSubst, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst', Id -> TcRhoType
mkTyVarTy Id
tv') }
tcInstInvisibleTyBinder TCvSubst
subst (Anon AnonArgFlag
af Scaled TcRhoType
ty)
| Just (Coercion -> TcM TcRhoType
mk, TcRhoType
k1, TcRhoType
k2) <- TcRhoType
-> Maybe (Coercion -> TcM TcRhoType, TcRhoType, TcRhoType)
get_eq_tys_maybe (HasCallStack => TCvSubst -> TcRhoType -> TcRhoType
TCvSubst -> TcRhoType -> TcRhoType
substTy TCvSubst
subst (Scaled TcRhoType -> TcRhoType
forall a. Scaled a -> a
scaledThing Scaled TcRhoType
ty))
= ASSERT( af == InvisArg )
do { Coercion
co <- Maybe (HsType GhcRn) -> TcRhoType -> TcRhoType -> TcM Coercion
unifyKind Maybe (HsType GhcRn)
forall a. Maybe a
Nothing TcRhoType
k1 TcRhoType
k2
; TcRhoType
arg' <- Coercion -> TcM TcRhoType
mk Coercion
co
; (TCvSubst, TcRhoType) -> TcM (TCvSubst, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst, TcRhoType
arg') }
| Bool
otherwise
= String -> SDoc -> TcM (TCvSubst, TcRhoType)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcInvisibleTyBinder" (Scaled TcRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr Scaled TcRhoType
ty)
get_eq_tys_maybe :: Type
-> Maybe ( Coercion -> TcM Type
, Type
, Type
)
get_eq_tys_maybe :: TcRhoType
-> Maybe (Coercion -> TcM TcRhoType, TcRhoType, TcRhoType)
get_eq_tys_maybe TcRhoType
ty
| Just (TyCon
tc, [TcRhoType
_, TcRhoType
_, TcRhoType
k1, TcRhoType
k2]) <- HasDebugCallStack => TcRhoType -> Maybe (TyCon, [TcRhoType])
TcRhoType -> Maybe (TyCon, [TcRhoType])
splitTyConApp_maybe TcRhoType
ty
, TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
heqTyConKey
= (Coercion -> TcM TcRhoType, TcRhoType, TcRhoType)
-> Maybe (Coercion -> TcM TcRhoType, TcRhoType, TcRhoType)
forall a. a -> Maybe a
Just (\Coercion
co -> Coercion -> TcRhoType -> TcRhoType -> TcM TcRhoType
mkHEqBoxTy Coercion
co TcRhoType
k1 TcRhoType
k2, TcRhoType
k1, TcRhoType
k2)
| Just (TyCon
tc, [TcRhoType
_, TcRhoType
k1, TcRhoType
k2]) <- HasDebugCallStack => TcRhoType -> Maybe (TyCon, [TcRhoType])
TcRhoType -> Maybe (TyCon, [TcRhoType])
splitTyConApp_maybe TcRhoType
ty
, TyCon
tc TyCon -> Unique -> Bool
forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqTyConKey
= (Coercion -> TcM TcRhoType, TcRhoType, TcRhoType)
-> Maybe (Coercion -> TcM TcRhoType, TcRhoType, TcRhoType)
forall a. a -> Maybe a
Just (\Coercion
co -> Coercion -> TcRhoType -> TcRhoType -> TcM TcRhoType
mkEqBoxTy Coercion
co TcRhoType
k1 TcRhoType
k2, TcRhoType
k1, TcRhoType
k2)
| Bool
otherwise
= Maybe (Coercion -> TcM TcRhoType, TcRhoType, TcRhoType)
forall a. Maybe a
Nothing
mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
mkHEqBoxTy :: Coercion -> TcRhoType -> TcRhoType -> TcM TcRhoType
mkHEqBoxTy Coercion
co TcRhoType
ty1 TcRhoType
ty2
= TcRhoType -> TcM TcRhoType
forall (m :: * -> *) a. Monad m => a -> m a
return (TcRhoType -> TcM TcRhoType) -> TcRhoType -> TcM TcRhoType
forall a b. (a -> b) -> a -> b
$
TyCon -> [TcRhoType] -> TcRhoType
mkTyConApp (DataCon -> TyCon
promoteDataCon DataCon
heqDataCon) [TcRhoType
k1, TcRhoType
k2, TcRhoType
ty1, TcRhoType
ty2, Coercion -> TcRhoType
mkCoercionTy Coercion
co]
where k1 :: TcRhoType
k1 = HasDebugCallStack => TcRhoType -> TcRhoType
TcRhoType -> TcRhoType
tcTypeKind TcRhoType
ty1
k2 :: TcRhoType
k2 = HasDebugCallStack => TcRhoType -> TcRhoType
TcRhoType -> TcRhoType
tcTypeKind TcRhoType
ty2
mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
mkEqBoxTy :: Coercion -> TcRhoType -> TcRhoType -> TcM TcRhoType
mkEqBoxTy Coercion
co TcRhoType
ty1 TcRhoType
ty2
= TcRhoType -> TcM TcRhoType
forall (m :: * -> *) a. Monad m => a -> m a
return (TcRhoType -> TcM TcRhoType) -> TcRhoType -> TcM TcRhoType
forall a b. (a -> b) -> a -> b
$
TyCon -> [TcRhoType] -> TcRhoType
mkTyConApp (DataCon -> TyCon
promoteDataCon DataCon
eqDataCon) [TcRhoType
k, TcRhoType
ty1, TcRhoType
ty2, Coercion -> TcRhoType
mkCoercionTy Coercion
co]
where k :: TcRhoType
k = HasDebugCallStack => TcRhoType -> TcRhoType
TcRhoType -> TcRhoType
tcTypeKind TcRhoType
ty1
tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar]))
-> Id
-> TcM ([(Name, TcTyVar)], TcThetaType, TcType)
tcInstType :: ([Id] -> TcM (TCvSubst, [Id]))
-> Id -> TcM ([(Name, Id)], [TcRhoType], TcRhoType)
tcInstType [Id] -> TcM (TCvSubst, [Id])
inst_tyvars Id
id
| [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
tyvars
= ([(Name, Id)], [TcRhoType], TcRhoType)
-> TcM ([(Name, Id)], [TcRhoType], TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [TcRhoType]
theta, TcRhoType
tau)
| Bool
otherwise
= do { (TCvSubst
subst, [Id]
tyvars') <- [Id] -> TcM (TCvSubst, [Id])
inst_tyvars [Id]
tyvars
; let tv_prs :: [(Name, Id)]
tv_prs = (Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
tyVarName [Id]
tyvars [Name] -> [Id] -> [(Name, Id)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Id]
tyvars'
subst' :: TCvSubst
subst' = TCvSubst -> VarSet -> TCvSubst
extendTCvInScopeSet TCvSubst
subst (TcRhoType -> VarSet
tyCoVarsOfType TcRhoType
rho)
; ([(Name, Id)], [TcRhoType], TcRhoType)
-> TcM ([(Name, Id)], [TcRhoType], TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, Id)]
tv_prs, HasCallStack => TCvSubst -> [TcRhoType] -> [TcRhoType]
TCvSubst -> [TcRhoType] -> [TcRhoType]
substTheta TCvSubst
subst' [TcRhoType]
theta, HasCallStack => TCvSubst -> TcRhoType -> TcRhoType
TCvSubst -> TcRhoType -> TcRhoType
substTy TCvSubst
subst' TcRhoType
tau) }
where
([Id]
tyvars, TcRhoType
rho) = TcRhoType -> ([Id], TcRhoType)
tcSplitForAllTys (Id -> TcRhoType
idType Id
id)
([TcRhoType]
theta, TcRhoType
tau) = TcRhoType -> ([TcRhoType], TcRhoType)
tcSplitPhiTy TcRhoType
rho
tcInstTypeBndrs :: Id -> TcM ([(Name, InvisTVBinder)], TcThetaType, TcType)
tcInstTypeBndrs :: Id -> TcM ([(Name, InvisTVBinder)], [TcRhoType], TcRhoType)
tcInstTypeBndrs Id
id
| [InvisTVBinder] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InvisTVBinder]
tyvars
= ([(Name, InvisTVBinder)], [TcRhoType], TcRhoType)
-> TcM ([(Name, InvisTVBinder)], [TcRhoType], TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [TcRhoType]
theta, TcRhoType
tau)
| Bool
otherwise
= do { (TCvSubst
subst, [InvisTVBinder]
tyvars') <- (TCvSubst
-> InvisTVBinder
-> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, InvisTVBinder))
-> TCvSubst
-> [InvisTVBinder]
-> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, [InvisTVBinder])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM TCvSubst
-> InvisTVBinder
-> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, InvisTVBinder)
inst_invis_bndr TCvSubst
emptyTCvSubst [InvisTVBinder]
tyvars
; let tv_prs :: [(Name, InvisTVBinder)]
tv_prs = (InvisTVBinder -> Name) -> [InvisTVBinder] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Id -> Name
tyVarName (Id -> Name) -> (InvisTVBinder -> Id) -> InvisTVBinder -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InvisTVBinder -> Id
forall tv argf. VarBndr tv argf -> tv
binderVar) [InvisTVBinder]
tyvars [Name] -> [InvisTVBinder] -> [(Name, InvisTVBinder)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [InvisTVBinder]
tyvars'
subst' :: TCvSubst
subst' = TCvSubst -> VarSet -> TCvSubst
extendTCvInScopeSet TCvSubst
subst (TcRhoType -> VarSet
tyCoVarsOfType TcRhoType
rho)
; ([(Name, InvisTVBinder)], [TcRhoType], TcRhoType)
-> TcM ([(Name, InvisTVBinder)], [TcRhoType], TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, InvisTVBinder)]
tv_prs, HasCallStack => TCvSubst -> [TcRhoType] -> [TcRhoType]
TCvSubst -> [TcRhoType] -> [TcRhoType]
substTheta TCvSubst
subst' [TcRhoType]
theta, HasCallStack => TCvSubst -> TcRhoType -> TcRhoType
TCvSubst -> TcRhoType -> TcRhoType
substTy TCvSubst
subst' TcRhoType
tau) }
where
([InvisTVBinder]
tyvars, TcRhoType
rho) = TcRhoType -> ([InvisTVBinder], TcRhoType)
splitForAllTysInvis (Id -> TcRhoType
idType Id
id)
([TcRhoType]
theta, TcRhoType
tau) = TcRhoType -> ([TcRhoType], TcRhoType)
tcSplitPhiTy TcRhoType
rho
inst_invis_bndr :: TCvSubst -> InvisTVBinder
-> TcM (TCvSubst, InvisTVBinder)
inst_invis_bndr :: TCvSubst
-> InvisTVBinder
-> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, InvisTVBinder)
inst_invis_bndr TCvSubst
subst (Bndr Id
tv Specificity
spec)
= do { (TCvSubst
subst', Id
tv') <- TCvSubst -> Id -> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, Id)
newMetaTyVarTyVarX TCvSubst
subst Id
tv
; (TCvSubst, InvisTVBinder)
-> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, InvisTVBinder)
forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst', Id -> Specificity -> InvisTVBinder
forall var argf. var -> argf -> VarBndr var argf
Bndr Id
tv' Specificity
spec) }
tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType)
tcSkolDFunType :: Id -> TcM ([Id], [TcRhoType], TcRhoType)
tcSkolDFunType Id
dfun
= do { ([(Name, Id)]
tv_prs, [TcRhoType]
theta, TcRhoType
tau) <- ([Id] -> TcM (TCvSubst, [Id]))
-> Id -> TcM ([(Name, Id)], [TcRhoType], TcRhoType)
tcInstType [Id] -> TcM (TCvSubst, [Id])
tcInstSuperSkolTyVars Id
dfun
; ([Id], [TcRhoType], TcRhoType)
-> TcM ([Id], [TcRhoType], TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (((Name, Id) -> Id) -> [(Name, Id)] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Id) -> Id
forall a b. (a, b) -> b
snd [(Name, Id)]
tv_prs, [TcRhoType]
theta, TcRhoType
tau) }
tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar])
tcSuperSkolTyVars :: [Id] -> (TCvSubst, [Id])
tcSuperSkolTyVars = (TCvSubst -> Id -> (TCvSubst, Id))
-> TCvSubst -> [Id] -> (TCvSubst, [Id])
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL TCvSubst -> Id -> (TCvSubst, Id)
tcSuperSkolTyVar TCvSubst
emptyTCvSubst
tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar)
tcSuperSkolTyVar :: TCvSubst -> Id -> (TCvSubst, Id)
tcSuperSkolTyVar TCvSubst
subst Id
tv
= (TCvSubst -> Id -> Id -> TCvSubst
extendTvSubstWithClone TCvSubst
subst Id
tv Id
new_tv, Id
new_tv)
where
kind :: TcRhoType
kind = TCvSubst -> TcRhoType -> TcRhoType
substTyUnchecked TCvSubst
subst (Id -> TcRhoType
tyVarKind Id
tv)
new_tv :: Id
new_tv = Name -> TcRhoType -> TcTyVarDetails -> Id
mkTcTyVar (Id -> Name
tyVarName Id
tv) TcRhoType
kind TcTyVarDetails
superSkolemTv
tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
tcInstSkolTyVars :: [Id] -> TcM (TCvSubst, [Id])
tcInstSkolTyVars = TCvSubst -> [Id] -> TcM (TCvSubst, [Id])
tcInstSkolTyVarsX TCvSubst
emptyTCvSubst
tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
tcInstSkolTyVarsX :: TCvSubst -> [Id] -> TcM (TCvSubst, [Id])
tcInstSkolTyVarsX = Bool -> TCvSubst -> [Id] -> TcM (TCvSubst, [Id])
tcInstSkolTyVarsPushLevel Bool
False
tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
tcInstSuperSkolTyVars :: [Id] -> TcM (TCvSubst, [Id])
tcInstSuperSkolTyVars = TCvSubst -> [Id] -> TcM (TCvSubst, [Id])
tcInstSuperSkolTyVarsX TCvSubst
emptyTCvSubst
tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
tcInstSuperSkolTyVarsX :: TCvSubst -> [Id] -> TcM (TCvSubst, [Id])
tcInstSuperSkolTyVarsX TCvSubst
subst = Bool -> TCvSubst -> [Id] -> TcM (TCvSubst, [Id])
tcInstSkolTyVarsPushLevel Bool
True TCvSubst
subst
tcInstSkolTyVarsPushLevel :: Bool -> TCvSubst -> [TyVar]
-> TcM (TCvSubst, [TcTyVar])
tcInstSkolTyVarsPushLevel :: Bool -> TCvSubst -> [Id] -> TcM (TCvSubst, [Id])
tcInstSkolTyVarsPushLevel Bool
overlappable TCvSubst
subst [Id]
tvs
= do { TcLevel
tc_lvl <- TcM TcLevel
getTcLevel
; let pushed_lvl :: TcLevel
pushed_lvl = TcLevel -> TcLevel
pushTcLevel TcLevel
tc_lvl
; TcLevel -> Bool -> TCvSubst -> [Id] -> TcM (TCvSubst, [Id])
tcInstSkolTyVarsAt TcLevel
pushed_lvl Bool
overlappable TCvSubst
subst [Id]
tvs }
tcInstSkolTyVarsAt :: TcLevel -> Bool
-> TCvSubst -> [TyVar]
-> TcM (TCvSubst, [TcTyVar])
tcInstSkolTyVarsAt :: TcLevel -> Bool -> TCvSubst -> [Id] -> TcM (TCvSubst, [Id])
tcInstSkolTyVarsAt TcLevel
lvl Bool
overlappable TCvSubst
subst [Id]
tvs
= (Name -> TcRhoType -> Id)
-> TCvSubst -> [Id] -> TcM (TCvSubst, [Id])
freshenTyCoVarsX Name -> TcRhoType -> Id
new_skol_tv TCvSubst
subst [Id]
tvs
where
details :: TcTyVarDetails
details = TcLevel -> Bool -> TcTyVarDetails
SkolemTv TcLevel
lvl Bool
overlappable
new_skol_tv :: Name -> TcRhoType -> Id
new_skol_tv Name
name TcRhoType
kind = Name -> TcRhoType -> TcTyVarDetails -> Id
mkTcTyVar Name
name TcRhoType
kind TcTyVarDetails
details
freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar])
freshenTyVarBndrs :: [Id] -> TcM (TCvSubst, [Id])
freshenTyVarBndrs = (Name -> TcRhoType -> Id) -> [Id] -> TcM (TCvSubst, [Id])
freshenTyCoVars Name -> TcRhoType -> Id
mkTyVar
freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcM (TCvSubst, [CoVar])
freshenCoVarBndrsX :: TCvSubst -> [Id] -> TcM (TCvSubst, [Id])
freshenCoVarBndrsX TCvSubst
subst = (Name -> TcRhoType -> Id)
-> TCvSubst -> [Id] -> TcM (TCvSubst, [Id])
freshenTyCoVarsX Name -> TcRhoType -> Id
mkCoVar TCvSubst
subst
freshenTyCoVars :: (Name -> Kind -> TyCoVar)
-> [TyVar] -> TcM (TCvSubst, [TyCoVar])
freshenTyCoVars :: (Name -> TcRhoType -> Id) -> [Id] -> TcM (TCvSubst, [Id])
freshenTyCoVars Name -> TcRhoType -> Id
mk_tcv = (Name -> TcRhoType -> Id)
-> TCvSubst -> [Id] -> TcM (TCvSubst, [Id])
freshenTyCoVarsX Name -> TcRhoType -> Id
mk_tcv TCvSubst
emptyTCvSubst
freshenTyCoVarsX :: (Name -> Kind -> TyCoVar)
-> TCvSubst -> [TyCoVar]
-> TcM (TCvSubst, [TyCoVar])
freshenTyCoVarsX :: (Name -> TcRhoType -> Id)
-> TCvSubst -> [Id] -> TcM (TCvSubst, [Id])
freshenTyCoVarsX Name -> TcRhoType -> Id
mk_tcv = (TCvSubst -> Id -> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, Id))
-> TCvSubst -> [Id] -> TcM (TCvSubst, [Id])
forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM ((Name -> TcRhoType -> Id)
-> TCvSubst -> Id -> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, Id)
freshenTyCoVarX Name -> TcRhoType -> Id
mk_tcv)
freshenTyCoVarX :: (Name -> Kind -> TyCoVar)
-> TCvSubst -> TyCoVar -> TcM (TCvSubst, TyCoVar)
freshenTyCoVarX :: (Name -> TcRhoType -> Id)
-> TCvSubst -> Id -> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, Id)
freshenTyCoVarX Name -> TcRhoType -> Id
mk_tcv TCvSubst
subst Id
tycovar
= do { SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; Unique
uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; let old_name :: Name
old_name = Id -> Name
tyVarName Id
tycovar
new_name :: Name
new_name = Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
old_name) SrcSpan
loc
new_kind :: TcRhoType
new_kind = TCvSubst -> TcRhoType -> TcRhoType
substTyUnchecked TCvSubst
subst (Id -> TcRhoType
tyVarKind Id
tycovar)
new_tcv :: Id
new_tcv = Name -> TcRhoType -> Id
mk_tcv Name
new_name TcRhoType
new_kind
subst1 :: TCvSubst
subst1 = TCvSubst -> Id -> Id -> TCvSubst
extendTCvSubstWithClone TCvSubst
subst Id
tycovar Id
new_tcv
; (TCvSubst, Id) -> IOEnv (Env TcGblEnv TcLclEnv) (TCvSubst, Id)
forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst1, Id
new_tcv) }
newOverloadedLit :: HsOverLit GhcRn
-> ExpRhoType
-> TcM (HsOverLit GhcTc)
newOverloadedLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (HsOverLit GhcTc)
newOverloadedLit
lit :: HsOverLit GhcRn
lit@(OverLit { ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val = OverLitVal
val, ol_ext :: forall p. HsOverLit p -> XOverLit p
ol_ext = XOverLit GhcRn
rebindable }) ExpRhoType
res_ty
| Bool -> Bool
not Bool
XOverLit GhcRn
rebindable
= do { TcRhoType
res_ty <- ExpRhoType -> TcM TcRhoType
expTypeToType ExpRhoType
res_ty
; DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
; case Platform -> OverLitVal -> TcRhoType -> Maybe (HsExpr GhcTc)
shortCutLit Platform
platform OverLitVal
val TcRhoType
res_ty of
Just HsExpr GhcTc
expr -> HsOverLit GhcTc -> TcM (HsOverLit GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsOverLit GhcRn
lit { ol_witness :: HsExpr GhcTc
ol_witness = HsExpr GhcTc
expr
, ol_ext :: XOverLit GhcTc
ol_ext = Bool -> TcRhoType -> OverLitTc
OverLitTc Bool
False TcRhoType
res_ty })
Maybe (HsExpr GhcTc)
Nothing -> CtOrigin -> HsOverLit GhcRn -> ExpRhoType -> TcM (HsOverLit GhcTc)
newNonTrivialOverloadedLit CtOrigin
orig HsOverLit GhcRn
lit
(TcRhoType -> ExpRhoType
mkCheckExpType TcRhoType
res_ty) }
| Bool
otherwise
= CtOrigin -> HsOverLit GhcRn -> ExpRhoType -> TcM (HsOverLit GhcTc)
newNonTrivialOverloadedLit CtOrigin
orig HsOverLit GhcRn
lit ExpRhoType
res_ty
where
orig :: CtOrigin
orig = HsOverLit GhcRn -> CtOrigin
LiteralOrigin HsOverLit GhcRn
lit
newNonTrivialOverloadedLit :: CtOrigin
-> HsOverLit GhcRn
-> ExpRhoType
-> TcM (HsOverLit GhcTc)
newNonTrivialOverloadedLit :: CtOrigin -> HsOverLit GhcRn -> ExpRhoType -> TcM (HsOverLit GhcTc)
newNonTrivialOverloadedLit CtOrigin
orig
lit :: HsOverLit GhcRn
lit@(OverLit { ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val = OverLitVal
val, ol_witness :: forall p. HsOverLit p -> HsExpr p
ol_witness = HsVar XVar GhcRn
_ (L SrcSpan
_ IdP GhcRn
meth_name)
, ol_ext :: forall p. HsOverLit p -> XOverLit p
ol_ext = XOverLit GhcRn
rebindable }) ExpRhoType
res_ty
= do { HsLit GhcTc
hs_lit <- OverLitVal -> TcM (HsLit GhcTc)
mkOverLit OverLitVal
val
; let lit_ty :: TcRhoType
lit_ty = HsLit GhcTc -> TcRhoType
forall (p :: Pass). HsLit (GhcPass p) -> TcRhoType
hsLitType HsLit GhcTc
hs_lit
; (()
_, SyntaxExprTc
fi') <- CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcRhoType] -> [TcRhoType] -> TcRn ())
-> TcM ((), SyntaxExprTc)
forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([TcRhoType] -> [TcRhoType] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
orig (Name -> SyntaxExprRn
mkRnSyntaxExpr IdP GhcRn
Name
meth_name)
[TcRhoType -> SyntaxOpType
synKnownType TcRhoType
lit_ty] ExpRhoType
res_ty (([TcRhoType] -> [TcRhoType] -> TcRn ()) -> TcM ((), SyntaxExprTc))
-> ([TcRhoType] -> [TcRhoType] -> TcRn ())
-> TcM ((), SyntaxExprTc)
forall a b. (a -> b) -> a -> b
$
\[TcRhoType]
_ [TcRhoType]
_ -> () -> TcRn ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
; let L SrcSpan
_ HsExpr GhcTc
witness = SyntaxExprTc
-> [GenLocated SrcSpan (HsExpr GhcTc)]
-> GenLocated SrcSpan (HsExpr GhcTc)
nlHsSyntaxApps SyntaxExprTc
fi' [HsLit GhcTc -> GenLocated SrcSpan (HsExpr GhcTc)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit HsLit GhcTc
hs_lit]
; TcRhoType
res_ty <- ExpRhoType -> TcM TcRhoType
readExpType ExpRhoType
res_ty
; HsOverLit GhcTc -> TcM (HsOverLit GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsOverLit GhcRn
lit { ol_witness :: HsExpr GhcTc
ol_witness = HsExpr GhcTc
witness
, ol_ext :: XOverLit GhcTc
ol_ext = Bool -> TcRhoType -> OverLitTc
OverLitTc Bool
XOverLit GhcRn
rebindable TcRhoType
res_ty }) }
newNonTrivialOverloadedLit CtOrigin
_ HsOverLit GhcRn
lit ExpRhoType
_
= String -> SDoc -> TcM (HsOverLit GhcTc)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"newNonTrivialOverloadedLit" (HsOverLit GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsOverLit GhcRn
lit)
mkOverLit ::OverLitVal -> TcM (HsLit GhcTc)
mkOverLit :: OverLitVal -> TcM (HsLit GhcTc)
mkOverLit (HsIntegral IntegralLit
i)
= do { TcRhoType
integer_ty <- Name -> TcM TcRhoType
tcMetaTy Name
integerTyConName
; HsLit GhcTc -> TcM (HsLit GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XHsInteger GhcTc -> Integer -> TcRhoType -> HsLit GhcTc
forall x. XHsInteger x -> Integer -> TcRhoType -> HsLit x
HsInteger (IntegralLit -> SourceText
il_text IntegralLit
i)
(IntegralLit -> Integer
il_value IntegralLit
i) TcRhoType
integer_ty) }
mkOverLit (HsFractional FractionalLit
r)
= do { TcRhoType
rat_ty <- Name -> TcM TcRhoType
tcMetaTy Name
rationalTyConName
; HsLit GhcTc -> TcM (HsLit GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XHsRat GhcTc -> FractionalLit -> TcRhoType -> HsLit GhcTc
forall x. XHsRat x -> FractionalLit -> TcRhoType -> HsLit x
HsRat NoExtField
XHsRat GhcTc
noExtField FractionalLit
r TcRhoType
rat_ty) }
mkOverLit (HsIsString SourceText
src FastString
s) = HsLit GhcTc -> TcM (HsLit GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (XHsString GhcTc -> FastString -> HsLit GhcTc
forall x. XHsString x -> FastString -> HsLit x
HsString XHsString GhcTc
SourceText
src FastString
s)
tcSyntaxName :: CtOrigin
-> TcType
-> (Name, HsExpr GhcRn)
-> TcM (Name, HsExpr GhcTc)
tcSyntaxName :: CtOrigin
-> TcRhoType -> (Name, HsExpr GhcRn) -> TcM (Name, HsExpr GhcTc)
tcSyntaxName CtOrigin
orig TcRhoType
ty (Name
std_nm, HsVar XVar GhcRn
_ (L SrcSpan
_ IdP GhcRn
user_nm))
| Name
std_nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== IdP GhcRn
Name
user_nm
= do HsExpr GhcTc
rhs <- CtOrigin -> Name -> [TcRhoType] -> TcM (HsExpr GhcTc)
newMethodFromName CtOrigin
orig Name
std_nm [TcRhoType
ty]
(Name, HsExpr GhcTc) -> TcM (Name, HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
std_nm, HsExpr GhcTc
rhs)
tcSyntaxName CtOrigin
orig TcRhoType
ty (Name
std_nm, HsExpr GhcRn
user_nm_expr) = do
Id
std_id <- Name -> TcM Id
tcLookupId Name
std_nm
let
([Id
tv], [TcRhoType]
_, TcRhoType
tau) = TcRhoType -> ([Id], [TcRhoType], TcRhoType)
tcSplitSigmaTy (Id -> TcRhoType
idType Id
std_id)
sigma1 :: TcRhoType
sigma1 = HasCallStack => [Id] -> [TcRhoType] -> TcRhoType -> TcRhoType
[Id] -> [TcRhoType] -> TcRhoType -> TcRhoType
substTyWith [Id
tv] [TcRhoType
ty] TcRhoType
tau
(TidyEnv -> TcM (TidyEnv, SDoc))
-> TcM (Name, HsExpr GhcTc) -> TcM (Name, HsExpr GhcTc)
forall a. (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addErrCtxtM (HsExpr GhcRn
-> CtOrigin -> TcRhoType -> TidyEnv -> TcM (TidyEnv, SDoc)
syntaxNameCtxt HsExpr GhcRn
user_nm_expr CtOrigin
orig TcRhoType
sigma1) (TcM (Name, HsExpr GhcTc) -> TcM (Name, HsExpr GhcTc))
-> TcM (Name, HsExpr GhcTc) -> TcM (Name, HsExpr GhcTc)
forall a b. (a -> b) -> a -> b
$ do
SrcSpan
span <- TcRn SrcSpan
getSrcSpanM
GenLocated SrcSpan (HsExpr GhcTc)
expr <- LHsExpr GhcRn
-> TcRhoType -> TcM (GenLocated SrcSpan (HsExpr GhcTc))
tcCheckPolyExpr (SrcSpan -> HsExpr GhcRn -> LHsExpr GhcRn
forall l e. l -> e -> GenLocated l e
L SrcSpan
span HsExpr GhcRn
user_nm_expr) TcRhoType
sigma1
(Name, HsExpr GhcTc) -> TcM (Name, HsExpr GhcTc)
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
std_nm, GenLocated SrcSpan (HsExpr GhcTc) -> HsExpr GhcTc
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan (HsExpr GhcTc)
expr)
syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv
-> TcRn (TidyEnv, SDoc)
syntaxNameCtxt :: HsExpr GhcRn
-> CtOrigin -> TcRhoType -> TidyEnv -> TcM (TidyEnv, SDoc)
syntaxNameCtxt HsExpr GhcRn
name CtOrigin
orig TcRhoType
ty TidyEnv
tidy_env
= do { CtLoc
inst_loc <- CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM CtOrigin
orig (TypeOrKind -> Maybe TypeOrKind
forall a. a -> Maybe a
Just TypeOrKind
TypeLevel)
; let msg :: SDoc
msg = [SDoc] -> SDoc
vcat [ String -> SDoc
text String
"When checking that" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes (HsExpr GhcRn -> SDoc
forall a. Outputable a => a -> SDoc
ppr HsExpr GhcRn
name)
SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
"(needed by a syntactic construct)"
, Int -> SDoc -> SDoc
nest Int
2 (String -> SDoc
text String
"has the required type:"
SDoc -> SDoc -> SDoc
<+> TcRhoType -> SDoc
forall a. Outputable a => a -> SDoc
ppr (TidyEnv -> TcRhoType -> TcRhoType
tidyType TidyEnv
tidy_env TcRhoType
ty))
, Int -> SDoc -> SDoc
nest Int
2 (CtLoc -> SDoc
pprCtLoc CtLoc
inst_loc) ]
; (TidyEnv, SDoc) -> TcM (TidyEnv, SDoc)
forall (m :: * -> *) a. Monad m => a -> m a
return (TidyEnv
tidy_env, SDoc
msg) }
getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
getOverlapFlag Maybe OverlapMode
overlap_mode
= do { DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let overlap_ok :: Bool
overlap_ok = Extension -> DynFlags -> Bool
xopt Extension
LangExt.OverlappingInstances DynFlags
dflags
incoherent_ok :: Bool
incoherent_ok = Extension -> DynFlags -> Bool
xopt Extension
LangExt.IncoherentInstances DynFlags
dflags
use :: OverlapMode -> OverlapFlag
use OverlapMode
x = OverlapFlag :: OverlapMode -> Bool -> OverlapFlag
OverlapFlag { isSafeOverlap :: Bool
isSafeOverlap = DynFlags -> Bool
safeLanguageOn DynFlags
dflags
, overlapMode :: OverlapMode
overlapMode = OverlapMode
x }
default_oflag :: OverlapFlag
default_oflag | Bool
incoherent_ok = OverlapMode -> OverlapFlag
use (SourceText -> OverlapMode
Incoherent SourceText
NoSourceText)
| Bool
overlap_ok = OverlapMode -> OverlapFlag
use (SourceText -> OverlapMode
Overlaps SourceText
NoSourceText)
| Bool
otherwise = OverlapMode -> OverlapFlag
use (SourceText -> OverlapMode
NoOverlap SourceText
NoSourceText)
final_oflag :: OverlapFlag
final_oflag = OverlapFlag -> Maybe OverlapMode -> OverlapFlag
setOverlapModeMaybe OverlapFlag
default_oflag Maybe OverlapMode
overlap_mode
; OverlapFlag -> TcM OverlapFlag
forall (m :: * -> *) a. Monad m => a -> m a
return OverlapFlag
final_oflag }
tcGetInsts :: TcM [ClsInst]
tcGetInsts :: TcM [ClsInst]
tcGetInsts = (TcGblEnv -> [ClsInst])
-> IOEnv (Env TcGblEnv TcLclEnv) TcGblEnv -> TcM [ClsInst]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcGblEnv -> [ClsInst]
tcg_insts IOEnv (Env TcGblEnv TcLclEnv) TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
-> Class -> [Type] -> TcM ClsInst
newClsInst :: Maybe OverlapMode
-> Name
-> [Id]
-> [TcRhoType]
-> Class
-> [TcRhoType]
-> TcM ClsInst
newClsInst Maybe OverlapMode
overlap_mode Name
dfun_name [Id]
tvs [TcRhoType]
theta Class
clas [TcRhoType]
tys
= do { (TCvSubst
subst, [Id]
tvs') <- [Id] -> TcM (TCvSubst, [Id])
freshenTyVarBndrs [Id]
tvs
; let tys' :: [TcRhoType]
tys' = HasCallStack => TCvSubst -> [TcRhoType] -> [TcRhoType]
TCvSubst -> [TcRhoType] -> [TcRhoType]
substTys TCvSubst
subst [TcRhoType]
tys
dfun :: Id
dfun = Name -> [Id] -> [TcRhoType] -> Class -> [TcRhoType] -> Id
mkDictFunId Name
dfun_name [Id]
tvs [TcRhoType]
theta Class
clas [TcRhoType]
tys
; OverlapFlag
oflag <- Maybe OverlapMode -> TcM OverlapFlag
getOverlapFlag Maybe OverlapMode
overlap_mode
; let inst :: ClsInst
inst = Id -> OverlapFlag -> [Id] -> Class -> [TcRhoType] -> ClsInst
mkLocalInstance Id
dfun OverlapFlag
oflag [Id]
tvs' Class
clas [TcRhoType]
tys'
; WarningFlag -> Bool -> SDoc -> TcRn ()
warnIfFlag WarningFlag
Opt_WarnOrphans
(IsOrphan -> Bool
isOrphan (ClsInst -> IsOrphan
is_orphan ClsInst
inst))
(ClsInst -> SDoc
instOrphWarn ClsInst
inst)
; ClsInst -> TcM ClsInst
forall (m :: * -> *) a. Monad m => a -> m a
return ClsInst
inst }
instOrphWarn :: ClsInst -> SDoc
instOrphWarn :: ClsInst -> SDoc
instOrphWarn ClsInst
inst
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"Orphan instance:") Int
2 (ClsInst -> SDoc
pprInstanceHdr ClsInst
inst)
SDoc -> SDoc -> SDoc
$$ String -> SDoc
text String
"To avoid this"
SDoc -> SDoc -> SDoc
$$ Int -> SDoc -> SDoc
nest Int
4 ([SDoc] -> SDoc
vcat [SDoc]
possibilities)
where
possibilities :: [SDoc]
possibilities =
String -> SDoc
text String
"move the instance declaration to the module of the class or of the type, or" SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
:
String -> SDoc
text String
"wrap the type with a newtype and declare the instance on the new type." SDoc -> [SDoc] -> [SDoc]
forall a. a -> [a] -> [a]
:
[]
tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
tcExtendLocalInstEnv [ClsInst]
dfuns TcM a
thing_inside
= do { [ClsInst] -> TcRn ()
traceDFuns [ClsInst]
dfuns
; TcGblEnv
env <- IOEnv (Env TcGblEnv TcLclEnv) TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; (InstEnv
inst_env', [ClsInst]
cls_insts') <- ((InstEnv, [ClsInst])
-> ClsInst -> IOEnv (Env TcGblEnv TcLclEnv) (InstEnv, [ClsInst]))
-> (InstEnv, [ClsInst])
-> [ClsInst]
-> IOEnv (Env TcGblEnv TcLclEnv) (InstEnv, [ClsInst])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (InstEnv, [ClsInst])
-> ClsInst -> IOEnv (Env TcGblEnv TcLclEnv) (InstEnv, [ClsInst])
addLocalInst
(TcGblEnv -> InstEnv
tcg_inst_env TcGblEnv
env, TcGblEnv -> [ClsInst]
tcg_insts TcGblEnv
env)
[ClsInst]
dfuns
; let env' :: TcGblEnv
env' = TcGblEnv
env { tcg_insts :: [ClsInst]
tcg_insts = [ClsInst]
cls_insts'
, tcg_inst_env :: InstEnv
tcg_inst_env = InstEnv
inst_env' }
; TcGblEnv -> TcM a -> TcM a
forall gbl lcl a. gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setGblEnv TcGblEnv
env' TcM a
thing_inside }
addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst])
addLocalInst :: (InstEnv, [ClsInst])
-> ClsInst -> IOEnv (Env TcGblEnv TcLclEnv) (InstEnv, [ClsInst])
addLocalInst (InstEnv
home_ie, [ClsInst]
my_insts) ClsInst
ispec
= do {
; Bool
isGHCi <- TcRn Bool
getIsGHCi
; ExternalPackageState
eps <- TcRnIf TcGblEnv TcLclEnv ExternalPackageState
forall gbl lcl. TcRnIf gbl lcl ExternalPackageState
getEps
; TcGblEnv
tcg_env <- IOEnv (Env TcGblEnv TcLclEnv) TcGblEnv
forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; let home_ie' :: InstEnv
home_ie'
| Bool
isGHCi = InstEnv -> ClsInst -> InstEnv
deleteFromInstEnv InstEnv
home_ie ClsInst
ispec
| Bool
otherwise = InstEnv
home_ie
global_ie :: InstEnv
global_ie = ExternalPackageState -> InstEnv
eps_inst_env ExternalPackageState
eps
inst_envs :: InstEnvs
inst_envs = InstEnvs :: InstEnv -> InstEnv -> VisibleOrphanModules -> InstEnvs
InstEnvs { ie_global :: InstEnv
ie_global = InstEnv
global_ie
, ie_local :: InstEnv
ie_local = InstEnv
home_ie'
, ie_visible :: VisibleOrphanModules
ie_visible = TcGblEnv -> VisibleOrphanModules
tcVisibleOrphanMods TcGblEnv
tcg_env }
; let inconsistent_ispecs :: [ClsInst]
inconsistent_ispecs = InstEnvs -> ClsInst -> [ClsInst]
checkFunDeps InstEnvs
inst_envs ClsInst
ispec
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ClsInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
inconsistent_ispecs) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
ClsInst -> [ClsInst] -> TcRn ()
funDepErr ClsInst
ispec [ClsInst]
inconsistent_ispecs
; let ([Id]
_tvs, Class
cls, [TcRhoType]
tys) = ClsInst -> ([Id], Class, [TcRhoType])
instanceHead ClsInst
ispec
([InstMatch]
matches, [ClsInst]
_, [InstMatch]
_) = Bool
-> InstEnvs
-> Class
-> [TcRhoType]
-> ([InstMatch], [ClsInst], [InstMatch])
lookupInstEnv Bool
False InstEnvs
inst_envs Class
cls [TcRhoType]
tys
dups :: [ClsInst]
dups = (ClsInst -> Bool) -> [ClsInst] -> [ClsInst]
forall a. (a -> Bool) -> [a] -> [a]
filter (ClsInst -> ClsInst -> Bool
identicalClsInstHead ClsInst
ispec) ((InstMatch -> ClsInst) -> [InstMatch] -> [ClsInst]
forall a b. (a -> b) -> [a] -> [b]
map InstMatch -> ClsInst
forall a b. (a, b) -> a
fst [InstMatch]
matches)
; Bool -> TcRn () -> TcRn ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ClsInst] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
dups) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
ClsInst -> ClsInst -> TcRn ()
dupInstErr ClsInst
ispec ([ClsInst] -> ClsInst
forall a. [a] -> a
head [ClsInst]
dups)
; (InstEnv, [ClsInst])
-> IOEnv (Env TcGblEnv TcLclEnv) (InstEnv, [ClsInst])
forall (m :: * -> *) a. Monad m => a -> m a
return (InstEnv -> ClsInst -> InstEnv
extendInstEnv InstEnv
home_ie' ClsInst
ispec, ClsInst
ispec ClsInst -> [ClsInst] -> [ClsInst]
forall a. a -> [a] -> [a]
: [ClsInst]
my_insts) }
traceDFuns :: [ClsInst] -> TcRn ()
traceDFuns :: [ClsInst] -> TcRn ()
traceDFuns [ClsInst]
ispecs
= String -> SDoc -> TcRn ()
traceTc String
"Adding instances:" ([SDoc] -> SDoc
vcat ((ClsInst -> SDoc) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map ClsInst -> SDoc
pp [ClsInst]
ispecs))
where
pp :: ClsInst -> SDoc
pp ClsInst
ispec = SDoc -> Int -> SDoc -> SDoc
hang (Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ClsInst -> Id
instanceDFunId ClsInst
ispec) SDoc -> SDoc -> SDoc
<+> SDoc
colon)
Int
2 (ClsInst -> SDoc
forall a. Outputable a => a -> SDoc
ppr ClsInst
ispec)
funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
funDepErr ClsInst
ispec [ClsInst]
ispecs
= SDoc -> [ClsInst] -> TcRn ()
addClsInstsErr (String -> SDoc
text String
"Functional dependencies conflict between instance declarations:")
(ClsInst
ispec ClsInst -> [ClsInst] -> [ClsInst]
forall a. a -> [a] -> [a]
: [ClsInst]
ispecs)
dupInstErr :: ClsInst -> ClsInst -> TcRn ()
dupInstErr :: ClsInst -> ClsInst -> TcRn ()
dupInstErr ClsInst
ispec ClsInst
dup_ispec
= SDoc -> [ClsInst] -> TcRn ()
addClsInstsErr (String -> SDoc
text String
"Duplicate instance declarations:")
[ClsInst
ispec, ClsInst
dup_ispec]
addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
addClsInstsErr SDoc
herald [ClsInst]
ispecs
= SrcSpan -> TcRn () -> TcRn ()
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (ClsInst -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan ([ClsInst] -> ClsInst
forall a. [a] -> a
head [ClsInst]
sorted)) (TcRn () -> TcRn ()) -> TcRn () -> TcRn ()
forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn ()
addErr (SDoc -> Int -> SDoc -> SDoc
hang SDoc
herald Int
2 ([ClsInst] -> SDoc
pprInstances [ClsInst]
sorted))
where
sorted :: [ClsInst]
sorted = (ClsInst -> ClsInst -> Ordering) -> [ClsInst] -> [ClsInst]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (SrcSpan -> SrcSpan -> Ordering
SrcLoc.leftmost_smallest (SrcSpan -> SrcSpan -> Ordering)
-> (ClsInst -> SrcSpan) -> ClsInst -> ClsInst -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` ClsInst -> SrcSpan
forall a. NamedThing a => a -> SrcSpan
getSrcSpan) [ClsInst]
ispecs