module Vectorise.Type.Type
( vectTyCon
, vectAndLiftType
, vectType
)
where
import GhcPrelude
import Vectorise.Utils
import Vectorise.Monad
import Vectorise.Builtins
import TcType
import Type
import TyCoRep
import TyCon
import Control.Monad
import Data.Maybe
import Outputable
vectTyCon :: TyCon -> VM TyCon
vectTyCon tc = maybe tc id <$> lookupTyCon tc
vectAndLiftType :: Type -> VM (Type, Type)
vectAndLiftType ty | Just ty' <- coreView ty = vectAndLiftType ty'
vectAndLiftType ty
= do { padicts <- liftM catMaybes $ mapM paDictArgType tyvars
; vmono_ty <- vectType mono_ty
; lmono_ty <- mkPDataType vmono_ty
; return (abstractType tyvars (padicts ++ theta) vmono_ty,
abstractType tyvars (padicts ++ theta) lmono_ty)
}
where
(tyvars, phiTy) = splitForAllTys ty
(theta, mono_ty) = tcSplitPhiTy phiTy
vectType :: Type -> VM Type
vectType ty
| Just ty' <- coreView ty
= vectType ty'
vectType (TyVarTy tv) = return $ TyVarTy tv
vectType (LitTy l) = return $ LitTy l
vectType (AppTy ty1 ty2) = AppTy <$> vectType ty1 <*> vectType ty2
vectType (TyConApp tc tys) = TyConApp <$> vectTyCon tc <*> mapM vectType tys
vectType (FunTy ty1 ty2)
| isPredTy ty1
= mkFunTy <$> vectType ty1 <*> vectType ty2
| otherwise
= TyConApp <$> builtin closureTyCon <*> mapM vectType [ty1, ty2]
vectType ty@(ForAllTy {})
= do {
; let (tyvars, tyBody) = splitForAllTys ty
; vtyBody <- vectType tyBody
; dictsPA <- liftM catMaybes $ mapM paDictArgType tyvars
; return $ abstractType tyvars dictsPA vtyBody
}
vectType ty@(CastTy {})
= pprSorry "Vectorise.Type.Type.vectType: CastTy" (ppr ty)
vectType ty@(CoercionTy {})
= pprSorry "Vectorise.Type.Type.vectType: CoercionTy" (ppr ty)
abstractType :: [TyVar] -> [Type] -> Type -> Type
abstractType tyvars dicts = mkInvForAllTys tyvars . mkFunTys dicts