AppTy fun _ -> getTyDescription fun
FunTy _ res -> '-' : '>' : fun_result res
TyConApp tycon _ -> getOccString tycon
- NoteTy (FTVNote _) ty -> getTyDescription ty
PredTy sty -> getPredTyDescription sty
ForAllTy _ ty -> getTyDescription ty
}
-- Maybe CoreTidy should know whether to expand newtypes or not?
make_ty (PredTy p) = make_ty (predTypeRep p)
-make_ty (NoteTy _ t) = make_ty t
IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t)
toIfaceType (PredTy st) =
IfacePredTy (toIfacePred st)
-toIfaceType (NoteTy other_note ty) =
- toIfaceType ty
----------------
-- A little bit of (perhaps optional) trickiness here. When
importsType2 env (TyConApp tc args) =importsTyCon env tc . importsTypeArgs2 env args
importsType2 env (FunTy arg res) = importsType env arg . importsType2 env res
importsType2 env (ForAllTy tv body_ty) = importsType2 env body_ty
-importsType2 env (NoteTy _ ty) = importsType2 env ty
importsType2 _ _ = panic "IlxGen.lhs: importsType2 ty"
importsTypeArgs2 env tys = foldR (importsType2 env) tys
importsTyConDataConType2 env (TyConApp tc args) = importsTyConDataConTypeTyCon env tc . importsTyConDataConTypeArgs2 env args
importsTyConDataConType2 env (FunTy arg res) = importsTyConDataConType env arg . importsTyConDataConType2 env res
importsTyConDataConType2 env (ForAllTy tv body_ty) = importsTyConDataConType2 env body_ty
-importsTyConDataConType2 env (NoteTy _ ty) = importsTyConDataConType2 env ty
importsTyConDataConType2 _ _ = panic "IlxGen.lhs: importsTyConDataConType2 ty"
importsTyConDataConTypeArgs2 env tys = foldR (importsTyConDataConType2 env) tys
-- This part strips off at most "max" term applications or one type application
get_type_args 0 args env funty = ([],[],env,args,funty)
- get_type_args max args env (NoteTy _ ty) =
- trace "IlxGen Internal Error: non representation type passed to get_args" (get_type_args max args env ty)
get_type_args max ((arg@(StgTypeArg v)):rest) env (ForAllTy tv rem_funty)
= if isIlxTyVar tv then
let env2 = extendIlxEnvWithFormalTyVars env [tv] in
get_type_args _ (StgTypeArg _:_) _ _ = trace "IlxGen Internal Error: get_type_args could not get ForAllTy for corresponding arg" ([],[],env,[],funty)
get_type_args _ args env funty = ([],[],env,args,funty)
- get_term_args n max args env (NoteTy _ ty)
- -- Skip NoteTy types
- = trace "IlxGen Internal Error: non representation type passed to get_term_args" (get_term_args n max args env ty)
get_term_args n 0 args env funty
-- Stop if we've hit the maximum number of ILX arguments to apply n one hit.
= ([],[],env,args,funty)
\begin{code}
-isVoidIlxRepType (NoteTy _ ty) = isVoidIlxRepType ty
isVoidIlxRepType (TyConApp tc _) | (tyConPrimRep tc == VoidRep) = True
isVoidIlxRepType (TyConApp tc tys)
= isUnboxedTupleTyCon tc && null (filter (not. isVoidIlxRepType) tys)
--- Get rid of all NoteTy and NewTy artifacts
+-- Get rid of all NewTy artifacts
deepIlxRepType :: Type -> Type
deepIlxRepType (FunTy l r)
= FunTy (deepIlxRepType l) (deepIlxRepType r)
TyConApp tc (map deepIlxRepType tys)
deepIlxRepType (AppTy f x) = AppTy (deepIlxRepType f) (deepIlxRepType x)
deepIlxRepType (ForAllTy b ty) = ForAllTy b (deepIlxRepType ty)
-deepIlxRepType (NoteTy _ ty) = deepIlxRepType ty
deepIlxRepType (PredTy p) = deepIlxRepType (predTypeRep p)
deepIlxRepType ty@(TyVarTy tv) = ty
= ilxComment (text "higher order type var " <+> pprId tv) <+>
pprIlxFunTy (text "class [mscorlib]System.Object") (ilxTypeR env body_ty)
-ilxTypeR env (NoteTy _ ty)
- = trace "WARNING! non-representation type given to ilxTypeR: see generated ILX for context where this occurs"
- (vcat [text "/* WARNING! non-representation type given to ilxTypeR! */",
- ilxTypeR env ty ])
-
pprIlxFunTy dom ran = parens (hsep [text "func",parens dom,text "-->", ran])
ilxTyConApp env tcon args =
| isSynTyCon tc = go_syn tc tys
| otherwise = do { tys' <- mapM go tys
; return $ occurs (TyConApp tc) tys' }
- go (NoteTy _ ty2) = go ty2 -- Discard free-tyvar annotations
go (PredTy p) = do { p' <- go_pred p
; return $ occurs1 PredTy p' }
go (FunTy arg res) = do { arg' <- go arg
zonkType unbound_var_fn ty
= go ty
where
- go (NoteTy _ ty2) = go ty2 -- Discard free-tyvar annotations
-
go (TyConApp tc tys) = do tys' <- mapM go tys
return (TyConApp tc tys')
= do { check_arg_type rank ty1
; check_arg_type rank ty2 }
-check_type rank ubx_tup (NoteTy other_note ty)
- = check_type rank ubx_tup ty
-
check_type rank ubx_tup ty@(TyConApp tc tys)
| isSynTyCon tc
= do { -- Check that the synonym has enough args
fvType ty | Just exp_ty <- tcView ty = fvType exp_ty
fvType (TyVarTy tv) = [tv]
fvType (TyConApp _ tys) = fvTypes tys
-fvType (NoteTy _ ty) = fvType ty
fvType (PredTy pred) = fvPred pred
fvType (FunTy arg res) = fvType arg ++ fvType res
fvType (AppTy fun arg) = fvType fun ++ fvType arg
sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty
sizeType (TyVarTy _) = 1
sizeType (TyConApp _ tys) = sizeTypes tys + 1
-sizeType (NoteTy _ ty) = sizeType ty
sizeType (PredTy pred) = sizePred pred
sizeType (FunTy arg res) = sizeType arg + sizeType res + 1
sizeType (AppTy fun arg) = sizeType fun + sizeType arg
reifyType :: TypeRep.Type -> TcM TH.Type
reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys
-reifyType (NoteTy _ ty) = reifyType ty
reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt;
go (FunTy a b) = go a `plusNameEnv` go b
go (PredTy (IParam _ ty)) = go ty
go (PredTy (ClassP cls tys)) = go_s tys -- Ignore class
- go (NoteTy _ ty) = go ty
go (ForAllTy _ ty) = go ty
go_tc tc tys | isSynTyCon tc = extendNameEnv (go_s tys) (tyConName tc) tc
= do { (coi,nty1) <- tcGenericNormaliseFamInst fun ty1
; return (mkForAllTyCoI tyvar coi, mkForAllTy tyvar nty1)
}
-tcGenericNormaliseFamInst fun (NoteTy note ty1)
- = do { (coi,nty1) <- tcGenericNormaliseFamInst fun ty1
- ; return (coi, NoteTy note nty1)
- }
tcGenericNormaliseFamInst fun ty@(TyVarTy tv)
| isTcTyVar tv
= do { traceTc (text "tcGenericNormaliseFamInst" <+> ppr ty)
-- are transparent, so we need a special function here
tcInstHeadTyNotSynonym ty
= case ty of
- NoteTy _ ty -> tcInstHeadTyNotSynonym ty
TyConApp tc tys -> not (isSynTyCon tc)
_ -> True
-- These must be a constructor applied to type variable arguments
tcInstHeadTyAppAllTyVars ty
= case ty of
- NoteTy _ ty -> tcInstHeadTyAppAllTyVars ty
TyConApp _ tys -> ok tys
FunTy arg res -> ok [arg, res]
other -> False
where
tvs = mapCatMaybes get_tv tys
- get_tv (NoteTy _ ty) = get_tv ty -- Again, do not look
get_tv (TyVarTy tv) = Just tv -- through synonyms
get_tv other = Nothing
\end{code}
tcTyVarsOfType (TyVarTy tv) = if isTcTyVar tv then unitVarSet tv
else emptyVarSet
tcTyVarsOfType (TyConApp tycon tys) = tcTyVarsOfTypes tys
-tcTyVarsOfType (NoteTy _ ty) = tcTyVarsOfType ty
tcTyVarsOfType (PredTy sty) = tcTyVarsOfPred sty
tcTyVarsOfType (FunTy arg res) = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res
tcTyVarsOfType (AppTy fun arg) = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg
go (AppTy fun arg) = go fun `unionVarSet` go arg
go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar
`unionVarSet` go_tv tyvar
- go (NoteTy _ _) = panic "exactTyVarsOfType" -- Handled by tcView
go_pred (IParam _ ty) = go ty
go_pred (ClassP _ tys) = exactTyVarsOfTypes tys
tyClsNamesOfType :: Type -> NameSet
tyClsNamesOfType (TyVarTy tv) = emptyNameSet
tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys
-tyClsNamesOfType (NoteTy _ ty2) = tyClsNamesOfType ty2
tyClsNamesOfType (PredTy (IParam n ty)) = tyClsNamesOfType ty
tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys
tyClsNamesOfType (PredTy (EqPred ty1 ty2)) = tyClsNamesOfType ty1 `unionNameSets` tyClsNamesOfType ty2
--
-- For once, it's safe to treat synonyms as opaque!
-unBox (NoteTy n ty) = do { ty' <- unBox ty; return (NoteTy n ty') }
unBox (TyConApp tc tys) = do { tys' <- mapM unBox tys; return (TyConApp tc tys') }
unBox (AppTy f a) = do { f' <- unBox f; a' <- unBox a; return (mkAppTy f' a') }
unBox (FunTy f a) = do { f' <- unBox f; a' <- unBox a; return (FunTy f' a') }
isIdentityCoercion,
mkSymCoI, mkTransCoI,
mkTyConAppCoI, mkAppTyCoI, mkFunTyCoI,
- mkNoteTyCoI, mkForAllTyCoI,
+ mkForAllTyCoI,
fromCoI, fromACo,
mkClassPPredCoI, mkIParamPredCoI, mkEqPredCoI
coercionKind (ForAllTy tv ty)
= let (ty1, ty2) = coercionKind ty in
(ForAllTy tv ty1, ForAllTy tv ty2)
-coercionKind (NoteTy _ ty) = coercionKind ty
coercionKind (PredTy (EqPred c1 c2))
= let k1 = coercionKindPredTy c1
k2 = coercionKindPredTy c2 in
mkFunTyCoI ty1 coi1 ty2 coi2 =
ACo $ FunTy (fromCoI coi1 ty1) (fromCoI coi2 ty2)
-mkNoteTyCoI :: TyNote -> CoercionI -> CoercionI
-mkNoteTyCoI _ IdCo = IdCo
-mkNoteTyCoI note (ACo co) = ACo $ NoteTy note co
-
mkForAllTyCoI :: TyVar -> CoercionI -> CoercionI
mkForAllTyCoI _ IdCo = IdCo
mkForAllTyCoI tv (ACo co) = ACo $ ForAllTy tv co
normaliseType env (ForAllTy tyvar ty1)
= let (coi,nty1) = normaliseType env ty1
in (mkForAllTyCoI tyvar coi,ForAllTy tyvar nty1)
-normaliseType env (NoteTy note ty1)
- = let (coi,nty1) = normaliseType env ty1
- in (coi,NoteTy note nty1)
normaliseType _ ty@(TyVarTy _)
= (IdCo,ty)
normaliseType env (PredTy predty)
import StaticFlags
import Util
import Outputable
-import UniqSet
import Data.List
import Data.Maybe ( isJust )
-- By being non-recursive and inlined, this case analysis gets efficiently
-- joined onto the case analysis that the caller is already doing
-coreView (NoteTy _ ty) = Just ty
coreView (PredTy p)
| isEqPred p = Nothing
| otherwise = Just (predTypeRep p)
{-# INLINE tcView #-}
tcView :: Type -> Maybe Type
-- Same, but for the type checker, which just looks through synonyms
-tcView (NoteTy _ ty) = Just ty
tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- tcExpandTyCon_maybe tc tys
= Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys')
tcView _ = Nothing
rttiView :: Type -> Type
-- Same, but for the RTTI system, which cannot deal with predicates nor polymorphism
rttiView (ForAllTy _ ty) = rttiView ty
-rttiView (NoteTy _ ty) = rttiView ty
rttiView (FunTy PredTy{} ty) = rttiView ty
-rttiView (FunTy NoteTy{} ty) = rttiView ty
rttiView ty@TyConApp{} | Just ty' <- coreView ty
= rttiView ty'
rttiView (TyConApp tc tys) = mkTyConApp tc (map rttiView tys)
kindView :: Kind -> Maybe Kind
-- C.f. coreView, tcView
-- For the moment, we don't even handle synonyms in kinds
-kindView (NoteTy _ k) = Just k
kindView _ = Nothing
\end{code}
mkAppTy orig_ty1 orig_ty2
= mk_app orig_ty1
where
- mk_app (NoteTy _ ty1) = mk_app ty1
mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ [orig_ty2])
mk_app _ = AppTy orig_ty1 orig_ty2
-- Note that the TyConApp could be an
mkAppTys orig_ty1 orig_tys2
= mk_app orig_ty1
where
- mk_app (NoteTy _ ty1) = mk_app ty1
mk_app (TyConApp tc tys) = mkTyConApp tc (tys ++ orig_tys2)
-- mkTyConApp: see notes with mkAppTy
mk_app _ = foldl AppTy orig_ty1 orig_tys2
mkForAllTys tyvars ty = foldr ForAllTy ty tyvars
isForAllTy :: Type -> Bool
-isForAllTy (NoteTy _ ty) = isForAllTy ty
isForAllTy (ForAllTy _ _) = True
isForAllTy _ = False
-- We should be looking for the coercion kind,
-- not the type kind
foldr (\_ k -> kindFunResult k) (tyConKind tycon) tys
-typeKind (NoteTy _ ty) = typeKind ty
typeKind (PredTy pred) = predKind pred
typeKind (AppTy fun _) = kindFunResult (typeKind fun)
typeKind (ForAllTy _ ty) = typeKind ty
-- NB: for type synonyms tyVarsOfType does *not* expand the synonym
tyVarsOfType (TyVarTy tv) = unitVarSet tv
tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys
-tyVarsOfType (NoteTy (FTVNote tvs) _) = tvs
tyVarsOfType (PredTy sty) = tyVarsOfPred sty
tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res
tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg
Just tv' -> TyVarTy tv'
go (TyConApp tycon tys) = let args = map go tys
in args `seqList` TyConApp tycon args
- go (NoteTy note ty) = (NoteTy $! (go_note note)) $! (go ty)
go (PredTy sty) = PredTy (tidyPred env sty)
go (AppTy fun arg) = (AppTy $! (go fun)) $! (go arg)
go (FunTy fun arg) = (FunTy $! (go fun)) $! (go arg)
where
(envp, tvp) = tidyTyVarBndr env tv
- go_note note@(FTVNote _ftvs) = note -- No need to tidy the free tyvars
-
tidyTypes :: TidyEnv -> [Type] -> [Type]
tidyTypes env tys = map (tidyType env) tys
seqType (TyVarTy tv) = tv `seq` ()
seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2
seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2
-seqType (NoteTy note t2) = seqNote note `seq` seqType t2
seqType (PredTy p) = seqPred p
seqType (TyConApp tc tys) = tc `seq` seqTypes tys
seqType (ForAllTy tv ty) = tv `seq` seqType ty
seqTypes [] = ()
seqTypes (ty:tys) = seqType ty `seq` seqTypes tys
-seqNote :: TyNote -> ()
-seqNote (FTVNote set) = sizeUniqSet set `seq` ()
-
seqPred :: PredType -> ()
seqPred (ClassP c tys) = c `seq` seqTypes tys
seqPred (IParam n ty) = n `seq` seqType ty
tcPartOfType t1 (FunTy s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2
tcPartOfType t1 (PredTy p2) = tcPartOfPred t1 p2
tcPartOfType t1 (TyConApp _ ts) = any (tcPartOfType t1) ts
-tcPartOfType t1 (NoteTy _ t2) = tcPartOfType t1 t2
tcPartOfPred :: Type -> PredType -> Bool
tcPartOfPred t1 (IParam _ t2) = tcPartOfType t1 t2
cmpTypeX env (FunTy s1 t1) (FunTy s2 t2) = cmpTypeX env s1 s2 `thenCmp` cmpTypeX env t1 t2
cmpTypeX env (PredTy p1) (PredTy p2) = cmpPredX env p1 p2
cmpTypeX env (TyConApp tc1 tys1) (TyConApp tc2 tys2) = (tc1 `compare` tc2) `thenCmp` cmpTypesX env tys1 tys2
-cmpTypeX env t1 (NoteTy _ t2) = cmpTypeX env t1 t2
-- Deal with the rest: TyVarTy < AppTy < FunTy < TyConApp < ForAllTy < PredTy
cmpTypeX _ (AppTy _ _) (TyVarTy _) = GT
go (PredTy p) = PredTy $! (substPred subst p)
- go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard the free tyvar note
-
go (FunTy arg res) = (FunTy $! (go arg)) $! (go res)
go (AppTy fun arg) = mkAppTy (go fun) $! (go arg)
-- The mkAppTy smart constructor is important
\begin{code}
module TypeRep (
TyThing(..),
- Type(..), TyNote(..), -- Representation visible
+ Type(..),
PredType(..), -- to friends
Kind, ThetaType, -- Synonyms
-- friends:
import Var
-import VarSet
import Name
import OccName
import BasicTypes
| AppTy
Type -- Function is *not* a TyConApp
Type -- It must be another AppTy, or TyVarTy
- -- (or NoteTy of these)
| TyConApp -- Application of a TyCon, including newtypes *and* synonyms
TyCon -- *Invariant* saturated appliations of FunTyCon and
-- of a coercion variable; never as the argument or result
-- of a FunTy (unlike ClassP, IParam)
- | NoteTy -- A type with a note attached
- TyNote
- Type -- The expanded version
-
type Kind = Type -- Invariant: a kind is always
-- FunTy k1 k2
-- or TyConApp PrimTyCon [...]
type SuperKind = Type -- Invariant: a super kind is always
-- TyConApp SuperKindTyCon ...
-
-data TyNote = FTVNote TyVarSet -- The free type variables of the noted expression
\end{code}
-------------------------------------
coSuperKind = kindTyConType coSuperKindTyCon
isTySuperKind :: SuperKind -> Bool
-isTySuperKind (NoteTy _ ty) = isTySuperKind ty
isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey
isTySuperKind _ = False
isCoSuperKind :: SuperKind -> Bool
-isCoSuperKind (NoteTy _ ty) = isCoSuperKind ty
isCoSuperKind (TyConApp kc []) = kc `hasKey` coSuperKindTyConKey
isCoSuperKind _ = False
-- All coercions are of form (ty1 ~ ty2)
-- This function is here rather than in Coercion,
-- because it's used in a knot-tied way to enforce invariants in Var
-isCoercionKind (NoteTy _ k) = isCoercionKind k
isCoercionKind (PredTy (EqPred {})) = True
isCoercionKind _ = False
coVarPred tv
= ASSERT( isCoVar tv )
case tyVarKind tv of
- PredTy eq -> eq -- There shouldn't even be a NoteTy in the way
+ PredTy eq -> eq
other -> pprPanic "coVarPred" (ppr tv $$ ppr other)
\end{code}
ppr_type :: Prec -> Type -> SDoc
ppr_type _ (TyVarTy tv) = ppr tv
ppr_type _ (PredTy pred) = ifPprDebug (ptext SLIT("<pred>")) <> (ppr pred)
-ppr_type p (NoteTy _ ty2) = ifPprDebug (ptext SLIT("<note>")) <> ppr_type p ty2
ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys
ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $
-- equality predicates.
split1 tvs (ForAllTy tv ty)
| not (isCoVar tv) = split1 (tv:tvs) ty
- split1 tvs (NoteTy _ ty) = split1 tvs ty
split1 tvs ty = (reverse tvs, ty)
- split2 ps (NoteTy _ arg -- Rather a disgusting case
- `FunTy` res) = split2 ps (arg `FunTy` res)
split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty
split2 ps (ForAllTy tv ty)
| isCoVar tv = split2 (coVarPred tv : ps) ty
- split2 ps (NoteTy _ ty) = split2 ps ty
split2 ps ty = (reverse ps, ty)
ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc
projects / ghc-hetmet.git / commitdiff