gore-and-ash-glfw (empty) → 1.1.0.0

raw patch · 7 files changed

+828/−0 lines, 7 filesdep +GLFW-bdep +basedep +deepseqsetup-changed

Dependencies added: GLFW-b, base, deepseq, exceptions, extra, gore-and-ash, hashable, mtl, transformers, unordered-containers

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• gore-and-ash-glfw.cabal +43/−0
• src/Game/GoreAndAsh/GLFW.hs +99/−0
• src/Game/GoreAndAsh/GLFW/API.hs +350/−0
• src/Game/GoreAndAsh/GLFW/Module.hs +216/−0
• src/Game/GoreAndAsh/GLFW/State.hs +88/−0

@@ -0,0 +1,30 @@+Copyright Gushcha Anton (c) 2015-2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of  nor the names of other+      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+OWNER 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,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,43 @@+name:                gore-and-ash-glfw+version:             1.1.0.0+synopsis:            Core module for Gore&Ash engine for GLFW input events+description:         Please see README.md+homepage:            https://github.com/Teaspot-Studio/gore-and-ash-glfw+license:             BSD3+license-file:        LICENSE+author:              Anton Gushcha+maintainer:          ncrashed@gmail.com+copyright:           2015-2016 Anton Gushcha+category:            Game+build-type:          Simple+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Game.GoreAndAsh.GLFW+                       Game.GoreAndAsh.GLFW.API+                       Game.GoreAndAsh.GLFW.Module+                       Game.GoreAndAsh.GLFW.State++  default-language:    Haskell2010+  build-depends:       base >= 4.7 && < 5+                     , deepseq >= 1.4+                     , exceptions >= 0.8.0.2+                     , extra >= 1.4.2+                     , GLFW-b >= 1.4.7+                     , gore-and-ash >= 1.1.0.1+                     , hashable >= 1.2.3+                     , mtl >= 2.2+                     , transformers >= 0.4.2+                     , unordered-containers >= 0.2.5+                     +  default-extensions:  +                       BangPatterns+                       DeriveGeneric+                       FlexibleInstances+                       GeneralizedNewtypeDeriving+                       MultiParamTypeClasses+                       RecordWildCards+                       TypeFamilies+                       UndecidableInstances+                       ScopedTypeVariables

@@ -0,0 +1,99 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-|+Module      : Game.GoreAndAsh.GLFW+Description : Module that contains GLFW integration for Gore&Ash+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX++The core module contains API for GLFW library integration. +The module doesn't depends on others core modules and could be place in any place in +game monad stack.++The module is NOT pure within first phase (see 'ModuleStack' docs), therefore currently only 'IO' end monad can handler the module.++Example of embedding:++@+-- | Application monad is monad stack build from given list of modules over base monad (IO)+type AppStack = ModuleStack [GLFWT, ... other modules ... ] IO+newtype AppState = AppState (ModuleState AppStack)+  deriving (Generic)++instance NFData AppState ++-- | Wrapper around type family+newtype AppMonad a = AppMonad (AppStack a)+  deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadThrow, MonadCatch, MonadGLFW, ... other modules monads ... )+  +instance GameModule AppMonad AppState where +  type ModuleState AppMonad = AppState+  runModule (AppMonad m) (AppState s) = do +    (a, s') <- runModule m s +    return (a, AppState s')+  newModuleState = AppState <$> newModuleState+  withModule _ = withModule (Proxy :: Proxy AppStack)+  cleanupModule (AppState s) = cleanupModule s ++-- | Arrow that is build over the monad stack+type AppWire a b = GameWire AppMonad a b+-- | Action that makes indexed app wire+type AppActor i a b = GameActor AppMonad i a b+@++-}+module Game.GoreAndAsh.GLFW(+  -- * Low-level API +    GLFWState+  , GLFWT+  , MonadGLFW(..)+  -- * Arrow API+  -- ** Keyboard API+  , keyStatus+  , keyStatusDyn+  , keyPressed+  , keyPressedDyn+  , keyReleased+  , keyReleasedDyn+  , keyRepeating+  , keyRepeatingDyn+  , keyPressing+  , keyPressingDyn+  -- ** Mouse buttons API+  , mouseButton+  , mouseButtonDyn+  , mouseButtonPressed+  , mouseButtonPressedDyn+  , mouseButtonReleased+  , mouseButtonReleasedDyn+  -- ** Cursor position+  , mousePosition+  , mousePositionChange+  , mouseXChange+  , mouseYChange+  , mouseDelta+  , mouseDeltaChange+  , mouseDeltaXChange+  , mouseDeltaYChange+  -- ** Mouse scroll+  , mouseScroll+  , mouseScrollX+  , mouseScrollY+  -- ** Window API+  , windowSize+  , windowClosing+  -- ** Reexports+  , Key(..)+  , KeyState(..)+  , MouseButton(..)+  , MouseButtonState(..)+  , ModifierKeys(..)+  ) where++import Graphics.UI.GLFW++import Game.GoreAndAsh.GLFW.API +import Game.GoreAndAsh.GLFW.Module+import Game.GoreAndAsh.GLFW.State 

@@ -0,0 +1,350 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-|+Module      : Game.GoreAndAsh.GLFW.API+Description : Monadic and arrow API for GLFW core module+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX++The module contains monadic and arrow API of the core module.+-}+module Game.GoreAndAsh.GLFW.API(+    MonadGLFW(..)+  -- * Keyboard API+  , keyStatus+  , keyStatusDyn+  , keyPressed+  , keyPressedDyn+  , keyReleased+  , keyReleasedDyn+  , keyRepeating+  , keyRepeatingDyn+  , keyPressing+  , keyPressingDyn+  -- * Mouse buttons API+  , mouseButton+  , mouseButtonDyn+  , mouseButtonPressed+  , mouseButtonPressedDyn+  , mouseButtonReleased+  , mouseButtonReleasedDyn+  -- * Cursor position+  , mousePosition+  , mousePositionChange+  , mouseXChange+  , mouseYChange+  , mouseDelta+  , mouseDeltaChange+  , mouseDeltaXChange+  , mouseDeltaYChange+  -- * Mouse scroll+  , mouseScroll+  , mouseScrollX+  , mouseScrollY+  -- * Window API+  , windowSize+  , windowClosing+  -- * Reexports+  , Key(..)+  , KeyState(..)+  , MouseButton(..)+  , MouseButtonState(..)+  , ModifierKeys(..)+  ) where++import Prelude hiding (id, (.))+import Control.Wire ++import Control.Monad.State.Strict +import Control.Wire.Unsafe.Event+import Graphics.UI.GLFW+import qualified Data.HashMap.Strict as M ++import Game.GoreAndAsh+import Game.GoreAndAsh.GLFW.State+import Game.GoreAndAsh.GLFW.Module ++-- | Module low-level API+class Monad m => MonadGLFW m where +  -- | Returns state of given keyboard's key+  keyStatusM :: Key -> m (Maybe (KeyState, ModifierKeys))+  -- | Returns state of given mouse button+  mouseButtonM :: MouseButton -> m (Maybe (MouseButtonState, ModifierKeys))+  -- | Returns current position of mouse cursor+  mousePosM :: m (Double, Double)+  -- | Returns current scroll values of mouse+  mouseScrollM :: m [(Double, Double)]+  -- | Returns current size of window+  windowSizeM :: m (Maybe (Double, Double))+  -- | Returns True when close button is pushed+  windowClosingM :: m Bool +  -- | Setups current window for input catch+  setCurrentWindowM :: Maybe Window -> m ()+  -- | Returns current window +  getCurrentWindowM :: m (Maybe Window)+  -- | Setup maximum size of inner buffers for keys, mouse buttons+  setBufferSizeM :: Int -> m ()++instance {-# OVERLAPPING #-} Monad m => MonadGLFW (GLFWT s m) where +  keyStatusM k = do +    GLFWState{..} <- GLFWT get+    return $ M.lookup k glfwKeys++  mouseButtonM b = do +    GLFWState{..} <- GLFWT get +    return $ M.lookup b glfwMouseButtons++  mousePosM = GLFWT $ glfwMousePos <$> get +  mouseScrollM = GLFWT $ glfwScroll <$> get +  windowSizeM = GLFWT $ glfwWindowSize <$> get +  windowClosingM = GLFWT $ glfwClose <$> get ++  setCurrentWindowM w = GLFWT $ do +    s <- get +    put $ s { +        glfwWindow = w +      , glfwPrevWindow = glfwWindow s +      }++  getCurrentWindowM = GLFWT $ do +    s <- get +    return . glfwWindow $! s ++  setBufferSizeM i = GLFWT $ do +    s <- get +    put $ s {+        glfwBufferSize = i +      }++instance {-# OVERLAPPABLE #-} (Monad (mt m), MonadGLFW m, MonadTrans mt) => MonadGLFW (mt m) where +  keyStatusM = lift . keyStatusM+  mouseButtonM = lift . mouseButtonM+  mousePosM = lift mousePosM+  mouseScrollM = lift mouseScrollM+  windowSizeM = lift windowSizeM+  windowClosingM = lift windowClosingM+  setCurrentWindowM = lift . setCurrentWindowM+  getCurrentWindowM = lift getCurrentWindowM+  setBufferSizeM = lift . setBufferSizeM+  +-- | Produces event when key state changes+keyStatus :: MonadGLFW m => Key -> GameWire m a (Event (KeyState, ModifierKeys))+keyStatus k = liftGameMonad (maybe2Event <$> keyStatusM k)++-- | Produces event when key state changes, get key as arrow argument+keyStatusDyn :: MonadGLFW m => GameWire m Key (Event (KeyState, ModifierKeys))+keyStatusDyn = liftGameMonad1 $ \k -> do +  ms <- keyStatusM k +  return $ maybe2Event ms ++-- | Simple transform from maybe to event+maybe2Event :: Maybe a -> Event a +maybe2Event Nothing = NoEvent +maybe2Event (Just a) = Event a++keyStated :: MonadGLFW m => KeyState -> Key -> GameWire m a (Event ModifierKeys)+keyStated ks k = mapE snd . filterE (\(ks', _) -> ks' == ks) . keyStatus k++keyStatedDyn :: MonadGLFW m => KeyState -> GameWire m Key (Event ModifierKeys)+keyStatedDyn ks = mapE snd . filterE (\(ks', _) -> ks' == ks) . keyStatusDyn++-- | Fires when keyboard key is pressed+keyPressed :: MonadGLFW m => Key -> GameWire m a (Event ModifierKeys)+keyPressed = keyStated KeyState'Pressed++-- | Version of keyPressed that takes key at runtime+keyPressedDyn :: MonadGLFW m => GameWire m Key (Event ModifierKeys)+keyPressedDyn = keyStatedDyn KeyState'Pressed++-- | Fires when keyboard key is released+keyReleased :: MonadGLFW m => Key -> GameWire m a (Event ModifierKeys)+keyReleased = keyStated KeyState'Released++-- | Version of keyReleased that takes key at runtime+keyReleasedDyn :: MonadGLFW m => GameWire m Key (Event ModifierKeys)+keyReleasedDyn = keyStatedDyn KeyState'Released++-- | Fires when keyboard key is entered into repeating mode+keyRepeating :: MonadGLFW m => Key -> GameWire m a (Event ModifierKeys)+keyRepeating = keyStated KeyState'Repeating++-- | Version of keyRepeating that takes key at runtime+keyRepeatingDyn :: MonadGLFW m => GameWire m Key (Event ModifierKeys)+keyRepeatingDyn = keyStatedDyn KeyState'Repeating++-- | Fires event from moment of press until release of given key+keyPressing :: MonadGLFW m => Key -> GameWire m a (Event ModifierKeys)+keyPressing k = go NoEvent +  where+    go !e = mkGen $ \_ _ -> do +      !mks <- keyStatusM k+      return $! case mks of +        Nothing -> (Right e, go e)+        Just (!ks, !mds) -> case ks of +          KeyState'Pressed -> (Right $! Event mds, go $! Event mds)+          KeyState'Released -> (Right NoEvent, go NoEvent)+          _ -> (Right e, go e)++-- | Version of keyPressing that takes key at runtime+keyPressingDyn :: MonadGLFW m => GameWire m Key (Event ModifierKeys)+keyPressingDyn = go NoEvent +  where+    go !e = mkGen $ \_ k -> do +      !mks <- keyStatusM k+      return $! case mks of +        Nothing -> (Right e, go e)+        Just (!ks, !mds) -> case ks of +          KeyState'Pressed -> (Right $! Event mds, go $! Event mds)+          KeyState'Released -> (Right NoEvent, go NoEvent)+          _ -> (Right e, go e)++-- | Produces event when mouse button state changes+mouseButton :: MonadGLFW m => MouseButton -> GameWire m a (Event (MouseButtonState, ModifierKeys))+mouseButton k = liftGameMonad (maybe2Event <$> mouseButtonM k)++-- | Produces event when key state changes, get key as arrow argument+mouseButtonDyn :: MonadGLFW m => GameWire m MouseButton (Event (MouseButtonState, ModifierKeys))+mouseButtonDyn = liftGameMonad1 $ \k -> do +  ms <- mouseButtonM k +  return $ maybe2Event ms ++mouseButtonStated :: MonadGLFW m => MouseButtonState -> MouseButton -> GameWire m a (Event ModifierKeys)+mouseButtonStated bs b = mapE snd . filterE (\(bs', _) -> bs == bs') . mouseButton b++mouseButtonStatedDyn :: MonadGLFW m => MouseButtonState -> GameWire m MouseButton (Event ModifierKeys)+mouseButtonStatedDyn bs = mapE snd . filterE (\(bs', _) -> bs == bs') . mouseButtonDyn++-- | Fires when mouse button is pressed+mouseButtonPressed :: MonadGLFW m => MouseButton -> GameWire m a (Event ModifierKeys)+mouseButtonPressed = mouseButtonStated MouseButtonState'Pressed ++-- | Version of mouseButtonPressed that takes button at runtime+mouseButtonPressedDyn :: MonadGLFW m => GameWire m MouseButton (Event ModifierKeys)+mouseButtonPressedDyn = mouseButtonStatedDyn MouseButtonState'Pressed++-- | Fires when mouse button is released+mouseButtonReleased :: MonadGLFW m => MouseButton -> GameWire m a (Event ModifierKeys)+mouseButtonReleased = mouseButtonStated MouseButtonState'Released ++-- | Version of mouseButtonReleased that takes button at runtime+mouseButtonReleasedDyn :: MonadGLFW m => GameWire m MouseButton (Event ModifierKeys)+mouseButtonReleasedDyn = mouseButtonStatedDyn MouseButtonState'Released++-- | Returns current position of mouse+mousePosition :: MonadGLFW m => GameWire m a (Double, Double)+mousePosition = liftGameMonad mousePosM++-- | Fires event when mouse position changes+mousePositionChange :: MonadGLFW m => GameWire m a (Event (Double, Double))+mousePositionChange = go 0 0+  where+    go !x !y = mkGen $ \_ _-> do +      (!x', !y') <- mousePosM+      return $ if x /= x' || y /= y' +        then (Right $! Event (x', y'), go x' y')+        else (Right NoEvent, go x y)++-- | Fires event when mouse X axis changes+mouseXChange :: MonadGLFW m => GameWire m a (Event Double)+mouseXChange = go 0 +  where+    go !x = mkGen $ \_ _-> do +      (!x', _) <- mousePosM+      return $ if x /= x'+        then (Right $! Event x', go x')+        else (Right NoEvent, go x)++-- | Fires event when mouse Y axis changes+mouseYChange :: MonadGLFW m => GameWire m a (Event Double)+mouseYChange = go 0 +  where+    go !y = mkGen $ \_ _-> do +      (_, !y') <- mousePosM+      return $ if y /= y'+        then (Right $! Event y', go y')+        else (Right NoEvent, go y)++-- | Returns mouse delta moves+mouseDelta :: MonadGLFW m => GameWire m a (Double, Double)+mouseDelta = go 0 0+  where +    go !x !y = mkGen $ \_ _ -> do +      (!x', !y') <- mousePosM+      let dx = x' - x +          dy = y' - y+          res = Right (dx, dy)+      return $ dx `seq` dy `seq` (res, go x' y')++-- | Fires when mouse moves, holds delta move+mouseDeltaChange :: MonadGLFW m => GameWire m a (Event (Double, Double))+mouseDeltaChange = go 0 0+  where +    go !x !y = mkGen $ \_ _ -> do +      (!x', !y') <- mousePosM+      let dx = x' - x +          dy = y' - y+          res = Right $! Event (dx, dy)+      return $ if x /= x' || y /= y' +        then dx `seq` dy `seq` (res, go x' y')+        else (Right NoEvent, go x y)++-- | Fires when mouse X axis changes, holds delta move+mouseDeltaXChange :: MonadGLFW m => GameWire m a (Event Double)+mouseDeltaXChange = go 0 +  where +    go !x = mkGen $ \_ _ -> do +      (!x', _) <- mousePosM+      let dx = x' - x +          res = Right $! Event dx+      return $ if x /= x' +        then dx `seq` (res, go x')+        else (Right NoEvent, go x)++-- | Fires when mouse Y axis changes, holds delta move+mouseDeltaYChange :: MonadGLFW m => GameWire m a (Event Double)+mouseDeltaYChange = go 0 +  where +    go !y = mkGen $ \_ _ -> do +      (_, !y') <- mousePosM+      let dy = y' - y +          res = Right $! Event dy+      return $ if y /= y'+        then dy `seq` (res, go y')+        else (Right NoEvent, go y)++-- | Fires when windows size is changed+windowSize :: MonadGLFW m => GameWire m a (Event (Double, Double))+windowSize = go 0 0 +  where+    go !x !y = mkGen $ \_ _ -> do +      ms <- windowSizeM+      return $! case ms of +        Nothing -> (Right NoEvent, go x y)+        Just (!x', !y') -> if x /= x' || y /= y' +          then x' `seq` y' `seq` (Right $! Event (x', y'), go x' y')+          else (Right NoEvent, go x y)++-- | Fires when user scrolls+mouseScroll :: MonadGLFW m => GameWire m a (Event (Double, Double))+mouseScroll = mkGen_ $ \_ -> do +  ss <- mouseScrollM+  return . Right $! case ss of +    [] -> NoEvent+    ((!x', !y'):_) -> Event (x', y')++-- | Fires when user scrolls X axis+mouseScrollX :: MonadGLFW m => GameWire m a (Event Double)+mouseScrollX = mapE fst . mouseScroll++-- | Fires when user scrolls Y axis+mouseScrollY :: MonadGLFW m => GameWire m a (Event Double)+mouseScrollY = mapE snd . mouseScroll ++-- | Fires when user hits close button of window +windowClosing :: MonadGLFW m => GameWire m a (Event ())+windowClosing = liftGameMonad $ do +  f <- windowClosingM +  return $! if f then Event ()+    else NoEvent 

@@ -0,0 +1,216 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-|+Module      : Game.GoreAndAsh.GLFW.Module+Description : Monad transformer of the module+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX++The module contains declaration of monad transformer of the core module and+instance for 'GameModule' class.+-}+module Game.GoreAndAsh.GLFW.Module(+    GLFWT(..)+  ) where++import Control.Monad.Catch+import Control.Monad.Extra+import Control.Monad.Fix +import Control.Monad.IO.Class+import Control.Monad.State.Strict +import Data.IORef+import Data.Proxy +import Graphics.UI.GLFW+import qualified Data.HashMap.Strict as M ++import Game.GoreAndAsh+import Game.GoreAndAsh.GLFW.State++-- | Monad transformer that handles GLFW specific API+--+-- [@s@] - State of next core module in modules chain;+--+-- [@m@] - Next monad in modules monad stack;+--+-- [@a@] - Type of result value;+--+-- How to embed module:+-- +-- @+-- type AppStack = ModuleStack [GLFWT, ... other modules ... ] IO+--+-- newtype AppMonad a = AppMonad (AppStack a)+--   deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadThrow, MonadCatch, MonadSDL)+-- @+--+-- The module is NOT pure within first phase (see 'ModuleStack' docs), therefore currently only 'IO' end monad can handler the module.+newtype GLFWT s m a = GLFWT { runGLFWT :: StateT (GLFWState s) m a }+  deriving (Functor, Applicative, Monad, MonadState (GLFWState s), MonadFix, MonadThrow, MonadCatch, MonadMask)++instance GameModule m s => GameModule (GLFWT s m) (GLFWState s) where +  type ModuleState (GLFWT s m) = GLFWState s+  +  runModule (GLFWT m) s_ = do+    liftIO $ pollEvents+    close <- readCloseEvent s_+    let s = s_ { glfwClose = close }++    ((a, s'@GLFWState{..}), nextState) <- runModule (runStateT m s) (glfwNextState s)+    bindWindow glfwPrevWindow glfwWindow glfwKeyChannel glfwMouseButtonChannel +      glfwMousePosChannel glfwWindowSizeChannel glfwScrollChannel glfwCloseChannel+    keys <- readAllKeys s'+    buttons <- readAllButtons s'+    mpos <- readMousePos s'+    wsize <- readWindowSize s'+    scroll <- readMouseScroll s'+    return (a, s' { +        glfwKeys = keys+      , glfwMouseButtons = buttons+      , glfwMousePos = mpos+      , glfwNextState = nextState +      , glfwWindowSize = wsize+      , glfwScroll = scroll+      , glfwClose = False+      })+    where +      readAllKeys GLFWState{..} = liftIO $ do+        keys <- readAllChan glfwBufferSize glfwKeyChannel+        return $ M.fromList $ (\(k, ks, mds) -> (k, (ks, mds))) <$> keys++      readAllButtons GLFWState{..} = liftIO $ do +        btns <- readAllChan glfwBufferSize glfwMouseButtonChannel+        return $ M.fromList $ (\(b, bs, mds) -> (b, (bs, mds))) <$> btns ++      readMousePos GLFWState{..} = liftIO $+        readIORef glfwMousePosChannel++      readWindowSize GLFWState{..} = liftIO $ +        readIORef glfwWindowSizeChannel ++      readMouseScroll GLFWState{..} = liftIO $ +        readAllChan glfwBufferSize glfwScrollChannel++      readCloseEvent GLFWState{..} = liftIO $ +        readIORef glfwCloseChannel ++  newModuleState = do+    s <- newModuleState +    kc <- liftIO $ newIORef []+    mbc <- liftIO $ newIORef []+    mpc <- liftIO $ newIORef (0, 0)+    wsc <- liftIO $ newIORef Nothing+    sch <- liftIO $ newIORef []+    cch <- liftIO $ newIORef False+    return $ GLFWState {+        glfwNextState = s+      , glfwKeyChannel = kc+      , glfwKeys = M.empty+      , glfwMouseButtonChannel = mbc +      , glfwMouseButtons = M.empty+      , glfwMousePos = (0, 0)+      , glfwMousePosChannel = mpc+      , glfwWindow = Nothing+      , glfwPrevWindow = Nothing+      , glfwWindowSize = Nothing+      , glfwWindowSizeChannel = wsc+      , glfwScroll = []+      , glfwScrollChannel = sch+      , glfwClose = False+      , glfwCloseChannel = cch+      , glfwBufferSize = 100+      }++  withModule _ = withModule (Proxy :: Proxy m)+  cleanupModule _ = return ()+  +instance MonadTrans (GLFWT s) where+  lift = GLFWT . lift ++instance MonadIO m => MonadIO (GLFWT s m) where +  liftIO = GLFWT . liftIO ++-- | Updates handlers when current window changes+bindWindow :: MonadIO m => Maybe Window -> Maybe Window +  -> KeyChannel -> ButtonChannel -> MouseChannel -> WindowSizeChannel +  -> ScrollChannel -> CloseChannel -> m ()+bindWindow prev cur kch mbch mpch wsch sch cch = unless (prev == cur) $ liftIO $ do +  whenJust prev $ \w -> do+    setKeyCallback w Nothing+    setMouseButtonCallback w Nothing+    setCursorPosCallback w Nothing+    setWindowSizeCallback w Nothing >> atomicWriteIORef wsch Nothing+    setScrollCallback w Nothing+    setWindowCloseCallback w Nothing+  whenJust cur $ \w -> do+    bindKeyListener kch w+    bindMouseButtonListener mbch w+    bindMousePosListener mpch w++    bindWindowSizeListener wsch w+    -- update window size+    (!sx, !sy) <- getWindowSize w +    atomicWriteIORef wsch $! Just (fromIntegral sx, fromIntegral sy)++    bindScrollListener sch w +    bindCloseCallback cch w++atomicAppendIORef :: IORef [a] -> a -> IO ()+atomicAppendIORef ref a = atomicModifyIORef ref $ \as -> (a : as, ()) ++-- | Bind callback that passes keyboard info to channel+bindKeyListener :: KeyChannel -> Window -> IO ()+bindKeyListener kch w = setKeyCallback w (Just f)+  where+    f :: Window -> Key -> Int -> KeyState -> ModifierKeys -> IO ()+    f _ k _ ks mds = atomicAppendIORef kch (k, ks, mds)++-- | Bind callback that passes mouse button info to channel+bindMouseButtonListener :: ButtonChannel -> Window -> IO ()+bindMouseButtonListener mbch w = setMouseButtonCallback w (Just f)+  where +    f :: Window -> MouseButton -> MouseButtonState -> ModifierKeys -> IO ()+    f _ b bs mds = atomicAppendIORef mbch (b, bs, mds)++-- | Bind callback that passes mouse position info to channel+bindMousePosListener :: MouseChannel -> Window -> IO ()+bindMousePosListener mpch w = setCursorPosCallback w (Just f)+  where +    f :: Window -> Double -> Double -> IO ()+    f w' x y = do+      (sx, sy) <- getWindowSize w'+      let x' = 2 * (x / fromIntegral sx - 0.5)+          y' = 2 * (0.5 - y / fromIntegral sy)+      atomicWriteIORef mpch $! x' `seq` y' `seq` (x', y')++-- | Bind callback that passes window size info to channel+bindWindowSizeListener :: WindowSizeChannel -> Window -> IO ()+bindWindowSizeListener wsch w = setWindowSizeCallback w (Just f)+  where+    f :: Window -> Int -> Int -> IO ()+    f _ sx sy = do +      let sx' = fromIntegral sx +          sy' = fromIntegral sy+      atomicWriteIORef wsch . Just $! sx' `seq` sy' `seq` (sx', sy')++-- | Bind callback that passes scoll info to channel+bindScrollListener :: ScrollChannel -> Window -> IO ()+bindScrollListener sch w = setScrollCallback w (Just f)+  where +    f :: Window -> Double -> Double -> IO ()+    f _ !sx !sy = atomicAppendIORef sch $! (sx, sy)++-- | Bind callback that passes close event to channel+bindCloseCallback :: CloseChannel -> Window -> IO ()+bindCloseCallback cch w = setWindowCloseCallback w (Just f)+  where +    f :: Window -> IO ()+    f _ = atomicWriteIORef cch True ++-- | Helper function to read all elements from channel+readAllChan :: Int -> IORef [a] -> IO [a]+readAllChan mi chan = do +  xs <- readIORef chan +  atomicWriteIORef chan []+  return $ take mi xs

@@ -0,0 +1,88 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-|+Module      : Game.GoreAndAsh.GLFW.State+Description : Internal core module state+Copyright   : (c) Anton Gushcha, 2015-2016+License     : BSD3+Maintainer  : ncrashed@gmail.com+Stability   : experimental+Portability : POSIX+-}+module Game.GoreAndAsh.GLFW.State(+    KeyChannel+  , ButtonChannel+  , MouseChannel+  , WindowSizeChannel+  , ScrollChannel+  , CloseChannel+  , GLFWState(..)+  ) where++import Control.DeepSeq+import Data.IORef+import Data.Hashable+import GHC.Generics (Generic)+import Graphics.UI.GLFW+import qualified Data.HashMap.Strict as M ++-- | Channel to connect core and callback with key states+type KeyChannel = IORef [(Key, KeyState, ModifierKeys)]+-- | Channel to connect core and callback with mouse button states+type ButtonChannel = IORef [(MouseButton, MouseButtonState, ModifierKeys)]+-- | Channel to connect core and callback with mouse position+type MouseChannel = IORef (Double, Double)+-- | Channel to connect core and callback with window resizing +type WindowSizeChannel = IORef (Maybe (Double, Double))+-- | Channel to connect core and callback with mouse scrolling+type ScrollChannel = IORef [(Double, Double)]+-- | Channel to connect core and callback for window closing+type CloseChannel = IORef Bool ++-- | Module inner state+--+-- [@s@] - State of next module, the states are chained via nesting.+data GLFWState s = GLFWState {+  glfwNextState :: !s+, glfwKeys :: !(M.HashMap Key (KeyState, ModifierKeys))+, glfwKeyChannel :: !KeyChannel+, glfwMouseButtons :: !(M.HashMap MouseButton (MouseButtonState, ModifierKeys))+, glfwMouseButtonChannel :: !ButtonChannel+, glfwMousePos :: !(Double, Double)+, glfwMousePosChannel :: !MouseChannel+, glfwWindow :: !(Maybe Window)+, glfwPrevWindow :: !(Maybe Window)+, glfwWindowSize :: !(Maybe (Double, Double))+, glfwWindowSizeChannel :: !WindowSizeChannel+, glfwScroll :: ![(Double, Double)]+, glfwScrollChannel :: !ScrollChannel+, glfwClose :: !Bool+, glfwCloseChannel :: !CloseChannel +, glfwBufferSize :: !Int+} deriving (Generic)++instance NFData s => NFData (GLFWState s) where +  rnf GLFWState {..} = +    glfwNextState `deepseq` +    glfwKeys `deepseq` +    glfwKeyChannel `seq` +    glfwMouseButtons `deepseq` +    glfwMouseButtonChannel `seq` +    glfwMousePos `deepseq`+    glfwMousePosChannel `seq`+    glfwWindow `seq`+    glfwPrevWindow `seq` +    glfwWindowSize `deepseq`+    glfwWindowSizeChannel `seq`+    glfwScroll `deepseq`+    glfwScrollChannel `seq` +    glfwClose `seq` +    glfwCloseChannel `seq`+    glfwBufferSize `seq` ()++instance Hashable Key +instance Hashable MouseButton+instance NFData Key +instance NFData KeyState +instance NFData ModifierKeys+instance NFData MouseButton+instance NFData MouseButtonState