gpu-vulkan-khr-surface-glfw (empty) → 0.1.0.0
raw patch · 7 files changed
+172/−0 lines, 7 filesdep +basedep +containersdep +glfw-groupsetup-changed
Dependencies added: base, containers, glfw-group, gpu-vulkan, gpu-vulkan-khr-surface, gpu-vulkan-khr-surface-glfw, gpu-vulkan-middle-khr-surface, gpu-vulkan-middle-khr-surface-glfw, stm, typelevel-tools-yj
Files
- CHANGELOG.md +11/−0
- LICENSE +26/−0
- README.md +1/−0
- Setup.hs +2/−0
- gpu-vulkan-khr-surface-glfw.cabal +71/−0
- src/Gpu/Vulkan/Khr/Surface/Glfw/Window.hs +59/−0
- test/Spec.hs +2/−0
+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog for `gpu-vulkan-khr-surface-glfw`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## Unreleased++## 0.1.0.0 - YYYY-MM-DD
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright 2025 Yoshikuni Jujo++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,1 @@+# gpu-vulkan-khr-surface-glfw
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ gpu-vulkan-khr-surface-glfw.cabal view
@@ -0,0 +1,71 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.37.0.+--+-- see: https://github.com/sol/hpack++name: gpu-vulkan-khr-surface-glfw+version: 0.1.0.0+synopsis: GLFW surface for Vulkan+description: Please see the README on GitHub at <https://github.com/YoshikuniJujo/gpu-vulkan-khr-surface-glfw#readme>+category: GPU+homepage: https://github.com/YoshikuniJujo/gpu-vulkan-khr-surface-glfw#readme+bug-reports: https://github.com/YoshikuniJujo/gpu-vulkan-khr-surface-glfw/issues+author: Yoshikuni Jujo+maintainer: yoshikuni.jujo@gmail.com+copyright: Copyright (c) 2023 Yoshikuni Jujo+license: BSD-3-Clause+license-file: LICENSE+build-type: Simple+extra-doc-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/YoshikuniJujo/gpu-vulkan-khr-surface-glfw++library+ exposed-modules:+ Gpu.Vulkan.Khr.Surface.Glfw.Window+ other-modules:+ Paths_gpu_vulkan_khr_surface_glfw+ autogen-modules:+ Paths_gpu_vulkan_khr_surface_glfw+ hs-source-dirs:+ src+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+ build-depends:+ base >=4.7 && <5+ , containers <1+ , glfw-group <1+ , gpu-vulkan <1+ , gpu-vulkan-khr-surface <1+ , gpu-vulkan-middle-khr-surface <1+ , gpu-vulkan-middle-khr-surface-glfw <1+ , stm <3+ , typelevel-tools-yj <1+ default-language: Haskell2010++test-suite gpu-vulkan-khr-surface-glfw-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_gpu_vulkan_khr_surface_glfw+ autogen-modules:+ Paths_gpu_vulkan_khr_surface_glfw+ hs-source-dirs:+ test+ ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , containers <1+ , glfw-group <1+ , gpu-vulkan <1+ , gpu-vulkan-khr-surface <1+ , gpu-vulkan-khr-surface-glfw+ , gpu-vulkan-middle-khr-surface <1+ , gpu-vulkan-middle-khr-surface-glfw <1+ , stm <3+ , typelevel-tools-yj <1+ default-language: Haskell2010
+ src/Gpu/Vulkan/Khr/Surface/Glfw/Window.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Gpu.Vulkan.Khr.Surface.Glfw.Window (++ -- * CREATE++ create, create'++ ) where++import Prelude hiding (lookup)++import Control.Concurrent.STM+import Control.Concurrent.STM.TSem+import Control.Exception+import Data.TypeLevel.ParMaybe qualified as TPMaybe+import Data.TypeLevel.Tuple.Uncurry+import Data.Map qualified as Map++import Graphics.UI.GlfwG.Window.Type++import Gpu.Vulkan.AllocationCallbacks.Internal qualified as AllocationCallbacks+import Gpu.Vulkan.Instance.Internal qualified as Vk.Instance+import Gpu.Vulkan.Khr.Surface.Internal qualified as Vk.Khr.Surface+import Gpu.Vulkan.Khr.Surface.Middle qualified as Vk.Khr.Surface.M+import Gpu.Vulkan.Khr.Surface.Glfw.Middle qualified as M++create :: AllocationCallbacks.ToMiddle mac =>+ Vk.Instance.I si -> W sw ->+ TPMaybe.M (U2 AllocationCallbacks.A) mac ->+ (forall ss . Vk.Khr.Surface.S ss -> IO a) -> IO a+create (Vk.Instance.I ist) (W win)+ (AllocationCallbacks.toMiddle -> macc) f = bracket+ (M.createWindowSurface ist win macc)+ (\sfc -> Vk.Khr.Surface.M.destroy ist sfc macc)+ (f . Vk.Khr.Surface.S)++create' :: (Ord k, AllocationCallbacks.ToMiddle ma) =>+ Vk.Khr.Surface.Group si ma ss k -> k -> W sw ->+ IO (Either String (Vk.Khr.Surface.S ss))+create' (Vk.Khr.Surface.Group+ (Vk.Instance.I ist)+ (AllocationCallbacks.toMiddle -> ma) sem ss) k (W win) = do+ ok <- atomically do+ mx <- (Map.lookup k) <$> readTVar ss+ case mx of+ Nothing -> waitTSem sem >> pure True+ Just _ -> pure False+ if ok+ then do s <- M.createWindowSurface ist win ma+ let s' = Vk.Khr.Surface.S s+ atomically $ modifyTVar ss (Map.insert k s') >> signalTSem sem+ pure $ Right s'+ else pure . Left $+ "Gpu.Vulkan.Khr.Surface.Glfw.Window: The key already exist"
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"