+-- ----------------------------------------------------------------------------
+-- Types
+
+paArgType :: Type -> Kind -> VM (Maybe Type)
+paArgType ty k
+ | Just k' <- kindView k = paArgType ty k'
+
+-- Here, we assume that for a kind (k1 -> k2) to be valid, k1 and k2 can only
+-- be made up of * and (->), i.e., they can't be coercion kinds or #.
+paArgType ty (FunTy k1 k2)
+ = do
+ tv <- newTyVar FSLIT("a") k1
+ ty1 <- paArgType' (TyVarTy tv) k1
+ ty2 <- paArgType' (AppTy ty (TyVarTy tv)) k2
+ return . Just $ ForAllTy tv (FunTy ty1 ty2)
+
+paArgType ty k
+ | isLiftedTypeKind k
+ = do
+ tc <- builtin paTyCon
+ return . Just $ TyConApp tc [ty]
+
+ | otherwise
+ = return Nothing
+
+paArgType' :: Type -> Kind -> VM Type
+paArgType' ty k
+ = do
+ r <- paArgType ty k
+ case r of
+ Just ty' -> return ty'
+ Nothing -> pprPanic "paArgType'" (ppr ty)
+
+vectTyCon :: TyCon -> VM TyCon
+vectTyCon tc
+ | isFunTyCon tc = builtin closureTyCon
+ | otherwise = do
+ r <- lookupTyCon tc
+ case r of
+ Just tc' -> return tc'
+
+ -- FIXME: just for now
+ Nothing -> pprTrace "ccTyCon:" (ppr tc) $ return tc
+
+vectType :: Type -> VM Type
+vectType ty | Just ty' <- coreView ty = vectType ty
+vectType (TyVarTy tv) = return $ TyVarTy tv
+vectType (AppTy ty1 ty2) = liftM2 AppTy (vectType ty1) (vectType ty2)
+vectType (TyConApp tc tys) = liftM2 TyConApp (vectTyCon tc) (mapM vectType tys)
+vectType (FunTy ty1 ty2) = liftM2 TyConApp (builtin closureTyCon)
+ (mapM vectType [ty1,ty2])
+vectType (ForAllTy tv ty)
+ = do
+ r <- paArgType (TyVarTy tv) (tyVarKind tv)
+ ty' <- vectType ty
+ return . ForAllTy tv $ case r of { Just paty -> FunTy paty ty'; Nothing -> ty' }
+
+vectType ty = pprPanic "vectType:" (ppr ty)
+