--------------------------------
-- Rexported from Type
Kind, -- Stuff to do with kinds is insensitive to pre/post Tc
- unliftedTypeKind, liftedTypeKind, unboxedTypeKind,
+ unliftedTypeKind, liftedTypeKind, unboxedTypeKind, argTypeKind,
openTypeKind, mkArrowKind, mkArrowKinds,
isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
isArgTypeKind, isSubKind, defaultKind,
import Type ( -- Re-exports
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
tyVarsOfTheta, Kind, PredType(..),
- ThetaType, unliftedTypeKind, unboxedTypeKind,
+ ThetaType, unliftedTypeKind, unboxedTypeKind, argTypeKind,
liftedTypeKind, openTypeKind, mkArrowKind,
isLiftedTypeKind, isUnliftedTypeKind,
mkArrowKinds, mkForAllTy, mkForAllTys,
import DataCon ( DataCon, dataConStupidTheta, dataConResTys )
import Class ( Class )
import Var ( TyVar, Id, isTcTyVar, mkTcTyVar, tyVarName, tyVarKind, tcTyVarDetails )
-import ForeignCall ( Safety, playSafe, DNType(..) )
+import ForeignCall ( Safety, DNType(..) )
import Unify ( tcMatchTys )
import VarSet
be the *same*, so we can't make them into skolem constants that don't unify
with each other. Alas.
-On the other hand, we *must* use skolems for signature type variables,
-becuase GADT type refinement refines skolems only.
-
One solution would be insist that in the above defn the programmer uses
the same type variable in both type signatures. But that takes explanation.
The alternative (currently implemented) is to have a special kind of skolem
-constant, SigSkokTv, which can unify with other SigSkolTvs.
+constant, SigTv, which can unify with other SigTvs. These are *not* treated
+as righd for the purposes of GADTs. And they are used *only* for pattern
+bindings and mutually recursive function bindings. See the function
+TcBinds.tcInstSig, and its use_skols parameter.
\begin{code}
tidySkolemTyVar :: TidyEnv -> TcTyVar -> (TidyEnv, TcTyVar)
-- Tidy the type inside a GenSkol, preparatory to printing it
tidySkolemTyVar env tv
- = ASSERT( isSkolemTyVar tv )
+ = ASSERT( isSkolemTyVar tv || isSigTyVar tv )
(env1, mkTcTyVar (tyVarName tv) (tyVarKind tv) info1)
where
(env1, info1) = case tcTyVarDetails tv of
- SkolemTv (GenSkol tvs ty loc) -> (env2, SkolemTv (GenSkol tvs1 ty1 loc))
+ SkolemTv info -> (env1, SkolemTv info')
+ where
+ (env1, info') = tidy_skol_info env info
+ MetaTv (SigTv info) box -> (env1, MetaTv (SigTv info') box)
+ where
+ (env1, info') = tidy_skol_info env info
+ info -> (env, info)
+
+ tidy_skol_info env (GenSkol tvs ty loc) = (env2, GenSkol tvs1 ty1 loc)
where
(env1, tvs1) = tidyOpenTyVars env tvs
(env2, ty1) = tidyOpenType env1 ty
- info -> (env, info)
+ tidy_skol_info env info = (env, info)
pprSkolTvBinding :: TcTyVar -> SDoc
-- Print info about the binding of a skolem tyvar,
%************************************************************************
\begin{code}
+mkSigmaTy :: [TyVar] -> [PredType] -> Type -> Type
mkSigmaTy tyvars theta tau = mkForAllTys tyvars (mkPhiTy theta tau)
mkPhiTy :: [PredType] -> Type -> Type
tcIsForAllTy (ForAllTy tv ty) = True
tcIsForAllTy t = False
-tcSplitPhiTy :: Type -> ([PredType], Type)
+tcSplitPhiTy :: Type -> (ThetaType, Type)
tcSplitPhiTy ty = split ty ty []
where
split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs
- split orig_ty (FunTy arg res) ts = case tcSplitPredTy_maybe arg of
- Just p -> split res res (p:ts)
- Nothing -> (reverse ts, orig_ty)
+ split orig_ty (FunTy arg res) ts
+ | Just p <- tcSplitPredTy_maybe arg = split res res (p:ts)
split orig_ty ty ts = (reverse ts, orig_ty)
+tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type)
tcSplitSigmaTy ty = case tcSplitForAllTys ty of
(tvs, rho) -> case tcSplitPhiTy rho of
(theta, tau) -> (tvs, theta, tau)
| otherwise
= ([], ty)
-tcFunArgTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> arg }
-tcFunResultTy ty = case tcSplitFunTy_maybe ty of { Just (arg,res) -> res }
-
+tcSplitFunTy ty = expectJust "tcSplitFunTy" (tcSplitFunTy_maybe ty)
+tcFunArgTy ty = fst (tcSplitFunTy ty)
+tcFunResultTy ty = snd (tcSplitFunTy ty)
-----------------------
tcSplitAppTy_maybe :: Type -> Maybe (Type, Type)
tcSplitDFunHead tau
= case tcSplitPredTy_maybe tau of
Just (ClassP clas tys) -> (clas, tys)
+ other -> panic "tcSplitDFunHead"
tcValidInstHeadTy :: Type -> Bool
-- Used in Haskell-98 mode, for the argument types of an instance head
getClassPredTys :: PredType -> (Class, [Type])
getClassPredTys (ClassP clas tys) = (clas, tys)
+getClassPredTys other = panic "getClassPredTys"
mkDictTy :: Class -> [Type] -> Type
mkDictTy clas tys = mkPredTy (ClassP clas tys)
| con <- cons
, let Just subst = tcMatchTys tvs1 res_tys1 (dataConResTys con)
, pred <- dataConStupidTheta con ]
+dataConsStupidTheta [] = panic "dataConsStupidTheta"
\end{code}
\begin{code}
exactTyVarsOfType :: TcType -> TyVarSet
-- Find the free type variables (of any kind)
--- but *expand* type synonyms. See Note [Silly type synonym] belos.
+-- but *expand* type synonyms. See Note [Silly type synonym] above.
exactTyVarsOfType ty
= go ty
where
toDNType ty
| isStringTy ty = DNString
| isFFIDotnetObjTy ty = DNObject
- | Just (tc,argTys) <- tcSplitTyConApp_maybe ty =
- case lookup (getUnique tc) dn_assoc of
+ | Just (tc,argTys) <- tcSplitTyConApp_maybe ty
+ = case lookup (getUnique tc) dn_assoc of
Just x -> x
Nothing
| tc `hasKey` ioTyConKey -> toDNType (head argTys)
- | otherwise -> pprPanic ("toDNType: unsupported .NET type") (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc)
+ | otherwise -> pprPanic ("toDNType: unsupported .NET type")
+ (pprType ty <+> parens (hcat (map pprType argTys)) <+> ppr tc)
+ | otherwise = panic "toDNType" -- Is this right?
where
dn_assoc :: [ (Unique, DNType) ]
dn_assoc = [ (unitTyConKey, DNUnit)
projects / ghc-hetmet.git / blobdiff