aztecs-sdl 0.1.0.0 → 0.2.0.0
raw patch · 5 files changed
+472/−176 lines, 5 filesdep −sdl2-imagedep ~basedep ~containersnew-component:exe:keyboardnew-component:exe:mouse
Dependencies removed: sdl2-image
Dependency ranges changed: base, containers
Files
- aztecs-sdl.cabal +31/−5
- examples/Keyboard.hs +26/−0
- examples/Mouse.hs +26/−0
- examples/Window.hs +8/−28
- src/Data/Aztecs/SDL.hs +381/−143
aztecs-sdl.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: aztecs-sdl-version: 0.1.0.0+version: 0.2.0.0 license: BSD-3-Clause license-file: LICENSE maintainer: matt@hunzinger.me@@ -26,24 +26,50 @@ default-language: Haskell2010 ghc-options: -Wall build-depends:- base >=4 && <5,+ base >=4.6 && <5, aztecs >= 0.3, aztecs-asset >= 0.1, aztecs-transform >= 0.1,- containers >=0.7,+ containers >=0.6, mtl >=2, sdl2 >=2,- sdl2-image >=2, text >=1.2, linear >= 1 +executable keyboard+ main-is: Keyboard.hs+ hs-source-dirs: examples+ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base >=4.6 && <5,+ aztecs-sdl,+ aztecs >= 0.3,+ aztecs-asset >= 0.1,+ aztecs-transform >= 0.1,+ sdl2 >=2+++executable mouse+ main-is: Mouse.hs+ hs-source-dirs: examples+ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base >=4.6 && <5,+ aztecs-sdl,+ aztecs >= 0.3,+ aztecs-asset >= 0.1,+ aztecs-transform >= 0.1,+ sdl2 >=2+ executable window main-is: Window.hs hs-source-dirs: examples default-language: Haskell2010 ghc-options: -Wall build-depends:- base >=4 && <5,+ base >=4.6 && <5, aztecs-sdl, aztecs >= 0.3, aztecs-asset >= 0.1,
+ examples/Keyboard.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeApplications #-}++module Main where++import Control.Arrow ((>>>))+import Data.Aztecs+import qualified Data.Aztecs.Access as A+import qualified Data.Aztecs.Query as Q+import Data.Aztecs.SDL (KeyboardInput, Window (..))+import qualified Data.Aztecs.SDL as SDL+import qualified Data.Aztecs.System as S++setup :: System () ()+setup = S.queue . const . A.spawn_ $ bundle Window {windowTitle = "Aztecs"}++update :: System () ()+update = S.all (Q.fetch @_ @KeyboardInput) >>> S.task print++main :: IO ()+main =+ runSchedule_ $+ schedule SDL.setup+ >>> schedule setup+ >>> forever (schedule SDL.update >>> schedule update >>> schedule SDL.draw)
+ examples/Mouse.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE Arrows #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeApplications #-}++module Main where++import Control.Arrow ((>>>))+import Data.Aztecs+import qualified Data.Aztecs.Access as A+import qualified Data.Aztecs.Query as Q+import Data.Aztecs.SDL (MouseInput, Window (..))+import qualified Data.Aztecs.SDL as SDL+import qualified Data.Aztecs.System as S++setup :: System () ()+setup = S.queue . const . A.spawn_ $ bundle Window {windowTitle = "Aztecs"}++update :: System () ()+update = S.all (Q.fetch @_ @MouseInput) >>> S.task print++main :: IO ()+main =+ runSchedule_ $+ schedule SDL.setup+ >>> schedule setup+ >>> forever (schedule SDL.update >>> schedule update >>> schedule SDL.draw)
examples/Window.hs view
@@ -4,39 +4,19 @@ module Main where -import Control.Arrow (returnA, (>>>))+import Control.Arrow ((>>>)) import Data.Aztecs import qualified Data.Aztecs.Access as A-import Data.Aztecs.Asset (load)-import qualified Data.Aztecs.Query as Q-import Data.Aztecs.SDL (Image (..), Window (..))+import Data.Aztecs.SDL (Window (..)) import qualified Data.Aztecs.SDL as SDL import qualified Data.Aztecs.System as S-import Data.Aztecs.Transform (Transform (..), transform)-import SDL (V2 (..)) setup :: System () ()-setup =- S.mapSingle- ( proc () -> do- assetServer <- Q.fetch -< ()- (texture, assetServer') <- Q.run (load "example.png") -< assetServer- Q.set -< assetServer'- returnA -< texture- )- >>> S.queue- ( \texture -> do- A.spawn_ $ bundle Window {windowTitle = "Aztecs"}- A.spawn_ $- bundle Image {imageTexture = texture, imageSize = V2 100 100}- <> bundle transform {transformPosition = V2 100 100}- A.spawn_ $- bundle Image {imageTexture = texture, imageSize = V2 200 200}- <> bundle transform {transformPosition = V2 500 100}- )--update :: System () ()-update = S.all (Q.fetch @_ @SDL.Keyboard) >>> S.run (\keyboard -> print keyboard)+setup = S.queue . const . A.spawn_ $ bundle Window {windowTitle = "Aztecs"} main :: IO ()-main = runSystem_ $ SDL.setup >>> setup >>> S.forever (SDL.update >>> update >>> SDL.draw)+main =+ runSchedule_ $+ schedule SDL.setup+ >>> schedule setup+ >>> forever (schedule SDL.update >>> schedule SDL.draw)
src/Data/Aztecs/SDL.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE Arrows #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -7,28 +8,77 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -module Data.Aztecs.SDL where+module Data.Aztecs.SDL+ ( -- * Window components+ Window (..),+ WindowRenderer (..), + -- * Camera components+ Camera (..),+ CameraTarget (..),++ -- * Surface components+ Surface (..),+ SurfaceTarget (..),+ SurfaceTexture (..),++ -- * Input++ -- ** Keyboard input+ KeyboardInput (..),+ isKeyPressed,+ wasKeyPressed,+ wasKeyReleased,++ -- ** Mouse input+ MouseInput (..),++ -- * Time+ Time (..),++ -- * Systems+ setup,+ update,+ draw,++ -- ** Primitive systems+ addWindows,+ buildTextures,+ drawTextures,+ addCameraTargets,+ addSurfaceTargets,+ handleInput,+ updateTime,+ clearKeyboard,+ clearKeyboardQuery,+ clearMouseInput,+ clearMouseInputQuery,+ )+where+ import Control.Arrow (Arrow (..), returnA, (>>>)) import Data.Aztecs import qualified Data.Aztecs.Access as A-import Data.Aztecs.Asset (Asset (..), AssetServer, Handle, lookupAsset)-import qualified Data.Aztecs.Asset as Asset import qualified Data.Aztecs.Query as Q import qualified Data.Aztecs.System as S-import Data.Aztecs.Transform (Transform (..))-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Maybe (mapMaybe)+import Data.Aztecs.Transform (Size (..), Transform (..))+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Set (Set)+import qualified Data.Set as Set import qualified Data.Text as T-import Foreign.C (CInt)-import SDL hiding (Texture, Window, windowTitle)-import qualified SDL hiding (Texture)-import qualified SDL.Image as IMG+import Data.Word (Word32)+import SDL hiding (Surface, Texture, Window, windowTitle)+import qualified SDL +#if !MIN_VERSION_base(4,20,0)+import Data.Foldable (foldl')+#endif+ -- | Window component. data Window = Window- { windowTitle :: String+ { windowTitle :: !String } deriving (Show) @@ -36,37 +86,56 @@ -- | Window renderer component. data WindowRenderer = WindowRenderer- { windowRendererRaw :: SDL.Window,- windowRenderer :: Renderer+ { windowRendererRaw :: !SDL.Window,+ windowRenderer :: !Renderer } deriving (Show) instance Component WindowRenderer +data Camera = Camera {cameraViewport :: !(V2 Int), cameraScale :: !(V2 Float)}+ deriving (Show)++instance Component Camera++newtype CameraTarget = CameraTarget {cameraTargetWindow :: EntityID}+ deriving (Eq, Show)++instance Component CameraTarget+ -- | Setup SDL setup :: System () () setup = fmap (const ()) $- Asset.setup @Texture- &&& S.run (const initializeAll)- &&& S.queue (const . A.spawn_ . bundle $ Keyboard mempty)+ S.task (const initializeAll)+ &&& S.queue+ ( const $ do+ A.spawn_ . bundle $ Time 0+ A.spawn_ . bundle $ KeyboardInput mempty mempty+ A.spawn_ . bundle $ MouseInput (P $ V2 0 0) (V2 0 0) mempty+ ) -- | Update SDL windows update :: System () () update =- addWindows- >>> addWindowTargets- >>> Asset.loadAssets @Texture- >>> keyboardInput+ const ()+ <$> ( updateTime+ &&& ( addWindows+ >>> addCameraTargets+ >>> addSurfaceTargets+ >>> handleInput+ >>> buildTextures+ )+ ) draw :: System () ()-draw = drawImages >>> renderWindows+draw = const () <$> (drawTextures &&& clearKeyboard &&& clearMouseInput) -- | Setup new windows. addWindows :: System () () addWindows = proc () -> do newWindows <- S.filter (Q.entity &&& Q.fetch @_ @Window) (without @WindowRenderer) -< ()- newWindows' <- S.run createNewWindows -< newWindows+ newWindows' <- S.task createNewWindows -< newWindows S.queue insertNewWindows -< newWindows' where createNewWindows newWindows = mapM createWindowRenderer newWindows@@ -77,164 +146,333 @@ insertNewWindows newWindows' = mapM_ insertWindowRenderer newWindows' insertWindowRenderer (eId, window, renderer) = A.insert eId (WindowRenderer window renderer) --- | Render windows.-renderWindows :: System () ()-renderWindows =+newtype SurfaceTexture = SurfaceTexture {unSurfaceTexture :: SDL.Texture}++instance Component SurfaceTexture++buildTextures :: System () ()+buildTextures = let go windowDraws = mapM_- ( \(window, draws) -> do- let renderer = windowRenderer window- rendererDrawColor renderer $= V4 0 0 0 255- clear renderer- mapM_ (\(d, transform) -> runDraw d transform renderer) draws- present renderer+ ( \(window, cameraDraws) -> do+ mapM_+ ( \(_, cameraDraws') -> do+ let renderer = windowRenderer window+ mapM_+ ( \(eId, surface, transform, maybeTexture) -> do+ sdlTexture <- SDL.createTextureFromSurface renderer $ sdlSurface surface+ textureDesc <- queryTexture sdlTexture+ case maybeTexture of+ Just (SurfaceTexture lastTexture) -> destroyTexture lastTexture+ Nothing -> return ()+ A.insert eId (SurfaceTexture sdlTexture)+ A.insert+ eId+ ( Size $+ transformScale transform+ * fromMaybe+ (fmap fromIntegral $ V2 (textureWidth textureDesc) (textureHeight textureDesc))+ ((fmap (\(Rectangle _ s) -> fmap fromIntegral s) $ surfaceBounds surface))+ )+ )+ cameraDraws'+ )+ cameraDraws ) windowDraws in proc () -> do+ cameras <- S.all $ Q.entity &&& Q.fetch -< () windows <- S.all (Q.entity &&& Q.fetch @_ @WindowRenderer) -< () draws <- S.all ( proc () -> do- d <- Q.fetch @_ @Draw -< ()+ eId <- Q.entity -< ()+ d <- Q.fetch @_ @Surface -< () transform <- Q.fetch @_ @Transform -< ()- target <- Q.fetch @_ @WindowTarget -< ()- returnA -< (d, transform, target)+ target <- Q.fetch @_ @SurfaceTarget -< ()+ maybeTexture <- Q.fetchMaybe @_ @SurfaceTexture -< ()+ returnA -< (eId, d, transform, target, maybeTexture) ) -< ()- let windowDraws =- foldr- ( \(eId, window) acc ->- let draws' =- foldr- ( \(d, transform, target) acc' ->- if unWindowTarget target == eId- then (d, transform) : acc'- else acc'+ let cameraDraws =+ map+ ( \(eId, cameraTarget) ->+ ( cameraTarget,+ mapMaybe+ ( \(surfaceEid, d, transform, target, maybeTexture) ->+ if drawTargetCamera target == eId+ then Just (surfaceEid, d, transform, maybeTexture)+ else Nothing+ )+ draws+ )+ )+ cameras+ windowDraws =+ map+ ( \(eId, window) ->+ ( window,+ filter (\(cameraTarget, _) -> cameraTargetWindow cameraTarget == eId) cameraDraws+ )+ )+ windows+ S.queue go -< windowDraws++drawTextures :: System () ()+drawTextures =+ let go windowDraws =+ mapM_+ ( \(window, cameraDraws) -> do+ mapM_+ ( \(camera, _, cameraTransform, cameraDraws') -> do+ let renderer = windowRenderer window+ rendererDrawColor renderer $= V4 0 0 0 255+ rendererScale renderer $= fmap realToFrac (cameraScale camera)+ rendererViewport renderer+ $= Just+ ( Rectangle+ (P (fmap fromIntegral $ transformPosition cameraTransform))+ (fmap fromIntegral $ cameraViewport camera)+ )+ clear renderer+ mapM_+ ( \(surface, transform, texture) -> do+ textureDesc <- queryTexture $ unSurfaceTexture texture+ copyEx+ renderer+ (unSurfaceTexture texture)+ (fmap fromIntegral <$> surfaceBounds surface)+ ( Just+ ( Rectangle+ (fmap fromIntegral . P $ transformPosition transform)+ ( fromMaybe+ (fmap fromIntegral $ V2 (textureWidth textureDesc) (textureHeight textureDesc))+ ((fmap (\(Rectangle _ s) -> fmap fromIntegral s) $ surfaceBounds surface))+ )+ ) )- []- draws- in (window, draws') : acc+ (realToFrac $ transformRotation transform)+ Nothing+ (V2 False False)+ )+ cameraDraws'+ present renderer )- []+ cameraDraws+ )+ windowDraws+ in proc () -> do+ cameras <-+ S.all+ ( proc () -> do+ eId <- Q.entity -< ()+ camera <- Q.fetch @_ @Camera -< ()+ cameraTarget <- Q.fetch @_ @CameraTarget -< ()+ t <- Q.fetch @_ @Transform -< ()+ returnA -< (eId, camera, cameraTarget, t)+ )+ -<+ ()+ windows <- S.all (Q.entity &&& Q.fetch @_ @WindowRenderer) -< ()+ draws <-+ S.all+ ( proc () -> do+ d <- Q.fetch @_ @Surface -< ()+ transform <- Q.fetch @_ @Transform -< ()+ target <- Q.fetch @_ @SurfaceTarget -< ()+ texture <- Q.fetch @_ @SurfaceTexture -< ()+ returnA -< (d, transform, target, texture)+ )+ -<+ ()+ let cameraDraws =+ map+ ( \(eId, camera, cameraTarget, t) ->+ ( camera,+ cameraTarget,+ t,+ mapMaybe+ ( \(d, transform, target, texture) ->+ if drawTargetCamera target == eId+ then Just (d, transform, texture)+ else Nothing+ )+ draws+ )+ )+ cameras+ windowDraws =+ map+ ( \(eId, window) ->+ ( window,+ filter (\(_, cameraTarget, _, _) -> cameraTargetWindow cameraTarget == eId) cameraDraws+ )+ ) windows- S.run go -< windowDraws+ S.task go -< windowDraws --- | Window target component.--- This component can be used to specify which `Window` to draw an entity to.-newtype WindowTarget = WindowTarget {unWindowTarget :: EntityID}+-- | Surface target component.+-- This component can be used to specify which `Camera` to draw a `Surface` to.+newtype SurfaceTarget = SurfaceTarget {drawTargetCamera :: EntityID} deriving (Eq, Show) -instance Component WindowTarget+instance Component SurfaceTarget --- | Draw component.+-- | Surface component. -- This component can be used to draw to a window.-newtype Draw = Draw {runDraw :: Transform -> Renderer -> IO ()}+data Surface = Surface+ { sdlSurface :: !SDL.Surface,+ surfaceBounds :: !(Maybe (Rectangle Int))+ } -instance Component Draw+instance Component Surface --- | Add `WindowTarget` components to entities with a new `Draw` component.-addWindowTargets :: System () ()-addWindowTargets = proc () -> do- windows <- S.all (Q.entity &&& Q.fetch @_ @WindowRenderer) -< ()- newDraws <- S.filter (Q.entity &&& Q.fetch @_ @Draw) (without @WindowTarget) -< ()+-- | Add `CameraTarget` components to entities with a new `Draw` component.+addCameraTargets :: System () ()+addCameraTargets = proc () -> do+ windows <- S.all (Q.entity &&& Q.fetch @_ @Window) -< ()+ newCameras <- S.filter (Q.entity &&& Q.fetch @_ @Camera) (without @CameraTarget) -< () S.queue- ( \(newDraws, windows) -> case windows of- (windowEId, _) : _ -> mapM_ (\(eId, _) -> A.insert eId $ WindowTarget windowEId) newDraws+ ( \(newCameras, windows) -> case windows of+ (windowEId, _) : _ -> mapM_ (\(eId, _) -> A.insert eId $ CameraTarget windowEId) newCameras _ -> return () ) -<- (newDraws, windows)+ (newCameras, windows) --- | Draw a rectangle.-rect :: V2 Int -> Draw-rect size = Draw $- \transform renderer -> do- surface <- createRGBSurface (fmap fromIntegral size) RGBA8888- surfaceRenderer <- createSoftwareRenderer surface- rendererDrawColor surfaceRenderer $= V4 255 0 0 255- fillRect surfaceRenderer Nothing- texture <- SDL.createTextureFromSurface renderer surface- copyEx- renderer- texture- Nothing- (Just (Rectangle (fmap (fromIntegral @CInt . round) . P $ transformPosition transform) (fmap fromIntegral size)))- (realToFrac $ transformRotation transform)- Nothing- (V2 False False)- freeSurface surface- destroyTexture texture+-- | Add `SurfaceTarget` components to entities with a new `Surface` component.+addSurfaceTargets :: System () ()+addSurfaceTargets = proc () -> do+ cameras <- S.all (Q.entity &&& Q.fetch @_ @Camera) -< ()+ newDraws <- S.filter (Q.entity &&& Q.fetch @_ @Surface) (without @SurfaceTarget) -< ()+ S.queue+ ( \(newDraws, cameras) -> case cameras of+ (cameraEId, _) : _ -> mapM_ (\(eId, _) -> A.insert eId $ SurfaceTarget cameraEId) newDraws+ _ -> return ()+ )+ -<+ (newDraws, cameras) --- | Texture asset.-newtype Texture = Texture {textureSurface :: Surface}+newtype Time = Time {elapsedMS :: Word32}+ deriving (Eq, Ord, Num, Show) -instance Asset Texture where- loadAsset path = Texture <$> IMG.load path+instance Component Time --- | Image component.-data Image = Image- { imageTexture :: Handle Texture,- imageSize :: V2 Int+updateTime :: System () ()+updateTime = proc () -> do+ t <- S.task (const SDL.ticks) -< ()+ S.mapSingle Q.set -< Time t+ returnA -< ()++-- | Keyboard input component.+data KeyboardInput = KeyboardInput+ { -- | Keyboard events that occured this frame.+ keyboardEvents :: !(Map Keycode InputMotion),+ -- | Keys that are currently pressed.+ keyboardPressed :: !(Set Keycode) } deriving (Show) -instance Component Image+instance Component KeyboardInput --- | Draw images to their target windows.-drawImages :: System () ()-drawImages = proc () -> do- imgs <- S.filter (Q.entity &&& Q.fetch @_ @Image) (without @Draw) -< ()- assets <- S.single (Q.fetch @_ @(AssetServer Texture)) -< ()- let newAssets =- mapMaybe (\(eId, img) -> (,img,eId) <$> lookupAsset (imageTexture img) assets) imgs- S.queue (mapM_ go) -< newAssets- where- go (texture, img, eId) = do- A.insert- eId- ( Draw $- \transform renderer -> do- sdlTexture <- SDL.createTextureFromSurface renderer (textureSurface texture)- copyEx- renderer- sdlTexture- Nothing- ( Just- ( Rectangle- (fmap (fromIntegral @CInt . round) . P $ transformPosition transform)- (fmap fromIntegral $ imageSize img)- )- )- (realToFrac $ transformRotation transform)- Nothing- (V2 False False)- destroyTexture sdlTexture- )+-- | @True@ if this key is currently pressed.+isKeyPressed :: Keycode -> KeyboardInput -> Bool+isKeyPressed key kb = Set.member key $ keyboardPressed kb --- | Keyboard state.-newtype Keyboard = Keyboard {unKeyboard :: Map Keycode InputMotion}- deriving (Show, Semigroup, Monoid)+-- | Check for a key event that occured this frame.+keyEvent :: Keycode -> KeyboardInput -> Maybe InputMotion+keyEvent key kb = Map.lookup key $ keyboardEvents kb -instance Component Keyboard+-- | @True@ if this key was pressed this frame.+wasKeyPressed :: Keycode -> KeyboardInput -> Bool+wasKeyPressed key kb = case keyEvent key kb of+ Just Pressed -> True+ _ -> False +-- | @True@ if this key was released this frame.+wasKeyReleased :: Keycode -> KeyboardInput -> Bool+wasKeyReleased key kb = case keyEvent key kb of+ Just Released -> True+ _ -> False++-- | Mouse input component.+data MouseInput = MouseInput+ { -- | Mouse position in screen-space.+ mousePosition :: !(Point V2 Int),+ -- | Mouse offset since last frame.+ mouseOffset :: !(V2 Int),+ -- | Mouse button states.+ mouseButtons :: !(Map MouseButton InputMotion)+ }+ deriving (Show)++instance Component MouseInput+ -- | Keyboard input system.-keyboardInput :: System () ()-keyboardInput = proc () -> do- events <- S.run . const $ SDL.pollEvents -< ()- S.mapSingle- ( proc events -> do- let go event keyAcc = case eventPayload event of- KeyboardEvent keyboardEvent ->- Keyboard $+handleInput :: System () ()+handleInput = proc () -> do+ events <- S.task . const $ SDL.pollEvents -< ()+ kb <- S.single Q.fetch -< ()+ mouseInput <- S.single Q.fetch -< ()+ let go (kbAcc, mouseAcc) event = case eventPayload event of+ KeyboardEvent keyboardEvent ->+ ( KeyboardInput+ ( Map.insert+ (keysymKeycode $ keyboardEventKeysym keyboardEvent)+ (keyboardEventKeyMotion keyboardEvent)+ (keyboardEvents kbAcc)+ )+ ( case keyboardEventKeyMotion keyboardEvent of+ Pressed ->+ Set.insert+ (keysymKeycode $ keyboardEventKeysym keyboardEvent)+ (keyboardPressed kbAcc)+ Released ->+ Set.delete+ (keysymKeycode $ keyboardEventKeysym keyboardEvent)+ (keyboardPressed kbAcc)+ ),+ mouseAcc+ )+ MouseMotionEvent mouseMotionEvent ->+ ( kbAcc,+ MouseInput+ { mousePosition = (fmap fromIntegral $ mouseMotionEventPos mouseMotionEvent),+ mouseOffset = (fmap fromIntegral $ mouseMotionEventRelMotion mouseMotionEvent),+ mouseButtons = (mouseButtons mouseAcc)+ }+ )+ MouseButtonEvent mouseButtonEvent ->+ ( kbAcc,+ MouseInput+ { mousePosition = (fmap fromIntegral $ mouseButtonEventPos mouseButtonEvent),+ mouseOffset = V2 0 0,+ mouseButtons = Map.insert- (keysymKeycode $ keyboardEventKeysym keyboardEvent)- (keyboardEventKeyMotion keyboardEvent)- (unKeyboard keyAcc)- _ -> keyAcc- keyboard <- Q.fetch -< ()- Q.set -< foldr go keyboard events- )- -<- events+ (mouseButtonEventButton mouseButtonEvent)+ (mouseButtonEventMotion mouseButtonEvent)+ (mouseButtons mouseAcc)+ }+ )+ _ -> (kbAcc, mouseAcc)+ (kb', mouseInput') = foldl' go (kb, mouseInput) events+ S.mapSingle Q.set -< kb'+ S.mapSingle Q.set -< mouseInput' returnA -< ()++clearKeyboardQuery :: (Monad m) => Query m () KeyboardInput+clearKeyboardQuery = proc () -> do+ kb <- Q.fetch -< ()+ Q.set -< kb {keyboardEvents = mempty}++clearKeyboard :: System () ()+clearKeyboard = const () <$> S.mapSingle clearKeyboardQuery++clearMouseInputQuery :: (Monad m) => Query m () MouseInput+clearMouseInputQuery = proc () -> do+ mouseInput <- Q.fetch -< ()+ Q.set -< mouseInput {mouseButtons = mempty, mouseOffset = V2 0 0}++clearMouseInput :: System () ()+clearMouseInput = const () <$> S.mapSingle clearMouseInputQuery