{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
module GHC.Tc.Utils.Instantiate (
topSkolemise,
topInstantiate, instantiateSigma,
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 GHC.Driver.Session
import GHC.Builtin.Types ( heqDataCon, eqDataCon, integerTyConName )
import GHC.Builtin.Names
import GHC.Hs
import GHC.Core.InstEnv
import GHC.Core.Predicate
import GHC.Core ( Expr(..), isOrphan )
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Core.TyCo.Rep
import GHC.Core.TyCo.Ppr ( debugPprType )
import GHC.Core.Class( Class )
import GHC.Core.DataCon
import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcCheckPolyExpr, tcSyntaxOp )
import {-# SOURCE #-} GHC.Tc.Utils.Unify( unifyType, unifyKind )
import GHC.Tc.Utils.Zonk
import GHC.Tc.Utils.Monad
import GHC.Tc.Types.Constraint
import GHC.Tc.Types.Origin
import GHC.Tc.Utils.Env
import GHC.Tc.Types.Evidence
import GHC.Tc.Instance.FunDeps
import GHC.Tc.Utils.TcMType
import GHC.Tc.Utils.TcType
import GHC.Types.Id.Make( mkDictFunId )
import GHC.Types.Basic ( TypeOrKind(..) )
import GHC.Types.SourceText
import GHC.Types.SrcLoc as SrcLoc
import GHC.Types.Var.Env
import GHC.Types.Var.Set
import GHC.Types.Id
import GHC.Types.Name
import GHC.Types.Var
import qualified GHC.LanguageExtensions as LangExt
import GHC.Utils.Misc
import GHC.Utils.Panic
import GHC.Utils.Outputable
import GHC.Unit.State
import GHC.Unit.External
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 -> LIdP GhcTc -> HsExpr GhcTc
forall p. XVar p -> LIdP 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 CtOrigin
orig TcRhoType
ty
| ([Id]
tvs, [TcRhoType]
theta, TcRhoType
body) <- 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 { ([Id]
_, HsWrapper
wrap1, TcRhoType
body1) <- CtOrigin
-> [Id]
-> [TcRhoType]
-> TcRhoType
-> TcM ([Id], HsWrapper, TcRhoType)
instantiateSigma CtOrigin
orig [Id]
tvs [TcRhoType]
theta TcRhoType
body
; (HsWrapper
wrap2, TcRhoType
rho) <- CtOrigin -> TcRhoType -> TcM (HsWrapper, TcRhoType)
topInstantiate CtOrigin
orig TcRhoType
body1
; (HsWrapper, TcRhoType) -> TcM (HsWrapper, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
wrap2 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap1, TcRhoType
rho) }
| Bool
otherwise = (HsWrapper, TcRhoType) -> TcM (HsWrapper, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
idHsWrapper, TcRhoType
ty)
instantiateSigma :: CtOrigin -> [TyVar] -> TcThetaType -> TcSigmaType
-> TcM ([TcTyVar], HsWrapper, TcSigmaType)
instantiateSigma :: CtOrigin
-> [Id]
-> [TcRhoType]
-> TcRhoType
-> TcM ([Id], HsWrapper, TcRhoType)
instantiateSigma CtOrigin
orig [Id]
tvs [TcRhoType]
theta TcRhoType
body_ty
= do { (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]
tvs
; let inst_theta :: [TcRhoType]
inst_theta = HasCallStack => TCvSubst -> [TcRhoType] -> [TcRhoType]
TCvSubst -> [TcRhoType] -> [TcRhoType]
substTheta TCvSubst
subst [TcRhoType]
theta
inst_body :: TcRhoType
inst_body = HasCallStack => TCvSubst -> TcRhoType -> TcRhoType
TCvSubst -> TcRhoType -> TcRhoType
substTy TCvSubst
subst TcRhoType
body_ty
inst_tv_tys :: [TcRhoType]
inst_tv_tys = [Id] -> [TcRhoType]
mkTyVarTys [Id]
inst_tvs
; HsWrapper
wrap <- 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
"origin" SDoc -> SDoc -> SDoc
<+> CtOrigin -> SDoc
pprCtOrigin CtOrigin
orig
, String -> SDoc
text String
"tvs" SDoc -> SDoc -> SDoc
<+> [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
tvs
, String -> SDoc
text String
"theta" SDoc -> SDoc -> SDoc
<+> [TcRhoType] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [TcRhoType]
theta
, String -> SDoc
text String
"type" SDoc -> SDoc -> SDoc
<+> TcRhoType -> SDoc
debugPprType TcRhoType
body_ty
, 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 ])
; ([Id], HsWrapper, TcRhoType) -> TcM ([Id], HsWrapper, TcRhoType)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Id]
inst_tvs, HsWrapper
wrap, TcRhoType
inst_body) }
where
free_tvs :: VarSet
free_tvs = TcRhoType -> VarSet
tyCoVarsOfType TcRhoType
body_ty VarSet -> VarSet -> VarSet
`unionVarSet` [TcRhoType] -> VarSet
tyCoVarsOfTypes [TcRhoType]
theta
in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet (VarSet
free_tvs VarSet -> [Id] -> VarSet
`delVarSetList` [Id]
tvs)
empty_subst :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst InScopeSet
in_scope
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 SDoc -> TcRhoType -> TcRhoType -> TcM Coercion
unifyType Maybe SDoc
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 SDoc -> TcRhoType -> TcRhoType -> TcM Coercion
unifyType Maybe SDoc
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 SDoc -> TcRhoType -> TcRhoType -> TcM Coercion
unifyKind Maybe SDoc
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)
tcSplitForAllInvisTyVars (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)
splitForAllInvisTVBinders (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 _ 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 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 -> [LHsExpr GhcTc] -> LHsExpr GhcTc
nlHsSyntaxApps SyntaxExprTc
fi' [HsLit GhcTc -> LHsExpr 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 SourceText
XHsString GhcTc
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 _ user_nm))
| Name
std_nm Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== 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 (LHsExpr GhcTc)
tcCheckPolyExpr (SrcSpan -> HsExpr GhcRn -> GenLocated SrcSpan (HsExpr 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 = do
UnitState
unit_state <- DynFlags -> UnitState
unitState (DynFlags -> UnitState)
-> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
-> IOEnv (Env TcGblEnv TcLclEnv) UnitState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
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 -> TcRn ()) -> SDoc -> TcRn ()
forall a b. (a -> b) -> a -> b
$ UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
unit_state (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ (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