use putStrLn for printing messages and some minor adjustemnts
This commit is contained in:
parent
345942b3be
commit
53c2fa9c92
5 changed files with 22 additions and 14 deletions
|
@ -46,7 +46,7 @@ pickPhysicalDevice vkInstance = do
|
||||||
discretePhysDevices
|
discretePhysDevices
|
||||||
|
|
||||||
liftIO $ do
|
liftIO $ do
|
||||||
print ("picked the following device:" :: String)
|
putStrLn "picked the following device:"
|
||||||
print (Vk.deviceName props)
|
print (Vk.deviceName props)
|
||||||
|
|
||||||
return maxMemdiscretePhysDevice
|
return maxMemdiscretePhysDevice
|
||||||
|
@ -57,6 +57,13 @@ createLogicalDevice
|
||||||
-> Vk.SurfaceKHR
|
-> Vk.SurfaceKHR
|
||||||
-> m (Vk.Device, V.Vector Vk.SurfaceFormatKHR)
|
-> m (Vk.Device, V.Vector Vk.SurfaceFormatKHR)
|
||||||
createLogicalDevice physDevice surface = do
|
createLogicalDevice physDevice surface = do
|
||||||
|
|
||||||
|
queueFamiliyProperties <- Vk.getPhysicalDeviceQueueFamilyProperties physDevice
|
||||||
|
|
||||||
|
liftIO $ do
|
||||||
|
putStrLn "There are currently following queue families available"
|
||||||
|
print queueFamiliyProperties
|
||||||
|
|
||||||
let priorities = V.singleton 1
|
let priorities = V.singleton 1
|
||||||
extensionNames = V.singleton Vk.KHR_SWAPCHAIN_EXTENSION_NAME
|
extensionNames = V.singleton Vk.KHR_SWAPCHAIN_EXTENSION_NAME
|
||||||
queueCreateInfo = Vk.zero
|
queueCreateInfo = Vk.zero
|
||||||
|
@ -71,7 +78,7 @@ createLogicalDevice physDevice surface = do
|
||||||
(_, logDevice) <- allocate
|
(_, logDevice) <- allocate
|
||||||
(Vk.createDevice physDevice deviceCreateInfo Nothing)
|
(Vk.createDevice physDevice deviceCreateInfo Nothing)
|
||||||
(\logDevice -> do
|
(\logDevice -> do
|
||||||
print ("destroying logical device" :: String)
|
putStrLn "destroying logical device"
|
||||||
Vk.destroyDevice logDevice Nothing
|
Vk.destroyDevice logDevice Nothing
|
||||||
)
|
)
|
||||||
|
|
||||||
|
@ -91,7 +98,7 @@ createSwapchain
|
||||||
createSwapchain surface surfaceFormats windowDimension logicalDevice = do
|
createSwapchain surface surfaceFormats windowDimension logicalDevice = do
|
||||||
|
|
||||||
liftIO $ do
|
liftIO $ do
|
||||||
print ("available formats:" :: String)
|
putStrLn "available formats:"
|
||||||
print surfaceFormats
|
print surfaceFormats
|
||||||
|
|
||||||
(surfaceFormat, colorSpace) <-
|
(surfaceFormat, colorSpace) <-
|
||||||
|
@ -109,7 +116,7 @@ createSwapchain surface surfaceFormats windowDimension logicalDevice = do
|
||||||
error ("createSwapchain: No suitable surface formats available" :: String)
|
error ("createSwapchain: No suitable surface formats available" :: String)
|
||||||
|
|
||||||
liftIO $ do
|
liftIO $ do
|
||||||
print ("picking following format and color space:" :: String)
|
putStrLn "picking following format and color space:"
|
||||||
print (surfaceFormat, colorSpace)
|
print (surfaceFormat, colorSpace)
|
||||||
|
|
||||||
let createInfo = Vk.zero
|
let createInfo = Vk.zero
|
||||||
|
@ -130,7 +137,7 @@ createSwapchain surface surfaceFormats windowDimension logicalDevice = do
|
||||||
swapchain <- snd <$> allocate
|
swapchain <- snd <$> allocate
|
||||||
(Vk.createSwapchainKHR logicalDevice createInfo Nothing)
|
(Vk.createSwapchainKHR logicalDevice createInfo Nothing)
|
||||||
(\swapchain -> do
|
(\swapchain -> do
|
||||||
print ("destroying swapchain" :: String)
|
putStrLn "destroying swapchain"
|
||||||
Vk.destroySwapchainKHR logicalDevice swapchain Nothing
|
Vk.destroySwapchainKHR logicalDevice swapchain Nothing
|
||||||
)
|
)
|
||||||
|
|
||||||
|
@ -170,7 +177,7 @@ getImageViewHandles swapchain surfaceFormat logicalDevice = do
|
||||||
snd <$> allocate
|
snd <$> allocate
|
||||||
(Vk.createImageView logicalDevice createInfo Nothing)
|
(Vk.createImageView logicalDevice createInfo Nothing)
|
||||||
(\imageView -> do
|
(\imageView -> do
|
||||||
print ("destroying image view" :: String)
|
putStrLn "destroying image view"
|
||||||
Vk.destroyImageView logicalDevice imageView Nothing
|
Vk.destroyImageView logicalDevice imageView Nothing
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
|
|
|
@ -25,7 +25,7 @@ initEngine = do
|
||||||
void $ allocate_
|
void $ allocate_
|
||||||
SDL.initializeAll
|
SDL.initializeAll
|
||||||
(do
|
(do
|
||||||
print ("This is the end!" :: String)
|
putStrLn "This is the end!"
|
||||||
SDL.quit
|
SDL.quit
|
||||||
)
|
)
|
||||||
|
|
||||||
|
@ -42,7 +42,7 @@ initEngine = do
|
||||||
allocate
|
allocate
|
||||||
(SDL.createWindow "Haskell ❤️ Vulkan" windowConfig)
|
(SDL.createWindow "Haskell ❤️ Vulkan" windowConfig)
|
||||||
(\window -> do
|
(\window -> do
|
||||||
liftIO $ print ("destroying window" :: String)
|
liftIO $ putStrLn "destroying window"
|
||||||
SDL.destroyWindow window
|
SDL.destroyWindow window
|
||||||
)
|
)
|
||||||
|
|
||||||
|
@ -63,7 +63,7 @@ initVulkan window = do
|
||||||
SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
|
SDL.vkCreateSurface window (castPtr (Vk.instanceHandle vulkanInstance))
|
||||||
)
|
)
|
||||||
(\vulkanSurface -> do
|
(\vulkanSurface -> do
|
||||||
print ("destroying surface" :: String)
|
putStrLn "destroying surface"
|
||||||
Vk.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
|
Vk.destroySurfaceKHR vulkanInstance vulkanSurface Nothing
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
|
@ -17,7 +17,7 @@ createInstance window = do
|
||||||
windowExtensions <- liftIO $ fmap (Vk.EXT_DEBUG_UTILS_EXTENSION_NAME :) $
|
windowExtensions <- liftIO $ fmap (Vk.EXT_DEBUG_UTILS_EXTENSION_NAME :) $
|
||||||
traverse BS.packCString =<< SDL.vkGetInstanceExtensions window
|
traverse BS.packCString =<< SDL.vkGetInstanceExtensions window
|
||||||
liftIO $ do
|
liftIO $ do
|
||||||
print ("activating followinfg extensions:" :: String)
|
putStrLn "activating followinfg extensions:"
|
||||||
print windowExtensions
|
print windowExtensions
|
||||||
let createInfo = Vk.zero
|
let createInfo = Vk.zero
|
||||||
{ Vk.applicationInfo = Just Vk.zero
|
{ Vk.applicationInfo = Just Vk.zero
|
||||||
|
@ -33,7 +33,7 @@ createInstance window = do
|
||||||
(_, inst) <- allocate
|
(_, inst) <- allocate
|
||||||
(Vk.createInstance createInfo Nothing)
|
(Vk.createInstance createInfo Nothing)
|
||||||
(\inst -> do
|
(\inst -> do
|
||||||
print ("destroying instance" :: String)
|
putStrLn "destroying instance"
|
||||||
Vk.destroyInstance inst Nothing
|
Vk.destroyInstance inst Nothing
|
||||||
)
|
)
|
||||||
|
|
||||||
|
|
|
@ -59,7 +59,7 @@ createBufferView logicalDevice = do
|
||||||
buffer <- snd <$> allocate
|
buffer <- snd <$> allocate
|
||||||
(Vk.createBuffer logicalDevice bufferCreateInfo Nothing)
|
(Vk.createBuffer logicalDevice bufferCreateInfo Nothing)
|
||||||
(\buffer -> do
|
(\buffer -> do
|
||||||
print ("destroying buffer" :: String)
|
putStrLn "destroying buffer"
|
||||||
Vk.destroyBuffer logicalDevice buffer Nothing
|
Vk.destroyBuffer logicalDevice buffer Nothing
|
||||||
)
|
)
|
||||||
|
|
||||||
|
@ -73,7 +73,7 @@ createBufferView logicalDevice = do
|
||||||
allocate
|
allocate
|
||||||
(Vk.createBufferView logicalDevice bufferViewCreateInfo Nothing)
|
(Vk.createBufferView logicalDevice bufferViewCreateInfo Nothing)
|
||||||
(\bufferView -> do
|
(\bufferView -> do
|
||||||
print ("destroying bufferView" :: String)
|
putStrLn "destroying bufferView"
|
||||||
Vk.destroyBufferView logicalDevice bufferView Nothing
|
Vk.destroyBufferView logicalDevice bufferView Nothing
|
||||||
)
|
)
|
||||||
|
|
||||||
|
@ -93,6 +93,6 @@ allocateMemory logicalDevice buffer = do
|
||||||
allocate
|
allocate
|
||||||
(Vk.allocateMemory logicalDevice memoryAllocateInfo Nothing)
|
(Vk.allocateMemory logicalDevice memoryAllocateInfo Nothing)
|
||||||
(\memory -> do
|
(\memory -> do
|
||||||
print ("Freeing memory" :: String)
|
putStrLn "Freeing memory"
|
||||||
Vk.freeMemory logicalDevice memory Nothing
|
Vk.freeMemory logicalDevice memory Nothing
|
||||||
)
|
)
|
||||||
|
|
|
@ -18,6 +18,7 @@ maintainer: nek0@nek0.eu
|
||||||
-- copyright:
|
-- copyright:
|
||||||
category: Game
|
category: Game
|
||||||
extra-source-files: CHANGELOG.md
|
extra-source-files: CHANGELOG.md
|
||||||
|
, shadersrc/*
|
||||||
|
|
||||||
executable vulkan-tutorial
|
executable vulkan-tutorial
|
||||||
main-is: Main.hs
|
main-is: Main.hs
|
||||||
|
|
Loading…
Reference in a new issue