glfw-group (empty) → 0.1.0.0

raw patch · 15 files changed

+376/−0 lines, 15 filesdep +GLFW-bdep +basedep +containerssetup-changed

Dependencies added: GLFW-b, base, containers, glfw-group, stm, text

Files

• CHANGELOG.md +11/−0
• LICENSE +26/−0
• README.md +1/−0
• Setup.hs +2/−0
• app/Main.hs +6/−0
• glfw-group.cabal +88/−0
• src/Graphics/UI/GlfwG.hs +50/−0
• src/Graphics/UI/GlfwG/Gamepad.hs +9/−0
• src/Graphics/UI/GlfwG/Joystick.hs +10/−0
• src/Graphics/UI/GlfwG/Key.hs +7/−0
• src/Graphics/UI/GlfwG/Mouse.hs +18/−0
• src/Graphics/UI/GlfwG/Window.hs +132/−0
• src/Graphics/UI/GlfwG/Window/Type.hs +8/−0
• src/Lib.hs +6/−0
• test/Spec.hs +2/−0

@@ -0,0 +1,11 @@+# Changelog for `glfw-group`++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

@@ -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.

@@ -0,0 +1,1 @@+# glfw-group

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,6 @@+module Main (main) where++import Lib++main :: IO ()+main = someFunc

@@ -0,0 +1,88 @@+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:           glfw-group+version:        0.1.0.0+synopsis:       GLFW package with window groups destroyed together+description:    Please see the README on GitHub at <https://github.com/YoshikuniJujo/glfw-group#readme>+category:       Graphics+homepage:       https://github.com/YoshikuniJujo/glfw-group#readme+bug-reports:    https://github.com/YoshikuniJujo/glfw-group/issues+author:         Yoshikuni Jujo+maintainer:     yoshikuni.jujo@gmail.com+copyright:      (c) 2025 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/glfw-group++library+  exposed-modules:+      Graphics.UI.GlfwG+      Graphics.UI.GlfwG.Gamepad+      Graphics.UI.GlfwG.Joystick+      Graphics.UI.GlfwG.Key+      Graphics.UI.GlfwG.Mouse+      Graphics.UI.GlfwG.Window+      Graphics.UI.GlfwG.Window.Type+      Lib+  other-modules:+      Paths_glfw_group+  autogen-modules:+      Paths_glfw_group+  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:+      GLFW-b <4+    , base >=4.7 && <5+    , containers <1+    , stm <3+    , text <3+  default-language: Haskell2010++executable glfw-group-exe+  main-is: Main.hs+  other-modules:+      Paths_glfw_group+  autogen-modules:+      Paths_glfw_group+  hs-source-dirs:+      app+  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:+      GLFW-b <4+    , base >=4.7 && <5+    , containers <1+    , glfw-group+    , stm <3+    , text <3+  default-language: Haskell2010++test-suite glfw-group-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Paths_glfw_group+  autogen-modules:+      Paths_glfw_group+  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:+      GLFW-b <4+    , base >=4.7 && <5+    , containers <1+    , glfw-group+    , stm <3+    , text <3+  default-language: Haskell2010

@@ -0,0 +1,50 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Graphics.UI.GlfwG (++	init, ErrorMessage, getRequiredInstanceExtensions,++	GlfwB.pollEvents, GlfwB.waitEvents++	) where++import Prelude hiding (init)++import Foreign.Ptr+import Foreign.Storable+import Foreign.C.String+import Control.Exception+import Data.Bool+import Data.Text qualified as Txt+import Data.Text.Foreign qualified as Txt++import qualified Graphics.UI.GLFW as GlfwB++init :: (ErrorMessage -> IO a) -> IO a -> IO a+init hdl cmp = GlfwB.init >>= bool+	(hdl $ "Gpu.Vulkan.Khr.Surface.Glfw: " +++		"GLFW-b.Graphics.UI.GLFW.init return False")+	(finally cmp GlfwB.terminate)++type ErrorMessage = String++getRequiredInstanceExtensions :: IO [Txt.Text]+getRequiredInstanceExtensions = (cstrToText `mapM`) =<< GlfwB.getRequiredInstanceExtensions++cstrToText :: CString -> IO Txt.Text+cstrToText cs = Txt.peekCStringLen =<< cstringToCStringLen cs++cstringLength :: CString -> IO Int+cstringLength pc = do+	c <- peek pc+	case c of+		0 -> pure 0+		_ -> (+ 1) <$> cstringLength (pc `plusPtr` 1)++cstringToCStringLen :: CString -> IO CStringLen+cstringToCStringLen cs = (cs ,) <$> cstringLength cs

@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Graphics.UI.GlfwG.Gamepad (+	GamepadButton(..), GamepadAxis(..), GamepadButtonState(..),+	GamepadState(..), joystickIsGamepad, getGamepadName, getGamepadState,+	updateGamepadMappings+	) where++import Graphics.UI.GLFW

@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Graphics.UI.GlfwG.Joystick (+	Joystick(..), JoystickState(..), JoystickButtonState(..),+	joystickPresent, joystickIsGamepad, getJoystickAxes, getJoystickButtons,+	getJoystickHats, JoystickHatState(..), getJoystickName, getJoystickGUID,+	setJoystickCallback, JoystickCallback+	) where++import Graphics.UI.GLFW

@@ -0,0 +1,7 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Graphics.UI.GlfwG.Key (+	B.Key(..), B.KeyState(..), B.ModifierKeys(..) ) where++import Graphics.UI.GLFW qualified as B

@@ -0,0 +1,18 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Graphics.UI.GlfwG.Mouse (++	getButton, B.MouseButton(..), B.MouseButtonState(..),+	getCursorPos++	) where++import Graphics.UI.GLFW qualified as B+import Graphics.UI.GlfwG.Window.Type qualified as Win++getButton :: Win.W sw -> B.MouseButton -> IO B.MouseButtonState+getButton (Win.W w) = B.getMouseButton w++getCursorPos :: Win.W sw -> IO (Double, Double)+getCursorPos (Win.W w) = B.getCursorPos w

@@ -0,0 +1,132 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE BlockArguments, LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Graphics.UI.GlfwG.Window (++	-- * CREATE AND DESTROY++	W, create, Group, group, create', unsafeDestroy, lookup,++	shouldClose, setShouldClose,++	-- ** HINT++	hint, B.WindowHint(..),+	B.ClientAPI(..),++	-- * PARAMETER++	getSize, setSize,+	getFrameSize,+	getFramebufferSize,++	-- * CALLBACK++	setKeyCallback, KeyCallback,+	setFramebufferSizeCallback, B.FramebufferSizeCallback,++	-- * STATE++	getKey++	) where++import Prelude hiding (lookup)++import Control.Concurrent.STM+import Control.Concurrent.STM.TSem+import Data.Map qualified as M++import Graphics.UI.GLFW qualified as B+import Graphics.UI.GlfwG.Window.Type++data Group s k = Group TSem (TVar (M.Map k (W s)))++create :: Int -> Int -> String -> Maybe B.Monitor -> Maybe B.Window ->+	(forall s . W s -> IO a) -> IO a+create wd hg ttl mm mws f = group \g -> f . fromRight =<< create' g () wd hg ttl mm mws+	where fromRight = \case Left _ -> error "never occur"; Right w -> w++group :: (forall s . Group s k -> IO a) -> IO a+group f = do+	(sem, m) <- atomically $ (,) <$> newTSem 1 <*> newTVar M.empty+	rtn <- f $ Group sem m+	((\(W w) -> B.destroyWindow w) `mapM_`) =<< atomically (readTVar m)+	pure rtn++create' :: Ord k => Group s k -> k -> Int -> Int -> String ->+	Maybe B.Monitor -> Maybe B.Window -> IO (Either String (W s))+create' (Group sem ws) k wd hg ttl mm mws = do+	ok <- atomically do+		mx <- M.lookup k <$> readTVar ws+		case mx of+			Nothing -> waitTSem sem >> pure True+			Just _ -> pure False+	if ok+	then do	mw <- (W <$>) <$> B.createWindow wd hg ttl mm mws+		case mw of+			Just w -> atomically do+				modifyTVar ws (M.insert k w) +				signalTSem sem+				pure $ Right w+			Nothing -> pure . Left $+				"Gpu.Vulkan.Khr.Surface." +++				"Glfw.Window.create': GLFW-b: error"+	else pure . Left $ "Gpu.Vulkan.Khr.Surface.Glfw.Window.create': " +++		"The key already exist"++unsafeDestroy :: Ord k => Group s k -> k -> IO (Either String ())+unsafeDestroy (Group sem ws) k = do+	mw <- atomically do+		mx <- M.lookup k <$> readTVar ws+		case mx of+			Nothing -> pure Nothing+			Just _ -> waitTSem sem >> pure mx+	case mw of+		Nothing -> pure . Left $+			"Gpu.Vulkan.Khr.Surface.Glfw.Window.destroy: " +++			"No such key"+		Just (W w) -> do+			B.destroyWindow w+			atomically do+				modifyTVar ws (M.delete k)+				signalTSem sem+				pure $ Right ()++hint :: B.WindowHint -> IO ()+hint = B.windowHint++lookup :: Ord k => Group s k -> k -> IO (Maybe (W s))+lookup (Group _sem ws) k = atomically $ M.lookup k <$> readTVar ws++setFramebufferSizeCallback :: W s -> Maybe B.FramebufferSizeCallback -> IO ()+setFramebufferSizeCallback (W w) = B.setFramebufferSizeCallback w++getSize :: W sw -> IO (Int, Int)+getSize (W w) = B.getWindowSize w++setSize :: W sw -> Int -> Int -> IO ()+setSize (W w) = B.setWindowSize w++getFrameSize :: W sw -> IO (Int, Int, Int, Int)+getFrameSize (W w) = B.getWindowFrameSize w++getFramebufferSize :: W sw -> IO (Int, Int)+getFramebufferSize (W w) = B.getFramebufferSize w++setKeyCallback :: W s -> Maybe (KeyCallback s) -> IO ()+setKeyCallback (W w) = B.setKeyCallback w . ((. W) <$>)++type KeyCallback s = W s -> B.Key -> Int -> B.KeyState -> B.ModifierKeys -> IO ()++shouldClose :: W sw -> IO Bool+shouldClose (W w) = B.windowShouldClose w++setShouldClose :: W sw -> Bool -> IO ()+setShouldClose (W w) = B.setWindowShouldClose w++getKey :: W sw -> B.Key -> IO B.KeyState+getKey (W w) = B.getKey w

@@ -0,0 +1,8 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}++module Graphics.UI.GlfwG.Window.Type where++import Graphics.UI.GLFW qualified as B++newtype W s = W B.Window deriving (Eq, Ord, Show)

@@ -0,0 +1,6 @@+module Lib+    ( someFunc+    ) where++someFunc :: IO ()+someFunc = putStrLn "someFunc"

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"