module Inst (
deeplySkolemise,
deeplyInstantiate, instCall, instStupidTheta,
emitWanted, emitWanteds,
newOverloadedLit, mkOverLit,
newClsInst,
tcGetInsts, tcGetInstEnvs, getOverlapFlag,
tcExtendLocalInstEnv, instCallConstraints, newMethodFromName,
tcSyntaxName,
tyVarsOfWC, tyVarsOfBag,
tyVarsOfCt, tyVarsOfCts,
) where
#include "HsVersions.h"
import TcExpr( tcPolyExpr, tcSyntaxOp )
import TcUnify( unifyType )
import FastString
import HsSyn
import TcHsSyn
import TcRnMonad
import TcEnv
import TcEvidence
import InstEnv
import FunDeps
import TcMType
import Type
import Coercion ( Role(..) )
import TcType
import HscTypes
import Class( Class )
import MkId( mkDictFunId )
import Id
import Name
import Var ( EvVar )
import VarEnv
import VarSet
import PrelNames
import SrcLoc
import DynFlags
import Bag
import Util
import Outputable
import Control.Monad( unless )
import Data.Maybe( isJust )
emitWanteds :: CtOrigin -> TcThetaType -> TcM [EvVar]
emitWanteds origin theta = mapM (emitWanted origin) theta
emitWanted :: CtOrigin -> TcPredType -> TcM EvVar
emitWanted origin pred
= do { loc <- getCtLoc origin
; ev <- newEvVar pred
; emitSimple $ mkNonCanonical $
CtWanted { ctev_pred = pred, ctev_evar = ev, ctev_loc = loc }
; return ev }
newMethodFromName :: CtOrigin -> Name -> TcRhoType -> TcM (HsExpr TcId)
newMethodFromName origin name inst_ty
= do { id <- tcLookupId name
; let (tvs, theta, _caller_knows_this) = tcSplitSigmaTy (idType id)
(the_tv:rest) = tvs
subst = zipOpenTvSubst [the_tv] [inst_ty]
; wrap <- ASSERT( null rest && isSingleton theta )
instCall origin [inst_ty] (substTheta subst theta)
; return (mkHsWrap wrap (HsVar id)) }
deeplySkolemise
:: TcSigmaType
-> TcM (HsWrapper, [TyVar], [EvVar], TcRhoType)
deeplySkolemise ty
| Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty
= do { ids1 <- newSysLocalIds (fsLit "dk") arg_tys
; (subst, tvs1) <- tcInstSkolTyVars tvs
; ev_vars1 <- newEvVars (substTheta subst theta)
; (wrap, tvs2, ev_vars2, rho) <- deeplySkolemise (substTy subst ty')
; return ( mkWpLams ids1
<.> mkWpTyLams tvs1
<.> mkWpLams ev_vars1
<.> wrap
<.> mkWpEvVarApps ids1
, tvs1 ++ tvs2
, ev_vars1 ++ ev_vars2
, mkFunTys arg_tys rho ) }
| otherwise
= return (idHsWrapper, [], [], ty)
deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
deeplyInstantiate orig ty
| Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty
= do { (subst, tvs') <- tcInstTyVars tvs
; ids1 <- newSysLocalIds (fsLit "di") (substTys subst arg_tys)
; let theta' = substTheta subst theta
; wrap1 <- instCall orig (mkTyVarTys tvs') theta'
; traceTc "Instantiating (deeply)" (vcat [ text "origin" <+> pprCtOrigin orig
, text "type" <+> ppr ty
, text "with" <+> ppr tvs'
, text "args:" <+> ppr ids1
, text "theta:" <+> ppr theta' ])
; (wrap2, rho2) <- deeplyInstantiate orig (substTy subst rho)
; return (mkWpLams ids1
<.> wrap2
<.> wrap1
<.> mkWpEvVarApps ids1,
mkFunTys arg_tys rho2) }
| otherwise = return (idHsWrapper, ty)
instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
instCall orig tys theta
= do { dict_app <- instCallConstraints orig theta
; return (dict_app <.> mkWpTyApps tys) }
instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper
instCallConstraints orig preds
| null preds
= return idHsWrapper
| otherwise
= do { evs <- mapM go preds
; traceTc "instCallConstraints" (ppr evs)
; return (mkWpEvApps evs) }
where
go pred
| Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred
= do { co <- unifyType ty1 ty2
; return (EvCoercion co) }
| otherwise
= do { ev_var <- emitWanted modified_orig pred
; return (EvId ev_var) }
where
modified_orig
| Just (Representational, ty1, ty2) <- getEqPredTys_maybe pred
= CoercibleOrigin ty1 ty2
| otherwise
= orig
instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
instStupidTheta orig theta
= do { _co <- instCallConstraints orig theta
; return () }
newOverloadedLit :: CtOrigin
-> HsOverLit Name
-> TcRhoType
-> TcM (HsOverLit TcId)
newOverloadedLit orig lit res_ty
= do dflags <- getDynFlags
newOverloadedLit' dflags orig lit res_ty
newOverloadedLit' :: DynFlags
-> CtOrigin
-> HsOverLit Name
-> TcRhoType
-> TcM (HsOverLit TcId)
newOverloadedLit' dflags orig
lit@(OverLit { ol_val = val, ol_rebindable = rebindable
, ol_witness = meth_name }) res_ty
| not rebindable
, Just expr <- shortCutLit dflags val res_ty
= return (lit { ol_witness = expr, ol_type = res_ty
, ol_rebindable = rebindable })
| otherwise
= do { hs_lit <- mkOverLit val
; let lit_ty = hsLitType hs_lit
; fi' <- tcSyntaxOp orig meth_name (mkFunTy lit_ty res_ty)
; let witness = HsApp (noLoc fi') (noLoc (HsLit hs_lit))
; return (lit { ol_witness = witness, ol_type = res_ty
, ol_rebindable = rebindable }) }
mkOverLit :: OverLitVal -> TcM HsLit
mkOverLit (HsIntegral src i)
= do { integer_ty <- tcMetaTy integerTyConName
; return (HsInteger src i integer_ty) }
mkOverLit (HsFractional r)
= do { rat_ty <- tcMetaTy rationalTyConName
; return (HsRat r rat_ty) }
mkOverLit (HsIsString src s) = return (HsString src s)
tcSyntaxName :: CtOrigin
-> TcType
-> (Name, HsExpr Name)
-> TcM (Name, HsExpr TcId)
tcSyntaxName orig ty (std_nm, HsVar user_nm)
| std_nm == user_nm
= do rhs <- newMethodFromName orig std_nm ty
return (std_nm, rhs)
tcSyntaxName orig ty (std_nm, user_nm_expr) = do
std_id <- tcLookupId std_nm
let
([tv], _, tau) = tcSplitSigmaTy (idType std_id)
sigma1 = substTyWith [tv] [ty] tau
addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
span <- getSrcSpanM
expr <- tcPolyExpr (L span user_nm_expr) sigma1
return (std_nm, unLoc expr)
syntaxNameCtxt :: HsExpr Name -> CtOrigin -> Type -> TidyEnv
-> TcRn (TidyEnv, SDoc)
syntaxNameCtxt name orig ty tidy_env
= do { inst_loc <- getCtLoc orig
; let msg = vcat [ ptext (sLit "When checking that") <+> quotes (ppr name)
<+> ptext (sLit "(needed by a syntactic construct)")
, nest 2 (ptext (sLit "has the required type:")
<+> ppr (tidyType tidy_env ty))
, nest 2 (pprArisingAt inst_loc) ]
; return (tidy_env, msg) }
getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
getOverlapFlag overlap_mode
= do { dflags <- getDynFlags
; let overlap_ok = xopt Opt_OverlappingInstances dflags
incoherent_ok = xopt Opt_IncoherentInstances dflags
use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
, overlapMode = x }
default_oflag | incoherent_ok = use Incoherent
| overlap_ok = use Overlaps
| otherwise = use NoOverlap
final_oflag = setOverlapModeMaybe default_oflag overlap_mode
; return final_oflag }
tcGetInsts :: TcM [ClsInst]
tcGetInsts = fmap tcg_insts getGblEnv
newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType
-> Class -> [Type] -> TcM ClsInst
newClsInst overlap_mode dfun_name tvs theta clas tys
= do { (subst, tvs') <- freshenTyVarBndrs tvs
; let tys' = substTys subst tys
theta' = substTheta subst theta
dfun = mkDictFunId dfun_name tvs' theta' clas tys'
; oflag <- getOverlapFlag overlap_mode
; return (mkLocalInstance dfun oflag tvs' clas tys') }
tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a
tcExtendLocalInstEnv dfuns thing_inside
= do { traceDFuns dfuns
; env <- getGblEnv
; (inst_env', cls_insts') <- foldlM addLocalInst
(tcg_inst_env env, tcg_insts env)
dfuns
; let env' = env { tcg_insts = cls_insts'
, tcg_inst_env = inst_env' }
; setGblEnv env' thing_inside }
addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst])
addLocalInst (home_ie, my_insts) ispec
= do {
; isGHCi <- getIsGHCi
; eps <- getEps
; tcg_env <- getGblEnv
; let home_ie'
| isGHCi = deleteFromInstEnv home_ie ispec
| otherwise = home_ie
(_tvs, cls, tys) = instanceHead ispec
global_ie
| isJust (tcg_sig_of tcg_env) = emptyInstEnv
| otherwise = eps_inst_env eps
inst_envs = InstEnvs { ie_global = global_ie
, ie_local = home_ie'
, ie_visible = tcg_visible_orphan_mods tcg_env }
(matches, _, _) = lookupInstEnv inst_envs cls tys
dups = filter (identicalClsInstHead ispec) (map fst matches)
; case checkFunDeps inst_envs ispec of
Just specs -> funDepErr ispec specs
Nothing -> return ()
; unless (null dups) $
dupInstErr ispec (head dups)
; return (extendInstEnv home_ie' ispec, ispec : my_insts) }
traceDFuns :: [ClsInst] -> TcRn ()
traceDFuns ispecs
= traceTc "Adding instances:" (vcat (map pp ispecs))
where
pp ispec = hang (ppr (instanceDFunId ispec) <+> colon)
2 (ppr ispec)
funDepErr :: ClsInst -> [ClsInst] -> TcRn ()
funDepErr ispec ispecs
= addClsInstsErr (ptext (sLit "Functional dependencies conflict between instance declarations:"))
(ispec : ispecs)
dupInstErr :: ClsInst -> ClsInst -> TcRn ()
dupInstErr ispec dup_ispec
= addClsInstsErr (ptext (sLit "Duplicate instance declarations:"))
[ispec, dup_ispec]
addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()
addClsInstsErr herald ispecs
= setSrcSpan (getSrcSpan (head sorted)) $
addErr (hang herald 2 (pprInstances sorted))
where
sorted = sortWith getSrcLoc ispecs
tyVarsOfCt :: Ct -> TcTyVarSet
tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (tyVarsOfType xi) tv
tyVarsOfCt (CFunEqCan { cc_tyargs = tys, cc_fsk = fsk }) = extendVarSet (tyVarsOfTypes tys) fsk
tyVarsOfCt (CDictCan { cc_tyargs = tys }) = tyVarsOfTypes tys
tyVarsOfCt (CIrredEvCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev)
tyVarsOfCt (CHoleCan { cc_ev = ev }) = tyVarsOfType (ctEvPred ev)
tyVarsOfCt (CNonCanonical { cc_ev = ev }) = tyVarsOfType (ctEvPred ev)
tyVarsOfCts :: Cts -> TcTyVarSet
tyVarsOfCts = foldrBag (unionVarSet . tyVarsOfCt) emptyVarSet
tyVarsOfWC :: WantedConstraints -> TyVarSet
tyVarsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_insol = insol })
= tyVarsOfCts simple `unionVarSet`
tyVarsOfBag tyVarsOfImplic implic `unionVarSet`
tyVarsOfCts insol
tyVarsOfImplic :: Implication -> TyVarSet
tyVarsOfImplic (Implic { ic_skols = skols
, ic_given = givens, ic_wanted = wanted })
= (tyVarsOfWC wanted `unionVarSet` tyVarsOfTypes (map evVarPred givens))
`delVarSetList` skols
tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet
tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet