-- Various unifications
unifyType, unifyTypeList, unifyTheta,
unifyKind, unifyKinds, unifyFunKind,
- checkExpectedKind,
preSubType, boxyMatchTypes,
--------------------------------
go ty1 ty2 -- C.f. the isSigmaTy case for boxySubMatchType
| isSigmaTy ty1
- , (tvs1, _, tau1) <- tcSplitSigmaTy ty1
- , (tvs2, _, tau2) <- tcSplitSigmaTy ty2
+ , (tvs1, ps1, tau1) <- tcSplitSigmaTy ty1
+ , (tvs2, ps2, tau2) <- tcSplitSigmaTy ty2
, equalLength tvs1 tvs2
+ , equalLength ps1 ps2
= boxy_match (tmpl_tvs `delVarSetList` tvs1) tau1
(boxy_tvs `extendVarSetList` tvs2) tau2 subst
Nothing -> orig_boxy_ty
Just ty -> ty `boxyLub` orig_boxy_ty
- go _ (TyVarTy tv) | isMetaTyVar tv
+ go _ (TyVarTy tv) | isTcTyVar tv && isMetaTyVar tv
+ -- NB: A TyVar (not TcTyVar) is possible here, representing
+ -- a skolem, because in this pure boxy_match function
+ -- we don't instantiate foralls to TcTyVars; cf Trac #2714
= subst -- Don't fail if the template has more info than the target!
-- Otherwise, with tmpl_tvs = [a], matching (a -> Int) ~ (Bool -> beta)
-- would fail to instantiate 'a', because the meta-type-variable
unifyTypeList :: [TcTauType] -> TcM ()
unifyTypeList [] = return ()
unifyTypeList [_] = return ()
-unifyTypeList (ty1:tys@(ty2:_)) = do { unifyType ty1 ty2
- ; unifyTypeList tys }
+unifyTypeList (ty1:tys@(ty2:_)) = do { _ <- unifyType ty1 ty2
+ ; unifyTypeList tys }
\end{code}
%************************************************************************
identicalOpenSynTyConApp = idxTys1 `tcEqTypes` idxTys2
-- See Note [OpenSynTyCon app]
- -- If we can reduce a family app => proceed with reduct
- -- NB: We use isOpenSynTyCon, not isOpenSynTyConApp as we also must
- -- defer oversaturated applications!
- go outer sty1 ty1@(TyConApp con1 _) sty2 ty2
- | isOpenSynTyCon con1
- = do { (coi1, ty1') <- tcNormaliseFamInst ty1
- ; case coi1 of
- IdCo -> defer -- no reduction, see [Deferred Unification]
- _ -> liftM (coi1 `mkTransCoI`) $ go outer sty1 ty1' sty2 ty2
- }
-
- -- If we can reduce a family app => proceed with reduct
- -- NB: We use isOpenSynTyCon, not isOpenSynTyConApp as we also must
- -- defer oversaturated applications!
- go outer sty1 ty1 sty2 ty2@(TyConApp con2 _)
- | isOpenSynTyCon con2
- = do { (coi2, ty2') <- tcNormaliseFamInst ty2
- ; case coi2 of
- IdCo -> defer -- no reduction, see [Deferred Unification]
- _ -> liftM (`mkTransCoI` mkSymCoI coi2) $
- go outer sty1 ty1 sty2 ty2'
- }
-
-- Functions; just check the two parts
go _ _ (FunTy fun1 arg1) _ (FunTy fun2 arg2)
= do { coi_l <- uTys nb1 fun1 nb2 fun2
; coi_t <- uTys nb1 t1 nb2 t2
; return $ mkAppTyCoI s1 coi_s t1 coi_t }
+ -- If we can reduce a family app => proceed with reduct
+ -- NB1: We use isOpenSynTyCon, not isOpenSynTyConApp as we also must
+ -- defer oversaturated applications!
+ --
+ -- NB2: Do this *after* trying decomposing applications, so that decompose
+ -- (m a) ~ (F Int b)
+ -- where F has arity 1
+ go _ _ ty1@(TyConApp con1 _) _ ty2
+ | isOpenSynTyCon con1
+ = do { (coi1, ty1') <- tcNormaliseFamInst ty1
+ ; case coi1 of
+ IdCo -> defer -- no reduction, see [Deferred Unification]
+ _ -> liftM (coi1 `mkTransCoI`) $ uTys nb1 ty1' nb2 ty2
+ }
+
+ go _ _ ty1 _ ty2@(TyConApp con2 _)
+ | isOpenSynTyCon con2
+ = do { (coi2, ty2') <- tcNormaliseFamInst ty2
+ ; case coi2 of
+ IdCo -> defer -- no reduction, see [Deferred Unification]
+ _ -> liftM (`mkTransCoI` mkSymCoI coi2) $
+ uTys nb1 ty1 nb2 ty2'
+ }
+
-- Anything else fails
go outer _ _ _ _ = bale_out outer
-- with that type.
zapToMonotype res_ty
= do { res_tau <- newFlexiTyVarTy liftedTypeKind
- ; boxyUnify res_tau res_ty
+ ; _ <- boxyUnify res_tau res_ty
; return res_tau }
unBox :: BoxyType -> TcM TcType
%************************************************************************
%* *
- Checking kinds
-%* *
-%************************************************************************
-
----------------------------
--- We would like to get a decent error message from
--- (a) Under-applied type constructors
--- f :: (Maybe, Maybe)
--- (b) Over-applied type constructors
--- f :: Int x -> Int x
---
-
-\begin{code}
-checkExpectedKind :: Outputable a => a -> TcKind -> TcKind -> TcM ()
--- A fancy wrapper for 'unifyKind', which tries
--- to give decent error messages.
--- (checkExpectedKind ty act_kind exp_kind)
--- checks that the actual kind act_kind is compatible
--- with the expected kind exp_kind
--- The first argument, ty, is used only in the error message generation
-checkExpectedKind ty act_kind exp_kind
- | act_kind `isSubKind` exp_kind -- Short cut for a very common case
- = return ()
- | otherwise = do
- (_errs, mb_r) <- tryTc (unifyKind exp_kind act_kind)
- case mb_r of
- Just _ -> return () -- Unification succeeded
- Nothing -> do
-
- -- So there's definitely an error
- -- Now to find out what sort
- exp_kind <- zonkTcKind exp_kind
- act_kind <- zonkTcKind act_kind
-
- env0 <- tcInitTidyEnv
- let (exp_as, _) = splitKindFunTys exp_kind
- (act_as, _) = splitKindFunTys act_kind
- n_exp_as = length exp_as
- n_act_as = length act_as
-
- (env1, tidy_exp_kind) = tidyKind env0 exp_kind
- (env2, tidy_act_kind) = tidyKind env1 act_kind
-
- err | n_exp_as < n_act_as -- E.g. [Maybe]
- = quotes (ppr ty) <+> ptext (sLit "is not applied to enough type arguments")
-
- -- Now n_exp_as >= n_act_as. In the next two cases,
- -- n_exp_as == 0, and hence so is n_act_as
- | isLiftedTypeKind exp_kind && isUnliftedTypeKind act_kind
- = ptext (sLit "Expecting a lifted type, but") <+> quotes (ppr ty)
- <+> ptext (sLit "is unlifted")
-
- | isUnliftedTypeKind exp_kind && isLiftedTypeKind act_kind
- = ptext (sLit "Expecting an unlifted type, but") <+> quotes (ppr ty)
- <+> ptext (sLit "is lifted")
-
- | otherwise -- E.g. Monad [Int]
- = ptext (sLit "Kind mis-match")
-
- more_info = sep [ ptext (sLit "Expected kind") <+>
- quotes (pprKind tidy_exp_kind) <> comma,
- ptext (sLit "but") <+> quotes (ppr ty) <+>
- ptext (sLit "has kind") <+> quotes (pprKind tidy_act_kind)]
-
- failWithTcM (env2, err $$ more_info)
-\end{code}
-
-%************************************************************************
-%* *
\subsection{Checking signature type variables}
%* *
%************************************************************************
projects / ghc-hetmet.git / blobdiff