packages feed

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

raw patch · 7 files changed

+881/−0 lines, 7 filesdep +basedep +containersdep +deepseqsetup-changed

Dependencies added: base, containers, deepseq, exceptions, gore-and-ash, lens, linear, mtl, sdl2, text, transformers, unordered-containers

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Anton Gushcha (c) 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ gore-and-ash-sdl.cabal view
@@ -0,0 +1,46 @@+name:                gore-and-ash-sdl+version:             1.1.0.0+synopsis:            Gore&Ash core module for integration with SDL library+description:         Please see README.md+homepage:            git@github.com:Teaspot-Studio/gore-and-ash-sdl.git+license:             BSD3+license-file:        LICENSE+author:              Anton Gushcha+maintainer:          ncrashed@gmail.com+copyright:           2016 Anton Gushcha+category:            Game+build-type:          Simple+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Game.GoreAndAsh.SDL+                       Game.GoreAndAsh.SDL.API+                       Game.GoreAndAsh.SDL.Module+                       Game.GoreAndAsh.SDL.State++  default-language:    Haskell2010+  build-depends:       base >= 4.7 && < 5+                     , containers >= 0.5.6.2+                     , deepseq >= 1.4.1.1+                     , exceptions >= 0.8.0.2+                     , gore-and-ash >= 1.1.0.0+                     , lens >= 4.13+                     , linear >= 1.20.3+                     , mtl >= 2.2.1+                     , sdl2 >= 2.1.1+                     , text >= 1.2.2.0+                     , transformers >= 0.4.2.0+                     , unordered-containers >= 0.2.5.1+                     +  default-extensions:    +                       BangPatterns+                       DeriveGeneric+                       FlexibleInstances+                       GeneralizedNewtypeDeriving+                       MultiParamTypeClasses+                       OverloadedStrings+                       RecordWildCards+                       ScopedTypeVariables+                       TypeFamilies+                       UndecidableInstances
+ src/Game/GoreAndAsh/SDL.hs view
@@ -0,0 +1,74 @@+{-|+Module      : Game.GoreAndAsh.SDL+Description : Module that contains SDL 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 SDL2 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 [SDLT, ... 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, MonadSDL, ... 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.SDL(+  -- * Low level API+    SDLState+  , SDLT+  , MonadSDL(..)+  -- * Arrow API+  , WindowConfig(..)+  , RendererConfig(..)+  , RendererType(..)+  , module ReExport+  -- ** Keyboard arrow API+  , keyScancode+  , keyPress+  , keyRelease+  , keyPressing+  -- ** Mouse arrow API+  , mouseScroll+  , mouseScrollX+  , mouseScrollY+  , mouseClick+  -- ** Window arrow API+  , windowClosed+  ) where++import SDL as ReExport hiding (get, Event)++import Game.GoreAndAsh.SDL.API as X +import Game.GoreAndAsh.SDL.Module as X +import Game.GoreAndAsh.SDL.State as X
+ src/Game/GoreAndAsh/SDL/API.hs view
@@ -0,0 +1,383 @@+{-|+Module      : Game.GoreAndAsh.SDL.API+Description : Monadic and arrow API for SDL 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.SDL.API(+    MonadSDL(..)+  , WindowConfig(..)+  , RendererConfig(..)+  , RendererType(..)+  , module ReExport+  -- | Keyboard arrow API+  , keyScancode+  , keyPress+  , keyRelease+  , keyPressing+  -- | Mouse arrow API+  , mouseScroll+  , mouseScrollX+  , mouseScrollY+  , mouseClick+  -- | Window arrow API+  , windowClosed+  ) where++import Control.Lens ((^.))+import Control.Monad.Catch+import Control.Monad.State.Strict+import Control.Wire+import Control.Wire.Unsafe.Event+import Data.Int +import Data.Sequence (Seq)+import Data.Text (Text)+import Data.Word +import Foreign +import GHC.Generics +import Linear +import Linear.Affine+import Prelude hiding (id, (.))+import qualified Data.HashMap.Strict as H +import qualified Data.Sequence as S ++import SDL as ReExport hiding (get, Event)+import SDL.Internal.Types+import qualified SDL.Raw as SDLRaw ++import Game.GoreAndAsh+import Game.GoreAndAsh.SDL.Module+import Game.GoreAndAsh.SDL.State++-- | Module specific exceptions+data SDL'ModuleException = +  -- | Tried to register two windows with equal names+  SDL'ConflictingWindows !Text+  deriving (Generic, Show)++instance Exception SDL'ModuleException++-- | Low level API for module+class (MonadIO m, MonadThrow m) => MonadSDL m where +  -- | Creates window and stores in module context+  --+  -- Throws @SDL'ConflictingWindows@ on name conflict+  sdlCreateWindowM :: +       Text -- ^ Window name that is used to get the window (and renderer) from the module later+    -> Text -- ^ Title of the window+    -> WindowConfig -- ^ Window configuration+    -> RendererConfig -- ^ Renderer configuration+    -> m (Window, Renderer)++  -- | Getting window and renderer by name+  sdlGetWindowM :: +       Text -- ^ Window name that was used at @sdlCreateWindowM@ call+    -> m (Maybe (Window, Renderer))++  -- | Destroying window and renderer by name+  sdlDestroyWindowM ::+       Text -- ^ Window name that was used at @sdlCreateWindowM@ call+    -> m ()++  -- | Setup background color for window+  sdlSetBackColor :: +       Text -- ^ Window name that was used at @sdlCreateWindowM@ call+    -> V4 Word8 -- ^ Color to set+    -> m ()++  -- | Getting window shown events that occurs scince last frame+  sdlWindowShownEventsM :: m (Seq WindowShownEventData)+  -- | Getting window hidden events that occurs scince last frame+  sdlWindowHiddenEventsM :: m (Seq WindowHiddenEventData)+  -- | Getting window exposed events that occurs scince last frame+  sdlWindowExposedEventsM :: m (Seq WindowExposedEventData)+  -- | Getting window move events that occurs scince last frame+  sdlWindowMovedEventsM :: m (Seq WindowMovedEventData)+  -- | Getting window resize events that occurs scince last frame+  -- +  -- This is event is always preceded by WindowSizeChangedEvent.+  sdlWindowResizedEventsM :: m (Seq WindowResizedEventData)+  -- | Getting window resize events that occurs scince last frame+  --+  -- The window size has changed, either as a result of an API call or through the system or user changing the window size; this event is followed by WindowResizedEvent if the size was changed by an external event, i.e. the user or the window manager.+  sdlWindowSizeChangedEventsM :: m (Seq WindowSizeChangedEventData)+  -- | Getting window minimization events that occurs scince last frame+  sdlWindowMinimizedEventsM :: m (Seq WindowMinimizedEventData)+  -- | Getting window maximization events that occurs scince last frame+  sdlWindowMaximizedEventsM :: m (Seq WindowMaximizedEventData)+  -- | Getting window restore events that occurs scince last frame+  sdlWindowRestoredEventsM :: m (Seq WindowRestoredEventData)+  -- | Getting window focus events that occurs scince last frame+  sdlWindowGainedMouseFocusEventsM :: m (Seq WindowGainedMouseFocusEventData)+  -- | Getting window focus events that occurs scince last frame+  sdlWindowLostMouseFocusEventsM :: m (Seq WindowLostMouseFocusEventData)+  -- | Getting window focus events that occurs scince last frame+  sdlWindowGainedKeyboardFocusEventsM :: m (Seq WindowGainedKeyboardFocusEventData)+  -- | Getting window focus events that occurs scince last frame+  sdlWindowLostKeyboardFocusEventsM :: m (Seq WindowLostKeyboardFocusEventData)+  -- | Getting window close events that occurs scince last frame+  sdlWindowClosedEventsM :: m (Seq WindowClosedEventData)++  -- | Getting keyboard events that occurs scince last frame+  sdlKeyboardEventsM :: m (Seq KeyboardEventData)+  -- | Getting input API events that occurs scince last frame+  sdlTextEditingEventsM :: m (Seq TextEditingEventData)+  -- | Getting input API events that occurs scince last frame+  sdlTextInputEventsM :: m (Seq TextInputEventData)++  -- | Getting mouse events that occurs scince last frame+  sdlMouseMotionEventsM :: m (Seq MouseMotionEventData)+  -- | Getting mouse events that occurs scince last frame+  sdlMouseButtonEventsM :: m (Seq MouseButtonEventData)+  -- | Getting mouse events that occurs scince last frame+  sdlMouseWheelEventsM :: m (Seq MouseWheelEventData)++  -- | Getting joystick events that occurs scince last frame+  sdlJoyAxisEventsM :: m (Seq JoyAxisEventData)+  -- | Getting joystick events that occurs scince last frame+  sdlJoyBallEventsM :: m (Seq JoyBallEventData)+  -- | Getting joystick events that occurs scince last frame+  sdlJoyHatEventsM :: m (Seq JoyHatEventData)+  -- | Getting joystick events that occurs scince last frame+  sdlJoyButtonEventsM :: m (Seq JoyButtonEventData)+  -- | Getting joystick events that occurs scince last frame+  sdlJoyDeviceEventsM :: m (Seq JoyDeviceEventData)++  -- | Getting controller events that occurs scince last frame+  sdlControllerAxisEventsM :: m (Seq ControllerAxisEventData)+  -- | Getting controller events that occurs scince last frame+  sdlControllerButtonEventsM :: m (Seq ControllerButtonEventData)+  -- | Getting controller events that occurs scince last frame+  sdlControllerDeviceEventsM :: m (Seq ControllerDeviceEventData)++  -- | Getting quit request event+  sdlQuitEventM :: m Bool+  -- | Getting user events that occurs scince last frame+  sdlUserEventsM :: m (Seq UserEventData)+  -- | Getting video driver specific events that occurs scince last frame+  sdlSysWMEventsM :: m (Seq SysWMEventData)++  -- | Getting touch events that occurs scince last frame+  sdlTouchFingerEventsM :: m (Seq TouchFingerEventData)+  -- | Getting touch events that occurs scince last frame+  sdlMultiGestureEventsM :: m (Seq MultiGestureEventData)+  -- | Getting touch events that occurs scince last frame+  sdlDollarGestureEventsM :: m (Seq DollarGestureEventData)++  -- | Getting file opened events that occurs scince last frame+  sdlDropEventsM :: m (Seq DropEventData)+  -- | Getting clipboard changed events that occurs scince last frame+  sdlClipboardUpdateEventsM :: m (Seq ClipboardUpdateEventData)++instance {-# OVERLAPPING #-} (MonadIO m, MonadThrow m) => MonadSDL (SDLT s m) where+  sdlCreateWindowM n t wc rc = do +    w <- createWindow t wc+    r <- createRenderer w (-1) rc+    s <- SDLT get+    case H.lookup n . sdlWindows $! s of +      Just _ -> throwM . SDL'ConflictingWindows $! n+      Nothing -> do+        SDLT . put $! s {+            sdlWindows = H.insert n (w, r, defColor) . sdlWindows $! s+          }+        return (w, r)+    where +      defColor = V4 0 0 0 255++  sdlGetWindowM n = do +    s <- SDLT get +    return . fmap (\(w, r, _) -> (w, r)) . H.lookup n . sdlWindows $! s ++  sdlDestroyWindowM n = do +    s <- SDLT get +    case H.lookup n . sdlWindows $! s of +      Just (w, r, _) -> do +        destroyRenderer r +        destroyWindow w+        SDLT . put $! s {+          sdlWindows = H.delete n . sdlWindows $! s+        }+      Nothing -> return ()++  sdlSetBackColor n c = do +    s <- SDLT get +    case H.lookup n . sdlWindows $! s of +      Just (w, r, _) -> SDLT . put $! s {+          sdlWindows = H.insert n (w, r, c) . sdlWindows $! s +        }+      Nothing -> return ()++  sdlWindowShownEventsM = sdlWindowShownEvents <$> get+  sdlWindowHiddenEventsM = sdlWindowHiddenEvents <$> get+  sdlWindowExposedEventsM = sdlWindowExposedEvents <$> get+  sdlWindowMovedEventsM = sdlWindowMovedEvents <$> get+  sdlWindowResizedEventsM = sdlWindowResizedEvents <$> get+  sdlWindowSizeChangedEventsM = sdlWindowSizeChangedEvents <$> get+  sdlWindowMinimizedEventsM = sdlWindowMinimizedEvents <$> get+  sdlWindowMaximizedEventsM = sdlWindowMaximizedEvents <$> get+  sdlWindowRestoredEventsM = sdlWindowRestoredEvents <$> get+  sdlWindowGainedMouseFocusEventsM = sdlWindowGainedMouseFocusEvents <$> get+  sdlWindowLostMouseFocusEventsM = sdlWindowLostMouseFocusEvents <$> get+  sdlWindowGainedKeyboardFocusEventsM = sdlWindowGainedKeyboardFocusEvents <$> get+  sdlWindowLostKeyboardFocusEventsM = sdlWindowLostKeyboardFocusEvents <$> get+  sdlWindowClosedEventsM = sdlWindowClosedEvents <$> get+  sdlKeyboardEventsM = sdlKeyboardEvents <$> get+  sdlTextEditingEventsM = sdlTextEditingEvents <$> get+  sdlTextInputEventsM = sdlTextInputEvents <$> get+  sdlMouseMotionEventsM = sdlMouseMotionEvents <$> get+  sdlMouseButtonEventsM = sdlMouseButtonEvents <$> get+  sdlMouseWheelEventsM = sdlMouseWheelEvents <$> get+  sdlJoyAxisEventsM = sdlJoyAxisEvents <$> get+  sdlJoyBallEventsM = sdlJoyBallEvents <$> get+  sdlJoyHatEventsM = sdlJoyHatEvents <$> get+  sdlJoyButtonEventsM = sdlJoyButtonEvents <$> get+  sdlJoyDeviceEventsM = sdlJoyDeviceEvents <$> get+  sdlControllerAxisEventsM = sdlControllerAxisEvents <$> get+  sdlControllerButtonEventsM = sdlControllerButtonEvents <$> get+  sdlControllerDeviceEventsM = sdlControllerDeviceEvents <$> get+  sdlQuitEventM = sdlQuitEvent <$> get+  sdlUserEventsM = sdlUserEvents <$> get+  sdlSysWMEventsM = sdlSysWMEvents <$> get+  sdlTouchFingerEventsM = sdlTouchFingerEvents <$> get+  sdlMultiGestureEventsM = sdlMultiGestureEvents <$> get+  sdlDollarGestureEventsM = sdlDollarGestureEvents <$> get+  sdlDropEventsM = sdlDropEvents <$> get+  sdlClipboardUpdateEventsM = sdlClipboardUpdateEvents <$> get++instance {-# OVERLAPPABLE #-} (MonadIO (mt m), MonadThrow (mt m), MonadSDL m, MonadTrans mt) => MonadSDL (mt m) where +  sdlCreateWindowM n t wc rc = lift $ sdlCreateWindowM n t wc rc+  sdlGetWindowM = lift . sdlGetWindowM+  sdlDestroyWindowM = lift . sdlDestroyWindowM+  sdlSetBackColor a b = lift $ sdlSetBackColor a b ++  sdlWindowShownEventsM = lift sdlWindowShownEventsM+  sdlWindowHiddenEventsM = lift sdlWindowHiddenEventsM+  sdlWindowExposedEventsM = lift sdlWindowExposedEventsM+  sdlWindowMovedEventsM = lift sdlWindowMovedEventsM+  sdlWindowResizedEventsM = lift sdlWindowResizedEventsM+  sdlWindowSizeChangedEventsM = lift sdlWindowSizeChangedEventsM+  sdlWindowMinimizedEventsM = lift sdlWindowMinimizedEventsM+  sdlWindowMaximizedEventsM = lift sdlWindowMaximizedEventsM+  sdlWindowRestoredEventsM = lift sdlWindowRestoredEventsM+  sdlWindowGainedMouseFocusEventsM = lift sdlWindowGainedMouseFocusEventsM+  sdlWindowLostMouseFocusEventsM = lift sdlWindowLostMouseFocusEventsM+  sdlWindowGainedKeyboardFocusEventsM = lift sdlWindowGainedKeyboardFocusEventsM+  sdlWindowLostKeyboardFocusEventsM = lift sdlWindowLostKeyboardFocusEventsM+  sdlWindowClosedEventsM = lift sdlWindowClosedEventsM+  sdlKeyboardEventsM = lift sdlKeyboardEventsM+  sdlTextEditingEventsM = lift sdlTextEditingEventsM+  sdlTextInputEventsM = lift sdlTextInputEventsM+  sdlMouseMotionEventsM = lift sdlMouseMotionEventsM+  sdlMouseButtonEventsM = lift sdlMouseButtonEventsM+  sdlMouseWheelEventsM = lift sdlMouseWheelEventsM+  sdlJoyAxisEventsM = lift sdlJoyAxisEventsM+  sdlJoyBallEventsM = lift sdlJoyBallEventsM+  sdlJoyHatEventsM = lift sdlJoyHatEventsM+  sdlJoyButtonEventsM = lift sdlJoyButtonEventsM+  sdlJoyDeviceEventsM = lift sdlJoyDeviceEventsM+  sdlControllerAxisEventsM = lift sdlControllerAxisEventsM+  sdlControllerButtonEventsM = lift sdlControllerButtonEventsM+  sdlControllerDeviceEventsM = lift sdlControllerDeviceEventsM+  sdlQuitEventM = lift sdlQuitEventM+  sdlUserEventsM = lift sdlUserEventsM+  sdlSysWMEventsM = lift sdlSysWMEventsM+  sdlTouchFingerEventsM = lift sdlTouchFingerEventsM+  sdlMultiGestureEventsM = lift sdlMultiGestureEventsM+  sdlDollarGestureEventsM = lift sdlDollarGestureEventsM+  sdlDropEventsM = lift sdlDropEventsM+  sdlClipboardUpdateEventsM = lift sdlClipboardUpdateEventsM++-- | Fires when specific scancode key is pressed/unpressed+keyScancode :: MonadSDL m => Scancode -> InputMotion -> GameWire m a (Event (Seq KeyboardEventData))+keyScancode sc im = liftGameMonad $ do +  es <- S.filter isNeeded <$> sdlKeyboardEventsM+  return $! if S.null es +    then NoEvent+    else Event es +  where+    isNeeded KeyboardEventData{..} = keyboardEventKeyMotion == im +      && sc == keysymScancode keyboardEventKeysym ++-- | Fires when specific scancode key is pressed+keyPress :: MonadSDL m => Scancode -> GameWire m a (Event (Seq KeyboardEventData))+keyPress sc = keyScancode sc Pressed ++-- | Fires when specific scancode key is released+keyRelease :: MonadSDL m => Scancode -> GameWire m a (Event (Seq KeyboardEventData))+keyRelease sc = keyScancode sc Released ++-- | Fires event from moment of press until release of given key+keyPressing :: MonadSDL m => Scancode -> GameWire m a (Event KeyboardEventData)+keyPressing sc = go NoEvent +  where+    go !e = mkGen $ \_ _ -> do +      !mks <- S.viewr . S.filter isNeeded <$> sdlKeyboardEventsM+      return $! case mks of +        S.EmptyR -> (Right e, go e)+        _ S.:> mds@KeyboardEventData{..} -> case keyboardEventKeyMotion of +          Pressed -> (Right $! Event mds, go $! Event mds)+          Released -> (Right NoEvent, go NoEvent)++    isNeeded KeyboardEventData{..} = sc == keysymScancode keyboardEventKeysym   ++-- | Returns accumulated mouse scroll scince last frame+mouseScroll :: MonadSDL m => GameWire m a (Event (V2 Int32))+mouseScroll = liftGameMonad $ do +  es <- sdlMouseWheelEventsM+  return $! if S.null es +    then NoEvent+    else Event . sumV . fmap mouseWheelEventPos $! es++-- | Returns accumulated mouse scroll scince last frame+mouseScrollX :: MonadSDL m => GameWire m a (Event Int32)+mouseScrollX = mapE (^. _x) . mouseScroll++-- | Returns accumulated mouse scroll scince last frame+mouseScrollY :: MonadSDL m => GameWire m a (Event Int32)+mouseScrollY = mapE (^. _y) . mouseScroll++-- | Fires when window with specific name is closed+windowClosed :: MonadSDL m => Text -> GameWire m a (Event ())+windowClosed n = go Nothing +  where+  go Nothing = mkGen $ \_ _ -> do +    mr <- sdlGetWindowM n+    return $! case mr of +      Nothing -> (Right NoEvent, go Nothing)+      Just (w, _) -> (Right NoEvent, go $ Just w)+  go (Just w) = liftGameMonad $ do +    es <- S.filter isNeeded <$> sdlWindowClosedEventsM+    return $! if S.null es +      then NoEvent+      else Event ()+    where+      isNeeded WindowClosedEventData{..} = windowClosedEventWindow == w++-- | Fires when user clicks within window. Click coordinates are in [-1 .. 1] range+mouseClick :: MonadSDL m => MouseButton -> GameWire m a (Event (V2 Double))+mouseClick mb = liftGameMonad $ do +  es <- S.filter isNeeded <$> sdlMouseButtonEventsM+  case S.viewr es of +    S.EmptyR -> return NoEvent+    _ S.:> MouseButtonEventData{..} -> do+      (size :: V2 Int) <- getWindowSize mouseButtonEventWindow+      return . Event $! transformCoords size mouseButtonEventPos+  where+    isNeeded MouseButtonEventData{..} = mouseButtonEventButton == mb && mouseButtonEventMotion == Pressed+    transformCoords (V2 w h) (P (V2 xi yi)) = +      inv33 (viewportTransform2D 0 (V2 (fromIntegral w) (fromIntegral h)))+      `applyTransform2D`+      V2 (fromIntegral xi) (fromIntegral yi)++-- | Helper to hide pointer manipulation while getting window size+getWindowSize :: (MonadIO m, Integral a) => Window -> m (V2 a)+getWindowSize (Window wptr) = liftIO $ with 0 $ \xptr -> with 0 $ \yptr -> do +  SDLRaw.getWindowSize wptr xptr yptr+  x <- peek xptr +  y <- peek yptr +  return $! V2 (fromIntegral x) (fromIntegral y)
+ src/Game/GoreAndAsh/SDL/Module.hs view
@@ -0,0 +1,124 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-|+Module      : Game.GoreAndAsh.SDL.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.SDL.Module(+    SDLT(..)+  ) where++import Control.Monad.Catch+import Control.Monad.Fix +import Control.Monad.IO.Class +import Control.Monad.State.Strict+import qualified Data.Foldable as F +import qualified Data.HashMap.Strict as H +import qualified Data.Sequence as S ++import SDL++import Game.GoreAndAsh+import Game.GoreAndAsh.SDL.State++-- | Monad transformer of SDL core module.+--+-- [@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 [SDLT, ... 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 SDLT s m a = SDLT { runSDLT :: StateT (SDLState s) m a }+  deriving (Functor, Applicative, Monad, MonadState (SDLState s), MonadFix, MonadTrans, MonadIO, MonadThrow, MonadCatch, MonadMask)++instance GameModule m s => GameModule (SDLT s m) (SDLState s) where +  type ModuleState (SDLT s m) = SDLState s+  runModule (SDLT m) s = do+    s' <- processEvents s +    clearWindows s'+    ((a, s''), nextState) <- runModule (runStateT m s') (sdlNextState s')+    drawWindows s''+    return (a, flashSDLState $ s'' { +        sdlNextState = nextState+      })++  newModuleState = emptySDLState <$> newModuleState+  withModule _ io = initializeAll >> io+  cleanupModule _ = quit++-- | Takes all window and renderers and update them+drawWindows :: MonadIO m => SDLState s -> m ()+drawWindows SDLState{..} = mapM_ go . H.elems $! sdlWindows+  where +  go (_, r, _) = present r ++-- | Clear surface of all windows+clearWindows :: MonadIO m => SDLState s -> m ()+clearWindows SDLState{..} = mapM_ go . H.elems $! sdlWindows+  where +  go (_, r, c) = do +    rendererDrawColor r $= c+    clear r++-- | Catch all SDL events+processEvents :: MonadIO m => SDLState s -> m (SDLState s)+processEvents sdlState = do +  es <- pollEvents+  return $! F.foldl' process sdlState (eventPayload <$> es)+  where +  process s e = case e of +    WindowShownEvent d -> s { sdlWindowShownEvents = sdlWindowShownEvents s S.|> d }+    WindowHiddenEvent d -> s { sdlWindowHiddenEvents = sdlWindowHiddenEvents s S.|> d }+    WindowExposedEvent d -> s { sdlWindowExposedEvents = sdlWindowExposedEvents s S.|> d }+    WindowMovedEvent d -> s { sdlWindowMovedEvents = sdlWindowMovedEvents s S.|> d }+    WindowResizedEvent d -> s { sdlWindowResizedEvents = sdlWindowResizedEvents s S.|> d }+    WindowSizeChangedEvent d -> s { sdlWindowSizeChangedEvents = sdlWindowSizeChangedEvents s S.|> d }+    WindowMinimizedEvent d -> s { sdlWindowMinimizedEvents = sdlWindowMinimizedEvents s S.|> d }+    WindowMaximizedEvent d -> s { sdlWindowMaximizedEvents = sdlWindowMaximizedEvents s S.|> d }+    WindowRestoredEvent d -> s { sdlWindowRestoredEvents = sdlWindowRestoredEvents s S.|> d }+    WindowGainedMouseFocusEvent d -> s { sdlWindowGainedMouseFocusEvents = sdlWindowGainedMouseFocusEvents s S.|> d }+    WindowLostMouseFocusEvent d -> s { sdlWindowLostMouseFocusEvents = sdlWindowLostMouseFocusEvents s S.|> d }+    WindowGainedKeyboardFocusEvent d -> s { sdlWindowGainedKeyboardFocusEvents = sdlWindowGainedKeyboardFocusEvents s S.|> d }+    WindowLostKeyboardFocusEvent d -> s { sdlWindowLostKeyboardFocusEvents = sdlWindowLostKeyboardFocusEvents s S.|> d }+    WindowClosedEvent d -> s { sdlWindowClosedEvents = sdlWindowClosedEvents s S.|> d }+    KeyboardEvent d -> s { sdlKeyboardEvents = sdlKeyboardEvents s S.|> d }+    TextEditingEvent d -> s { sdlTextEditingEvents = sdlTextEditingEvents s S.|> d }+    TextInputEvent d -> s { sdlTextInputEvents = sdlTextInputEvents s S.|> d }+    MouseMotionEvent d -> s { sdlMouseMotionEvents = sdlMouseMotionEvents s S.|> d }+    MouseButtonEvent d -> s { sdlMouseButtonEvents = sdlMouseButtonEvents s S.|> d }+    MouseWheelEvent d -> s { sdlMouseWheelEvents = sdlMouseWheelEvents s S.|> d }+    JoyAxisEvent d -> s { sdlJoyAxisEvents = sdlJoyAxisEvents s S.|> d }+    JoyBallEvent d -> s { sdlJoyBallEvents = sdlJoyBallEvents s S.|> d }+    JoyHatEvent d -> s { sdlJoyHatEvents = sdlJoyHatEvents s S.|> d }+    JoyButtonEvent d -> s { sdlJoyButtonEvents = sdlJoyButtonEvents s S.|> d }+    JoyDeviceEvent d -> s { sdlJoyDeviceEvents = sdlJoyDeviceEvents s S.|> d }+    ControllerAxisEvent d -> s { sdlControllerAxisEvents = sdlControllerAxisEvents s S.|> d }+    ControllerButtonEvent d -> s { sdlControllerButtonEvents = sdlControllerButtonEvents s S.|> d }+    ControllerDeviceEvent d -> s { sdlControllerDeviceEvents = sdlControllerDeviceEvents s S.|> d }+    QuitEvent -> s { sdlQuitEvent = True }+    UserEvent d -> s { sdlUserEvents = sdlUserEvents s S.|> d }+    SysWMEvent d -> s { sdlSysWMEvents = sdlSysWMEvents s S.|> d }+    TouchFingerEvent d -> s { sdlTouchFingerEvents = sdlTouchFingerEvents s S.|> d }+    MultiGestureEvent d -> s { sdlMultiGestureEvents = sdlMultiGestureEvents s S.|> d }+    DollarGestureEvent d -> s { sdlDollarGestureEvents = sdlDollarGestureEvents s S.|> d }+    DropEvent d -> s { sdlDropEvents = sdlDropEvents s S.|> d }+    ClipboardUpdateEvent d -> s { sdlClipboardUpdateEvents = sdlClipboardUpdateEvents s S.|> d }+    _ -> s
+ src/Game/GoreAndAsh/SDL/State.hs view
@@ -0,0 +1,222 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-|+Module      : Game.GoreAndAsh.SDL.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.SDL.State(+    SDLState(..)+  , emptySDLState+  , flashSDLState+  ) where++import Control.DeepSeq +import Data.Text +import Data.Word+import GHC.Generics (Generic)+import Linear++import SDL.Event +import SDL.Input.Keyboard+import SDL.Input.Mouse+import SDL.Internal.Types++import Data.Sequence (Seq)+import qualified Data.Sequence as S ++import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as H ++-- | Inner state of SDL module.+--+-- [@s@] - State of next module, the states are chained via nesting.+data SDLState s = SDLState {+  sdlNextState :: !s+, sdlWindows :: !(HashMap Text (Window, Renderer, V4 Word8))++, sdlWindowShownEvents :: !(Seq WindowShownEventData)+, sdlWindowHiddenEvents :: !(Seq WindowHiddenEventData)+, sdlWindowExposedEvents :: !(Seq WindowExposedEventData)+, sdlWindowMovedEvents :: !(Seq WindowMovedEventData)+, sdlWindowResizedEvents :: !(Seq WindowResizedEventData)+, sdlWindowSizeChangedEvents :: !(Seq WindowSizeChangedEventData)+, sdlWindowMinimizedEvents :: !(Seq WindowMinimizedEventData)+, sdlWindowMaximizedEvents :: !(Seq WindowMaximizedEventData)+, sdlWindowRestoredEvents :: !(Seq WindowRestoredEventData)+, sdlWindowGainedMouseFocusEvents :: !(Seq WindowGainedMouseFocusEventData)+, sdlWindowLostMouseFocusEvents :: !(Seq WindowLostMouseFocusEventData)+, sdlWindowGainedKeyboardFocusEvents :: !(Seq WindowGainedKeyboardFocusEventData)+, sdlWindowLostKeyboardFocusEvents :: !(Seq WindowLostKeyboardFocusEventData)+, sdlWindowClosedEvents :: !(Seq WindowClosedEventData)+, sdlKeyboardEvents :: !(Seq KeyboardEventData)+, sdlTextEditingEvents :: !(Seq TextEditingEventData)+, sdlTextInputEvents :: !(Seq TextInputEventData)+, sdlMouseMotionEvents :: !(Seq MouseMotionEventData)+, sdlMouseButtonEvents :: !(Seq MouseButtonEventData)+, sdlMouseWheelEvents :: !(Seq MouseWheelEventData)+, sdlJoyAxisEvents :: !(Seq JoyAxisEventData)+, sdlJoyBallEvents :: !(Seq JoyBallEventData)+, sdlJoyHatEvents :: !(Seq JoyHatEventData)+, sdlJoyButtonEvents :: !(Seq JoyButtonEventData)+, sdlJoyDeviceEvents :: !(Seq JoyDeviceEventData)+, sdlControllerAxisEvents :: !(Seq ControllerAxisEventData)+, sdlControllerButtonEvents :: !(Seq ControllerButtonEventData)+, sdlControllerDeviceEvents :: !(Seq ControllerDeviceEventData)+, sdlQuitEvent :: !Bool+, sdlUserEvents :: !(Seq UserEventData)+, sdlSysWMEvents :: !(Seq SysWMEventData)+, sdlTouchFingerEvents :: !(Seq TouchFingerEventData)+, sdlMultiGestureEvents :: !(Seq MultiGestureEventData)+, sdlDollarGestureEvents :: !(Seq DollarGestureEventData)+, sdlDropEvents :: !(Seq DropEventData)+, sdlClipboardUpdateEvents :: !(Seq ClipboardUpdateEventData)+} deriving (Generic)++instance NFData s => NFData (SDLState s)+instance NFData WindowShownEventData +instance NFData WindowHiddenEventData+instance NFData WindowExposedEventData +instance NFData WindowMovedEventData +instance NFData WindowResizedEventData +instance NFData WindowSizeChangedEventData +instance NFData WindowMinimizedEventData +instance NFData WindowMaximizedEventData +instance NFData WindowRestoredEventData +instance NFData WindowGainedMouseFocusEventData +instance NFData WindowLostMouseFocusEventData +instance NFData WindowGainedKeyboardFocusEventData +instance NFData WindowLostKeyboardFocusEventData +instance NFData WindowClosedEventData +instance NFData KeyboardEventData +instance NFData TextEditingEventData +instance NFData TextInputEventData +instance NFData MouseMotionEventData +instance NFData MouseButtonEventData +instance NFData MouseWheelEventData +instance NFData JoyAxisEventData +instance NFData JoyBallEventData +instance NFData JoyHatEventData +instance NFData JoyButtonEventData +instance NFData JoyDeviceEventData +instance NFData ControllerAxisEventData +instance NFData ControllerButtonEventData +instance NFData ControllerDeviceEventData+instance NFData TouchFingerEventData +instance NFData MultiGestureEventData +instance NFData DollarGestureEventData +instance NFData ClipboardUpdateEventData+instance NFData Keysym+instance NFData MouseButton+instance NFData InputMotion+instance NFData Scancode+instance NFData MouseDevice +instance NFData Keycode +instance NFData KeyModifier++instance NFData Window where+  rnf = (`seq` ())++instance NFData Renderer where+  rnf = (`seq` ())++instance NFData SysWMEventData where+  rnf SysWMEventData{..} = sysWMEventMsg `seq` ()++instance NFData UserEventData where+  rnf UserEventData{..} = userEventWindow +    `seq` userEventCode+    `seq` userEventData1+    `seq` userEventData2+    `seq` ()++instance NFData DropEventData where+  rnf DropEventData{..} = dropEventFile `seq` ()++-- | Creates empty module state+emptySDLState :: s -> SDLState s +emptySDLState s = SDLState {+    sdlNextState = s+  , sdlWindows = H.empty ++  , sdlWindowShownEvents = S.empty+  , sdlWindowHiddenEvents = S.empty+  , sdlWindowExposedEvents = S.empty+  , sdlWindowMovedEvents = S.empty+  , sdlWindowResizedEvents = S.empty+  , sdlWindowSizeChangedEvents = S.empty+  , sdlWindowMinimizedEvents = S.empty+  , sdlWindowMaximizedEvents = S.empty+  , sdlWindowRestoredEvents = S.empty+  , sdlWindowGainedMouseFocusEvents = S.empty+  , sdlWindowLostMouseFocusEvents = S.empty+  , sdlWindowGainedKeyboardFocusEvents = S.empty+  , sdlWindowLostKeyboardFocusEvents = S.empty+  , sdlWindowClosedEvents = S.empty+  , sdlKeyboardEvents = S.empty+  , sdlTextEditingEvents = S.empty+  , sdlTextInputEvents = S.empty+  , sdlMouseMotionEvents = S.empty+  , sdlMouseButtonEvents = S.empty+  , sdlMouseWheelEvents = S.empty+  , sdlJoyAxisEvents = S.empty+  , sdlJoyBallEvents = S.empty+  , sdlJoyHatEvents = S.empty+  , sdlJoyButtonEvents = S.empty+  , sdlJoyDeviceEvents = S.empty+  , sdlControllerAxisEvents = S.empty+  , sdlControllerButtonEvents = S.empty+  , sdlControllerDeviceEvents = S.empty+  , sdlQuitEvent = False+  , sdlUserEvents = S.empty+  , sdlSysWMEvents = S.empty+  , sdlTouchFingerEvents = S.empty+  , sdlMultiGestureEvents = S.empty+  , sdlDollarGestureEvents = S.empty+  , sdlDropEvents = S.empty+  , sdlClipboardUpdateEvents = S.empty+  }++-- | After full cycle of simulation all events are dropped+flashSDLState :: SDLState s -> SDLState s +flashSDLState s = s {+    sdlWindowShownEvents = S.empty+  , sdlWindowHiddenEvents = S.empty+  , sdlWindowExposedEvents = S.empty+  , sdlWindowMovedEvents = S.empty+  , sdlWindowResizedEvents = S.empty+  , sdlWindowSizeChangedEvents = S.empty+  , sdlWindowMinimizedEvents = S.empty+  , sdlWindowMaximizedEvents = S.empty+  , sdlWindowRestoredEvents = S.empty+  , sdlWindowGainedMouseFocusEvents = S.empty+  , sdlWindowLostMouseFocusEvents = S.empty+  , sdlWindowGainedKeyboardFocusEvents = S.empty+  , sdlWindowLostKeyboardFocusEvents = S.empty+  , sdlWindowClosedEvents = S.empty+  , sdlKeyboardEvents = S.empty+  , sdlTextEditingEvents = S.empty+  , sdlTextInputEvents = S.empty+  , sdlMouseMotionEvents = S.empty+  , sdlMouseButtonEvents = S.empty+  , sdlMouseWheelEvents = S.empty+  , sdlJoyAxisEvents = S.empty+  , sdlJoyBallEvents = S.empty+  , sdlJoyHatEvents = S.empty+  , sdlJoyButtonEvents = S.empty+  , sdlJoyDeviceEvents = S.empty+  , sdlControllerAxisEvents = S.empty+  , sdlControllerButtonEvents = S.empty+  , sdlControllerDeviceEvents = S.empty+  , sdlQuitEvent = False+  , sdlUserEvents = S.empty+  , sdlSysWMEvents = S.empty+  , sdlTouchFingerEvents = S.empty+  , sdlMultiGestureEvents = S.empty+  , sdlDollarGestureEvents = S.empty+  , sdlDropEvents = S.empty+  , sdlClipboardUpdateEvents = S.empty+  }