Commit 7c2af5cb authored by Iavor S. Diatchki's avatar Iavor S. Diatchki
Browse files

Extend GHC's type with a representation for type level literals.

Currently, we support only numeric literals but---hopefully---these
modifications should make it fairly easy to add other ones, if necessary.
parent 826b75a9
......@@ -1099,8 +1099,15 @@ getTyDescription ty
FunTy _ res -> '-' : '>' : fun_result res
TyConApp tycon _ -> getOccString tycon
ForAllTy _ ty -> getTyDescription ty
LiteralTy n -> getTyLitDescription n
}
where
fun_result (FunTy _ res) = '>' : fun_result res
fun_result other = getTyDescription other
getTyLitDescription :: TyLit -> String
getTyLitDescription l =
case l of
NumberTyLit n -> show n
\end{code}
......@@ -864,11 +864,17 @@ getTyDescription ty
FunTy _ res -> '-' : '>' : fun_result res
TyConApp tycon _ -> getOccString tycon
ForAllTy _ ty -> getTyDescription ty
LiteralTy n -> getTyLitDescription n
}
where
fun_result (FunTy _ res) = '>' : fun_result res
fun_result other = getTyDescription other
getTyLitDescription :: TyLit -> String
getTyLitDescription l =
case l of
NumberTyLit n -> show n
--------------------------------------
-- CmmInfoTable-related things
--------------------------------------
......
......@@ -846,10 +846,20 @@ lintType ty@(TyConApp tc tys)
| otherwise
= failWithL (hang (ptext (sLit "Malformed type:")) 2 (ppr ty))
lintType ty@(LiteralTy l) = lintTyLit l >> return (typeKind ty)
lintType (ForAllTy tv ty)
= do { lintTyBndrKind tv
; addInScopeVar tv (lintType ty) }
---
lintTyLit :: TyLit -> LintM ()
lintTyLit (NumberTyLit n)
| n >= 0 = return ()
| otherwise = failWithL msg
where msg = ptext (sLit "Negative type literal:") <+> integer n
----------------
lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind
lint_ty_app ty k tys = lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k tys
......
......@@ -486,7 +486,10 @@ data TypeMap a
, tm_app :: TypeMap (TypeMap a)
, tm_fun :: TypeMap (TypeMap a)
, tm_tc_app :: NameEnv (ListMap TypeMap a)
, tm_forall :: TypeMap (BndrMap a) }
, tm_forall :: TypeMap (BndrMap a)
, tm_tylit :: TyLitMap a
}
instance Outputable a => Outputable (TypeMap a) where
ppr m = text "TypeMap elts" <+> ppr (foldTypeMap (:) [] m)
......@@ -499,7 +502,8 @@ wrapEmptyTypeMap = TM { tm_var = emptyTM
, tm_app = EmptyTM
, tm_fun = EmptyTM
, tm_tc_app = emptyNameEnv
, tm_forall = EmptyTM }
, tm_forall = EmptyTM
, tm_tylit = emptyTyLitMap }
instance TrieMap TypeMap where
type Key TypeMap = Type
......@@ -519,6 +523,7 @@ lkT env ty m
go (AppTy t1 t2) = tm_app >.> lkT env t1 >=> lkT env t2
go (FunTy t1 t2) = tm_fun >.> lkT env t1 >=> lkT env t2
go (TyConApp tc tys) = tm_tc_app >.> lkNamed tc >=> lkList (lkT env) tys
go (LiteralTy l) = tm_tylit >.> lkTyLit l
go (ForAllTy tv ty) = tm_forall >.> lkT (extendCME env tv) ty >=> lkBndr env tv
-----------------
......@@ -535,6 +540,8 @@ xtT env (ForAllTy tv ty) f m = m { tm_forall = tm_forall m |> xtT (extendCME e
xtT env (TyConApp tc tys) f m = m { tm_tc_app = tm_tc_app m |> xtNamed tc
|>> xtList (xtT env) tys f }
xtT _ (LiteralTy l) f m = m { tm_tylit = tm_tylit m |> xtTyLit l f }
fdT :: (a -> b -> b) -> TypeMap a -> b -> b
fdT _ EmptyTM = \z -> z
fdT k m = foldTM k (tm_var m)
......@@ -542,6 +549,31 @@ fdT k m = foldTM k (tm_var m)
. foldTM (foldTM k) (tm_fun m)
. foldTM (foldTM k) (tm_tc_app m)
. foldTM (foldTM k) (tm_forall m)
. foldTyLit k (tm_tylit m)
------------------------
data TyLitMap a
= EmptyTLM
| TLM { tlm_number :: Map.Map Integer a }
emptyTyLitMap :: TyLitMap a
emptyTyLitMap = EmptyTLM
lkTyLit :: TyLit -> TyLitMap a -> Maybe a
lkTyLit l =
case l of
NumberTyLit n -> tlm_number >.> Map.lookup n
xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a
xtTyLit l f m =
case l of
NumberTyLit n -> m { tlm_number = tlm_number m |> Map.alter f n }
foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b
foldTyLit l m x = Map.fold l x (tlm_number m)
\end{code}
......
......@@ -1037,6 +1037,10 @@ instance Binary IfaceType where
put_ bh (IfaceTyConApp tc tys)
= do { putByte bh 21; put_ bh tc; put_ bh tys }
put_ bh (IfaceLiteralTy n)
= do { putByte bh 30; put_ bh n }
get bh = do
h <- getByte bh
case h of
......@@ -1076,8 +1080,21 @@ instance Binary IfaceType where
21 -> do { tc <- get bh; tys <- get bh
; return (IfaceTyConApp tc tys) }
30 -> do n <- get bh
return (IfaceLiteralTy n)
_ -> panic ("get IfaceType " ++ show h)
instance Binary IfaceTyLit where
put_ bh (IfaceNumberTyLit n) = putByte bh 1 >> put_ bh n
get bh =
do tag <- getByte bh
case tag of
1 -> do { n <- get bh
; return (IfaceNumberTyLit n) }
_ -> panic ("get IfaceTyLit " ++ show tag)
instance Binary IfaceTyCon where
-- Int,Char,Bool can't show up here because they can't not be saturated
put_ bh IfaceIntTc = putByte bh 1
......
......@@ -808,6 +808,7 @@ freeNamesIfType (IfaceTyVar _) = emptyNameSet
freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t
freeNamesIfType (IfaceTyConApp tc ts) =
freeNamesIfTc tc &&& fnList freeNamesIfType ts
freeNamesIfType (IfaceLiteralTy _) = emptyNameSet
freeNamesIfType (IfaceForAllTy tv t) =
freeNamesIfTvBndr tv &&& freeNamesIfType t
freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t
......
......@@ -17,6 +17,7 @@ module IfaceType (
IfExtName, IfLclName, IfIPName,
IfaceType(..), IfacePredType, IfaceKind, IfaceTyCon(..), IfaceCoCon(..),
IfaceTyLit(..),
IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion,
ifaceTyConName,
......@@ -83,10 +84,14 @@ data IfaceType -- A kind of universal type, used for types, kinds, and coerci
| IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated
-- Includes newtypes, synonyms, tuples
| IfaceCoConApp IfaceCoCon [IfaceType] -- Always saturated
| IfaceLiteralTy IfaceTyLit
type IfacePredType = IfaceType
type IfaceContext = [IfacePredType]
data IfaceTyLit
= IfaceNumberTyLit Integer
data IfaceTyCon -- Encodes type constructors, kind constructors
-- coercion constructors, the lot
= IfaceTc IfExtName -- The common case
......@@ -241,6 +246,8 @@ ppr_ty :: Int -> IfaceType -> SDoc
ppr_ty _ (IfaceTyVar tyvar) = ppr tyvar
ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys
ppr_ty _ (IfaceLiteralTy n) = ppr_tylit n
ppr_ty ctxt_prec (IfaceCoConApp tc tys)
= maybeParen ctxt_prec tYCON_PREC
(sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys))])
......@@ -302,6 +309,9 @@ ppr_tc :: IfaceTyCon -> SDoc
ppr_tc tc@(IfaceTc ext_nm) = parenSymOcc (getOccName ext_nm) (ppr tc)
ppr_tc tc = ppr tc
ppr_tylit :: IfaceTyLit -> SDoc
ppr_tylit (IfaceNumberTyLit n) = integer n
-------------------
instance Outputable IfaceTyCon where
ppr (IfaceIPTc n) = ppr (IPName n)
......@@ -317,6 +327,9 @@ instance Outputable IfaceCoCon where
ppr IfaceInstCo = ptext (sLit "Inst")
ppr (IfaceNthCo d) = ptext (sLit "Nth:") <> int d
instance Outputable IfaceTyLit where
ppr = ppr_tylit
-------------------
pprIfaceContext :: IfaceContext -> SDoc
-- Prints "(C a, D b) =>", including the arrow
......@@ -362,6 +375,7 @@ toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyVar tv)
toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2)
toIfaceType (FunTy t1 t2) = IfaceFunTy (toIfaceType t1) (toIfaceType t2)
toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys)
toIfaceType (LiteralTy n) = IfaceLiteralTy (toIfaceTyLit n)
toIfaceType (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t)
toIfaceTyVar :: TyVar -> FastString
......@@ -402,6 +416,9 @@ toIfaceWiredInTyCon tc nm
| nm == tySuperKindTyConName = IfaceSuperKindTc
| otherwise = IfaceTc nm
toIfaceTyLit :: TyLit -> IfaceTyLit
toIfaceTyLit (NumberTyLit x) = IfaceNumberTyLit x
----------------
toIfaceTypes :: [Type] -> [IfaceType]
toIfaceTypes ts = map toIfaceType ts
......
......@@ -815,6 +815,7 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
tcIfaceType :: IfaceType -> IfL Type
tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
tcIfaceType (IfaceLiteralTy l) = do { l1 <- tcIfaceTyLit l; return (LiteralTy l1) }
tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') }
tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
......@@ -826,6 +827,10 @@ tcIfaceTypes tys = mapM tcIfaceType tys
-----------------------------------------
tcIfaceCtxt :: IfaceContext -> IfL ThetaType
tcIfaceCtxt sts = mapM tcIfaceType sts
-----------------------------------------
tcIfaceTyLit :: IfaceTyLit -> IfL TyLit
tcIfaceTyLit (IfaceNumberTyLit n) = return (NumberTyLit n)
\end{code}
%************************************************************************
......@@ -840,6 +845,7 @@ tcIfaceCo (IfaceTyVar n) = mkCoVarCo <$> tcIfaceCoVar n
tcIfaceCo (IfaceAppTy t1 t2) = mkAppCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
tcIfaceCo (IfaceFunTy t1 t2) = mkFunCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
tcIfaceCo (IfaceTyConApp tc ts) = mkTyConAppCo <$> tcIfaceTyCon tc <*> mapM tcIfaceCo ts
tcIfaceCo t@(IfaceLiteralTy _) = mkReflCo <$> tcIfaceType t
tcIfaceCo (IfaceCoConApp tc ts) = tcIfaceCoApp tc ts
tcIfaceCo (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' ->
mkForAllCo tv' <$> tcIfaceCo t
......
......@@ -38,6 +38,7 @@ module TysPrim(
anyKind, liftedTypeKind, unliftedTypeKind, openTypeKind,
argTypeKind, ubxTupleKind, constraintKind,
mkArrowKind, mkArrowKinds,
typeNatKind,
funTyCon, funTyConName,
primTyCons,
......@@ -341,6 +342,11 @@ argTypeKind = kindTyConType argTypeKindTyCon
ubxTupleKind = kindTyConType ubxTupleKindTyCon
constraintKind = kindTyConType constraintKindTyCon
-- XXX: we should probably be using a different type than Word here...
typeNatKind :: Kind
typeNatKind = kindTyConType (mkKindTyCon wordTyConName tySuperKind)
-- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@
mkArrowKind :: Kind -> Kind -> Kind
mkArrowKind k1 k2 = FunTy k1 k2
......
......@@ -262,6 +262,7 @@ liftTcCoSubstWith tvs cos ty
Nothing -> mkTcReflCo ty
go (AppTy t1 t2) = mkTcAppCo (go t1) (go t2)
go (TyConApp tc tys) = mkTcTyConAppCo tc (map go tys)
go ty@(LiteralTy _) = mkTcReflCo ty
go (ForAllTy tv ty) = mkTcForAllCo tv (go ty)
go (FunTy t1 t2) = mkTcFunCo (go t1) (go t2)
\end{code}
......
......@@ -169,6 +169,9 @@ normaliseFfiType' env ty0 = go [] ty0
go _ ty@(TyVarTy _)
= return (Refl ty, ty)
go _ ty@(LiteralTy _)
= return (Refl ty, ty)
add_co co rec_nts ty
= do (co', ty') <- go rec_nts ty
return (mkTransCo co co', ty')
......
......@@ -525,8 +525,7 @@ kc_hs_type ty@(HsExplicitTupleTy _ tys) exp_kind = do
return (HsExplicitTupleTy (map snd ty_k_s) (map fst ty_k_s))
kc_hs_type ty@(HsNumberTy n) exp_kind = do
-- XXX: Temporarily we use the Word type lifted to the kind level.
checkExpectedKind ty wordTy exp_kind
checkExpectedKind ty typeNatKind exp_kind
return (HsNumberTy n)
kc_hs_type (HsWrapTy {}) _exp_kind =
......@@ -764,8 +763,7 @@ ds_type (HsExplicitTupleTy kis tys) = do
tys' <- mapM dsHsType tys
return $ mkTyConApp (buildPromotedDataTyCon (tupleCon BoxedTuple (length kis'))) (kis' ++ tys')
ds_type (HsNumberTy n) =
failWithTc (ptext (sLit "ds_type: NumberTy not yet implemenetd"))
ds_type (HsNumberTy n) = return (mkNumberTy n)
ds_type (HsWrapTy (WpKiApps kappas) ty) = do
tau <- ds_type ty
......
......@@ -811,6 +811,8 @@ zonkType zonk_tc_tyvar ty
go (TyConApp tc tys) = do tys' <- mapM go tys
return (TyConApp tc tys')
go (LiteralTy n) = return (LiteralTy n)
go (FunTy arg res) = do arg' <- go arg
res' <- go res
return (FunTy arg' res')
......@@ -1079,6 +1081,8 @@ check_type rank ubx_tup ty@(TyConApp tc tys)
arity_msg = arityErr "Type synonym" (tyConName tc) tc_arity n_args
ubx_tup_msg = ubxArgTyErr ty
check_type _ _ (LiteralTy _) = return ()
check_type _ _ ty = pprPanic "check_type" (ppr ty)
----------------------------------------
......@@ -1744,6 +1748,7 @@ fvType :: Type -> [TyVar]
fvType ty | Just exp_ty <- tcView ty = fvType exp_ty
fvType (TyVarTy tv) = [tv]
fvType (TyConApp _ tys) = fvTypes tys
fvType (LiteralTy _) = []
fvType (FunTy arg res) = fvType arg ++ fvType res
fvType (AppTy fun arg) = fvType fun ++ fvType arg
fvType (ForAllTy tyvar ty) = filter (/= tyvar) (fvType ty)
......@@ -1756,6 +1761,7 @@ sizeType :: Type -> Int
sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty
sizeType (TyVarTy _) = 1
sizeType (TyConApp _ tys) = sizeTypes tys + 1
sizeType (LiteralTy _) = 1
sizeType (FunTy arg res) = sizeType arg + sizeType res + 1
sizeType (AppTy fun arg) = sizeType fun + sizeType arg
sizeType (ForAllTy _ ty) = sizeType ty
......
......@@ -1524,6 +1524,7 @@ ty_cts_subst subst inscope fl ty
go' (TyVarTy tv) = tyvar_cts_subst tv `orElse` mkTcReflCo (TyVarTy tv)
go' (AppTy ty1 ty2) = mkTcAppCo (go ty1) (go ty2)
go' (TyConApp tc tys) = mkTcTyConAppCo tc (map go tys)
go' ty@(LiteralTy _) = mkTcReflCo ty
go' (ForAllTy v ty) = mkTcForAllCo v' $! co
where
......
......@@ -896,6 +896,7 @@ floatEqualities skols can_given wantders
| FlatSkol ty <- tcTyVarDetails tv = tvs_under_fsks ty
| otherwise = unitVarSet tv
tvs_under_fsks (TyConApp _ tys) = unionVarSets (map tvs_under_fsks tys)
tvs_under_fsks (LiteralTy _) = emptyVarSet
tvs_under_fsks (FunTy arg res) = tvs_under_fsks arg `unionVarSet` tvs_under_fsks res
tvs_under_fsks (AppTy fun arg) = tvs_under_fsks fun `unionVarSet` tvs_under_fsks arg
tvs_under_fsks (ForAllTy tv ty) -- The kind of a coercion binder
......@@ -1378,4 +1379,4 @@ newFlatWanteds orig theta
CNonCanonical { cc_id = v
, cc_flavor = Wanted loc
, cc_depth = 0 } }
\end{code}
\ No newline at end of file
\end{code}
......@@ -1306,6 +1306,7 @@ reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `T
reifyType ty@(FunTy t1 t2)
| isPredTy t1 = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
| otherwise = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
reifyType (LiteralTy _) = failWith $ ptext $ sLit "Type-level literal canont be reifyed yet."
reify_for_all :: TypeRep.Type -> TcM TH.Type
reify_for_all ty
......
......@@ -238,6 +238,7 @@ calcClassCycles cls
= flip (foldr (expandType seen path)) tys
expandType _ _ (TyVarTy _) = id
expandType _ _ (LiteralTy _) = id
expandType seen path (AppTy t1 t2) = expandType seen path t1 . expandType seen path t2
expandType seen path (FunTy t1 t2) = expandType seen path t1 . expandType seen path t2
expandType seen path (ForAllTy _tv t) = expandType seen path t
......@@ -473,6 +474,7 @@ tcTyConsOfType ty
go :: Type -> NameEnv TyCon -- The NameEnv does duplicate elim
go ty | Just ty' <- tcView ty = go ty'
go (TyVarTy _) = emptyNameEnv
go (LiteralTy _) = emptyNameEnv
go (TyConApp tc tys) = go_tc tc tys
go (AppTy a b) = go a `plusNameEnv` go b
go (FunTy a b) = go a `plusNameEnv` go b
......
......@@ -172,7 +172,9 @@ import TyCon
-- others:
import DynFlags
import Name hiding (varName)
import Name -- hiding (varName)
-- We use this to make dictionaries for type literals.
-- Perhaps there's a better way to do this?
import NameSet
import VarEnv
import PrelNames
......@@ -183,7 +185,6 @@ import Maybes
import ListSetOps
import Outputable
import FastString
import Data.List( mapAccumL )
import Data.IORef
\end{code}
......@@ -499,6 +500,7 @@ tidyType env@(_, subst) ty
Just tv' -> expand tv'
go (TyConApp tycon tys) = let args = map go tys
in args `seqList` TyConApp tycon args
go (LiteralTy n) = LiteralTy n
go (AppTy fun arg) = (AppTy $! (go fun)) $! (go arg)
go (FunTy fun arg) = (FunTy $! (go fun)) $! (go arg)
go (ForAllTy tv ty) = ForAllTy tvp $! (tidyType envp ty)
......@@ -592,6 +594,7 @@ tcTyFamInsts (TyVarTy _) = []
tcTyFamInsts (TyConApp tc tys)
| isSynFamilyTyCon tc = [(tc, tys)]
| otherwise = concat (map tcTyFamInsts tys)
tcTyFamInsts (LiteralTy _) = []
tcTyFamInsts (FunTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2
tcTyFamInsts (AppTy ty1 ty2) = tcTyFamInsts ty1 ++ tcTyFamInsts ty2
tcTyFamInsts (ForAllTy _ ty) = tcTyFamInsts ty
......@@ -641,6 +644,7 @@ exactTyVarsOfType ty
go ty | Just ty' <- tcView ty = go ty' -- This is the key line
go (TyVarTy tv) = unitVarSet tv
go (TyConApp _ tys) = exactTyVarsOfTypes tys
go (LiteralTy _) = emptyVarSet
go (FunTy arg res) = go arg `unionVarSet` go res
go (AppTy fun arg) = go fun `unionVarSet` go arg
go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar
......@@ -776,9 +780,13 @@ getDFunTyKey :: Type -> OccName -- Get some string from a type, to be used to
getDFunTyKey ty | Just ty' <- tcView ty = getDFunTyKey ty'
getDFunTyKey (TyVarTy tv) = getOccName tv
getDFunTyKey (TyConApp tc _) = getOccName tc
getDFunTyKey (LiteralTy x) = getDFunTyLitKey x
getDFunTyKey (AppTy fun _) = getDFunTyKey fun
getDFunTyKey (FunTy _ _) = getOccName funTyCon
getDFunTyKey (ForAllTy _ t) = getDFunTyKey t
getDFunTyLitKey :: TyLit -> OccName
getDFunTyLitKey (NumberTyLit n) = mkOccName Name.varName (show n)
\end{code}
......@@ -1168,6 +1176,7 @@ tcTyVarsOfType :: Type -> TcTyVarSet
tcTyVarsOfType (TyVarTy tv) = if isTcTyVar tv then unitVarSet tv
else emptyVarSet
tcTyVarsOfType (TyConApp _ tys) = tcTyVarsOfTypes tys
tcTyVarsOfType (LiteralTy _) = emptyVarSet
tcTyVarsOfType (FunTy arg res) = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res
tcTyVarsOfType (AppTy fun arg) = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg
tcTyVarsOfType (ForAllTy tyvar ty) = tcTyVarsOfType ty `delVarSet` tyvar
......@@ -1192,6 +1201,7 @@ orphNamesOfType ty | Just ty' <- tcView ty = orphNamesOfType ty'
orphNamesOfType (TyVarTy _) = emptyNameSet
orphNamesOfType (TyConApp tycon tys) = orphNamesOfTyCon tycon
`unionNameSets` orphNamesOfTypes tys
orphNamesOfType (LiteralTy _) = emptyNameSet
orphNamesOfType (FunTy arg res) = orphNamesOfType arg `unionNameSets` orphNamesOfType res
orphNamesOfType (AppTy fun arg) = orphNamesOfType fun `unionNameSets` orphNamesOfType arg
orphNamesOfType (ForAllTy _ ty) = orphNamesOfType ty
......
......@@ -615,7 +615,11 @@ uType_np origin orig_ty1 orig_ty2
| tc1 == tc2 -- See Note [TyCon app]
= do { cos <- uList origin uType tys1 tys2
; return $ mkTcTyConAppCo tc1 cos }
go (LiteralTy m) ty@(LiteralTy n)
| m == n
= return $ mkTcReflCo ty
-- See Note [Care with type applications]
go (AppTy s1 t1) ty2
| Just (s2,t2) <- tcSplitAppTy_maybe ty2
......@@ -912,6 +916,7 @@ checkTauTvUpdate tv ty
= Just (TyConApp tc tys')
| isSynTyCon tc, Just ty_expanded <- tcView this_ty
= ok ty_expanded -- See Note [Type synonyms and the occur check]
ok ty@(LiteralTy _) = Just ty
ok (FunTy arg res) | Just arg' <- ok arg, Just res' <- ok res
= Just (FunTy arg' res')
ok (AppTy fun arg) | Just fun' <- ok fun, Just arg' <- ok arg
......
......@@ -919,6 +919,7 @@ ty_co_subst subst ty
go (ForAllTy v ty) = mkForAllCo v' $! (ty_co_subst subst' ty)
where
(subst', v') = liftCoSubstTyVarBndr subst v
go ty@(LiteralTy _) = mkReflCo ty
liftCoSubstTyVar :: LiftCoSubst -> TyVar -> Maybe Coercion
liftCoSubstTyVar (LCS _ cenv) tv = lookupVarEnv cenv tv
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment