x
In general,
if deeplySkolemise ty = (wrap, tvs, evs, rho)
and e :: rho
then wrap e :: ty
and 'wrap' binds tvs, evs
ToDo: this eta-abstraction plays fast and loose with termination,
because it can introduce extra lambdas. Maybe add a `seq` to
fix this
\begin{code}
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
; tvs1 <- tcInstSkolTyVars tvs
; let subst = zipTopTvSubst tvs (mkTyVarTys tvs1)
; 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 { (_, tys, subst) <- tcInstTyVars tvs
; ids1 <- newSysLocalIds (fsLit "di") (substTys subst arg_tys)
; wrap1 <- instCall orig tys (substTheta subst theta)
; (wrap2, rho2) <- deeplyInstantiate orig (substTy subst rho)
; return (mkWpLams ids1
<.> wrap2
<.> wrap1
<.> mkWpEvVarApps ids1,
mkFunTys arg_tys rho2) }
| otherwise = return (idHsWrapper, ty)
\end{code}
%************************************************************************
%* *
Instantiating a call
%* *
%************************************************************************
\begin{code}
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 _ [] = return idHsWrapper
instCallConstraints origin (EqPred ty1 ty2 : preds)
= do { traceTc "instCallConstraints" $ ppr (EqPred ty1 ty2)
; coi <- unifyType ty1 ty2
; co_fn <- instCallConstraints origin preds
; let co = case coi of
IdCo ty -> ty
ACo co -> co
; return (co_fn <.> WpEvApp (EvCoercion co)) }
instCallConstraints origin (pred : preds)
= do { ev_var <- emitWanted origin pred
; co_fn <- instCallConstraints origin preds
; return (co_fn <.> WpEvApp (EvId ev_var)) }
instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
instStupidTheta orig theta
= do { _co <- instCallConstraints orig theta
; return () }
\end{code}
%************************************************************************
%* *
Literals
%* *
%************************************************************************
In newOverloadedLit we convert directly to an Int or Integer if we
know that's what we want. This may save some time, by not
temporarily generating overloaded literals, but it won't catch all
cases (the rest are caught in lookupInst).
\begin{code}
newOverloadedLit :: CtOrigin
-> HsOverLit Name
-> TcRhoType
-> TcM (HsOverLit TcId)
newOverloadedLit orig
lit@(OverLit { ol_val = val, ol_rebindable = rebindable
, ol_witness = meth_name }) res_ty
| not rebindable
, Just expr <- shortCutLit val res_ty
= return (lit { ol_witness = expr, ol_type = res_ty })
| 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 }) }
mkOverLit :: OverLitVal -> TcM HsLit
mkOverLit (HsIntegral i)
= do { integer_ty <- tcMetaTy integerTyConName
; return (HsInteger i integer_ty) }
mkOverLit (HsFractional r)
= do { rat_ty <- tcMetaTy rationalTyConName
; return (HsRat r rat_ty) }
mkOverLit (HsIsString s) = return (HsString s)
\end{code}
%************************************************************************
%* *
Re-mappable syntax
Used only for arrow syntax -- find a way to nuke this
%* *
%************************************************************************
Suppose we are doing the -XRebindableSyntax thing, and we encounter
a do-expression. We have to find (>>) in the current environment, which is
done by the rename. Then we have to check that it has the same type as
Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
this:
(>>) :: HB m n mn => m a -> n b -> mn b
So the idea is to generate a local binding for (>>), thus:
let then72 :: forall a b. m a -> m b -> m b
then72 = ...something involving the user's (>>)...
in
...the do-expression...
Now the do-expression can proceed using then72, which has exactly
the expected type.
In fact tcSyntaxName just generates the RHS for then72, because we only
want an actual binding in the do-expression case. For literals, we can
just use the expression inline.
\begin{code}
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)
\end{code}
%************************************************************************
%* *
Instances
%* *
%************************************************************************
\begin{code}
getOverlapFlag :: TcM OverlapFlag
getOverlapFlag
= do { dflags <- getDOpts
; let overlap_ok = xopt Opt_OverlappingInstances dflags
incoherent_ok = xopt Opt_IncoherentInstances dflags
overlap_flag | incoherent_ok = Incoherent
| overlap_ok = OverlapOk
| otherwise = NoOverlap
; return overlap_flag }
tcGetInstEnvs :: TcM (InstEnv, InstEnv)
tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
return (eps_inst_env eps, tcg_inst_env env) }
tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
tcExtendLocalInstEnv dfuns thing_inside
= do { traceDFuns dfuns
; env <- getGblEnv
; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
tcg_inst_env = inst_env' }
; setGblEnv env' thing_inside }
addLocalInst :: InstEnv -> Instance -> TcM InstEnv
addLocalInst home_ie ispec
= do {
let dfun = instanceDFunId ispec
; (tvs', theta', tau') <- tcInstSkolType (idType dfun)
; let (cls, tys') = tcSplitDFunHead tau'
dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
ispec' = setInstanceDFunId ispec dfun'
; eps <- getEps
; let inst_envs = (eps_inst_env eps, home_ie)
; case checkFunDeps inst_envs ispec' of
Just specs -> funDepErr ispec' specs
Nothing -> return ()
; let { (matches, _) = lookupInstEnv inst_envs cls tys'
; dup_ispecs = [ dup_ispec
| (dup_ispec, _) <- matches
, let (_,_,_,dup_tys) = instanceHead dup_ispec
, isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
; case dup_ispecs of
dup_ispec : _ -> dupInstErr ispec' dup_ispec
[] -> return ()
; return (extendInstEnv home_ie ispec') }
traceDFuns :: [Instance] -> TcRn ()
traceDFuns ispecs
= traceTc "Adding instances:" (vcat (map pp ispecs))
where
pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
funDepErr :: Instance -> [Instance] -> TcRn ()
funDepErr ispec ispecs
= addDictLoc ispec $
addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:"))
2 (pprInstances (ispec:ispecs)))
dupInstErr :: Instance -> Instance -> TcRn ()
dupInstErr ispec dup_ispec
= addDictLoc ispec $
addErr (hang (ptext (sLit "Duplicate instance declarations:"))
2 (pprInstances [ispec, dup_ispec]))
addDictLoc :: Instance -> TcRn a -> TcRn a
addDictLoc ispec thing_inside
= setSrcSpan (mkSrcSpan loc loc) thing_inside
where
loc = getSrcLoc ispec
\end{code}
%************************************************************************
%* *
Simple functions over evidence variables
%* *
%************************************************************************
\begin{code}
unitImplication :: Implication -> Bag Implication
unitImplication implic
| isEmptyWC (ic_wanted implic) = emptyBag
| otherwise = unitBag implic
hasEqualities :: [EvVar] -> Bool
hasEqualities givens = any (has_eq . evVarPred) givens
where
has_eq (EqPred {}) = True
has_eq (IParam {}) = False
has_eq (ClassP cls _tys) = any has_eq (classSCTheta cls)
tyVarsOfWC :: WantedConstraints -> TyVarSet
tyVarsOfWC (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
= tyVarsOfEvVarXs flat `unionVarSet`
tyVarsOfBag tyVarsOfImplication implic `unionVarSet`
tyVarsOfEvVarXs insol
tyVarsOfImplication :: Implication -> TyVarSet
tyVarsOfImplication (Implic { ic_skols = skols, ic_wanted = wanted })
= tyVarsOfWC wanted `minusVarSet` skols
tyVarsOfEvVarX :: EvVarX a -> TyVarSet
tyVarsOfEvVarX (EvVarX ev _) = tyVarsOfEvVar ev
tyVarsOfEvVarXs :: Bag (EvVarX a) -> TyVarSet
tyVarsOfEvVarXs = tyVarsOfBag tyVarsOfEvVarX
tyVarsOfEvVar :: EvVar -> TyVarSet
tyVarsOfEvVar ev = tyVarsOfPred $ evVarPred ev
tyVarsOfEvVars :: [EvVar] -> TyVarSet
tyVarsOfEvVars = foldr (unionVarSet . tyVarsOfEvVar) emptyVarSet
tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet
tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet
tidyWC :: TidyEnv -> WantedConstraints -> WantedConstraints
tidyWC env (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
= WC { wc_flat = tidyWantedEvVars env flat
, wc_impl = mapBag (tidyImplication env) implic
, wc_insol = mapBag (tidyFlavoredEvVar env) insol }
tidyImplication :: TidyEnv -> Implication -> Implication
tidyImplication env implic@(Implic { ic_skols = tvs
, ic_given = given
, ic_wanted = wanted
, ic_loc = loc })
= implic { ic_skols = mkVarSet tvs'
, ic_given = map (tidyEvVar env1) given
, ic_wanted = tidyWC env1 wanted
, ic_loc = tidyGivenLoc env1 loc }
where
(env1, tvs') = mapAccumL tidyTyVarBndr env (varSetElems tvs)
tidyEvVar :: TidyEnv -> EvVar -> EvVar
tidyEvVar env var = setVarType var (tidyType env (varType var))
tidyWantedEvVar :: TidyEnv -> WantedEvVar -> WantedEvVar
tidyWantedEvVar env (EvVarX v l) = EvVarX (tidyEvVar env v) l
tidyWantedEvVars :: TidyEnv -> Bag WantedEvVar -> Bag WantedEvVar
tidyWantedEvVars env = mapBag (tidyWantedEvVar env)
tidyFlavoredEvVar :: TidyEnv -> FlavoredEvVar -> FlavoredEvVar
tidyFlavoredEvVar env (EvVarX v fl)
= EvVarX (tidyEvVar env v) (tidyFlavor env fl)
tidyFlavor :: TidyEnv -> CtFlavor -> CtFlavor
tidyFlavor env (Given loc) = Given (tidyGivenLoc env loc)
tidyFlavor _ fl = fl
tidyGivenLoc :: TidyEnv -> GivenLoc -> GivenLoc
tidyGivenLoc env (CtLoc skol span ctxt) = CtLoc (tidySkolemInfo env skol) span ctxt
tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo
tidySkolemInfo env (SigSkol cx ty) = SigSkol cx (tidyType env ty)
tidySkolemInfo env (InferSkol ids) = InferSkol (mapSnd (tidyType env) ids)
tidySkolemInfo _ info = info
substWC :: TvSubst -> WantedConstraints -> WantedConstraints
substWC subst (WC { wc_flat = flat, wc_impl = implic, wc_insol = insol })
= WC { wc_flat = substWantedEvVars subst flat
, wc_impl = mapBag (substImplication subst) implic
, wc_insol = mapBag (substFlavoredEvVar subst) insol }
substImplication :: TvSubst -> Implication -> Implication
substImplication subst implic@(Implic { ic_skols = tvs
, ic_given = given
, ic_wanted = wanted
, ic_loc = loc })
= implic { ic_skols = mkVarSet tvs'
, ic_given = map (substEvVar subst1) given
, ic_wanted = substWC subst1 wanted
, ic_loc = substGivenLoc subst1 loc }
where
(subst1, tvs') = mapAccumL substTyVarBndr subst (varSetElems tvs)
substEvVar :: TvSubst -> EvVar -> EvVar
substEvVar subst var = setVarType var (substTy subst (varType var))
substWantedEvVars :: TvSubst -> Bag WantedEvVar -> Bag WantedEvVar
substWantedEvVars subst = mapBag (substWantedEvVar subst)
substWantedEvVar :: TvSubst -> WantedEvVar -> WantedEvVar
substWantedEvVar subst (EvVarX v l) = EvVarX (substEvVar subst v) l
substFlavoredEvVar :: TvSubst -> FlavoredEvVar -> FlavoredEvVar
substFlavoredEvVar subst (EvVarX v fl)
= EvVarX (substEvVar subst v) (substFlavor subst fl)
substFlavor :: TvSubst -> CtFlavor -> CtFlavor
substFlavor subst (Given loc) = Given (substGivenLoc subst loc)
substFlavor _ fl = fl
substGivenLoc :: TvSubst -> GivenLoc -> GivenLoc
substGivenLoc subst (CtLoc skol span ctxt) = CtLoc (substSkolemInfo subst skol) span ctxt
substSkolemInfo :: TvSubst -> SkolemInfo -> SkolemInfo
substSkolemInfo subst (SigSkol cx ty) = SigSkol cx (substTy subst ty)
substSkolemInfo subst (InferSkol ids) = InferSkol (mapSnd (substTy subst) ids)
substSkolemInfo _ info = info
\end{code}