{-# 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 "HsVersions.h"
import GHC.Prelude
import GHC.Driver.Session
import GHC.Driver.Env
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 -> [Type] -> TcM (HsExpr GhcTc)
newMethodFromName CtOrigin
origin Name
name [Type]
ty_args
= do { DFunId
id <- Name -> TcM DFunId
tcLookupId Name
name
; let ty :: Type
ty = HasDebugCallStack => Type -> [Type] -> Type
piResultTys (DFunId -> Type
idType DFunId
id) [Type]
ty_args
([Type]
theta, Type
_caller_knows_this) = Type -> ([Type], Type)
tcSplitPhiTy Type
ty
; HsWrapper
wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )
CtOrigin -> [Type] -> [Type] -> TcM HsWrapper
instCall CtOrigin
origin [Type]
ty_args [Type]
theta
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc
mkHsWrap HsWrapper
wrap (forall p. XVar p -> LIdP p -> HsExpr p
HsVar NoExtField
noExtField (forall a an. a -> LocatedAn an a
noLocA DFunId
id))) }
topSkolemise :: TcSigmaType
-> TcM ( HsWrapper
, [(Name,TyVar)]
, [EvVar]
, TcRhoType )
topSkolemise :: Type -> TcM (HsWrapper, [(Name, DFunId)], [DFunId], Type)
topSkolemise Type
ty
= TCvSubst
-> HsWrapper
-> [(Name, DFunId)]
-> [DFunId]
-> Type
-> TcM (HsWrapper, [(Name, DFunId)], [DFunId], Type)
go TCvSubst
init_subst HsWrapper
idHsWrapper [] [] Type
ty
where
init_subst :: TCvSubst
init_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (VarSet -> InScopeSet
mkInScopeSet (Type -> VarSet
tyCoVarsOfType Type
ty))
go :: TCvSubst
-> HsWrapper
-> [(Name, DFunId)]
-> [DFunId]
-> Type
-> TcM (HsWrapper, [(Name, DFunId)], [DFunId], Type)
go TCvSubst
subst HsWrapper
wrap [(Name, DFunId)]
tv_prs [DFunId]
ev_vars Type
ty
| ([DFunId]
tvs, [Type]
theta, Type
inner_ty) <- Type -> ([DFunId], [Type], Type)
tcSplitSigmaTy Type
ty
, Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DFunId]
tvs Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
theta)
= do { (TCvSubst
subst', [DFunId]
tvs1) <- TCvSubst -> [DFunId] -> TcM (TCvSubst, [DFunId])
tcInstSkolTyVarsX TCvSubst
subst [DFunId]
tvs
; [DFunId]
ev_vars1 <- [Type] -> TcM [DFunId]
newEvVars (HasCallStack => TCvSubst -> [Type] -> [Type]
substTheta TCvSubst
subst' [Type]
theta)
; TCvSubst
-> HsWrapper
-> [(Name, DFunId)]
-> [DFunId]
-> Type
-> TcM (HsWrapper, [(Name, DFunId)], [DFunId], Type)
go TCvSubst
subst'
(HsWrapper
wrap HsWrapper -> HsWrapper -> HsWrapper
<.> [DFunId] -> HsWrapper
mkWpTyLams [DFunId]
tvs1 HsWrapper -> HsWrapper -> HsWrapper
<.> [DFunId] -> HsWrapper
mkWpLams [DFunId]
ev_vars1)
([(Name, DFunId)]
tv_prs forall a. [a] -> [a] -> [a]
++ (forall a b. (a -> b) -> [a] -> [b]
map DFunId -> Name
tyVarName [DFunId]
tvs forall a b. [a] -> [b] -> [(a, b)]
`zip` [DFunId]
tvs1))
([DFunId]
ev_vars forall a. [a] -> [a] -> [a]
++ [DFunId]
ev_vars1)
Type
inner_ty }
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
wrap, [(Name, DFunId)]
tv_prs, [DFunId]
ev_vars, HasCallStack => TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
ty)
topInstantiate ::CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
topInstantiate :: CtOrigin -> Type -> TcM (HsWrapper, Type)
topInstantiate CtOrigin
orig Type
sigma
| ([DFunId]
tvs, Type
body1) <- (ArgFlag -> Bool) -> Type -> ([DFunId], Type)
tcSplitSomeForAllTyVars ArgFlag -> Bool
isInvisibleArgFlag Type
sigma
, ([Type]
theta, Type
body2) <- Type -> ([Type], Type)
tcSplitPhiTy Type
body1
, Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DFunId]
tvs Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
theta)
= do { ([DFunId]
_, HsWrapper
wrap1, Type
body3) <- CtOrigin
-> [DFunId] -> [Type] -> Type -> TcM ([DFunId], HsWrapper, Type)
instantiateSigma CtOrigin
orig [DFunId]
tvs [Type]
theta Type
body2
; (HsWrapper
wrap2, Type
body4) <- CtOrigin -> Type -> TcM (HsWrapper, Type)
topInstantiate CtOrigin
orig Type
body3
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
wrap2 HsWrapper -> HsWrapper -> HsWrapper
<.> HsWrapper
wrap1, Type
body4) }
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
idHsWrapper, Type
sigma)
instantiateSigma :: CtOrigin -> [TyVar] -> TcThetaType -> TcSigmaType
-> TcM ([TcTyVar], HsWrapper, TcSigmaType)
instantiateSigma :: CtOrigin
-> [DFunId] -> [Type] -> Type -> TcM ([DFunId], HsWrapper, Type)
instantiateSigma CtOrigin
orig [DFunId]
tvs [Type]
theta Type
body_ty
= do { (TCvSubst
subst, [DFunId]
inst_tvs) <- forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM TCvSubst -> DFunId -> TcM (TCvSubst, DFunId)
newMetaTyVarX TCvSubst
empty_subst [DFunId]
tvs
; let inst_theta :: [Type]
inst_theta = HasCallStack => TCvSubst -> [Type] -> [Type]
substTheta TCvSubst
subst [Type]
theta
inst_body :: Type
inst_body = HasCallStack => TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
body_ty
inst_tv_tys :: [Type]
inst_tv_tys = [DFunId] -> [Type]
mkTyVarTys [DFunId]
inst_tvs
; HsWrapper
wrap <- CtOrigin -> [Type] -> [Type] -> TcM HsWrapper
instCall CtOrigin
orig [Type]
inst_tv_tys [Type]
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
<+> forall a. Outputable a => a -> SDoc
ppr [DFunId]
tvs
, String -> SDoc
text String
"theta" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
theta
, String -> SDoc
text String
"type" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
debugPprType Type
body_ty
, String -> SDoc
text String
"with" SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
vcat (forall a b. (a -> b) -> [a] -> [b]
map Type -> SDoc
debugPprType [Type]
inst_tv_tys)
, String -> SDoc
text String
"theta:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
inst_theta ])
; forall (m :: * -> *) a. Monad m => a -> m a
return ([DFunId]
inst_tvs, HsWrapper
wrap, Type
inst_body) }
where
free_tvs :: VarSet
free_tvs = Type -> VarSet
tyCoVarsOfType Type
body_ty VarSet -> VarSet -> VarSet
`unionVarSet` [Type] -> VarSet
tyCoVarsOfTypes [Type]
theta
in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet (VarSet
free_tvs VarSet -> [DFunId] -> VarSet
`delVarSetList` [DFunId]
tvs)
empty_subst :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst InScopeSet
in_scope
instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM TCvSubst
instTyVarsWith :: CtOrigin -> [DFunId] -> [Type] -> TcM TCvSubst
instTyVarsWith CtOrigin
orig [DFunId]
tvs [Type]
tys
= TCvSubst -> [DFunId] -> [Type] -> TcM TCvSubst
go TCvSubst
emptyTCvSubst [DFunId]
tvs [Type]
tys
where
go :: TCvSubst -> [DFunId] -> [Type] -> TcM TCvSubst
go TCvSubst
subst [] []
= forall (m :: * -> *) a. Monad m => a -> m a
return TCvSubst
subst
go TCvSubst
subst (DFunId
tv:[DFunId]
tvs) (Type
ty:[Type]
tys)
| Type
tv_kind HasDebugCallStack => Type -> Type -> Bool
`tcEqType` Type
ty_kind
= TCvSubst -> [DFunId] -> [Type] -> TcM TCvSubst
go (TCvSubst -> DFunId -> Type -> TCvSubst
extendTvSubstAndInScope TCvSubst
subst DFunId
tv Type
ty) [DFunId]
tvs [Type]
tys
| Bool
otherwise
= do { Coercion
co <- CtOrigin -> TypeOrKind -> Role -> Type -> Type -> TcM Coercion
emitWantedEq CtOrigin
orig TypeOrKind
KindLevel Role
Nominal Type
ty_kind Type
tv_kind
; TCvSubst -> [DFunId] -> [Type] -> TcM TCvSubst
go (TCvSubst -> DFunId -> Type -> TCvSubst
extendTvSubstAndInScope TCvSubst
subst DFunId
tv (Type
ty Type -> Coercion -> Type
`mkCastTy` Coercion
co)) [DFunId]
tvs [Type]
tys }
where
tv_kind :: Type
tv_kind = HasCallStack => TCvSubst -> Type -> Type
substTy TCvSubst
subst (DFunId -> Type
tyVarKind DFunId
tv)
ty_kind :: Type
ty_kind = HasDebugCallStack => Type -> Type
tcTypeKind Type
ty
go TCvSubst
_ [DFunId]
_ [Type]
_ = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"instTysWith" (forall a. Outputable a => a -> SDoc
ppr [DFunId]
tvs SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [Type]
tys)
instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
instCall :: CtOrigin -> [Type] -> [Type] -> TcM HsWrapper
instCall CtOrigin
orig [Type]
tys [Type]
theta
= do { HsWrapper
dict_app <- CtOrigin -> [Type] -> TcM HsWrapper
instCallConstraints CtOrigin
orig [Type]
theta
; forall (m :: * -> *) a. Monad m => a -> m a
return (HsWrapper
dict_app HsWrapper -> HsWrapper -> HsWrapper
<.> [Type] -> HsWrapper
mkWpTyApps [Type]
tys) }
instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper
instCallConstraints :: CtOrigin -> [Type] -> TcM HsWrapper
instCallConstraints CtOrigin
orig [Type]
preds
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Type]
preds
= forall (m :: * -> *) a. Monad m => a -> m a
return HsWrapper
idHsWrapper
| Bool
otherwise
= do { [EvTerm]
evs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> TcM EvTerm
go [Type]
preds
; String -> SDoc -> TcRn ()
traceTc String
"instCallConstraints" (forall a. Outputable a => a -> SDoc
ppr [EvTerm]
evs)
; forall (m :: * -> *) a. Monad m => a -> m a
return ([EvTerm] -> HsWrapper
mkWpEvApps [EvTerm]
evs) }
where
go :: TcPredType -> TcM EvTerm
go :: Type -> TcM EvTerm
go Type
pred
| Just (Role
Nominal, Type
ty1, Type
ty2) <- Type -> Maybe (Role, Type, Type)
getEqPredTys_maybe Type
pred
= do { Coercion
co <- Maybe SDoc -> Type -> Type -> TcM Coercion
unifyType forall a. Maybe a
Nothing Type
ty1 Type
ty2
; forall (m :: * -> *) a. Monad m => a -> m a
return (Coercion -> EvTerm
evCoercion Coercion
co) }
| Just (TyCon
tc, args :: [Type]
args@[Type
_, Type
_, Type
ty1, Type
ty2]) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
pred
, TyCon
tc forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
heqTyConKey
= do { Coercion
co <- Maybe SDoc -> Type -> Type -> TcM Coercion
unifyType forall a. Maybe a
Nothing Type
ty1 Type
ty2
; forall (m :: * -> *) a. Monad m => a -> m a
return (DFunId -> [Type] -> [EvExpr] -> EvTerm
evDFunApp (DataCon -> DFunId
dataConWrapId DataCon
heqDataCon) [Type]
args [forall b. Coercion -> Expr b
Coercion Coercion
co]) }
| Bool
otherwise
= CtOrigin -> Type -> TcM EvTerm
emitWanted CtOrigin
orig Type
pred
instDFunType :: DFunId -> [DFunInstType]
-> TcM ( [TcType]
, TcThetaType )
instDFunType :: DFunId -> [DFunInstType] -> TcM ([Type], [Type])
instDFunType DFunId
dfun_id [DFunInstType]
dfun_inst_tys
= do { (TCvSubst
subst, [Type]
inst_tys) <- TCvSubst -> [DFunId] -> [DFunInstType] -> TcM (TCvSubst, [Type])
go TCvSubst
empty_subst [DFunId]
dfun_tvs [DFunInstType]
dfun_inst_tys
; forall (m :: * -> *) a. Monad m => a -> m a
return ([Type]
inst_tys, HasCallStack => TCvSubst -> [Type] -> [Type]
substTheta TCvSubst
subst [Type]
dfun_theta) }
where
dfun_ty :: Type
dfun_ty = DFunId -> Type
idType DFunId
dfun_id
([DFunId]
dfun_tvs, [Type]
dfun_theta, Type
_) = Type -> ([DFunId], [Type], Type)
tcSplitSigmaTy Type
dfun_ty
empty_subst :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (VarSet -> InScopeSet
mkInScopeSet (Type -> VarSet
tyCoVarsOfType Type
dfun_ty))
go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType])
go :: TCvSubst -> [DFunId] -> [DFunInstType] -> TcM (TCvSubst, [Type])
go TCvSubst
subst [] [] = forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst, [])
go TCvSubst
subst (DFunId
tv:[DFunId]
tvs) (Just Type
ty : [DFunInstType]
mb_tys)
= do { (TCvSubst
subst', [Type]
tys) <- TCvSubst -> [DFunId] -> [DFunInstType] -> TcM (TCvSubst, [Type])
go (TCvSubst -> DFunId -> Type -> TCvSubst
extendTvSubstAndInScope TCvSubst
subst DFunId
tv Type
ty)
[DFunId]
tvs
[DFunInstType]
mb_tys
; forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst', Type
ty forall a. a -> [a] -> [a]
: [Type]
tys) }
go TCvSubst
subst (DFunId
tv:[DFunId]
tvs) (DFunInstType
Nothing : [DFunInstType]
mb_tys)
= do { (TCvSubst
subst', DFunId
tv') <- TCvSubst -> DFunId -> TcM (TCvSubst, DFunId)
newMetaTyVarX TCvSubst
subst DFunId
tv
; (TCvSubst
subst'', [Type]
tys) <- TCvSubst -> [DFunId] -> [DFunInstType] -> TcM (TCvSubst, [Type])
go TCvSubst
subst' [DFunId]
tvs [DFunInstType]
mb_tys
; forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst'', DFunId -> Type
mkTyVarTy DFunId
tv' forall a. a -> [a] -> [a]
: [Type]
tys) }
go TCvSubst
_ [DFunId]
_ [DFunInstType]
_ = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"instDFunTypes" (forall a. Outputable a => a -> SDoc
ppr DFunId
dfun_id SDoc -> SDoc -> SDoc
$$ forall a. Outputable a => a -> SDoc
ppr [DFunInstType]
dfun_inst_tys)
instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
instStupidTheta :: CtOrigin -> [Type] -> TcRn ()
instStupidTheta CtOrigin
orig [Type]
theta
= do { HsWrapper
_co <- CtOrigin -> [Type] -> TcM HsWrapper
instCallConstraints CtOrigin
orig [Type]
theta
; forall (m :: * -> *) a. Monad m => a -> m a
return () }
tcInstInvisibleTyBinders :: TcType -> TcKind -> TcM (TcType, TcKind)
tcInstInvisibleTyBinders :: Type -> Type -> TcM (Type, Type)
tcInstInvisibleTyBinders Type
ty Type
kind
= do { ([Type]
extra_args, Type
kind') <- Int -> Type -> TcM ([Type], Type)
tcInstInvisibleTyBindersN Int
n_invis Type
kind
; forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> [Type] -> Type
mkAppTys Type
ty [Type]
extra_args, Type
kind') }
where
n_invis :: Int
n_invis = Type -> Int
invisibleTyBndrCount Type
kind
tcInstInvisibleTyBindersN :: Int -> TcKind -> TcM ([TcType], TcKind)
tcInstInvisibleTyBindersN :: Int -> Type -> TcM ([Type], Type)
tcInstInvisibleTyBindersN Int
0 Type
kind
= forall (m :: * -> *) a. Monad m => a -> m a
return ([], Type
kind)
tcInstInvisibleTyBindersN Int
n Type
ty
= forall {t}.
(Ord t, Num t) =>
t -> TCvSubst -> Type -> TcM ([Type], Type)
go Int
n TCvSubst
empty_subst Type
ty
where
empty_subst :: TCvSubst
empty_subst = InScopeSet -> TCvSubst
mkEmptyTCvSubst (VarSet -> InScopeSet
mkInScopeSet (Type -> VarSet
tyCoVarsOfType Type
ty))
go :: t -> TCvSubst -> Type -> TcM ([Type], Type)
go t
n TCvSubst
subst Type
kind
| t
n forall a. Ord a => a -> a -> Bool
> t
0
, Just (TyBinder
bndr, Type
body) <- Type -> Maybe (TyBinder, Type)
tcSplitPiTy_maybe Type
kind
, TyBinder -> Bool
isInvisibleBinder TyBinder
bndr
= do { (TCvSubst
subst', Type
arg) <- TCvSubst -> TyBinder -> TcM (TCvSubst, Type)
tcInstInvisibleTyBinder TCvSubst
subst TyBinder
bndr
; ([Type]
args, Type
inner_ty) <- t -> TCvSubst -> Type -> TcM ([Type], Type)
go (t
nforall a. Num a => a -> a -> a
-t
1) TCvSubst
subst' Type
body
; forall (m :: * -> *) a. Monad m => a -> m a
return (Type
argforall a. a -> [a] -> [a]
:[Type]
args, Type
inner_ty) }
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return ([], HasCallStack => TCvSubst -> Type -> Type
substTy TCvSubst
subst Type
kind)
tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)
tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, Type)
tcInstInvisibleTyBinder TCvSubst
subst (Named (Bndr DFunId
tv ArgFlag
_))
= do { (TCvSubst
subst', DFunId
tv') <- TCvSubst -> DFunId -> TcM (TCvSubst, DFunId)
newMetaTyVarX TCvSubst
subst DFunId
tv
; forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst', DFunId -> Type
mkTyVarTy DFunId
tv') }
tcInstInvisibleTyBinder TCvSubst
subst (Anon AnonArgFlag
af Scaled Type
ty)
| Just (Coercion -> TcM Type
mk, Type
k1, Type
k2) <- Type -> Maybe (Coercion -> TcM Type, Type, Type)
get_eq_tys_maybe (HasCallStack => TCvSubst -> Type -> Type
substTy TCvSubst
subst (forall a. Scaled a -> a
scaledThing Scaled Type
ty))
= ASSERT( af == InvisArg )
do { Coercion
co <- Maybe SDoc -> Type -> Type -> TcM Coercion
unifyKind forall a. Maybe a
Nothing Type
k1 Type
k2
; Type
arg' <- Coercion -> TcM Type
mk Coercion
co
; forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst, Type
arg') }
| Bool
otherwise
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"tcInvisibleTyBinder" (forall a. Outputable a => a -> SDoc
ppr Scaled Type
ty)
get_eq_tys_maybe :: Type
-> Maybe ( Coercion -> TcM Type
, Type
, Type
)
get_eq_tys_maybe :: Type -> Maybe (Coercion -> TcM Type, Type, Type)
get_eq_tys_maybe Type
ty
| Just (TyCon
tc, [Type
_, Type
_, Type
k1, Type
k2]) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
, TyCon
tc forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
heqTyConKey
= forall a. a -> Maybe a
Just (\Coercion
co -> Coercion -> Type -> Type -> TcM Type
mkHEqBoxTy Coercion
co Type
k1 Type
k2, Type
k1, Type
k2)
| Just (TyCon
tc, [Type
_, Type
k1, Type
k2]) <- HasDebugCallStack => Type -> Maybe (TyCon, [Type])
splitTyConApp_maybe Type
ty
, TyCon
tc forall a. Uniquable a => a -> Unique -> Bool
`hasKey` Unique
eqTyConKey
= forall a. a -> Maybe a
Just (\Coercion
co -> Coercion -> Type -> Type -> TcM Type
mkEqBoxTy Coercion
co Type
k1 Type
k2, Type
k1, Type
k2)
| Bool
otherwise
= forall a. Maybe a
Nothing
mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
mkHEqBoxTy :: Coercion -> Type -> Type -> TcM Type
mkHEqBoxTy Coercion
co Type
ty1 Type
ty2
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
TyCon -> [Type] -> Type
mkTyConApp (DataCon -> TyCon
promoteDataCon DataCon
heqDataCon) [Type
k1, Type
k2, Type
ty1, Type
ty2, Coercion -> Type
mkCoercionTy Coercion
co]
where k1 :: Type
k1 = HasDebugCallStack => Type -> Type
tcTypeKind Type
ty1
k2 :: Type
k2 = HasDebugCallStack => Type -> Type
tcTypeKind Type
ty2
mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type
mkEqBoxTy :: Coercion -> Type -> Type -> TcM Type
mkEqBoxTy Coercion
co Type
ty1 Type
ty2
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
TyCon -> [Type] -> Type
mkTyConApp (DataCon -> TyCon
promoteDataCon DataCon
eqDataCon) [Type
k, Type
ty1, Type
ty2, Coercion -> Type
mkCoercionTy Coercion
co]
where k :: Type
k = HasDebugCallStack => Type -> Type
tcTypeKind Type
ty1
tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar]))
-> Id
-> TcM ([(Name, TcTyVar)], TcThetaType, TcType)
tcInstType :: ([DFunId] -> TcM (TCvSubst, [DFunId]))
-> DFunId -> TcM ([(Name, DFunId)], [Type], Type)
tcInstType [DFunId] -> TcM (TCvSubst, [DFunId])
inst_tyvars DFunId
id
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DFunId]
tyvars
= forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Type]
theta, Type
tau)
| Bool
otherwise
= do { (TCvSubst
subst, [DFunId]
tyvars') <- [DFunId] -> TcM (TCvSubst, [DFunId])
inst_tyvars [DFunId]
tyvars
; let tv_prs :: [(Name, DFunId)]
tv_prs = forall a b. (a -> b) -> [a] -> [b]
map DFunId -> Name
tyVarName [DFunId]
tyvars forall a b. [a] -> [b] -> [(a, b)]
`zip` [DFunId]
tyvars'
subst' :: TCvSubst
subst' = TCvSubst -> VarSet -> TCvSubst
extendTCvInScopeSet TCvSubst
subst (Type -> VarSet
tyCoVarsOfType Type
rho)
; forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, DFunId)]
tv_prs, HasCallStack => TCvSubst -> [Type] -> [Type]
substTheta TCvSubst
subst' [Type]
theta, HasCallStack => TCvSubst -> Type -> Type
substTy TCvSubst
subst' Type
tau) }
where
([DFunId]
tyvars, Type
rho) = Type -> ([DFunId], Type)
tcSplitForAllInvisTyVars (DFunId -> Type
idType DFunId
id)
([Type]
theta, Type
tau) = Type -> ([Type], Type)
tcSplitPhiTy Type
rho
tcInstTypeBndrs :: Id -> TcM ([(Name, InvisTVBinder)], TcThetaType, TcType)
tcInstTypeBndrs :: DFunId -> TcM ([(Name, InvisTVBinder)], [Type], Type)
tcInstTypeBndrs DFunId
id
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InvisTVBinder]
tyvars
= forall (m :: * -> *) a. Monad m => a -> m a
return ([], [Type]
theta, Type
tau)
| Bool
otherwise
= do { (TCvSubst
subst, [InvisTVBinder]
tyvars') <- forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM TCvSubst -> InvisTVBinder -> TcM (TCvSubst, InvisTVBinder)
inst_invis_bndr TCvSubst
emptyTCvSubst [InvisTVBinder]
tyvars
; let tv_prs :: [(Name, InvisTVBinder)]
tv_prs = forall a b. (a -> b) -> [a] -> [b]
map (DFunId -> Name
tyVarName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall tv argf. VarBndr tv argf -> tv
binderVar) [InvisTVBinder]
tyvars forall a b. [a] -> [b] -> [(a, b)]
`zip` [InvisTVBinder]
tyvars'
subst' :: TCvSubst
subst' = TCvSubst -> VarSet -> TCvSubst
extendTCvInScopeSet TCvSubst
subst (Type -> VarSet
tyCoVarsOfType Type
rho)
; forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, InvisTVBinder)]
tv_prs, HasCallStack => TCvSubst -> [Type] -> [Type]
substTheta TCvSubst
subst' [Type]
theta, HasCallStack => TCvSubst -> Type -> Type
substTy TCvSubst
subst' Type
tau) }
where
([InvisTVBinder]
tyvars, Type
rho) = Type -> ([InvisTVBinder], Type)
splitForAllInvisTVBinders (DFunId -> Type
idType DFunId
id)
([Type]
theta, Type
tau) = Type -> ([Type], Type)
tcSplitPhiTy Type
rho
inst_invis_bndr :: TCvSubst -> InvisTVBinder
-> TcM (TCvSubst, InvisTVBinder)
inst_invis_bndr :: TCvSubst -> InvisTVBinder -> TcM (TCvSubst, InvisTVBinder)
inst_invis_bndr TCvSubst
subst (Bndr DFunId
tv Specificity
spec)
= do { (TCvSubst
subst', DFunId
tv') <- TCvSubst -> DFunId -> TcM (TCvSubst, DFunId)
newMetaTyVarTyVarX TCvSubst
subst DFunId
tv
; forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst', forall var argf. var -> argf -> VarBndr var argf
Bndr DFunId
tv' Specificity
spec) }
tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType)
tcSkolDFunType :: DFunId -> TcM ([DFunId], [Type], Type)
tcSkolDFunType DFunId
dfun
= do { ([(Name, DFunId)]
tv_prs, [Type]
theta, Type
tau) <- ([DFunId] -> TcM (TCvSubst, [DFunId]))
-> DFunId -> TcM ([(Name, DFunId)], [Type], Type)
tcInstType [DFunId] -> TcM (TCvSubst, [DFunId])
tcInstSuperSkolTyVars DFunId
dfun
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, DFunId)]
tv_prs, [Type]
theta, Type
tau) }
tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar])
tcSuperSkolTyVars :: [DFunId] -> (TCvSubst, [DFunId])
tcSuperSkolTyVars = forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL TCvSubst -> DFunId -> (TCvSubst, DFunId)
tcSuperSkolTyVar TCvSubst
emptyTCvSubst
tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar)
tcSuperSkolTyVar :: TCvSubst -> DFunId -> (TCvSubst, DFunId)
tcSuperSkolTyVar TCvSubst
subst DFunId
tv
= (TCvSubst -> DFunId -> DFunId -> TCvSubst
extendTvSubstWithClone TCvSubst
subst DFunId
tv DFunId
new_tv, DFunId
new_tv)
where
kind :: Type
kind = TCvSubst -> Type -> Type
substTyUnchecked TCvSubst
subst (DFunId -> Type
tyVarKind DFunId
tv)
new_tv :: DFunId
new_tv = Name -> Type -> TcTyVarDetails -> DFunId
mkTcTyVar (DFunId -> Name
tyVarName DFunId
tv) Type
kind TcTyVarDetails
superSkolemTv
tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
tcInstSkolTyVars :: [DFunId] -> TcM (TCvSubst, [DFunId])
tcInstSkolTyVars = TCvSubst -> [DFunId] -> TcM (TCvSubst, [DFunId])
tcInstSkolTyVarsX TCvSubst
emptyTCvSubst
tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
tcInstSkolTyVarsX :: TCvSubst -> [DFunId] -> TcM (TCvSubst, [DFunId])
tcInstSkolTyVarsX = Bool -> TCvSubst -> [DFunId] -> TcM (TCvSubst, [DFunId])
tcInstSkolTyVarsPushLevel Bool
False
tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])
tcInstSuperSkolTyVars :: [DFunId] -> TcM (TCvSubst, [DFunId])
tcInstSuperSkolTyVars = TCvSubst -> [DFunId] -> TcM (TCvSubst, [DFunId])
tcInstSuperSkolTyVarsX TCvSubst
emptyTCvSubst
tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])
tcInstSuperSkolTyVarsX :: TCvSubst -> [DFunId] -> TcM (TCvSubst, [DFunId])
tcInstSuperSkolTyVarsX TCvSubst
subst = Bool -> TCvSubst -> [DFunId] -> TcM (TCvSubst, [DFunId])
tcInstSkolTyVarsPushLevel Bool
True TCvSubst
subst
tcInstSkolTyVarsPushLevel :: Bool
-> TCvSubst -> [TyVar]
-> TcM (TCvSubst, [TcTyVar])
tcInstSkolTyVarsPushLevel :: Bool -> TCvSubst -> [DFunId] -> TcM (TCvSubst, [DFunId])
tcInstSkolTyVarsPushLevel Bool
overlappable TCvSubst
subst [DFunId]
tvs
= do { TcLevel
tc_lvl <- TcM TcLevel
getTcLevel
; let !pushed_lvl :: TcLevel
pushed_lvl = TcLevel -> TcLevel
pushTcLevel TcLevel
tc_lvl
; TcLevel -> Bool -> TCvSubst -> [DFunId] -> TcM (TCvSubst, [DFunId])
tcInstSkolTyVarsAt TcLevel
pushed_lvl Bool
overlappable TCvSubst
subst [DFunId]
tvs }
tcInstSkolTyVarsAt :: TcLevel -> Bool
-> TCvSubst -> [TyVar]
-> TcM (TCvSubst, [TcTyVar])
tcInstSkolTyVarsAt :: TcLevel -> Bool -> TCvSubst -> [DFunId] -> TcM (TCvSubst, [DFunId])
tcInstSkolTyVarsAt TcLevel
lvl Bool
overlappable TCvSubst
subst [DFunId]
tvs
= (Name -> Type -> DFunId)
-> TCvSubst -> [DFunId] -> TcM (TCvSubst, [DFunId])
freshenTyCoVarsX Name -> Type -> DFunId
new_skol_tv TCvSubst
subst [DFunId]
tvs
where
details :: TcTyVarDetails
details = TcLevel -> Bool -> TcTyVarDetails
SkolemTv TcLevel
lvl Bool
overlappable
new_skol_tv :: Name -> Type -> DFunId
new_skol_tv Name
name Type
kind = Name -> Type -> TcTyVarDetails -> DFunId
mkTcTyVar Name
name Type
kind TcTyVarDetails
details
freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar])
freshenTyVarBndrs :: [DFunId] -> TcM (TCvSubst, [DFunId])
freshenTyVarBndrs = (Name -> Type -> DFunId) -> [DFunId] -> TcM (TCvSubst, [DFunId])
freshenTyCoVars Name -> Type -> DFunId
mkTyVar
freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcM (TCvSubst, [CoVar])
freshenCoVarBndrsX :: TCvSubst -> [DFunId] -> TcM (TCvSubst, [DFunId])
freshenCoVarBndrsX TCvSubst
subst = (Name -> Type -> DFunId)
-> TCvSubst -> [DFunId] -> TcM (TCvSubst, [DFunId])
freshenTyCoVarsX Name -> Type -> DFunId
mkCoVar TCvSubst
subst
freshenTyCoVars :: (Name -> Kind -> TyCoVar)
-> [TyVar] -> TcM (TCvSubst, [TyCoVar])
freshenTyCoVars :: (Name -> Type -> DFunId) -> [DFunId] -> TcM (TCvSubst, [DFunId])
freshenTyCoVars Name -> Type -> DFunId
mk_tcv = (Name -> Type -> DFunId)
-> TCvSubst -> [DFunId] -> TcM (TCvSubst, [DFunId])
freshenTyCoVarsX Name -> Type -> DFunId
mk_tcv TCvSubst
emptyTCvSubst
freshenTyCoVarsX :: (Name -> Kind -> TyCoVar)
-> TCvSubst -> [TyCoVar]
-> TcM (TCvSubst, [TyCoVar])
freshenTyCoVarsX :: (Name -> Type -> DFunId)
-> TCvSubst -> [DFunId] -> TcM (TCvSubst, [DFunId])
freshenTyCoVarsX Name -> Type -> DFunId
mk_tcv = forall (m :: * -> *) acc x y.
Monad m =>
(acc -> x -> m (acc, y)) -> acc -> [x] -> m (acc, [y])
mapAccumLM ((Name -> Type -> DFunId)
-> TCvSubst -> DFunId -> TcM (TCvSubst, DFunId)
freshenTyCoVarX Name -> Type -> DFunId
mk_tcv)
freshenTyCoVarX :: (Name -> Kind -> TyCoVar)
-> TCvSubst -> TyCoVar -> TcM (TCvSubst, TyCoVar)
freshenTyCoVarX :: (Name -> Type -> DFunId)
-> TCvSubst -> DFunId -> TcM (TCvSubst, DFunId)
freshenTyCoVarX Name -> Type -> DFunId
mk_tcv TCvSubst
subst DFunId
tycovar
= do { SrcSpan
loc <- TcRn SrcSpan
getSrcSpanM
; Unique
uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
; let old_name :: Name
old_name = DFunId -> Name
tyVarName DFunId
tycovar
new_name :: Name
new_name = Unique -> OccName -> SrcSpan -> Name
mkInternalName Unique
uniq (forall a. NamedThing a => a -> OccName
getOccName Name
old_name) SrcSpan
loc
new_kind :: Type
new_kind = TCvSubst -> Type -> Type
substTyUnchecked TCvSubst
subst (DFunId -> Type
tyVarKind DFunId
tycovar)
new_tcv :: DFunId
new_tcv = Name -> Type -> DFunId
mk_tcv Name
new_name Type
new_kind
subst1 :: TCvSubst
subst1 = TCvSubst -> DFunId -> DFunId -> TCvSubst
extendTCvSubstWithClone TCvSubst
subst DFunId
tycovar DFunId
new_tcv
; forall (m :: * -> *) a. Monad m => a -> m a
return (TCvSubst
subst1, DFunId
new_tcv) }
newOverloadedLit :: HsOverLit GhcRn
-> ExpRhoType
-> TcM (HsOverLit GhcTc)
newOverloadedLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (HsOverLit GhcTc)
newOverloadedLit HsOverLit GhcRn
lit ExpRhoType
res_ty
= do { Maybe (HsOverLit GhcTc)
mb_lit' <- HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc))
tcShortCutLit HsOverLit GhcRn
lit ExpRhoType
res_ty
; case Maybe (HsOverLit GhcTc)
mb_lit' of
Just HsOverLit GhcTc
lit' -> forall (m :: * -> *) a. Monad m => a -> m a
return HsOverLit GhcTc
lit'
Maybe (HsOverLit GhcTc)
Nothing -> HsOverLit GhcRn -> ExpRhoType -> TcM (HsOverLit GhcTc)
newNonTrivialOverloadedLit HsOverLit GhcRn
lit ExpRhoType
res_ty }
newNonTrivialOverloadedLit :: HsOverLit GhcRn
-> ExpRhoType
-> TcM (HsOverLit GhcTc)
newNonTrivialOverloadedLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (HsOverLit GhcTc)
newNonTrivialOverloadedLit
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 SrcSpanAnnN
_ Name
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 :: Type
lit_ty = forall (p :: Pass). HsLit (GhcPass p) -> Type
hsLitType HsLit GhcTc
hs_lit
; (()
_, SyntaxExprTc
fi') <- forall a.
CtOrigin
-> SyntaxExprRn
-> [SyntaxOpType]
-> ExpRhoType
-> ([Type] -> [Type] -> TcM a)
-> TcM (a, SyntaxExprTc)
tcSyntaxOp CtOrigin
orig (Name -> SyntaxExprRn
mkRnSyntaxExpr Name
meth_name)
[Type -> SyntaxOpType
synKnownType Type
lit_ty] ExpRhoType
res_ty forall a b. (a -> b) -> a -> b
$
\[Type]
_ [Type]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
; let L SrcSpanAnnA
_ HsExpr GhcTc
witness = SyntaxExprTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc
nlHsSyntaxApps SyntaxExprTc
fi' [forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit HsLit GhcTc
hs_lit]
; Type
res_ty <- ExpRhoType -> TcM Type
readExpType ExpRhoType
res_ty
; 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 -> Type -> OverLitTc
OverLitTc XOverLit GhcRn
rebindable Type
res_ty }) }
where
orig :: CtOrigin
orig = HsOverLit GhcRn -> CtOrigin
LiteralOrigin HsOverLit GhcRn
lit
newNonTrivialOverloadedLit HsOverLit GhcRn
lit ExpRhoType
_
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"newNonTrivialOverloadedLit" (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 { Type
integer_ty <- Name -> TcM Type
tcMetaTy Name
integerTyConName
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall x. XHsInteger x -> Integer -> Type -> HsLit x
HsInteger (IntegralLit -> SourceText
il_text IntegralLit
i)
(IntegralLit -> Integer
il_value IntegralLit
i) Type
integer_ty) }
mkOverLit (HsFractional FractionalLit
r)
= do { Type
rat_ty <- Name -> TcM Type
tcMetaTy Name
rationalTyConName
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall x. XHsRat x -> FractionalLit -> Type -> HsLit x
HsRat NoExtField
noExtField FractionalLit
r Type
rat_ty) }
mkOverLit (HsIsString SourceText
src FastString
s) = forall (m :: * -> *) a. Monad m => a -> m a
return (forall x. XHsString x -> FastString -> HsLit x
HsString SourceText
src FastString
s)
tcSyntaxName :: CtOrigin
-> TcType
-> (Name, HsExpr GhcRn)
-> TcM (Name, HsExpr GhcTc)
tcSyntaxName :: CtOrigin
-> Type -> (Name, HsExpr GhcRn) -> TcM (Name, HsExpr GhcTc)
tcSyntaxName CtOrigin
orig Type
ty (Name
std_nm, HsVar XVar GhcRn
_ (L SrcSpanAnnN
_ Name
user_nm))
| Name
std_nm forall a. Eq a => a -> a -> Bool
== Name
user_nm
= do HsExpr GhcTc
rhs <- CtOrigin -> Name -> [Type] -> TcM (HsExpr GhcTc)
newMethodFromName CtOrigin
orig Name
std_nm [Type
ty]
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
std_nm, HsExpr GhcTc
rhs)
tcSyntaxName CtOrigin
orig Type
ty (Name
std_nm, HsExpr GhcRn
user_nm_expr) = do
DFunId
std_id <- Name -> TcM DFunId
tcLookupId Name
std_nm
let
([DFunId
tv], [Type]
_, Type
tau) = Type -> ([DFunId], [Type], Type)
tcSplitSigmaTy (DFunId -> Type
idType DFunId
std_id)
sigma1 :: Type
sigma1 = HasCallStack => [DFunId] -> [Type] -> Type -> Type
substTyWith [DFunId
tv] [Type
ty] Type
tau
forall a. (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a
addErrCtxtM (HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv -> TcM (TidyEnv, SDoc)
syntaxNameCtxt HsExpr GhcRn
user_nm_expr CtOrigin
orig Type
sigma1) forall a b. (a -> b) -> a -> b
$ do
SrcSpan
span <- TcRn SrcSpan
getSrcSpanM
GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr <- LHsExpr GhcRn -> Type -> TcM (LHsExpr GhcTc)
tcCheckPolyExpr (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
span) HsExpr GhcRn
user_nm_expr) Type
sigma1
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
std_nm, forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpanAnnA (HsExpr GhcTc)
expr)
syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv
-> TcRn (TidyEnv, SDoc)
syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv -> TcM (TidyEnv, SDoc)
syntaxNameCtxt HsExpr GhcRn
name CtOrigin
orig Type
ty TidyEnv
tidy_env
= do { CtLoc
inst_loc <- CtOrigin -> Maybe TypeOrKind -> TcM CtLoc
getCtLocM CtOrigin
orig (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 (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
<+> forall a. Outputable a => a -> SDoc
ppr (TidyEnv -> Type -> Type
tidyType TidyEnv
tidy_env Type
ty))
, Int -> SDoc -> SDoc
nest Int
2 (CtLoc -> SDoc
pprCtLoc CtLoc
inst_loc) ]
; 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 <- 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 { 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
; forall (m :: * -> *) a. Monad m => a -> m a
return OverlapFlag
final_oflag }
tcGetInsts :: TcM [ClsInst]
tcGetInsts :: TcM [ClsInst]
tcGetInsts = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TcGblEnv -> [ClsInst]
tcg_insts forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
-> Class -> [Type] -> TcM ClsInst
newClsInst :: Maybe OverlapMode
-> Name -> [DFunId] -> [Type] -> Class -> [Type] -> TcM ClsInst
newClsInst Maybe OverlapMode
overlap_mode Name
dfun_name [DFunId]
tvs [Type]
theta Class
clas [Type]
tys
= do { (TCvSubst
subst, [DFunId]
tvs') <- [DFunId] -> TcM (TCvSubst, [DFunId])
freshenTyVarBndrs [DFunId]
tvs
; let tys' :: [Type]
tys' = HasCallStack => TCvSubst -> [Type] -> [Type]
substTys TCvSubst
subst [Type]
tys
dfun :: DFunId
dfun = Name -> [DFunId] -> [Type] -> Class -> [Type] -> DFunId
mkDictFunId Name
dfun_name [DFunId]
tvs [Type]
theta Class
clas [Type]
tys
; OverlapFlag
oflag <- Maybe OverlapMode -> TcM OverlapFlag
getOverlapFlag Maybe OverlapMode
overlap_mode
; let inst :: ClsInst
inst = DFunId -> OverlapFlag -> [DFunId] -> Class -> [Type] -> ClsInst
mkLocalInstance DFunId
dfun OverlapFlag
oflag [DFunId]
tvs' Class
clas [Type]
tys'
; WarningFlag -> Bool -> SDoc -> TcRn ()
warnIfFlag WarningFlag
Opt_WarnOrphans
(IsOrphan -> Bool
isOrphan (ClsInst -> IsOrphan
is_orphan ClsInst
inst))
(ClsInst -> SDoc
instOrphWarn ClsInst
inst)
; 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" forall a. a -> [a] -> [a]
:
String -> SDoc
text String
"wrap the type with a newtype and declare the instance on the new type." forall a. a -> [a] -> [a]
:
[]
tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
tcExtendLocalInstEnv :: forall a. [ClsInst] -> TcM a -> TcM a
tcExtendLocalInstEnv [ClsInst]
dfuns TcM a
thing_inside
= do { [ClsInst] -> TcRn ()
traceDFuns [ClsInst]
dfuns
; TcGblEnv
env <- forall gbl lcl. TcRnIf gbl lcl gbl
getGblEnv
; (InstEnv
inst_env', [ClsInst]
cls_insts') <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM (InstEnv, [ClsInst]) -> ClsInst -> TcM (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' }
; 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 -> TcM (InstEnv, [ClsInst])
addLocalInst (InstEnv
home_ie, [ClsInst]
my_insts) ClsInst
ispec
= do {
; Bool
isGHCi <- TcRn Bool
getIsGHCi
; ExternalPackageState
eps <- forall gbl lcl. TcRnIf gbl lcl ExternalPackageState
getEps
; TcGblEnv
tcg_env <- 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 { 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
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
inconsistent_ispecs) forall a b. (a -> b) -> a -> b
$
ClsInst -> [ClsInst] -> TcRn ()
funDepErr ClsInst
ispec [ClsInst]
inconsistent_ispecs
; let ([DFunId]
_tvs, Class
cls, [Type]
tys) = ClsInst -> ([DFunId], Class, [Type])
instanceHead ClsInst
ispec
([InstMatch]
matches, [ClsInst]
_, [InstMatch]
_) = Bool
-> InstEnvs
-> Class
-> [Type]
-> ([InstMatch], [ClsInst], [InstMatch])
lookupInstEnv Bool
False InstEnvs
inst_envs Class
cls [Type]
tys
dups :: [ClsInst]
dups = forall a. (a -> Bool) -> [a] -> [a]
filter (ClsInst -> ClsInst -> Bool
identicalClsInstHead ClsInst
ispec) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [InstMatch]
matches)
; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ClsInst]
dups) forall a b. (a -> b) -> a -> b
$
ClsInst -> ClsInst -> TcRn ()
dupInstErr ClsInst
ispec (forall a. [a] -> a
head [ClsInst]
dups)
; forall (m :: * -> *) a. Monad m => a -> m a
return (InstEnv -> ClsInst -> InstEnv
extendInstEnv InstEnv
home_ie' ClsInst
ispec, ClsInst
ispec 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 (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 (forall a. Outputable a => a -> SDoc
ppr (ClsInst -> DFunId
instanceDFunId ClsInst
ispec) SDoc -> SDoc -> SDoc
<+> SDoc
colon)
Int
2 (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 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 <- HscEnv -> UnitState
hsc_units forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall gbl lcl. TcRnIf gbl lcl HscEnv
getTopEnv
forall a. SrcSpan -> TcRn a -> TcRn a
setSrcSpan (forall a. NamedThing a => a -> SrcSpan
getSrcSpan (forall a. [a] -> a
head [ClsInst]
sorted)) forall a b. (a -> b) -> a -> b
$
SDoc -> TcRn ()
addErr forall a b. (a -> b) -> a -> b
$ UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
unit_state 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 = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (SrcSpan -> SrcSpan -> Ordering
SrcLoc.leftmost_smallest forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a. NamedThing a => a -> SrcSpan
getSrcSpan) [ClsInst]
ispecs